diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/elabd.lst gcc-3.4.0/gcc/testsuite/ada/acats/elabd.lst *** gcc-3.3.3/gcc/testsuite/ada/acats/elabd.lst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/elabd.lst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + c731001 + c854002 + ca11018 + ca11019 + ca5006a diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/norun.lst gcc-3.4.0/gcc/testsuite/ada/acats/norun.lst *** gcc-3.3.3/gcc/testsuite/ada/acats/norun.lst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/norun.lst 2003-10-29 17:04:38.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + cdd2a03 + templat + # Tests must be sorted in alphabetical order + # cdd2a03: new Ada ruling not supported yet. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/overflow.lst gcc-3.4.0/gcc/testsuite/ada/acats/overflow.lst *** gcc-3.3.3/gcc/testsuite/ada/acats/overflow.lst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/overflow.lst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + c45632a + c45632b + c45632c + c45504a + c45504b + c45504c + c45613a + c45613b + c45613c + c45304a + c45304b + c45304c + c46014a + c460008 + c460011 + c4a012b diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/run_acats gcc-3.4.0/gcc/testsuite/ada/acats/run_acats *** gcc-3.3.3/gcc/testsuite/ada/acats/run_acats 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/run_acats 2004-01-08 15:19:36.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + #!/bin/sh + + if [ "$testdir" = "" ]; then + echo You must use make check or make check-ada + exit 1 + fi + + # Set up environment to use the Ada compiler from the object tree + + host_gnatchop=`type gnatchop | awk '{print $3}'` + host_gnatmake=`type gnatmake | awk '{print $3}'` + ROOT=`${PWDCMD-pwd}` + BASE=`cd $ROOT/../../..; ${PWDCMD-pwd}` + + PATH=$BASE:$ROOT:$PATH + ADA_INCLUDE_PATH=$BASE/ada/rts + ADA_OBJECTS_PATH=$ADA_INCLUDE_PATH + + if [ ! -d $ADA_INCLUDE_PATH ]; then + echo gnatlib missing, exiting. + exit 1 + fi + + if [ ! -f $BASE/gnatchop ]; then + echo gnattools missing, exiting. + exit 1 + fi + + if [ ! -f $BASE/gnatmake ]; then + echo gnattools missing, exiting. + exit 1 + fi + + GCC_DRIVER="$BASE/xgcc" + GCC="$BASE/xgcc -B$BASE/" + export PATH ADA_INCLUDE_PATH ADA_OBJECTS_PATH GCC_DRIVER GCC + + echo '#!/bin/sh' > host_gnatchop + echo PATH=`dirname $host_gnatchop`:'$PATH' >> host_gnatchop + echo unset ADA_INCLUDE_PATH ADA_OBJECTS_PATH GCC_EXEC_PREFIX >> host_gnatchop + echo export PATH >> host_gnatchop + echo exec $host_gnatchop '"$@"' >> host_gnatchop + + chmod +x host_gnatchop + + echo '#!/bin/sh' > host_gnatmake + echo PATH=`dirname $host_gnatmake`:'$PATH' >> host_gnatmake + echo unset ADA_INCLUDE_PATH ADA_OBJECTS_PATH GCC_EXEC_PREFIX >> host_gnatmake + echo export PATH >> host_gnatmake + echo exec $host_gnatmake '"$@"' >> host_gnatmake + + chmod +x host_gnatmake + + exec $testdir/run_all.sh "$@" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/run_all.sh gcc-3.4.0/gcc/testsuite/ada/acats/run_all.sh *** gcc-3.3.3/gcc/testsuite/ada/acats/run_all.sh 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/run_all.sh 2004-01-13 11:48:46.000000000 +0000 *************** *** 0 **** --- 1,269 ---- + #!/bin/sh + # Run ACATS with the GNU Ada compiler + + # The following functions are to be customized if you run in cross + # environment or want to change compilation flags. Note that for + # tests requiring checks not turned on by default, this script + # automatically adds the needed flags to pass (ie: -gnato or -gnatE). + + # gccflags="-O3 -fomit-frame-pointer -funroll-all-loops -finline-functions" + # gnatflags="-gnatN" + + gccflags="" + gnatflags="-gnatws" + + target_run () { + $* + } + + # End of customization section. + + display_noeol () { + printf "$@" + printf "$@" >> $dir/acats.sum + printf "$@" >> $dir/acats.log + } + + display () { + echo "$@" + echo "$@" >> $dir/acats.sum + echo "$@" >> $dir/acats.log + } + + log () { + echo "$@" >> $dir/acats.sum + echo "$@" >> $dir/acats.log + } + + dir=`${PWDCMD-pwd}` + + if [ "$testdir" = "" ]; then + echo You must use make check or make check-ada + exit 1 + fi + + if [ "$dir" = "$testdir" ]; then + echo "error: srcdir must be different than objdir, exiting." + exit 1 + fi + + target_gnatchop () { + gnatchop --GCC="$GCC_DRIVER" $* + } + + target_gnatmake () { + echo gnatmake --GCC=\"$GCC\" $gnatflags $gccflags $* -largs $EXTERNAL_OBJECTS --GCC=\"$GCC\" + gnatmake --GCC="$GCC" $gnatflags $gccflags $* -largs $EXTERNAL_OBJECTS --GCC="$GCC" + } + + target_gcc () { + $GCC $gccflags $* + } + + clean_dir () { + rm -f "$binmain" *.o *.ali > /dev/null 2>&1 + } + + EXTERNAL_OBJECTS="" + # Global variable to communicate external objects to link with. + + rm -f $dir/acats.sum $dir/acats.log + + display " === acats configuration ===" + + display target gcc is $GCC + display `$GCC -v 2>&1` + display host=`gcc -dumpmachine` + display target=`$GCC -dumpmachine` + display `type gnatmake` + gnatls -v >> $dir/acats.log + display "" + + display " === acats support ===" + display_noeol "Generating support files..." + + rm -rf $dir/support + mkdir -p $dir/support + cd $dir/support + + cp $testdir/support/*.ada $testdir/support/*.a $testdir/support/*.tst $dir/support + + sed -e "s,ACATS4GNATDIR,$dir,g" \ + < $testdir/support/impdef.a > $dir/support/impdef.a + sed -e "s,ACATS4GNATDIR,$dir,g" \ + < $testdir/support/macro.dfs > $dir/support/MACRO.DFS + sed -e "s,ACATS4GNATDIR,$dir,g" \ + < $testdir/support/tsttests.dat > $dir/support/TSTTESTS.DAT + + cp $testdir/tests/cd/*.c $dir/support + cp $testdir/tests/cxb/*.c $dir/support + + rm -rf $dir/run + mv $dir/tests $dir/tests.$$ 2> /dev/null + rm -rf $dir/tests.$$ & + mkdir -p $dir/run + + cp -pr $testdir/tests $dir/ + + for i in $dir/support/*.ada $dir/support/*.a; do + host_gnatchop $i >> $dir/acats.log 2>&1 + done + + # These tools are used to preprocess some ACATS sources + # they need to be compiled native on the host. + + host_gnatmake -q -gnatws macrosub.adb + if [ $? -ne 0 ]; then + display "**** Failed to compile macrosub" + exit 1 + fi + ./macrosub > macrosub.out 2>&1 + + gcc -c cd300051.c + host_gnatmake -q -gnatws widechr.adb + if [ $? -ne 0 ]; then + display "**** Failed to compile widechr" + exit 1 + fi + ./widechr > widechr.out 2>&1 + + rm -f $dir/support/macrosub + rm -f $dir/support/widechr + rm -f $dir/support/*.ali + rm -f $dir/support/*.o + + display " done." + + # From here, all compilations will be made by the target compiler + + display_noeol "Compiling support files..." + + target_gcc -c *.c + if [ $? -ne 0 ]; then + display "**** Failed to compile C code" + exit 1 + fi + + target_gnatchop *.adt >> $dir/acats.log 2>&1 + + target_gnatmake -c -gnato -gnatE *.ads >> $dir/acats.log 2>&1 + target_gnatmake -c -gnato -gnatE *.adb >> $dir/acats.log 2>&1 + + display " done." + display "" + display " === acats tests ===" + + if [ $# -eq 0 ]; then + chapters=`cd $dir/tests; echo [a-z]*` + else + chapters=$* + fi + + glob_countn=0 + glob_countok=0 + glob_countu=0 + + for chapter in $chapters; do + display Running chapter $chapter ... + + if [ ! -d $dir/tests/$chapter ]; then + display "*** CHAPTER $chapter does not exist, skipping." + display "" + continue + fi + + cd $dir/tests/$chapter + ls *.a *.ada *.adt *.am *.dep 2> /dev/null | sed -e 's/\(.*\)\..*/\1/g' | \ + cut -c1-7 | sort | uniq | comm -23 - $testdir/norun.lst \ + > $dir/tests/$chapter/${chapter}.lst + countn=`wc -l < $dir/tests/$chapter/${chapter}.lst` + glob_countn=`expr $glob_countn + $countn` + counti=0 + for i in `cat $dir/tests/$chapter/${chapter}.lst`; do + counti=`expr $counti + 1` + extraflags="" + grep $i $testdir/overflow.lst > /dev/null 2>&1 + if [ $? -eq 0 ]; then + extraflags="$extraflags -gnato" + fi + grep $i $testdir/elabd.lst > /dev/null 2>&1 + if [ $? -eq 0 ]; then + extraflags="$extraflags -gnatE" + fi + test=$dir/tests/$chapter/$i + mkdir $test && cd $test >> $dir/acats.log 2>&1 + + if [ $? -ne 0 ]; then + display "FAIL: $i" + failed="${failed}${i} " + clean_dir + continue + fi + + target_gnatchop -c -w `ls ${test}*.a ${test}*.ada ${test}*.adt ${test}*.am ${test}*.dep 2> /dev/null` >> $dir/acats.log 2>&1 + ls ${i}?.adb > ${i}.lst 2> /dev/null + ls ${i}*m.adb >> ${i}.lst 2> /dev/null + ls ${i}.adb >> ${i}.lst 2> /dev/null + main=`tail -1 ${i}.lst` + binmain=`echo $main | sed -e 's/\(.*\)\..*/\1/g'` + echo "BUILD $main" >> $dir/acats.log + EXTERNAL_OBJECTS="" + case $i in + cxb30*) EXTERNAL_OBJECTS="$dir/support/cxb30040.o $dir/support/cxb30060.o $dir/support/cxb30130.o $dir/support/cxb30131.o";; + ca1020e) rm -f ca1020e_func1.adb ca1020e_func2.adb ca1020e_proc1.adb ca1020e_proc2.adb > /dev/null 2>&1;; + ca14028) rm -f ca14028_func2.ads ca14028_func3.ads ca14028_proc1.ads ca14028_proc3.ads > /dev/null 2>&1;; + cxh1001) extraflags="-a -f"; echo "pragma Normalize_Scalars;" > gnat.adc + esac + if [ "$main" = "" ]; then + display "FAIL: $i" + failed="${failed}${i} " + clean_dir + continue + fi + + target_gnatmake $extraflags -I$dir/support $main >> $dir/acats.log 2>&1 + if [ $? -ne 0 ]; then + display "FAIL: $i" + failed="${failed}${i} " + clean_dir + continue + fi + + echo "RUN $binmain" >> $dir/acats.log + cd $dir/run + target_run $dir/tests/$chapter/$i/$binmain > $dir/tests/$chapter/$i/${i}.log 2>&1 + cd $dir/tests/$chapter/$i + cat ${i}.log >> $dir/acats.log + egrep -e '(==== |\+\+\+\+ |\!\!\!\! )' ${i}.log > /dev/null 2>&1 + if [ $? -ne 0 ]; then + grep 'Tasking not implemented' ${i}.log > /dev/null 2>&1 + + if [ $? -ne 0 ]; then + display "FAIL: $i" + failed="${failed}${i} " + else + log "UNSUPPORTED: $i" + glob_countn=`expr $glob_countn - 1` + glob_countu=`expr $glob_countu + 1` + fi + else + log "PASS: $i" + glob_countok=`expr $glob_countok + 1` + fi + clean_dir + done + done + + display " === acats Summary ===" + display "# of expected passes $glob_countok" + display "# of unexpected failures `expr $glob_countn - $glob_countok`" + + if [ $glob_countu -ne 0 ]; then + display "# of unsupported tests $glob_countu" + fi + + if [ $glob_countok -ne $glob_countn ]; then + display "*** FAILURES: $failed" + fi + + exit 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/acats25.lst gcc-3.4.0/gcc/testsuite/ada/acats/support/acats25.lst *** gcc-3.3.3/gcc/testsuite/ada/acats/support/acats25.lst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/acats25.lst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,4308 ---- + a22006b.ada + a22006c.ada + a22006d.ada + a26007a.tst + a27003a.ada + a29003a.ada + a2a031a.ada + a33003a.ada + a34017c.ada + a35101b.ada + a35402a.ada + a35801f.ada + a35902c.ada + a38106d.ada + a38106e.ada + a49027a.ada + a49027b.ada + a49027c.ada + a54b01a.ada + a54b02a.ada + a55b12a.ada + a55b13a.ada + a55b14a.ada + a71004a.ada + a73001i.ada + a73001j.ada + a74105b.ada + a74106a.ada + a74106b.ada + a74106c.ada + a74205e.ada + a74205f.ada + a83009a.ada + a83009b.ada + a83a02a.ada + a83a02b.ada + a83a06a.ada + a83a08a.ada + a83c01c.ada + a83c01h.ada + a83c01i.ada + a85007d.ada + a85013b.ada + a87b59a.ada + a95001c.ada + a95074d.ada + a97106a.ada + a99006a.ada + aa2010a.ada + aa2012a.ada + acats25.lst + ac1015b.ada + ac3106a.ada + ac3206a.ada + ac3207a.ada + ad7001b.ada + ad7001c0.ada + ad7001c1.ada + ad7001d0.ada + ad7001d1.ada + ad7006a.ada + ad7101a.ada + ad7101c.ada + ad7102a.ada + ad7103a.ada + ad7103c.ada + ad7104a.ada + ad7201a.ada + ad7203b.ada + ad7205b.ada + ad8011a.tst + ada101a.ada + ae2113a.ada + ae2113b.ada + ae3002g.ada + ae3101a.ada + ae3702a.ada + ae3709a.ada + b22001a.tst + b22001b.tst + b22001c.tst + b22001d.tst + b22001e.tst + b22001f.tst + b22001g.tst + b22001h.ada + b22001i.tst + b22001j.tst + b22001k.tst + b22001l.tst + b22001m.tst + b22001n.tst + b23002a.ada + b23004a.ada + b23004b.ada + b24001a.ada + b24001b.ada + b24001c.ada + b24005a.ada + b24005b.ada + b24007a.ada + b24009a.ada + b24009b.ada + b24104a.ada + b24204a.ada + b24204b.ada + b24204c.ada + b24204d.ada + b24204e.ada + b24204f.ada + b24205a.ada + b24206a.ada + b24206b.ada + b24211b.ada + b25002a.ada + b25002b.ada + b26001a.ada + b26002a.ada + b26005a.ada + b28001a.ada + b28001b.ada + b28001c.ada + b28001d.ada + b28001e.ada + b28001f.ada + b28001g.ada + b28001h.ada + b28001i.ada + b28001j.ada + b28001k.ada + b28001l.ada + b28001m.ada + b28001n.ada + b28001o.ada + b28001p.ada + b28001q.ada + b28001r.ada + b28001s.ada + b28001t.ada + b28001u.ada + b28001v.ada + b28001w.ada + b29001a.ada + b2a003a.ada + b2a003b.ada + b2a003c.ada + b2a003d.ada + b2a003e.ada + b2a003f.ada + b2a005a.ada + b2a005b.ada + b2a007a.ada + b2a010a.ada + b2a021a.ada + b32101a.ada + b32103a.ada + b32104a.ada + b32106a.ada + b32201a.ada + b32202a.ada + b32202b.ada + b32202c.ada + b330001.a + b33001a.ada + b33101a.ada + b33102a.ada + b33102b.ada + b33102c.ada + b33102d.ada + b33102e.ada + b33201a.ada + b33201b.ada + b33201c.ada + b33201d.ada + b33201e.ada + b33204a.ada + b33205a.ada + b33302a.ada + b34001b.ada + b34001e.ada + b34002b.ada + b34003b.ada + b34004b.ada + b34005b.ada + b34005e.ada + b34005h.ada + b34005k.ada + b34005n.ada + b34005q.ada + b34005t.ada + b34006b.ada + b34006e.ada + b34006h.ada + b34006k.ada + b34007b.ada + b34007e.ada + b34007h.ada + b34007k.ada + b34007n.ada + b34007q.ada + b34007t.ada + b34008b.ada + b34009b.ada + b34009e.ada + b34009h.ada + b34009k.ada + b34011a.ada + b34014b.ada + b34014d.ada + b34014f.ada + b34014i.ada + b34014m.ada + b34014o.ada + b34014q.ada + b34014s.ada + b34014v.ada + b34014z.ada + b35004a.ada + b35101a.ada + b35103a.ada + b35103b.ada + b35302a.ada + b354001.a + b35401a.ada + b35401b.ada + b35403a.ada + b35501a.ada + b35501b.ada + b35506a.ada + b35506b.ada + b35506c.ada + b35506d.ada + b35701a.ada + b35709a.ada + b35901a.ada + b35901c.ada + b35901d.ada + b35a01a.ada + b35a08a.ada + b360001.a + b36001a.ada + b36002a.ada + b36101a.ada + b36102a.ada + b36103a.ada + b36105c.dep + b36171a.ada + b36171b.ada + b36171c.ada + b36171d.ada + b36171e.ada + b36171f.ada + b36171g.ada + b36171h.ada + b36171i.ada + b36201a.ada + b36307a.ada + b370001.a + b370002.a + b37004a.ada + b37004b.ada + b37004c.ada + b37004d.ada + b37004e.ada + b37004f.ada + b37004g.ada + b3710010.a + b3710011.a + b3710012.a + b3710013.a + b3710014.am + b37101a.ada + b37102a.ada + b37104a.ada + b37106a.ada + b37201a.ada + b37201b.ada + b37203a.ada + b37301i.ada + b37301j.ada + b37302a.ada + b37303a.ada + b37309b.ada + b37310b.ada + b37311a.ada + b37401a.ada + b37409b.ada + b380001.a + b38003a.ada + b38003b.ada + b38003c.ada + b38003d.ada + b38008a.ada + b38008b.ada + b38009a.ada + b38009d.ada + b38101a.ada + b38101b.ada + b38101c.ada + b38103a.ada + b38103b.ada + b38103c0.ada + b38103c1.ada + b38103c2.ada + b38103c3.ada + b38103d.ada + b38103e0.ada + b38103e1.ada + b38105a.ada + b38105b.ada + b38203a.ada + b390001.a + b391001.a + b391002.a + b391003.a + b391004.a + b392001.a + b392002.a + b392003.a + b392004.a + b392005.a + b392006.a + b392007.a + b392008.a + b392009.a + b392010.a + b392011.a + b393001.a + b393002.a + b393003.a + b393004.a + b393005.a + b393006.a + b393007.a + b3a0001.a + b3a0002.a + b3a0003.a + b3a0004.a + b3a2002.a + b3a2003.a + b3a2004.a + b3a2005.a + b3a2006.a + b3a2007.a + b3a2008.a + b3a2009.a + b3a2010.a + b3a2011.a + b3a2012.a + b3a2013.a + b3a2014.a + b3a2015.a + b3a2016.a + b41101a.ada + b41101c.ada + b41201a.ada + b41201c.ada + b41202c.ada + b41202d.ada + b41324b.ada + b41325b.ada + b41327b.ada + b420001.a + b430001.a + b43001m.ada + b43002d.ada + b43002e.ada + b43002f.ada + b43002g.ada + b43002h.ada + b43002i.ada + b43002j.ada + b43002k.ada + b43005a.ada + b43005b.ada + b43005f.ada + b43101a.ada + b43102a.ada + b43102b.ada + b43105c.ada + b43201a.ada + b43201c.ada + b43201d.ada + b43202a.ada + b43202c.ada + b43209b.ada + b43221a.ada + b43221b.ada + b43223a.ada + b44001a.ada + b44001b.ada + b44002b.ada + b44002c.ada + b44004a.ada + b44004b.ada + b44004c.ada + b44004d.ada + b44004e.ada + b45102a.ada + b45116a.ada + b45121a.ada + b45204a.ada + b45205a.ada + b45206c.ada + b45207a.ada + b45207b.ada + b45207c.ada + b45207d.ada + b45207g.ada + b45207h.ada + b45207i.ada + b45207j.ada + b45207m.ada + b45207n.ada + b45207o.ada + b45207p.ada + b45207s.ada + b45207t.ada + b45207u.ada + b45207v.ada + b45208a.ada + b45208b.ada + b45208c.ada + b45208g.ada + b45208h.ada + b45208i.ada + b45208m.ada + b45208n.ada + b45208s.ada + b45208t.ada + b45209a.ada + b45209b.ada + b45209c.ada + b45209d.ada + b45209e.ada + b45209f.ada + b45209g.ada + b45209h.ada + b45209i.ada + b45209j.ada + b45209k.ada + b45221a.ada + b45261a.ada + b45261b.ada + b45261c.ada + b45261d.ada + b45301a.ada + b45301b.ada + b45301c.ada + b45302a.ada + b45341a.ada + b455002.a + b45501a.ada + b45501b.ada + b45501c.ada + b45522a.ada + b45537a.ada + b45601a.ada + b45625a.ada + b45661a.ada + b460001.a + b460002.a + b460004.a + b460005.a + b46002a.ada + b46003a.ada + b46004a.ada + b46004b.ada + b46004c.ada + b46004d.ada + b46004e.ada + b46005a.ada + b47001a.ada + b480001.a + b48001a.ada + b48001b.ada + b48002a.ada + b48002b.ada + b48002c.ada + b48002d.ada + b48002e.ada + b48002g.ada + b48003a.ada + b48003b.ada + b48003c.ada + b48003d.ada + b48003e.ada + b490001.a + b490002.a + b49002a.ada + b49004a.ada + b49005a.ada + b49007a.ada + b49007b.ada + b49008a.ada + b49008c.ada + b49009b.ada + b49009c.ada + b49010a.ada + b49011a.ada + b4a010c.ada + b4a016a.ada + b51001a.ada + b51004b.ada + b51004c.ada + b52002a.ada + b52002b.ada + b52002c.ada + b52002d.ada + b52002e.ada + b52002f.ada + b52002g.ada + b52004a.ada + b52004b.ada + b52004c.ada + b52004d.dep + b52004e.dep + b53001a.ada + b53001b.ada + b53002a.ada + b53002b.ada + b53009a.ada + b53009b.ada + b53009c.ada + b54a01b.ada + b54a01f.ada + b54a01g.ada + b54a01l.ada + b54a05a.ada + b54a05b.ada + b54a10a.ada + b54a12a.ada + b54a20a.ada + b54a21a.ada + b54a25a.ada + b54a60a.ada + b54a60b.ada + b54b01b.tst + b54b01c.ada + b54b02b.ada + b54b02c.ada + b54b02d.ada + b54b04a.ada + b54b04b.ada + b54b05a.ada + b54b06a.ada + b55a01a.ada + b55a01d.ada + b55a01e.ada + b55a01j.ada + b55a01k.ada + b55a01l.ada + b55a01n.ada + b55a01o.ada + b55a01t.ada + b55a01u.ada + b55a01v.ada + b55b01a.ada + b55b01b.ada + b55b09b.ada + b55b09c.dep + b55b09d.dep + b55b12b.ada + b55b12c.ada + b55b17a.ada + b55b17b.ada + b55b17c.ada + b55b18a.ada + b56001a.ada + b56001d.ada + b56001e.ada + b56001f.ada + b56001g.ada + b56001h.ada + b57001a.ada + b57001b.ada + b57001c.ada + b57001d.ada + b58001a.ada + b58002a.ada + b58002b.ada + b58002c.ada + b58003a.ada + b58003b.ada + b59001a.ada + b59001c.ada + b59001d.ada + b59001e.ada + b59001f.ada + b59001g.ada + b59001h.ada + b59001i.ada + b610001.a + b61001f.ada + b61005a.ada + b61006a.ada + b61011a.ada + b62001a.ada + b62001b.ada + b62001c.ada + b62001d.ada + b63001a.ada + b63001b.ada + b63005a.ada + b63005b.ada + b63006a.ada + b63009a.ada + b63009b.ada + b63009c0.ada + b63009c1.ada + b63009c2.ada + b63009c3.ada + b63103a.ada + b64002a.ada + b64002c.ada + b64003a.ada + b64004a.ada + b64004b.ada + b64004c.ada + b64004d.ada + b64004e.ada + b64004f.ada + b641001.a + b64101a.ada + b64201a.ada + b65001a.ada + b65002a.ada + b65002b.ada + b660001.a + b660002.a + b66001a.ada + b66001b.ada + b66001c.ada + b66001d.ada + b67001a.ada + b67001b.ada + b67001c.ada + b67001d.ada + b67001h.ada + b67001i.ada + b67001j.ada + b67001k.ada + b67004a.ada + b71001a.ada + b71001b.ada + b71001c.ada + b71001d.ada + b71001f.ada + b71001g.ada + b71001h.ada + b71001i.ada + b71001j.ada + b71001l.ada + b71001m.ada + b71001n.ada + b71001o.ada + b71001p.ada + b71001r.ada + b71001t.ada + b71001u.ada + b71001v.ada + b7200010.a + b7200011.a + b7200012.a + b7200013.a + b7200014.a + b7200015.a + b7200016.a + b730001.a + b730002.a + b730003.a + b730004.a + b730005.a + b7300060.a + b7300061.a + b7300062.a + b7300063.am + b73001a.ada + b73001b.ada + b73001c.ada + b73001d.ada + b73001e.ada + b73001f.ada + b73001g.ada + b73001h.ada + b73004a.ada + b73004b0.ada + b73004b1.ada + b73004b2.ada + b7310010.a + b7310011.a + b7310012.a + b7310013.a + b7310014.a + b7310015.a + b7310016.am + b731a01.a + b731a02.a + b740001.a + b74001a.ada + b74001b.ada + b74101a.ada + b74101b.ada + b74103a.ada + b74103d.ada + b74103e.ada + b74103g.ada + b74103i.ada + b74104a.ada + b74105a.ada + b74105c.ada + b74201a.ada + b74202a.ada + b74202b.ada + b74202c.ada + b74202d.ada + b74203b.ada + b74203c.ada + b74203d.ada + b74203e.ada + b74205a.ada + b74207a.ada + b74304a.ada + b74304b.ada + b74304c.ada + b74404a.ada + b74404b.ada + b74409a.ada + b810001.a + b830001.a + b8300020.a + b8300021.a + b8300022.a + b8300023.a + b8300024.a + b8300025.am + b83001a.ada + b83003a.ada + b83003b0.ada + b83003b1.ada + b83003b2.ada + b83003b3.ada + b83003b4.ada + b83003c.ada + b83004a.ada + b83004b0.ada + b83004b1.ada + b83004b2.ada + b83004b3.ada + b83004c0.ada + b83004c1.ada + b83004c2.ada + b83004d0.ada + b83004d1.ada + b83004d2.ada + b83004d3.ada + b83006a.ada + b83006b.ada + b83008a.ada + b83008b.ada + b83011a.ada + b83023b.ada + b83024b.ada + b83024f0.ada + b83024f1.ada + b83024f2.ada + b83024f3.ada + b83026b.ada + b83027b.ada + b83027d.ada + b83028b.ada + b83029b.ada + b83030b.ada + b83030d.ada + b83031b.ada + b83031d.ada + b83031f.ada + b83032b.ada + b83033b.ada + b83041e.ada + b83a01a.ada + b83a01b.ada + b83a01c.ada + b83a05a.ada + b83a06b.ada + b83a06h.ada + b83a07a.ada + b83a07b.ada + b83a07c.ada + b83a08b.ada + b83a09a.ada + b83b01a.ada + b83b02c.ada + b83e01a.ada + b83e01b.ada + b83e01c.ada + b83e01d.ada + b83e01e0.ada + b83e01e1.ada + b83e01e2.ada + b83e01e3.ada + b83e01f0.ada + b83e01f1.ada + b83e01f2.ada + b83e01f3.ada + b83e01f4.ada + b83e01f5.ada + b83e01f6.ada + b83e11a.ada + b83f02a.ada + b83f02b.ada + b83f02c.ada + b840001.a + b84001a.ada + b84002b.ada + b84004a.ada + b84005b.ada + b84006a.ada + b84007a.ada + b84008b.ada + b85001a.ada + b85001b.ada + b85001c.ada + b85001d.ada + b85001e.ada + b85001f.ada + b85001g.ada + b85001h.ada + b85001i.ada + b85001j.ada + b85001k.ada + b85001l.ada + b85002a.ada + b85003a.ada + b85003b.ada + b85004a.ada + b85008f.ada + b85008g.ada + b85008h.ada + b85010a.ada + b85010b.ada + b85012a.ada + b85013c.ada + b85013d.ada + b85015a.ada + b8510010.a + b8510011.a + b8510012.am + b86001a0.ada + b86001a1.ada + b87b23b.ada + b87b26a.ada + b87b48c.ada + b91001b.ada + b91001c.ada + b91001d.ada + b91001e.ada + b91001f.ada + b91001g.ada + b91002a.ada + b91002b.ada + b91002c.ada + b91002d.ada + b91002e.ada + b91002f.ada + b91002g.ada + b91002h.ada + b91002i.ada + b91002j.ada + b91002k.ada + b91002l.ada + b91003a.ada + b91003b.ada + b91003c.ada + b91003d.ada + b91003e.ada + b91004a.ada + b91005a.ada + b92001a.ada + b92001b.ada + b940001.a + b940002.a + b940003.a + b940004.a + b940005.a + b940006.a + b940007.a + b95001a.ada + b95001b.ada + b95001d.ada + b95002a.ada + b95003a.ada + b95004a.ada + b95004b.ada + b95006a.ada + b95006b.ada + b95006c.ada + b95006d.ada + b95007a.ada + b95007b.ada + b95020a.ada + b95020b0.ada + b95020b1.ada + b95020b2.ada + b95030a.ada + b95031a.ada + b95032a.ada + b95061a.ada + b95061b.ada + b95061c.ada + b95061d.ada + b95061e.ada + b95061f.ada + b95061g.ada + b95062a.ada + b95063a.ada + b95064a.ada + b95068a.ada + b95070a.ada + b95080a.ada + b95080c.ada + b95081a.ada + b95082a.ada + b95082b.ada + b95082c.ada + b95082d.ada + b95082e.ada + b95082f.ada + b95083a.ada + b95094a.ada + b95094b.ada + b95094c.ada + b951001.a + b952001.a + b952002.a + b952003.a + b952004.a + b954001.a + b954003.a + b954004.a + b960001.a + b96002a.ada + b97102b.ada + b97102c.ada + b97102d.ada + b97102f.ada + b97102g.ada + b97102h.ada + b97102i.ada + b97103a.ada + b97103b.ada + b97103d.ada + b97103e.ada + b97103f.ada + b97103g.ada + b97104a.ada + b97104b.ada + b97104c.ada + b97104d.ada + b97104e.ada + b97104f.ada + b97104g.ada + b97107a.ada + b97108a.ada + b97108b.ada + b97109a.ada + b97110a.ada + b97110b.ada + b97111a.ada + b97206a.ada + b97306a.ada + b99001a.ada + b99001b.ada + b99002a.ada + b99002b.ada + b99002c.ada + b99003a.ada + b9a001a.ada + b9a001b.ada + ba1001a0.ada + ba1001a1.ada + ba1001a4.ada + ba1001ac.ada + ba1001d.ada + ba1010a0.ada + ba1010a1.ada + ba1010a2.ada + ba1010a3.ada + ba1010b0.ada + ba1010b1.ada + ba1010b2.ada + ba1010b4.ada + ba1010b5.ada + ba1010b6.ada + ba1010b7.ada + ba1010b8.ada + ba1010c0.ada + ba1010c1.ada + ba1010c2.ada + ba1010c3.ada + ba1010c4.ada + ba1010c5.ada + ba1010c6.ada + ba1010d0.ada + ba1010d1.ada + ba1010d2.ada + ba1010d3.ada + ba1010e0.ada + ba1010e1.ada + ba1010e2.ada + ba1010e3.ada + ba1010e4.ada + ba1010e5.ada + ba1010e6.ada + ba1010f0.ada + ba1010f1.ada + ba1010f3.ada + ba1010f4.ada + ba1010f5.ada + ba1010f6.ada + ba1010f7.ada + ba1010f8.ada + ba1010g0.ada + ba1010g2.ada + ba1010g3.ada + ba1010g4.ada + ba1010g5.ada + ba1010h0.ada + ba1010h2.ada + ba1010i0.ada + ba1010i1.ada + ba1010i3.ada + ba1010i4.ada + ba1010j0.ada + ba1010j1.ada + ba1010j2.ada + ba1010j4.ada + ba1010j5.ada + ba1010j6.ada + ba1010j7.ada + ba1010j8.ada + ba1010k0.ada + ba1010k1.ada + ba1010k2.ada + ba1010k3.ada + ba1010k4.ada + ba1010k5.ada + ba1010k6.ada + ba1010l0.ada + ba1010l1.ada + ba1010l2.ada + ba1010l3.ada + ba1010l4.ada + ba1010l5.ada + ba1010l6.ada + ba1010m0.ada + ba1010m1.ada + ba1010m3.ada + ba1010m4.ada + ba1010m5.ada + ba1010m6.ada + ba1010m7.ada + ba1010m8.ada + ba1010n0.ada + ba1010n2.ada + ba1010n3.ada + ba1010n4.ada + ba1010n5.ada + ba1010p0.ada + ba1010p2.ada + ba1010q0.ada + ba1010q1.ada + ba1010q3.ada + ba1010q4.ada + ba1011b0.ada + ba1011b1.ada + ba1011b2.ada + ba1011b3.ada + ba1011b4.ada + ba1011b5.ada + ba1011b6.ada + ba1011b7.ada + ba1011b8.ada + ba1011c0.ada + ba1011c1.ada + ba1011c2.ada + ba1011c3.ada + ba1011c4.ada + ba1011c5.ada + ba1011c6.ada + ba1011c7.ada + ba1011c8.ada + ba1020a0.ada + ba1020a1.ada + ba1020a2.ada + ba1020a3.ada + ba1020a4.ada + ba1020a5.ada + ba1020a6.ada + ba1020a7.ada + ba1020a8.ada + ba1020b0.ada + ba1020b1.ada + ba1020b2.ada + ba1020b3.ada + ba1020b4.ada + ba1020b5.ada + ba1020b6.ada + ba1020c0.ada + ba1020c1.ada + ba1020c2.ada + ba1020c3.ada + ba1020c4.ada + ba1020c5.ada + ba1020f0.ada + ba1020f1.ada + ba1020f2.ada + ba11001.a + ba11002.a + ba11003.a + ba11004.a + ba11005.a + ba11007.a + ba11008.a + ba11009.a + ba11010.a + ba11011.a + ba11012.a + ba1101a.ada + ba1101b0.ada + ba1101b1.ada + ba1101b2.ada + ba1101b3.ada + ba1101b4.ada + ba1101c0.ada + ba1101c1.ada + ba1101c2.ada + ba1101c3.ada + ba1101c4.ada + ba1101c5.ada + ba1101c6.ada + ba1101e0.ada + ba1101e1.ada + ba1101f.ada + ba1101g.ada + ba1109a0.ada + ba1109a1.ada + ba1109a2.ada + ba1110a0.ada + ba1110a1.ada + ba1110a2.ada + ba1110a3.ada + ba1110a4.ada + ba1110a5.ada + ba12001.a + ba12002.a + ba12003.a + ba12004.a + ba12005.a + ba12007.a + ba12008.a + ba13b01.a + ba13b02.a + ba15001.a + ba150020.a + ba150021.a + ba150022.a + ba150023.a + ba150024.a + ba150025.a + ba150026.a + ba150027.a + ba150028.a + ba150029.am + ba2001a.ada + ba2001b.ada + ba2001c.ada + ba2001d.ada + ba2001f0.ada + ba2001f1.ada + ba2001f2.ada + ba2003b0.ada + ba2003b1.ada + ba2011a0.ada + ba2011a1.ada + ba2011a2.ada + ba2011a3.ada + ba2011a4.ada + ba2011a5.ada + ba2011a6.ada + ba2011a7.ada + ba2011a8.ada + ba2011a9.ada + ba2013a.ada + ba2013b.ada + ba21001.a + ba21002.a + ba210030.a + ba210031.a + ba210032.a + ba210033.a + ba210034.a + ba210035.a + ba210040.a + ba210041.a + ba210042.a + ba210043.a + ba210044.a + ba210045.am + ba21a01.a + ba21a02.a + ba3001a0.ada + ba3001a1.ada + ba3001a2.ada + ba3001a3.ada + ba3001b0.ada + ba3001b1.ada + ba3001c0.ada + ba3001c1.ada + ba3001e0.ada + ba3001e1.ada + ba3001e2.ada + ba3001e3.ada + ba3001f0.ada + ba3001f1.ada + ba3001f2.ada + ba3001f3.ada + ba3006a0.ada + ba3006a1.ada + ba3006a2.ada + ba3006a3.ada + ba3006a4.ada + ba3006a5.ada + ba3006a6.ada + ba3006b0.ada + ba3006b1.ada + ba3006b2.ada + ba3006b3.ada + ba3006b4.ada + bb10001.a + bb20001.a + bb2001a.ada + bb2002a.ada + bb2003a.ada + bb2003b.ada + bb2003c.ada + bb3001a.ada + bb3002a.ada + bc1001a.ada + bc1002a.ada + bc1005a.ada + bc1008a.ada + bc1008b.ada + bc1008c.ada + bc1009a.ada + bc1011a.ada + bc1011b.ada + bc1011c.ada + bc1012a.ada + bc1013a.ada + bc1014a.ada + bc1014b.ada + bc1016a.ada + bc1016b.ada + bc1101a.ada + bc1102a.ada + bc1103a.ada + bc1106a.ada + bc1107a.ada + bc1109a.ada + bc1109b.ada + bc1109c.ada + bc1109d.ada + bc1110a.ada + bc1201a.ada + bc1201b.ada + bc1201c.ada + bc1201d.ada + bc1201e.ada + bc1201f.ada + bc1201g.ada + bc1201h.ada + bc1201i.ada + bc1201j.ada + bc1201k.ada + bc1201l.ada + bc1202a.ada + bc1202c.ada + bc1202e.ada + bc1202f.ada + bc1202g.ada + bc1203a.ada + bc1205a.ada + bc1206a.ada + bc1207a.ada + bc1208a.ada + bc1226a.ada + bc1230a.ada + bc1303a.ada + bc1303b.ada + bc1303c.ada + bc1303d.ada + bc1303e.ada + bc1303f.ada + bc1303g.ada + bc1306a.ada + bc2001b.ada + bc2001c.ada + bc2001d.ada + bc2001e.ada + bc2004a.ada + bc2004b.ada + bc30001.a + bc3001a.ada + bc3002a.ada + bc3002b.ada + bc3002c.ada + bc3002d.ada + bc3002e.ada + bc3005a.ada + bc3005b.ada + bc3005c.ada + bc3006a.ada + bc3009c.ada + bc3011b.ada + bc3013a.ada + bc3016g.ada + bc3018a.ada + bc3101a.ada + bc3101b.ada + bc3102a.ada + bc3102b.ada + bc3103b.ada + bc3123c.ada + bc3201a.ada + bc3201b.ada + bc3201c.ada + bc3202a.ada + bc3202b.ada + bc3202c.ada + bc3202d.ada + bc3205c.ada + bc3301a.ada + bc3301b.ada + bc3302a.ada + bc3302b.ada + bc3303a.ada + bc3304a.ada + bc3401a.ada + bc3401b.ada + bc3402a.ada + bc3402b.ada + bc3403a.ada + bc3403b.ada + bc3403c.ada + bc3404a.ada + bc3404b.ada + bc3404c.ada + bc3404d.ada + bc3404e.ada + bc3404f.ada + bc3405a.ada + bc3405b.ada + bc3405d.ada + bc3405e.ada + bc3405f.ada + bc3501a.ada + bc3501b.ada + bc3501c.ada + bc3501d.ada + bc3501e.ada + bc3501f.ada + bc3501g.ada + bc3501h.ada + bc3501i.ada + bc3501j.ada + bc3501k.ada + bc3502a.ada + bc3502b.ada + bc3502c.ada + bc3502d.ada + bc3502e.ada + bc3502f.ada + bc3502g.ada + bc3502h.ada + bc3502i.ada + bc3502j.ada + bc3502k.ada + bc3502l.ada + bc3502m.ada + bc3502n.ada + bc3502o.ada + bc3503a.ada + bc3503c.ada + bc3503d.ada + bc3503e.ada + bc3503f.ada + bc3604a.ada + bc3604b.ada + bc3607a.ada + bc40001.a + bc40002.a + bc50001.a + bc50002.a + bc50003.a + bc50004.a + bc51002.a + bc51003.a + bc51004.a + bc51005.a + bc51006.a + bc51007.a + bc51011.a + bc51012.a + bc51013.a + bc51015.a + bc51016.a + bc51017.a + bc51018.a + bc51019.a + bc51020.a + bc51b01.a + bc51b02.a + bc51c01.a + bc51c02.a + bc53001.a + bc53002.a + bc54001.a + bc54002.a + bc54003.a + bc54a01.a + bc54a02.a + bc54a03.a + bc54a04.a + bc54a05.a + bc54a06.a + bc70001.a + bc70002.a + bc70003.a + bc70004.a + bc70005.a + bc70006.a + bc70007.a + bc70008.a + bc70009.a + bc70010.a + bd1b01a.ada + bd1b02b.ada + bd1b03c.ada + bd1b05e.ada + bd1b06j.ada + bd2001b.ada + bd2a01h.ada + bd2a02a.tst + bd2a03a.ada + bd2a03b.ada + bd2a06a.ada + bd2a25a.ada + bd2a35a.ada + bd2a45a.ada + bd2a55a.ada + bd2a55b.ada + bd2a67a.ada + bd2a77a.ada + bd2a85a.ada + bd2a85b.ada + bd2b01c.ada + bd2b02a.ada + bd2b03a.ada + bd2b03b.ada + bd2b03c.ada + bd2c01d.tst + bd2c02a.tst + bd2c03a.tst + bd2d01c.ada + bd2d01d.ada + bd2d02a.ada + bd2d03a.ada + bd2d03b.ada + bd3001a.ada + bd3001b.ada + bd3001c.ada + bd3002a.ada + bd3003a.ada + bd3003b.ada + bd3012a.ada + bd3013a.ada + bd4001a.ada + bd4002a.ada + bd4003a.ada + bd4003b.ada + bd4003c.ada + bd4006a.tst + bd4007a.ada + bd4009a.ada + bd4011a.ada + bd5001a.ada + bd5005a.ada + bd5005d.ada + bd5102a.ada + bd5102b.ada + bd5103a.ada + bd5104a.ada + bd7001a.ada + bd7101h.ada + bd7201c.ada + bd7203a.ada + bd7204a.ada + bd7205a.ada + bd7301a.ada + bd7302a.ada + bd8001a.tst + bd8002a.tst + bd8003a.tst + bd8004a.tst + bd8004b.tst + bd8004c.tst + bdb0a01.a + bdd2001.a + bde0001.a + bde0002.a + bde0003.a + bde0004.a + bde0005.a + bde0006.a + bde0007.a + bde0008.a + be2101e.ada + be2101j.ada + be2114a.ada + be2116a.ada + be2208a.ada + be3002a.ada + be3002e.ada + be3205a.ada + be3301c.ada + be3606c.ada + be3703a.ada + be3802a.ada + be3803a.ada + be3902a.ada + be3903a.ada + bxa8001.a + bxac001.a + bxac002.a + bxac003.a + bxac004.a + bxac005.a + bxc3001.a + bxc3002.a + bxc5001.a + bxc6001.a + bxc6002.a + bxc6003.a + bxc6a01.a + bxc6a02.a + bxc6a03.a + bxc6a04.a + bxd1001.a + bxd1002.a + bxe2007.a + bxe2008.a + bxe2009.a + bxe2010.a + bxe2011.a + bxe2012.a + bxe2013.a + bxe2a01.a + bxe2a02.a + bxe2a03.a + bxe2a04.a + bxe2a05.a + bxe2a06.a + bxe4001.a + bxf1001.a + bxh4001.a + bxh4002.a + bxh4003.a + bxh4004.a + bxh4005.a + bxh4006.a + bxh4007.a + bxh4008.a + bxh4009.a + bxh4010.a + bxh4011.a + bxh4012.a + bxh4013.a + c23001a.ada + c23003a.tst + c23003b.tst + c23003g.tst + c23003i.tst + c23006a.ada + c23006b.ada + c23006c.ada + c23006d.ada + c23006e.ada + c23006f.ada + c23006g.ada + c24002d.ada + c24003a.ada + c24003b.ada + c24003c.ada + c24106a.ada + c24202d.ada + c24203a.ada + c24203b.ada + c24207a.ada + c24211a.ada + c250001.aw + c250002.aw + c25001a.ada + c25001b.ada + c26006a.ada + c26008a.ada + c2a001a.ada + c2a001b.ada + c2a001c.ada + c2a002a.ada + c2a008a.ada + c2a021b.ada + c32001a.ada + c32001b.ada + c32001c.ada + c32001d.ada + c32001e.ada + c32107a.ada + c32107c.ada + c32108a.ada + c32108b.ada + c32111a.ada + c32111b.ada + c32112b.ada + c32113a.ada + c32115a.ada + c32115b.ada + c330001.a + c330002.a + c332001.a + c340001.a + c34001a.ada + c34001c.ada + c34001d.ada + c34001f.ada + c34002a.ada + c34002c.ada + c34003a.ada + c34003c.ada + c34004a.ada + c34004c.ada + c34005a.ada + c34005c.ada + c34005d.ada + c34005f.ada + c34005g.ada + c34005i.ada + c34005j.ada + c34005l.ada + c34005m.ada + c34005o.ada + c34005p.ada + c34005r.ada + c34005s.ada + c34005u.ada + c34005v.ada + c34006a.ada + c34006d.ada + c34006f.ada + c34006g.ada + c34006j.ada + c34006l.ada + c34007a.ada + c34007d.ada + c34007f.ada + c34007g.ada + c34007i.ada + c34007j.ada + c34007m.ada + c34007p.ada + c34007r.ada + c34007s.ada + c34007u.ada + c34007v.ada + c34008a.ada + c34009a.ada + c34009d.ada + c34009f.ada + c34009g.ada + c34009j.ada + c34009l.ada + c34011b.ada + c34012a.ada + c34014a.ada + c34014c.ada + c34014e.ada + c34014g.ada + c34014h.ada + c34014n.ada + c34014p.ada + c34014r.ada + c34014t.ada + c34014u.ada + c34018a.ada + c340a01.a + c340a02.a + c341a01.a + c341a02.a + c341a03.a + c341a04.a + c35003a.ada + c35003b.ada + c35003d.ada + c35102a.ada + c352001.a + c354002.a + c354003.a + c35502a.ada + c35502b.ada + c35502c.ada + c35502d.tst + c35502e.ada + c35502f.tst + c35502g.ada + c35502h.ada + c35502i.ada + c35502j.ada + c35502k.ada + c35502l.ada + c35502m.ada + c35502n.ada + c35502o.ada + c35502p.ada + c35503a.ada + c35503b.ada + c35503c.ada + c35503d.tst + c35503e.ada + c35503f.tst + c35503g.ada + c35503h.ada + c35503k.ada + c35503l.ada + c35503o.ada + c35503p.ada + c35504a.ada + c35504b.ada + c35505c.ada + c35505e.ada + c35505f.ada + c35507a.ada + c35507b.ada + c35507c.ada + c35507e.ada + c35507g.ada + c35507h.ada + c35507i.ada + c35507j.ada + c35507k.ada + c35507l.ada + c35507m.ada + c35507n.ada + c35507o.ada + c35507p.ada + c35508a.ada + c35508b.ada + c35508c.ada + c35508e.ada + c35508g.ada + c35508h.ada + c35508k.ada + c35508l.ada + c35508o.ada + c35508p.ada + c35703a.ada + c35704a.ada + c35704b.ada + c35704c.ada + c35704d.ada + c35801d.ada + c35902d.ada + c35904a.ada + c35904b.ada + c35a02a.ada + c35a05a.ada + c35a05d.ada + c35a05n.ada + c35a05q.ada + c35a07a.ada + c35a07d.ada + c35a08b.ada + c360002.a + c36104a.ada + c36104b.ada + c36172a.ada + c36172b.ada + c36172c.ada + c36174a.ada + c36180a.ada + c36202c.ada + c36203a.ada + c36204a.ada + c36204b.ada + c36204c.ada + c36204d.ada + c36205a.ada + c36205b.ada + c36205c.ada + c36205d.ada + c36205e.ada + c36205f.ada + c36205g.ada + c36205h.ada + c36205i.ada + c36205j.ada + c36205k.ada + c36205l.ada + c36301a.ada + c36301b.ada + c36302a.ada + c36304a.ada + c36305a.ada + c37002a.ada + c37003a.ada + c37003b.ada + c37005a.ada + c37006a.ada + c37008a.ada + c37008b.ada + c37009a.ada + c37010a.ada + c37010b.ada + c371001.a + c371002.a + c371003.a + c37102b.ada + c37103a.ada + c37105a.ada + c37107a.ada + c37108b.ada + c37206a.ada + c37207a.ada + c37208a.ada + c37208b.ada + c37209a.ada + c37209b.ada + c37210a.ada + c37211a.ada + c37211b.ada + c37211c.ada + c37211d.ada + c37211e.ada + c37213b.ada + c37213d.ada + c37213f.ada + c37213h.ada + c37213j.ada + c37213k.ada + c37213l.ada + c37215b.ada + c37215d.ada + c37215f.ada + c37215h.ada + c37217a.ada + c37217b.ada + c37217c.ada + c37304a.ada + c37305a.ada + c37306a.ada + c37309a.ada + c37310a.ada + c37312a.ada + c37402a.ada + c37403a.ada + c37404a.ada + c37404b.ada + c37405a.ada + c37411a.ada + c38002a.ada + c38002b.ada + c38005a.ada + c38005b.ada + c38005c.ada + c38006a.ada + c38102a.ada + c38102b.ada + c38102c.ada + c38102d.ada + c38102e.ada + c38104a.ada + c38107a.ada + c38107b.ada + c38108a.ada + c38108b.ada + c38108c0.ada + c38108c1.ada + c38108c2.ada + c38108d0.ada + c38108d1.ada + c38202a.ada + c3900010.a + c3900011.am + c390002.a + c390003.a + c390004.a + c3900050.a + c3900051.a + c3900052.a + c3900053.am + c3900060.a + c3900061.a + c3900062.a + c3900063.am + c390007.a + c390010.a + c390011.a + c39006a.ada + c39006b.ada + c39006c0.ada + c39006c1.ada + c39006d.ada + c39006e.ada + c39006f0.ada + c39006f1.ada + c39006f2.ada + c39006f3.ada + c39006g.ada + c39007a.ada + c39007b.ada + c39008a.ada + c39008b.ada + c39008c.ada + c390a010.a + c390a011.am + c390a020.a + c390a021.a + c390a022.am + c390a030.a + c390a031.am + c391001.a + c391002.a + c392002.a + c392003.a + c392004.a + c392005.a + c392008.a + c392010.a + c392011.a + c392013.a + c392014.a + c392a01.a + c392c05.a + c392c07.a + c392d01.a + c392d02.a + c392d03.a + c393001.a + c393007.a + c393008.a + c393009.a + c393010.a + c393011.a + c393012.a + c393a02.a + c393a03.a + c393a05.a + c393a06.a + c393b12.a + c393b13.a + c393b14.a + c3a0001.a + c3a0002.a + c3a0003.a + c3a0004.a + c3a0005.a + c3a0006.a + c3a0007.a + c3a0008.a + c3a0009.a + c3a0010.a + c3a0011.a + c3a00120.a + c3a00121.a + c3a00122.am + c3a0013.a + c3a0014.a + c3a0015.a + c3a1001.a + c3a1002.a + c3a2001.a + c3a2002.a + c3a2003.a + c3a2a01.a + c3a2a02.a + c410001.a + c41101d.ada + c41103a.ada + c41103b.ada + c41104a.ada + c41105a.ada + c41107a.ada + c41201d.ada + c41203a.ada + c41203b.ada + c41204a.ada + c41205a.ada + c41206a.ada + c41207a.ada + c41301a.ada + c41303a.ada + c41303b.ada + c41303c.ada + c41303e.ada + c41303f.ada + c41303g.ada + c41303i.ada + c41303j.ada + c41303k.ada + c41303m.ada + c41303n.ada + c41303o.ada + c41303q.ada + c41303r.ada + c41303s.ada + c41303u.ada + c41303v.ada + c41303w.ada + c41304a.ada + c41304b.ada + c41306a.ada + c41306b.ada + c41306c.ada + c41307d.ada + c41309a.ada + c41320a.ada + c41321a.ada + c41322a.ada + c41323a.ada + c41324a.ada + c41325a.ada + c41326a.ada + c41327a.ada + c41328a.ada + c41401a.ada + c41402a.ada + c41404a.ada + c420001.a + c42006a.ada + c42007e.ada + c43003a.ada + c43004a.ada + c43004c.ada + c431001.a + c43103a.ada + c43103b.ada + c43104a.ada + c43105a.ada + c43105b.ada + c43106a.ada + c43107a.ada + c43108a.ada + c432001.a + c432002.a + c432003.a + c432004.a + c43204a.ada + c43204c.ada + c43204e.ada + c43204f.ada + c43204g.ada + c43204h.ada + c43204i.ada + c43205a.ada + c43205b.ada + c43205c.ada + c43205d.ada + c43205e.ada + c43205g.ada + c43205h.ada + c43205i.ada + c43205j.ada + c43205k.ada + c43206a.ada + c43207b.ada + c43207d.ada + c43208a.ada + c43208b.ada + c43209a.ada + c43210a.ada + c43211a.ada + c43212a.ada + c43212c.ada + c43214a.ada + c43214b.ada + c43214c.ada + c43214d.ada + c43214e.ada + c43214f.ada + c43215a.ada + c43215b.ada + c43222a.ada + c43224a.ada + c433001.a + c44003d.ada + c44003f.ada + c44003g.ada + c450001.a + c45112a.ada + c45112b.ada + c45113a.ada + c45114b.ada + c452001.a + c45201a.ada + c45201b.ada + c45202b.ada + c45210a.ada + c45211a.ada + c45220a.ada + c45220b.ada + c45220c.ada + c45220d.ada + c45220e.ada + c45220f.ada + c45231a.ada + c45231b.dep + c45231c.dep + c45231d.tst + c45232b.ada + c45242b.ada + c45251a.ada + c45252a.ada + c45252b.ada + c45253a.ada + c45262a.ada + c45262b.ada + c45262c.ada + c45262d.ada + c45264a.ada + c45264b.ada + c45264c.ada + c45265a.ada + c45271a.ada + c45272a.ada + c45273a.ada + c45274a.ada + c45274b.ada + c45274c.ada + c45281a.ada + c45282a.ada + c45282b.ada + c45291a.ada + c45303a.ada + c45304a.ada + c45304b.dep + c45304c.dep + c45322a.ada + c45323a.ada + c45331a.ada + c45342a.ada + c45343a.ada + c45344a.ada + c45345b.ada + c45347a.ada + c45347b.ada + c45347c.ada + c45347d.ada + c45411a.ada + c45411b.dep + c45411c.dep + c45411d.ada + c45413a.ada + c45431a.ada + c455001.a + c45502b.dep + c45502c.dep + c45503a.ada + c45503b.dep + c45503c.dep + c45504a.ada + c45504b.dep + c45504c.dep + c45504d.ada + c45504e.dep + c45504f.dep + c45505a.ada + c45523a.ada + c45531a.ada + c45531b.ada + c45531c.ada + c45531d.ada + c45531e.ada + c45531f.ada + c45531g.ada + c45531h.ada + c45531i.ada + c45531j.ada + c45531k.ada + c45531l.ada + c45531m.dep + c45531n.dep + c45531o.dep + c45531p.dep + c45532a.ada + c45532b.ada + c45532c.ada + c45532d.ada + c45532e.ada + c45532f.ada + c45532g.ada + c45532h.ada + c45532i.ada + c45532j.ada + c45532k.ada + c45532l.ada + c45532m.dep + c45532n.dep + c45532o.dep + c45532p.dep + c45534b.ada + c45536a.dep + c45611a.ada + c45611b.dep + c45611c.dep + c45613a.ada + c45613b.dep + c45613c.dep + c45614a.ada + c45614b.dep + c45614c.dep + c45622a.ada + c45624a.ada + c45624b.ada + c45631a.ada + c45631b.dep + c45631c.dep + c45632a.ada + c45632b.dep + c45632c.dep + c45651a.ada + c45662a.ada + c45662b.ada + c45672a.ada + c460001.a + c460002.a + c460004.a + c460005.a + c460006.a + c460007.a + c460008.a + c460009.a + c460010.a + c460011.a + c460012.a + c46011a.ada + c46013a.ada + c46014a.ada + c46021a.ada + c46024a.ada + c46031a.ada + c46032a.ada + c46033a.ada + c46041a.ada + c46042a.ada + c46043b.ada + c46044b.ada + c46051a.ada + c46051b.ada + c46051c.ada + c46052a.ada + c46053a.ada + c46054a.ada + c460a01.a + c460a02.a + c47002a.ada + c47002b.ada + c47002c.ada + c47002d.ada + c47003a.ada + c47004a.ada + c47005a.ada + c47006a.ada + c47007a.ada + c47008a.ada + c47009a.ada + c47009b.ada + c48004a.ada + c48004b.ada + c48004c.ada + c48004d.ada + c48004e.ada + c48004f.ada + c48005a.ada + c48005b.ada + c48006a.ada + c48006b.ada + c48007a.ada + c48007b.ada + c48007c.ada + c48008a.ada + c48008c.ada + c48009a.ada + c48009b.ada + c48009c.ada + c48009d.ada + c48009e.ada + c48009f.ada + c48009g.ada + c48009h.ada + c48009i.ada + c48009j.ada + c48010a.ada + c48011a.ada + c48012a.ada + c490001.a + c490002.a + c490003.a + c49020a.ada + c49021a.ada + c49022a.ada + c49022b.ada + c49022c.ada + c49023a.ada + c49024a.ada + c49025a.ada + c49026a.ada + c4a005b.ada + c4a006a.ada + c4a007a.tst + c4a010a.ada + c4a010b.ada + c4a011a.ada + c4a012b.ada + c4a013a.ada + c4a014a.ada + c51004a.ada + c52005a.ada + c52005b.ada + c52005c.ada + c52005d.ada + c52005e.ada + c52005f.ada + c52008a.ada + c52008b.ada + c52009a.ada + c52009b.ada + c52010a.ada + c52011a.ada + c52011b.ada + c52101a.ada + c52102a.ada + c52102b.ada + c52102c.ada + c52102d.ada + c52103a.ada + c52103b.ada + c52103c.ada + c52103f.ada + c52103g.ada + c52103h.ada + c52103k.ada + c52103l.ada + c52103m.ada + c52103p.ada + c52103q.ada + c52103r.ada + c52103x.ada + c52104a.ada + c52104b.ada + c52104c.ada + c52104f.ada + c52104g.ada + c52104h.ada + c52104k.ada + c52104l.ada + c52104m.ada + c52104p.ada + c52104q.ada + c52104r.ada + c52104x.ada + c52104y.ada + c53007a.ada + c540001.a + c54a03a.ada + c54a04a.ada + c54a07a.ada + c54a13a.ada + c54a13b.ada + c54a13c.ada + c54a13d.ada + c54a22a.ada + c54a23a.ada + c54a24a.ada + c54a24b.ada + c54a42a.ada + c54a42b.ada + c54a42c.ada + c54a42d.ada + c54a42e.ada + c54a42f.ada + c54a42g.ada + c55b03a.ada + c55b04a.ada + c55b05a.ada + c55b06a.ada + c55b06b.ada + c55b07a.dep + c55b07b.dep + c55b10a.ada + c55b11a.ada + c55b11b.ada + c55b15a.ada + c55b16a.ada + c55c02a.ada + c55c02b.ada + c56002a.ada + c57003a.ada + c57004a.ada + c57004b.ada + c58004c.ada + c58004d.ada + c58004g.ada + c58005a.ada + c58005b.ada + c58005h.ada + c58006a.ada + c58006b.ada + c59002a.ada + c59002b.ada + c59002c.ada + c61008a.ada + c61009a.ada + c61010a.ada + c62002a.ada + c62003a.ada + c62003b.ada + c62004a.ada + c62006a.ada + c631001.a + c640001.a + c64002b.ada + c64004g.ada + c64005a.ada + c64005b.ada + c64005c.ada + c64005d0.ada + c64005da.ada + c64005db.ada + c64005dc.ada + c641001.a + c64103b.ada + c64103c.ada + c64103d.ada + c64103e.ada + c64103f.ada + c64104a.ada + c64104b.ada + c64104c.ada + c64104d.ada + c64104e.ada + c64104f.ada + c64104g.ada + c64104h.ada + c64104i.ada + c64104j.ada + c64104k.ada + c64104l.ada + c64104m.ada + c64104n.ada + c64104o.ada + c64105a.ada + c64105b.ada + c64105c.ada + c64105d.ada + c64106a.ada + c64106b.ada + c64106c.ada + c64106d.ada + c64107a.ada + c64108a.ada + c64109a.ada + c64109b.ada + c64109c.ada + c64109d.ada + c64109e.ada + c64109f.ada + c64109g.ada + c64109h.ada + c64109i.ada + c64109j.ada + c64109k.ada + c64109l.ada + c64201b.ada + c64201c.ada + c64202a.ada + c650001.a + c65003a.ada + c65003b.ada + c66002a.ada + c66002c.ada + c66002d.ada + c66002e.ada + c66002f.ada + c66002g.ada + c67002a.ada + c67002b.ada + c67002c.ada + c67002d.ada + c67002e.ada + c67003f.ada + c67005a.ada + c67005b.ada + c67005c.ada + c67005d.ada + c72001b.ada + c72002a.ada + c730001.a + c730002.a + c730003.a + c730004.a + c73002a.ada + c730a01.a + c730a02.a + c731001.a + c74004a.ada + c74203a.ada + c74206a.ada + c74207b.ada + c74208a.ada + c74208b.ada + c74209a.ada + c74210a.ada + c74211a.ada + c74211b.ada + c74302a.ada + c74302b.ada + c74305a.ada + c74305b.ada + c74306a.ada + c74307a.ada + c74401d.ada + c74401e.ada + c74401k.ada + c74401q.ada + c74402a.ada + c74402b.ada + c74406a.ada + c74407b.ada + c74409b.ada + c760001.a + c760002.a + c760007.a + c760009.a + c760010.a + c760011.a + c760012.a + c760013.a + c761001.a + c761002.a + c761003.a + c761004.a + c761005.a + c761006.a + c761007.a + c761010.a + c761011.a + c83007a.ada + c83012d.ada + c83022a.ada + c83022g0.ada + c83022g1.ada + c83023a.ada + c83024a.ada + c83024e0.ada + c83024e1.ada + c83025a.ada + c83025c.ada + c83027a.ada + c83027c.ada + c83028a.ada + c83029a.ada + c83030a.ada + c83030c.ada + c83031a.ada + c83031c.ada + c83031e.ada + c83032a.ada + c83033a.ada + c83051a.ada + c83b02a.ada + c83b02b.ada + c83e02a.ada + c83e02b.ada + c83e03a.ada + c83f01a.ada + c83f01b.ada + c83f01c0.ada + c83f01c1.ada + c83f01c2.ada + c83f01d0.ada + c83f01d1.ada + c83f03a.ada + c83f03b.ada + c83f03c0.ada + c83f03c1.ada + c83f03c2.ada + c83f03d0.ada + c83f03d1.ada + c840001.a + c84002a.ada + c84005a.ada + c84008a.ada + c84009a.ada + c85004b.ada + c85005a.ada + c85005b.ada + c85005c.ada + c85005d.ada + c85005e.ada + c85005f.ada + c85005g.ada + c85006a.ada + c85006b.ada + c85006c.ada + c85006d.ada + c85006e.ada + c85006f.ada + c85006g.ada + c85007a.ada + c85007e.ada + c85009a.ada + c85011a.ada + c85013a.ada + c85014a.ada + c85014b.ada + c85014c.ada + c85017a.ada + c85018a.ada + c85018b.ada + c85019a.ada + c854001.a + c854002.a + c86003a.ada + c86004a.ada + c86004b0.ada + c86004b1.ada + c86004b2.ada + c86004c0.ada + c86004c1.ada + c86004c2.ada + c86006i.ada + c86007a.ada + c87a05a.ada + c87a05b.ada + c87b02a.ada + c87b02b.ada + c87b03a.ada + c87b04a.ada + c87b04b.ada + c87b04c.ada + c87b05a.ada + c87b06a.ada + c87b07a.ada + c87b07b.ada + c87b07c.ada + c87b07d.ada + c87b07e.ada + c87b08a.ada + c87b09a.ada + c87b09c.ada + c87b10a.ada + c87b11a.ada + c87b11b.ada + c87b13a.ada + c87b14a.ada + c87b14b.ada + c87b14c.ada + c87b14d.ada + c87b15a.ada + c87b16a.ada + c87b17a.ada + c87b18a.ada + c87b18b.ada + c87b19a.ada + c87b23a.ada + c87b24a.ada + c87b24b.ada + c87b26b.ada + c87b27a.ada + c87b28a.ada + c87b29a.ada + c87b30a.ada + c87b31a.ada + c87b32a.ada + c87b33a.ada + c87b34a.ada + c87b34b.ada + c87b34c.ada + c87b35c.ada + c87b38a.ada + c87b39a.ada + c87b40a.ada + c87b41a.ada + c87b42a.ada + c87b43a.ada + c87b44a.ada + c87b45a.ada + c87b45c.ada + c87b47a.ada + c87b48a.ada + c87b48b.ada + c87b50a.ada + c87b54a.ada + c87b57a.ada + c87b62a.ada + c87b62b.ada + c87b62c.ada + c87b62d.tst + c910001.a + c910002.a + c910003.a + c91004b.ada + c91004c.ada + c91006a.ada + c91007a.ada + c92002a.ada + c92003a.ada + c92005a.ada + c92005b.ada + c92006a.ada + c930001.a + c93001a.ada + c93002a.ada + c93003a.ada + c93004a.ada + c93004b.ada + c93004c.ada + c93004d.ada + c93004f.ada + c93005a.ada + c93005b.ada + c93005c.ada + c93005d.ada + c93005e.ada + c93005f.ada + c93005g.ada + c93005h.ada + c93006a.ada + c93007a.ada + c93008a.ada + c93008b.ada + c940001.a + c940002.a + c940004.a + c940005.a + c940006.a + c940007.a + c940010.a + c940011.a + c940012.a + c940013.a + c940014.a + c940015.a + c940016.a + c94001a.ada + c94001b.ada + c94001c.ada + c94001e.ada + c94001f.ada + c94001g.ada + c94002a.ada + c94002b.ada + c94002d.ada + c94002e.ada + c94002f.ada + c94002g.ada + c94004a.ada + c94004b.ada + c94004c.ada + c94005a.ada + c94005b.ada + c94006a.ada + c94007a.ada + c94007b.ada + c94008a.ada + c94008b.ada + c94008c.ada + c94008d.ada + c94010a.ada + c94011a.ada + c94020a.ada + c940a03.a + c95008a.ada + c95009a.ada + c95010a.ada + c95011a.ada + c95012a.ada + c95021a.ada + c95022a.ada + c95022b.ada + c95033a.ada + c95033b.ada + c95034a.ada + c95034b.ada + c95035a.ada + c95040a.ada + c95040b.ada + c95040c.ada + c95040d.ada + c95041a.ada + c95065a.ada + c95065b.ada + c95065c.ada + c95065d.ada + c95065e.ada + c95065f.ada + c95066a.ada + c95067a.ada + c95071a.ada + c95072a.ada + c95072b.ada + c95073a.ada + c95074c.ada + c95076a.ada + c95078a.ada + c95080b.ada + c95082g.ada + c95085a.ada + c95085b.ada + c95085c.ada + c95085d.ada + c95085e.ada + c95085f.ada + c95085g.ada + c95085h.ada + c95085i.ada + c95085j.ada + c95085k.ada + c95085l.ada + c95085m.ada + c95085n.ada + c95085o.ada + c95086a.ada + c95086b.ada + c95086c.ada + c95086d.ada + c95086e.ada + c95086f.ada + c95087a.ada + c95087b.ada + c95087c.ada + c95087d.ada + c95088a.ada + c95089a.ada + c95090a.ada + c95092a.ada + c95093a.ada + c95095a.ada + c95095b.ada + c95095c.ada + c95095d.ada + c95095e.ada + c951001.a + c951002.a + c953001.a + c953002.a + c953003.a + c954001.a + c954010.a + c954011.a + c954012.a + c954013.a + c954014.a + c954015.a + c954016.a + c954017.a + c954018.a + c954019.a + c954020.a + c954021.a + c954022.a + c954023.a + c954024.a + c954025.a + c954026.a + c954a01.a + c954a02.a + c954a03.a + c960001.a + c960002.a + c960004.a + c96001a.ada + c96004a.ada + c96005a.ada + c96005b.tst + c96005d.ada + c96005f.ada + c96006a.ada + c96007a.ada + c96008a.ada + c96008b.ada + c97112a.ada + c97113a.ada + c97114a.ada + c97115a.ada + c97116a.ada + c97117a.ada + c97117b.ada + c97117c.ada + c97118a.ada + c97120a.ada + c97120b.ada + c97201a.ada + c97201b.ada + c97201c.ada + c97201d.ada + c97201e.ada + c97201g.ada + c97201h.ada + c97201x.ada + c97202a.ada + c97203a.ada + c97203b.ada + c97203c.ada + c97204a.ada + c97204b.ada + c97205a.ada + c97205b.ada + c97301a.ada + c97301b.ada + c97301c.ada + c97301d.ada + c97301e.ada + c97302a.ada + c97303a.ada + c97303b.ada + c97303c.ada + c97304a.ada + c97304b.ada + c97305a.ada + c97305b.ada + c97305c.ada + c97305d.ada + c97307a.ada + c974001.a + c974002.a + c974003.a + c974004.a + c974005.a + c974006.a + c974007.a + c974008.a + c974009.a + c974010.a + c974011.a + c974012.a + c974013.a + c974014.a + c980001.a + c980002.a + c980003.a + c99004a.ada + c99005a.ada + c9a003a.ada + c9a004a.ada + c9a007a.ada + c9a009a.ada + c9a009c.ada + c9a009f.ada + c9a009g.ada + c9a009h.ada + c9a010a.ada + c9a011a.ada + c9a011b.ada + ca1003a.ada + ca1004a.ada + ca1005a.ada + ca1006a.ada + ca1011a0.ada + ca1011a1.ada + ca1011a2.ada + ca1011a3.ada + ca1011a4.ada + ca1011a5.ada + ca1011a6.ada + ca1012a0.ada + ca1012a1.ada + ca1012a2.ada + ca1012a3.ada + ca1012a4.ada + ca1012b0.ada + ca1012b2.ada + ca1012b4.ada + ca1013a0.ada + ca1013a1.ada + ca1013a2.ada + ca1013a3.ada + ca1013a4.ada + ca1013a5.ada + ca1013a6.ada + ca1014a0.ada + ca1014a1.ada + ca1014a2.ada + ca1014a3.ada + ca1020e0.ada + ca1020e1.ada + ca1020e2.ada + ca1020e3.ada + ca1022a0.ada + ca1022a1.ada + ca1022a2.ada + ca1022a3.ada + ca1022a4.ada + ca1022a5.ada + ca1022a6.ada + ca11001.a + ca11002.a + ca11003.a + ca110040.a + ca110041.a + ca110042.am + ca110050.a + ca110051.am + ca11006.a + ca11007.a + ca11008.a + ca11009.a + ca11010.a + ca11011.a + ca11012.a + ca11013.a + ca11014.a + ca11015.a + ca11016.a + ca11017.a + ca11018.a + ca11019.a + ca11020.a + ca11021.a + ca11022.a + ca1102a0.ada + ca1102a1.ada + ca1102a2.ada + ca1106a.ada + ca1108a.ada + ca1108b.ada + ca11a01.a + ca11a02.a + ca11b01.a + ca11b02.a + ca11c01.a + ca11c02.a + ca11c03.a + ca11d010.a + ca11d011.a + ca11d012.a + ca11d013.am + ca11d02.a + ca11d03.a + ca13001.a + ca13002.a + ca13003.a + ca13a01.a + ca13a02.a + ca140230.a + ca140231.a + ca140232.am + ca140233.a + ca140280.a + ca140281.a + ca140282.a + ca140283.am + ca15003.a + ca200020.a + ca200021.a + ca200022.am + ca2001h0.ada + ca2001h1.ada + ca2001h2.ada + ca2001h3.ada + ca2002a0.ada + ca2002a1.ada + ca2002a2.ada + ca2003a0.ada + ca2003a1.ada + ca2004a0.ada + ca2004a1.ada + ca2004a2.ada + ca2004a3.ada + ca2004a4.ada + ca2007a0.ada + ca2007a1.ada + ca2007a2.ada + ca2007a3.ada + ca2008a0.ada + ca2008a1.ada + ca2008a2.ada + ca2009a.ada + ca2009c0.ada + ca2009c1.ada + ca2009d.ada + ca2009f0.ada + ca2009f1.ada + ca2009f2.ada + ca2011b.ada + ca21001.a + ca3011a0.ada + ca3011a1.ada + ca3011a2.ada + ca3011a3.ada + ca3011a4.ada + ca5003a0.ada + ca5003a1.ada + ca5003a2.ada + ca5003a3.ada + ca5003a4.ada + ca5003a5.ada + ca5003a6.ada + ca5003b0.ada + ca5003b1.ada + ca5003b2.ada + ca5003b3.ada + ca5003b4.ada + ca5003b5.ada + ca5004a.ada + ca5004b0.ada + ca5004b1.ada + ca5004b2.ada + ca5006a.ada + cb10002.a + cb1001a.ada + cb1004a.ada + cb1005a.ada + cb1010a.ada + cb1010c.ada + cb1010d.ada + cb20001.a + cb20003.a + cb20004.a + cb20005.a + cb20006.a + cb20007.a + cb2004a.ada + cb2005a.ada + cb2006a.ada + cb2007a.ada + cb20a02.a + cb3003a.ada + cb3003b.ada + cb3004a.ada + cb40005.a + cb4001a.ada + cb4002a.ada + cb4003a.ada + cb4004a.ada + cb4005a.ada + cb4006a.ada + cb4007a.ada + cb4008a.ada + cb4009a.ada + cb4013a.ada + cb40a01.a + cb40a020.a + cb40a021.am + cb40a030.a + cb40a031.am + cb40a04.a + cb41001.a + cb41002.a + cb41003.a + cb41004.a + cb5001a.ada + cb5001b.ada + cb5002a.ada + cc1004a.ada + cc1005b.ada + cc1010a.ada + cc1010b.ada + cc1018a.ada + cc1104c.ada + cc1107b.ada + cc1111a.ada + cc1204a.ada + cc1207b.ada + cc1220a.ada + cc1221a.ada + cc1221b.ada + cc1221c.ada + cc1221d.ada + cc1222a.ada + cc1223a.ada + cc1224a.ada + cc1225a.tst + cc1226b.ada + cc1227a.ada + cc1301a.ada + cc1302a.ada + cc1304a.ada + cc1304b.ada + cc1307a.ada + cc1307b.ada + cc1308a.ada + cc1310a.ada + cc1311a.ada + cc1311b.ada + cc2002a.ada + cc30001.a + cc30002.a + cc3004a.ada + cc3007a.ada + cc3007b.ada + cc3011a.ada + cc3011d.ada + cc3012a.ada + cc3015a.ada + cc3016b.ada + cc3016c.ada + cc3016f.ada + cc3016i.ada + cc3017b.ada + cc3017c.ada + cc3019a.ada + cc3019b0.ada + cc3019b1.ada + cc3019b2.ada + cc3019c0.ada + cc3019c1.ada + cc3019c2.ada + cc3106b.ada + cc3120a.ada + cc3120b.ada + cc3121a.ada + cc3123a.ada + cc3125a.ada + cc3125b.ada + cc3125c.ada + cc3125d.ada + cc3126a.ada + cc3127a.ada + cc3128a.ada + cc3203a.ada + cc3207b.ada + cc3220a.ada + cc3221a.ada + cc3222a.ada + cc3223a.ada + cc3224a.ada + cc3225a.ada + cc3230a.ada + cc3231a.ada + cc3232a.ada + cc3233a.ada + cc3234a.ada + cc3235a.ada + cc3236a.ada + cc3240a.ada + cc3305a.ada + cc3305b.ada + cc3305c.ada + cc3305d.ada + cc3601a.ada + cc3601c.ada + cc3602a.ada + cc3603a.ada + cc3605a.ada + cc3606a.ada + cc3606b.ada + cc3607b.ada + cc40001.a + cc50001.a + cc50a01.a + cc50a02.a + cc51001.a + cc51002.a + cc51003.a + cc51004.a + cc51006.a + cc51007.a + cc51a01.a + cc51b03.a + cc51d01.a + cc51d02.a + cc54001.a + cc54002.a + cc54003.a + cc54004.a + cc70001.a + cc70002.a + cc70003.a + cc70a01.a + cc70a02.a + cc70b01.a + cc70b02.a + cc70c01.a + cc70c02.a + cd10001.a + cd1009a.ada + cd1009b.ada + cd1009d.ada + cd1009e.ada + cd1009f.ada + cd1009g.ada + cd1009h.ada + cd1009i.ada + cd1009j.ada + cd1009k.tst + cd1009l.ada + cd1009m.ada + cd1009n.ada + cd1009o.ada + cd1009p.ada + cd1009q.ada + cd1009r.ada + cd1009s.ada + cd1009t.tst + cd1009u.tst + cd1009v.ada + cd1009w.ada + cd1009x.ada + cd1009y.ada + cd1009z.ada + cd1c03a.ada + cd1c03b.ada + cd1c03c.ada + cd1c03e.tst + cd1c03f.ada + cd1c03g.ada + cd1c03h.ada + cd1c03i.ada + cd1c04a.ada + cd1c04d.ada + cd1c04e.ada + cd1c06a.tst + cd20001.a + cd2a21a.ada + cd2a21c.ada + cd2a21e.ada + cd2a22a.ada + cd2a22e.ada + cd2a22i.ada + cd2a22j.ada + cd2a23a.ada + cd2a23e.ada + cd2a24a.ada + cd2a24e.ada + cd2a24i.ada + cd2a24j.ada + cd2a31a.ada + cd2a31c.ada + cd2a31e.ada + cd2a32a.ada + cd2a32c.ada + cd2a32e.ada + cd2a32g.ada + cd2a32i.ada + cd2a32j.ada + cd2a51a.ada + cd2a53a.ada + cd2a53e.ada + cd2a83c.tst + cd2a91c.tst + cd2b11a.ada + cd2b11b.ada + cd2b11d.ada + cd2b11e.ada + cd2b11f.ada + cd2b15c.ada + cd2b16a.ada + cd2c11a.tst + cd2c11d.tst + cd2d11a.ada + cd2d13a.ada + cd30001.a + cd30002.a + cd30003.a + cd30004.a + cd300050.am + cd300051.c + cd3014a.ada + cd3014c.ada + cd3014d.ada + cd3014f.ada + cd3015a.ada + cd3015c.ada + cd3015e.ada + cd3015f.ada + cd3015g.ada + cd3015h.ada + cd3015i.ada + cd3015k.ada + cd3021a.ada + cd33001.a + cd33002.a + cd40001.a + cd4031a.ada + cd4041a.tst + cd4051a.ada + cd4051b.ada + cd4051c.ada + cd4051d.ada + cd5003a.ada + cd5003b.ada + cd5003c.ada + cd5003d.ada + cd5003e.ada + cd5003f.ada + cd5003g.ada + cd5003h.ada + cd5003i.ada + cd5011a.ada + cd5011c.ada + cd5011e.ada + cd5011g.ada + cd5011i.ada + cd5011k.ada + cd5011m.ada + cd5011q.ada + cd5011s.ada + cd5012a.ada + cd5012b.ada + cd5012e.ada + cd5012f.ada + cd5012i.ada + cd5012m.ada + cd5013a.ada + cd5013c.ada + cd5013e.ada + cd5013g.ada + cd5013i.ada + cd5013k.ada + cd5013m.ada + cd5013o.ada + cd5014a.ada + cd5014c.ada + cd5014e.ada + cd5014g.ada + cd5014i.ada + cd5014k.ada + cd5014m.ada + cd5014o.ada + cd5014t.ada + cd5014v.ada + cd5014x.ada + cd5014y.ada + cd5014z.ada + cd70001.a + cd7002a.ada + cd7007b.ada + cd7101d.ada + cd7101e.dep + cd7101f.dep + cd7101g.tst + cd7103d.ada + cd7202a.ada + cd7204b.ada + cd7204c.ada + cd72a01.a + cd72a02.a + cd7305a.ada + cd90001.a + cd92001.a + cda201a.ada + cda201b.ada + cda201c.ada + cda201e.ada + cdb0a01.a + cdb0a02.a + cdd1001.a + cdd2001.a + cde0001.a + ce2102a.ada + ce2102b.ada + ce2102c.tst + ce2102d.ada + ce2102e.ada + ce2102f.ada + ce2102g.ada + ce2102h.tst + ce2102i.ada + ce2102j.ada + ce2102k.ada + ce2102l.ada + ce2102m.ada + ce2102n.ada + ce2102o.ada + ce2102p.ada + ce2102q.ada + ce2102r.ada + ce2102s.ada + ce2102t.ada + ce2102u.ada + ce2102v.ada + ce2102w.ada + ce2102x.ada + ce2102y.ada + ce2103a.tst + ce2103b.tst + ce2103c.ada + ce2103d.ada + ce2104a.ada + ce2104b.ada + ce2104c.ada + ce2104d.ada + ce2106a.ada + ce2106b.ada + ce2108e.ada + ce2108f.ada + ce2108g.ada + ce2108h.ada + ce2109a.ada + ce2109b.ada + ce2109c.ada + ce2110a.ada + ce2110c.ada + ce2111a.ada + ce2111b.ada + ce2111c.ada + ce2111e.ada + ce2111f.ada + ce2111g.ada + ce2111i.ada + ce2201a.ada + ce2201b.ada + ce2201c.ada + ce2201d.dep + ce2201e.dep + ce2201f.ada + ce2201g.ada + ce2201h.ada + ce2201i.ada + ce2201j.ada + ce2201k.ada + ce2201l.ada + ce2201m.ada + ce2201n.ada + ce2202a.ada + ce2203a.tst + ce2204a.ada + ce2204b.ada + ce2204c.ada + ce2204d.ada + ce2205a.ada + ce2206a.ada + ce2208b.ada + ce2401a.ada + ce2401b.ada + ce2401c.ada + ce2401e.ada + ce2401f.ada + ce2401h.ada + ce2401i.ada + ce2401j.ada + ce2401k.ada + ce2401l.ada + ce2402a.ada + ce2403a.tst + ce2404a.ada + ce2404b.ada + ce2405b.ada + ce2406a.ada + ce2407a.ada + ce2407b.ada + ce2408a.ada + ce2408b.ada + ce2409a.ada + ce2409b.ada + ce2410a.ada + ce2410b.ada + ce2411a.ada + ce3002b.tst + ce3002c.tst + ce3002d.ada + ce3002f.ada + ce3102a.ada + ce3102b.tst + ce3102d.ada + ce3102e.ada + ce3102f.ada + ce3102g.ada + ce3102h.ada + ce3102i.ada + ce3102j.ada + ce3102k.ada + ce3103a.ada + ce3104a.ada + ce3104b.ada + ce3104c.ada + ce3106a.ada + ce3106b.ada + ce3107a.tst + ce3107b.ada + ce3108a.ada + ce3108b.ada + ce3110a.ada + ce3112c.ada + ce3112d.ada + ce3114a.ada + ce3115a.ada + ce3201a.ada + ce3202a.ada + ce3206a.ada + ce3207a.ada + ce3301a.ada + ce3302a.ada + ce3303a.ada + ce3304a.tst + ce3305a.ada + ce3306a.ada + ce3401a.ada + ce3402a.ada + ce3402c.ada + ce3402d.ada + ce3402e.ada + ce3403a.ada + ce3403b.ada + ce3403c.ada + ce3403d.ada + ce3403e.ada + ce3403f.ada + ce3404a.ada + ce3404b.ada + ce3404c.ada + ce3404d.ada + ce3405a.ada + ce3405c.ada + ce3405d.ada + ce3406a.ada + ce3406b.ada + ce3406c.ada + ce3406d.ada + ce3407a.ada + ce3407b.ada + ce3407c.ada + ce3408a.ada + ce3408b.ada + ce3408c.ada + ce3409a.ada + ce3409b.ada + ce3409c.ada + ce3409d.ada + ce3409e.ada + ce3410a.ada + ce3410b.ada + ce3410c.ada + ce3410d.ada + ce3410e.ada + ce3411a.ada + ce3411c.ada + ce3412a.ada + ce3413a.ada + ce3413b.ada + ce3413c.ada + ce3414a.ada + ce3601a.ada + ce3602a.ada + ce3602b.ada + ce3602c.ada + ce3602d.ada + ce3603a.ada + ce3604a.ada + ce3604b.ada + ce3605a.ada + ce3605b.ada + ce3605c.ada + ce3605d.ada + ce3605e.ada + ce3606a.ada + ce3606b.ada + ce3701a.ada + ce3704a.ada + ce3704b.ada + ce3704c.ada + ce3704d.ada + ce3704e.ada + ce3704f.ada + ce3704m.ada + ce3704n.ada + ce3704o.ada + ce3705a.ada + ce3705b.ada + ce3705c.ada + ce3705d.ada + ce3705e.ada + ce3706c.ada + ce3706d.ada + ce3706f.ada + ce3706g.ada + ce3707a.ada + ce3708a.ada + ce3801a.ada + ce3801b.ada + ce3804a.ada + ce3804b.ada + ce3804c.ada + ce3804d.ada + ce3804e.ada + ce3804f.ada + ce3804g.ada + ce3804h.ada + ce3804i.ada + ce3804j.ada + ce3804m.ada + ce3804o.ada + ce3804p.ada + ce3805a.ada + ce3805b.ada + ce3806a.ada + ce3806b.ada + ce3806c.ada + ce3806d.ada + ce3806e.ada + ce3806f.ada + ce3806g.ada + ce3806h.ada + ce3809a.ada + ce3809b.ada + ce3810a.ada + ce3810b.ada + ce3815a.ada + ce3901a.ada + ce3902b.ada + ce3904a.ada + ce3904b.ada + ce3905a.ada + ce3905b.ada + ce3905c.ada + ce3905l.ada + ce3906a.ada + ce3906b.ada + ce3906c.ada + ce3906d.ada + ce3906e.ada + ce3906f.ada + ce3907a.ada + ce3908a.ada + checkfil.ada + coverage.txt + cxa3001.a + cxa3002.a + cxa3003.a + cxa3004.a + cxa4001.a + cxa4002.a + cxa4003.a + cxa4004.a + cxa4005.a + cxa4006.a + cxa4007.a + cxa4008.a + cxa4009.a + cxa4010.a + cxa4011.a + cxa4012.a + cxa4013.a + cxa4014.a + cxa4015.a + cxa4016.a + cxa4017.a + cxa4018.a + cxa4019.a + cxa4020.a + cxa4021.a + cxa4022.a + cxa4023.a + cxa4024.a + cxa4025.a + cxa4026.a + cxa4027.a + cxa4028.a + cxa4029.a + cxa4030.a + cxa4031.a + cxa4032.a + cxa4033.a + cxa4034.a + cxa5011.a + cxa5012.a + cxa5013.a + cxa5015.a + cxa5a01.a + cxa5a02.a + cxa5a03.a + cxa5a04.a + cxa5a05.a + cxa5a06.a + cxa5a07.a + cxa5a08.a + cxa5a09.a + cxa5a10.a + cxa8001.a + cxa8002.a + cxa8003.a + cxa9001.a + cxa9002.a + cxaa001.a + cxaa002.a + cxaa003.a + cxaa004.a + cxaa005.a + cxaa006.a + cxaa007.a + cxaa008.a + cxaa009.a + cxaa010.a + cxaa011.a + cxaa012.a + cxaa013.a + cxaa014.a + cxaa015.a + cxaa016.a + cxaa017.a + cxaa018.a + cxaa019.a + cxab001.a + cxac001.a + cxac002.a + cxac003.a + cxac004.a + cxac005.a + cxaca01.a + cxaca02.a + cxacb01.a + cxacb02.a + cxacc01.a + cxaf001.a + cxb2001.a + cxb2002.a + cxb2003.a + cxb3001.a + cxb3002.a + cxb3003.a + cxb30040.c + cxb30041.am + cxb3005.a + cxb30060.c + cxb30061.am + cxb3007.a + cxb3008.a + cxb3009.a + cxb3010.a + cxb3011.a + cxb3012.a + cxb30130.c + cxb30131.c + cxb30132.am + cxb3014.a + cxb3015.a + cxb3016.a + cxb4001.a + cxb4002.a + cxb4003.a + cxb4004.a + cxb4005.a + cxb4006.a + cxb4007.a + cxb4008.a + cxb40090.cbl + cxb40091.cbl + cxb40092.cbl + cxb40093.am + cxb5001.a + cxb5002.a + cxb5003.a + cxb50040.ftn + cxb50041.ftn + cxb50042.am + cxb50050.ftn + cxb50051.ftn + cxb50052.am + cxc3001.a + cxc3002.a + cxc3003.a + cxc3004.a + cxc3005.a + cxc3006.a + cxc3007.a + cxc3008.a + cxc3009.a + cxc6001.a + cxc6002.a + cxc6003.a + cxc7001.a + cxc7002.a + cxc7003.a + cxc7004.a + cxd1001.a + cxd1002.a + cxd1003.a + cxd1004.a + cxd1005.a + cxd1006.a + cxd1007.a + cxd1008.a + cxd2001.a + cxd2002.a + cxd2003.a + cxd2004.a + cxd2006.a + cxd2007.a + cxd2008.a + cxd3001.a + cxd3002.a + cxd3003.a + cxd4001.a + cxd4002.a + cxd4003.a + cxd4004.a + cxd4005.a + cxd4006.a + cxd4007.a + cxd4008.a + cxd4009.a + cxd4010.a + cxd5001.a + cxd6001.a + cxd6002.a + cxd6003.a + cxd8001.a + cxd8002.a + cxd8003.a + cxd9001.a + cxda001.a + cxda002.a + cxda003.a + cxda004.a + cxdb001.a + cxdb002.a + cxdb003.a + cxdb004.a + cxe1001.a + cxe2001.a + cxe2002.a + cxe4001.a + cxe4002.a + cxe4003.a + cxe4004.a + cxe4005.a + cxe4006.a + cxe5001.a + cxe5002.a + cxe5003.a + cxf1001.a + cxf2001.a + cxf2002.a + cxf2003.a + cxf2004.a + cxf2005.a + cxf2a01.a + cxf2a02.a + cxf3001.a + cxf3002.a + cxf3003.a + cxf3004.a + cxf3a01.a + cxf3a02.a + cxf3a03.a + cxf3a04.a + cxf3a05.a + cxf3a06.a + cxf3a07.a + cxf3a08.a + cxg1001.a + cxg1002.a + cxg1003.a + cxg1004.a + cxg1005.a + cxg2001.a + cxg2002.a + cxg2003.a + cxg2004.a + cxg2005.a + cxg2006.a + cxg2007.a + cxg2008.a + cxg2009.a + cxg2010.a + cxg2011.a + cxg2012.a + cxg2013.a + cxg2014.a + cxg2015.a + cxg2016.a + cxg2017.a + cxg2018.a + cxg2019.a + cxg2020.a + cxg2021.a + cxg2022.a + cxg2023.a + cxg2024.a + cxh1001.a + cxh3001.a + cxh3002.a + cxh30030.a + cxh30031.am + cz00004.a + cz1101a.ada + cz1102a.ada + cz1103a.ada + d4a002a.ada + d4a002b.ada + d4a004a.ada + d4a004b.ada + e28002b.ada + e28005d.ada + e52103y.ada + eb4011a.ada + eb4012a.ada + eb4014a.ada + ee3203a.ada + ee3204a.ada + ee3402b.ada + ee3409f.ada + ee3412c.ada + enumchek.ada + f340a000.a + f340a001.a + f341a00.a + f390a00.a + f392a00.a + f392c00.a + f392d00.a + f393a00.a + f393b00.a + f3a2a00.a + f460a00.a + f730a000.a + f730a001.a + f731a00.a + f940a00.a + f954a00.a + fa11a00.a + fa11b00.a + fa11c00.a + fa11d00.a + fa13a00.a + fa13b00.a + fa21a00.a + fb20a00.a + fb40a00.a + fc50a00.a + fc51a00.a + fc51b00.a + fc51c00.a + fc51d00.a + fc54a00.a + fc70a00.a + fc70b00.a + fc70c00.a + fcndecl.ada + fd72a00.a + fdb0a00.a + fxa5a00.a + fxaca00.a + fxacb00.a + fxacc00.a + fxc6a00.a + fxe2a00.a + fxf2a00.a + fxf3a00.a + impdef.a + impdefc.a + impdefd.a + impdefe.a + impdefg.a + impdefh.a + la140010.a + la140011.am + la140012.a + la140020.a + la140021.am + la140022.a + la140030.a + la140031.a + la140032.am + la140033.a + la140040.a + la140041.am + la140042.a + la140050.a + la140051.a + la140052.am + la140053.a + la140060.a + la140061.a + la140062.am + la140063.a + la140070.a + la140071.a + la140072.am + la140073.a + la140080.a + la140081.a + la140082.am + la140083.a + la140090.a + la140091.a + la140092.am + la140093.a + la140100.a + la140101.a + la140102.am + la140103.a + la140110.a + la140111.a + la140112.am + la140113.a + la140120.a + la140121.a + la140122.am + la140123.a + la140130.a + la140131.a + la140132.am + la140133.a + la140140.a + la140141.a + la140142.am + la140143.a + la140150.a + la140151.a + la140152.am + la140153.a + la140160.a + la140161.a + la140162.am + la140163.a + la140170.a + la140171.a + la140172.am + la140173.a + la140180.a + la140181.a + la140182.am + la140183.a + la140190.a + la140191.a + la140192.am + la140193.a + la140200.a + la140201.a + la140202.am + la140203.a + la140210.a + la140211.am + la140212.a + la140220.a + la140221.am + la140222.a + la140240.a + la140241.a + la140242.am + la140243.a + la140250.a + la140251.am + la140252.a + la140260.a + la140261.a + la140262.am + la140263.a + la140270.a + la140271.a + la140272.am + la140273.a + la200010.a + la200011.a + la200012.am + la5001a0.ada + la5001a1.ada + la5001a2.ada + la5001a3.ada + la5001a4.ada + la5001a5.ada + la5001a6.ada + la5001a7.ada + la5007a0.ada + la5007a1.ada + la5007b0.ada + la5007b1.ada + la5007c0.ada + la5007c1.ada + la5007d0.ada + la5007d1.ada + la5007e0.ada + la5007e1.ada + la5007f0.ada + la5007f1.ada + la5007g0.ada + la5007g1.ada + la5008a0.ada + la5008a1.ada + la5008b0.ada + la5008b1.ada + la5008c0.ada + la5008c1.ada + la5008d0.ada + la5008d1.ada + la5008e0.ada + la5008e1.ada + la5008f0.ada + la5008f1.ada + la5008g0.ada + la5008g1.ada + lencheck.ada + lxd70010.a + lxd70011.a + lxd70012.am + lxd70030.a + lxd70031.a + lxd70032.am + lxd70040.a + lxd70041.a + lxd70042.am + lxd70050.a + lxd70051.a + lxd70052.am + lxd70060.a + lxd70061.a + lxd70062.am + lxd70070.a + lxd70071.a + lxd70072.am + lxd70080.a + lxd70081.a + lxd70082.am + lxd70090.a + lxd70091.a + lxd70092.am + lxe30010.am + lxe30011.am + lxe30020.am + lxe30021.am + lxh40010.a + lxh40011.a + lxh40012.am + lxh40020.a + lxh40021.a + lxh40022.am + lxh40030.a + lxh40031.a + lxh40032.a + lxh40033.am + lxh40040.a + lxh40041.a + lxh40042.a + lxh40043.am + lxh40050.a + lxh40051.a + lxh40052.a + lxh40053.am + lxh40060.a + lxh40061.a + lxh40062.a + lxh40063.am + lxh40070.a + lxh40071.a + lxh40072.a + lxh40073.am + lxh40080.a + lxh40081.a + lxh40082.a + lxh40083.a + lxh40084.am + lxh40090.a + lxh40091.a + lxh40092.a + lxh40093.am + lxh40100.a + lxh40101.a + lxh40102.a + lxh40103.am + lxh40110.a + lxh40111.a + lxh40112.am + lxh40120.a + lxh40121.a + lxh40122.a + lxh40123.am + lxh40130.a + lxh40131.a + lxh40132.a + lxh40133.am + lxh40140.a + lxh40141.a + lxh40142.am + macro.dfs + macrosub.ada + repbody.ada + repspec.ada + spprt13s.tst + tctouch.ada + testobj.txt + tsttests.dat + ug-apxa.doc + ug-apxa.pdf + ug-apxa.txt + ug-apxb.doc + ug-apxb.pdf + ug-apxb.txt + ug-apxc.doc + ug-apxc.pdf + ug-apxc.txt + ug-apxd.doc + ug-apxd.pdf + ug-apxd.txt + ug-body.doc + ug-body.pdf + ug-body.txt + widechr.a diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/checkfil.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/checkfil.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/checkfil.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/checkfil.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,197 ---- + -- CHECK_FILE.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- THIS IS A PROCEDURE USED BY MANY OF THE CHAPTER 14 TESTS TO CHECK THE + -- CONTENTS OF A TEXT FILE. + + -- THIS PROCEDURE ASSUMES THE FILE PARAMETER PASSED TO IT IS AN OPEN + -- TEXT FILE. + + -- THE STRING PARAMETER CONTAINS THE CHARACTERS THAT ARE SUPPOSED TO BE + -- IN THE TEXT FILE. A '#' CHARACTER IS USED IN THE STRING TO DENOTE + -- THE END OF A LINE. A '@' CHARACTER IS USED TO DENOTE THE END OF A + -- PAGE. A '%' CHARACTER IS USED TO DENOTE THE END OF THE TEXT FILE. + -- THESE SYMBOLS SHOULD NOT BE USED AS TEXT OUTPUT. + + -- SPS 11/30/82 + -- JBG 2/3/83 + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CHECK_FILE (FILE: IN OUT FILE_TYPE; CONTENTS : STRING) IS + + X : CHARACTER; + COL_COUNT : POSITIVE_COUNT := 1; + LINE_COUNT : POSITIVE_COUNT := 1; + PAGE_COUNT : POSITIVE_COUNT := 1; + TRAILING_BLANKS_MSG_WRITTEN : BOOLEAN := FALSE; + STOP_PROCESSING : EXCEPTION; + + PROCEDURE CHECK_END_OF_LINE (EXPECT_END_OF_PAGE : BOOLEAN) IS + BEGIN + + -- SKIP OVER ANY TRAILING BLANKS. AN IMPLEMENTATION CAN LEGALLY + -- APPEND BLANKS TO THE END OF ANY LINE. + + WHILE NOT END_OF_LINE (FILE) LOOP + GET (FILE, X); + IF X /= ' ' THEN + FAILED ("FROM CHECK_FILE: END OF LINE EXPECTED - " & + X & " ENCOUNTERED"); + RAISE STOP_PROCESSING; + ELSE + IF NOT TRAILING_BLANKS_MSG_WRITTEN THEN + COMMENT ("FROM CHECK_FILE: " & + "THIS IMPLEMENTATION PADS " & + "LINES WITH BLANKS"); + TRAILING_BLANKS_MSG_WRITTEN := TRUE; + END IF; + END IF; + END LOOP; + + IF LINE_COUNT /= LINE (FILE) THEN + FAILED ("FROM CHECK_FILE: " & + "LINE COUNT INCORRECT - EXPECTED " & + POSITIVE_COUNT'IMAGE(LINE_COUNT) & + " GOT FROM FILE " & + POSITIVE_COUNT'IMAGE(LINE(FILE))); + END IF; + + -- NOTE: DO NOT SKIP_LINE WHEN AT END OF PAGE BECAUSE SKIP_LINE WILL + -- ALSO SKIP THE PAGE TERMINATOR. SEE RM 14.3.5 PARAGRAPH 1. + + IF NOT EXPECT_END_OF_PAGE THEN + IF END_OF_PAGE (FILE) THEN + FAILED ("FROM CHECK_FILE: PREMATURE END OF PAGE"); + RAISE STOP_PROCESSING; + ELSE + SKIP_LINE (FILE); + LINE_COUNT := LINE_COUNT + 1; + END IF; + END IF; + COL_COUNT := 1; + END CHECK_END_OF_LINE; + + PROCEDURE CHECK_END_OF_PAGE IS + BEGIN + IF NOT END_OF_PAGE (FILE) THEN + FAILED ("FROM CHECK_FILE: " & + "END_OF_PAGE NOT WHERE EXPECTED"); + RAISE STOP_PROCESSING; + ELSE + IF PAGE_COUNT /= PAGE (FILE) THEN + FAILED ("FROM CHECK_FILE: " & + "PAGE COUNT INCORRECT - EXPECTED " & + POSITIVE_COUNT'IMAGE (PAGE_COUNT) & + " GOT FROM FILE " & + POSITIVE_COUNT'IMAGE (PAGE(FILE))); + END IF; + + SKIP_PAGE (FILE); + PAGE_COUNT := PAGE_COUNT + 1; + LINE_COUNT := 1; + END IF; + END CHECK_END_OF_PAGE; + + BEGIN + + RESET (FILE, IN_FILE); + SET_LINE_LENGTH (STANDARD_OUTPUT, 0); + SET_PAGE_LENGTH (STANDARD_OUTPUT, 0); + + FOR I IN 1 .. CONTENTS'LENGTH LOOP + + BEGIN + CASE CONTENTS (I) IS + WHEN '#' => + CHECK_END_OF_LINE (CONTENTS (I + 1) = '@'); + WHEN '@' => + CHECK_END_OF_PAGE; + WHEN '%' => + IF NOT END_OF_FILE (FILE) THEN + FAILED ("FROM CHECK_FILE: " & + "END_OF_FILE NOT WHERE EXPECTED"); + RAISE STOP_PROCESSING; + END IF; + WHEN OTHERS => + IF COL_COUNT /= COL(FILE) THEN + FAILED ("FROM CHECK_FILE: " & + "COL COUNT INCORRECT - " & + "EXPECTED " & POSITIVE_COUNT' + IMAGE(COL_COUNT) & " GOT FROM " & + "FILE " & POSITIVE_COUNT'IMAGE + (COL(FILE))); + END IF; + GET (FILE, X); + COL_COUNT := COL_COUNT + 1; + IF X /= CONTENTS (I) THEN + FAILED("FROM CHECK_FILE: " & + "FILE DOES NOT CONTAIN CORRECT " & + "OUTPUT - EXPECTED " & CONTENTS(I) + & " - GOT " & X); + RAISE STOP_PROCESSING; + END IF; + END CASE; + EXCEPTION + WHEN STOP_PROCESSING => + COMMENT ("FROM CHECK_FILE: " & + "LAST CHARACTER IN FOLLOWING STRING " & + "REVEALED ERROR: " & CONTENTS (1 .. I)); + EXIT; + END; + + END LOOP; + + EXCEPTION + WHEN STATUS_ERROR => + FAILED ("FROM CHECK_FILE: " & + "STATUS_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN MODE_ERROR => + FAILED ("FROM CHECK_FILE: " & + "MODE_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN NAME_ERROR => + FAILED ("FROM CHECK_FILE: " & + "NAME_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN USE_ERROR => + FAILED ("FROM CHECK_FILE: " & + "USE_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN DEVICE_ERROR => + FAILED ("FROM CHECK_FILE: " & + "DEVICE_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN END_ERROR => + FAILED ("FROM CHECK_FILE: " & + "END_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN DATA_ERROR => + FAILED ("FROM CHECK_FILE: " & + "DATA_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN LAYOUT_ERROR => + FAILED ("FROM CHECK_FILE: " & + "LAYOUT_ERROR RAISED - FILE CHECKING INCOMPLETE"); + WHEN OTHERS => + FAILED ("FROM CHECK_FILE: " & + "SOME EXCEPTION RAISED - FILE CHECKING INCOMPLETE"); + + END CHECK_FILE; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/enumchek.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/enumchek.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/enumchek.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/enumchek.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- THIS GENERIC PROCEDURE IS INTENDED FOR USE IN CONJUNCTION WITH THE ACVC + -- CHAPTER 13 C TESTS. IT IS INSTANTIATED WITH TWO TYPES. THE FIRST IS AN + -- ENUMERATION TYPE FOR WHICH AN ENUMERATION CLAUSE HAS BEEN GIVEN, AND THE + -- SECOND IS AN INTEGER TYPE WHOSE 'SIZE IS THE SAME AS THE 'SIZE OF THIS + -- ENUMERATION TYPE. + + -- THE PROCEDURE ENUM_CHECK IS THEN CALLED WITH THREE ARGUMENTS. THE FIRST IS + -- AN ENUMERATION LITERAL FROM THE ENUMERATION TYPE, THE SECOND IS AN INTEGER + -- LITERAL WHICH IS THE VALUE OF THE EXPECTED REPRESENTATION (TAKEN FROM THE + -- ENUMERATION REPRESENTATION CLAUSE), AND THE THIRD IS A STRING DESCRIBING OR + -- NAMING THE TYPE (USED IN A CALL TO FAILED IF THE REPRESENTATION CHECK FAILS). + + -- THE CHECK IS TO CONVERT THE ENUMERATION VALUE TO A BOOLEAN ARRAY WITH A + -- LENGTH CORRESONDING TO THE 'SIZE OF THE ENUMERATION TYPE. AN INTEGER TYPE + -- IS THEN CREATED WITH THIS SAME 'SIZE, AND THE REQUIRED REPRESENTATION VALUE + -- IS CONVERTED FROM THIS TYPE TO A BOOLEAN ARRAY WITH THE SAME LENGTH. THE + -- TWO BOOLEAN ARRAYS ARE THEN COMPARED AND SHOULD BE EQUAL. THE CONVERSIONS + -- ARE PERFORMED USING APPROPRIATE INSTANTIATIONS OF UNCHECKED_CONVERSION. + + -- AUTHOR: ROBERT B. K. DEWAR, UNCOPYRIGHTED, PUBLIC DOMAIN USE AUTHORIZED + + GENERIC + + TYPE ENUM_TYPE IS PRIVATE; + TYPE INT_TYPE IS RANGE <>; + + PROCEDURE ENUM_CHECK (TEST_VALUE : ENUM_TYPE; + REP_VALUE : INT_TYPE; + TYPE_ID : STRING); + + + WITH UNCHECKED_CONVERSION; + WITH REPORT; USE REPORT; + + PROCEDURE ENUM_CHECK (TEST_VALUE : ENUM_TYPE; + REP_VALUE : INT_TYPE; + TYPE_ID : STRING) IS + + TYPE BIT_ARRAY_TYPE IS ARRAY (1 .. ENUM_TYPE'SIZE) OF BOOLEAN; + PRAGMA PACK (BIT_ARRAY_TYPE); + + FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (ENUM_TYPE, BIT_ARRAY_TYPE); + FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (INT_TYPE, BIT_ARRAY_TYPE); + + BIT_ARRAY_1 : BIT_ARRAY_TYPE; + BIT_ARRAY_2 : BIT_ARRAY_TYPE; + + INT_VALUE : INT_TYPE := INT_TYPE (REP_VALUE); + + BEGIN + + -- VERIFY CORRECT CALL (THIS IS A SANITY CHECK ON THE TEST ITSELF) + + IF ENUM_TYPE'SIZE /= INT_TYPE'SIZE THEN + FAILED ("ERROR IN ENUM_CHECK CALL: SIZES DO NOT MATCH"); + END IF; + + BIT_ARRAY_1 := TO_BITS (TEST_VALUE); + BIT_ARRAY_2 := TO_BITS (INT_VALUE); + + IF BIT_ARRAY_1 /= BIT_ARRAY_2 THEN + FAILED ("CHECK ON REPRESENTATION OF TYPE " & TYPE_ID & " FAILED."); + END IF; + + END ENUM_CHECK; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f340a000.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f340a000.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f340a000.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f340a000.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f340a001.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f340a001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f340a001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f340a001.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f341a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f341a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f341a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f341a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f390a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f390a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f390a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f390a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f392a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f392a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f392a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f392a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,200 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f392c00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f392c00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f392c00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f392c00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f392d00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f392d00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f392d00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f392d00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f393a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f393a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f393a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f393a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f393b00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f393b00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f393b00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f393b00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f3a2a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f3a2a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f3a2a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f3a2a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f460a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f460a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f460a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f460a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f730a000.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f730a000.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f730a000.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f730a000.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f730a001.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f730a001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f730a001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f730a001.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f731a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f731a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f731a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f731a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f940a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f940a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f940a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f940a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/f954a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/f954a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/f954a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/f954a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11b00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11b00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11b00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11b00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11c00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11c00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11c00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11c00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11d00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11d00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa11d00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa11d00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa13a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa13a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa13a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa13a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,171 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa13b00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa13b00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa13b00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa13b00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fa21a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fa21a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fa21a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fa21a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fb20a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fb20a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fb20a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fb20a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fb40a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fb40a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fb40a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fb40a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc50a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc50a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc50a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc50a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51b00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51b00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51b00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51b00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51c00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51c00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51c00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51c00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51d00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51d00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc51d00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc51d00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc54a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc54a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc54a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc54a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70b00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70b00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70b00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70b00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70c00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70c00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fc70c00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fc70c00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fcndecl.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/fcndecl.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fcndecl.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fcndecl.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- FCNDECL.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- PACKAGE THAT MAY BE MODIFIED TO DECLARE FUNCTIONS THAT RETURN + -- VALUES USABLE FOR INITIALIZATION OF CONSTANTS IN PACKAGE SPPRT13. + + WITH SYSTEM; + PACKAGE FCNDECL IS + -- INSERT FUNCTION DECLARATIONS AS NEEDED. + + type Mem is array (1 .. 100) of Long_Long_Integer; + Var0: Mem; + Var1: Mem; + Var2: Mem; + + Var_Addr : constant System.Address := Var0'address; + Var_Addr1: constant System.Address := Var1'address; + Var_Addr2: constant System.Address := Var2'address; + + Ent0: Mem; + Ent1: Mem; + Ent2: Mem; + + Entry_Addr : constant System.Address := Ent0'address; + Entry_Addr1: constant System.Address := Ent0'address; + Entry_Addr2: constant System.Address := Ent0'address; + + END FCNDECL; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fd72a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fd72a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fd72a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fd72a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fdb0a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fdb0a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fdb0a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fdb0a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fdd2a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fdd2a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fdd2a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fdd2a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxa5a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxa5a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxa5a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxa5a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxaca00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxaca00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxaca00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxaca00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxacb00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxacb00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxacb00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxacb00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxacc00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxacc00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxacc00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxacc00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxc6a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxc6a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxc6a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxc6a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,162 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxe2a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxe2a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxe2a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxe2a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxf2a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxf2a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxf2a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxf2a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/fxf3a00.a gcc-3.4.0/gcc/testsuite/ada/acats/support/fxf3a00.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/fxf3a00.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/fxf3a00.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,330 ---- + -- 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'(" new String'(" new String'("< 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/impdef.a gcc-3.4.0/gcc/testsuite/ada/acats/support/impdef.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/impdef.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/impdef.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,371 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefd.a gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefd.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefd.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefd.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefe.a gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefe.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefe.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefe.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefg.a gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefg.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefg.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefg.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefh.a gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefh.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/impdefh.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/impdefh.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/lencheck.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/lencheck.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/lencheck.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/lencheck.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- THIS GENERIC PROCEDURE IS INTENDED FOR USE IN CONJUNCTION WITH THE + -- ACVC CHAPTER 13 C TESTS. IT IS INSTANTIATED FOR A TYPE WHOSE + -- REPRESENTATION IS TO BE CHECKED, AND THEN THE PROCEDURE REP_CHECK + -- IS CALLED WITH TWO ARGUMENTS, THE FIRST IS A VALUE OF THE TYPE TO + -- BE CHECKED, AND THE SECOND IS A STRING DESCRIBING OR NAMING THE + -- TYPE (FOR USE IN A CALL TO FAILED IF THE REPRESENTATION CHECK FAILS) + + -- THE CHECK IS TO CONVERT THE VALUE TO A PACKED BOOLEAN ARRAY WITH A + -- LENGTH CORRESPONDING TO THE 'SIZE OF THE TYPE, AND THEN CONVERT IT + -- BACK AGAIN AND CHECK THAT THE SAME VALUE IS OBTAINED. THE + -- CONVERSIONS ARE PERFORMED USING APPROPRIATE INSTANTIATIONS OF + -- UNCHECKED_CONVERSION. + + -- AUTHOR: ROBERT B. K. DEWAR, UNCOPYRIGHTED, PUBLIC DOMAIN USE + -- AUTHORIZED + -- DHH 03/27/89 CHANGED REP_CHECK TO LENGTH_CHECK BY ADDING A THIRD + -- PARAMETER TO GIVE LENGTH EXPECTED AND BY DOING A BIT TO + -- BIT COPY OF THE UNCHECKED CONVERSION BOOLEAN ARRAY SO + -- A STRAIGHT COMPARE OF THE TWO VALUES CAN BE DONE. + + GENERIC + + TYPE TEST_TYPE IS PRIVATE; + + PROCEDURE LENGTH_CHECK (TEST_VALUE : TEST_TYPE; + EXPECTED_LENGTH : INTEGER; + TYPE_ID : STRING); + + WITH UNCHECKED_CONVERSION; + WITH REPORT; USE REPORT; + + PROCEDURE LENGTH_CHECK (TEST_VALUE : TEST_TYPE; + EXPECTED_LENGTH : INTEGER; + TYPE_ID : STRING) IS + LEN : CONSTANT INTEGER := EXPECTED_LENGTH; + TYPE BIT_ARRAY_TYPE IS ARRAY (1 .. LEN) OF BOOLEAN; + PRAGMA PACK (BIT_ARRAY_TYPE); + TYPE NEW_BIT_ARRAY_TYPE IS ARRAY (1 .. 3) OF BIT_ARRAY_TYPE; + + FUNCTION TO_BITS IS NEW UNCHECKED_CONVERSION (TEST_TYPE, + BIT_ARRAY_TYPE); + FUNCTION FROM_BITS IS NEW UNCHECKED_CONVERSION (BIT_ARRAY_TYPE, + TEST_TYPE); + + BIT_ARRAY : BIT_ARRAY_TYPE := (OTHERS => FALSE); + + BIT_ARRAY_NEW : NEW_BIT_ARRAY_TYPE := (OTHERS => (OTHERS => FALSE)); + BEGIN + + BIT_ARRAY := TO_BITS (TEST_VALUE); + + FOR I IN 1 .. LEN LOOP + BIT_ARRAY_NEW(IDENT_INT(1)) (IDENT_INT(I)) := BIT_ARRAY(I); + END LOOP; + + IF TEST_VALUE /= FROM_BITS (BIT_ARRAY_NEW(1)) THEN + FAILED ("CHECK ON REPRESENTATION FOR " & TYPE_ID & " FAILED."); + END IF; + + END LENGTH_CHECK; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/macrodef.adb gcc-3.4.0/gcc/testsuite/ada/acats/support/macrodef.adb *** gcc-3.3.3/gcc/testsuite/ada/acats/support/macrodef.adb 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/macrodef.adb 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + with Ada.Text_IO; + with System; + procedure Macrodef is + begin + Ada.Text_IO.Put_Line ("Integer'First = " & Integer'Image (Integer'First)); + Ada.Text_IO.Put_Line ("Integer'Last = " & Integer'Image (Integer'Last)); + Ada.Text_IO.Put_Line ("System.Min_Int = " & Long_Long_Integer'Image (System.Min_Int)); + Ada.Text_IO.Put_Line ("System.Max_Int = " & Long_Long_Integer'Image (System.Max_Int)); + Ada.Text_IO.Put_Line ("Ada.Text_IO.Count'Last = " & Ada.Text_IO.Count'Image (Ada.Text_IO.Count'Last)); + Ada.Text_IO.Put_Line ("Ada.Text_IO.Field'Last = " & Ada.Text_IO.Field'Image (Ada.Text_IO.Field'Last)); + end Macrodef; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/macro.dfs gcc-3.4.0/gcc/testsuite/ada/acats/support/macro.dfs *** gcc-3.3.3/gcc/testsuite/ada/acats/support/macro.dfs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/macro.dfs 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,301 ---- + -- MACRO.DFS + -- THIS FILE CONTAINS THE MACRO DEFINITIONS USED IN THE ACVC TESTS. + -- THESE DEFINITIONS ARE USED BY THE ACVC TEST PRE-PROCESSOR, + -- MACROSUB. MACROSUB WILL CALCULATE VALUES FOR THOSE MACRO SYMBOLS + -- WHOSE DEFINITIONS DEPEND ON THE VALUE OF MAX_IN_LEN (NAMELY, THE + -- VALUES OF THE MACRO SYMBOLS BIG_ID1, BIG_ID2, BIG_ID3, BIG_ID4, + -- BIG_STRING1, BIG_STRING2, MAX_STRING_LITERAL, BIG_INT_LIT, BIG_REAL_LIT, + -- AND BLANKS). THEREFORE, ANY VALUES GIVEN IN THIS FILE FOR THOSE + -- MACRO SYMBOLS WILL BE IGNORED BY MACROSUB. + + -- NOTE: AS REQUIRED BY THE MACROSUB PROGRAM, THE FIRST MACRO DEFINED + -- IN THIS FILE IS $MAX_IN_LEN. THE NEXT 5 MACRO DEFINITIONS + -- ARE FOR THOSE MACRO SYMBOLS THAT DEPEND ON THE VALUE OF + -- MAX_IN_LEN. THESE ARE IN ALPHABETIC ORDER. FOLLOWING THESE + -- ARE 36 MORE DEFINITIONS, ALSO IN ALPHABETIC ORDER. + + -- EACH DEFINITION IS ACCORDING TO THE FOLLOWING FORMAT: + + -- A. A NUMBER OF LINES PRECEDED BY THE ADA COMMENT DELIMITER, --. + -- THE FIRST OF THESE LINES CONTAINS THE MACRO SYMBOL AS IT APPEARS + -- IN THE TEST FILES (WITH THE DOLLAR SIGN). THE NEXT FEW "COMMENT" + -- LINES CONTAIN A DESCRIPTION OF THE VALUE TO BE SUBSTITUTED. + -- THE REMAINING "COMMENT" LINES, THE FIRST OF WHICH BEGINS WITH THE + -- WORDS "USED IN: " (NO QUOTES), CONTAIN A LIST OF THE TEST FILES + -- (WITHOUT THE .TST EXTENSION) IN WHICH THE MACRO SYMBOL APPEARS. + -- EACH TEST FILE NAME IS PRECEDED BY ONE OR MORE BLANKS. + -- B. A LINE, WITHOUT THE COMMENT DELIMITER, CONSISTING OF THE + -- IDENTIFIER (WITHOUT THE DOLLAR SIGN) OF THE MACRO SYMBOL, + -- FOLLOWED BY A SPACE OR TAB, FOLLOWED BY THE VALUE TO BE + -- SUBSTITUTED. IN THE DISTRIBUTION FILE, A SAMPLE VALUE IS + -- PROVIDED; THIS VALUE MUST BE REPLACED BY A VALUE APPROPRIATE TO + -- THE IMPLEMENTATION. + + -- DEFINITIONS ARE SEPARATED BY ONE OR MORE EMPTY LINES. + -- THE LIST OF DEFINITIONS BEGINS AFTER THE FOLLOWING EMPTY LINE. + + -- $MAX_IN_LEN + -- AN INTEGER LITERAL GIVING THE MAXIMUM LENGTH PERMITTED BY THE + -- COMPILER FOR A LINE OF ADA SOURCE CODE (NOT INCLUDING AN END-OF-LINE + -- CHARACTER). + -- USED IN: A26007A + MAX_IN_LEN 200 + + -- $MAX_STRING_LITERAL + -- A STRING LITERAL CONSISTING OF $MAX_IN_LEN CHARACTERS (INCLUDING THE + -- QUOTE CHARACTERS). + -- USED IN: A26007A + MAX_STRING_LITERAL "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" + + -- $BIG_ID1 + -- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN. + -- THE MACROSUB PROGRAM WILL SUPPLY AN IDENTIFIER IN WHICH THE + -- LAST CHARACTER IS '1' AND ALL OTHERS ARE 'A'. + -- USED IN: C23003A C23003B C23003G C23003I + -- C35502D C35502F + BIG_ID1 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA1 + + -- $BIG_ID2 + -- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN, + -- DIFFERING FROM $BIG_ID1 ONLY IN THE LAST CHARACTER. THE MACROSUB + -- PROGRAM WILL USE '2' AS THE LAST CHARACTER. + -- USED IN: C23003A C23003B B23003F C23003G C23003I + BIG_ID2 AAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAA2 + + -- $BIG_ID3 + -- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN. + -- MACROSUB WILL USE '3' AS THE "MIDDLE" CHARACTER; ALL OTHERS ARE 'A'. + -- USED IN: C23003A C23003B C23003G C23003I + BIG_ID3 AAAAAAAAAAAAAAAAAAAAAAAAAAAAA3AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + + -- $BIG_ID4 + -- AN IDENTIFIER IN WHICH THE NUMBER OF CHARACTERS IS $MAX_IN_LEN, + -- DIFFERING FROM $BIG_ID3 ONLY IN THE MIDDLE CHARACTER. MACROSUB + -- WILL USE '4' AS THE MIDDLE CHARACTER. + -- USED IN: C23003A C23003B C23003G C23003I + BIG_ID4 AAAAAAAAAAAAAAAAAAAAAAAAAAAAA4AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA + + -- $BIG_STRING1 + -- A STRING LITERAL (WITH QUOTES) WHOSE CATENATION WITH $BIG_STRING2 + -- ($BIG_STRING1 & $BIG_STRING2) PRODUCES THE IMAGE OF $BIG_ID1. + -- USED IN: C35502D C35502F + BIG_STRING1 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAAA" + + -- $BIG_STRING2 + -- A STRING LITERAL (WITH QUOTES) WHOSE CATENATION WITH $BIG_STRING1 + -- ($BIG_STRING1 & $BIG_STRING2) PRODUCES THE IMAGE OF $BIG_ID1. + -- USED IN: C35502D C35502F + BIG_STRING2 "AAAAAAAAAAAAAAAAAAAAAAAAAAAAA1" + + -- $BLANKS + -- A SEQUENCE OF ($MAX_IN_LEN - 20) BLANKS. + -- USED IN: B22001A B22001B B22001C B22001D B22001E B22001F + -- B22001G B22001I B22001J B22001K B22001L B22001M + -- B22001N + -- < LIMITS OF SAMPLE SHOWN BY ANGLE BRACKETS > + BLANKS + + -- $ACC_SIZE + -- AN INTEGER LITERAL WHOSE VALUE IS THE MINIMUM NUMBER OF BITS + -- SUFFICIENT TO HOLD ANY VALUE OF AN ACCESS TYPE. + -- USED IN: CD2A83C BD2A02A + ACC_SIZE 32 + + -- $ALIGNMENT + -- A VALUE THAT IS LEGITIMATE FOR USE IN A RECORD ALIGNMENT CLAUSE. + -- USED IN: CD4041A BD4006A + ALIGNMENT 4 + + -- $COUNT_LAST + -- AN INTEGER LITERAL WHOSE VALUE IS TEXT_IO.COUNT'LAST. + -- USED IN: CE3002B + COUNT_LAST 2147483647 + + -- $ENTRY_ADDRESS + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY + -- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION. + -- USED IN: SPPRT13SP + ENTRY_ADDRESS ENTRY_ADDR + + -- $ENTRY_ADDRESS1 + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY + -- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION. THE ADDRESS + -- MUST BE DISTINCT FROM THAT USED IN $ENTRY_ADDRESS. + -- USED IN: SPPRT13SP + ENTRY_ADDRESS1 ENTRY_ADDR1 + + -- $ENTRY_ADDRESS2 + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A TASK ENTRY + -- (I.E., FOR AN INTERRUPT) FOR THIS IMPLEMENTATION. THE ADDRESS + -- MUST BE DISTINCT FROM THOSE USED IN $ENTRY_ADDRESS + -- AND $ENTRY_ADDRESS1. + -- USED IN: SPPRT13SP + ENTRY_ADDRESS2 ENTRY_ADDR2 + + -- $FIELD_LAST + -- AN INTEGER LITERAL WHOSE VALUE IS TEXT_IO.FIELD'LAST. + -- USED IN: CE3002C + FIELD_LAST 255 + + -- $FORM_STRING + -- A STRING LITERAL SPECIFYING THAT THE EXTERNAL FILE MEETS BOTH + -- CONDITIONS: (1) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT + -- AN APPROPRIATE LINE-LENGTH FOR THE FILE, (2) THERE IS A VALUE + -- OF TYPE TEXT_IO.COUNT THAT IS NOT AN APPROPRIATE PAGE-LENGTH + -- FOR THE FILE. + -- IF IT IS NOT POSSIBLE TO SATISFY BOTH CONDITIONS, THEN SUBSTITUTE + -- A STRING LITERAL SPECIFYING THAT THE EXTERNAL FILE SATISFIES ONE + -- OF THE CONDITIONS. IF IT IS NOT POSSIBLE TO SATISFY EITHER CONDITION, + -- THEN SUBSTITUTE THE NULL STRING (""). + -- USED IN: CE3304A + FORM_STRING "" + + -- $FORM_STRING2 + -- A STRING LITERAL SPECIFYING THAT THE CAPACITY OF THE FILE IS + -- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION + -- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL + -- "CANNOT_RESTRICT_FILE_CAPACITY". + -- USED IN: CE2203A CE2403A + FORM_STRING2 "CANNOT_RESTRICT_FILE_CAPACITY" + + -- $GREATER_THAN_DURATION + -- A REAL LITERAL WHOSE VALUE (NOT SUBJECT TO ROUND-OFF ERROR + -- IF POSSIBLE) LIES BETWEEN DURATION'BASE'LAST AND DURATION'LAST. IF + -- NO SUCH VALUES EXIST, USE A VALUE IN DURATION'RANGE. + -- USED IN: C96005B + GREATER_THAN_DURATION 86_000.0 + + + + + -- $ILLEGAL_EXTERNAL_FILE_NAME1 + -- AN ILLEGAL EXTERNAL FILE NAME (E.G., TOO LONG, CONTAINING INVALID + -- CHARACTERS, CONTAINING WILD-CARD CHARACTERS, OR SPECIFYING A + -- NONEXISTENT DIRECTORY). + -- USED IN: CE2102C CE2102H CE2103A CE2103B CE3102B CE3107A + ILLEGAL_EXTERNAL_FILE_NAME1 /NODIRECTORY/FILENAME + + -- $ILLEGAL_EXTERNAL_FILE_NAME2 + -- AN ILLEGAL EXTERNAL FILE NAME, DIFFERENT FROM $ILLEGAL_EXTERNAL_FILE_NAME1. + -- USED IN: CE2102C CE2102H CE2103A CE2103B CE3102B + ILLEGAL_EXTERNAL_FILE_NAME2 /@@/@@/@@\@@\@@\@@ + + -- $INAPPROPRIATE_LINE_LENGTH + -- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE LINE-LENGTH + -- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1. + -- USED IN: CE3304A + INAPPROPRIATE_LINE_LENGTH -1 + + -- $INAPPROPRIATE_PAGE_LENGTH + -- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE PAGE-LENGTH + -- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1. + -- USED IN: CE3304A + INAPPROPRIATE_PAGE_LENGTH -1 + + -- $INTEGER_FIRST + -- AN INTEGER LITERAL, WITH SIGN, WHOSE VALUE IS INTEGER'FIRST. + -- THE LITERAL MUST NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING + -- BLANKS. + -- USED IN: C35503F B54B01B + INTEGER_FIRST -2147483648 + + -- $INTEGER_LAST + -- AN INTEGER LITERAL WHOSE VALUE IS INTEGER'LAST. THE LITERAL MUST + -- NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING BLANKS. + -- USED IN: C35503F B54B01B + INTEGER_LAST 2147483647 + + + -- $LESS_THAN_DURATION + -- A REAL LITERAL (WITH SIGN) WHOSE VALUE (NOT SUBJECT TO + -- ROUND-OFF ERROR IF POSSIBLE) LIES BETWEEN DURATION'BASE'FIRST AND + -- DURATION'FIRST. IF NO SUCH VALUES EXIST, USE A VALUE IN + -- DURATION'RANGE. + -- USED IN: C96005B + LESS_THAN_DURATION -86_400.0 + + + -- $MACHINE_CODE_STATEMENT + -- A VALID MACHINE CODE STATEMENT AS SPECIFIED IN THE PACKAGE + -- MACHINE_CODE. IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE + -- CODE THEN USE THE ADA NULL STATEMENT (I.E. NULL; ). + -- USED IN: AD8011A BD8001A BD8002A BD8004A BD8004B + MACHINE_CODE_STATEMENT Asm_Insn'(Asm ("nop")); + + -- $MAX_INT + -- AN INTEGER LITERAL WHOSE VALUE IS SYSTEM.MAX_INT. + -- THE LITERAL MUST NOT INCLUDE UNDERSCORES OR LEADING OR TRAILING + -- BLANKS. + -- USED IN: C35503D C35503F C4A007A + MAX_INT 9223372036854775807 + + + -- $MIN_INT + -- AN INTEGER LITERAL, WITH SIGN, WHOSE VALUE IS SYSTEM.MIN_INT. + -- THE LITERAL MUST NOT CONTAIN UNDERSCORES OR LEADING OR TRAILING + -- BLANKS. + -- USED IN: C35503D C35503F + MIN_INT -9223372036854775808 + + -- $NAME + -- THE NAME OF A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, + -- SHORT_INTEGER, OR LONG_INTEGER. + -- (IMPLEMENTATIONS WHICH HAVE NO SUCH TYPES SHOULD USE AN UNDEFINED + -- IDENTIFIER SUCH AS NO_SUCH_TYPE_AVAILABLE.) + -- USED IN: C45231D CD7101G + NAME LONG_LONG_INTEGER + + -- $OPTIONAL_DISC + -- A DISCRIMINANT USED AS THE DISCRIMINANT PART OF $RECORD_NAME. + -- IF MACHINE CODE INSERTIONS ARE NOT SUPPORTED THEN SUBSTITUTE + -- NO_SUCH_MACHINE_CODE_DISC. + -- USED IN: BD8002A + OPTIONAL_DISC + + -- $RECORD_DEFINITION + -- THE RECORD TYPE DEFINITION (WITH FINAL SEMICOLON) FOR THE TYPE THAT + -- WAS USED IN THE MACRO $RECORD_NAME, AS DECLARED IN PACKAGE + -- MACHINE_CODE. IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE CODE, + -- THEN USE A NULL RECORD DEFINITION + -- USED IN: BD8002A + RECORD_DEFINITION RECORD ASM : STRING (1..4); END RECORD; + + -- $RECORD_NAME + -- A VALID RECORD TYPE NAME THAT IS DEFINED IN PACKAGE MACHINE_CODE. + -- IF THE IMPLEMENTATION DOES NOT SUPPORT MACHINE CODE THEN + -- USE THE NAME "NO_SUCH_MACHINE_CODE_TYPE" + -- USED IN: BD8002A + RECORD_NAME Asm_Insn + + -- $TASK_SIZE + -- AN INTEGER LITERAL WHOSE VALUE IS THE NUMBER OF BITS REQUIRED TO + -- HOLD A TASK OBJECT. + -- USED IN: CD2A91C + TASK_SIZE 32 + + -- $TASK_STORAGE_SIZE + -- THE NUMBER OF STORAGE UNITS REQUIRED FOR A TASK ACTIVATION. + -- USED IN: BD2C01D BD2C02A BD2C03A C87B62D CD1009K CD1009T + -- CD1009U CD1C03E CD1C06A CD2C11A CC1225A CD2C11D + TASK_STORAGE_SIZE 1024 + + -- $VARIABLE_ADDRESS + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS + -- IMPLEMENTATION. + -- USED IN: SPPRT13SP + VARIABLE_ADDRESS VAR_ADDR + + -- $VARIABLE_ADDRESS1 + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS + -- IMPLEMENTATION. THE ADDRESS MUST BE DISTINCT FROM THAT USED IN + -- THE MACRO $VARIABLE_ADDRESS. + -- USED IN: SPPRT13SP + VARIABLE_ADDRESS1 VAR_ADDR1 + + -- $VARIABLE_ADDRESS2 + -- AN EXPRESSION YIELDING A LEGAL ADDRESS FOR A VARIABLE FOR THIS + -- IMPLEMENTATION. THE ADDRESS MUST BE DISTINCT FROM THOSE USED IN + -- THE MACROS $VARIABLE_ADDRESS AND $VARIABLE_ADDRESS1. + -- USED IN: SPPRT13SP + VARIABLE_ADDRESS2 VAR_ADDR2 + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/macrosub.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/macrosub.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/macrosub.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/macrosub.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,548 ---- + -- MACROSUB.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + ----------------------------------------------------------------------- + -- -- + -- THIS PROGRAM IS CALLED MACROSUB. IT IS USED TO REPLACE THE -- + -- MACROS IN THE ACVC TEST SUITE WITH THEIR PROPER VALUES. THE -- + -- STEPS LISTED BELOW SHOULD BE FOLLOWED TO ENSURE PROPER RUNNING -- + -- OF THE MACROSUB PROGRAM: -- + -- -- + -- 1) Edit the file MACRO.DFS (included with the testtape) -- + -- and insert your macro values. The macros which use -- + -- the value of MAX_IN_LEN are calculated automatically -- + -- and do not need to be entered. -- + -- -- + -- 2) Create a file called TSTTESTS.DAT which includes all -- + -- of the .TST test file names and their directory -- + -- specifications, if necessary. If a different name -- + -- other than TSTTESTS.DAT is used, this name must be -- + -- substituted in the MACROSUB.ADA file. -- + -- -- + -- 3) Compile and link MACROSUB. -- + -- -- + -- 4) Run the MACROSUB program. -- + -- -- + -- WHEN THE PROGRAM FINISHES RUNNING, THE MACROS WILL HAVE BEEN -- + -- REPLACED WITH THE APPROPRIATE VALUES FROM MACRO.DFS. -- + -- -- + -- -- + -- -- + -- HISTORY: -- + -- BCB 04/17/90 CHANGED MODE OF CALC_MAX_VALS TO OUT. CHANGED -- + -- VALUE OF MAX_VAL_LENGTH FROM 512 TO 400. ADDED -- + -- EXCEPTION HANDLER SO PROGRAM DOES NOT CRASH IF -- + -- AN EXCEPTION IS RAISED. ADDED MESSAGES TO -- + -- REPORT PROGRESS OF PROGRAM. CHANGED PROGRAM SO -- + -- IT DOES NOT ABORT IF A FILE CANNOT BE FOUND. -- + -- MODIFIED PROGRAM SO IT ACCEPTS FILENAMES WITH -- + -- VERSION NUMBERS. -- + ----------------------------------------------------------------------- + + WITH TEXT_IO; + USE TEXT_IO; + + PACKAGE DEFS IS + + ----------------------------------------------------------------------- + -- -- + -- THIS PACKAGE IS USED BY MACROSUB.ADA, PARSEMAC.ADA, AND BY -- + -- GETSUBS.ADA. THE PACKAGE CONTAINS VARIABLE DECLARATIONS WHICH -- + -- NEED TO BE KNOWN BY ALL OF THE PROCEDURES AND PACKAGES WHICH -- + -- MAKE UP THE PROGRAM. -- + -- -- + ----------------------------------------------------------------------- + + MAX_VAL_LENGTH : CONSTANT INTEGER := 400; + + SUBTYPE VAL_STRING IS STRING (1..MAX_VAL_LENGTH); + + TYPE REC_TYPE IS RECORD + MACRO_NAME : STRING (1..80); + NAME_LENGTH, VALUE_LENGTH : INTEGER; + MACRO_VALUE : VAL_STRING; + END RECORD; + + TYPE TABLE_TYPE IS ARRAY (1..100) OF REC_TYPE; + + SYMBOL_TABLE : TABLE_TYPE; + + NUM_MACROS : INTEGER; + + END DEFS; + + WITH TEXT_IO; + USE TEXT_IO; + WITH DEFS; + USE DEFS; + + PACKAGE GETSUBS IS + + ------------------------------------------------------------------------ + -- -- + -- THIS PACKAGE IS USED BY MACROSUB.ADA FOR READING FROM MACRO.DFS -- + -- THE VALUES FOR THE MACRO SUBSTITUTIONS FOR A TEST TAPE. -- + -- -- + ------------------------------------------------------------------------ + + MAC_FILE, LINE_LEN : EXCEPTION; + + PROCEDURE CALC_MAX_VALS(INDEX, LENGTH, MAX_IN_LEN : IN INTEGER; + CALCULATED : OUT BOOLEAN); + + PROCEDURE FILL_TABLE; + + END GETSUBS; + + PACKAGE BODY GETSUBS IS + + ----------------------------------------------------------------------- + -- -- + -- PROCEDURE CALC_MAX_VALS CALCULATES THE VALUE FOR THE MACRO -- + -- READ FROM MACRO.DFS IF ITS LENGTH IS EQUAL OR NEARLY EQUAL TO -- + -- MAX_IN_LEN. IT THEN RETURNS A FLAG SET TO TRUE IF A VALUE WAS -- + -- CALCULATED, FALSE IF ONE WAS NOT. -- + -- -- + ----------------------------------------------------------------------- + + PROCEDURE CALC_MAX_VALS(INDEX, LENGTH, MAX_IN_LEN : IN INTEGER; + CALCULATED : OUT BOOLEAN) IS + + BEGIN + + IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = "BIG_ID1" + THEN SYMBOL_TABLE (INDEX).MACRO_VALUE (1..MAX_IN_LEN) := + (1..(MAX_IN_LEN-1) => 'A') & "1"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_ID2" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN) := (1..(MAX_IN_LEN-1) => 'A') & "2"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_ID3" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN) := (1..(MAX_IN_LEN + 1)/2 => 'A') & "3" & + ((MAX_IN_LEN + 1)/2 + 2..MAX_IN_LEN => 'A'); + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_ID4" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN) := (1..(MAX_IN_LEN + 1)/2 => 'A') & "4" & + ((MAX_IN_LEN + 1)/2 + 2..MAX_IN_LEN => 'A'); + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_STRING1" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..(MAX_IN_LEN + 1)/2 + 2) := + '"' & (1..(MAX_IN_LEN + 1)/2 => 'A') & '"'; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_STRING2" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN - (MAX_IN_LEN + 1)/2 + 2) := + '"' & (2..MAX_IN_LEN - (MAX_IN_LEN + 1)/2 => 'A') & + '1' & '"'; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "MAX_STRING_LITERAL" THEN SYMBOL_TABLE (INDEX). + MACRO_VALUE (1..MAX_IN_LEN) := '"' & + (1..MAX_IN_LEN-2 => 'A') & '"'; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_INT_LIT" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN) := (1..MAX_IN_LEN-3 => '0') & "298"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_REAL_LIT" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN) := (1..MAX_IN_LEN-5 => '0') & "690.0"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "MAX_LEN_INT_BASED_LITERAL" THEN + SYMBOL_TABLE (INDEX). + MACRO_VALUE (1..MAX_IN_LEN) := "2:" & + (1..MAX_IN_LEN - 5 => '0') & "11:"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "MAX_LEN_REAL_BASED_LITERAL" THEN SYMBOL_TABLE (INDEX). + MACRO_VALUE (1..MAX_IN_LEN) := "16:" & + (1..MAX_IN_LEN - 7 => '0') & "F.E:"; + CALCULATED := TRUE; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BLANKS" THEN SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..MAX_IN_LEN-20) := (1..MAX_IN_LEN-20 => ' '); + CALCULATED := TRUE; + ELSE + CALCULATED := FALSE; + END IF; + IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BLANKS" THEN SYMBOL_TABLE (INDEX).VALUE_LENGTH := + MAX_IN_LEN - 20; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_STRING1" THEN + SYMBOL_TABLE (INDEX).VALUE_LENGTH := + (MAX_IN_LEN + 1)/2 + 2; + ELSIF SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) = + "BIG_STRING2" THEN + SYMBOL_TABLE (INDEX).VALUE_LENGTH := + MAX_IN_LEN - (MAX_IN_LEN + 1)/2 + 2; + ELSE SYMBOL_TABLE (INDEX).VALUE_LENGTH := MAX_IN_LEN; + END IF; + END CALC_MAX_VALS; + + ----------------------------------------------------------------------- + -- -- + -- PROCEDURE FILL_TABLE READS THE MACRO NAMES AND MACRO VALUES IN -- + -- FROM MACRO.DFS AND STORES THEM IN THE SYMBOL TABLE. PROCEDURE -- + -- CALC_MAX_VALS IS CALLED TO DETERMINE IF THE MACRO VALUE SHOULD -- + -- BE CALCULATED OR READ FROM MACRO.DFS. -- + -- -- + ----------------------------------------------------------------------- + + PROCEDURE FILL_TABLE IS + + INFILE1 : FILE_TYPE; + MACRO_FILE : CONSTANT STRING := "MACRO.DFS"; + A_LINE : VAL_STRING; + I, INDEX, LENGTH, HOLD, A_LENGTH, NAME : INTEGER; + MAX_IN_LEN : INTEGER := 1; + CALCULATED : BOOLEAN; + + BEGIN + INDEX := 1; + BEGIN + OPEN (INFILE1, IN_FILE, MACRO_FILE); + EXCEPTION + WHEN NAME_ERROR => + PUT_LINE ("** ERROR: MACRO FILE " & MACRO_FILE & + " NOT FOUND."); + RAISE MAC_FILE; + END; + WHILE NOT END_OF_FILE (INFILE1) LOOP + GET_LINE (INFILE1, A_LINE, A_LENGTH); + IF A_LENGTH > 0 AND A_LINE (1..2) /= "--" AND + A_LINE (1) /= ' ' AND A_LINE (1) /= ASCII.HT THEN + I := 1; + WHILE I <= A_LENGTH AND THEN + ((A_LINE (I) IN 'A'..'Z') OR + (A_LINE (I) IN '0'..'9') OR + A_LINE (I) = '_') LOOP + I := I + 1; + END LOOP; + I := I - 1; + LENGTH := I; + BEGIN + SYMBOL_TABLE (INDEX).MACRO_NAME (1..LENGTH) := + A_LINE (1..I); + EXCEPTION + WHEN CONSTRAINT_ERROR => + PUT_LINE ("** ERROR: LINE LENGTH IS " & + "GREATER THAN MAX_VAL_LENGTH."); + RAISE LINE_LEN; + END; + SYMBOL_TABLE (INDEX).NAME_LENGTH := I; + CALC_MAX_VALS (INDEX, LENGTH, MAX_IN_LEN, + CALCULATED); + IF NOT CALCULATED THEN + I := I + 1; + WHILE A_LINE (I) = ' ' OR A_LINE (I) = + ASCII.HT LOOP + I := I + 1; + IF SYMBOL_TABLE (INDEX).MACRO_NAME + (1..LENGTH) = "BLANKS" THEN + EXIT; + END IF; + END LOOP; + HOLD := I; + + -- MACRO VALUE BEGINS AT POSITION HOLD. + -- NOW FIND WHERE IT ENDS BY STARTING AT THE END OF THE INPUT + -- LINE AND SEARCHING BACKWARD FOR A NON-BLANK. + + I := A_LENGTH; + WHILE I > HOLD AND THEN (A_LINE (I) = ' ' + OR A_LINE(I) = ASCII.HT) LOOP + I := I - 1; + END LOOP; + LENGTH := I - HOLD + 1; + SYMBOL_TABLE (INDEX).MACRO_VALUE (1..LENGTH) + := A_LINE (HOLD..I); + SYMBOL_TABLE (INDEX).VALUE_LENGTH := LENGTH; + NAME := SYMBOL_TABLE (INDEX).NAME_LENGTH; + IF SYMBOL_TABLE (INDEX).MACRO_NAME (1..NAME) = + "MAX_IN_LEN" THEN MAX_IN_LEN := + INTEGER'VALUE (SYMBOL_TABLE (INDEX). + MACRO_VALUE (1..LENGTH)); + END IF; + END IF; + INDEX := INDEX + 1; + END IF; + END LOOP; + NUM_MACROS := INDEX - 1; + CLOSE (INFILE1); + END FILL_TABLE; + + BEGIN + NULL; + END GETSUBS; + + WITH TEXT_IO; + USE TEXT_IO; + WITH DEFS; + USE DEFS; + + PACKAGE PARSEMAC IS + + ------------------------------------------------------------------------ + -- -- + -- THIS PACKAGE IS USED BY MACROSUB.ADA FOR FINDING A MACRO TO -- + -- SUBSTITUTE. MACRO SUBSTITUTIONS ARE MADE IN *.TST TESTS IN THE -- + -- ACVC TEST SUITE. THIS PROCEDURE IS CURRENTLY SET UP FOR ACVC -- + -- VERSION 1.10. -- + -- -- + ------------------------------------------------------------------------ + + PROCEDURE LOOK_FOR_MACRO (A_LINE : IN STRING; + A_LENGTH : IN INTEGER; + PTR : IN OUT INTEGER; + MACRO : OUT STRING; + MACRO_LEN : IN OUT INTEGER); + + + PROCEDURE WHICH_MACRO (MACRO : IN STRING; + MACRO_LEN : IN INTEGER; + TEMP_MACRO : OUT STRING; + TEMP_MACRO_LEN : IN OUT INTEGER); + + END PARSEMAC; + + PACKAGE BODY PARSEMAC IS + + ----------------------------------------------------------------------- + -- PROCEDURE LOOK_FOR_MACRO LOOKS FOR A DOLLAR SIGN WHICH SIGNALS -- + -- THE START OF A MACRO IN THE *.TST FILES. IT THEN COUNTS -- + -- CHARACTERS UNTIL A , , OR <_> IS NOT FOUND. -- + -- RETURN PARAMETERS SEND THE BEGINNING POINTER AND LENGTH OF THE -- + -- MACRO BACK TO THE MAIN PROGRAM. ALSO RETURNED IS THE MACRO -- + -- STRING. -- + ----------------------------------------------------------------------- + + PROCEDURE LOOK_FOR_MACRO (A_LINE : IN STRING; + A_LENGTH : IN INTEGER; + PTR : IN OUT INTEGER; + MACRO : OUT STRING; + MACRO_LEN : IN OUT INTEGER) IS + + II, J : INTEGER := INTEGER'LAST; + + BEGIN + FOR I IN PTR..A_LENGTH LOOP + IF A_LINE (I) = '$' THEN + II := I+1; + EXIT; + END IF; + II := I; + END LOOP; + IF II < A_LENGTH THEN -- DOLLAR SIGN IS FOUND. + J := II; + WHILE J <= A_LENGTH AND THEN ((A_LINE(J) IN 'A'..'Z') OR + (A_LINE(J) IN '0'..'9') OR + A_LINE(J) = '_') LOOP + J := J+1; + END LOOP; + J := J-1; + MACRO_LEN := (J-II+1); + MACRO (1..MACRO_LEN) := A_LINE (II .. J); + -- DON'T INCLUDE THE DOLLAR SIGN + PTR := J+1; + ELSE + MACRO_LEN := 0; + END IF; + RETURN; + END LOOK_FOR_MACRO; + + ------------------------------------------------------------------------ + -- PROCEDURE WHICH_MACRO COMPARES THE INPUT MACRO STRING TO A -- + -- VALUE READ FROM MACRO.DFS AND STORED IN THE SYMBOL TABLE AND -- + -- RETURNS THE MACRO SUBSTITUTION STRING BACK TO THE MAIN PROGRAM. -- + ------------------------------------------------------------------------ + + PROCEDURE WHICH_MACRO (MACRO : IN STRING; + MACRO_LEN : IN INTEGER; + TEMP_MACRO : OUT STRING; + TEMP_MACRO_LEN : IN OUT INTEGER) IS + + BEGIN + FOR INDEX IN 1 .. NUM_MACROS LOOP + IF MACRO (1..MACRO_LEN) = + SYMBOL_TABLE (INDEX).MACRO_NAME + (1..SYMBOL_TABLE (INDEX).NAME_LENGTH) THEN + TEMP_MACRO_LEN := + SYMBOL_TABLE (INDEX).VALUE_LENGTH; + TEMP_MACRO (1..TEMP_MACRO_LEN) := + SYMBOL_TABLE (INDEX).MACRO_VALUE + (1..TEMP_MACRO_LEN); + EXIT; + END IF; + IF INDEX = NUM_MACROS THEN + PUT_LINE ("** ERROR: MACRO " & MACRO (1..MACRO_LEN) + & " NOT FOUND. UPDATE PROGRAM."); + TEMP_MACRO_LEN := MACRO_LEN; + TEMP_MACRO (1..TEMP_MACRO_LEN) := + MACRO (1..MACRO_LEN); + END IF; + END LOOP; + + END WHICH_MACRO; + + BEGIN + NULL; + END PARSEMAC; + + WITH TEXT_IO, GETSUBS, PARSEMAC, DEFS; + USE TEXT_IO, GETSUBS, PARSEMAC, DEFS; + + PROCEDURE MACROSUB IS + + ------------------------------------------------------------------------ + -- -- + -- MACROSUB IS THE MAIN PROGRAM THAT CALLS PROCEDURES IN TWO -- + -- PACKAGES, GETSUBS AND PARSEMAC. THIS PROGRAM IS USED TO MAKE -- + -- THE MACRO SUBSTITUTIONS FOR TST TESTS IN THE ACVC TEST SUITE. -- + -- -- + ------------------------------------------------------------------------ + + INFILE1, INFILE2, OUTFILE1 : FILE_TYPE; + FNAME, MACRO : VAL_STRING; + LENGTH, A_LENGTH, PTR, + TEMP_MACRO_LENGTH, MACRO_LEN, FILE_COUNT : INTEGER := 0; + A_LINE, TEMP_MACRO, TEMP_LINE, NEW_LINE : VAL_STRING; + END_OF_LINE_SEARCH, FLAG : BOOLEAN := FALSE; + TESTS_FILE : CONSTANT STRING := "TSTTESTS.DAT"; + TSTTESTS,FILE_CRE : EXCEPTION; + + BEGIN + PUT_LINE ("BEGINNING MACRO SUBSTITUTIONS."); + FILL_TABLE; + BEGIN + OPEN (INFILE2, IN_FILE, TESTS_FILE); + EXCEPTION + WHEN NAME_ERROR => + PUT_LINE ("** ERROR: ERROR DURING OPENING OF " & + "TSTTESTS.DAT"); + RAISE TSTTESTS; + END; + WHILE NOT END_OF_FILE (INFILE2) LOOP + GET_LINE (INFILE2, FNAME, LENGTH); + FILE_COUNT := FILE_COUNT + 1; + BEGIN + OPEN (INFILE1, IN_FILE, FNAME(1..LENGTH)); + EXCEPTION + WHEN NAME_ERROR => + PUT_LINE ("** ERROR: ERROR DURING OPENING OF " & + FNAME(1..LENGTH) & "."); + FLAG := TRUE; + END; + IF NOT FLAG THEN + PUT_LINE ("WORKING ON " & FNAME(1..LENGTH)); + IF FILE_COUNT = 70 THEN + PUT_LINE ("MACRO SUBSTITUTIONS HALF COMPLETED."); + END IF; + FOR I IN REVERSE 1 .. LENGTH LOOP + IF FNAME(I) = ';' THEN + LENGTH := I - 1; + EXIT; + END IF; + END LOOP; + IF FNAME (LENGTH-2..LENGTH) = "TST" THEN + FNAME (LENGTH-2..LENGTH) := "ADT"; + ELSIF FNAME (LENGTH-2..LENGTH) = "tst" THEN + FNAME (LENGTH-2..LENGTH) := "adt"; + END IF; + BEGIN + CREATE (OUTFILE1, OUT_FILE, FNAME (1..LENGTH)); + EXCEPTION + WHEN OTHERS => + PUT_LINE ("** ERROR: EXCEPTION RAISED DURING" & + " ATTEMPTED CREATION OF " & + FNAME(1..LENGTH) & "."); + RAISE FILE_CRE; + END; + WHILE NOT END_OF_FILE (INFILE1) LOOP + GET_LINE (INFILE1, A_LINE, A_LENGTH); + IF A_LENGTH > 0 AND A_LINE(1..2) /= "--" THEN + END_OF_LINE_SEARCH := FALSE; + PTR := 1; + WHILE NOT END_OF_LINE_SEARCH LOOP + LOOK_FOR_MACRO (A_LINE, A_LENGTH, PTR, + MACRO, MACRO_LEN); + IF MACRO_LEN = 0 THEN + END_OF_LINE_SEARCH := TRUE; + ELSE -- SEE WHICH MACRO IT IS + WHICH_MACRO (MACRO, MACRO_LEN, + TEMP_MACRO, TEMP_MACRO_LENGTH); + END IF; + IF NOT END_OF_LINE_SEARCH THEN + IF PTR-MACRO_LEN-2 > 0 THEN + -- IF MACRO IS NOT FIRST ON THE LINE + NEW_LINE (1..PTR-MACRO_LEN-2) + := A_LINE(1..PTR-MACRO_LEN -2); + -- THE OLD LINE UNTIL THE DOLLAR SIGN + END IF; + NEW_LINE(PTR-MACRO_LEN-1 .. + TEMP_MACRO_LENGTH + + (PTR-MACRO_LEN) - 2) := + TEMP_MACRO(1..TEMP_MACRO_LENGTH); + IF PTR <= A_LENGTH THEN + -- IF MACRO IS NOT LAST ON THE LINE + NEW_LINE (TEMP_MACRO_LENGTH + + PTR-MACRO_LEN - 1 .. + TEMP_MACRO_LENGTH - 1 + + A_LENGTH - MACRO_LEN) := + A_LINE (PTR..A_LENGTH); + ELSE + END_OF_LINE_SEARCH := TRUE; + END IF; + A_LENGTH := A_LENGTH + + TEMP_MACRO_LENGTH - + MACRO_LEN - 1; + A_LINE (1..A_LENGTH) := + NEW_LINE (1..A_LENGTH); + PTR := PTR - MACRO_LEN + + TEMP_MACRO_LENGTH - 1; + END IF; + END LOOP; + END IF; + PUT_LINE (OUTFILE1, A_LINE (1..A_LENGTH)); + END LOOP; + CLOSE (OUTFILE1); + CLOSE (INFILE1); + ELSE + FLAG := FALSE; + END IF; + END LOOP; + CLOSE (INFILE2); + PUT_LINE ("MACRO SUBSTITUTIONS COMPLETED."); + EXCEPTION + WHEN MAC_FILE | LINE_LEN | TSTTESTS | FILE_CRE => + NULL; + WHEN OTHERS => + PUT_LINE ("UNEXPECTED EXCEPTION RAISED"); + END MACROSUB; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/repbody.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/repbody.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/repbody.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/repbody.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,329 ---- + -- REPBODY.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- HISTORY: + -- DCB 04/27/80 + -- JRK 6/10/80 + -- JRK 11/12/80 + -- JRK 8/6/81 + -- JRK 10/27/82 + -- JRK 6/1/84 + -- JRK 11/18/85 ADDED PRAGMA ELABORATE. + -- PWB 07/29/87 ADDED STATUS ACTION_REQUIRED AND + -- PROCEDURE SPECIAL_ACTION. + -- TBN 08/20/87 ADDED FUNCTION LEGAL_FILE_NAME. + -- BCB 05/17/90 MODIFIED TO ALLOW OUTPUT TO DIRECT_IO FILE. + -- ADDED TIME-STAMP. + -- LDC 05/17/90 REMOVED OUTPUT TO DIRECT_IO FILE. + -- WMC 08/11/92 UPDATED ACVC VERSION STRING TO "9X BASIC". + -- DTN 07/05/92 UPDATED ACVC VERSION STRING TO + -- "ACVC 2.0 JULY 6 1993 DRAFT". + -- WMC 01/24/94 MODIFIED LEGAL_FILE_NAME TO ALLOW FIVE POSSIBLE + -- FILE NAMES (INCREASED RANGE OF TYPE FILE_NUM TO 1..5). + -- WMC 11/06/94 UPDATED ACVC VERSION STRING TO + -- "ACVC 2.0 NOVEMBER 6 1994 DRAFT". + -- DTN 12/04/94 UPDATED ACVC VERSION STRING TO + -- "ACVC 2.0". + -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_CHAR. + -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_STR. + -- DTN 11/21/95 UPDATED ACVC VERSION STRING TO + -- "ACVC 2.0.1". + -- DTN 12/14/95 UPDATED ACVC VERSION STRING TO + -- "ACVC 2.1". + -- EDS 12/17/97 UPDATED ACVC VERSION STRING TO + -- "2.2". + -- RLB 3/16/00 UPDATED ACATS VERSION STRING TO "2.3". + -- CHANGED VARIOUS STRINGS TO READ "ACATS". + -- RLB 3/22/01 UPDATED ACATS VERSION STRING TO "2.4". + -- RLB 3/29/01 UPDATED ACATS VERSION STRING TO "2.5". + + WITH TEXT_IO, CALENDAR; + USE TEXT_IO, CALENDAR; + PRAGMA ELABORATE (TEXT_IO, CALENDAR); + + PACKAGE BODY REPORT IS + + TYPE STATUS IS (PASS, FAIL, DOES_NOT_APPLY, ACTION_REQUIRED, + UNKNOWN); + + TYPE TIME_INTEGER IS RANGE 0 .. 86_400; + + TEST_STATUS : STATUS := FAIL; + + MAX_NAME_LEN : CONSTANT := 15; -- MAXIMUM TEST NAME LENGTH. + TEST_NAME : STRING (1..MAX_NAME_LEN); + + NO_NAME : CONSTANT STRING (1..7) := "NO_NAME"; + TEST_NAME_LEN : INTEGER RANGE 0..MAX_NAME_LEN := 0; + + + + ACATS_VERSION : CONSTANT STRING := "2.5"; + -- VERSION OF ACATS BEING RUN (X.XX). + + PROCEDURE PUT_MSG (MSG : STRING) IS + -- WRITE MESSAGE. LONG MESSAGES ARE FOLDED (AND INDENTED). + MAX_LEN : CONSTANT INTEGER RANGE 50..150 := 72; -- MAXIMUM + -- OUTPUT LINE LENGTH. + INDENT : CONSTANT INTEGER := TEST_NAME_LEN + 9; -- AMOUNT TO + -- INDENT CONTINUATION LINES. + I : INTEGER := 0; -- CURRENT INDENTATION. + M : INTEGER := MSG'FIRST; -- START OF MESSAGE SLICE. + N : INTEGER; -- END OF MESSAGE SLICE. + BEGIN + LOOP + IF I + (MSG'LAST-M+1) > MAX_LEN THEN + N := M + (MAX_LEN-I) - 1; + IF MSG (N) /= ' ' THEN + WHILE N >= M AND THEN MSG (N+1) /= ' ' LOOP + N := N - 1; + END LOOP; + IF N < M THEN + N := M + (MAX_LEN-I) - 1; + END IF; + END IF; + ELSE N := MSG'LAST; + END IF; + SET_COL (STANDARD_OUTPUT, TEXT_IO.COUNT (I+1)); + PUT_LINE (STANDARD_OUTPUT, MSG (M..N)); + I := INDENT; + M := N + 1; + WHILE M <= MSG'LAST AND THEN MSG (M) = ' ' LOOP + M := M + 1; + END LOOP; + EXIT WHEN M > MSG'LAST; + END LOOP; + END PUT_MSG; + + FUNCTION TIME_STAMP RETURN STRING IS + TIME_NOW : CALENDAR.TIME; + YEAR, + MONTH, + DAY, + HOUR, + MINUTE, + SECOND : TIME_INTEGER := 1; + + FUNCTION CONVERT (NUMBER : TIME_INTEGER) RETURN STRING IS + STR : STRING (1..2) := (OTHERS => '0'); + DEC_DIGIT : CONSTANT STRING := "0123456789"; + NUM : TIME_INTEGER := NUMBER; + BEGIN + IF NUM = 0 THEN + RETURN STR; + ELSE + NUM := NUM MOD 100; + STR (2) := DEC_DIGIT (INTEGER (NUM MOD 10 + 1)); + NUM := NUM / 10; + STR (1) := DEC_DIGIT (INTEGER (NUM + 1)); + RETURN STR; + END IF; + END CONVERT; + BEGIN + TIME_NOW := CALENDAR.CLOCK; + SPLIT (TIME_NOW, YEAR_NUMBER (YEAR), MONTH_NUMBER (MONTH), + DAY_NUMBER (DAY), DAY_DURATION (SECOND)); + HOUR := SECOND / 3600; + SECOND := SECOND MOD 3600; + MINUTE := SECOND / 60; + SECOND := SECOND MOD 60; + RETURN (CONVERT (TIME_INTEGER (YEAR)) & "-" & + CONVERT (TIME_INTEGER (MONTH)) & "-" & + CONVERT (TIME_INTEGER (DAY)) & " " & + CONVERT (TIME_INTEGER (HOUR)) & ":" & + CONVERT (TIME_INTEGER (MINUTE)) & ":" & + CONVERT (TIME_INTEGER (SECOND))); + END TIME_STAMP; + + PROCEDURE TEST (NAME : STRING; DESCR : STRING) IS + BEGIN + TEST_STATUS := PASS; + IF NAME'LENGTH <= MAX_NAME_LEN THEN + TEST_NAME_LEN := NAME'LENGTH; + ELSE TEST_NAME_LEN := MAX_NAME_LEN; + END IF; + TEST_NAME (1..TEST_NAME_LEN) := + NAME (NAME'FIRST .. NAME'FIRST+TEST_NAME_LEN-1); + + PUT_MSG (""); + PUT_MSG (",.,. " & TEST_NAME (1..TEST_NAME_LEN) & " " & + "ACATS " & ACATS_VERSION & " " & TIME_STAMP); + PUT_MSG ("---- " & TEST_NAME (1..TEST_NAME_LEN) & " " & + DESCR & "."); + END TEST; + + PROCEDURE COMMENT (DESCR : STRING) IS + BEGIN + PUT_MSG (" - " & TEST_NAME (1..TEST_NAME_LEN) & " " & + DESCR & "."); + END COMMENT; + + PROCEDURE FAILED (DESCR : STRING) IS + BEGIN + TEST_STATUS := FAIL; + PUT_MSG (" * " & TEST_NAME (1..TEST_NAME_LEN) & " " & + DESCR & "."); + END FAILED; + + PROCEDURE NOT_APPLICABLE (DESCR : STRING) IS + BEGIN + IF TEST_STATUS = PASS OR TEST_STATUS = ACTION_REQUIRED THEN + TEST_STATUS := DOES_NOT_APPLY; + END IF; + PUT_MSG (" + " & TEST_NAME (1..TEST_NAME_LEN) & " " & + DESCR & "."); + END NOT_APPLICABLE; + + PROCEDURE SPECIAL_ACTION (DESCR : STRING) IS + BEGIN + IF TEST_STATUS = PASS THEN + TEST_STATUS := ACTION_REQUIRED; + END IF; + PUT_MSG (" ! " & TEST_NAME (1..TEST_NAME_LEN) & " " & + DESCR & "."); + END SPECIAL_ACTION; + + PROCEDURE RESULT IS + BEGIN + CASE TEST_STATUS IS + WHEN PASS => + PUT_MSG ("==== " & TEST_NAME (1..TEST_NAME_LEN) & + " PASSED ============================."); + WHEN DOES_NOT_APPLY => + PUT_MSG ("++++ " & TEST_NAME (1..TEST_NAME_LEN) & + " NOT-APPLICABLE ++++++++++++++++++++."); + WHEN ACTION_REQUIRED => + PUT_MSG ("!!!! " & TEST_NAME (1..TEST_NAME_LEN) & + " TENTATIVELY PASSED !!!!!!!!!!!!!!!!."); + PUT_MSG ("!!!! " & (1..TEST_NAME_LEN => ' ') & + " SEE '!' COMMENTS FOR SPECIAL NOTES!!"); + WHEN OTHERS => + PUT_MSG ("**** " & TEST_NAME (1..TEST_NAME_LEN) & + " FAILED ****************************."); + END CASE; + TEST_STATUS := FAIL; + TEST_NAME_LEN := NO_NAME'LENGTH; + TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; + END RESULT; + + FUNCTION IDENT_INT (X : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL (X, X) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN 0; -- NEVER EXECUTED. + END IDENT_INT; + + FUNCTION IDENT_CHAR (X : CHARACTER) RETURN CHARACTER IS + BEGIN + IF EQUAL (CHARACTER'POS(X), CHARACTER'POS(X)) THEN -- ALWAYS + -- EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN '0'; -- NEVER EXECUTED. + END IDENT_CHAR; + + FUNCTION IDENT_WIDE_CHAR (X : WIDE_CHARACTER) RETURN WIDE_CHARACTER IS + BEGIN + IF EQUAL (WIDE_CHARACTER'POS(X), WIDE_CHARACTER'POS(X)) THEN + -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN '0'; -- NEVER EXECUTED. + END IDENT_WIDE_CHAR; + + FUNCTION IDENT_BOOL (X : BOOLEAN) RETURN BOOLEAN IS + BEGIN + IF EQUAL (BOOLEAN'POS(X), BOOLEAN'POS(X)) THEN -- ALWAYS + -- EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN FALSE; -- NEVER EXECUTED. + END IDENT_BOOL; + + FUNCTION IDENT_STR (X : STRING) RETURN STRING IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN ""; -- NEVER EXECUTED. + END IDENT_STR; + + FUNCTION IDENT_WIDE_STR (X : WIDE_STRING) RETURN WIDE_STRING IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN ""; -- NEVER EXECUTED. + END IDENT_WIDE_STR; + + FUNCTION EQUAL (X, Y : INTEGER) RETURN BOOLEAN IS + REC_LIMIT : CONSTANT INTEGER RANGE 1..100 := 3; -- RECURSION + -- LIMIT. + Z : BOOLEAN; -- RESULT. + BEGIN + IF X < 0 THEN + IF Y < 0 THEN + Z := EQUAL (-X, -Y); + ELSE Z := FALSE; + END IF; + ELSIF X > REC_LIMIT THEN + Z := EQUAL (REC_LIMIT, Y-X+REC_LIMIT); + ELSIF X > 0 THEN + Z := EQUAL (X-1, Y-1); + ELSE Z := Y = 0; + END IF; + RETURN Z; + EXCEPTION + WHEN OTHERS => + RETURN X = Y; + END EQUAL; + + FUNCTION LEGAL_FILE_NAME (X : FILE_NUM := 1; + NAM : STRING := "") + RETURN STRING IS + SUFFIX : STRING (2..6); + BEGIN + IF NAM = "" THEN + SUFFIX := TEST_NAME(3..7); + ELSE + SUFFIX := NAM(3..7); + END IF; + + CASE X IS + WHEN 1 => RETURN ('X' & SUFFIX); + WHEN 2 => RETURN ('Y' & SUFFIX); + WHEN 3 => RETURN ('Z' & SUFFIX); + WHEN 4 => RETURN ('V' & SUFFIX); + WHEN 5 => RETURN ('W' & SUFFIX); + END CASE; + END LEGAL_FILE_NAME; + + BEGIN + + TEST_NAME_LEN := NO_NAME'LENGTH; + TEST_NAME (1..TEST_NAME_LEN) := NO_NAME; + + END REPORT; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/repspec.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/repspec.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/repspec.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/repspec.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- REPSPEC.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- PURPOSE: + -- THIS REPORT PACKAGE PROVIDES THE MECHANISM FOR REPORTING THE + -- PASS/FAIL/NOT-APPLICABLE RESULTS OF EXECUTABLE (CLASSES A, C, + -- D, E, AND L) TESTS. + + -- IT ALSO PROVIDES THE MECHANISM FOR GUARANTEEING THAT CERTAIN + -- VALUES BECOME DYNAMIC (NOT KNOWN AT COMPILE-TIME). + + -- HISTORY: + -- JRK 12/13/79 + -- JRK 06/10/80 + -- JRK 08/06/81 + -- JRK 10/27/82 + -- JRK 06/01/84 + -- PWB 07/30/87 ADDED PROCEDURE SPECIAL_ACTION. + -- TBN 08/20/87 ADDED FUNCTION LEGAL_FILE_NAME. + -- BCB 05/17/90 ADDED FUNCTION TIME_STAMP. + -- WMC 01/24/94 INCREASED RANGE OF TYPE FILE_NUM FROM 1..3 TO 1..5. + -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_CHAR. + -- KAS 06/19/95 ADDED FUNCTION IDENT_WIDE_STR. + + PACKAGE REPORT IS + + SUBTYPE FILE_NUM IS INTEGER RANGE 1..5; + + -- THE REPORT ROUTINES. + + PROCEDURE TEST -- THIS ROUTINE MUST BE INVOKED AT THE + -- START OF A TEST, BEFORE ANY OF THE + -- OTHER REPORT ROUTINES ARE INVOKED. + -- IT SAVES THE TEST NAME AND OUTPUTS THE + -- NAME AND DESCRIPTION. + ( NAME : STRING; -- TEST NAME, E.G., "C23001A-AB". + DESCR : STRING -- BRIEF DESCRIPTION OF TEST, E.G., + -- "UPPER/LOWER CASE EQUIVALENCE IN " & + -- "IDENTIFIERS". + ); + + PROCEDURE FAILED -- OUTPUT A FAILURE MESSAGE. SHOULD BE + -- INVOKED SEPARATELY TO REPORT THE + -- FAILURE OF EACH SUBTEST WITHIN A TEST. + ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT FAILED. + -- SHOULD BE PHRASED AS: + -- "(FAILED BECAUSE) ...REASON...". + ); + + PROCEDURE NOT_APPLICABLE -- OUTPUT A NOT-APPLICABLE MESSAGE. + -- SHOULD BE INVOKED SEPARATELY TO REPORT + -- THE NON-APPLICABILITY OF EACH SUBTEST + -- WITHIN A TEST. + ( DESCR : STRING -- BRIEF DESCRIPTION OF WHAT IS + -- NOT-APPLICABLE. SHOULD BE PHRASED AS: + -- "(NOT-APPLICABLE BECAUSE)...REASON...". + ); + + PROCEDURE SPECIAL_ACTION -- OUTPUT A MESSAGE DESCRIBING SPECIAL + -- ACTIONS TO BE TAKEN. + -- SHOULD BE INVOKED SEPARATELY TO GIVE + -- EACH SPECIAL ACTION. + ( DESCR : STRING -- BRIEF DESCRIPTION OF ACTION TO BE + -- TAKEN. + ); + + PROCEDURE COMMENT -- OUTPUT A COMMENT MESSAGE. + ( DESCR : STRING -- THE MESSAGE. + ); + + PROCEDURE RESULT; -- THIS ROUTINE MUST BE INVOKED AT THE + -- END OF A TEST. IT OUTPUTS A MESSAGE + -- INDICATING WHETHER THE TEST AS A + -- WHOLE HAS PASSED, FAILED, IS + -- NOT-APPLICABLE, OR HAS TENTATIVELY + -- PASSED PENDING SPECIAL ACTIONS. + + -- THE DYNAMIC VALUE ROUTINES. + + -- EVEN WITH STATIC ARGUMENTS, THESE FUNCTIONS WILL HAVE DYNAMIC + -- RESULTS. + + FUNCTION IDENT_INT -- AN IDENTITY FUNCTION FOR TYPE INTEGER. + ( X : INTEGER -- THE ARGUMENT. + ) RETURN INTEGER; -- X. + + FUNCTION IDENT_CHAR -- AN IDENTITY FUNCTION FOR TYPE + -- CHARACTER. + ( X : CHARACTER -- THE ARGUMENT. + ) RETURN CHARACTER; -- X. + + FUNCTION IDENT_WIDE_CHAR -- AN IDENTITY FUNCTION FOR TYPE + -- WIDE_CHARACTER. + ( X : WIDE_CHARACTER -- THE ARGUMENT. + ) RETURN WIDE_CHARACTER; -- X. + + FUNCTION IDENT_BOOL -- AN IDENTITY FUNCTION FOR TYPE BOOLEAN. + ( X : BOOLEAN -- THE ARGUMENT. + ) RETURN BOOLEAN; -- X. + + FUNCTION IDENT_STR -- AN IDENTITY FUNCTION FOR TYPE STRING. + ( X : STRING -- THE ARGUMENT. + ) RETURN STRING; -- X. + + FUNCTION IDENT_WIDE_STR -- AN IDENTITY FUNCTION FOR TYPE WIDE_STRING. + ( X : WIDE_STRING -- THE ARGUMENT. + ) RETURN WIDE_STRING; -- X. + + FUNCTION EQUAL -- A RECURSIVE EQUALITY FUNCTION FOR TYPE + -- INTEGER. + ( X, Y : INTEGER -- THE ARGUMENTS. + ) RETURN BOOLEAN; -- X = Y. + + -- OTHER UTILITY ROUTINES. + + FUNCTION LEGAL_FILE_NAME -- A FUNCTION TO GENERATE LEGAL EXTERNAL + -- FILE NAMES. + ( X : FILE_NUM := 1; -- DETERMINES FIRST CHARACTER OF NAME. + NAM : STRING := "" -- DETERMINES REST OF NAME. + ) RETURN STRING; -- THE GENERATED NAME. + + FUNCTION TIME_STAMP -- A FUNCTION TO GENERATE THE TIME AND + -- DATE TO PLACE IN THE OUTPUT OF AN ACVC + -- TEST. + RETURN STRING; -- THE TIME AND DATE. + + END REPORT; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/spprt13s.tst gcc-3.4.0/gcc/testsuite/ada/acats/support/spprt13s.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/support/spprt13s.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/spprt13s.tst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- SPPRT13SP.TST + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- SPECIFICATION FOR PACKAGE SPPRT13 + + -- PURPOSE: + -- THIS PACKAGE CONTAINS CONSTANTS OF TYPE SYSTEM.ADDRESS. + -- THESE CONSTANTS ARE USED BY SELECTED CHAPTER 13 TESTS, + -- BY PARTS OF THE AVAT SYSTEM, AND BY ISOLATED TESTS FOR + -- OTHER CHAPTERS. + + -- MACRO SUBSTITUTIONS: + -- $VARIABLE_ADDRESS, $VARIABLE_ADDRESS1, AND $VARIABLE_ADDRESS2 ARE + -- EXPRESSIONS YIELDING LEGAL ADDRESSES FOR VARIABLES FOR THIS + -- IMPLEMENTATION. + + -- $ENTRY_ADDRESS, $ENTRY_ADDRESS1, AND $ENTRY_ADDRESS2 ARE + -- EXPRESSIONS YIELDING LEGAL ADDRESSES FOR TASK ENTRIES + -- (I.E., FOR INTERRUPTS) FOR THIS IMPLEMENTATION. + + -- IF NO EXPRESSIONS CAN BE GIVEN THAT ARE SATISFACTORY FOR THE + -- VALUES OF THESE CONSTANTS, THEN DECLARE SUITABLE FUNCTIONS + -- IN THE SPECIFICATION OF PACKAGE FCNDECL, CREATE A PACKAGE BODY + -- CONTAINING BODIES FOR THE FUNCTIONS, AND REPLACE THE MACROS WITH + -- APPROPRIATE FUNCTION CALLS. + + WITH FCNDECL; USE FCNDECL; + WITH SYSTEM; + PACKAGE SPPRT13 IS + + VARIABLE_ADDRESS : CONSTANT SYSTEM.ADDRESS := + $VARIABLE_ADDRESS; + VARIABLE_ADDRESS1 : CONSTANT SYSTEM.ADDRESS := + $VARIABLE_ADDRESS1; + VARIABLE_ADDRESS2 : CONSTANT SYSTEM.ADDRESS := + $VARIABLE_ADDRESS2; + + ENTRY_ADDRESS : CONSTANT SYSTEM.ADDRESS := + $ENTRY_ADDRESS; + ENTRY_ADDRESS1 : CONSTANT SYSTEM.ADDRESS := + $ENTRY_ADDRESS1; + ENTRY_ADDRESS2 : CONSTANT SYSTEM.ADDRESS := + $ENTRY_ADDRESS2; + + END SPPRT13; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/tctouch.ada gcc-3.4.0/gcc/testsuite/ada/acats/support/tctouch.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/support/tctouch.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/tctouch.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,264 ---- + -- TCTouch.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FOUNDATION DESCRIPTION: + -- The tools in this foundation are not peculiar to any particular + -- aspect of the language, but simplify the test writing and reading + -- process. Assert and Assert_Not are used to reduce the textual + -- overhead of the test-that-this-condition-is-(not)-true paradigm. + -- Touch and Validate are used to simplify tracing an expected path + -- of execution. + -- A tag comment of the form: + -- + -- TCTouch.Touch( 'A' ); ----------------------------------------- A + -- + -- is recommended to improve readability of this feature. + -- + -- Report.Test must be called before any of the procedures in this + -- package with the exception of Touch. + -- The usage paradigm is to call Touch in locations in the test where you + -- want a trace of execution. Each call to Touch should have a unique + -- character associated with it. At each place where a check can + -- reasonably be performed to determine correct execution of a + -- sub-test, a call to Validate should be made. The first parameter + -- passed to Validate is the expected string of characters produced by + -- call(s) to Touch in the subtest just executed. The second parameter + -- is the message to pass to Report.Failed if the expected sequence was + -- not executed. + -- + -- Validate should always be called after calls to Touch before a test + -- completes. + -- + -- In the event that calls may have been made to Touch that are not + -- intended to be recorded, or, the failure of a previous subtest may + -- leave Touch calls "Unvalidated", the procedure Flush will reset the + -- tracker to the "empty" state. Flush does not make any calls to + -- Report. + -- + -- Calls to Assert and Assert_Not are to replace the idiom: + -- + -- if BadCondition then -- or if not PositiveTest then + -- Report.Failed(Message); + -- end if; + -- + -- with: + -- + -- Assert_Not( BadCondition, Message ); -- or + -- Assert( PositiveTest, Message ); + -- + -- Implementation_Check is for use with tests that cross the boundary + -- between the core and the Special Needs Annexes. There are several + -- instances where language in the core becomes enforceable only when + -- a Special Needs Annex is supported. Implementation_Check should be + -- called in place of Report.Failed in these cases; it examines the + -- constants in Impdef that indicate if the particular Special Needs + -- Annex is being validated with this validation; and acts accordingly. + -- + -- The constant Foundation_ID contains the internal change version + -- for this software. + -- + -- ERROR CONDITIONS: + -- + -- It is an error to perform more than Max_Touch_Count (80) calls to + -- Touch without a subsequent call to Validate. To do so will cause + -- a false test failure. + -- + -- CHANGE HISTORY: + -- 02 JUN 94 SAIC Initial version + -- 27 OCT 94 SAIC Revised version + -- 07 AUG 95 SAIC Added Implementation_Check + -- 07 FEB 96 SAIC Changed to match new Impdef for 2.1 + -- 16 MAR 00 RLB Changed foundation id to reflect test suite version. + -- 22 MAR 01 RLB Changed foundation id to reflect test suite version. + -- 29 MAR 02 RLB Changed foundation id to reflect test suite version. + -- + --! + + package TCTouch is + Foundation_ID : constant String := "TCTouch ACATS 2.5"; + Max_Touch_Count : constant := 80; + + procedure Assert ( SB_True : Boolean; Message : String ); + procedure Assert_Not( SB_False : Boolean; Message : String ); + + procedure Touch ( A_Tag : Character ); + procedure Validate( Expected: String; + Message : String; + Order_Meaningful : Boolean := True ); + + procedure Flush; + + type Special_Needs_Annexes is ( Annex_C, Annex_D, Annex_E, + Annex_F, Annex_G, Annex_H ); + + procedure Implementation_Check( Message : in String; + Annex : in Special_Needs_Annexes + := Annex_C ); + -- If Impdef.Validating_Annex_ is true, will call Report.Failed + -- otherwise will call Report.Not_Applicable. This is to allow tests + -- which are driven by wording in the core of the language, yet have + -- their functionality dictated by the Special Needs Annexes to perform + -- dual purpose. + -- The default of Annex_C for the Annex parameter is to support early + -- tests written with the assumption that Implementation_Check was + -- expressly for use with the Systems Programming Annex. + + end TCTouch; + + with Report; + with Impdef; + package body TCTouch is + + procedure Assert( SB_True : Boolean; Message : String ) is + begin + if not SB_True then + Report.Failed( "Assertion failed: " & Message ); + end if; + end Assert; + + procedure Assert_Not( SB_False : Boolean; Message : String ) is + begin + if SB_False then + Report.Failed( "Assertion failed: " & Message ); + end if; + end Assert_Not; + + Collection : String(1..Max_Touch_Count); + Finger : Natural := 0; + + procedure Touch ( A_Tag : Character ) is + begin + Finger := Finger+1; + Collection(Finger) := A_Tag; + exception + when Constraint_Error => + Report.Failed("Trace Overflow: " & Collection); + Finger := 0; + end Touch; + + procedure Sort_String( S: in out String ) is + -- algorithm from Booch Components Page 472 + No_Swaps : Boolean; + procedure Swap(C1, C2: in out Character) is + T: Character := C1; + begin C1 := C2; C2 := T; end Swap; + begin + for OI in S'First+1..S'Last loop + No_Swaps := True; + for II in reverse OI..S'Last loop + if S(II) < S(II-1) then + Swap(S(II),S(II-1)); + No_Swaps := False; + end if; + end loop; + exit when No_Swaps; + end loop; + end Sort_String; + + procedure Validate( Expected: String; + Message : String; + Order_Meaningful : Boolean := True) is + Want : String(1..Expected'Length) := Expected; + begin + if not Order_Meaningful then + Sort_String( Want ); + Sort_String( Collection(1..Finger) ); + end if; + if Collection(1..Finger) /= Want then + Report.Failed( Message & " Expecting: " & Want + & " Got: " & Collection(1..Finger) ); + end if; + Finger := 0; + end Validate; + + procedure Flush is + begin + Finger := 0; + end Flush; + + procedure Implementation_Check( Message : in String; + Annex : in Special_Needs_Annexes + := Annex_C ) is + -- default to cover some legacy + -- USAGE DISCIPLINE: + -- Implementation_Check is designed to be used in tests that have + -- interdependency on one of the Special Needs Annexes, yet are _really_ + -- tests based in the core language. There will be instances where the + -- execution of a test would be failing in the light of the requirements + -- of the annex, yet from the point of view of the core language without + -- the additional requirements of the annex, the test does not apply. + -- In these cases, rather than issuing a call to Report.Failed, calling + -- TCTouch.Implementation_Check will check that sensitivity, and if + -- the implementation is attempting to validate against the specific + -- annex, Report.Failed will be called, otherwise, Report.Not_Applicable + -- will be called. + begin + + case Annex is + when Annex_C => + if ImpDef.Validating_Annex_C then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex C not supported" ); + end if; + + when Annex_D => + if ImpDef.Validating_Annex_D then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex D not supported" ); + end if; + + when Annex_E => + if ImpDef.Validating_Annex_E then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex E not supported" ); + end if; + + when Annex_F => + if ImpDef.Validating_Annex_F then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex F not supported" ); + end if; + + when Annex_G => + if ImpDef.Validating_Annex_G then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex G not supported" ); + end if; + + when Annex_H => + if ImpDef.Validating_Annex_H then + Report.Failed( Message ); + else + Report.Not_Applicable( Message & " Annex H not supported" ); + end if; + end case; + end Implementation_Check; + + end TCTouch; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/tsttests.dat gcc-3.4.0/gcc/testsuite/ada/acats/support/tsttests.dat *** gcc-3.3.3/gcc/testsuite/ada/acats/support/tsttests.dat 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/tsttests.dat 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + ACATS4GNATDIR/tests/a/a26007a.tst + ACATS4GNATDIR/tests/a/ad8011a.tst + ACATS4GNATDIR/tests/c2/c23003a.tst + ACATS4GNATDIR/tests/c2/c23003b.tst + ACATS4GNATDIR/tests/c2/c23003g.tst + ACATS4GNATDIR/tests/c2/c23003i.tst + ACATS4GNATDIR/tests/c3/c35502d.tst + ACATS4GNATDIR/tests/c3/c35502f.tst + ACATS4GNATDIR/tests/c3/c35503d.tst + ACATS4GNATDIR/tests/c3/c35503f.tst + ACATS4GNATDIR/tests/c4/c45231d.tst + ACATS4GNATDIR/tests/c4/c4a007a.tst + ACATS4GNATDIR/tests/c8/c87b62d.tst + ACATS4GNATDIR/tests/c9/c96005b.tst + ACATS4GNATDIR/tests/cc/cc1225a.tst + ACATS4GNATDIR/tests/cd/cd1009k.tst + ACATS4GNATDIR/tests/cd/cd1009t.tst + ACATS4GNATDIR/tests/cd/cd1009u.tst + ACATS4GNATDIR/tests/cd/cd1c03e.tst + ACATS4GNATDIR/tests/cd/cd1c06a.tst + ACATS4GNATDIR/tests/cd/cd2a83c.tst + ACATS4GNATDIR/tests/cd/cd2a91c.tst + ACATS4GNATDIR/tests/cd/cd2c11a.tst + ACATS4GNATDIR/tests/cd/cd2c11d.tst + ACATS4GNATDIR/tests/cd/cd4041a.tst + ACATS4GNATDIR/tests/cd/cd7101g.tst + ACATS4GNATDIR/tests/ce/ce2102c.tst + ACATS4GNATDIR/tests/ce/ce2102h.tst + ACATS4GNATDIR/tests/ce/ce2103a.tst + ACATS4GNATDIR/tests/ce/ce2103b.tst + ACATS4GNATDIR/tests/ce/ce2203a.tst + ACATS4GNATDIR/tests/ce/ce2403a.tst + ACATS4GNATDIR/tests/ce/ce3002b.tst + ACATS4GNATDIR/tests/ce/ce3002c.tst + ACATS4GNATDIR/tests/ce/ce3102b.tst + ACATS4GNATDIR/tests/ce/ce3107a.tst + ACATS4GNATDIR/tests/ce/ce3304a.tst + ACATS4GNATDIR/support/spprt13s.tst diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/support/widechr.a gcc-3.4.0/gcc/testsuite/ada/acats/support/widechr.a *** gcc-3.3.3/gcc/testsuite/ada/acats/support/widechr.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/support/widechr.a 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,294 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + -- A22006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT HORIZONTAL TABULATION CAN BE USED WITHIN AND OUTSIDE OF + -- COMMENTS. + + -- JBG 5/26/85 + + WITH REPORT; USE REPORT; + PROCEDURE A22006B IS + BEGIN + TEST ("A22006B", "CHECK USE OF HT IN AND OUT OF COMMENTS"); + -- PRECEDING LINE CONTAINED A LEADING HT + -- NEXT LINE CONTAINS A TAB INSIDE A COMMENT + -- HERE IS HT => <= CHARACTER IN A COMMENT + RESULT; -- TAB PRECEDES THIS COMMENT + END A22006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + + + + -- A22006C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A COMPILATION MAY BE PRECEDED BY EXTRA LINES + -- (INCLUDING LINES TERMINATED BY FORMAT EFFECTORS OTHER + -- THAN HORIZONTAL TABULATION). + + -- NOTE: THIS FILE BEGINS WITH: + -- 1) AN EMPTY LINE + -- 2) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX) + -- 3) A CARRIAGE RETURN CHARACTER (ASCII 13. = 0D HEX) + -- 4) A VERTICAL TABULATION CHARACTER (ASCII 11. = 0B HEX) + -- 5) A LINE FEED CHARACTER (ASCII 10. = 0A HEX) + -- 6) A LINE FEED CHARACTER (ASCII 10. = 0A HEX) + -- 7) A FORM FEED CHARACTER (ASCII 12. = 0C HEX) + + -- PWB 2/13/86 + + WITH REPORT; + USE REPORT; + + PROCEDURE A22006C IS + BEGIN + TEST ("A22006C", "CHECK THAT A COMPILATION CAN BE PRECEDED " & + "BY EXTRA LINES"); + RESULT; + END A22006C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a22006d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a22006d.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + -- A22006D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A COMPILATION CAN BE PRECEDED BY SPACES AND + -- HORIZONTAL TABULATION CHARACTERS. + + -- NOTE: THE FIRST LINE OF THIS FILE BEGINS WITH FOUR SPACE + -- CHARACTERS AND A HORIZONTAL TABULATION CHARACTER + + -- PWB 2/13/86 + + WITH REPORT; + USE REPORT; + + PROCEDURE A22006D IS + BEGIN + TEST ("A22006D", "CHECK THAT A COMPILATION CAN BE PRECEDED " & + "BY SPACE AND HORIZONTAL TABULATION CHARACTERS"); + RESULT; + END A22006D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a26007a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a26007a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a26007a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a26007a.tst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,48 ---- + -- A26007A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STRING LITERAL HAVING THE MAXIMUM PERMITTED LINE LENGTH + -- CAN BE GENERATED. + + -- TBN 3/5/86 + + WITH REPORT; USE REPORT; + PROCEDURE A26007A IS + + MAX_LEN_STRING_LIT : STRING (1 .. $MAX_IN_LEN - 2); + + -- MAX_IN_LEN IS THE MAXIMUM LINE LENGTH PERMITTED. + + BEGIN + TEST ("A26007A", "CHECK THAT A STRING LITERAL HAVING THE " & + "MAXIMUM PERMITTED LINE LENGTH CAN BE GENERATED"); + + MAX_LEN_STRING_LIT := + $MAX_STRING_LITERAL + ; + -- MAX_STRING_LITERAL IS A STRING LITERAL THAT IS MAXIMUM LENGTH. + -- QUOTES ARE COUNTED AS PART OF THE STRING LITERAL. + + RESULT; + END A26007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a27003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a27003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a27003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a27003a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- A27003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN A STRING LITERAL, CONSECUTIVE HYPHENS + -- ARE PERMITTED WITHOUT INDICATING A COMMENT, + -- AND THAT IN A COMMENT, A SINGLE DOUBLE-QUOTE IS + -- PERMITTED WITHOUT INDICATING A STRING LITERAL. + + -- PWB 03/04/86 + + WITH REPORT; USE REPORT; + PROCEDURE A27003A IS + + -- COMMENT : " IS PERMITTED HERE. + + STR1 : CONSTANT STRING := "AB--C"; + STR2 : STRING (1..10); + + BEGIN + + TEST ("A27003A", "CONSECUTIVE HYPHENS PERMITTED IN " & + "STRING LITERAL, AND QUOTE PERMITTED " & + "IN COMMENT"); + + STR2 := STR1 & "--ABC"; + -- COMMENT : " IS PERMITTED HERE. + + RESULT; + + END A27003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a29003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a29003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a29003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a29003a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- A29003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL PREDEFINED ATTRIBUTES EXCEPT DIGITS, DELTA, AND RANGE, + -- AND ALL PREDEFINED TYPE AND PACKAGE NAMES ARE NOT RESERVED WORDS. + + -- AH 8/11/86 + + WITH REPORT; USE REPORT; + PROCEDURE A29003A IS + SUBTYPE INT IS INTEGER; + + -- PREDEFINED ATTRIBUTES + + ADDRESS : INT := IDENT_INT(0); -- ATTRIBUTE + AFT : INT := IDENT_INT(0); -- ATTRIBUTE + BASE : INT := IDENT_INT(0); -- ATTRIBUTE + CALLABLE : INT := IDENT_INT(0); -- ATTRIBUTE + CONSTRAINED : INT := IDENT_INT(0); -- ATTRIBUTE + COUNT : INT := IDENT_INT(0); -- ATTRIBUTE + EMAX : INT := IDENT_INT(0); -- ATTRIBUTE + EPSILON : INT := IDENT_INT(0); -- ATTRIBUTE + FIRST : INT := IDENT_INT(0); -- ATTRIBUTE + FIRST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE + FORE : INT := IDENT_INT(0); -- ATTRIBUTE + IMAGE : INT := IDENT_INT(0); -- ATTRIBUTE + LARGE : INT := IDENT_INT(0); -- ATTRIBUTE + LAST : INT := IDENT_INT(0); -- ATTRIBUTE + LAST_BIT : INT := IDENT_INT(0); -- ATTRIBUTE + LENGTH : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_EMIN : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_OVERFLOWS : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_RADIX : INT := IDENT_INT(0); -- ATTRIBUTE + MACHINE_ROUNDS : INT := IDENT_INT(0); -- ATTRIBUTE + MANTISSA : INT := IDENT_INT(0); -- ATTRIBUTE + POS : INT := IDENT_INT(0); -- ATTRIBUTE + POSITION : INT := IDENT_INT(0); -- ATTRIBUTE + PRED : INT := IDENT_INT(0); -- ATTRIBUTE + SAFE_EMAX : INT := IDENT_INT(0); -- ATTRIBUTE + SAFE_LARGE : INT := IDENT_INT(0); -- ATTRIBUTE + SAFE_SMALL : INT := IDENT_INT(0); -- ATTRIBUTE + SIZE : INT := IDENT_INT(0); -- ATTRIBUTE + SMALL : INT := IDENT_INT(0); -- ATTRIBUTE + STORAGE_SIZE : INT := IDENT_INT(0); -- ATTRIBUTE + SUCC : INT := IDENT_INT(0); -- ATTRIBUTE + TERMINATED : INT := IDENT_INT(0); -- ATTRIBUTE + VAL : INT := IDENT_INT(0); -- ATTRIBUTE + VALUE : INT := IDENT_INT(0); -- ATTRIBUTE + WIDTH : INT := IDENT_INT(0); -- ATTRIBUTE + + -- PREDEFINED TYPES + + BOOLEAN : INT := IDENT_INT(0); -- TYPE + CHARACTER : INT := IDENT_INT(0); -- TYPE + DURATION : INT := IDENT_INT(0); -- TYPE + FLOAT : INT := IDENT_INT(0); -- TYPE + INTEGER : INT := IDENT_INT(0); -- TYPE + NATURAL : INT := IDENT_INT(0); -- TYPE + POSITIVE : INT := IDENT_INT(0); -- TYPE + STRING : INT := IDENT_INT(0); -- TYPE + + -- PREDEFINED PACKAGE NAMES + + ASCII : INT := IDENT_INT(0); -- PACKAGE + CALENDAR : INT := IDENT_INT(0); -- PACKAGE + DIRECT_IO : INT := IDENT_INT(0); -- PACKAGE + IO_EXCEPTIONS : INT := IDENT_INT(0); -- PACKAGE + LOW_LEVEL_IO : INT := IDENT_INT(0); -- PACKAGE + MACHINE_CODE : INT := IDENT_INT(0); -- PACKAGE + SEQUENTIAL_IO : INT := IDENT_INT(0); -- PACKAGE + SYSTEM : INT := IDENT_INT(0); -- PACKAGE + TEXT_IO : INT := IDENT_INT(0); -- PACKAGE + UNCHECKED_CONVERSION : INT := IDENT_INT(0); -- PACKAGE + UNCHECKED_DEALLOCATION : INT := IDENT_INT(0); -- PACKAGE + + BEGIN + TEST("A29003A", "NO ADDITIONAL RESERVED WORDS"); + RESULT; + END A29003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a2a031a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a2a031a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a2a031a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a2a031a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- A2A031A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXCLAMATION MARK CAN REPLACE A VERTICAL BAR WHEN THE + -- VERTICAL BAR IS USED AS A SEPARATOR. + + -- CONTEXTS ARE: + -- AS A CHOICE IN A VARIANT PART + -- IN A DISCRIMINANT CONSTRAINT + -- IN A CASE STATEMENT CHOICE + -- IN AN AGGREGATE + -- IN AN EXCEPTION HANDLER. + + -- JBG 5/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE A2A031A IS + + TYPE ENUM IS (E1, E2, E3); + TYPE REC (A, B : ENUM) IS + RECORD + C : INTEGER; + CASE A IS + WHEN E1 ! E2 => -- CHOICE OF VARIANT. + D : INTEGER; + WHEN E3 => + E : FLOAT; + END CASE; + END RECORD; + + EX1, EX2, EX3 : EXCEPTION; + + VAR : REC (A!B => E2); -- DISCRIMINANT CONSTRAINT. + + EVAR : ENUM := E2; + + BEGIN + + TEST ("A2A031A", "CHECK USE OF ! AS SEPARATOR IN PLACE OF |"); + + CASE EVAR IS + WHEN E3 => NULL; + WHEN E2!E1 => NULL; -- CASE STATEMENT CHOICE. + END CASE; + + VAR := (A!B => E2, C ! D => 0); -- AGGREGATE. + + RESULT; + EXCEPTION + WHEN EX1!EX2 ! EX3 => NULL; -- EXCEPTION HANDLER. + END A2A031A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a33003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a33003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a33003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a33003a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + -- A33003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FOLLOWING FORMS OF ALMOST RECURSIVE TYPES CAN BE + -- DECLARED: + -- A) A RECORD HAVING A COMPONENT OF AN ACCESS TYPE WHOSE DESIGNATED + -- TYPE IS THE RECORD TYPE; + + -- TBN 10/6/86 + -- DTN 11/12/91 DELETED SUBPARTS (B and C). + + WITH REPORT; USE REPORT; + PROCEDURE A33003A IS + + TYPE REC; + TYPE ACC_REC IS ACCESS REC; + TYPE REC IS + RECORD + A : INTEGER; + B : ACC_REC; + END RECORD; + + BEGIN + TEST ("A33003A", "CHECK THAT ALMOST RECURSIVE TYPES CAN BE " & + "DECLARED"); + + RESULT; + END A33003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a34017c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a34017c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a34017c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a34017c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- A34017C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DERIVED TYPE DEFINITION IS GIVEN IN THE VISIBLE PART + -- OF A PACKAGE, THE TYPE MAY BE USED AS THE PARENT TYPE IN A DERIVED + -- TYPE DEFINITION IN THE PRIVATE PART OF THE PACKAGE AND IN THE BODY. + + -- CHECK THAT IF A TYPE IS DECLARED IN THE VISIBLE PART OF A PACKAGE, + -- AND IS NOT A DERIVED TYPE OR A PRIVATE TYPE, IT MAY BE USED AS THE + -- PARENT TYPE IN A DERIVED TYPE DEFINITION IN THE VISIBLE PART, PRIVATE + -- PART, AND BODY. + + + -- DSJ 4/27/83 + + + WITH REPORT; + PROCEDURE A34017C IS + + USE REPORT; + + BEGIN + + TEST( "A34017C", "CHECK THAT A DERIVED TYPE MAY BE USED AS A " & + "PARENT TYPE IN THE PRIVATE PART AND BODY. " & + "CHECK THAT OTHER TYPES MAY BE USED AS PARENT " & + "TYPES IN VISIBLE PART ALSO"); + + DECLARE + + TYPE REC IS + RECORD + C : INTEGER; + END RECORD; + + PACKAGE PACK1 IS + + TYPE T1 IS RANGE 1 .. 10; + TYPE T2 IS NEW REC; + + TYPE T3 IS (A,B,C); + TYPE T4 IS ARRAY ( 1 .. 2 ) OF INTEGER; + TYPE T5 IS + RECORD + X : CHARACTER; + END RECORD; + TYPE T6 IS ACCESS INTEGER; + + TYPE N1 IS NEW T3; + TYPE N2 IS NEW T4; + TYPE N3 IS NEW T5; + TYPE N4 IS NEW T6; + + PRIVATE + + TYPE P1 IS NEW T1; + TYPE P2 IS NEW T2; + TYPE P3 IS NEW T3; + TYPE P4 IS NEW T4; + TYPE P5 IS NEW T5; + TYPE P6 IS NEW T6; + + END PACK1; + + PACKAGE BODY PACK1 IS + + TYPE Q1 IS NEW T1; + TYPE Q2 IS NEW T2; + TYPE Q3 IS NEW T3; + TYPE Q4 IS NEW T4; + TYPE Q5 IS NEW T5; + TYPE Q6 IS NEW T6; + + END PACK1; + + BEGIN + + NULL; + + END; + + RESULT; + + END A34017C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35101b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35101b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35101b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35101b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- A35101B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ONE ENUMERATION LITERAL IS PERMITTED IN AN ENUMERATION + -- TYPE DEFINITION. + + -- RJW 2/14/86 + + WITH REPORT; USE REPORT; + + PROCEDURE A35101B IS + + BEGIN + + TEST ("A35101B", "CHECK THAT ONE ENUMERATION LITERAL IS " & + "PERMITTED IN AN ENUMERATION TYPE " & + "DEFINITION" ); + DECLARE + + TYPE E1 IS (A); -- OK. + TYPE E2 IS ('1'); -- OK. + + BEGIN + NULL; + END; + + RESULT; + + END A35101B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35402a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- A35402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF AN INTEGER TYPE DEFINITION NEED NOT + -- HAVE THE SAME INTEGER TYPE. + + -- RJW 2/20/86 + + WITH REPORT; USE REPORT; + + PROCEDURE A35402A IS + + BEGIN + + TEST ( "A35402A", "CHECK THAT THE BOUNDS OF AN INTEGER " & + "TYPE DEFINITION NEED NOT HAVE THE SAME " & + "INTEGER TYPE" ); + + DECLARE + TYPE INT1 IS RANGE 1 .. 10; + TYPE INT2 IS RANGE 2 .. 8; + TYPE INT3 IS NEW INTEGER; + + I : CONSTANT INTEGER := 5; + I1 : CONSTANT INT1 := 5; + I2 : CONSTANT INT2 := 5; + I3 : CONSTANT INT3 := 5; + + TYPE INTRANGE1 IS RANGE I .. I1; -- OK. + + TYPE INTRANGE2 IS RANGE I1 .. I2; -- OK. + + TYPE INTRANGE3 IS RANGE I2 .. I3; -- OK. + + TYPE INTRANGE4 IS RANGE I3 .. I; -- OK. + BEGIN + NULL; + END; + + RESULT; + + END A35402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35801f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35801f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35801f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35801f.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- A35801F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE + -- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A FLOATING POINT + -- TYPE. + + -- THIS CHECK IS PROVIDED THROUGH THE USE OF THIS TEST IN CONJUNCTION + -- WITH TEST B35801C. + + -- R.WILLIAMS 8/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE A35801F IS + + TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0; + SUBTYPE SURREAL IS REAL RANGE -50.0 .. 50.0; + + TYPE NFLT IS NEW FLOAT; + SUBTYPE UNIT IS NFLT RANGE -1.0 .. 1.0; + + SUBTYPE EMPTY IS FLOAT RANGE 1.0 .. -1.0; + + R1 : REAL := SURREAL'FIRST; -- OK. + R2 : REAL := SURREAL'LAST; -- OK. + + N1 : NFLT := UNIT'FIRST; -- OK. + N2 : NFLT := UNIT'LAST; -- OK. + + F1 : FLOAT := FLOAT'FIRST; -- OK. + F2 : FLOAT := FLOAT'LAST; -- OK. + + E1 : FLOAT := EMPTY'FIRST; -- OK. + E2 : FLOAT := EMPTY'LAST; -- OK. + + BEGIN + TEST ( "A35801F", "CHECK THAT THE ATTRIBUTES FIRST AND LAST " & + "RETURN VALUES HAVING THE SAME BASE TYPE AS " & + "THE PREFIX WHEN THE PREFIX IS A FLOATING " & + "POINT TYPE" ); + + RESULT; + END A35801F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35902c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35902c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a35902c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a35902c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- A35902C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FIXED POINT TYPE WITH ONLY ONE MODEL NUMBER IS + -- ALLOWED. + + -- HISTORY: + -- RJW 02/26/86 CREATED ORIGINAL TEST. + -- DHH 10/15/87 CORRECTED RANGE ERRORS. + + WITH REPORT; USE REPORT; + + PROCEDURE A35902C IS + + BEGIN + + TEST ("A35902C", "CHECK THAT A FIXED POINT TYPE WITH ONLY ONE " & + "MODEL NUMBER IS ALLOWED" ); + DECLARE + TYPE F IS DELTA 1.0 RANGE -0.5 .. 0.5; -- OK. + F1 : F := 0.0; + + BEGIN + NULL; + END; + + RESULT; + + END A35902C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a38106d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a38106d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a38106d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a38106d.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- A38106D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE + -- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON + -- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE + -- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE + -- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE + -- INCOMPLETE TYPE. + + -- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES + -- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES + -- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY + -- TYPES + + -- PART 1: FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE SPECIFICATION. + + -- DSJ 5/05/83 + -- SPS 10/18/83 + -- EG 12/19/83 + + WITH REPORT ; + PROCEDURE A38106D IS + + USE REPORT ; + + BEGIN + + TEST("A38106D", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " & + "TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " & + "EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " & + "ACCESS TYPE AND AFTER THE FULL DECLARATION " & + "(WHICH IS IN THE PACKAGE SPECIFICATION)") ; + + DECLARE + + PACKAGE PACK1 IS + TYPE T1 ; + TYPE T2 ; + + PACKAGE PACK2 IS + TYPE ACC1 IS ACCESS T1 ; + TYPE ACC2 IS ACCESS T2 ; + END PACK2 ; + + TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ; + TYPE T2 IS + RECORD + C1, C2 : INTEGER ; + END RECORD ; + END PACK1 ; + + PACKAGE BODY PACK1 IS + A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL + A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL + R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL + R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL + + PACKAGE BODY PACK2 IS + X1 : INTEGER := A1(1) ; -- LEGAL + X2 : INTEGER := A1'FIRST ; -- LEGAL + X3 : INTEGER := A1'LAST ; -- LEGAL + X4 : INTEGER := A1'LENGTH ; -- LEGAL + B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL + X5 : INTEGER := R1.C1 ; -- LEGAL + END PACK2 ; + + END PACK1 ; + + BEGIN + + NULL ; + + END ; + + RESULT ; + + END A38106D ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a38106e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a38106e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a38106e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a38106e.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- A38106E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR AN ACCESS TYPE WHOSE DESIGNATED TYPE IS AN INCOMPLETE + -- TYPE, ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON + -- CHARACTERISTICS OF THE FULL DECLARATION OF THE TYPE ARE MADE + -- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE + -- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE + -- INCOMPLETE TYPE. + + -- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES + -- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES + -- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY + -- TYPES + + -- PART 2 : FULL DECLARATION OF INCOMPLETE TYPE IN PACKAGE BODY + + -- DSJ 5/05/83 + -- SPS 10/18/83 + -- EG 12/19/83 + + WITH REPORT ; + PROCEDURE A38106E IS + + USE REPORT ; + + BEGIN + + TEST("A38106E", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS " & + "TYPES OF INCOMPLETE TYPES ARE AVAILABLE AT THE " & + "EARLIEST PLACE IN THE IMMEDIATE SCOPE OF THE " & + "ACCESS TYPE AND AFTER THE FULL DECLARATION " & + "(WHICH IS IN THE PACKAGE BODY)"); + + DECLARE + + PACKAGE PACK1 IS + PRIVATE + TYPE T1 ; + TYPE T2 ; + PACKAGE PACK2 IS + TYPE ACC1 IS ACCESS T1 ; + TYPE ACC2 IS ACCESS T2 ; + END PACK2 ; + END PACK1 ; + + PACKAGE BODY PACK1 IS + TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ; + TYPE T2 IS + RECORD + C1, C2 : INTEGER ; + END RECORD ; + + A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL + A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL + R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL + R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL + + PACKAGE BODY PACK2 IS + X1 : INTEGER := A1(1) ; -- LEGAL + X2 : INTEGER := A1'FIRST ; -- LEGAL + X3 : INTEGER := A1'LAST ; -- LEGAL + X4 : INTEGER := A1'LENGTH ; -- LEGAL + B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL + X5 : INTEGER := R1.C1 ; -- LEGAL + END PACK2 ; + + END PACK1 ; + + BEGIN + + NULL ; + + END ; + + RESULT ; + + END A38106E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- A49027A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE AND + -- STATIC IN THE CORRESPONDING INSTANCE. + -- CHECK THAT FOR A GENERIC INSTANTIATION, IF THE ACTUAL PARAMETER + -- IS A STATIC SUBTYPE, THEN EVERY USE OF THE CORRESPONDING FORMAL + -- PARAMETER WITHIN THE INSTANCE IS CONSIDERED TO DENOTE A STATIC + -- SUBTYPE + -- + -- THIS IS A TEST BASED ON AI-00409/05-BI-WJ. + + -- HISTORY: + -- EDWARD V. BERARD, 27 AUGUST 1990 + -- CJJ 10 OCT 1990 TEST OBJECTIVE CHANGED TO REFLECT AIG + -- OBJECTIVE. + + WITH REPORT ; + + PROCEDURE A49027A IS + + BEGIN -- A49027A + + REPORT.TEST ("A49027A", "CHECK THAT A SUBTYPE CAN BE NONSTATIC " & + "IN A GENERIC TEMPLATE AND STATIC IN THE " & + "CORRESPONDING INSTANCE.") ; + + LOCAL_BLOCK: + + DECLARE + + TYPE NUMBER IS RANGE 1 .. 10 ; + + GENERIC + + TYPE NUMBER_TYPE IS RANGE <> ; + + PACKAGE STATIC_TEST IS + + TYPE NEW_NUMBER_TYPE IS NEW NUMBER_TYPE ; + SUBTYPE SUB_NUMBER_TYPE IS NUMBER_TYPE ; + + END STATIC_TEST ; + + PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST + (NUMBER_TYPE => NUMBER) ; + + TYPE ANOTHER_NUMBER IS RANGE + NEW_STATIC_TEST.NEW_NUMBER_TYPE'FIRST .. + NEW_STATIC_TEST.NEW_NUMBER_TYPE'LAST ; + + TYPE YET_ANOTHER_NUMBER IS RANGE + NEW_STATIC_TEST.SUB_NUMBER_TYPE'FIRST .. + NEW_STATIC_TEST.SUB_NUMBER_TYPE'LAST ; + + BEGIN -- LOCAL_BLOCK + + NULL ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + + END A49027A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- A49027B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUBTYPE CAN BE NONSTATIC IN A GENERIC TEMPLATE + -- AND STATIC IN THE CORRESPONDING INSTANCE. + + -- CHECK THAT IF A GENERIC PARAMETER IS A STATIC EXPRESSION AND THE + -- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE, + -- THEN EACH USE OF THE FORMAL PARAMETERS IN THE INSTANCE IS SAID TO + -- BE STATIC. + -- + -- A NAME DENOTING A CONSTANT DECLARED IN A GENERIC INSTANCE IS + -- ALLOWED AS A PRIMARY IN A STATIC EXPRESSION IF THE CONSTANT + -- IS DECLARED BY A CONSTANT DECLARATION WITH A STATIC SUBTYPE + -- AND INITIALIZED WITH A STATIC EXPRESSION. + -- + -- THIS IS A TEST BASED ON AI-00505/03-BI-WA. + + -- HISTORY: + -- EDWARD V. BERARD, 27 AUGUST 1990 + -- DAS 8 OCT 90 ADDED CODE TO MATCH EXAMPLE 1 IN + -- AI-00505. + -- JRL 05/29/92 CORRECTED MINOR PROBLEM IN REPORT.TEST STRING. + -- JRL 02/18/93 EXPANDED TEXT OF REPORT.TEST STRING. + -- PWN 04/14/95 CORRECTED MINOR COPYRIGHT COMMENT PROBLEM. + + + WITH REPORT ; + + PROCEDURE A49027B IS + + BEGIN -- A49027B + + REPORT.TEST ("A49027B", "CHECK THAT IF A GENERIC ACTUAL " & + "PARAMETER IS A STATIC EXPRESSION AND THE " & + "CORRESPONDING FORMAL PARAMETER HAS A STATIC " & + "SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " & + "FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE " & + "STATIC. CHECK THAT A NAME DENOTING A CONSTANT " & + "DECLARED IN A GENERIC INSTANCE IS ALLOWED AS " & + "A PRIMARY IN A STATIC EXPRESSION IF THE " & + "CONSTANT IS DECLARED BY A CONSTANT DECLARATION " & + "WITH A STATIC SUBTYPE AND INITIALIZED WITH A " & + "STATIC EXPRESSION. (AI-00505)"); + + LOCAL_BLOCK: + + DECLARE + + TYPE NUMBER IS RANGE 1 .. 10 ; + TYPE COLOR IS (RED, ORANGE, YELLOW, GREEN, BLUE) ; + MIDDLE_COLOR : CONSTANT COLOR := GREEN ; + + ENUMERATED_VALUE : COLOR := COLOR'LAST ; + + GENERIC + + TYPE NUMBER_TYPE IS RANGE <> ; + X : INTEGER ; + TYPE ENUMERATED IS (<>) ; + + FIRST_NUMBER : IN NUMBER_TYPE ; + SECOND_NUMBER : IN NUMBER_TYPE ; + THIRD_NUMBER : IN NUMBER_TYPE ; + FIRST_ENUMERATED : IN ENUMERATED ; + SECOND_ENUMERATED : IN ENUMERATED ; + THIRD_ENUMERATED : IN ENUMERATED ; + + FIRST_INTEGER_VALUE : IN INTEGER ; + SECOND_INTEGER_VALUE : IN INTEGER ; + + PACKAGE STATIC_TEST IS + + Y : CONSTANT INTEGER := X; + Z : CONSTANT NUMBER_TYPE := 5; + + SUBTYPE FIRST_NUMBER_SUBTYPE IS NUMBER_TYPE + RANGE FIRST_NUMBER .. SECOND_NUMBER ; + SUBTYPE SECOND_NUMBER_SUBTYPE IS NUMBER_TYPE + RANGE FIRST_NUMBER .. THIRD_NUMBER ; + + SUBTYPE FIRST_ENUMERATED_SUBTYPE IS ENUMERATED + RANGE FIRST_ENUMERATED .. SECOND_ENUMERATED ; + SUBTYPE SECOND_ENUMERATED_SUBTYPE IS ENUMERATED + RANGE FIRST_ENUMERATED .. THIRD_ENUMERATED ; + + SUBTYPE THIRD_NUMBER_TYPE IS INTEGER + RANGE FIRST_INTEGER_VALUE .. SECOND_INTEGER_VALUE ; + + END STATIC_TEST ; + + PACKAGE NEW_STATIC_TEST IS NEW STATIC_TEST + (NUMBER_TYPE => NUMBER, + X => 3, + ENUMERATED => COLOR, + FIRST_NUMBER => NUMBER'FIRST, + SECOND_NUMBER => NUMBER'LAST, + THIRD_NUMBER => NUMBER'SUCC(NUMBER'FIRST), + FIRST_ENUMERATED => RED, + SECOND_ENUMERATED => MIDDLE_COLOR, + THIRD_ENUMERATED => COLOR'VAL (1), + FIRST_INTEGER_VALUE => COLOR'POS (YELLOW), + SECOND_INTEGER_VALUE => NUMBER'POS (5)) ; + + TYPE T1 IS RANGE 1 .. NEW_STATIC_TEST.Y; + TYPE T2 IS RANGE 1 .. NEW_STATIC_TEST.Z; + + TYPE ANOTHER_NUMBER IS RANGE + NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'FIRST .. + NEW_STATIC_TEST.FIRST_NUMBER_SUBTYPE'LAST ; + + TYPE YET_ANOTHER_NUMBER IS RANGE + NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'FIRST .. + NEW_STATIC_TEST.SECOND_NUMBER_SUBTYPE'LAST ; + + TYPE STILL_ANOTHER_NUMBER IS RANGE + NEW_STATIC_TEST.THIRD_NUMBER_TYPE'FIRST .. + NEW_STATIC_TEST.THIRD_NUMBER_TYPE'LAST ; + + BEGIN -- LOCAL_BLOCK + + CASE ENUMERATED_VALUE IS + WHEN YELLOW => NULL ; + WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'FIRST + => NULL ; + WHEN NEW_STATIC_TEST.FIRST_ENUMERATED_SUBTYPE'LAST + => NULL ; + WHEN NEW_STATIC_TEST.SECOND_ENUMERATED_SUBTYPE'LAST + => NULL ; + WHEN COLOR'LAST => NULL ; + END CASE ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + + END A49027B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a49027c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a49027c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- A49027C.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- CHECK THAT IF A GENERIC PARAMETER IS A STATIC EXPRESSION AND THE + -- CORRESPONDING (IN) PARAMETER HAS A STATIC SUBTYPE IN THE INSTANCE, + -- THEN EACH USE OF THE FORMAL PARAMETER IN THE INSTANCE IS SAID TO + -- BE STATIC. + -- + -- SEE AI-00505. THIS TEST IS TAKEN FROM THE SECOND EXAMPLE. + -- + -- HISTORY: + -- DAS 8 OCT 90 INITIAL VERSION. + -- PWN 12/01/95 CORRECTED FORMAT OF CALL TO REPORT.TEST + -- KAS 25NOV96 CHANGED LITERAL 7 TO (IMPDEF.CHAR_BITS-1) + --! + + WITH REPORT; USE REPORT; + WITH IMPDEF; + + PROCEDURE A49027C IS + + GENERIC + X : INTEGER; + PACKAGE GP IS + TYPE REC IS + RECORD + C : STRING (1..X); + END RECORD; + END GP; + + PACKAGE NP IS NEW GP (1); + + TYPE NR IS NEW NP.REC; + FOR NR USE + RECORD + C AT 0 RANGE 0..IMPDEF.CHAR_BITS-1; -- SUBTYPE INDICATION + END RECORD; -- FOR C IN NP IS CONSIDERED STATIC. + + BEGIN + TEST("A49027C", "CHECK THAT IF A GENERIC PARAMETER IS A STATIC " & + "EXPRESSION AND THE CORRESPONDING (IN) PARAMETER HAS A " & + "STATIC SUBTYPE IN THE INSTANCE, THEN EACH USE OF THE " & + "FORMAL PARAMETER IN THE INSTANCE IS SAID TO BE STATIC."); + + RESULT; + + END A49027C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a54b01a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a54b01a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a54b01a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a54b01a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- A54B01A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A CASE EXPRESSION IS A CONSTANT, VARIABLE, + -- TYPE CONVERSION, OR QUALIFIED EXPRESSION, + -- AND THE SUBTYPE OF THE + -- EXPRESSION IS STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL + -- VALUES IN THE SUBTYPE'S RANGE ARE COVERED. + + + -- RM 01/23/80 + -- SPS 10/26/82 + -- SPS 2/1/83 + + WITH REPORT ; + PROCEDURE A54B01A IS + + USE REPORT ; + + BEGIN + + TEST("A54B01A" , "CHECK THAT IF" & + " THE SUBTYPE OF A CASE EXPRESSION IS STATIC," & + " AN 'OTHERS' CAN BE OMITTED IF ALL" & + " VALUES IN THE SUBTYPE'S RANGE ARE COVERED" ); + + -- THE TEST CASES APPEAR IN THE FOLLOWING ORDER: + -- + -- I. CONSTANTS + -- + -- II. STATIC SUBRANGES + -- + -- (A) VARIABLES (INTEGER , BOOLEAN) + -- (B) QUALIFIED EXPRESSIONS + -- (C) TYPE CONVERSIONS + + DECLARE -- CONSTANTS + T : CONSTANT BOOLEAN := TRUE; + FIVE : CONSTANT INTEGER := IDENT_INT(5); + BEGIN + + CASE FIVE IS + WHEN INTEGER'FIRST..4 => NULL ; + WHEN 5 => NULL ; + WHEN 6 .. INTEGER'LAST => NULL ; + END CASE; + + CASE T IS + WHEN TRUE => NULL ; + WHEN FALSE => NULL ; + END CASE; + + END ; + + + DECLARE -- STATIC SUBRANGES + + SUBTYPE STAT IS INTEGER RANGE 1..5 ; + I : INTEGER RANGE 1..5 ; + J : STAT ; + BOOL: BOOLEAN := FALSE ; + CHAR: CHARACTER := 'U' ; + TYPE ENUMERATION IS ( FIRST,SECOND,THIRD,FOURTH,FIFTH ); + ENUM: ENUMERATION := THIRD ; + + + BEGIN + + I := IDENT_INT( 2 ); + J := IDENT_INT( 2 ); + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + CASE BOOL IS + WHEN TRUE => NULL ; + WHEN FALSE => NULL ; + END CASE; + + CASE STAT'( 2 ) IS + WHEN 5 | 2..4 => NULL ; + WHEN 1 => NULL ; + END CASE; + + CASE STAT( J ) IS + WHEN 5 | 2..4 => NULL ; + WHEN 1 => NULL ; + END CASE; + + + END ; -- STATIC SUBRANGES + + RESULT ; + + + END A54B01A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a54b02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a54b02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a54b02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a54b02a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- A54B02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A CASE EXPRESSION IS A VARIABLE, CONSTANT, TYPE + -- CONVERSION, ATTRIBUTE (IN PARTICULAR 'FIRST AND 'LAST), + -- FUNCTION INVOCATION, QUALIFIED EXPRESSION, OR A PARENTHESIZED + -- EXPRESSION HAVING ONE OF THESE FORMS, AND THE SUBTYPE OF THE + -- EXPRESSION IS NON-STATIC, AN 'OTHERS' CAN BE OMITTED IF ALL + -- VALUES IN THE BASE TYPE'S RANGE ARE COVERED. + + -- RM 01/27/80 + -- SPS 10/26/82 + -- SPS 2/2/83 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT ; + PROCEDURE A54B02A IS + + USE REPORT ; + + BEGIN + + TEST("A54B02A" , "CHECK THAT IF THE" & + " SUBTYPE OF A CASE EXPRESSION IS NON-STATIC," & + " AN 'OTHERS' CAN BE OMITTED IF ALL" & + " VALUES IN THE BASE TYPE'S RANGE ARE COVERED" ); + + -- THE TEST CASES APPEAR IN THE FOLLOWING ORDER: + -- + -- (A) VARIABLES (INTEGER , BOOLEAN) + -- (B) CONSTANTS (INTEGER, BOOLEAN) + -- (C) ATTRIBUTES ('FIRST, 'LAST) + -- (D) FUNCTION CALLS + -- (E) QUALIFIED EXPRESSIONS + -- (F) TYPE CONVERSIONS + -- (G) PARENTHESIZED EXPRESSIONS OF THE ABOVE KINDS + + + DECLARE -- NON-STATIC RANGES + + SUBTYPE STAT IS INTEGER RANGE 1..50 ; + SUBTYPE DYN IS STAT RANGE 1..IDENT_INT( 5 ) ; + I : STAT RANGE 1..IDENT_INT( 5 ); + J : DYN ; + SUBTYPE DYNCHAR IS + CHARACTER RANGE ASCII.NUL .. IDENT_CHAR('Q'); + SUBTYPE STATCHAR IS + DYNCHAR RANGE 'A' .. 'C' ; + CHAR: DYNCHAR := 'F' ; + TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N ); + SUBTYPE STATENUM IS + ENUMERATION RANGE A .. L ; + SUBTYPE DYNENUM IS + STATENUM RANGE A .. ENUMERATION'VAL(IDENT_INT(5)); + ENUM: DYNENUM := B ; + CONS : CONSTANT DYN := 3; + + FUNCTION FF RETURN DYN IS + BEGIN + RETURN 2 ; + END FF ; + + BEGIN + + I := IDENT_INT( 2 ); + J := IDENT_INT( 2 ); + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + CASE J IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + CASE CONS IS + WHEN INTEGER'FIRST..INTEGER'LAST => NULL; + END CASE; + + CASE DYN'FIRST IS + WHEN INTEGER'FIRST..0 => NULL; + WHEN 1..INTEGER'LAST => NULL; + END CASE; + + CASE STATCHAR'LAST IS + WHEN CHARACTER'FIRST..'A' => NULL; + WHEN 'B'..CHARACTER'LAST => NULL; + END CASE; + + CASE FF IS + WHEN 4..5 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + WHEN 1..3 => NULL ; + END CASE; + + CASE DYN'( 2 ) IS + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + WHEN 5 | 2..4 => NULL ; + WHEN 1 => NULL ; + END CASE; + + CASE DYN( J ) IS + WHEN 5 | 2..4 => NULL ; + WHEN 1 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + + CASE ( CHAR ) IS + WHEN ASCII.NUL .. 'P' => NULL ; + WHEN 'Q' => NULL ; + WHEN 'R' .. 'Y' => NULL ; + WHEN 'Z' .. CHARACTER'LAST => NULL ; + END CASE; + + CASE ( ENUM ) IS + WHEN A | C | E => NULL ; + WHEN B | D => NULL ; + WHEN F .. L => NULL ; + WHEN M .. N => NULL ; + END CASE; + + CASE ( FF ) IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + CASE ( DYN'( I ) ) IS + WHEN 4..5 => NULL ; + WHEN 1..3 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + CASE ( DYN( 2 ) ) IS + WHEN 5 | 2..4 => NULL ; + WHEN 1 => NULL ; + WHEN INTEGER'FIRST..0 | 6..INTEGER'LAST => NULL ; + END CASE; + + CASE (CONS) IS + WHEN 1..100 => NULL; + WHEN INTEGER'FIRST..0 => NULL; + WHEN 101..INTEGER'LAST => NULL; + END CASE; + + CASE (DYNCHAR'LAST) IS + WHEN 'B'..'Y' => NULL; + WHEN CHARACTER'FIRST..'A' => NULL; + WHEN 'Z'..CHARACTER'LAST => NULL; + END CASE; + + END; + + + RESULT ; + + + END A54B02A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b12a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b12a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b12a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b12a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- A55B12A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE SUBTYPE OF A LOOP PARAMETER IN A LOOP OF THE FORM + -- + -- FOR I IN ST RANGE L..R LOOP + -- + -- IS CORRECTLY DETERMINED SO THAT WHEN THE LOOP PARAMETER IS USED + -- IN A CASE STATEMENT AN 'OTHERS' ALTERNATIVE IS NOT REQUIRED IF + -- THE CHOICES COVER THE APPROPRIATE RANGE OF SUBTYPE VALUES. + + -- CASE A : + -- L AND R ARE BOTH STATIC EXPRESSIONS, AND ST IS A STATIC + -- SUBTYPE COVERING A RANGE GREATER THAN L..R . + + + -- RM 02/02/80 + -- JRK 03/02/83 + + WITH REPORT ; + PROCEDURE A55B12A IS + + USE REPORT ; + + BEGIN + + TEST("A55B12A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" & + " IN A LOOP OF THE FORM 'FOR I IN ST RANGE" & + " L..R LOOP' IS CORRECTLY DETERMINED (A)" ); + + DECLARE + + SUBTYPE STAT IS INTEGER RANGE 1..10 ; + TYPE NEW_STAT IS NEW INTEGER RANGE 1..10 ; + + TYPE ENUMERATION IS ( A,B,C,D,E,F,G,H,K,L,M,N ); + SUBTYPE STAT_E IS ENUMERATION RANGE A..L ; + SUBTYPE STAT_B IS BOOLEAN RANGE FALSE..TRUE ; + SUBTYPE STAT_C IS CHARACTER RANGE 'A'..'L' ; + + BEGIN + + FOR I IN STAT RANGE 1..5 LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + FOR I IN NEW_STAT RANGE 1..5 LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + FOR I IN INTEGER RANGE 1..5 LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + + FOR I IN REVERSE STAT RANGE 1..5 LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + + FOR I IN STAT_E RANGE A..E LOOP + + CASE I IS + WHEN C..E => NULL ; + WHEN A..B => NULL ; + END CASE; + + END LOOP; + + + FOR I IN STAT_B RANGE TRUE..TRUE LOOP + + CASE I IS + WHEN TRUE => NULL ; + END CASE; + + END LOOP; + + + FOR I IN STAT_C RANGE 'A'..'E' LOOP + + CASE I IS + WHEN 'A'..'C' => NULL ; + WHEN 'D'..'E' => NULL ; + END CASE; + + END LOOP; + + + FOR I IN STAT_C RANGE 'E'..'B' LOOP + + CASE I IS + WHEN 'D'..'C' => NULL ; + WHEN 'E'..'B' => NULL ; + WHEN 'F'..'A' => NULL ; + WHEN 'M'..'A' => NULL ; + END CASE; + + END LOOP; + + + END ; + + RESULT ; + + END A55B12A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b13a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b13a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b13a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b13a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- A55B13A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- USING A CASE_STATEMENT , CHECK THAT IF L , R ARE LITERALS + -- OF TYPE T (INTEGER, BOOLEAN, CHARACTER, USER-DEFINED + -- ENUMERATION TYPE) THE SUBTYPE BOUNDS ASSOCIATED WITH A + -- LOOP OF THE FORM + -- FOR I IN L..R LOOP + -- ARE THE SAME AS THOSE FOR THE CORRESPONDING LOOP OF THE FORM + -- FOR I IN T RANGE L..R LOOP . + + + -- RM 04/07/81 + -- SPS 3/2/83 + -- JBG 8/21/83 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT ; + PROCEDURE A55B13A IS + + USE REPORT ; + + BEGIN + + TEST("A55B13A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" & + " IN A LOOP OF THE FORM 'FOR I IN " & + " LITERAL_L .. LITERAL_R LOOP' IS CORRECTLY" & + " DETERMINED" ); + + DECLARE + + TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H ); + ONE : CONSTANT := 1 ; + FIVE : CONSTANT := 5 ; + + + BEGIN + + + FOR I IN 1..5 LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + + FOR I IN REVERSE ONE .. FIVE LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL ; + WHEN 2 | 4 => NULL ; + END CASE; + + END LOOP; + + + FOR I IN REVERSE FALSE..TRUE LOOP + + CASE I IS + WHEN FALSE => NULL ; + WHEN TRUE => NULL ; + END CASE; + + END LOOP; + + + FOR I IN CHARACTER'('A') .. ASCII.DEL LOOP + + CASE I IS + WHEN CHARACTER'('A')..CHARACTER'('U') => NULL ; + WHEN CHARACTER'('V')..ASCII.DEL => NULL ; + END CASE; + + END LOOP; + + + FOR I IN CHARACTER'('A')..CHARACTER'('H') LOOP + + CASE I IS + WHEN CHARACTER'('A')..CHARACTER'('D') => NULL ; + WHEN CHARACTER'('E')..CHARACTER'('H') => NULL ; + END CASE; + + END LOOP; + + + FOR I IN REVERSE B..H LOOP + + CASE I IS + WHEN B..D => NULL ; + WHEN E..H => NULL ; + WHEN MIDPOINT => NULL ; + END CASE; + + END LOOP; + + + END ; + + + RESULT ; + + + END A55B13A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b14a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b14a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a55b14a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a55b14a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- A55B14A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- USING A CASE_STATEMENT , CHECK THAT THE SUBTYPE BOUNDS ASSOCIATED + -- WITH A LOOP OF THE FORM + -- FOR I IN ST LOOP + -- ARE, RESPECTIVELY, ST'FIRST..ST'LAST WHEN ST IS STATIC. + + -- RM 04/07/81 + -- SPS 3/2/83 + -- JBG 3/14/83 + + WITH REPORT; + PROCEDURE A55B14A IS + + USE REPORT; + USE ASCII ; + + TYPE ENUMERATION IS ( A,B,C,D,MIDPOINT,E,F,G,H ); + SUBTYPE ST_I IS INTEGER RANGE 1..5 ; + TYPE NEW_ST_I IS NEW INTEGER RANGE 1..5 ; + SUBTYPE ST_E IS ENUMERATION RANGE B..G ; + SUBTYPE ST_B IS BOOLEAN RANGE FALSE..FALSE; + SUBTYPE ST_C IS CHARACTER RANGE 'A'..DEL ; + + BEGIN + + TEST("A55B14A" , "CHECK THAT THE SUBTYPE OF A LOOP PARAMETER" & + " IN A LOOP OF THE FORM 'FOR I IN ST LOOP'" & + " ARE CORRECTLY DETERMINED WHEN ST IS STATIC" ); + + BEGIN + + + FOR I IN ST_I LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL; + WHEN 2 | 4 => NULL; + END CASE; + + END LOOP; + + + FOR I IN NEW_ST_I LOOP + + CASE I IS + WHEN 1 | 3 | 5 => NULL; + WHEN 2 | 4 => NULL; + END CASE; + + END LOOP; + + + FOR I IN ST_B LOOP + + CASE I IS + WHEN FALSE => NULL; + END CASE; + + END LOOP; + + + FOR I IN ST_C LOOP + + CASE I IS + WHEN 'A'..'U' => NULL; + WHEN 'V'..DEL => NULL; + END CASE; + + END LOOP; + + + FOR I IN ST_E LOOP + + CASE I IS + WHEN B..D => NULL; + WHEN E..G => NULL; + WHEN MIDPOINT => NULL; + END CASE; + + END LOOP; + + + END; + + + RESULT; + + + END A55B14A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a71004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a71004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a71004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a71004a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- A71004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL FORMS OF DECLARATION PERMITTED IN THE PRIVATE PART OF + -- A PACKAGE ARE INDEED ACCEPTED BY THE COMPILER. + -- TASKS, GENERICS, FIXED AND FLOAT DECLARATIONS ARE NOT TESTED. + + -- DAT 5/6/81 + -- VKG 2/16/83 + + WITH REPORT; USE REPORT; + + PROCEDURE A71004A IS + BEGIN + + TEST ("A71004A", "ALL FORMS OF DECLARATIONS IN PRIVATE PART"); + + DD: + DECLARE + + PACKAGE P1 IS + + TYPE P IS PRIVATE; + TYPE L IS LIMITED PRIVATE; + CP : CONSTANT P; + CL : CONSTANT L; + + PRIVATE + + ONE : CONSTANT := 1; + TWO : CONSTANT := ONE * 1.0 + 1.0; + N1, N2, N3 : CONSTANT := TWO; + TYPE I IS RANGE -10 .. 10; + X4, X5 : CONSTANT I := I(IDENT_INT(3)); + X6, X7 : I := X4 + X5; + TYPE AR IS ARRAY (I) OF L; + + X10 : ARRAY (IDENT_INT(1) .. IDENT_INT (10)) OF I; + X11 : CONSTANT ARRAY (1..10) OF I := (1..10=>3); + TYPE T3 IS (E12); + TYPE T4 IS NEW T3; + + TYPE REC1 (D:BOOLEAN:=TRUE) IS RECORD NULL; END RECORD; + SUBTYPE REC1TRUE IS REC1( D => TRUE ) ; + TYPE L IS NEW REC1TRUE ; + X8 , X9 : AR; + TYPE A6 IS ACCESS REC1 ; + SUBTYPE L1 IS L ; + SUBTYPE A7 IS A6(D=>TRUE); + SUBTYPE I14 IS I RANGE 1 .. 1; + TYPE UA1 IS ARRAY (I14 RANGE <> ) OF I14; + TYPE UA2 IS NEW UA1; + USE STANDARD.ASCII; + + PROCEDURE P1 ; + + FUNCTION F1 (X : UA1) RETURN UA1; + + FUNCTION "+" (X : UA1) RETURN UA1; + + PACKAGE PK IS + PRIVATE + END; + + PACKAGE PK1 IS + PACKAGE PK2 IS END; + PRIVATE + PACKAGE PK3 IS PRIVATE END; + END PK1; + + EX : EXCEPTION; + EX1, EX2 : EXCEPTION; + X99 : I RENAMES X7; + EX3 : EXCEPTION RENAMES EX1; + PACKAGE PQ1 RENAMES DD.P1; + PACKAGE PQ2 RENAMES PK1; + PACKAGE PQ3 RENAMES PQ2 . PK2; + FUNCTION "-" (X : UA1) RETURN UA1 RENAMES "+"; + PROCEDURE P98 RENAMES P1; + TYPE P IS NEW L; + CP : CONSTANT P := (D=> TRUE); + CL : CONSTANT L := L(CP); + + END P1; + + PACKAGE BODY P1 IS + + PROCEDURE P1 IS BEGIN NULL; END P1; + + FUNCTION F1 (X : UA1) RETURN UA1 IS + BEGIN RETURN X; END F1; + + FUNCTION "+" (X : UA1) RETURN UA1 IS + BEGIN RETURN F1(X); END "+"; + + PACKAGE BODY PK1 IS + PACKAGE BODY PK3 IS END; + END PK1; + + BEGIN + NULL ; + END P1; + + BEGIN + NULL; + END DD; + RESULT; + + END A71004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a73001i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a73001i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a73001i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a73001i.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- A73001I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR + -- GENERIC INSTANTIATION IN A PACKAGE SPECIFICATION NO PACKAGE BODY IS + -- REQUIRED. + + -- BHS 6/26/84 + + WITH REPORT; + PROCEDURE A73001I IS + + USE REPORT; + + BEGIN + + TEST ("A73001I", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " & + "SUBPROGRAM DECLARED BY RENAMING DECLARATION " & + "OR GENERIC INSTANTIATION IN A PACKAGE " & + "SPECIFICATION"); + + DECLARE + PACKAGE PACK1 IS + FUNCTION ADDI (X,Y : INTEGER) RETURN INTEGER RENAMES "+"; + END PACK1; + + BEGIN + NULL; + END; + + + DECLARE + GENERIC + TYPE ITEM IS RANGE <>; + PROCEDURE P (X : IN OUT ITEM); + + PROCEDURE P (X : IN OUT ITEM) IS + BEGIN + NULL; + END P; + + PACKAGE PACK2 IS + PROCEDURE NADA IS NEW P (INTEGER); + END PACK2; + + BEGIN + NULL; + END; + + RESULT; + + END A73001I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a73001j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a73001j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a73001j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a73001j.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- A73001J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A SUBPROGRAM IS DECLARED BY A RENAMING DECLARATION OR + -- GENERIC INSTANTIATION IN A GENERIC PACKAGE SPECIFICATION, NO PACKAGE + -- BODY IS REQUIRED. + + + -- BHS 6/27/84 + + WITH REPORT; + PROCEDURE A73001J IS + + USE REPORT; + + BEGIN + + TEST ("A73001J", "CHECK THAT NO PACKAGE BODY IS REQUIRED FOR " & + "SUBPROGRAM DECLARED BY RENAMING DECLARATION " & + "OR GENERIC INSTANTIATION IN A GENERIC " & + "PACKAGE SPECIFICATION"); + + DECLARE + GENERIC + TYPE ITEM IS RANGE <>; + PACKAGE PACK1 IS + FUNCTION ADDI (X,Y : ITEM) RETURN ITEM RENAMES "+"; + END PACK1; + + BEGIN + NULL; + END; + + + DECLARE + GENERIC + TYPE ITEM IS RANGE <>; + PROCEDURE P (X : IN OUT ITEM); + + PROCEDURE P (X : IN OUT ITEM) IS + BEGIN + NULL; + END P; + + GENERIC + TYPE OBJ IS RANGE <>; + PACKAGE PACK2 IS + PROCEDURE NADA IS NEW P (OBJ); + END PACK2; + + BEGIN + NULL; + END; + + RESULT; + + END A73001J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74105b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74105b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74105b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74105b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- A74105B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FULL TYPE DECLARATION OF A PRIVATE TYPE WITHOUT + -- DISCRIMINANTS MAY BE A CONSTRAINED TYPE WITH DISCRIMINANTS. + + -- DSJ 4/29/83 + -- SPS 10/22/83 + + WITH REPORT; + PROCEDURE A74105B IS + + USE REPORT; + + BEGIN + + TEST ("A74105B", "CHECK THAT THE FULL TYPE DECLARATION OF A " & + "PRIVATE TYPE WITHOUT DISCRIMINANTS MAY BE " & + "A CONSTRAINED TYPE WITH DISCRIMINANTS"); + + DECLARE + + TYPE REC1 (D : INTEGER) IS + RECORD + C1, C2 : INTEGER; + END RECORD; + + TYPE REC2 (F : INTEGER := 0) IS + RECORD + E1, E2 : INTEGER; + END RECORD; + + TYPE REC3 IS NEW REC1 (D => 1); + + TYPE REC4 IS NEW REC2 (F => 2); + + PACKAGE PACK1 IS + TYPE P1 IS PRIVATE; + TYPE P2 IS PRIVATE; + TYPE P3 IS PRIVATE; + TYPE P4 IS PRIVATE; + PRIVATE + TYPE P1 IS ACCESS REC1; + TYPE P2 IS NEW REC4; + TYPE P3 IS NEW REC1 (D => 5); + TYPE P4 IS NEW REC2 (F => 7); + END PACK1; + + BEGIN + + NULL; + + END; + + RESULT; + + END A74105B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- A74106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED + -- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE, + -- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH + -- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE + -- ABOVE. + + -- PART A: TYPES NOT INVOLVING FLOATING-POINT DATA OR FIXED-POINT DATA. + + + -- RM 05/13/81 + + + WITH REPORT; + PROCEDURE A74106A IS + + USE REPORT; + + BEGIN + + TEST( "A74106A" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " & + "TYPES CAN BE DEFINED IN TERMS OF " & + "VARIOUS OTHER TYPES" ); + + DECLARE + + TYPE ENUM IS ( A , B , C , D ); + + PACKAGE P0 IS + TYPE T0 IS PRIVATE; + PRIVATE + TYPE T0 IS NEW INTEGER; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE T1 IS PRIVATE; + TYPE T2 IS PRIVATE; + TYPE T3 IS PRIVATE; + TYPE T4 IS PRIVATE; + TYPE T5 IS PRIVATE; + TYPE T6 IS PRIVATE; + TYPE T7 IS PRIVATE; + TYPE T8 IS PRIVATE; + TYPE T9 IS PRIVATE; + TYPE TA IS PRIVATE; + TYPE TB IS PRIVATE; + TYPE TC IS PRIVATE; + TYPE TD(I : INTEGER) IS PRIVATE; + TYPE NT IS NEW ENUM; + TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN; + TYPE ACC_T IS ACCESS CHARACTER; + TYPE REC_T IS RECORD T : BOOLEAN; END RECORD; + TYPE D_REC_T(I : INTEGER := 1) IS + RECORD T : ENUM; END RECORD; + PRIVATE + TYPE TY(B : BOOLEAN) IS + RECORD G : BOOLEAN; END RECORD; + TYPE TC IS NEW T0; + TYPE T1 IS RANGE 1..100; + TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z'; + TYPE T3 IS NEW NT; + TYPE T4 IS ARRAY(1..2) OF INTEGER; + TYPE T5 IS NEW ARR_T; + TYPE T6 IS ACCESS ENUM; + TYPE T7 IS NEW ACC_T; + TYPE T8 IS + RECORD T : CHARACTER; END RECORD; + TYPE T9 IS NEW REC_T; + TYPE TA IS ACCESS TD; + TYPE TB IS ACCESS D_REC_T; + TYPE TD(I : INTEGER) IS + RECORD G : BOOLEAN; END RECORD; + + END P1; + + BEGIN + + NULL; + + END; + + + DECLARE + + TYPE ENUM IS ( A , B , C , D ); + + PACKAGE P0 IS + TYPE T0 IS LIMITED PRIVATE; + PRIVATE + TYPE T0 IS NEW ENUM; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE T1 IS LIMITED PRIVATE; + TYPE T2 IS LIMITED PRIVATE; + TYPE T3 IS LIMITED PRIVATE; + TYPE T4 IS LIMITED PRIVATE; + TYPE T5 IS LIMITED PRIVATE; + TYPE T6 IS LIMITED PRIVATE; + TYPE T7 IS LIMITED PRIVATE; + TYPE T8 IS LIMITED PRIVATE; + TYPE T9 IS LIMITED PRIVATE; + TYPE TA IS LIMITED PRIVATE; + TYPE TB IS LIMITED PRIVATE; + TYPE TC IS LIMITED PRIVATE; + TYPE TD(I : INTEGER) IS LIMITED PRIVATE; + TYPE NT IS NEW ENUM; + TYPE ARR_T IS ARRAY(1..2) OF BOOLEAN; + TYPE ACC_T IS ACCESS CHARACTER; + TYPE REC_T IS RECORD T : BOOLEAN; END RECORD; + TYPE D_REC_T(I : INTEGER := 1) IS + RECORD T : ENUM; END RECORD; + PRIVATE + TYPE TY(B : BOOLEAN) IS + RECORD G : BOOLEAN; END RECORD; + TYPE TC IS NEW T0; + TYPE T1 IS RANGE 1..100; + TYPE T2 IS NEW CHARACTER RANGE 'A'..'Z'; + TYPE T3 IS NEW NT; + TYPE T4 IS ARRAY(1..2) OF INTEGER; + TYPE T5 IS NEW ARR_T; + TYPE T6 IS ACCESS ENUM; + TYPE T7 IS NEW ACC_T; + TYPE T8 IS RECORD T : CHARACTER; END RECORD; + TYPE T9 IS NEW REC_T; + TYPE TA IS ACCESS TD; + TYPE TB IS ACCESS D_REC_T; + TYPE TD(I : INTEGER) IS + RECORD G : BOOLEAN; END RECORD; + + END P1; + + BEGIN + + NULL; + + END; + + + RESULT; + + + END A74106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- A74106B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED + -- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY TYPE, + -- RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE (WITH + -- OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY OF THE + -- ABOVE. + + -- PART B: TYPES INVOLVING FLOATING-POINT DATA. + + + -- RM 05/08/81 + + + WITH REPORT; + PROCEDURE A74106B IS + + USE REPORT; + + BEGIN + + TEST( "A74106B" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE " & + "TYPES CAN BE DEFINED IN TERMS OF " & + "FLOATING-POINT TYPES" ); + + DECLARE + + PACKAGE P0 IS + TYPE F0 IS PRIVATE; + PRIVATE + TYPE F0 IS NEW FLOAT; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE F1 IS PRIVATE; + TYPE F2 IS PRIVATE; + TYPE F3 IS PRIVATE; + TYPE F4 IS PRIVATE; + TYPE F5 IS PRIVATE; + TYPE F6 IS PRIVATE; + TYPE F7 IS PRIVATE; + TYPE F8 IS PRIVATE; + TYPE F9 IS PRIVATE; + TYPE FA IS PRIVATE; + TYPE FB IS PRIVATE; + TYPE FC IS PRIVATE; + TYPE FD(I : INTEGER) IS PRIVATE; + TYPE NF IS NEW FLOAT; + TYPE ARR_F IS ARRAY(1..2) OF FLOAT; + TYPE ACC_F IS ACCESS FLOAT; + TYPE REC_F IS RECORD F : FLOAT; END RECORD; + TYPE D_REC_F(I : INTEGER := 1) IS + RECORD F : FLOAT; END RECORD; + PRIVATE + TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD; + TYPE FC IS NEW F0; + TYPE F1 IS DIGITS 3; + TYPE F2 IS NEW FLOAT DIGITS 4; + TYPE F3 IS NEW NF; + TYPE F4 IS ARRAY(1..2) OF FLOAT; + TYPE F5 IS NEW ARR_F; + TYPE F6 IS ACCESS FLOAT; + TYPE F7 IS NEW ACC_F; + TYPE F8 IS RECORD F : FLOAT; END RECORD; + TYPE F9 IS NEW REC_F; + TYPE FA IS ACCESS FD; + TYPE FB IS ACCESS D_REC_F; + TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD; + + END P1; + + BEGIN + + NULL; + + END; + + + DECLARE + + PACKAGE P0 IS + TYPE F0 IS LIMITED PRIVATE; + PRIVATE + TYPE F0 IS NEW FLOAT; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE F1 IS LIMITED PRIVATE; + TYPE F2 IS LIMITED PRIVATE; + TYPE F3 IS LIMITED PRIVATE; + TYPE F4 IS LIMITED PRIVATE; + TYPE F5 IS LIMITED PRIVATE; + TYPE F6 IS LIMITED PRIVATE; + TYPE F7 IS LIMITED PRIVATE; + TYPE F8 IS LIMITED PRIVATE; + TYPE F9 IS LIMITED PRIVATE; + TYPE FA IS LIMITED PRIVATE; + TYPE FB IS LIMITED PRIVATE; + TYPE FC IS LIMITED PRIVATE; + TYPE FD(I : INTEGER) IS LIMITED PRIVATE; + TYPE NF IS NEW FLOAT; + TYPE ARR_F IS ARRAY(1..2) OF FLOAT; + TYPE ACC_F IS ACCESS FLOAT; + TYPE REC_F IS RECORD F : FLOAT; END RECORD; + TYPE D_REC_F(I : INTEGER := 1) IS + RECORD F : FLOAT; END RECORD; + PRIVATE + TYPE FY(B : BOOLEAN) IS RECORD G : FLOAT; END RECORD; + TYPE FC IS NEW F0; + TYPE F1 IS DIGITS 3; + TYPE F2 IS NEW FLOAT DIGITS 4; + TYPE F3 IS NEW NF; + TYPE F4 IS ARRAY(1..2) OF FLOAT; + TYPE F5 IS NEW ARR_F; + TYPE F6 IS ACCESS FLOAT; + TYPE F7 IS NEW ACC_F; + TYPE F8 IS RECORD F : FLOAT; END RECORD; + TYPE F9 IS NEW REC_F; + TYPE FA IS ACCESS FD; + TYPE FB IS ACCESS D_REC_F; + TYPE FD(I : INTEGER) IS RECORD G : FLOAT; END RECORD; + + END P1; + + BEGIN + + NULL; + + END; + + + RESULT; + + + END A74106B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74106c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74106c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- A74106C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FULL DECLARATION FOR A PRIVATE TYPE OR FOR A LIMITED + -- PRIVATE TYPE CAN BE GIVEN IN TERMS OF ANY SCALAR TYPE, ARRAY + -- TYPE, RECORD TYPE (WITH OR WITHOUT DISCRIMINANTS), ACCESS TYPE + -- (WITH OR WITHOUT DISCRIMINANTS), OR ANY TYPE DERIVED FROM ANY + -- OF THE ABOVE. + + -- PART C: TYPES INVOLVING FIXED-POINT DATA. + + -- HISTORY: + -- RM 05/11/81 CREATED ORIGINAL TEST. + -- DHH 10/15/87 CORRECTED RANGE ERRORS. + + + WITH REPORT; + PROCEDURE A74106C IS + + USE REPORT; + + BEGIN + + TEST( "A74106C" , "CHECK THAT PRIVATE TYPES AND LIMITED PRIVATE" & + " TYPES CAN BE DEFINED IN TERMS OF" & + " FIXED-POINT TYPES" ); + + DECLARE + + PACKAGE P0 IS + TYPE F0 IS PRIVATE; + PRIVATE + TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0; + TYPE F1 IS PRIVATE; + TYPE F2 IS PRIVATE; + TYPE F3 IS PRIVATE; + TYPE F4 IS PRIVATE; + TYPE F5 IS PRIVATE; + TYPE F6 IS PRIVATE; + TYPE F7 IS PRIVATE; + TYPE F8 IS PRIVATE; + TYPE F9 IS PRIVATE; + TYPE FA IS PRIVATE; + TYPE FB IS PRIVATE; + TYPE FC IS PRIVATE; + TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0; + TYPE ARR_F IS ARRAY(1..2) OF FX; + TYPE ACC_F IS ACCESS FX; + TYPE REC_F IS RECORD F : FX; END RECORD; + TYPE D_REC_F(I : INTEGER := 1) IS + RECORD F : FX; END RECORD; + PRIVATE + TYPE FC IS NEW F0; + TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0; + TYPE F2 IS NEW FX RANGE 0.0 .. 0.5; + TYPE F3 IS NEW NF; + TYPE F4 IS ARRAY(1..2) OF FX; + TYPE F5 IS NEW ARR_F; + TYPE F6 IS ACCESS FX; + TYPE F7 IS NEW ACC_F; + TYPE F8 IS RECORD F : FX; END RECORD; + TYPE F9 IS NEW REC_F; + TYPE FA IS ACCESS D_REC_F; + TYPE FB IS ACCESS D_REC_F; + END P1; + + BEGIN + + NULL; + + END; + + + DECLARE + + PACKAGE P0 IS + TYPE F0 IS LIMITED PRIVATE; + PRIVATE + TYPE F0 IS DELTA 1.0 RANGE 0.0 .. 10.0; + END P0; + + PACKAGE P1 IS + USE P0; + TYPE FX IS DELTA 0.1 RANGE 0.0 .. 1.0; + TYPE F1 IS LIMITED PRIVATE; + TYPE F2 IS LIMITED PRIVATE; + TYPE F3 IS LIMITED PRIVATE; + TYPE F4 IS LIMITED PRIVATE; + TYPE F5 IS LIMITED PRIVATE; + TYPE F6 IS LIMITED PRIVATE; + TYPE F7 IS LIMITED PRIVATE; + TYPE F8 IS LIMITED PRIVATE; + TYPE F9 IS LIMITED PRIVATE; + TYPE FA IS LIMITED PRIVATE; + TYPE FB IS LIMITED PRIVATE; + TYPE FC IS LIMITED PRIVATE; + TYPE NF IS DELTA 0.1 RANGE 1.0 .. 2.0; + TYPE ARR_F IS ARRAY(1..2) OF FX; + TYPE ACC_F IS ACCESS FX; + TYPE REC_F IS RECORD F : FX; END RECORD; + TYPE D_REC_F(I : INTEGER := 1) IS + RECORD F : FX; END RECORD; + PRIVATE + TYPE FC IS NEW F0; + TYPE F1 IS DELTA 100.0 RANGE -100.0 .. 900.0; + TYPE F2 IS NEW FX RANGE 0.0 .. 0.5; + TYPE F3 IS NEW NF; + TYPE F4 IS ARRAY(1..2) OF FX; + TYPE F5 IS NEW ARR_F; + TYPE F6 IS ACCESS FX; + TYPE F7 IS NEW ACC_F; + TYPE F8 IS RECORD F : FX; END RECORD; + TYPE F9 IS NEW REC_F; + TYPE FA IS ACCESS D_REC_F; + TYPE FB IS ACCESS D_REC_F; + END P1; + + BEGIN + + NULL; + + END; + + + RESULT; + + + END A74106C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74205e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74205e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74205e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74205e.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- A74205E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ADDITIONAL OPERATIONS FOR A COMPOSITE TYPE WITH A + -- COMPONENT OF A PRIVATE TYPE ARE AVAILABLE AT THE EARLIEST + -- PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION OF THE COMPOSITE + -- TYPE AND AFTER THE FULL DECLARATION OF THE PRIVATE TYPE. + + -- IN PARTICULAR, CHECH FOR THE FOLLOWING : + + -- (1) RELATIONAL OPERATORS WITH ARRAYS OF SCALAR TYPES + -- (2) EQUALITY WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES + -- (3) LOGICAL OPERATORS WITH ARRAYS OF BOOLEAN TYPES + -- (4) CATENATION WITH ARRAYS OF LIMITED PRIVATE TYPES + -- (5) INITIALIZATION WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES + -- (6) ASSIGNMENT WITH ARRAYS AND RECORDS OF LIMITED PRIVATE TYPES + -- (7) SELECTED COMPONENTS WITH COMPOSITES OF PRIVATE RECORD TYPES + -- (8) INDEXED COMPONENTS WITH COMPOSITES OF PRIVATE ARRAY TYPES + -- (9) SLICES WITH COMPOSITES OF PRIVATE ARRAY TYPES + -- (10) QUALIFICATION FOR COMPOSITES OF PRIVATE TYPES + -- (11) AGGREGATES FOR ARRAYS AND RECORDS OF PRIVATES TYPES + -- (12) USE OF 'SIZE FOR ARRAYS AND RECORDS OF PRIVATE TYPES + + -- DSJ 5/2/83 + + WITH REPORT ; + PROCEDURE A74205E IS + + USE REPORT ; + + BEGIN + + TEST("A74205E", "CHECK THAT ADDITIONAL OPERATIONS FOR " + & "COMPOSITE TYPES OF PRIVATE TYPES ARE " + & "AVAILABLE AT THE EARLIEST PLACE AFTER THE " + & "FULL DECLARATION AND IN THE IMMEDIATE " + & "SCOPE OF THE COMPOSITE TYPE") ; + + DECLARE + + PACKAGE PACK1 IS + TYPE LP1 IS LIMITED PRIVATE ; + PACKAGE PACK_LP IS + TYPE LP_ARR IS ARRAY (INTEGER RANGE <>) OF LP1 ; + SUBTYPE LP_ARR2 IS LP_ARR ( 1 .. 2 ) ; + SUBTYPE LP_ARR4 IS LP_ARR ( 1 .. 4 ) ; + END PACK_LP ; + + TYPE T1 IS PRIVATE ; + PACKAGE PACK2 IS + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF T1 ; + SUBTYPE ARR2 IS ARR ( 1 .. 2 ) ; + SUBTYPE ARR4 IS ARR ( 1 .. 4 ) ; + END PACK2 ; + + TYPE T2 IS PRIVATE ; + TYPE T3 IS PRIVATE ; + PACKAGE PACK3 IS + TYPE ARR_T2 IS ARRAY ( 1 .. 2 ) OF T2 ; + TYPE ARR_T3 IS ARRAY ( 1 .. 2 ) OF T3 ; + END PACK3 ; + PRIVATE + TYPE LP1 IS NEW BOOLEAN ; + TYPE T1 IS NEW BOOLEAN ; + TYPE T2 IS ARRAY ( 1 .. 2 ) OF INTEGER ; + TYPE T3 IS + RECORD + C1 : INTEGER ; + END RECORD ; + END PACK1 ; + + PACKAGE BODY PACK1 IS + + PACKAGE BODY PACK_LP IS + L1, L2 : LP_ARR2 := (TRUE,FALSE) ; -- LEGAL + A3 : LP_ARR2 := L1 ; -- LEGAL + B3 : BOOLEAN := L1 = L2 ; -- LEGAL + B4 : BOOLEAN := L1 /= L2 ; -- LEGAL + END PACK_LP ; + + PACKAGE BODY PACK2 IS + A1, A2 : ARR2 := (FALSE,TRUE) ; -- LEGAL + A4 : ARR2 := ARR2'(A1) ; -- LEGAL + B1 : BOOLEAN := A1 < A2 ; -- LEGAL + B2 : BOOLEAN := A1 >= A2 ; -- LEGAL + N3 : INTEGER := A1'SIZE ; -- LEGAL + PROCEDURE G1 (X : ARR2 := NOT A1) IS -- LEGAL + BEGIN + NULL ; + END G1 ; + + PROCEDURE G2 (X : ARR2 := A1 AND A2) IS -- LEGAL + BEGIN + NULL ; + END G2 ; + + PROCEDURE G3 (X : ARR4 := A1 & A2) IS -- LEGAL + BEGIN + NULL ; + END G3 ; + + PROCEDURE G4 (X : ARR2 := (FALSE,TRUE) ) IS -- LEGAL + BEGIN + NULL ; + END G4 ; + END PACK2 ; + + PACKAGE BODY PACK3 IS + X2 : ARR_T2 := + (1=>(1,2), 2=>(3,4)) ; -- LEGAL + X3 : ARR_T3 := + (1=>(C1=>5), 2=>(C1=>6)) ; -- LEGAL + N1 : INTEGER := X3(1).C1 ; -- LEGAL + N2 : INTEGER := X2(1)(2) ; -- LEGAL + N4 : T2 := X2(1)(1..2) ; -- LEGAL + END PACK3 ; + + END PACK1 ; + + BEGIN + + NULL ; + + END ; + + RESULT ; + + END A74205E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74205f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74205f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a74205f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a74205f.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- A74205F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR AN ACCESS TYPE WHOSE DESIGNATED TYPE IS A PRIVATE TYPE + -- ADDITIONAL OPERATIONS FOR THE ACCESS TYPE WHICH DEPEND ON + -- CHARACTERISTICS OF THE FULL DECLARATION OF THE PRIVATE TYPE ARE MADE + -- AVAILABLE AT THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE + -- ACCESS TYPE DECLARATION AND AFTER THE FULL DECLARATION OF THE PRIVATE + -- TYPE. + + -- (1) CHECK FOR COMPONENT SELECTION WITH RECORD TYPES + -- (2) CHECK FOR INDEXED COMPONENTS AND SLICES WITH ARRAY TYPES + -- (3) CHECK FOR USE OF 'FIRST, 'LAST, 'RANGE, AND 'LENGTH WITH ARRAY + -- TYPES + + -- DSJ 5/5/83 + + WITH REPORT ; + PROCEDURE A74205F IS + + USE REPORT ; + + BEGIN + + TEST("A74205F", "CHECK THAT ADDITIONAL OPERATIONS OF ACCESS TYPES " + & "OF PRIVATE TYPES ARE AVAILABLE AT THE EARLIEST " + & "PLACE IN THE IMMEDIATE SCOPE OF THE ACCESS TYPE " + & "AND AFTER THE FULL DECLARATION") ; + + DECLARE + + PACKAGE PACK1 IS + TYPE T1 IS PRIVATE ; + TYPE T2 IS PRIVATE ; + PACKAGE PACK2 IS + TYPE ACC1 IS ACCESS T1 ; + TYPE ACC2 IS ACCESS T2 ; + END PACK2 ; + PRIVATE + TYPE T1 IS ARRAY ( 1 .. 2 ) OF INTEGER ; + TYPE T2 IS + RECORD + C1, C2 : INTEGER ; + END RECORD ; + END PACK1 ; + + PACKAGE BODY PACK1 IS + A1 : PACK2.ACC1 := NEW T1'(2,4) ; -- LEGAL + A2 : PACK2.ACC1 := NEW T1'(6,8) ; -- LEGAL + R1 : PACK2.ACC2 := NEW T2'(3,5) ; -- LEGAL + R2 : PACK2.ACC2 := NEW T2'(7,9) ; -- LEGAL + + PACKAGE BODY PACK2 IS + X1 : INTEGER := A1(1) ; -- LEGAL + X2 : INTEGER := A1'FIRST ; -- LEGAL + X3 : INTEGER := A1'LAST ; -- LEGAL + X4 : INTEGER := A1'LENGTH ; -- LEGAL + B1 : BOOLEAN := 3 IN A1'RANGE ; -- LEGAL + X5 : INTEGER := R1.C1 ; -- LEGAL + END PACK2 ; + + END PACK1 ; + + BEGIN + + NULL ; + + END ; + + RESULT ; + + END A74205F ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83009a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- A83009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED TYPE DECLARATION AND A GENERIC + -- INSTANTIATION MAY DERIVE TWO OR MORE SUBPROGRAM HOMOGRAPHS. + -- CHECK THE CASES WHERE: + -- 1) THE DERIVED SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF THE + -- SUBSTITUTION OF THE DERIVED TYPE FOR THE PARENT TYPE IN + -- THE IMPLICIT SUBPROGRAM SPECIFICATIONS. + -- 2) THE PARENT TYPE IS DECLARED IN A GENERIC INSTANCE AND + -- THE INSTANCE INCLUDES TWO OR MORE DERIVABLE SUBPROGRAMS + -- THAT ARE HOMOGRAPHS AS A RESULT OF THE ARGUMENTS GIVEN + -- FOR THE GENERIC FORMAL-TYPE PARAMETERS. + -- TEST CASES WHERE THE DERIVED TYPE DECLARATIONS AND GENERIC + -- INSTANTIATIONS ARE GIVEN IN: + -- . THE VISIBLE PART OF A PACKAGE SPECIFICATION, + -- . THE PRIVATE PART OF A PACKAGE SPECIFICATION, + -- . A PACKAGE BODY, + -- . A SUBPROGRAM BODY, + -- . A BLOCK STATEMENT. + -- + -- HISTORY: + -- VCL 03-08-88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE A83009A IS + TYPE ENUM IS (E1, E2, E3); + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + PACKAGE G_PACK IS + TYPE PARENT IS (E1, E2, E3); + + PROCEDURE HP (P1 : PARENT; P2 : T1); + PROCEDURE HP (P3 : PARENT; P4 : T2); + + FUNCTION HF (P1 : T1) RETURN PARENT; + FUNCTION HF (P2 : T2) RETURN PARENT; + END G_PACK; + + PACKAGE BODY G_PACK IS + PROCEDURE HP (P1 : PARENT; P2 : T1) IS + BEGIN + NULL; + END HP; + + PROCEDURE HP (P3 : PARENT; P4 : T2) IS + BEGIN + NULL; + END HP; + + FUNCTION HF (P1 : T1) RETURN PARENT IS + BEGIN + RETURN E1; + END HF; + + FUNCTION HF (P2 : T2) RETURN PARENT IS + BEGIN + RETURN E2; + END HF; + END G_PACK; + BEGIN + TEST ("A83009A", "A DERIVED TYPE DECLARATION AND A GENERIC " & + "INSTANTIATION MAY DERIVE TWO OR " & + "MORE SUBPROGRAM HOMOGRAPHS"); + + DECLARE + -- SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF SUBSTITUTION. + + PACKAGE PACK2 IS + TYPE CHILD1 IS PRIVATE; + + PACKAGE IN_PACK2 IS + TYPE PARENT IS (E1, E2, E3); + PROCEDURE HP (P1 : PARENT; P2 : CHILD1); + PROCEDURE HP (P3 : CHILD1; P4 : PARENT); + + FUNCTION HF (P1 : CHILD1; P2 : PARENT) + RETURN PARENT; + FUNCTION HF (P3 : PARENT; P4 : CHILD1) + RETURN PARENT; + END IN_PACK2; + PRIVATE + TYPE CHILD1 IS NEW IN_PACK2.PARENT; + END PACK2; + + PACKAGE BODY PACK2 IS + TYPE CHILD2 IS NEW CHILD1; + + PACKAGE IN_BODY IS + TYPE CHILD3 IS NEW CHILD1; + END IN_BODY; + + PROCEDURE P IS + TYPE CHILD4 IS NEW CHILD1; + BEGIN + NULL; + END; + + PACKAGE BODY IN_PACK2 IS + PROCEDURE HP (P1 : PARENT; P2 : CHILD1) IS + BEGIN + NULL; + END HP; + + PROCEDURE HP (P3 : CHILD1; P4 : PARENT) IS + BEGIN + NULL; + END HP; + + FUNCTION HF (P1 : CHILD1; P2 : PARENT) + RETURN PARENT IS + BEGIN + RETURN E1; + END HF; + + FUNCTION HF (P3 : PARENT; P4 : CHILD1) + RETURN PARENT IS + BEGIN + RETURN E2; + END HF; + END IN_PACK2; + BEGIN + DECLARE + TYPE CHILD5 IS NEW CHILD1; + BEGIN + NULL; + END; + END PACK2; + BEGIN + NULL; + END; + + DECLARE + -- PARENT TYPE IN GENERIC INSTANCE HAS DERIVABLE HOMOGRAPHS. + + PACKAGE INSTANCE1 IS + NEW G_PACK (BOOLEAN, BOOLEAN); + + TYPE CHILD1 IS NEW INSTANCE1.PARENT; + + PACKAGE PACK1 IS + PACKAGE INSTANCE2 IS + NEW G_PACK (CHARACTER, CHARACTER); + + TYPE CHILD2 IS NEW INSTANCE2.PARENT; + TYPE CHILD3 IS PRIVATE; + PRIVATE + PACKAGE INSTANCE3 IS + NEW G_PACK (ENUM, ENUM); + + TYPE CHILD3 IS NEW INSTANCE3.PARENT; + END PACK1; + + PROCEDURE P1 IS + PACKAGE INSTANCE4 IS + NEW G_PACK (BOOLEAN, BOOLEAN); + + TYPE CHILD4 IS NEW INSTANCE4.PARENT; + BEGIN + NULL; + END P1; + + PACKAGE BODY PACK1 IS + PACKAGE INSTANCE5 IS + NEW G_PACK (ENUM, ENUM); + + TYPE CHILD5 IS NEW INSTANCE5.PARENT; + END PACK1; + BEGIN + NULL; + END; + + RESULT; + END A83009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83009b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83009b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83009b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83009b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- A83009B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED TYPE DECLARATION IN A GENERIC + -- UNIT MAY DERIVE TWO OR MORE SUBPROGRAM HOMOGRAPHS. + -- CHECK THE CASES WHERE: + -- 1) THE DERIVED SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF THE + -- SUBSTITUTION OF THE DERIVED TYPE FOR THE PARENT TYPE IN + -- THE IMPLICIT SUBPROGRAM SPECIFICATIONS. + -- 2) THE PARENT TYPE IS DECLARED IN A GENERIC INSTANCE AND + -- THE INSTANCE INCLUDES TWO OR MORE DERIVABLE SUBPROGRAMS + -- THAT ARE HOMOGRAPHS AS A RESULT OF THE ARGUMENTS GIVEN + -- FOR THE GENERIC FORMAL-TYPE PARAMETERS. + -- TEST CASES WHERE THE DERIVED TYPE DECLARATIONS ARE GIVEN IN: + -- . THE VISIBLE PART OF A GENERIC PACKAGE SPECIFICATION, + -- . THE PRIVATE PART OF A GENERIC PACKAGE SPECIFICATION, + -- . A GENERIC PACKAGE BODY, + -- . A GENERIC SUBPROGRAM BODY. + -- + -- HISTORY: + -- DHH 09/20/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE A83009B IS + TYPE ENUM IS (E1, E2, E3); + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + PACKAGE G_PACK IS + TYPE PARENT IS (E1, E2, E3); + + PROCEDURE HP (P1 : PARENT; P2 : T1); + PROCEDURE HP (P3 : PARENT; P4 : T2); + + FUNCTION HF (P1 : T1) RETURN PARENT; + FUNCTION HF (P2 : T2) RETURN PARENT; + END G_PACK; + + PACKAGE BODY G_PACK IS + PROCEDURE HP (P1 : PARENT; P2 : T1) IS + BEGIN + NULL; + END HP; + + PROCEDURE HP (P3 : PARENT; P4 : T2) IS + BEGIN + NULL; + END HP; + + FUNCTION HF (P1 : T1) RETURN PARENT IS + BEGIN + RETURN E1; + END HF; + + FUNCTION HF (P2 : T2) RETURN PARENT IS + BEGIN + RETURN E2; + END HF; + END G_PACK; + BEGIN + TEST ("A83009B", "A DERIVED TYPE DECLARATION IN A GENERIC " & + "UNIT MAY DERIVE TWO OR MORE SUBPROGRAM " & + "HOMOGRAPHS"); + + DECLARE + -- SUBPROGRAMS BECOME HOMOGRAPHS BECAUSE OF SUBSTITUTION. + + GENERIC + PACKAGE PACK2 IS + TYPE CHILD1 IS PRIVATE; + + PACKAGE IN_PACK2 IS + TYPE PARENT IS (E1, E2, E3); + PROCEDURE HP (P1 : PARENT; P2 : CHILD1); + PROCEDURE HP (P3 : CHILD1; P4 : PARENT); + + FUNCTION HF (P1 : CHILD1; P2 : PARENT) + RETURN PARENT; + FUNCTION HF (P3 : PARENT; P4 : CHILD1) + RETURN PARENT; + END IN_PACK2; + + USE IN_PACK2; + PRIVATE + TYPE CHILD1 IS NEW IN_PACK2.PARENT; -- PRIVATE PART + END PACK2; -- OF SPEC. + + PACKAGE BODY PACK2 IS + TYPE CHILD2 IS NEW CHILD1; -- VISIBLE PART OF BODY. + + GENERIC + PACKAGE IN_BODY IS + TYPE CHILD3 IS NEW CHILD1; -- VISIBLE PART OF SPEC. + END IN_BODY; + + GENERIC + PROCEDURE P; + PROCEDURE P IS + TYPE CHILD4 IS NEW CHILD1; -- SUBPROGRAM BODY. + BEGIN + NULL; + END; + + PACKAGE BODY IN_PACK2 IS + PROCEDURE HP (P1 : PARENT; P2 : CHILD1) IS + BEGIN + NULL; + END HP; + + PROCEDURE HP (P3 : CHILD1; P4 : PARENT) IS + BEGIN + NULL; + END HP; + + FUNCTION HF (P1 : CHILD1; P2 : PARENT) + RETURN PARENT IS + BEGIN + RETURN E1; + END HF; + + FUNCTION HF (P3 : PARENT; P4 : CHILD1) + RETURN PARENT IS + BEGIN + RETURN E2; + END HF; + END IN_PACK2; + BEGIN + NULL; + END PACK2; + BEGIN + NULL; + END; + + DECLARE + -- PARENT TYPE IN GENERIC INSTANCE HAS DERIVABLE HOMOGRAPHS. + + GENERIC + PACKAGE PACK1 IS + PACKAGE INSTANCE2 IS + NEW G_PACK (CHARACTER, CHARACTER); + + TYPE CHILD2 IS NEW INSTANCE2.PARENT; + TYPE CHILD3 IS PRIVATE; + PRIVATE + PACKAGE INSTANCE3 IS + NEW G_PACK (ENUM, ENUM); + + TYPE CHILD3 IS NEW INSTANCE3.PARENT; + END PACK1; + + GENERIC + PROCEDURE P1; + PROCEDURE P1 IS + PACKAGE INSTANCE4 IS + NEW G_PACK (BOOLEAN, BOOLEAN); + + TYPE CHILD4 IS NEW INSTANCE4.PARENT; + BEGIN + NULL; + END P1; + + PACKAGE BODY PACK1 IS + PACKAGE INSTANCE5 IS + NEW G_PACK (ENUM, ENUM); + + TYPE CHILD5 IS NEW INSTANCE5.PARENT; + END PACK1; + BEGIN + NULL; + END; + + RESULT; + END A83009B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a02a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- A83A02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A LABEL IN A NESTED SUBPROGRAM OR PACKAGE CAN BE IDENTICAL + -- TO A LABEL OUTSIDE SUCH CONSTRUCT. + + + -- "INSIDE LABEL": INSIDE * PACKAGE _PACK A + -- * FUNCTION INSIDE PACKAGE _PACKFUN B + -- * PROCEDURE _PROC C + -- * PROCEDURE INSIDE BLOCK _BLOCKPROC D + + -- "OUTSIDE LABEL": INSIDE * MAIN _MAIN 1 + -- * BLOCK IN MAIN _BLOCK 2 + -- * LOOP IN BLOCK IN MAIN _BLOCKLOOP 3 + -- * LOOP IN MAIN _LOOP 4 + + -- CASES TESTED: A1 B2 A3 B4 1 2 3 4 + -- D1 C2 C3 D4 + -- D2 AB A X . X . + -- B . X . X + -- C . X X . + -- D X . . X + + + -- RM 02/09/80 + + + WITH REPORT ; + PROCEDURE A83A02A IS + + USE REPORT ; + + PROCEDURE PROC1 IS + BEGIN + << LAB_PROC_BLOCK >> NULL ; -- C2 C + << LAB_PROC_BLOCKLOOP >> NULL ; -- C3 + END PROC1 ; + + PACKAGE PACK1 IS + FUNCTION F RETURN INTEGER ; + END PACK1 ; + + PACKAGE BODY PACK1 IS + FUNCTION F RETURN INTEGER IS + BEGIN + << LAB_PACKFUN_BLOCK >> NULL ; -- B2 B + << LAB_PACKFUN_LOOP >> NULL ; -- B4 + << LAB_PACKFUN_PACK >> NULL ; -- BA (AB) + RETURN 7 ; + END F ; + BEGIN + << LAB_PACK_MAIN >> NULL ; -- A1 A + << LAB_PACK_BLOCKLOOP >> NULL ; -- A3 + << LAB_PACKFUN_PACK >> NULL ; -- BA (AB) + END PACK1 ; + + BEGIN + + TEST( "A83A02A" , "CHECK THAT A LABEL IN A NESTED SUBPROGRAM" & + " OR PACKAGE CAN BE IDENTICAL TO A LABEL" & + " OUTSIDE SUCH CONSTRUCT" ); + + << LAB_PACK_MAIN >> NULL ; -- A1 1 + << LAB_BLOCKPROC_MAIN >> NULL ; -- D1 + + + DECLARE -- + + PROCEDURE PROC2 IS + BEGIN + << LAB_BLOCKPROC_MAIN >> NULL ; -- D1 D + << LAB_BLOCKPROC_LOOP >> NULL ; -- D4 + << LAB_BLOCKPROC_BLOCK >> NULL ; -- D2 + END PROC2 ; + + BEGIN + + << LAB_PACKFUN_BLOCK >> NULL ; -- B2 2 + << LAB_PROC_BLOCK >> NULL ; -- C2 + << LAB_BLOCKPROC_BLOCK >> NULL ; -- D2 + + FOR I IN 1..2 LOOP + << LAB_PACK_BLOCKLOOP >> NULL ; -- A3 3 + << LAB_PROC_BLOCKLOOP >> NULL ; -- C3 + END LOOP; + + END ; + + FOR I IN 1..2 LOOP + << LAB_PACKFUN_LOOP >> NULL ; -- B4 4 + << LAB_BLOCKPROC_LOOP >> NULL ; -- D4 + END LOOP; + + + RESULT ; + + + END A83A02A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a02b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a02b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a02b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a02b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- A83A02B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A LABEL IN A NESTED TASK CAN BE IDENTICAL TO A LABEL + -- OUTSIDE THE TASK. + + + -- "INSIDE LABEL": INSIDE * TASK BODY _TASK A + -- * BLOCK IN TASK BODY _TASKBLOCK B + -- * LOOP IN BLOCK IN TASK BODY _TASKBLOCKLOOP + -- * ACCEPT ST. WITHIN TASK BDY _TASKACCEPT D + + -- "OUTSIDE LABEL": INSIDE * MAIN _MAIN 1 + -- * BLOCK IN MAIN _BLOCK 2 + -- * LOOP IN BLOCK IN MAIN _BLOCKLOOP 3 + -- * LOOP IN MAIN _LOOP 4 + + -- CASES TESTED: A1 B2 A3 B4 | 1 2 3 4 + -- D1 C2 C3 D4 ---+---------- + -- A | X . X . + -- B | . X . X + -- C | . X X . + -- D | X . . X + + + -- RM 02/10/80 + + + WITH REPORT ; + PROCEDURE A83A02B IS + + USE REPORT ; + + TASK TYPE TASK1 IS + ENTRY E1 ; + END TASK1 ; + + TASK BODY TASK1 IS + BEGIN + + << LAB_TASK_MAIN >> NULL ; -- A1 A + << LAB_TASK_BLOCKLOOP >> NULL ; -- A3 + + BEGIN + + << LAB_TASKBLOCK_BLOCK >> NULL ; -- B2 B + << LAB_TASKBLOCK_LOOP >> NULL ; -- B4 + + FOR I IN 1..2 LOOP + << LAB_TASKBLOCKLOOP_BLOCK >>NULL ; -- C2 C + << LAB_TASKBLOCKLOOP_BLOCKLOOP >> + NULL ; -- C3 + END LOOP; + + END ; + + ACCEPT E1 DO + << LAB_TASKACCEPT_MAIN >> NULL ; -- D1 D + << LAB_TASKACCEPT_LOOP >> NULL ; -- D4 + END E1 ; + + END TASK1 ; + + BEGIN + + TEST( "A83A02B" , "CHECK THAT A LABEL IN A NESTED TASK" & + " CAN BE IDENTICAL TO A LABEL" & + " OUTSIDE THE TASK" ); + + << LAB_TASK_MAIN >> NULL ; -- A1 1 + << LAB_TASKACCEPT_MAIN >> NULL ; -- D1 + + + BEGIN + + << LAB_TASKBLOCK_BLOCK >> NULL ; -- B2 2 + << LAB_TASKBLOCKLOOP_BLOCK >> NULL ; -- C2 + + FOR I IN 1..2 LOOP + << LAB_TASK_BLOCKLOOP >> NULL ; -- A3 3 + << LAB_TASKBLOCKLOOP_BLOCKLOOP >> NULL ; -- C3 + END LOOP; + + END ; + + FOR I IN 1..2 LOOP + << LAB_TASKBLOCK_LOOP >> NULL ; -- B4 4 + << LAB_TASKACCEPT_LOOP >> NULL ; -- D4 + END LOOP; + + + RESULT ; + + + END A83A02B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a06a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a06a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a06a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a06a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- A83A06A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STATEMENT LABEL INSIDE A BLOCK BODY CAN BE THE + -- SAME AS A VARIABLE, CONSTANT, NAMED LITERAL, SUBPROGRAM, + -- ENUMERATION LITERAL, TYPE, OR PACKAGE DECLARED IN THE + -- ENCLOSING BODY. + + + -- RM 02/12/80 + -- JBG 5/16/83 + -- JBG 8/21/83 + -- JRK 12/19/83 + + WITH REPORT; USE REPORT; + PROCEDURE A83A06A IS + + LAB_VAR : INTEGER; + LAB_CONST : CONSTANT INTEGER := 12; + LAB_NAMEDLITERAL : CONSTANT := 13; + TYPE ENUM IS ( AA , BB , LAB_ENUMERAL ); + TYPE LAB_TYPE IS NEW INTEGER; + + PROCEDURE LAB_PROCEDURE IS + BEGIN + NULL; + END LAB_PROCEDURE; + + FUNCTION LAB_FUNCTION RETURN INTEGER IS + BEGIN + RETURN 7; + END LAB_FUNCTION; + + PACKAGE LAB_PACKAGE IS + INT : INTEGER; + END LAB_PACKAGE; + + BEGIN + + TEST ("A83A06A", "CHECK THAT STATEMENT LABELS INSIDE A BLOCK " & + "BODY CAN BE THE SAME AS IDENTIFIERS DECLARED "& + "OUTSIDE THE BODY"); + + LAB_BLOCK_1 : BEGIN NULL; END LAB_BLOCK_1; + + LAB_LOOP_1 : LOOP EXIT; END LOOP LAB_LOOP_1; + + BEGIN + + << LAB_VAR >> -- OK. + BEGIN NULL; END; + << LAB_ENUMERAL >> NULL; -- OK. + + << LAB_PROCEDURE >> -- OK. + FOR I IN INTEGER LOOP + << LAB_CONST >> NULL; -- OK. + << LAB_TYPE >> NULL; -- OK. + << LAB_FUNCTION >> EXIT; -- OK. + END LOOP; + + << LAB_NAMEDLITERAL >> NULL; + << LAB_PACKAGE >> NULL; + END; + + LAB_BLOCK_2 : -- OK. + BEGIN NULL; END LAB_BLOCK_2; + + LAB_LOOP_2 : -- OK. + LOOP EXIT; END LOOP LAB_LOOP_2; + + RESULT; + + END A83A06A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a08a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a08a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83a08a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83a08a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- A83A08A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- A STATEMENT LABEL DECLARED OUTSIDE A BLOCK CAN HAVE THE SAME + -- IDENTIFIER AS AN ENTITY DECLARED IN THE BLOCK, AND A GOTO + -- STATEMENT USING THE LABEL IS LEGAL OUTSIDE THE BLOCK. + + -- HISTORY: + -- PMW 09/20/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + + PROCEDURE A83A08A IS + + PASSES : INTEGER := 0; + + BEGIN + TEST ("A83A08A", "A STATEMENT LABEL DECLARED OUTSIDE A BLOCK " & + "CAN HAVE THE SAME IDENTIFIER AS AN ENTITY " & + "DECLARED IN THE BLOCK, AND A GOTO STATEMENT " & + "USING THE LABEL IS LEGAL OUTSIDE THE BLOCK"); + + GOTO LBLS; + + <> + + DECLARE + LBL : INTEGER := 1; + BEGIN + LBL := IDENT_INT (LBL); + PASSES := PASSES + 1; + END; + + <> + + BEGIN + DECLARE + TYPE STUFF IS (LBL, LBL_ONE, LBL_TWO); + ITEM : STUFF := LBL; + + FUNCTION LBLS (ITEM : STUFF) RETURN BOOLEAN IS + BEGIN + <> + CASE ITEM IS + WHEN LBL => RETURN TRUE; + WHEN LBL_ONE => PASSES := PASSES + 1; + WHEN LBL_TWO => RETURN FALSE; + END CASE; + IF PASSES < 2 THEN + PASSES := PASSES + 1; + GOTO LBL_2; + ELSE + RETURN TRUE; + END IF; + END LBLS; + + BEGIN + CASE PASSES IS + WHEN 0 => ITEM := LBL; + WHEN 1 => ITEM := LBL_ONE; + WHEN OTHERS => ITEM := LBL_TWO; + END CASE; + IF NOT LBLS (ITEM) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + END; + + + IF PASSES > 1 THEN + GOTO ENOUGH; + END IF; + GOTO LBL; + + <> + + RESULT; + + END A83A08A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- A83C01C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT COMPONENT NAMES MAY BE THE SAME AS NAMES OF + -- FORMAL PARAMETERS, LABELS, LOOP PARAMETERS, + -- VARIABLES, CONSTANTS, SUBPROGRAMS, PACKAGES, TYPES. + -- (NAMES OF COMPONENTS IN LOGICALLY NESTED RECORDS ARE TESTED IN + -- C83C01B.ADA .) + -- (NAMES OF TASKS ARE TESTED IN A83C01T.ADA .) + + -- RM 24 JUNE 1980 + -- JRK 10 NOV 1980 + -- RM 01 JAN 1982 + + WITH REPORT; + PROCEDURE A83C01C IS + + USE REPORT; + + BEGIN + + TEST( "A83C01C" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" & + " NAMES OF VARIABLES AND CONSTANTS " ) ; + + + + DECLARE + + VAR1 , VAR2 : INTEGER := 27 ; + CONST1 : CONSTANT INTEGER := 13 ; + CONST2 : CONSTANT BOOLEAN := FALSE ; + + TYPE R1A IS + RECORD + VAR1,VAR2,CONST1:INTEGER ; + END RECORD ; + + TYPE R1 IS + RECORD + VAR1 : INTEGER ; + VAR2 : BOOLEAN ; + CONST1 : BOOLEAN ; + A : R1A ; + END RECORD ; + + A : R1 := ( VAR1 => VAR1 , A => ( VAR1 => VAR2 , + VAR2 => VAR2 , + CONST1 => VAR1 ) , + VAR2 => CONST2 , CONST1 => CONST2 ) ; + + BEGIN + + VAR1 := A.A.VAR2 ; + A.CONST1 := CONST2 ; + A.A.CONST1 := A.VAR1 + VAR2 ; + + END ; + + + RESULT; + + END A83C01C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01h.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- A83C01H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT COMPONENT NAMES MAY BE THE SAME AS NAMES OF + -- LABELS. + + -- RM 24 JUNE 1980 + -- JRK 10 NOV 1980 + -- RM 01 JAN 1982 + + + WITH REPORT; + PROCEDURE A83C01H IS + + USE REPORT; + + BEGIN + + TEST( "A83C01H" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" & + " NAMES OF LABELS" ) ; + + + -- TEST FOR LABELS + + DECLARE + + TYPE R1A IS + RECORD + LAB3 : INTEGER ; + END RECORD ; + + TYPE R1 IS + RECORD + LAB1 : INTEGER ; + LAB2 : R1A ; + END RECORD ; + + A1 : R1 := ( 1 , ( LAB3 => 5 ) ); + + BEGIN + + << LAB1 >> + << LAB2 >> + << LAB3 >> + + A1.LAB1 := A1.LAB2.LAB3 ; + + DECLARE + + TYPE R1A IS + RECORD + LAB3 : INTEGER ; + LAB4 : INTEGER ; + END RECORD ; + + TYPE R1 IS + RECORD + LAB1 : INTEGER ; + LAB2 : R1A ; + END RECORD ; + + A1 : R1 := ( 3 , ( 6 , 7 ) ); + + BEGIN + + << LAB4 >> + + A1.LAB1 := A1.LAB2.LAB3 + A1.LAB2.LAB4 ; + + END ; + + END ; + + + + RESULT; + + END A83C01H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a83c01i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a83c01i.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- A83C01I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT COMPONENT NAMES MAY BE THE SAME AS NAMES OF + -- LOOP PARAMETERS. + + -- RM 24 JUNE 1980 + -- JRK 10 NOV 1980 + -- RM 01 JAN 1982 + + + WITH REPORT; + PROCEDURE A83C01I IS + + USE REPORT; + + BEGIN + + TEST( "A83C01I" , "CHECK THAT COMPONENT NAMES MAY BE THE SAME AS" & + " NAMES OF LOOP PARAMETERS" ) ; + + + + -- TEST FOR LOOP PARAMETERS + + + DECLARE + + TYPE R1A IS + RECORD + LOOP3 : INTEGER ; + END RECORD ; + + TYPE R1 IS + RECORD + LOOP1 : INTEGER ; + LOOP2 : R1A ; + END RECORD ; + + A1 : R1 := ( 3 , ( LOOP3 => 7 ) ); + + BEGIN + + FOR LOOP1 IN 0..1 LOOP + + FOR LOOP2 IN 0..2 LOOP + + FOR LOOP3 IN 0..3 LOOP + + A1.LOOP1 := A1.LOOP2.LOOP3 ; + + DECLARE + + TYPE R1A IS + RECORD + LOOP3 : INTEGER ; + LOOP4 : INTEGER ; + END RECORD ; + + TYPE R1 IS + RECORD + LOOP1 : INTEGER ; + LOOP2 : R1A ; + END RECORD ; + + A1 : R1 := ( 3 , ( 6 , 7 ) ); + + BEGIN + + FOR LOOP4 IN 0..4 LOOP + + A1.LOOP1 := A1.LOOP2.LOOP3 + + A1.LOOP2.LOOP4 ; + + END LOOP ; + + END ; + + END LOOP ; + + END LOOP ; + + END LOOP ; + + END ; + + + + RESULT; + + END A83C01I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a85007d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a85007d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a85007d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a85007d.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- A85007D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'FIRST, 'LAST, 'LENGTH, 'RANGE, 'ADDRESS, 'CONSTRAINED, + -- AND 'SIZE CAN BE APPLIED TO RENAMED NON-ACCESS OUT FORMAL PARAMETERS + -- AND RENAMED COMPONENTS OF NON-ACCESS OUT PARAMETERS. + + -- SPS 02/21/84 (SEE A62006D-B.ADA) + -- EG 02/22/84 + -- EG 05/30/84 + -- JBG 12/2/84 + + WITH REPORT; USE REPORT; + WITH SYSTEM; + + PROCEDURE A85007D IS + + PROCEDURE Q (X : SYSTEM.ADDRESS) IS + BEGIN + NULL; + END Q; + + BEGIN + + TEST ("A85007D", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " & + "RENAMED NON-ACCESS FORMAL OUT PARAMETERS"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 2) OF BOOLEAN; + TYPE REC (D : INTEGER) IS RECORD + Y : BOOLEAN; + X : ARR; + END RECORD; + + PROCEDURE PROC (C2 : OUT ARR; + C3 : OUT REC) IS + + X : SYSTEM.ADDRESS; + I : INTEGER; + + C21 : ARR RENAMES C2; + C22 : ARR RENAMES C21; + C31 : REC RENAMES C3; + C32 : REC RENAMES C31; + C33 : ARR RENAMES C3.X; + C34 : ARR RENAMES C33; + C35 : ARR RENAMES C32.X; + C36 : BOOLEAN RENAMES C3.Y; + C37 : BOOLEAN RENAMES C36; + C38 : BOOLEAN RENAMES C32.Y; + + BEGIN + + I := C21'LENGTH; + Q(C21'ADDRESS); + I := C21'SIZE; + I := C22'LENGTH; + Q(C22'ADDRESS); + I := C22'SIZE; + + FOR I IN C21'RANGE LOOP + NULL; + END LOOP; + FOR I IN C22'RANGE LOOP + NULL; + END LOOP; + + FOR I IN C21'FIRST..C21'LAST LOOP + NULL; + END LOOP; + FOR I IN C22'FIRST..C22'LAST LOOP + NULL; + END LOOP; + + I := C31.X'LENGTH; + C3.Y := C31'CONSTRAINED; + FOR J IN C31.X'RANGE LOOP + NULL; + END LOOP; + FOR J IN C31.X'FIRST..C31.X'LAST LOOP + NULL; + END LOOP; + I := C32.X'LENGTH; + C31.Y := C32'CONSTRAINED; + FOR J IN C32.X'RANGE LOOP + NULL; + END LOOP; + FOR J IN C32.X'FIRST..C32.X'LAST LOOP + NULL; + END LOOP; + I := C33'LENGTH; + FOR J IN C33'RANGE LOOP + NULL; + END LOOP; + FOR J IN C33'FIRST..C33'LAST LOOP + NULL; + END LOOP; + I := C34'LENGTH; + FOR J IN C34'RANGE LOOP + NULL; + END LOOP; + FOR J IN C34'FIRST..C34'LAST LOOP + NULL; + END LOOP; + I := C35'LENGTH; + FOR J IN C35'RANGE LOOP + NULL; + END LOOP; + FOR J IN C35'FIRST..C35'LAST LOOP + NULL; + END LOOP; + + Q(C31.Y'ADDRESS); + I := C31.Y'SIZE; + Q(C32.Y'ADDRESS); + I := C32.Y'SIZE; + Q(C36'ADDRESS); + I := C36'SIZE; + Q(C37'ADDRESS); + I := C37'SIZE; + Q(C38'ADDRESS); + I := C38'SIZE; + + END PROC; + + BEGIN + + NULL; + + END; + + RESULT; + + END A85007D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a85013b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a85013b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a85013b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a85013b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- A85013B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT: + + -- A) A SUBPROGRAM OR ENTRY CAN BE RENAMED WITHIN ITS OWN BODY. + + -- B) THE NEW NAME OF A SUBPROGRAM CAN BE USED IN A RENAMING + -- DECLARATION. + + -- EG 02/22/84 + + WITH REPORT; + + PROCEDURE A85013B IS + + USE REPORT; + + BEGIN + + TEST("A85013B","CHECK THAT A SUBPROGRAM CAN BE RENAMED WITHIN " & + "ITS OWN BODY AND THAT THE NEW NAME CAN BE USED" & + " IN A RENAMING DECLARATION"); + + DECLARE + + PROCEDURE PROC1 (A : BOOLEAN) IS + PROCEDURE PROC2 (B : BOOLEAN := FALSE) RENAMES PROC1; + PROCEDURE PROC3 (C : BOOLEAN := FALSE) RENAMES PROC2; + BEGIN + IF A THEN + PROC3; + END IF; + END PROC1; + + BEGIN + + PROC1 (TRUE); + + END; + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + PROCEDURE E1 RENAMES E; + PROCEDURE E2 RENAMES E1; + BEGIN + ACCEPT E DO + DECLARE + PROCEDURE E3 RENAMES E; + PROCEDURE E4 RENAMES E3; + BEGIN + NULL; + END; + END E; + END T; + + BEGIN + T.E; + END; + + RESULT; + + END A85013B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a87b59a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a87b59a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a87b59a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a87b59a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- A87B59A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BECAUSE A GENERIC ACTUAL PROGRAM PARAMETER MUST BE A + -- SUBPROGRAM, AN ENUMERATION LITERAL, OR AN ENTRY WITH THE SAME + -- PARAMETER AND RESULT TYPE PROFILE AS THE FORMAL PARAMETER, AN + -- OVERLOADED NAME APPEARING AS AN ACTUAL PARAMETER CAN BE RESOLVED. + + -- R.WILLIAMS 9/24/86 + + WITH REPORT; USE REPORT; + PROCEDURE A87B59A IS + + BEGIN + TEST ( "A87B59A", "CHECK THAT BECAUSE A GENERIC ACTUAL PROGRAM " & + "PARAMETER MUST BE A SUBPROGRAM, AN " & + "ENUMERATION LITERAL, OR AN ENTRY WITH THE " & + "SAME PARAMETER AND RESULT TYPE PROFILE AS " & + "THE FORMAL PARAMETER, AN OVERLOADED NAME " & + "APPEARING AS AN ACTUAL PARAMETER CAN BE " & + "RESOLVED" ); + + DECLARE -- A. + FUNCTION F1 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F1; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END F1; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F RETURN T; + PROCEDURE P; + + PROCEDURE P IS + BEGIN + NULL; + END P; + + PROCEDURE P1 IS NEW P (INTEGER, F1); + PROCEDURE P2 IS NEW P (BOOLEAN, F1); + + BEGIN + P1; + P2; + END; -- A. + + DECLARE -- B. + FUNCTION F1 (X : INTEGER; B : BOOLEAN) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (X); + END F1; + + FUNCTION F1 (X : INTEGER; B : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (B); + END F1; + + FUNCTION F1 (B : BOOLEAN; X : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (B); + END F1; + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + WITH FUNCTION F (A : T1; B : T2) RETURN T1; + PROCEDURE P1; + + PROCEDURE P1 IS + BEGIN + NULL; + END P1; + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + WITH FUNCTION F (A : T1; B : T2) RETURN T2; + PROCEDURE P2; + + PROCEDURE P2 IS + BEGIN + NULL; + END P2; + + PROCEDURE PROC1 IS NEW P1 (INTEGER, BOOLEAN, F1); + PROCEDURE PROC2 IS NEW P1 (BOOLEAN, INTEGER, F1); + PROCEDURE PROC3 IS NEW P2 (INTEGER, BOOLEAN, F1); + + BEGIN + PROC1; + PROC2; + END; -- B. + + DECLARE -- C. + TYPE COLOR IS (RED, YELLOW, BLUE); + C : COLOR; + + TYPE LIGHT IS (RED, YELLOW, GREEN); + L : LIGHT; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F RETURN T; + FUNCTION GF RETURN T; + + FUNCTION GF RETURN T IS + BEGIN + RETURN T'VAL (IDENT_INT (T'POS (F))); + END GF; + + FUNCTION F1 IS NEW GF (COLOR, RED); + FUNCTION F2 IS NEW GF (LIGHT, YELLOW); + BEGIN + C := F1; + L := F2; + END; -- C. + + DECLARE -- D. + TASK TK IS + ENTRY E (X : INTEGER); + ENTRY E (X : BOOLEAN); + ENTRY E (X : INTEGER; Y : BOOLEAN); + ENTRY E (X : BOOLEAN; Y : INTEGER); + END TK; + + TASK BODY TK IS + BEGIN + LOOP + SELECT + ACCEPT E (X : INTEGER); + OR + ACCEPT E (X : BOOLEAN); + OR + ACCEPT E (X : INTEGER; Y : BOOLEAN); + OR + ACCEPT E (X : BOOLEAN; Y : INTEGER); + OR + TERMINATE; + END SELECT; + END LOOP; + END TK; + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + WITH PROCEDURE P1 (X : T1); + WITH PROCEDURE P2 (X : T1; Y : T2); + PACKAGE PKG IS + PROCEDURE P; + END PKG; + + PACKAGE BODY PKG IS + PROCEDURE P IS + BEGIN + IF EQUAL (3, 3) THEN + P1 (T1'VAL (1)); + P2 (T1'VAL (0), T2'VAL (1)); + END IF; + END P; + END PKG; + + PACKAGE PK1 IS NEW PKG (INTEGER, BOOLEAN, TK.E, TK.E); + PACKAGE PK2 IS NEW PKG (BOOLEAN, INTEGER, TK.E, TK.E); + + BEGIN + PK1.P; + PK2.P; + END; -- D. + + DECLARE -- E. + FUNCTION "+" (X, Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (X OR Y); + END "+"; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION "+" (X, Y : T) RETURN T; + PROCEDURE P; + + PROCEDURE P IS + S : T; + BEGIN + S := "+" (T'VAL (0), T'VAL (1)); + END P; + + PROCEDURE P1 IS NEW P (BOOLEAN, "+"); + PROCEDURE P2 IS NEW P (INTEGER, "+"); + + BEGIN + P1; + P2; + END; -- E. + + DECLARE -- F. + TYPE ADD_OPS IS ('+', '-', '&'); + + GENERIC + TYPE T1 IS (<>); + TYPE T2 IS (<>); + TYPE T3 IS ARRAY (POSITIVE RANGE <> ) OF T2; + X2 : T2; + X3 : T3; + WITH FUNCTION F1 RETURN T1; + WITH FUNCTION F2 (X : T2; Y : T3) RETURN T3; + PROCEDURE P; + + PROCEDURE P IS + A : T1; + S : T3 (IDENT_INT (1) .. IDENT_INT (2)); + BEGIN + A := F1; + S := F2 (X2, X3); + END P; + + PROCEDURE P1 IS NEW P (ADD_OPS, CHARACTER, STRING, + '&', "&", '&', "&"); + + BEGIN + P1; + END; -- F. + + RESULT; + END A87B59A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a95001c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a95001c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a95001c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a95001c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- A95001C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE BOUNDS OF THE DISCRETE RANGE OF AN ENTRY FAMILY + -- ARE INTEGER LITERALS, NAMED NUMBERS, OR ATTRIBUTES HAVING TYPE + -- UNIVERSAL_INTEGER, BUT NOT EXPRESSIONS OF TYPE UNIVERSAL_INTEGER, + -- THE INDEX (IN AN ENTRY NAME OR ACCEPT STATEMENT) IS OF THE + -- PREDEFINED TYPE INTEGER. + + -- WEI 3/4/82 + -- RJK 2/1/84 ADDED TO ACVC + -- TBN 1/7/86 RENAMED FROM B950DHA-B.ADA. ADDED NAMED CONSTANTS + -- AND ATTRIBUTES AS KINDS OF BOUNDS, AND MADE TEST + -- EXECUTABLE. + -- RJW 4/11/86 RENAMED FROM C95001C-B.ADA. + + WITH REPORT; USE REPORT; + + PROCEDURE A95001C IS + + SUBTYPE T IS INTEGER RANGE 1 .. 10; + I : INTEGER := 1; + NAMED_INT1 : CONSTANT := 1; + NAMED_INT2 : CONSTANT := 2; + + TASK T1 IS + ENTRY E1 (1 .. 2); + ENTRY E2 (NAMED_INT1 .. NAMED_INT2); + ENTRY E3 (T'POS(1) .. T'POS(2)); + END T1; + + TASK BODY T1 IS + I_INT : INTEGER := 1; + I_POS : INTEGER := 2; + BEGIN + ACCEPT E1 (I_INT); + ACCEPT E2 (I_POS); + ACCEPT E3 (T'SUCC(1)); + END T1; + + BEGIN + TEST ("A95001C", "CHECK THAT IF THE BOUNDS OF THE DISCRETE " & + "RANGE OF AN ENTRY FAMILY ARE INTEGER " & + "LITERALS, NAMED NUMBERS, OR " & + "(UNIVERSAL_INTEGER) ATTRIBUTES, THE INDEX " & + "IS OF THE PREDEFINED TYPE INTEGER"); + + T1.E1 (I); + T1.E2 (NAMED_INT2); + T1.E3 (T'SUCC(I)); + + RESULT; + END A95001C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a95074d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a95074d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a95074d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a95074d.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- A95074D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'ADDRESS, 'CONSTRAINED, 'SIZE, 'POSITION, 'FIRST_BIT, + -- AND 'LAST_BIT CAN BE APPLIED TO AN OUT PARAMETER OR OUT PARAMETER + -- SUBCOMPONENT THAT DOES NOT HAVE AN ACCESS TYPE. + + -- JWC 6/25/85 + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE A95074D IS + BEGIN + + TEST ("A95074D", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " & + "NON-ACCESS FORMAL OUT PARAMETERS"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 2) OF BOOLEAN; + + TYPE REC (D : INTEGER := 1) IS RECORD + Y : BOOLEAN; + X : ARR; + END RECORD; + + TASK T IS + ENTRY E (C1 : OUT ARR; C2 : OUT REC); + END T; + + TASK BODY T IS + X : SYSTEM.ADDRESS; + I : INTEGER; + BEGIN + IF IDENT_BOOL (FALSE) THEN + ACCEPT E (C1 : OUT ARR; C2 : OUT REC) DO + + C2.Y := C2'CONSTRAINED; + + X := C1'ADDRESS; + X := C1(1)'ADDRESS; + X := C2'ADDRESS; + X := C2.Y'ADDRESS; + + I := C1'SIZE; + I := C2.Y'SIZE; + + I := C2.X'POSITION; + I := C2.Y'FIRST_BIT; + I := C2.Y'LAST_BIT; + END E; + END IF; + END T; + + BEGIN + NULL; + END; + + RESULT; + + END A95074D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a97106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a97106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a97106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a97106a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- A97106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SELECTIVE_WAIT MAY HAVE MORE THAN ONE 'DELAY' ALTER- + -- NATIVE. + + + -- RM 4/27/1982 + + + WITH REPORT; + USE REPORT; + PROCEDURE A97106A IS + + + BEGIN + + + TEST ( "A97106A" , "CHECK THAT A SELECTIVE_WAIT MAY HAVE" & + " MORE THAN ONE 'DELAY' ALTERNATIVE" ); + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TYPE TT IS + ENTRY A ; + END TT ; + + + TASK BODY TT IS + DUMMY : BOOLEAN := FALSE ; + BEGIN + + SELECT + ACCEPT A ; + OR + DELAY 2.5 ; + OR + ACCEPT A ; + OR + ACCEPT A ; + OR + DELAY 2.5 ; -- MULTIPLE 'DELAY'S PERMITTED (IF + OR -- AND ONLY IF SINGLE 'DELAY'S + DELAY 2.5 ; -- ARE PERMITTED). + OR + ACCEPT A ; + END SELECT ; + + END TT ; + + BEGIN + NULL ; + END ; + + ------------------------------------------------------------------- + + + RESULT; + + + END A97106A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a99006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a99006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/a99006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/a99006a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- A99006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'COUNT RETURNS A UNIVERSAL INTEGER VALUE. + + -- HISTORY: + -- DHH 03/28/88 CREATED ORIGINAL TEST. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE A99006A IS + + TASK CHOICE IS + ENTRY START; + ENTRY E1; + ENTRY STOP; + END CHOICE; + + TASK BODY CHOICE IS + X : INTEGER; + BEGIN + ACCEPT START; + ACCEPT E1 DO + DECLARE + TYPE Y IS NEW INTEGER RANGE -5 .. 5; + T : Y := E1'COUNT; + BEGIN + X := E1'COUNT; + END; + END E1; + ACCEPT STOP; + END CHOICE; + + BEGIN + + TEST("A99006A", "CHECK THAT 'COUNT RETURNS A UNIVERSAL INTEGER " & + "VALUE"); + + CHOICE.START; + CHOICE.E1; + CHOICE.STOP; + + RESULT; + END A99006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/aa2010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/aa2010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/aa2010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/aa2010a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,199 ---- + -- AA2010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SUBUNIT NAMES CAN BE IDENTICAL TO IDENTIFIERS DECLARED IN + -- STANDARD, NAMELY, BOOLEAN, INTEGER, FLOAT, CHARACTER, ASCII, + -- NATURAL, POSITIVE, STRING, DURATION, CONSTRAINT_ERROR, + -- NUMERIC_ERROR, PROGRAM_ERROR, STORAGE_ERROR, AND TASKING_ERROR. + + -- R.WILLIAMS 9/18/86 + + PACKAGE AA2010A_TYPEDEF IS + TYPE ENUM IS (E1, E2, E3); + END AA2010A_TYPEDEF; + + WITH AA2010A_TYPEDEF; USE AA2010A_TYPEDEF; + PACKAGE AA2010A_PARENT IS + + PROCEDURE BOOLEAN; + FUNCTION INTEGER RETURN ENUM; + PACKAGE FLOAT IS END FLOAT; + + PROCEDURE CHARACTER; + FUNCTION ASCII RETURN ENUM; + + TASK NATURAL IS + ENTRY E; + END NATURAL; + + PROCEDURE POSITIVE; + FUNCTION STRING RETURN ENUM; + PACKAGE DURATION IS END DURATION; + + PROCEDURE CONSTRAINT_ERROR; + FUNCTION NUMERIC_ERROR RETURN ENUM; + + TASK PROGRAM_ERROR IS + ENTRY E; + END PROGRAM_ERROR; + + PROCEDURE STORAGE_ERROR; + FUNCTION TASKING_ERROR RETURN ENUM; + + END AA2010A_PARENT; + + PACKAGE BODY AA2010A_PARENT IS + + PROCEDURE BOOLEAN IS SEPARATE; + FUNCTION INTEGER RETURN ENUM IS SEPARATE; + PACKAGE BODY FLOAT IS SEPARATE; + + PROCEDURE CHARACTER IS SEPARATE; + FUNCTION ASCII RETURN ENUM IS SEPARATE; + TASK BODY NATURAL IS SEPARATE; + + PROCEDURE POSITIVE IS SEPARATE; + FUNCTION STRING RETURN ENUM IS SEPARATE; + PACKAGE BODY DURATION IS SEPARATE; + + PROCEDURE CONSTRAINT_ERROR IS SEPARATE; + FUNCTION NUMERIC_ERROR RETURN ENUM IS SEPARATE; + TASK BODY PROGRAM_ERROR IS SEPARATE; + + PROCEDURE STORAGE_ERROR IS SEPARATE; + FUNCTION TASKING_ERROR RETURN ENUM IS SEPARATE; + + END AA2010A_PARENT; + + SEPARATE (AA2010A_PARENT) + PROCEDURE BOOLEAN IS + BEGIN + NULL; + END; + + SEPARATE (AA2010A_PARENT) + FUNCTION INTEGER RETURN ENUM IS + BEGIN + RETURN E1; + END; + + SEPARATE (AA2010A_PARENT) + PACKAGE BODY FLOAT IS END; + + SEPARATE (AA2010A_PARENT) + PROCEDURE CHARACTER IS + BEGIN + NULL; + END; + + SEPARATE (AA2010A_PARENT) + FUNCTION ASCII RETURN ENUM IS + BEGIN + RETURN E1; + END; + + SEPARATE (AA2010A_PARENT) + TASK BODY NATURAL IS + BEGIN + ACCEPT E; + END; + + SEPARATE (AA2010A_PARENT) + PROCEDURE POSITIVE IS + BEGIN + NULL; + END; + + SEPARATE (AA2010A_PARENT) + FUNCTION STRING RETURN ENUM IS + BEGIN + RETURN E1; + END; + + SEPARATE (AA2010A_PARENT) + PACKAGE BODY DURATION IS END; + + SEPARATE (AA2010A_PARENT) + PROCEDURE CONSTRAINT_ERROR IS + BEGIN + NULL; + END; + + SEPARATE (AA2010A_PARENT) + FUNCTION NUMERIC_ERROR RETURN ENUM IS + BEGIN + RETURN E1; + END; + + SEPARATE (AA2010A_PARENT) + TASK BODY PROGRAM_ERROR IS + BEGIN + ACCEPT E; + END; + + SEPARATE (AA2010A_PARENT) + PROCEDURE STORAGE_ERROR IS + BEGIN + NULL; + END; + + SEPARATE (AA2010A_PARENT) + FUNCTION TASKING_ERROR RETURN ENUM IS + BEGIN + RETURN E1; + END; + + WITH REPORT; USE REPORT; + WITH AA2010A_TYPEDEF; USE AA2010A_TYPEDEF; + WITH AA2010A_PARENT; USE AA2010A_PARENT; + PROCEDURE AA2010A IS + E : ENUM; + BEGIN + TEST ( "AA2010A", "CHECK THAT SUBUNIT NAMES CAN BE IDENTICAL " & + "TO IDENTIFIERS DECLARED IN STANDARD, " & + "NAMELY, BOOLEAN, INTEGER, FLOAT, " & + "CHARACTER, ASCII, NATURAL, POSITIVE, " & + "STRING, DURATION, CONSTRAINT_ERROR, " & + "NUMERIC_ERROR, PROGRAM_ERROR, " & + "STORAGE_ERROR, AND TASKING_ERROR" ); + + AA2010A_PARENT.BOOLEAN; + E := AA2010A_PARENT.INTEGER; + + AA2010A_PARENT.CHARACTER; + E := AA2010A_PARENT.ASCII; + AA2010A_PARENT.NATURAL.E; + + AA2010A_PARENT.POSITIVE; + E := AA2010A_PARENT.STRING; + + AA2010A_PARENT.CONSTRAINT_ERROR; + E := AA2010A_PARENT.NUMERIC_ERROR; + AA2010A_PARENT.PROGRAM_ERROR.E; + + AA2010A_PARENT.STORAGE_ERROR; + E := AA2010A_PARENT.TASKING_ERROR; + + RESULT; + END AA2010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/aa2012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/aa2012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/aa2012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/aa2012a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- AA2012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A BODY STUB CAN SERVE AS AN IMPLICIT DECLARATION OF A + -- SUBPROGRAM, I.E., A PRECEDING SUBPROGRAM DECLARATION IS NOT + -- REQUIRED. + + -- R.WILLIAMS 9/18/86 + + PROCEDURE AA2012A1 IS + + I : INTEGER; + + PROCEDURE AA2012A2 IS SEPARATE; + + FUNCTION AA2012A3 RETURN INTEGER IS SEPARATE; + + BEGIN + AA2012A2; + I := AA2012A3; + + END AA2012A1; + + SEPARATE (AA2012A1) + PROCEDURE AA2012A2 IS + BEGIN + NULL; + END; + + SEPARATE (AA2012A1) + FUNCTION AA2012A3 RETURN INTEGER IS + BEGIN + RETURN 5; + END; + + WITH AA2012A1; + WITH REPORT; USE REPORT; + PROCEDURE AA2012A IS + + BEGIN + TEST ( "AA2012A", "CHECK THAT A BODY STUB CAN SERVE AS AN " & + "IMPLICIT DECLARATION OF A SUBPROGRAM, " & + "I.E., A PRECEDING SUBPROGRAM DECLARATION " & + "IS NOT REQUIRED" ); + + AA2012A1; + + RESULT; + END AA2012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac1015b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac1015b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac1015b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac1015b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- AC1015B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WITHIN A GENERIC SUBPROGRAM THE NAME OF THE GENERIC + -- SUBPROGRAM CAN BE USED AS AN ACTUAL PARAMETER IN AN + -- INSTANTIATION. + + -- HISTORY: + -- BCB 03/28/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE AC1015B IS + + GENERIC + PROCEDURE P; + + PROCEDURE P IS + GENERIC + WITH PROCEDURE F; + PROCEDURE T; + + PROCEDURE T IS + BEGIN + NULL; + END T; + + PROCEDURE S IS NEW T(F => P); + + BEGIN + NULL; + END P; + + GENERIC + FUNCTION D RETURN BOOLEAN; + + FUNCTION D RETURN BOOLEAN IS + GENERIC + WITH FUNCTION L RETURN BOOLEAN; + FUNCTION A RETURN BOOLEAN; + + FUNCTION A RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END A; + + FUNCTION B IS NEW A(L => D); + + BEGIN + RETURN TRUE; + END D; + + BEGIN + TEST ("AC1015B", "CHECK THAT WITHIN A GENERIC SUBPROGRAM THE " & + "NAME OF THE GENERIC SUBPROGRAM CAN BE USED AS " & + "AN ACTUAL PARAMETER IN AN INSTANTIATION"); + + RESULT; + END AC1015B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3106a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- AC3106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ACTUAL GENERIC IN OUT PARAMETER CAN BE: + -- A) ANY SUBCOMPONENT THAT DOES NOT DEPEND ON A DISCRIMINANT, + -- EVEN IF THE ENCLOSING VARIABLE IS UNCONSTRAINED; + -- B) ANY SUBCOMPONENT OF AN UNCONSTAINED VARIABLE OF A + -- RECORD TYPE IF THE DISCRIMINANTS OF THE + -- VARIABLE DO NOT HAVE DEFAULTS AND THE VARIABLE IS NOT + -- A GENERIC FORMAL IN OUT PARAMETER; + -- C) ANY COMPONENT OF AN OBJECT DESIGNATED BY AN ACCESS + -- VALUE. + + -- HISTORY: + -- RJW 11/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE AC3106A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + + TYPE REC (D : INT := 0) IS RECORD + A : INTEGER := 5; + CASE D IS + WHEN OTHERS => + V : INTEGER := 5; + END CASE; + END RECORD; + + TYPE AR_REC IS ARRAY (1 .. 10) OF REC; + + TYPE R_REC IS RECORD + E : REC; + END RECORD; + + TYPE A_STRING IS ACCESS STRING; + TYPE A_REC IS ACCESS REC; + TYPE A_AR_REC IS ACCESS AR_REC; + TYPE A_R_REC IS ACCESS R_REC; + + TYPE DIS (L : INT := 1) IS RECORD + S : STRING (1 .. L) := "A"; + R : REC (L); + AS : A_STRING (1 .. L) := NEW STRING (1 .. L); + AR : A_REC (L) := NEW REC (1); + RC : REC (3); + ARU : A_REC := NEW REC; + V_AR : AR_REC; + V_R : R_REC; + AC_AR : A_AR_REC := NEW AR_REC; + AC_R : A_R_REC := NEW R_REC; + END RECORD; + + TYPE A_DIS IS ACCESS DIS; + AD : A_DIS := NEW DIS; + + TYPE DIS2 (L : INT) IS RECORD + S : STRING (1 .. L); + R : REC (L); + AS : A_STRING (1 .. L); + AR : A_REC (L); + END RECORD; + + X : DIS; + + SUBTYPE REC3 IS REC (3); + + GENERIC + GREC3 : IN OUT REC3; + PACKAGE PREC3 IS END PREC3; + + SUBTYPE REC0 IS REC (0); + + GENERIC + GREC0 : IN OUT REC0; + PACKAGE PREC0 IS END PREC0; + + GENERIC + GINT : IN OUT INTEGER; + PACKAGE PINT IS END PINT; + + GENERIC + GA_REC : IN OUT A_REC; + PACKAGE PA_REC IS END PA_REC; + + GENERIC + GAR_REC : IN OUT AR_REC; + PACKAGE PAR_REC IS END PAR_REC; + + GENERIC + GR_REC : IN OUT R_REC; + PACKAGE PR_REC IS END PR_REC; + + GENERIC + GA_AR_REC : IN OUT A_AR_REC; + PACKAGE PA_AR_REC IS END PA_AR_REC; + + GENERIC + GA_R_REC : IN OUT A_R_REC; + PACKAGE PA_R_REC IS END PA_R_REC; + + TYPE BUFFER (SIZE : INT) IS RECORD + POS : NATURAL := 0; + VAL : STRING (1 .. SIZE); + END RECORD; + + SUBTYPE BUFF_5 IS BUFFER (5); + + GENERIC + Y : IN OUT CHARACTER; + PACKAGE P_CHAR IS END P_CHAR; + + SUBTYPE STRING5 IS STRING (1 .. 5); + GENERIC + GSTRING : STRING5; + PACKAGE P_STRING IS END P_STRING; + + GENERIC + GA_STRING : A_STRING; + PACKAGE P_A_STRING IS END P_A_STRING; + + GENERIC + X : IN OUT BUFF_5; + PACKAGE P_BUFF IS + RX : BUFF_5 RENAMES X; + END P_BUFF; + + Z : BUFFER (1) := (SIZE => 1, POS =>82, VAL =>"R"); + BEGIN + TEST ("AC3106A", "CHECK THE PERMITTED FORMS OF AN ACTUAL " & + "GENERIC IN OUT PARAMETER"); + + DECLARE -- A) + PACKAGE NPINT3 IS NEW PINT (X.RC.A); + PACKAGE NPINT4 IS NEW PINT (X.RC.V); + PACKAGE NPREC3 IS NEW PREC3 (X.RC); + PACKAGE NPA_REC IS NEW PA_REC (X.ARU); + PACKAGE NPINT5 IS NEW PINT (X.ARU.A); + PACKAGE NPINT6 IS NEW PINT (X.ARU.V); + PACKAGE NPAR_REC IS NEW PAR_REC (X.V_AR); + PACKAGE NPREC01 IS NEW PREC0 (X.V_AR (1)); + PACKAGE NPR_REC IS NEW PR_REC (X.V_R); + PACKAGE NPREC02 IS NEW PREC0 (X.V_R.E); + PACKAGE NPINT7 IS NEW PINT (X.V_R.E.A); + + PACKAGE NP_BUFF IS NEW P_BUFF (Z); + USE NP_BUFF; + + PACKAGE NP_CHAR3 IS NEW P_CHAR (RX.VAL (1)); + + PROCEDURE PROC (X : IN OUT BUFFER) IS + PACKAGE NP_CHAR4 IS NEW P_CHAR (X.VAL (1)); + BEGIN + NULL; + END; + BEGIN + NULL; + END; -- A) + + DECLARE -- B) + PROCEDURE PROC (Y : IN OUT DIS2) IS + PACKAGE NP_STRING IS NEW P_STRING (Y.S); + PACKAGE NP_CHAR IS NEW P_CHAR (Y.S (1)); + PACKAGE NP_A_STRING IS NEW P_A_STRING (Y.AS); + PACKAGE NP_CHAR2 IS NEW P_CHAR (Y.AS (1)); + PACKAGE NPINT3 IS NEW PINT (Y.R.A); + PACKAGE NPINT4 IS NEW PINT (Y.R.V); + PACKAGE NPREC3 IS NEW PREC3 (Y.R); + PACKAGE NPA_REC IS NEW PA_REC (Y.AR); + PACKAGE NPINT5 IS NEW PINT (Y.AR.A); + PACKAGE NPINT6 IS NEW PINT (Y.AR.V); + BEGIN + NULL; + END; + BEGIN + NULL; + END; -- B) + + DECLARE -- C) + PACKAGE NP_CHAR IS NEW P_CHAR (AD.S (1)); + PACKAGE NP_A_STRING IS NEW P_A_STRING (AD.AS); + PACKAGE NP_CHAR2 IS NEW P_CHAR (AD.AS (1)); + PACKAGE NPINT3 IS NEW PINT (AD.R.A); + PACKAGE NPINT4 IS NEW PINT (AD.R.V); + PACKAGE NPREC3 IS NEW PREC3 (AD.R); + PACKAGE NPA_REC IS NEW PA_REC (AD.AR); + PACKAGE NPINT5 IS NEW PINT (AD.AR.A); + PACKAGE NPINT6 IS NEW PINT (AD.AR.V); + BEGIN + NULL; + END; -- C) + + RESULT; + END AC3106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3206a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- AC3206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INSTANTIATION IS LEGAL IF A FORMAL PRIVATE TYPE IS + -- USED IN A CONSTANT DECLARATION AND THE ACTUAL PARAMETER IS A + -- TYPE WITH DISCRIMINANTS THAT DO AND DO NOT HAVE DEFAULTS. (CHECK + -- CASES THAT USED TO BE FORBIDDEN). + + -- HISTORY: + -- DHH 09/16/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE AC3206A IS + + BEGIN + TEST ("AC3206A", "CHECK THAT AN INSTANTIATION IS LEGAL IF A " & + "FORMAL PRIVATE TYPE IS USED IN A CONSTANT " & + "DECLARATION AND THE ACTUAL PARAMETER IS A " & + "TYPE WITH DISCRIMINANTS THAT DO AND DO NOT " & + "HAVE DEFAULTS"); + + DECLARE -- CHECK DEFAULTS LEGAL UNDER AI-37. + + GENERIC + TYPE GEN IS PRIVATE; + INIT : GEN; + PACKAGE GEN_PACK IS + CONST : CONSTANT GEN := INIT; + SUBTYPE NEW_GEN IS GEN; + END GEN_PACK; + + TYPE REC(A : INTEGER := 4) IS + RECORD + X : INTEGER; + Y : BOOLEAN; + END RECORD; + + PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE)); + USE P; + + CON : CONSTANT P.NEW_GEN := (4, 5, FALSE); + + BEGIN + NULL; + END; + + DECLARE + + GENERIC + TYPE GEN(DIS : INTEGER) IS PRIVATE; + INIT : GEN; + PACKAGE GEN_PACK IS + CONST : CONSTANT GEN := INIT; + SUBTYPE NEW_GEN IS GEN(4); + END GEN_PACK; + + TYPE REC(A : INTEGER := 4) IS + RECORD + X : INTEGER; + Y : BOOLEAN; + END RECORD; + + PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE)); + USE P; + + CON : CONSTANT P.NEW_GEN := (4, 5, FALSE); + + BEGIN + NULL; + END; + + DECLARE + + GENERIC + TYPE GEN(DIS : INTEGER) IS PRIVATE; + INIT : GEN; + PACKAGE GEN_PACK IS + CONST : CONSTANT GEN := INIT; + SUBTYPE NEW_GEN IS GEN(4); + END GEN_PACK; + + TYPE REC(A : INTEGER) IS + RECORD + X : INTEGER; + Y : BOOLEAN; + END RECORD; + + PACKAGE P IS NEW GEN_PACK(REC, (4, 5, FALSE)); + USE P; + + CON : CONSTANT P.NEW_GEN := (4, 5, FALSE); + + BEGIN + NULL; + END; + + RESULT; + END AC3206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3207a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3207a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ac3207a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ac3207a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- AC3207A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INSTANTIATION IS LEGAL IF A FORMAL PARAMETER + -- HAVING A LIMITED PRIVATE TYPE WITHOUT DISCRIMINANTS IS USED TO + -- DECLARE AN OBJECT IN A BLOCK THAT CONTAINS A SELECTIVE WAIT + -- WITH A TERMINATE ALTERNATIVE, AND THE ACTUAL PARAMETER'S BASE + -- TYPE IS A TASK TYPE OR A TYPE WITH A SUBCOMPONENT OF A TASK TYPE. + + -- HISTORY: + -- DHH 09/16/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE AC3207A IS + + GENERIC + TYPE PRIV IS LIMITED PRIVATE; + PACKAGE GEN_P IS + TASK T1 IS + ENTRY E; + END T1; + END GEN_P; + + TASK TYPE TASK_T IS + END TASK_T; + + TYPE REC IS + RECORD + OBJ : TASK_T; + END RECORD; + + PACKAGE BODY GEN_P IS + TASK BODY T1 IS + BEGIN + DECLARE + OBJ : PRIV; + BEGIN + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END; + END T1; + END GEN_P; + + TASK BODY TASK_T IS + BEGIN + NULL; + END; + + PACKAGE P IS NEW GEN_P(TASK_T); + PACKAGE NEW_P IS NEW GEN_P(REC); + + BEGIN + TEST ("AC3207A", "CHECK THAT AN INSTANTIATION IS LEGAL IF A " & + "FORMAL PARAMETER HAVING A LIMITED PRIVATE " & + "TYPE WITHOUT DISCRIMINANTS IS USED TO " & + "DECLARE AN OBJECT IN A BLOCK THAT CONTAINS " & + "A SELECTIVE WAIT WITH A TERMINATE " & + "ALTERNATIVE, AND THE ACTUAL PARAMETER'S BASE " & + "TYPE IS A TASK TYPE OR A TYPE WITH A " & + "SUBCOMPONENT OF A TASK TYPE"); + + P.T1.E; + + NEW_P.T1.E; + + RESULT; + END AC3207A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- AD7001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE + -- IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR THE UNIT + -- CONTAINING THE REFERENCES. + + -- HISTORY: + -- JET 09/08/87 CREATED ORIGINAL TEST. + -- VCL 03/30/88 CREATED NAMED NUMBERS WITH VALUES OF + -- SYSTEM.MIN_INT AND SYSTEM.MAX_INT. DELETED + -- ASSIGNMENTS OF MIN_INT AND MAX_INT TO INTEGER + -- VARIABLES. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7001B IS + + CHECK_ADDRESS : SYSTEM.ADDRESS; + CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME; + CHECK_PRIORITY : SYSTEM.PRIORITY; + I : INTEGER; + F : FLOAT; + SMALL : CONSTANT := SYSTEM.MIN_INT; + LARGE : CONSTANT := SYSTEM.MAX_INT; + MEM : CONSTANT := SYSTEM.MEMORY_SIZE; + + BEGIN + + TEST ("AD7001B", "CHECK THAT A DECLARATION IN PACKAGE " & + "SYSTEM IS ACCESSIBLE IF A WITH CLAUSE " & + "NAMING SYSTEM IS PROVIDED FOR THE UNIT " & + "CONTAINING THE REFERENCES"); + + I := SYSTEM.STORAGE_UNIT; + I := SYSTEM.MAX_DIGITS; + I := SYSTEM.MAX_MANTISSA; + F := SYSTEM.FINE_DELTA; + F := SYSTEM.TICK; + + RESULT; + + END AD7001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001c0.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- AD7001C0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE + -- IN A LIBRARY PACKAGE BODY IF A WITH CLAUSE NAMING SYSTEM + -- IS PROVIDED FOR THE PACKAGE SPECIFICATION, ALTHOUGH IN A + -- SEPARATE FILE. + + -- HISTORY: + -- JET 09/09/87 CREATED ORIGINAL TEST. + -- RJW 05/03/88 REVISED AND ENTERED TEST INTO ACVC. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + -- THIS FILE CONTAINS PACKAGE SPEC AD7001C_PACKAGE AND THE MAIN + -- PROCEDURE FOR TEST AD7001C. FILE AD7001C1.ADA CONTAINS + -- THE PACKAGE BODY FOR THE PACKAGE SPEC AND IS ALSO REQUIRED + -- FOR TEST EXECUTION. + + WITH SYSTEM; + + PACKAGE AD7001C_PACKAGE IS + + I : INTEGER; + F : FLOAT; + + PROCEDURE REQUIRE_BODY; + + END AD7001C_PACKAGE; + + + WITH AD7001C_PACKAGE; USE AD7001C_PACKAGE; + WITH REPORT; USE REPORT; + + PROCEDURE AD7001C0M IS + + BEGIN + TEST ("AD7001C", "CHECK THAT A DECLARATION IN PACKAGE SYSTEM " & + "IS ACCESSIBLE IN A LIBRARY PACKAGE BODY IF " & + "A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR " & + "THE PACKAGE SPECIFICATION, ALTHOUGH IN A " & + "SEPARATE FILE"); + RESULT; + END AD7001C0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001c1.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- AD7001C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE + -- IN A LIBRARY PACKAGE BODY IF A WITH CLAUSE NAMING SYSTEM + -- IS PROVIDED FOR THE PACKAGE SPECIFICATION, ALTHOUGH IN ANOTHER + -- FILE. + + -- HISTORY: + -- JET 09/09/87 CREATED ORIGINAL TEST. + -- RJW 05/03/88 REVISED AND ENTERED IN ACVC. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + -- THIS FILE CONTAINS THE PACKAGE BODY FOR PACKAGE AD7001C_PACKAGE. + -- FILE AD7001C0M.ADA CONTAINS THE PACKAGE SPEC AND MAIN PROCEDURE + -- FOR TEST AD7001C AND IS ALSO REQUIRED FOR TEST EXECUTION. + + PACKAGE BODY AD7001C_PACKAGE IS + + CHECK_ADDRESS : SYSTEM.ADDRESS; + CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME; + CHECK_PRIORITY : SYSTEM.PRIORITY; + MEM_SIZE : CONSTANT := SYSTEM.MEMORY_SIZE; + + TYPE INTRANGE IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + BEGIN + I := SYSTEM.STORAGE_UNIT; + I := SYSTEM.MAX_DIGITS; + I := SYSTEM.MAX_MANTISSA; + F := SYSTEM.FINE_DELTA; + F := SYSTEM.TICK; + END AD7001C_PACKAGE; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001d0.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- AD7001D0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE + -- IN A SUBUNIT IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED + -- FOR THE MAIN UNIT CONTAINING THE SUBUNIT, ALTHOUGH IN A + -- SEPARATE FILE. + + -- HISTORY: + -- JET 09/09/87 CREATED ORIGINAL TEST. + -- RJW 05/03/88 REVISED AND ENTERED TEST INTO ACVC. + + -- THIS FILE CONTAINS THE MAIN PROCEDURE FOR TEST AD7001D. FILE + -- AD7001D1.ADA CONTAINS THE PACKAGE BODY FOR THE SUBUNIT PACKAGE + -- SPEC AND IS ALSO REQUIRED FOR TEST EXECUTION. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7001D0M IS + + PACKAGE AD7001D_PACKAGE IS + + I : INTEGER; + F : FLOAT; + + END AD7001D_PACKAGE; + + PACKAGE BODY AD7001D_PACKAGE IS SEPARATE; + + BEGIN + TEST ("AD7001D", "CHECK THAT A DECLARATION IN PACKAGE SYSTEM " & + "IS ACCESSIBLE IN A SUBUNIT IF A WITH CLAUSE " & + "NAMING SYSTEM IS PROVIDED FOR THE MAIN UNIT " & + "CONTAINING THE SUBUNIT, ALTHOUGH IN A " & + "SEPARATE FILE"); + RESULT; + END AD7001D0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7001d1.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- AD7001D1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN PACKAGE SYSTEM IS ACCESSIBLE IN + -- A SUBUNIT IF A WITH CLAUSE NAMING SYSTEM IS PROVIDED FOR THE + -- MAIN UNIT CONTAINING THE SUBUNIT, ALTHOUGH IN A SEPARATE + -- FILE. + + -- HISTORY: + -- JET 09/09/87 CREATED ORIGINAL TEST. + + -- THIS FILE CONTAINS THE PACKAGE BODY FOR PACKAGE AD7001D_PACKAGE. + -- FILE AD7001D0M.ADA CONTAINS THE PACKAGE SPEC AND MAIN PROCEDURE + -- FOR TEST AD7001D AND IS ALSO REQUIRED FOR TEST EXECUTION. + + SEPARATE (AD7001D0M) + + PACKAGE BODY AD7001D_PACKAGE IS + + CHECK_ADDRESS : SYSTEM.ADDRESS; + CHECK_NAME : SYSTEM.NAME := SYSTEM.SYSTEM_NAME; + CHECK_PRIORITY : SYSTEM.PRIORITY; + MEM_SIZE : CONSTANT := SYSTEM.MEMORY_SIZE; + + TYPE INTRANGE IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT; + + BEGIN + I := SYSTEM.STORAGE_UNIT; + I := SYSTEM.MAX_DIGITS; + I := SYSTEM.MAX_MANTISSA; + F := SYSTEM.FINE_DELTA; + F := SYSTEM.TICK; + END AD7001D_PACKAGE; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7006a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + -- AD7006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT 'SYSTEM.MEMORY_SIZE' IS DECLARED AND + -- THAT IT IS A STATIC UNIVERSAL INTEGER. + + -- HISTORY: + -- VCL 09/14/87 CREATED ORIGINAL TEST. + -- RJW 06/13/89 MODIFIED TEST AND REMOVED INTEGER VARIABLE. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE AD7006A IS + BEGIN + TEST ("AD7006A", "THE CONSTANT 'SYSTEM.MEMORY_SIZE' IS " & + "DECLARED AND IT IS A STATIC UNIVERSAL " & + "INTEGER"); + + DECLARE + MY_MSIZE : CONSTANT := SYSTEM.MEMORY_SIZE - 1; + BEGIN + RESULT; + END; + + END AD7006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7101a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7101a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7101a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7101a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- AD7101A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MIN_INT AND MAX_INT ARE DECLARED IN PACKAGE SYSTEM + -- AND THAT BOTH ARE STATIC AND HAVE TYPE . + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7101A IS + + U_MIN : CONSTANT := SYSTEM.MIN_INT; + U_MAX : CONSTANT := SYSTEM.MAX_INT; + + TYPE S_MIN IS RANGE SYSTEM.MIN_INT .. 7; + TYPE S_MAX IS RANGE 7 .. SYSTEM.MAX_INT; + + BEGIN + + TEST ("AD7101A", "CHECK THAT MIN_INT AND MAX_INT ARE DECLARED " & + "IN PACKAGE SYSTEM AND THAT BOTH ARE STATIC " & + "AND HAVE TYPE "); + + RESULT; + + END AD7101A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7101c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7101c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7101c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7101c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- AD7101C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT TYPE DEFINITIONS WITH RANGES -MAX_INT .. MAX_INT + -- AND MIN_INT .. MAX_INT ARE ACCEPTED. + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + -- VCL 03/30/88 CHANGED INTEGER SUBTYPE DECLARATIONS TO TYPE + -- DEFINITIONS. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7101C IS + + TYPE CHECK1 IS RANGE -MAX_INT .. MAX_INT; + TYPE CHECK2 IS RANGE MIN_INT .. MAX_INT; + + BEGIN + + TEST ("AD7101C", "CHECK THAT TYPE DEFINITIONS WITH RANGES " & + "-MAX_INT .. MAX_INT AND MIN_INT .. MAX_INT " & + "ARE ACCEPTED"); + + RESULT; + + END AD7101C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7102a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- AD7102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT MAX_DIGITS IS DECLARED WITHIN THE + -- PACKAGE SYSTEM, THAT ITS TYPE IS , AND THAT + -- ITS VALUE IS STATIC. + + -- HISTORY: + -- BCB 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7102A IS + + U_DIGITS : CONSTANT := SYSTEM.MAX_DIGITS; + + TYPE S_DIGITS IS RANGE 7 .. SYSTEM.MAX_DIGITS; + + BEGIN + + TEST ("AD7102A", "CHECK THAT THE CONSTANT MAX_DIGITS IS " & + "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " & + "TYPE IS , AND THAT ITS " & + "VALUE IS STATIC"); + RESULT; + + END AD7102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7103a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- AD7103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT MAX_MANTISSA IS DECLARED WITHIN THE + -- PACKAGE SYSTEM, THAT ITS TYPE IS , AND THAT + -- ITS VALUE IS STATIC. + + -- HISTORY: + -- BCB 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7103A IS + + U_MANTISSA : CONSTANT := SYSTEM.MAX_MANTISSA; + + TYPE S_MANTISSA IS RANGE 7 .. SYSTEM.MAX_MANTISSA; + + BEGIN + + TEST ("AD7103A", "CHECK THAT THE CONSTANT MAX_MANTISSA IS " & + "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " & + "TYPE IS , AND THAT ITS " & + "VALUE IS STATIC"); + RESULT; + + END AD7103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7103c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7103c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7103c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7103c.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- AD7103C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT FINE_DELTA IS DECLARED WITHIN THE + -- PACKAGE SYSTEM, THAT ITS TYPE IS , AND THAT + -- ITS VALUE IS STATIC. + + -- HISTORY: + -- BCB 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7103C IS + + U_DELTA : CONSTANT := SYSTEM.FINE_DELTA; + + TYPE S_DELTA IS DELTA SYSTEM.FINE_DELTA RANGE -1.0 .. 1.0; + + BEGIN + + TEST ("AD7103C", "CHECK THAT THE CONSTANT FINE_DELTA IS " & + "DECLARED WITHIN THE PACKAGE SYSTEM, THAT ITS " & + "TYPE IS , AND THAT ITS " & + "VALUE IS STATIC"); + RESULT; + + END AD7103C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7104a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- AD7104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT TICK IS DECLARED WITHIN THE PACKAGE + -- SYSTEM, THAT ITS TYPE IS , AND THAT ITS VALUE + -- IS STATIC. + + -- HISTORY: + -- BCB 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE AD7104A IS + + U_TICK: CONSTANT := SYSTEM.TICK; + + F : FLOAT := SYSTEM.TICK; + + BEGIN + + TEST ("AD7104A", "CHECK THAT THE CONSTANT TICK IS DECLARED " & + "WITHIN THE PACKAGE SYSTEM, THAT ITS TYPE IS " & + ", AND THAT ITS VALUE IS STATIC"); + + RESULT; + + END AD7104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7201a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- AD7201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF THE 'ADDRESS ATTRIBUTE CAN DENOTE A + -- PACKAGE, SUBPROGRAM, TASK TYPE, SINGLE TASK, AND LABEL. + + -- HISTORY: + -- DHH 09/01/88 CREATED ORIGINAL TEST. + -- RJW 02/23/90 REMOVED TESTS FOR THE 'ADDRESS ATTRIBUTE APPLIED TO + -- A GENERIC UNIT. REMOVED DECLARATION OF TYPE + -- "COLOR". + -- DTN 11/22/91 DELETED SUBPART (A). + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE AD7201A IS + + SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS; + + BEGIN + TEST ("AD7201A", "CHECK THAT THE PREFIX OF THE 'ADDRESS " & + "ATTRIBUTE CAN DENOTE A PACKAGE, " & + "SUBPROGRAM, TASK TYPE, SINGLE TASK, AND LABEL"); + + DECLARE + PACKAGE B IS + END B; + B1 : BOOLEAN := (B'ADDRESS IN MY_ADDRESS); + + PROCEDURE C; + C1 : BOOLEAN := (C'ADDRESS IN MY_ADDRESS); + + FUNCTION D RETURN BOOLEAN; + D1 : BOOLEAN := (D'ADDRESS IN MY_ADDRESS); + + TASK E IS + END E; + E1 : BOOLEAN := (E'ADDRESS IN MY_ADDRESS); + + TASK TYPE F IS + END F; + F1 : BOOLEAN := (F'ADDRESS IN MY_ADDRESS); + + G1 : BOOLEAN; + + PACKAGE BODY B IS + BEGIN + NULL; + END B; + + PROCEDURE C IS + BEGIN + NULL; + END C; + + FUNCTION D RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END D; + + TASK BODY E IS + BEGIN + NULL; + END E; + + TASK BODY F IS + BEGIN + NULL; + END F; + + BEGIN + <> G1 := (G'ADDRESS IN MY_ADDRESS); + END; + + RESULT; + END AD7201A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7203b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7203b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7203b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7203b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- AD7203B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF THE 'SIZE' ATTRIBUTE CAN BE AN OBJECT, + -- A TYPE, OR A SUBTYPE. + + -- HISTORY: + -- BCB 09/27/88 CREATED ORIGINAL TEST BY MODIFYING AND RENAMING + -- CD7203B.ADA. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE AD7203B IS + + TYPE I_REC IS + RECORD + I1, I2 : INTEGER; + END RECORD; + + I : INTEGER; + I_A : ARRAY (1 ..5) OF INTEGER; + I_R : I_REC; + + I_SIZE : INTEGER := I'SIZE; + I_A_SIZE : INTEGER := I_A'SIZE; + I_R_SIZE : INTEGER := I_R'SIZE; + I_A_1_SIZE : INTEGER := I_A(1)'SIZE; + I_R_I1_SIZE : INTEGER := I_R.I1'SIZE; + + TYPE FIXED IS DELTA 0.01 RANGE -1.0 .. 1.0; + TYPE FXD_REC IS + RECORD + FXD1, FXD2 : FIXED; + END RECORD; + + FXD : FIXED; + FXD_A : ARRAY (1 .. 5) OF FIXED; + FXD_R : FXD_REC; + + FXD_SIZE : INTEGER := FXD'SIZE; + FXD_A_SIZE : INTEGER := FXD_A'SIZE; + FXD_R_SIZE : INTEGER := FXD_R'SIZE; + FXD_A_1_SIZE : INTEGER := FXD_A(1)'SIZE; + FXD_R_FXD1_SIZE : INTEGER := FXD_R.FXD1'SIZE; + + TYPE FLT_REC IS + RECORD + FLT1, FLT2 : FLOAT; + END RECORD; + + FLT : FLOAT; + FLT_A : ARRAY (1 .. 5) OF FLOAT; + FLT_R : FLT_REC; + + FLT_SIZE : INTEGER := FLT'SIZE; + FLT_A_SIZE : INTEGER := FLT_A'SIZE; + FLT_R_SIZE : INTEGER := FLT_R'SIZE; + FLT_A_1_SIZE : INTEGER := FLT_A(1)'SIZE; + FLT_R_FLT1_SIZE : INTEGER := FLT_R.FLT1'SIZE; + + SUBTYPE TINY_INT IS INTEGER RANGE 0 .. 255; + TYPE TI_REC IS + RECORD + TI1, TI2 : TINY_INT; + END RECORD; + + TI : TINY_INT; + TI_A : ARRAY (1 .. 5) OF TINY_INT; + TI_R : TI_REC; + + TINY_INT_SIZE : INTEGER := TINY_INT'SIZE; + TI_SIZE : INTEGER := TI'SIZE; + TI_A_SIZE : INTEGER := TI_A'SIZE; + TI_R_SIZE : INTEGER := TI_R'SIZE; + TI_A_1_SIZE : INTEGER := TI_A(1)'SIZE; + TI_R_TI1_SIZE : INTEGER := TI_R.TI1'SIZE; + + TYPE STR IS ARRAY (TINY_INT RANGE <>) OF CHARACTER; + TYPE STR_2 IS ARRAY (1 .. 127) OF CHARACTER; + TYPE STR_REC IS + RECORD + S1, S2 : STR (TINY_INT'FIRST .. TINY_INT'LAST); + END RECORD; + + S : STR (TINY_INT'FIRST .. TINY_INT'LAST); + S_A : ARRAY (1 .. 5) OF STR (TINY_INT'FIRST .. TINY_INT'LAST); + S_R : STR_REC; + + STR_2_SIZE : INTEGER := STR_2'SIZE; + S_SIZE : INTEGER := S'SIZE; + S_A_SIZE : INTEGER := S_A'SIZE; + S_R_SIZE : INTEGER := S_R'SIZE; + S_A_1_SIZE : INTEGER := S_A(1)'SIZE; + S_R_S1_SIZE : INTEGER := S_R.S1'SIZE; + + TYPE C_REC IS + RECORD + C1, C2 : CHARACTER; + END RECORD; + + C : CHARACTER; + C_A : ARRAY (1 .. 5) OF CHARACTER; + C_R : C_REC; + + C_SIZE : INTEGER := C'SIZE; + C_A_SIZE : INTEGER := C_A'SIZE; + C_R_SIZE : INTEGER := C_R'SIZE; + C_A_1_SIZE : INTEGER := C_A(1)'SIZE; + C_R_C1_SIZE : INTEGER := C_R.C1'SIZE; + + TYPE B_REC IS + RECORD + B1, B2 : BOOLEAN; + END RECORD; + + B : BOOLEAN; + B_A : ARRAY (1 .. 5) OF BOOLEAN; + B_R : B_REC; + + B_SIZE : INTEGER := B'SIZE; + B_A_SIZE : INTEGER := B_A'SIZE; + B_R_SIZE : INTEGER := B_R'SIZE; + B_A_1_SIZE : INTEGER := B_A(1)'SIZE; + B_R_B1_SIZE : INTEGER := B_R.B1'SIZE; + + TYPE DISCR IS RANGE 1 .. 2; + TYPE DISCR_REC (D : DISCR := 1) IS + RECORD + CASE D IS + WHEN 1 => + C1_I : INTEGER; + WHEN 2 => + C2_I1 : INTEGER; + C2_I2 : INTEGER; + END CASE; + END RECORD; + + DR_UC : DISCR_REC; + DR_C : DISCR_REC (2); + DR_A : ARRAY (1 .. 5) OF DISCR_REC; + + DR_UC_SIZE : INTEGER := DR_UC'SIZE; + DR_C_SIZE : INTEGER := DR_C'SIZE; + DR_A_SIZE : INTEGER := DR_A'SIZE; + DR_UC_C1_I_SIZE : INTEGER := DR_UC.C1_I'SIZE; + DR_A_1_SIZE : INTEGER := DR_A(1)'SIZE; + + TYPE ENUM IS (E1, E2, E3, E4); + TYPE ENUM_REC IS + RECORD + E1, E2 : ENUM; + END RECORD; + + E : ENUM; + E_A : ARRAY (1 .. 5) OF ENUM; + E_R : ENUM_REC; + + E_SIZE : INTEGER := E'SIZE; + E_A_SIZE : INTEGER := E_A'SIZE; + E_R_SIZE : INTEGER := E_R'SIZE; + E_A_1_SIZE : INTEGER := E_A(1)'SIZE; + E_R_E1_SIZE : INTEGER := E_R.E1'SIZE; + + TASK TYPE TSK IS END TSK; + TYPE TSK_REC IS + RECORD + TSK1, TSK2 : TSK; + END RECORD; + + T : TSK; + T_A : ARRAY (1 .. 5) OF TSK; + T_R : TSK_REC; + + T_SIZE : INTEGER := T'SIZE; + T_A_SIZE : INTEGER := T_A'SIZE; + T_R_SIZE : INTEGER := T_R'SIZE; + T_A_1_SIZE : INTEGER := T_A(1)'SIZE; + T_R_TSK1_SIZE : INTEGER := T_R.TSK1'SIZE; + + TYPE ACC IS ACCESS INTEGER; + TYPE ACC_REC IS + RECORD + A1, A2 : ACC; + END RECORD; + + A : ACC; + A_A : ARRAY (1 .. 5) OF ACC; + A_R : ACC_REC; + + A_SIZE : INTEGER := A'SIZE; + A_A_SIZE : INTEGER := A_A'SIZE; + A_R_SIZE : INTEGER := A_R'SIZE; + A_A_1_SIZE : INTEGER := A_A(1)'SIZE; + A_R_A1_SIZE : INTEGER := A_R.A1'SIZE; + + PACKAGE PK IS + TYPE PRV IS PRIVATE; + TYPE PRV_REC IS + RECORD + P1, P2 : PRV; + END RECORD; + + TYPE LPRV IS LIMITED PRIVATE; + TYPE LPRV_REC IS + RECORD + LP1, LP2 : LPRV; + END RECORD; + PRIVATE + TYPE PRV IS NEW INTEGER; + + TYPE LPRV IS NEW INTEGER; + END PK; + USE PK; + + P : PRV; + P_A : ARRAY (1 .. 5) OF PRV; + P_R : PRV_REC; + + P_SIZE : INTEGER := P'SIZE; + P_A_SIZE : INTEGER := P_A'SIZE; + P_R_SIZE : INTEGER := P_R'SIZE; + P_A_1_SIZE : INTEGER := P_A(1)'SIZE; + P_R_P1_SIZE : INTEGER := P_R.P1'SIZE; + + LP : LPRV; + LP_A : ARRAY (1 .. 5) OF LPRV; + LP_R : LPRV_REC; + + LP_SIZE : INTEGER := LP'SIZE; + LP_A_SIZE : INTEGER := LP_A'SIZE; + LP_R_SIZE : INTEGER := LP_R'SIZE; + LP_A_1_SIZE : INTEGER := LP_A(1)'SIZE; + LP_R_LP1_SIZE : INTEGER := LP_R.LP1'SIZE; + + TASK BODY TSK IS + BEGIN + NULL; + END TSK; + + BEGIN + TEST ("AD7203B", "CHECK THAT THE PREFIX OF THE 'SIZE' ATTRIBUTE " & + "CAN BE AN OBJECT, A TYPE, OR A SUBTYPE"); + + RESULT; + END AD7203B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7205b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7205b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad7205b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad7205b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- AD7205B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF THE 'STORAGE_SIZE ATTRIBUTE CAN BE AN + -- ACCESS TYPE, A TASK TYPE, A TASK OBJECT, OR A SINGLE TASK. + + -- HISTORY: + -- JET 09/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE AD7205B IS + + B : BOOLEAN; + + TYPE A IS ACCESS INTEGER; + TASK TYPE T; + T1 : T; + TASK T2; + + TASK BODY T IS + BEGIN + NULL; + END T; + + TASK BODY T2 IS + BEGIN + NULL; + END T2; + + BEGIN + + TEST ("AD7205B", "CHECK THAT THE PREFIX OF THE 'STORAGE_SIZE " & + "ATTRIBUTE CAN BE AN ACCESS TYPE, A TASK TYPE, " & + "A TASK OBJECT, OR A SINGLE TASK"); + + B := A'STORAGE_SIZE = T'STORAGE_SIZE; -- ACCESS AND TASK TYPES. + B := T1'STORAGE_SIZE = T2'STORAGE_SIZE; -- TASK OBJECT & SINGLE + -- TASK. + + RESULT; + + END AD7205B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad8011a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad8011a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ad8011a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ad8011a.tst 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- AD8011A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CODE STATEMENTS ARE ALLOWED IN A PROCEDURE BODY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- MACHINE CODE INSERTIONS. + + -- IF SUCH INSERTIONS ARE NOT SUPPORTED, THE "WITH MACHINE_CODE" + -- CLAUSE MUST BE REJECTED. + + + -- MACRO SUBSTITUTION: + -- IF MACHINE CODE INSERTIONS ARE SUPPORTED THEN THE MACRO + -- $MACHINE_CODE_STATEMENT MUST BE REPLACED BY A VALID CODE + -- STATEMENT. + + -- IF MACHINE CODE INSERTIONS ARE NOT SUPPORTED, THEN SUBSTITUTE + -- THE ADA NULL STATEMENT (IE: NULL;) FOR $MACHINE_CODE_STATEMENT. + + -- HISTORY: + -- DHH 08/30/88 CREATED ORIGINAL TEST. + + WITH MACHINE_CODE; -- N/A => ERROR. + USE MACHINE_CODE; + WITH REPORT; USE REPORT; + PROCEDURE AD8011A IS + + PROCEDURE CODE IS + BEGIN + $MACHINE_CODE_STATEMENT + END; + + BEGIN + TEST("AD8011A", "CHECK THAT CODE STATEMENTS ARE ALLOWED IN " & + "A PROCEDURE BODY"); + + CODE; + + RESULT; + END AD8011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ada101a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ada101a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ada101a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ada101a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- ADA101A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNCHECKED_DEALLOCATION CAN BE INSTANTIATED WITH ANY + -- TYPE AS THE OBJECT PARAMETER. + + -- HISTORY: + -- JET 09/23/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH UNCHECKED_DEALLOCATION; + PROCEDURE ADA101A IS + + TYPE ENUM IS (CURLY, MOE, LARRY); + TYPE DER IS NEW INTEGER; + SUBTYPE SUB IS CHARACTER RANGE 'A'..'Z'; + TASK TYPE TSK; + TYPE ACC IS ACCESS INTEGER; + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS RANGE -100..100; + END P; + USE P; + + TYPE ARR1 IS ARRAY (INTEGER RANGE 1..10) OF INTEGER; + TYPE ARR2 IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + + TYPE REC1 IS RECORD + D, I : INTEGER; + END RECORD; + + TYPE REC2 (D : INTEGER) IS RECORD + C : CHARACTER; + END RECORD; + + TYPE INTEGERA IS ACCESS INTEGER; + TYPE FLOATA IS ACCESS FLOAT; + TYPE ENUMA IS ACCESS ENUM; + TYPE BOOLEANA IS ACCESS BOOLEAN; + TYPE CHARACTERA IS ACCESS CHARACTER; + TYPE DERA IS ACCESS DER; + TYPE SUBA IS ACCESS SUB; + TYPE TSKA IS ACCESS TSK; + TYPE ACCA IS ACCESS ACC; + TYPE PRIVA IS ACCESS PRIV; + TYPE ARR1A IS ACCESS ARR1; + TYPE ARR2A IS ACCESS ARR2; + TYPE REC1A IS ACCESS REC1; + TYPE REC2A IS ACCESS REC2; + + TASK BODY TSK IS + BEGIN + NULL; + END TSK; + + PROCEDURE RLSI IS NEW UNCHECKED_DEALLOCATION(INTEGER, INTEGERA); + PROCEDURE RLSF IS NEW UNCHECKED_DEALLOCATION(FLOAT, FLOATA); + PROCEDURE RLSE IS NEW UNCHECKED_DEALLOCATION(ENUM, ENUMA); + PROCEDURE RLSB IS NEW UNCHECKED_DEALLOCATION(BOOLEAN, BOOLEANA); + PROCEDURE RLSC IS NEW UNCHECKED_DEALLOCATION(CHARACTER,CHARACTERA); + PROCEDURE RLSD IS NEW UNCHECKED_DEALLOCATION(DER, DERA); + PROCEDURE RLSS IS NEW UNCHECKED_DEALLOCATION(SUB, SUBA); + PROCEDURE RLST IS NEW UNCHECKED_DEALLOCATION(TSK, TSKA); + PROCEDURE RLSA IS NEW UNCHECKED_DEALLOCATION(ACC, ACCA); + PROCEDURE RLSP IS NEW UNCHECKED_DEALLOCATION(PRIV, PRIVA); + PROCEDURE RLSA1 IS NEW UNCHECKED_DEALLOCATION(ARR1, ARR1A); + PROCEDURE RLSA2 IS NEW UNCHECKED_DEALLOCATION(ARR2, ARR2A); + PROCEDURE RLSR1 IS NEW UNCHECKED_DEALLOCATION(REC1, REC1A); + PROCEDURE RLSR2 IS NEW UNCHECKED_DEALLOCATION(REC2, REC2A); + + BEGIN + TEST ("ADA101A", "CHECK THAT UNCHECKED_DEALLOCATION CAN BE " & + "INSTANTIATED WITH ANY TYPE AS THE OBJECT " & + "PARAMETER"); + + RESULT; + END ADA101A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae2113a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae2113a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae2113a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae2113a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- AE2113A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE SUBPROGRAMS CREATE, OPEN, CLOSE, DELETE, RESET, MODE, + -- NAME, FORM, AND IS_OPEN ARE AVAILABLE FOR DIRECT_IO AND THAT + -- SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER NAMES. + + -- TBN 9/30/86 + + WITH DIRECT_IO; + WITH REPORT; USE REPORT; + PROCEDURE AE2113A IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + + TEMP : FILE_TYPE; + + BEGIN + TEST ("AE2113A", "CHECK THAT THE SUBPROGRAMS CREATE, OPEN, " & + "CLOSE, DELETE, RESET, MODE, NAME, FORM, AND " & + "IS_OPEN ARE AVAILABLE FOR DIRECT_IO AND THAT " & + "SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER " & + "NAMES"); + BEGIN + CREATE (FILE=> TEMP, MODE=> OUT_FILE, + NAME=> "AE2113A.DAT", FORM=> ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + RESET (FILE=> TEMP, MODE=> OUT_FILE); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + CLOSE (FILE=> TEMP); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + OPEN (FILE=> TEMP, MODE=> OUT_FILE, + NAME=> "AE2113A.DAT", FORM=> ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF IS_OPEN (FILE=> TEMP) THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF MODE (FILE=> TEMP) /= OUT_FILE THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF NAME (FILE=> TEMP) /= "AE2113A.DAT" THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF FORM (FILE=> TEMP) /= "" THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + DELETE (FILE=> TEMP); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + RESULT; + END AE2113A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae2113b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae2113b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae2113b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae2113b.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- AE2113B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE SUBPROGRAMS CREATE, OPEN, CLOSE, DELETE, RESET, MODE, + -- NAME, FORM, AND IS_OPEN ARE AVAILABLE FOR SEQUENTIAL_IO AND THAT + -- SUBPROGRAMS HAVE THE CORRECT FORMAL PARAMETER NAMES. + + -- TBN 9/30/86 + + WITH SEQUENTIAL_IO; + WITH REPORT; USE REPORT; + PROCEDURE AE2113B IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + + TEMP : FILE_TYPE; + + BEGIN + TEST ("AE2113B", "CHECK THAT THE SUBPROGRAMS CREATE, OPEN, " & + "CLOSE, DELETE, RESET, MODE, NAME, FORM, AND " & + "IS_OPEN ARE AVAILABLE FOR SEQUENTIAL_IO AND " & + "THAT SUBPROGRAMS HAVE THE CORRECT FORMAL " & + "PARAMETER NAMES"); + BEGIN + CREATE (FILE=> TEMP, MODE=> OUT_FILE, + NAME=> "AE2113B.DAT", FORM=> ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + RESET (FILE=> TEMP, MODE=> OUT_FILE); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + CLOSE (FILE=> TEMP); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + OPEN (FILE=> TEMP, MODE=> OUT_FILE, + NAME=> "AE2113B.DAT", FORM=> ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF IS_OPEN (FILE=> TEMP) THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF MODE (FILE=> TEMP) /= OUT_FILE THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF NAME (FILE=> TEMP) /= "AE2113B.DAT" THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF FORM (FILE=> TEMP) /= "" THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + DELETE (FILE=> TEMP); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + RESULT; + END AE2113B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3002g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3002g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3002g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3002g.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + -- AE3002G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FILE_MODE IS VISIBLE AND HAS LITERALS IN_FILE AND + -- OUT_FILE. ASLO CHECK THAT TYPE_SET IS VISIBLE AND HAS LITERALS + -- LOWER_CASE AND UPPER_CASE. + + -- TBN 10/3/86 + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + PROCEDURE AE3002G IS + + TEMP_FILE : FILE_TYPE; + MODE : FILE_MODE := IN_FILE; + LETTERS : TYPE_SET := LOWER_CASE; + + BEGIN + TEST ("AE3002G", "CHECK THAT FILE_MODE AND TYPE_SET ARE VISIBLE " & + "AND CHECK THEIR LITERALS"); + + MODE := OUT_FILE; + LETTERS := UPPER_CASE; + + RESULT; + END AE3002G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3101a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3101a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3101a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3101a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- AE3101A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CREATE, OPEN, CLOSE, DELETE, RESET, MODE, NAME, + -- FORM, IS_OPEN, AND END_OF_FILE ARE AVAILABLE FOR TEXT FILES. + -- ALSO CHECK THAT FORMAL PARAMETER NAMES ARE CORRECT. + + -- HISTORY: + -- ABW 08/24/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- DWC 09/24/87 REMOVED DEPENDENCE ON FILE SUPPORT. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE AE3101A IS + + FILE1 : FILE_TYPE; + + BEGIN + + TEST ("AE3101A" , "CHECK THAT CREATE, OPEN, DELETE, " & + "RESET, MODE, NAME, FORM, IS_OPEN, " & + "AND END_OF_FILE ARE AVAILABLE " & + "FOR TEXT FILE"); + + BEGIN + CREATE (FILE => FILE1, + MODE => OUT_FILE, + NAME => LEGAL_FILE_NAME, + FORM => ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + RESET (FILE => FILE1, MODE => IN_FILE); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + CLOSE (FILE => FILE1); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + OPEN (FILE => FILE1, + MODE => IN_FILE, + NAME => LEGAL_FILE_NAME, + FORM => ""); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + IF IS_OPEN (FILE => FILE1) THEN + NULL; + END IF; + + BEGIN + IF MODE (FILE => FILE1) /= IN_FILE THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF NAME (FILE => FILE1) /= LEGAL_FILE_NAME THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF FORM (FILE => FILE1) /= "" THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + IF END_OF_FILE (FILE => FILE1) THEN + NULL; + END IF; + EXCEPTION + WHEN OTHERS => + NULL; + END; + + BEGIN + DELETE (FILE => FILE1); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + RESULT; + + END AE3101A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3702a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3702a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3702a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3702a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- AE3702A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INTEGER_IO CAN BE INSTANTIATED FOR USER DEFINED INTEGER + -- TYPES. + + -- SPS 10/1/82 + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE AE3702A IS + BEGIN + + TEST ("AE3702A", "CHECK THAT INTEGER_IO CAN BE INSTANTIATED FOR " & + "USER DEFINED TYPES"); + + DECLARE + TYPE I1 IS RANGE 6 .. 14; + TYPE I2 IS NEW INTEGER; + TYPE I3 IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + SUBTYPE S1 IS INTEGER RANGE 6 .. 14; + SUBTYPE S2 IS INTEGER; + SUBTYPE S3 IS INTEGER RANGE 0 .. INTEGER'LAST; + + PACKAGE NIO1 IS NEW INTEGER_IO (I1); + PACKAGE NIO2 IS NEW INTEGER_IO (I2); + PACKAGE NIO3 IS NEW INTEGER_IO (I3); + PACKAGE NIO4 IS NEW INTEGER_IO (S1); + PACKAGE NIO5 IS NEW INTEGER_IO (S2); + PACKAGE NIO6 IS NEW INTEGER_IO (S3); + + BEGIN + NULL; + END; + + RESULT; + END AE3702A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3709a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3709a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/a/ae3709a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/a/ae3709a.ada 2003-10-27 11:28:49.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- AE3709A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE NAMES OF THE FORMAL PARAMETERS. + + -- JBG 3/30/83 + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE AE3709A IS + + PACKAGE INT IS NEW INTEGER_IO(INTEGER); + USE INT; + FILE : FILE_TYPE; + STR : STRING(1..3); + LAST : POSITIVE; + ITEM : INTEGER; + + BEGIN + + TEST ("AE3709A", "CHECK NAMES OF FORMAL PARAMETERS"); + + IF EQUAL(2, 3) THEN + GET (FILE => FILE, ITEM => ITEM, WIDTH => 0); + GET (ITEM => ITEM, WIDTH => 0); + PUT (FILE => FILE, ITEM => ITEM, WIDTH => 4, BASE => 4); + PUT (ITEM => ITEM, WIDTH => 4, BASE => 4); + GET (FROM => STR, ITEM => ITEM, LAST => LAST); + PUT (TO => STR, ITEM => ITEM, BASE => 4); + END IF; + + RESULT; + + END AE3709A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23001a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C23001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UPPER AND LOWER CASE LETTERS ARE EQUIVALENT IN IDENTIFIERS + -- (INCLUDING RESERVED WORDS). + + -- JRK 12/12/79 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C23001A IS + + USE REPORT; + + AN_IDENTIFIER : INTEGER := 1; + + BEGIN + TEST ("C23001A", "UPPER/LOWER CASE EQUIVALENCE IN IDENTIFIERS"); + + DECLARE + an_identifier : INTEGER := 3; + BEGIN + IF an_identifier /= AN_IDENTIFIER THEN + FAILED ("LOWER CASE NOT EQUIVALENT TO UPPER " & + "IN DECLARABLE IDENTIFIERS"); + END IF; + END; + + IF An_IdEnTIfieR /= AN_IDENTIFIER THEN + FAILED ("MIXED CASE NOT EQUIVALENT TO UPPER IN " & + "DECLARABLE IDENTIFIERS"); + END IF; + + if AN_IDENTIFIER = 1 ThEn + AN_IDENTIFIER := 2; + END IF; + IF AN_IDENTIFIER /= 2 THEN + FAILED ("LOWER AND/OR MIXED CASE NOT EQUIVALENT TO " & + "UPPER IN RESERVED WORDS"); + END IF; + + RESULT; + END C23001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003a.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C23003A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VARIABLE IDENTIFIERS CAN BE AS LONG AS THE MAXIMUM LENGTH + -- IDENTIFIER PERMITTED AND THAT ALL CHARACTERS ARE SIGNIFICANT. + + -- JRK 12/12/79 + -- JRK 1/11/80 + -- JWC 6/28/85 RENAMED TO -AB + -- KAS 12/04/95 CHANGED "INPUT LINE LENGTH" TO "LENGTH IDENTIFIER" + + WITH REPORT; + PROCEDURE C23003A IS + + USE REPORT; + + BEGIN + TEST ("C23003A", "MAXIMUM LENGTH VARIABLE IDENTIFIERS"); + + -- BIG_ID1 AND BIG_ID2 ARE TWO MAXIMUM LENGTH IDENTIFIERS THAT + -- DIFFER ONLY IN THEIR LAST CHARACTER. + + DECLARE + $BIG_ID1 + -- BIG_ID1 + : INTEGER := 1; + BEGIN + DECLARE + $BIG_ID2 + -- BIG_ID2 + : INTEGER := 2; + BEGIN + + IF + $BIG_ID1 + -- BIG_ID1 + + + $BIG_ID2 + -- BIG_ID2 + /= 3 THEN + FAILED ("IDENTIFIERS AS LONG AS " & + "MAXIMUM INPUT LINE LENGTH " & + "NOT PERMITTED OR NOT " & + "DISTINGUISHED BY DISTINCT " & + "SUFFIXES"); + END IF; + + END; + END; + + -- BIG_ID3 AND BIG_ID4 ARE TWO MAXIMUM LENGTH IDENTIFIERS THAT + -- DIFFER ONLY IN THEIR MIDDLE CHARACTER. + + DECLARE + $BIG_ID3 + -- BIG_ID3 + : INTEGER := 3; + BEGIN + DECLARE + $BIG_ID4 + -- BIG_ID4 + : INTEGER := 4; + BEGIN + + IF + $BIG_ID3 + -- BIG_ID3 + + + $BIG_ID4 + -- BIG_ID4 + /= 7 THEN + FAILED ("IDENTIFIERS AS LONG AS " & + "MAXIMUM INPUT LINE LENGTH " & + "NOT PERMITTED OR NOT " & + "DISTINGUISHED BY DISTINCT " & + "MIDDLES"); + END IF; + + END; + END; + + RESULT; + END C23003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003b.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003b.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003b.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003b.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C23003B.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- CHECK THAT THE NAME OF A LIBRARY UNIT PACKAGE AND THE NAME OF A LIBRARY + -- SUBPROGRAM CAN BE AS LONG AS THE LONGEST IDENTIFIER ALLOWED BY + -- AN IMPLEMENTATION. + + -- JBG 5/26/85 + -- DTN 3/25/92 CONSOLIDATION OF C23003B.TST AND C23003C.TST. + -- KAS 11/04/95 CHANGE "LINE" TO "IDENTIFIER" + + PACKAGE + $BIG_ID1 + IS + A : INTEGER := 1; + END + $BIG_ID1 + ; + PACKAGE + $BIG_ID2 + IS + B : INTEGER := 2; + END + $BIG_ID2 + ; + + PROCEDURE + $BIG_ID3 + (X : OUT INTEGER) IS + BEGIN + X := 1; + END + $BIG_ID3 + ; + PROCEDURE + $BIG_ID4 + (X : OUT INTEGER) IS + BEGIN + X := 2; + END + $BIG_ID4 + ; + + WITH + $BIG_ID1 + , + $BIG_ID2 + , + $BIG_ID3 + , + $BIG_ID4 + ; + USE + $BIG_ID1 + , + $BIG_ID2 + ; + + WITH REPORT; USE REPORT; + PROCEDURE C23003B IS + X1, X2 : INTEGER := 0; + BEGIN + TEST ("C23003B", "CHECK LONGEST POSSIBLE IDENTIFIER CAN BE USED " & + "FOR LIBRARY PACKAGE AND SUBPROGRAM"); + + IF A + IDENT_INT(1) /= B THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION"); + END IF; + + + $BIG_ID3 + (X1); + $BIG_ID4 + (X2); + + IF X1 + IDENT_INT(1) /= X2 THEN + FAILED ("INCORRECT PROCEDURE IDENTIFICATION"); + END IF; + + RESULT; + END C23003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003g.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003g.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003g.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003g.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C23003G.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAME OF A GENERIC LIBRARY UNIT PACKAGE AND THE NAME + -- OF A GENERIC LIBRARY UNIT SUBPROGRAM CAN BE AS LONG + + -- JBG 5/26/85 + -- DTN 3/25/92 CONSOLIDATION OF C23003G.TST AND C23003H.TST. + -- KAS 12/4/95 CHANGE "LINE" TO "IDENTIFIER" + + GENERIC + PACKAGE + $BIG_ID1 + IS + A : INTEGER := 1; + END + $BIG_ID1 + ; + GENERIC + PACKAGE + $BIG_ID2 + IS + B : INTEGER := 2; + END + $BIG_ID2 + ; + + GENERIC + FUNCTION + $BIG_ID3 + RETURN INTEGER; + + FUNCTION + $BIG_ID3 + RETURN INTEGER IS + BEGIN + RETURN 3; + END + $BIG_ID3 + ; + + GENERIC + FUNCTION + $BIG_ID4 + RETURN INTEGER; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION + $BIG_ID4 + RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(4); + END + $BIG_ID4 + ; + + WITH + $BIG_ID3 + ; + PRAGMA ELABORATE ( + $BIG_ID3 + ); + FUNCTION F1 IS NEW + $BIG_ID3 + ; + + WITH + $BIG_ID1 + ; + PRAGMA ELABORATE ( + $BIG_ID1 + ); + PACKAGE C23003G_PKG IS NEW + $BIG_ID1 + ; + WITH C23003G_PKG, F1, + $BIG_ID2 + , + $BIG_ID4 + ; + USE C23003G_PKG; + WITH REPORT; USE REPORT; + PROCEDURE C23003G IS + + PACKAGE P2 IS NEW + $BIG_ID2 + ; + USE P2; + FUNCTION F2 IS NEW + $BIG_ID4 + ; + + BEGIN + TEST ("C23003G", "CHECK LONGEST POSSIBLE IDENTIFIER CAN BE USED " & + "FOR GENERIC LIBRARY PACKAGE AND SUBPROGRAM"); + + IF A + IDENT_INT(1) /= B THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION"); + END IF; + + + IF F1 + IDENT_INT(1) /= F2 THEN + FAILED ("INCORRECT FUNCTION IDENTIFICATION"); + END IF; + + RESULT; + END C23003G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003i.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003i.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23003i.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23003i.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C23003I.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LONGEST POSSIBLE IDENTIFIER CAN BE THE NAME OF A + -- LIBRARY PACKAGE CREATED BY A GENERIC INSTANTIATION. + + -- JBG 5/26/85 + -- DTN 3/25/92 DELETED TEST OF TWO MAXIMUM LENGTH PACKAGE NAMES THAT + -- DIFFER ONLY IN THEIR MIDDLE CHARACTER. + + GENERIC + C : INTEGER; + PACKAGE C23003I_PKG IS + A : INTEGER := C; + END C23003I_PKG; + + WITH C23003I_PKG; + PRAGMA ELABORATE (C23003I_PKG); + PACKAGE + $BIG_ID1 + IS NEW C23003I_PKG (1); + + WITH REPORT; USE REPORT; + WITH C23003I_PKG; + PRAGMA ELABORATE (REPORT, C23003I_PKG); + PACKAGE + $BIG_ID2 + IS NEW C23003I_PKG (IDENT_INT(2)); + + WITH + $BIG_ID1 + , + $BIG_ID2 + ; + WITH REPORT; USE REPORT; + PROCEDURE C23003I IS + BEGIN + TEST ("C23003I", "CHECK THAT LONGEST POSSIBLE IDENTIFIER CAN BE " & + "USED FOR A LIBRARY PACKAGE INSTANTIATION"); + + IF + $BIG_ID1 + .A + IDENT_INT(1) /= + $BIG_ID2 + .A THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION"); + END IF; + + RESULT; + END C23003I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,48 ---- + -- C23006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN IDENTIFIERS. + + -- JRK 12/12/79 + -- JBG 5/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C23006A IS + + AN_IDENTIFIER : INTEGER := 1; + + BEGIN + TEST ("C23006A", "UNDERSCORES ARE SIGNFICANT IN IDENTIFERS"); + + DECLARE + ANIDENTIFIER : INTEGER := 3; + BEGIN + IF ANIDENTIFIER = AN_IDENTIFIER THEN + FAILED ("UNDERSCORE IGNORED " & + "IN DECLARABLE IDENTIFIERS"); + END IF; + END; + + RESULT; + END C23006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C23006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN LIBRARY PACKAGE IDENTIFIERS + + -- JBG 5/26/85 + -- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + PACKAGE C23006B_PKG IS + A : INTEGER := 1; + END C23006B_PKG; + + PACKAGE C23006BPKG IS + D : INTEGER := 4; + PROCEDURE REQUIRE_BODY; + END C23006BPKG; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C23006BPKG IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + D := IDENT_INT (5); + END C23006BPKG; + + WITH C23006BPKG, C23006B_PKG; + USE C23006BPKG, C23006B_PKG; + WITH REPORT; USE REPORT; + PROCEDURE C23006B IS + BEGIN + TEST ("C23006B", "CHECK UNDERSCORES ARE SIGNIFICANT " & + "FOR LIBRARY PACKAGE IDENTIFIERS"); + + IF A + IDENT_INT(4) /= D THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION"); + END IF; + + RESULT; + END C23006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C23006C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNFICANT IN NAMES OF LIBRARY + -- SUBPROGRAMS. + + -- JBG 5/26/85 + + PROCEDURE C23006C_PROC (X : OUT INTEGER) IS + BEGIN + X := 1; + END C23006C_PROC; + + PROCEDURE C23006CPROC (X : OUT INTEGER); + + PROCEDURE C23006CPROC (X : OUT INTEGER) IS + BEGIN + X := 2; + END C23006CPROC; + + FUNCTION C23006C_FUNC RETURN INTEGER IS + BEGIN + RETURN 3; + END C23006C_FUNC; + + FUNCTION C23006CFUNC RETURN INTEGER; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION C23006CFUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(4); + END C23006CFUNC; + + WITH C23006C_PROC, C23006CPROC, C23006C_FUNC, C23006CFUNC; + WITH REPORT; USE REPORT; + PROCEDURE C23006C IS + X1, X2 : INTEGER; + BEGIN + TEST ("C23006C", "CHECK UNDERSCORES ARE SIGNIFICANT " & + "FOR LIBRARY SUBPROGRAM"); + + C23006C_PROC (X1); + C23006CPROC (X2); + IF X1 + IDENT_INT(1) /= X2 THEN + FAILED ("INCORRECT PROCEDURE IDENTIFICATION"); + END IF; + + IF C23006C_FUNC + IDENT_INT(1) /= C23006CFUNC THEN + FAILED ("INCORRECT FUNCTION IDENTIFICATION"); + END IF; + + RESULT; + END C23006C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C23006D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN THE NAMES OF GENERIC + -- LIBRARY PACKAGES + + -- JBG 5/26/85 + -- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + GENERIC + PACKAGE C23006D_PKG IS + A : INTEGER := 1; + END C23006D_PKG; + + GENERIC + PACKAGE C23006DPKG IS + D : INTEGER := 2; + PROCEDURE REQUIRE_BODY; + END C23006DPKG; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C23006DPKG IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + D := IDENT_INT (5); + END C23006DPKG; + + WITH C23006D_PKG; + PRAGMA ELABORATE (C23006D_PKG); + PACKAGE C23006D_INST IS NEW C23006D_PKG; + + WITH C23006DPKG, C23006D_INST; + USE C23006D_INST; + WITH REPORT; USE REPORT; + PROCEDURE C23006D IS + + PACKAGE P2 IS NEW C23006DPKG; + USE P2; + + BEGIN + TEST ("C23006D", "CHECK UNDERSCORES ARE SIGNIFICANT " & + "FOR GENERIC LIBRARY PACKAGE IDENTIFIERS"); + + IF A + IDENT_INT(4) /= D THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION - 1"); + END IF; + + RESULT; + END C23006D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C23006E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN THE NAMES OF GENERIC + -- LIBRARY UNIT SUBPROGRAMS. + + -- JBG 5/26/85 + + GENERIC + PROCEDURE C23006E_PROC (X : OUT INTEGER); + + PROCEDURE C23006E_PROC (X : OUT INTEGER) IS + BEGIN + X := 1; + END C23006E_PROC; + + GENERIC + PROCEDURE C230063PROC (X : OUT INTEGER); + + PROCEDURE C230063PROC (X : OUT INTEGER) IS + BEGIN + X := 2; + END C230063PROC; + + GENERIC + FUNCTION C23006E_GFUNC RETURN INTEGER; + + FUNCTION C23006E_GFUNC RETURN INTEGER IS + BEGIN + RETURN 3; + END C23006E_GFUNC; + + GENERIC + FUNCTION C23006EGFUNC RETURN INTEGER; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION C23006EGFUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(4); + END C23006EGFUNC; + + WITH C23006E_PROC; + PRAGMA ELABORATE (C23006E_PROC); + PROCEDURE P1 IS NEW C23006E_PROC; + + WITH C23006E_GFUNC; + PRAGMA ELABORATE (C23006E_GFUNC); + FUNCTION F1 IS NEW C23006E_GFUNC; + + WITH P1, F1, C230063PROC, C23006EGFUNC; + WITH REPORT; USE REPORT; + PROCEDURE C23006E IS + + X1, X2 : INTEGER; + PROCEDURE P2 IS NEW C230063PROC; + FUNCTION F2 IS NEW C23006EGFUNC; + + BEGIN + TEST ("C23006E", "CHECK UNDERSCORES ARE SIGNIFICANT " & + "FOR GENERIC LIBRARY SUBPROGRAM IDENTIFIERS"); + + P1 (X1); + P2 (X2); + IF X1 + IDENT_INT(1) /= X2 THEN + FAILED ("INCORRECT PROCEDURE IDENTIFICATION"); + END IF; + + IF F1 + IDENT_INT(1) /= F2 THEN + FAILED ("INCORRECT FUNCTION IDENTIFICATION"); + END IF; + + RESULT; + END C23006E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- C23006F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN LIBRARY PACKAGE NAMES + -- CREATED BY A GENERIC INSTANTIATION. + + -- JBG 5/26/85 + + GENERIC + C : INTEGER; + PACKAGE C23006F_PKG IS + A : INTEGER := C; + END C23006F_PKG; + + WITH C23006F_PKG; + PRAGMA ELABORATE (C23006F_PKG); + PACKAGE C23006F_INST IS NEW C23006F_PKG (1); + + WITH REPORT; USE REPORT; + WITH C23006F_PKG; + PRAGMA ELABORATE (REPORT, C23006F_PKG); + PACKAGE C23006FINST IS NEW C23006F_PKG (IDENT_INT(2)); + + WITH C23006F_INST, C23006FINST; + WITH REPORT; USE REPORT; + PROCEDURE C23006F IS + BEGIN + TEST ("C23006F", "CHECK THAT UNDERSCORES ARE SIGNIFICANT IN " & + "NAMES USED FOR A LIBRARY PACKAGE INSTANTIATION"); + + IF C23006F_INST.A + IDENT_INT(1) /= C23006FINST.A THEN + FAILED ("INCORRECT PACKAGE IDENTIFICATION - 1"); + END IF; + + RESULT; + END C23006F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c23006g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c23006g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C23006G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNDERSCORES ARE SIGNIFICANT IN LIBRARY SUBPROGRAM NAMES + -- CREATED BY A GENERIC INSTANTIATION. + + -- JBG 5/26/85 + + GENERIC + C : INTEGER; + PROCEDURE C23006G_PROC (X : OUT INTEGER); + + PROCEDURE C23006G_PROC (X : OUT INTEGER) IS + BEGIN + X := C; + END C23006G_PROC; + + GENERIC + C : INTEGER; + FUNCTION C23006G_FUNC RETURN INTEGER; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION C23006G_FUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(C); + END C23006G_FUNC; + + WITH C23006G_PROC; + PRAGMA ELABORATE (C23006G_PROC); + PROCEDURE C23006G_INSTP IS NEW C23006G_PROC (1); + + WITH REPORT; USE REPORT; + WITH C23006G_PROC; + PRAGMA ELABORATE (REPORT, C23006G_PROC); + PROCEDURE C23006GINSTP IS NEW C23006G_PROC (IDENT_INT(2)); + + WITH C23006G_FUNC; + PRAGMA ELABORATE (C23006G_FUNC); + FUNCTION C23006G_INSTF IS NEW C23006G_FUNC (3); + + WITH C23006G_FUNC; + PRAGMA ELABORATE (C23006G_FUNC); + FUNCTION C23006GINSTF IS NEW C23006G_FUNC (4); + + WITH C23006G_INSTP, C23006GINSTP, C23006G_INSTF, C23006GINSTF; + WITH REPORT; USE REPORT; + PROCEDURE C23006G IS + X1, X2 : INTEGER; + BEGIN + TEST ("C23006G", "CHECK THAT UNDERSCORES ARE SIGNFICANT IN NAMES "& + "USED FOR A LIBRARY SUBPROGRAM INSTANTIATION"); + C23006G_INSTP (X1); + C23006GINSTP (X2); + + IF X1 + IDENT_INT(1) /= X2 THEN + FAILED ("INCORRECT PROCEDURE IDENTIFICATION"); + END IF; + + IF C23006G_INSTF + IDENT_INT(1) /= C23006GINSTF THEN + FAILED ("INCORRECT FUNCTION IDENTIFICATION"); + END IF; + + RESULT; + END C23006G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24002d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C24002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOWER CASE E MAY BE USED IN INTEGER LITERALS, FLOATING POINT + -- LITERALS, AND FIXED POINT LITERALS. + -- CHECK THAT THESE NUMERIC LITERALS YIELD THE CORRECT VALUES. + + -- WMC 03/16/92 CONSOLIDATION OF C24002A.ADA, C24002B.ADA, C24002C.ADA + + WITH REPORT; + + PROCEDURE C24002D IS + + USE REPORT; + + BEGIN + TEST("C24002D", "CHECK THAT LOWER CASE E WORKS IN INTEGER, " & + "FLOATING POINT, AND FIXED POINT LITERALS, " & + "AND THAT THESE NUMERIC LITERALS YIELD THE " & + "CORRECT VALUES"); + + -- Integer Literals + DECLARE + X,Y : INTEGER; + BEGIN + X := 12e1; + Y := 16#E#e1; + + IF (X /= 120) OR (Y /= 224) THEN + FAILED("INCORRECT HANDLING OF LOWER CASE E " & + "IN INTEGER LITERALS"); + END IF; + END; + + + -- Floating Point Literal + DECLARE + X : FLOAT; + BEGIN + X := 16#F.FF#e+2; + + IF (X /= 4095.0) THEN + FAILED("INCORRECT HANDLING OF LOWER CASE E " & + "IN BASED FLOATING POINT LITERALS"); + END IF; + END; + + + -- Fixed Point Literal + DECLARE + TYPE FIXED IS DELTA 0.1 RANGE 0.0 .. 300.0; + X : FIXED; + BEGIN + X := 16#F.F#e1; + + IF (X /= 255.0) THEN + FAILED("INCORRECT HANDLING OF LOWER CASE E " & + "IN BASED FIXED POINT LITERALS"); + END IF; + END; + + RESULT; + + END C24002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- C24003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LEADING ZEROES IN INTEGRAL PARTS OF INTEGER LITERALS + -- ARE IGNORED. + + -- JRK 12/12/79 + -- JRK 12/16/80 + -- TBN 10/16/85 RENAMED FROM C24003A.TST AND FIXED LINE LENGTH. + -- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST' + -- TO '.ADA'. + + WITH REPORT; + PROCEDURE C24003A IS + + USE REPORT; + + BEGIN + TEST ("C24003A", "LEADING ZEROES IN INTEGER LITERALS"); + + IF 0000000000000000000000000000000000000000247 /= 247 THEN + FAILED ("LEADING ZEROES IN INTEGER LITERALS NOT " & + "IGNORED"); + END IF; + + IF 35E00000000000000000000000000000000000000001 /= 350 THEN + FAILED ("LEADING ZEROES IN EXPONENTS NOT IGNORED"); + END IF; + + IF 000000000000000000000000000000000000000016#FF# /= 255 THEN + FAILED ("LEADING ZEROES IN BASES NOT IGNORED"); + END IF; + + IF 16#0000000000000000000000000000000000000000FF# /= 255 THEN + FAILED ("LEADING ZEROES IN BASED INTEGER LITERALS " & + "NOT IGNORED"); + END IF; + + RESULT; + END C24003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C24003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LEADING ZEROES IN INTEGRAL PARTS AND TRAILING ZEROES IN + -- FRACTIONAL PARTS OF FLOATING POINT LITERALS ARE IGNORED. + + -- JRK 12/12/79 + -- JRK 12/16/80 + -- TBN 10/21/85 RENAMED FROM C24003B.TST AND FIXED LINE LENGTH. + -- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST' + -- TO '.ADA'. + + WITH REPORT; + PROCEDURE C24003B IS + + USE REPORT; + + FL : FLOAT := 69.0E1; + + BEGIN + TEST ("C24003B", "LEADING/TRAILING ZEROES IN " & + "FLOATING POINT LITERALS"); + + IF 000000000000000000000000000000000000000069.0E1 /= FL THEN + FAILED ("LEADING ZEROES IN INTEGRAL PART OF FLOATING " & + "POINT LITERAL NOT IGNORED"); + END IF; + + IF 69.0000000000000000000000000000000000000000E1 /= FL THEN + -- MIGHT RAISE NUMERIC_ERROR AT COMPILE-TIME. + FAILED ("TRAILING ZEROES IN FRACTIONAL PART OF " & + "FLOATING POINT LITERAL NOT IGNORED"); + END IF; + + IF 0000000000000000000000000000000000000000690.00000 /= FL THEN + FAILED ("LEADING/TRAILING ZEROES IN MANTISSA OF " & + "FLOATING POINT LITERAL NOT IGNORED"); + END IF; + + IF 69.0E00000000000000000000000000000000000000001 /= FL THEN + FAILED ("LEADING ZEROES IN EXPONENT OF FLOATING " & + "POINT LITERAL NOT IGNORED"); + END IF; + + IF 16#00000000000000000000000000000000000000002B.2#E1 /= FL THEN + FAILED ("LEADING ZEROES IN BASED FLOATING POINT " & + "LITERAL NOT IGNORED"); + END IF; + + IF 16#2B.20000000000000000000000000000000000000000#E1 /= FL THEN + FAILED ("TRAILING ZEROES IN BASED FLOATING POINT " & + "LITERAL NOT IGNORED"); + END IF; + + RESULT; + END C24003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24003c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24003c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C24003C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LEADING ZEROES IN INTEGRAL PARTS AND TRAILING ZEROES IN + -- FRACTIONAL PARTS OF FIXED POINT LITERALS ARE IGNORED. + + -- JRK 12/12/79 + -- JRK 12/16/80 + -- TBN 10/21/85 RENAMED FROM C24003C.TST AND FIXED LINE LENGTH. + -- DTN 11/12/91 DELETED SUBPART (B). CHANGED EXTENSION FROM '.TST' + -- TO '.ADA'. + + WITH REPORT; + PROCEDURE C24003C IS + + USE REPORT; + + TYPE FIXED IS DELTA 1.0 RANGE 0.0 .. 1000.0; + FX : FIXED := 69.0E1; + + BEGIN + + TEST ("C24003C", "LEADING/TRAILING ZEROES IN " & + "FIXED POINT LITERALS"); + + IF 000000000000000000000000000000000000000069.0E1 /= FX THEN + FAILED ("LEADING ZEROES IN INTEGRAL PART OF FIXED " & + "POINT LITERAL NOT IGNORED"); + END IF; + + IF 69.0000000000000000000000000000000000000000E1 /= FX THEN + -- MIGHT RAISE NUMERIC_ERROR AT COMPILE-TIME. + FAILED ("TRAILING ZEROES IN FRACTIONAL PART OF " & + "FIXED POINT LITERAL NOT IGNORED"); + END IF; + + IF 0000000000000000000000000000000000000000690.00000 /= FX THEN + FAILED ("LEADING/TRAILING ZEROES IN MANTISSA OF " & + "FIXED POINT LITERAL NOT IGNORED"); + END IF; + + IF 69.0E00000000000000000000000000000000000000001 /= FX THEN + FAILED ("LEADING ZEROES IN EXPONENT OF FIXED " & + "POINT LITERAL NOT IGNORED"); + END IF; + + IF 16#00000000000000000000000000000000000000002B.2#E1 /= FX THEN + FAILED ("LEADING ZEROES IN BASED FIXED POINT " & + "LITERAL NOT IGNORED"); + END IF; + + IF 16#2B.20000000000000000000000000000000000000000#E1 /= FX THEN + FAILED ("TRAILING ZEROES IN BASED FIXED POINT " & + "LITERAL NOT IGNORED"); + END IF; + + RESULT; + END C24003C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24106a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C24106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNDERSCORE CHARACTERS ARE PERMITTED IN ANY PART OF + -- A NON-BASED DECIMAL LITERAL. + + -- HISTORY: + -- DHH 01/19/88 CREATED ORIGINAL TEST + + WITH REPORT; USE REPORT; + + PROCEDURE C24106A IS + + BEGIN + TEST("C24106A", "CHECK THAT UNDERSCORE CHARACTERS " & + "ARE PERMITTED IN ANY PART OF " & + "A NON-BASED DECIMAL LITERAL"); + + IF 1.2_3_4_5_6 /= 1.23456 THEN + FAILED("UNDERSCORES NOT PERMITTED IN FRACTIONAL PART " & + "OF A NON_BASED LITERAL"); + END IF; + IF 1_2_3_4_5.6 /= 12345.6 THEN + FAILED("UNDERSCORES NOT PERMITTED IN INTEGRAL PART " & + "OF A NON_BASED LITERAL"); + END IF; + IF 0.12E1_2 /= 0.12E12 THEN + FAILED("UNDERSCORES NOT PERMITTED IN EXPONENT PART " & + "OF A NON_BASED LITERAL"); + END IF; + IF 1_2_3_4_5 /= 12345 THEN + FAILED("UNDERSCORES NOT PERMITTED IN INTEGRAL PART " & + "OF A NON_BASED LITERAL INTEGER"); + END IF; + IF 0E1_0 /= 0 THEN + FAILED("UNDERSCORES NOT PERMITTED IN EXPONENT PART " & + "OF A NON_BASED LITERAL INTEGER"); + END IF; + + RESULT; + END C24106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24202d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24202d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24202d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24202d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C24202D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NON-CONSECUTIVE UNDERSCORES ARE PERMITTED + -- IN EVERY PART OF BASED INTEGER, FLOATING POINT, AND FIXED POINT LITERALS. + + -- WMC 03/16/92 CONSOLIDATION OF C24202A.ADA, C24202B.ADA, C24202C.ADA + + WITH REPORT; + + PROCEDURE C24202D IS + + USE REPORT; + + TYPE FIXED1 IS DELTA 2.0**(-6) RANGE 0.0 .. 10.0; + + I1, I2 : INTEGER; + F1, F2, F3 : FLOAT; + F4, F5 : FIXED1; + + BEGIN + TEST("C24202D", "UNDERSCORES ALLOWED IN NUMERIC LITERALS"); + + I1 := 12_3; + I2 := 16#D#E0_1; + + IF (I1 /= 123) OR (I2 /= 16#D#E01) THEN + FAILED("UNDERSCORES IN INTEGER LITERALS NOT HANDLED CORRECTLY"); + END IF; + + + F1 := 1.2_5E1; + F2 := 8#1_3.5#; + F3 := 8#3.4#E1_1; + + IF (F1 /= 1.25E1) OR (F2 /= 8#13.5#) OR (F3 /= 8#3.4#E11) THEN + FAILED("UNDERSCORES IN FLOATING POINT LITERALS NOT " & + "HANDLED CORRECTLY"); + END IF; + + + F4 := 1_6#1.A#; + F5 := 8#2.3_7#; + + IF (F4 /= 16#1.A#) OR (F5 /= 8#2.37#) THEN + FAILED("UNDERSCORES IN FIXED POINT LITERALS NOT " & + "HANDLED CORRECTLY"); + END IF; + + RESULT; + + END C24202D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24203a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C24203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BASED INTEGER LITERALS WITH BASES 2 THROUGH 16 ALL + -- YIELD CORRECT VALUES. + + -- JRK 12/12/79 + -- JRK 10/27/80 + -- JWC 6/28/85 RENAMED FROM C24103A.ADA + + WITH REPORT; + PROCEDURE C24203A IS + + USE REPORT; + + I : INTEGER := 200; + + BEGIN + TEST ("C24203A", "VALUES OF BASED INTEGER LITERALS"); + + IF 2#11# /= 3 THEN + FAILED ("INCORRECT VALUE FOR BASE 2 INTEGER"); + END IF; + + IF 3#22# /= 8 THEN + FAILED ("INCORRECT VALUE FOR BASE 3 INTEGER"); + END IF; + + IF 4#33# /= 15 THEN + FAILED ("INCORRECT VALUE FOR BASE 4 INTEGER"); + END IF; + + IF 5#44# /= 24 THEN + FAILED ("INCORRECT VALUE FOR BASE 5 INTEGER"); + END IF; + + IF 6#55# /= 35 THEN + FAILED ("INCORRECT VALUE FOR BASE 6 INTEGER"); + END IF; + + IF 7#66# /= 48 THEN + FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER"); + END IF; + + IF 8#77# /= 63 THEN + FAILED ("INCORRECT VALUE FOR BASE 8 INTEGER"); + END IF; + + IF 9#88# /= 80 THEN + FAILED ("INCORRECT VALUE FOR BASE 9 INTEGER"); + END IF; + + IF 10#99# /= 99 THEN + FAILED ("INCORRECT VALUE FOR BASE 10 INTEGER"); + END IF; + + IF 11#AA# /= 120 THEN + FAILED ("INCORRECT VALUE FOR BASE 11 INTEGER"); + END IF; + + IF 12#BB# /= 143 THEN + FAILED ("INCORRECT VALUE FOR BASE 12 INTEGER"); + END IF; + + IF 13#CC# /= 168 THEN + FAILED ("INCORRECT VALUE FOR BASE 13 INTEGER"); + END IF; + + IF 14#DD# /= 195 THEN + FAILED ("INCORRECT VALUE FOR BASE 14 INTEGER"); + END IF; + + IF 15#EE# /= 224 THEN + FAILED ("INCORRECT VALUE FOR BASE 15 INTEGER"); + END IF; + + IF 16#FF# /= 255 THEN + FAILED ("INCORRECT VALUE FOR BASE 16 INTEGER"); + END IF; + + ---------------------------------------- + + IF 7#66#E1 /= 336 THEN + FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER " & + "WITH EXPONENT"); + END IF; + + RESULT; + END C24203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24203b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24203b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24203b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24203b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C24203B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT BASED REAL LITERALS WITH BASES 2 THROUGH 16 ALL + -- YIELD CORRECT VALUES. + + -- THIS TEST USES MODEL NUMBERS OF DIGITS 6. + + -- HISTORY: + -- DHH 06/15/88 CREATED ORIGINAL TEST. + -- DTN 11/30/95 REMOVED CONFORMANCE CHECKS WHERE RULES RELAXED. + + WITH REPORT; USE REPORT; + PROCEDURE C24203B IS + + TYPE CHECK IS DIGITS 6; + + BEGIN + TEST("C24203B", "CHECK THAT BASED REAL LITERALS WITH BASES " & + "2 THROUGH 16 ALL YIELD CORRECT VALUES"); + + IF + 2#0.0000000000000000000000000000000000000000000000000000000000001# + /= 2.0 ** (-61) THEN + FAILED ("INCORRECT VALUE FOR BASE 2 REAL LITERAL"); + END IF; + + IF 3#0.00000000001# < + ((2.0 ** (-18)) + (251558.0 * (2.0 ** (-37)))) OR + 3#0.00000000001# > + ((2.0 ** (-18)) + (251559.0 * (2.0 ** (-37)))) THEN + FAILED ("INCORRECT VALUE FOR BASE 3 REAL LITERAL"); + END IF; + + IF 4#13333333.213# /= 32767.609375 THEN + FAILED ("INCORRECT VALUE FOR BASE 4 REAL LITERAL"); + END IF; + + IF 5#2021444.4241121# < 32749.90625 OR + 5#2021444.4241121# > 32749.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 5 REAL LITERAL"); + END IF; + + IF 6#411355.531043# /= 32759.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 6 REAL LITERAL"); + END IF; + + IF 7#164366.625344# < 32780.90625 OR + 7#164366.625344# > 32780.9375 THEN + FAILED ("INCORRECT VALUE FOR BASE 7 REAL LITERAL"); + END IF; + + IF 8#77777.07# /= 32767.109375 THEN + FAILED ("INCORRECT VALUE FOR BASE 8 REAL LITERAL"); + END IF; + + IF 9#48888.820314# < 32804.90625 OR + 9#48888.820314# > 32804.9375 THEN + FAILED ("INCORRECT VALUE FOR BASE 9 REAL LITERAL"); + END IF; + + IF 10#32767.921875# /= 32767.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 10 REAL LITERAL"); + END IF; + + IF 11#2267A.A06682# < 32757.90625 OR + 11#2267A.A06682# > 32757.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 11 REAL LITERAL"); + END IF; + + IF 12#16B5B.B09# /= 32759.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 12 REAL LITERAL"); + END IF; + + IF 13#11B9C.BB616# < 32746.90625 OR + 13#11B9C.BB616# > 32746.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 13 REAL LITERAL"); + END IF; + + IF 14#BD1D.CC98A7# /= 32759.921875 THEN + FAILED ("INCORRECT VALUE FOR BASE 14 REAL LITERAL"); + END IF; + + IF 15#3D28188D45881111111111.0# < + (((2.0 ** 21) -2.0) * (2.0 ** 63)) THEN + FAILED ("INCORRECT VALUE FOR BASE 15 REAL LITERAL"); + END IF; + + + RESULT; + END C24203B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24207a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24207a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24207a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24207a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C24207A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LETTERS IN A BASED LITERAL MAY APPEAR IN UPPER OR LOWER + -- CASE. + + -- TBN 2/28/86 + + WITH REPORT; USE REPORT; + PROCEDURE C24207A IS + + TYPE FLOAT IS DIGITS 5; + INT_1 : INTEGER := 15#AbC# ; + INT_2 : INTEGER := 15#aBc# ; + FLO_1 : FLOAT := 16#FeD.C#e1; + FLO_2 : FLOAT := 16#fEd.c#E1; + + BEGIN + TEST("C24207A", "CHECK THAT LETTERS IN A BASED LITERAL MAY " & + "APPEAR IN UPPER OR LOWER CASE"); + + IF INT_1 /= INT_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 1"); + END IF; + + IF FLO_1 /= FLO_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 2"); + END IF; + + INT_1 := 14#aBc#E1; + INT_2 := 14#AbC#e1; + FLO_1 := 16#CdEf.aB#E0; + FLO_2 := 16#cDeF.Ab#e0; + + IF INT_1 /= INT_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 3"); + END IF; + + IF FLO_1 /= FLO_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 4"); + END IF; + + RESULT; + END C24207A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24211a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24211a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c24211a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c24211a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C24211A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LEGAL FORMS INVOLVING A DIGIT FOLLOWED BY A COLON ARE + -- CORRECTLY ANALYZED USING A TWO CHARACTER LOOK-AHEAD. + + -- HISTORY: + -- DHH 01/19/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C24211A IS + + TYPE FIXED IS DELTA 0.0125 RANGE -1.0 .. 100.0; + + A : INTEGER RANGE 0 .. 2:10::= 1; + B : INTEGER RANGE 0 .. 2#10#:= 1; + X : FIXED RANGE 0.0 .. 16:3.0::= 1.0; + Y : FIXED RANGE 0.0 .. 16#3.0#:= 1.0; + IN2 : INTEGER; + BOOL : BOOLEAN:=3:10:=3:10:; + + BEGIN + + TEST("C24211A", "CHECK THAT LEGAL FORMS INVOLVING A DIGIT " & + "FOLLOWED BY A COLON ARE CORRECTLY ANALYZED " & + "USING A TWO CHARACTER LOOK-AHEAD"); + + IF IDENT_INT(A) /= B THEN + FAILED("CALCULATIONS OF BASED INTEGER LITERALS WHEN " & + "REPRESENTED BY SHARPS DO NOT MATCH CALCULATIONS " & + "OF BASED INTEGER LITERALS REPRESENTED BY COLONS"); + END IF; + A := A + 1; + + + IF EQUAL(3,3) THEN + Y := X + Y; + ELSE + Y := X - Y; + END IF; + + IF (2 * X) = Y THEN + NULL; + ELSE + FAILED("CALCULATIONS OF BASED REAL LITERALS WHEN " & + "REPRESENTED BY SHARPS DO NOT MATCH CALCULATIONS " & + "OF BASED REAL LITERALS REPRESENTED BY COLONS"); + END IF; + IF NOT BOOL THEN + FAILED("BOOLEAN VALUE BASED ON REAL LITERAL WAS CALCULATED " & + "INCORRECTLY"); + IN2:=2:10:; + ELSE + BOOL := FALSE; + IN2:=3:10:; + END IF; + IF BOOL THEN + A := A + 1; + ELSE + A := A - 1; + END IF; + + RESULT; + END C24211A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c250001.aw gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c250001.aw *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c250001.aw 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c250001.aw 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- C250001.AW + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that wide character literals are supported. + -- Check that wide character string literals are supported. + -- + -- TEST DESCRIPTION: + -- This test utilizes the brackets scheme for representing wide character + -- values in transportable 7 bit ASCII as proposed by Robert Dewar; + -- this test defines Wide_Character and Wide_String objects, and assigns + -- and tests several sample values. + -- + -- SPECIAL REQUIREMENTS: + -- + -- This file must be preprocessed before it can be executed as a test. + -- + -- This test requires that all occurrences of the bracket escape + -- representation for wide characters be replaced, as appropriate, with + -- the corresponding wide character as represented by the implementation. + -- + -- Characters above ASCII.Del are represented by an 8 character sequence: + -- + -- ["xxxx"] + -- + -- where the character code represented is specified by four hexadecimal + -- digits, () upper case. For example the wide character with the + -- code 16#ABCD# is represented by the eight character sequence: + -- + -- ["ABCD"] + -- + -- The following function documents the translation algorithm: + -- + -- function To_Wide( S:String ) return Wide_character is + -- Numerical : Natural := 0; + -- type Xlate is array(Character range '0'..'F') of Natural; + -- Xlation : Xlate + -- := ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4, + -- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9, + -- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14, + -- 'F' => 15, others => 0 ); + -- begin + -- for I in S'Range loop + -- Numerical := Numerical * 16 + Xlation(S(I)); + -- end loop; + -- return Wide_Character'Val(Numerical); -- the returned value is + -- implementation dependent + -- exception + -- when Constraint_Error => raise; + -- end To_Wide; + -- + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial .Aversion + -- 11 APR 96 SAIC Minor robustness changes for 2.1 + -- 12 NOV 96 SAIC Changed file extension to .AW + -- + --! + + ----------------------------------------------------------------- C250001_0 + + package C250001_0 is + + -- The wide characters used in this test are sequential starting with + -- the character '["4F42"]' 16#0F42# + + Four_Eff_Four_Two : constant Wide_Character := '["4F42"]'; + + Four_Eff_4_3_Through_9 : constant Wide_String := + "["4F43"]["4F44"]["4F45"]["4F46"]["4F47"]["4F48"]["4F49"]"; + + Four_Eff_A_B : constant Wide_String := "["4F4A"]["4F4B"]"; + + end C250001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- no package body C250001_0 is required or allowed + + ------------------------------------------------------------------- C250001 + + with Report; + with C250001_0; + with Ada.Tags; + + procedure C250001 is + use C250001_0; + + function Hex( N: Natural ) return String is + S : String := "xxxx"; + T : String := "0123456789ABCDEF"; + V : Natural := N; + begin + for I in reverse 1..4 loop + S(I) := T(V rem 16 +1); + V := V / 16; + end loop; + return S; + end Hex; + + procedure Match( Check : Wide_Character; Matching : Natural ) is + begin + if Wide_Character'Pos( Check ) /= Matching then + Report.Failed( "Didn't match for " & Hex(Matching) ); + end if; + end Match; + + type Value_List is array(Positive range <>) of Natural; + + procedure Match( Check : Wide_String; Matching : Value_List ) is + begin + if Check'Length /= Matching'Length then + Report.Failed( "Check'Length /= Matching'Length" ); + else + for I in Check'Range loop + Match( Check(I), Matching(I) ); + end loop; + end if; + end Match; + + begin -- Main test procedure. + + Report.Test ("C250001", "Check that wide character literals " & + "are supported. Check that wide character " & + "string literals are supported." ); + + Match( Four_Eff_Four_Two, 16#4F42# ); + + Match(Four_Eff_4_3_Through_9, + (16#4F43#,16#4F44#,16#4F45#,16#4F46#,16#4F47#,16#4F48#,16#4F49#) ); + + -- check catenations + + Match( Four_Eff_Four_Two & Four_Eff_Four_Two, (16#4F42#,16#4F42#) ); + + Match( Four_Eff_Four_Two & Four_Eff_A_B, (16#4F42#,16#4F4A#,16#4F4B#) ); + + Match( Four_Eff_A_B & Four_Eff_Four_Two, (16#4F4A#,16#4F4B#,16#4F42#) ); + + Match( Four_Eff_A_B & Four_Eff_A_B, + (16#4F4A#,16#4F4B#,16#4F4A#,16#4F4B#) ); + + Report.Result; + + end C250001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c250002.aw gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c250002.aw *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c250002.aw 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c250002.aw 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- C250002.AW + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that characters in Latin-1 above ASCII.Del can be used in + -- identifiers, character literals and strings. + -- + -- TEST DESCRIPTION: + -- This test utilizes the brackets scheme for representing Latin-1 + -- character values in transportable 7 bit ASCII as proposed by + -- Robert Dewar; this test defines Character and String objects, + -- assigns and tests several sample values. Several Identifiers + -- used in this test also include Characters via the bracket escape + -- sequence scheme. + -- + -- Note that C250001 checks Wide_Characters and Wide_Strings. + -- + -- SPECIAL REQUIREMENTS: + -- + -- This file must be preprocessed before it can be executed as a test. + -- + -- This test requires that all occurrences of the bracket escaped + -- characters be replaced with the corresponding 8 bit character. + -- + -- Characters above ASCII.Del are represented by a 6 character sequence: + -- + -- ["xx"] + -- + -- where the character code represented is specified by two hexadecimal + -- digits () upper case. For example the Latin-1 character with the + -- code 16#AB# is represented by the six character sequence: + -- + -- ["AB"] + -- + -- None of the values used in this test should be interpreted as + -- a control character. + -- + -- The following function documents the translation algorithm: + -- + -- function To_Char( S:String ) return Character is + -- Numerical : Natural := 0; + -- type Xlate is array(Character range '0'..'F') of Natural; + -- Xlation : Xlate + -- := ('0' => 0, '1' => 1, '2' => 2, '3' => 3, '4' => 4, + -- '5' => 5, '6' => 6, '7' => 7, '8' => 8, '9' => 9, + -- 'A' => 10, 'B' => 11, 'C' => 12, 'D' => 13, 'E' => 14, + -- 'F' => 15, others => 0 ); + -- begin + -- for I in S'Range loop + -- Numerical := Numerical * 16 + Xlation(S(I)); + -- end loop; + -- return Character'Val(Numerical); + -- end To_Char; + -- + -- + -- CHANGE HISTORY: + -- 10 JAN 96 SAIC Initial version + -- 12 NOV 96 SAIC Changed file extension to .AW + -- + --! + + ----------------------------------------------------------------- C250002_0 + + package C250002_0 is + + -- The extended characters used in this test start with + -- the character '["A1"]' 16#A1# and increase from there + + type Tagged_["C0"]_Id is tagged record + Length, Width: Natural; + end record; + + X_Char_A2 : constant Character := '["A2"]'; + + X_Char_A3_Through_A9 : constant String := + "["A3"]["A4"]["A5"]["A6"]["A7"]["A8"]["A9"]"; + + X_Char_AA_AB : constant String := "["AA"]["AB"]"; + + end C250002_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- no package body C250002_0 is required or allowed + + ----------------------------------------------------------------- C250002_X + + with Ada.Characters.Latin_1; + package C250002_["C1"] is + + type Enum is ( Item, 'A', '["AD"]', AE_["C6"]["E6"]_ae, + '["2D"]', '["FF"]' ); + + task type C2_["C2"] is + entry C2_["C3"]; + end C2_["C2"]; + + end C250002_["C1"]; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C250002_["C1"] is + + task body C2_["C2"] is + begin + accept C2_["C3"]; + end C2_["C2"]; + + end C250002_["C1"]; + + ------------------------------------------------------------------- C250002 + + with Report; + with C250002_0; + with C250002_["C1"]; + + with Ada.Tags; + + procedure C250002 is + use C250002_0; + + My_Task: C250002_["C1"].C2_["C2"]; + + function Hex( N: Natural ) return String is + S : String := "xx"; + T : String := "0123456789ABCDEF"; + begin + S(1) := T(N / 16 +1); + S(2) := T(N mod 16 +1); + return S; + end Hex; + + procedure Match( Check : Character; Matching : Natural ) is + begin + if Check /= Character'Val( Matching ) then + Report.Failed( "Didn't match for " & Hex(Matching) ); + end if; + end Match; + + type Value_List is array(Positive range <>) of Natural; + + procedure Match( Check : String; Matching : Value_List ) is + begin + if Check'Length /= Matching'Length then + Report.Failed( "Check'Length /= Matching'Length" ); + else + for I in Check'Range loop + Match( Check(I), Matching(I - Check'First + Matching'First) ); + end loop; + end if; + end Match; + + TC_Count : Natural := 0; + + begin -- Main test procedure. + + Report.Test ("C250002", "Check that characters above ASCII.Del can be " & + "used in identifiers, character literals and " & + "strings" ); + + Report.Comment( Ada.Tags.Expanded_Name(Tagged_["C0"]_Id'Tag) ); + + for Specials in C250002_["C1"].Enum loop + TC_Count := TC_Count +1; + end loop; + + if TC_Count /= 6 then + Report.Failed("Expected 6 literals in Enum"); + end if; + + Match( X_Char_A2, 16#A2# ); + + Match(X_Char_A3_Through_A9, + (16#A3#,16#A4#,16#A5#,16#A6#,16#A7#,16#A8#,16#A9#) ); + + -- check catenations + + Match( X_Char_A2 & X_Char_A2, (16#A2#,16#A2#) ); + + Match( X_Char_A2 & X_Char_AA_AB, (16#A2#,16#AA#,16#AB#) ); + + Match( X_Char_AA_AB & X_Char_A2, (16#AA#,16#AB#,16#A2#) ); + + Match( X_Char_AA_AB & X_Char_AA_AB, + (16#AA#,16#AB#,16#AA#,16#AB#) ); + + My_Task.C2_["C3"]; + + Report.Result; + + end C250002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c25001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c25001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c25001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c25001a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,211 ---- + -- C25001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL CHARACTER LITERALS CAN BE WRITTEN. + + -- CASE A: THE BASIC CHARACTER SET. + + -- TBN 3/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C25001A IS + + BEGIN + TEST ("C25001A", "CHECK THAT EACH CHARACTER IN THE BASIC " & + "CHARACTER SET CAN BE WRITTEN"); + + IF CHARACTER'POS('A') /= 65 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'A'"); + END IF; + IF CHARACTER'POS('B') /= 66 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'B'"); + END IF; + IF CHARACTER'POS('C') /= 67 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'C'"); + END IF; + IF CHARACTER'POS('D') /= 68 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'D'"); + END IF; + IF CHARACTER'POS('E') /= 69 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'E'"); + END IF; + IF CHARACTER'POS('F') /= 70 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'F'"); + END IF; + IF CHARACTER'POS('G') /= 71 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'G'"); + END IF; + IF CHARACTER'POS('H') /= 72 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'H'"); + END IF; + IF CHARACTER'POS('I') /= 73 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'I'"); + END IF; + IF CHARACTER'POS('J') /= 74 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'J'"); + END IF; + IF CHARACTER'POS('K') /= 75 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'K'"); + END IF; + IF CHARACTER'POS('L') /= 76 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'L'"); + END IF; + IF CHARACTER'POS('M') /= 77 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'M'"); + END IF; + IF CHARACTER'POS('N') /= 78 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'N'"); + END IF; + IF CHARACTER'POS('O') /= 79 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'O'"); + END IF; + IF CHARACTER'POS('P') /= 80 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'P'"); + END IF; + IF CHARACTER'POS('Q') /= 81 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'Q'"); + END IF; + IF CHARACTER'POS('R') /= 82 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'R'"); + END IF; + IF CHARACTER'POS('S') /= 83 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'S'"); + END IF; + IF CHARACTER'POS('T') /= 84 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'T'"); + END IF; + IF CHARACTER'POS('U') /= 85 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'U'"); + END IF; + IF CHARACTER'POS('V') /= 86 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'V'"); + END IF; + IF CHARACTER'POS('W') /= 87 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'W'"); + END IF; + IF CHARACTER'POS('X') /= 88 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'X'"); + END IF; + IF CHARACTER'POS('Y') /= 89 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'Y'"); + END IF; + IF CHARACTER'POS('Z') /= 90 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'Z'"); + END IF; + + IF CHARACTER'POS('0') /= 48 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '0'"); + END IF; + IF CHARACTER'POS('1') /= 49 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '1'"); + END IF; + IF CHARACTER'POS('2') /= 50 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '2'"); + END IF; + IF CHARACTER'POS('3') /= 51 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '3'"); + END IF; + IF CHARACTER'POS('4') /= 52 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '4'"); + END IF; + IF CHARACTER'POS('5') /= 53 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '5'"); + END IF; + IF CHARACTER'POS('6') /= 54 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '6'"); + END IF; + IF CHARACTER'POS('7') /= 55 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '7'"); + END IF; + IF CHARACTER'POS('8') /= 56 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '8'"); + END IF; + IF CHARACTER'POS('9') /= 57 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '9'"); + END IF; + + IF CHARACTER'POS('"') /= 34 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '""'"); + END IF; + IF CHARACTER'POS('#') /= 35 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '#'"); + END IF; + IF CHARACTER'POS('&') /= 38 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '&'"); + END IF; + IF CHARACTER'POS(''') /= 39 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '''"); + END IF; + IF CHARACTER'POS('(') /= 40 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '('"); + END IF; + IF CHARACTER'POS(')') /= 41 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ')'"); + END IF; + IF CHARACTER'POS('*') /= 42 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '*'"); + END IF; + IF CHARACTER'POS('+') /= 43 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '+'"); + END IF; + IF CHARACTER'POS(',') /= 44 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ','"); + END IF; + IF CHARACTER'POS('-') /= 45 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '-'"); + END IF; + IF CHARACTER'POS('.') /= 46 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '.'"); + END IF; + IF CHARACTER'POS('/') /= 47 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '/'"); + END IF; + IF CHARACTER'POS(':') /= 58 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ':'"); + END IF; + IF CHARACTER'POS(';') /= 59 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ';'"); + END IF; + IF CHARACTER'POS('<') /= 60 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '<'"); + END IF; + IF CHARACTER'POS('=') /= 61 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '='"); + END IF; + IF CHARACTER'POS('>') /= 62 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '>'"); + END IF; + IF CHARACTER'POS('_') /= 95 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '_'"); + END IF; + IF CHARACTER'POS('|') /= 124 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '|'"); + END IF; + + IF CHARACTER'POS(' ') /= 32 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ' '"); + END IF; + + RESULT; + END C25001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c25001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c25001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c25001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c25001b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C25001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL CHARACTER LITERALS CAN BE WRITTEN. + + -- CASE B: THE LOWER CASE LETTERS AND THE OTHER + -- SPECIAL CHARACTERS. + + -- TBN 8/1/86 + + WITH REPORT; USE REPORT; + PROCEDURE C25001B IS + + BEGIN + TEST ("C25001B", "CHECK THAT EACH CHARACTER IN THE LOWER CASE " & + "LETTERS AND THE OTHER SPECIAL CHARACTERS CAN " & + "BE WRITTEN"); + + IF CHARACTER'POS('a') /= 97 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'a'"); + END IF; + IF CHARACTER'POS('b') /= 98 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'b'"); + END IF; + IF CHARACTER'POS('c') /= 99 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'c'"); + END IF; + IF CHARACTER'POS('d') /= 100 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'd'"); + END IF; + IF CHARACTER'POS('e') /= 101 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'e'"); + END IF; + IF CHARACTER'POS('f') /= 102 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'f'"); + END IF; + IF CHARACTER'POS('g') /= 103 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'g'"); + END IF; + IF CHARACTER'POS('h') /= 104 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'h'"); + END IF; + IF CHARACTER'POS('i') /= 105 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'i'"); + END IF; + IF CHARACTER'POS('j') /= 106 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'j'"); + END IF; + IF CHARACTER'POS('k') /= 107 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'k'"); + END IF; + IF CHARACTER'POS('l') /= 108 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'l'"); + END IF; + IF CHARACTER'POS('m') /= 109 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'm'"); + END IF; + IF CHARACTER'POS('n') /= 110 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'n'"); + END IF; + IF CHARACTER'POS('o') /= 111 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'o'"); + END IF; + IF CHARACTER'POS('p') /= 112 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'p'"); + END IF; + IF CHARACTER'POS('q') /= 113 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'q'"); + END IF; + IF CHARACTER'POS('r') /= 114 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'r'"); + END IF; + IF CHARACTER'POS('s') /= 115 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 's'"); + END IF; + IF CHARACTER'POS('t') /= 116 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 't'"); + END IF; + IF CHARACTER'POS('u') /= 117 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'u'"); + END IF; + IF CHARACTER'POS('v') /= 118 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'v'"); + END IF; + IF CHARACTER'POS('w') /= 119 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'w'"); + END IF; + IF CHARACTER'POS('x') /= 120 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'x'"); + END IF; + IF CHARACTER'POS('y') /= 121 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'y'"); + END IF; + IF CHARACTER'POS('z') /= 122 THEN + FAILED ("INCORRECT POSITION NUMBER FOR 'z'"); + END IF; + + IF CHARACTER'POS('!') /= 33 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '!'"); + END IF; + IF CHARACTER'POS('$') /= 36 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '$'"); + END IF; + IF CHARACTER'POS('%') /= 37 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '%'"); + END IF; + IF CHARACTER'POS('?') /= 63 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '?'"); + END IF; + IF CHARACTER'POS('@') /= 64 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '@'"); + END IF; + IF CHARACTER'POS('[') /= 91 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '['"); + END IF; + IF CHARACTER'POS('\') /= 92 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '\'"); + END IF; + IF CHARACTER'POS(']') /= 93 THEN + FAILED ("INCORRECT POSITION NUMBER FOR ']'"); + END IF; + IF CHARACTER'POS('^') /= 94 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '^'"); + END IF; + IF CHARACTER'POS('`') /= 96 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '`'"); + END IF; + IF CHARACTER'POS('{') /= 123 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '{'"); + END IF; + IF CHARACTER'POS('}') /= 125 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '}'"); + END IF; + IF CHARACTER'POS('~') /= 126 THEN + FAILED ("INCORRECT POSITION NUMBER FOR '~'"); + END IF; + + RESULT; + END C25001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c26006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c26006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c26006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c26006a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- C26006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL ASCII CHARACTERS CAN APPEAR IN THE MIDDLE OF A STRING + -- (I.E., NONE ARE USED IN THE INTERNAL REPRESENTATION TO TERMINATE THE + -- STRING). + + -- JRK 12/12/79 + + WITH REPORT; + PROCEDURE C26006A IS + + USE REPORT; + + S1 : STRING (1..3) := "A 1"; + S2 : STRING (1..3) := "A 2"; + + BEGIN + TEST ("C26006A", "ALL ASCII CHARACTERS CAN APPEAR IN MIDDLE " & + "OF STRINGS"); + + FOR C IN CHARACTER'FIRST .. CHARACTER'LAST LOOP + S1 (2) := C; + S2 (2) := C; + IF S1 = S2 THEN + FAILED (CHARACTER'IMAGE(C) & " TERMINATED A " & + "STRING = COMPARISON"); + END IF; + END LOOP; + + RESULT; + END C26006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c26008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c26008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c26008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c26008a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- C26008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UPPER AND LOWER CASE LETTERS ARE DISTINCT WITHIN STRING + -- LITERALS. + + -- JRK 12/12/79 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; + PROCEDURE C26008A IS + + USE REPORT; + + BEGIN + TEST ("C26008A", "UPPER/LOWER CASE ARE DISTINCT IN STRING " & + "LITERALS"); + + IF CHARACTER'('a') = 'A' THEN + FAILED ("LOWER CASE NOT DISTINCT FROM UPPER IN " & + "CHARACTER LITERALS"); + END IF; + + IF STRING'("abcde") = "ABCDE" THEN + FAILED ("LOWER CASE NOT DISTINCT FROM UPPER IN " & + "STRING LITERALS"); + END IF; + + RESULT; + END C26008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C2A001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NON-CONSECUTIVE UNDERSCORES ARE PERMITTED + -- IN EVERY PART OF A BASED INTEGER LITERAL WHEN SHARPS + -- ARE USED INSTEAD OF COLONS. + + -- INTEGER LITERALS. + + -- DCB 1/24/80 + -- JRK 10/27/80 + -- JBG 5/28/85 + + WITH REPORT; + PROCEDURE C2A001A IS + + USE REPORT; + + I1, I2, I3, I4 : INTEGER; + + BEGIN + TEST("C2A001A", "UNDERSCORES ALLOWED IN BASED INTEGER LITERALS " & + "THAT HAVE COLONS"); + + I1 := 12_3; + I2 := 1_6:D:; + I3 := 2:1011_0101:; + I4 := 16:D:E0_1; + + IF I1 = 123 AND I2 = 16:D: AND I3 = 2:10110101: AND + I4 = 16:D:E01 THEN + NULL; + ELSE + FAILED("UNDERSCORES IN INTEGER LITERALS NOT HANDLED " & + "CORRECTLY"); + END IF; + + RESULT; + END C2A001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C2A001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NON-CONSECUTIVE UNDERSCORES ARE PERMITTED + -- IN EVERY PART OF A BASED FLOATING POINT LITERAL THAT + -- USES COLONS INSTEAD OF SHARPS. + + -- DCB 04/22/80 + -- JRK 10/27/80 + -- JBG 5/28/85 + + WITH REPORT; + PROCEDURE C2A001B IS + + USE REPORT; + + F1, F2, F3, F4, F5 : FLOAT; + + BEGIN + TEST("C2A001B", "UNDERSCORES ALLOWED IN BASED FLOATING POINT " & + "LITERALS THAT HAVE COLONS"); + + F1 := 1.2_5E1; + F2 := 1_6:1.A:; + F3 := 8:1_3.5:; + F4 := 8:2.3_7:; + F5 := 8:3.4:E1_1; + + IF F1 = 1.25E1 AND F2 = 16:1.A: AND F3 = 8:13.5: AND + F4 = 8:2.37: AND F5 = 8:3.4:E11 THEN + NULL; + ELSE + FAILED("UNDERSCORES IN FLOATING POINT LITERALS NOT " & + "HANDLED CORRECTLY"); + END IF; + + RESULT; + END C2A001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a001c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C2A001C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NON-CONSECUTIVE UNDERSCORES ARE PERMITTED + -- IN EVERY PART OF A BASED FIXED POINT LITERAL THAT USES + -- COLONS INSTEAD OF SHARPS. + + -- DCB 04/22/80 + -- JRK 10/27/80 + -- JBG 5/28/85 + + WITH REPORT; + PROCEDURE C2A001C IS + + USE REPORT; + + TYPE FIXED1 IS DELTA 2.0**(-6) RANGE 0.0 .. 10.0; + TYPE FIXED2 IS DELTA 2.0**(-4) RANGE 0.0 .. 100.0; + + F2, F4 : FIXED1; + F1, F3, F5 : FIXED2; + + BEGIN + TEST("C2A001C", "UNDERSCORES ALLOWED IN BASED FIXED POINT " & + "LITERALS THAT USE COLONS"); + + F1 := 1.2_5E1; + F2 := 1_6:1.A:; + F3 := 8:1_3.5:; + F4 := 8:2.3_7:; + F5 := 8:3.4:E0_1; + + IF F1 = 1.25E1 AND F2 = 16:1.A: AND F3 = 8:13.5: AND + F4 = 8:2.37: AND F5 = 8:3.4:E01 THEN + NULL; + ELSE + FAILED("UNDERSCORES IN FIXED POINT LITERALS NOT " & + "HANDLED CORRECTLY"); + END IF; + + RESULT; + END C2A001C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a002a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C2A002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BASED INTEGER LITERALS WITH BASES 2 THROUGH 16 ALL + -- YIELD CORRECT VALUES WHEN COLONS ARE USED INSTEAD OF SHARPS. + + -- JRK 12/12/79 + -- JRK 10/27/80 + -- JBG 5/28/85 + + WITH REPORT; + PROCEDURE C2A002A IS + + USE REPORT; + + I : INTEGER := 200; + + BEGIN + TEST ("C2A002A", "VALUES OF BASED INTEGER LITERALS WITH " & + "COLONS"); + + IF 2:11: /= 3 THEN + FAILED ("INCORRECT VALUE FOR BASE 2 INTEGER"); + END IF; + + IF 3:22: /= 8 THEN + FAILED ("INCORRECT VALUE FOR BASE 3 INTEGER"); + END IF; + + IF 4:33: /= 15 THEN + FAILED ("INCORRECT VALUE FOR BASE 4 INTEGER"); + END IF; + + IF 5:44: /= 24 THEN + FAILED ("INCORRECT VALUE FOR BASE 5 INTEGER"); + END IF; + + IF 6:55: /= 35 THEN + FAILED ("INCORRECT VALUE FOR BASE 6 INTEGER"); + END IF; + + IF 7:66: /= 48 THEN + FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER"); + END IF; + + IF 8:77: /= 63 THEN + FAILED ("INCORRECT VALUE FOR BASE 8 INTEGER"); + END IF; + + IF 9:88: /= 80 THEN + FAILED ("INCORRECT VALUE FOR BASE 9 INTEGER"); + END IF; + + IF 10:99: /= 99 THEN + FAILED ("INCORRECT VALUE FOR BASE 10 INTEGER"); + END IF; + + IF 11:AA: /= 120 THEN + FAILED ("INCORRECT VALUE FOR BASE 11 INTEGER"); + END IF; + + IF 12:BB: /= 143 THEN + FAILED ("INCORRECT VALUE FOR BASE 12 INTEGER"); + END IF; + + IF 13:CC: /= 168 THEN + FAILED ("INCORRECT VALUE FOR BASE 13 INTEGER"); + END IF; + + IF 14:DD: /= 195 THEN + FAILED ("INCORRECT VALUE FOR BASE 14 INTEGER"); + END IF; + + IF 15:EE: /= 224 THEN + FAILED ("INCORRECT VALUE FOR BASE 15 INTEGER"); + END IF; + + IF 16:FF: /= 255 THEN + FAILED ("INCORRECT VALUE FOR BASE 16 INTEGER"); + END IF; + + ---------------------------------------- + + IF 7:66:E1 /= 336 THEN + FAILED ("INCORRECT VALUE FOR BASE 7 INTEGER " & + "WITH EXPONENT"); + END IF; + + RESULT; + END C2A002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a008a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- C2A008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UPPER AND LOWER CASE "E" MAY APPEAR IN BASED LITERALS, + -- WHEN USING COLONS IN PLACE OF THE SHARP SIGN. + + -- TBN 2/28/86 + + WITH REPORT; USE REPORT; + PROCEDURE C2A008A IS + + TYPE FLOAT IS DIGITS 5; + INT_1 : INTEGER := 15:A:E1; + INT_2 : INTEGER := 15:A:e1; + FLO_1 : FLOAT := 16:FD.C:E1; + FLO_2 : FLOAT := 16:FD.C:e1; + + BEGIN + TEST("C2A008A", "CHECK THAT UPPER AND LOWER CASE ""E"" MAY " & + "APPEAR IN BASED LITERALS, WHEN USING COLONS " & + "IN PLACE OF THE SHARP SIGN"); + + IF INT_1 /= INT_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 1"); + END IF; + + IF FLO_1 /= FLO_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 2"); + END IF; + + INT_1 := 14:BC:E1; + INT_2 := 14:BC:e1; + FLO_1 := 16:DEF.AB:E0; + FLO_2 := 16:DEF.AB:e0; + + IF INT_1 /= INT_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 3"); + END IF; + + IF FLO_1 /= FLO_2 THEN + FAILED ("UPPER AND LOWER CASE LETTERS NOT ALLOWED - 4"); + END IF; + + RESULT; + END C2A008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c2/c2a021b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + -- C2A021B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STRING LITERAL DELIMITED BY PERCENT SIGNS MUST CONTAIN A + -- DOUBLED PERCENT CHARACTER IF THE STRING VALUE IS TO CONTAIN A PERCENT + -- CHARACTER. + + -- JBG 5/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C2A021B IS + X : STRING (1..5) := %%%%%345%; + Y : STRING (1..5) := IDENT_STR ("%%345"); + BEGIN + TEST ("C2A021B", "CHECK USE OF PERCENT SIGN INSIDE STRINGS " & + "DELIMITED WITH PERCENT SIGNS"); + + IF X /= Y THEN + FAILED ("STRING LITERALS NOT EQUAL"); + END IF; + + RESULT; + END C2A021B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C32001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN MULTIPLE OBJECT DECLARATIONS FOR SCALAR TYPES, THE + -- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED + -- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE + -- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS + -- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + + -- RJW 7/16/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C32001A IS + + BUMP : ARRAY (1 .. 8) OF INTEGER := (OTHERS => 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + + BEGIN + TEST ("C32001A", "CHECK THAT IN MULTIPLE OBJECT DECLARATION " & + "FOR SCALAR TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE DAY IS (MON, TUES, WED, THURS, FRI); + D1, D2 : DAY + RANGE MON .. DAY'VAL (F (1)) := + DAY'VAL (F (1) - 1); + CD1, CD2 : CONSTANT DAY + RANGE MON .. DAY'VAL (F (2)) := + DAY'VAL (F (2) - 1); + + I1, I2 : INTEGER RANGE 0 .. F (3) := + F (3) - 1; + CI1, CI2 : CONSTANT INTEGER RANGE 0 .. F (4) + := F (4) - 1; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + FL1, FL2 : FLT RANGE 0.0 .. FLT (F (5)) := + FLT (F (5) - 1); + CFL1, CFL2 : CONSTANT FLT + RANGE 0.0 .. FLT (F (6)) := + FLT (F (6) - 1); + + TYPE FIX IS DELTA 1.0 RANGE -5.0 .. 5.0; + FI1, FI2 : FIX RANGE 0.0 .. FIX (F (7)) := + FIX (F (7) - 1); + CFI1, CFI2 : CONSTANT FIX + RANGE 0.0 .. FIX (F (8)) := + FIX (F (8) - 1); + + BEGIN + IF D1 /= TUES THEN + FAILED ( "D1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF D2 /= THURS THEN + FAILED ( "D2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CD1 /= TUES THEN + FAILED ( "CD1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CD2 /= THURS THEN + FAILED ( "CD2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF I1 /= 1 THEN + FAILED ( "I1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF I2 /= 3 THEN + FAILED ( "I2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CI1 /= 1 THEN + FAILED ( "CI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CI2 /= 3 THEN + FAILED ( "CI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FL1 /= 1.0 THEN + FAILED ( "FL1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FL2 /= 3.0 THEN + FAILED ( "FL2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFL1 /= 1.0 THEN + FAILED ( "CFL1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFL2 /= 3.0 THEN + FAILED ( "CFL2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FI1 /= 1.0 THEN + FAILED ( "FI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF FI2 /= 3.0 THEN + FAILED ( "FI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFI1 /= 1.0 THEN + FAILED ( "CFI1 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + IF CFI2 /= 3.0 THEN + FAILED ( "CFI2 NOT INITIALIZED TO CORRECT VALUE" ); + END IF; + + END; + + RESULT; + END C32001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,249 ---- + -- C32001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IN MULTIPLE OBJECT DECLARATIONS FOR ARRAY TYPES, THE + -- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE + -- EVALUATED ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE + -- SUBTYPE INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE + -- EVALUATIONS YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT + -- DECLARATIONS. + + -- HISTORY: + -- RJW 07/16/86 CREATED ORIGINAL TEST. + -- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED + -- COMMENTS FOR S4 AND CS4 TO READ THAT THE BOUNDS ARE + -- 1 .. 6 AND THE COMPONENT TYPE ARR IS 1 .. 5. + + WITH REPORT; USE REPORT; + + PROCEDURE C32001B IS + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + BUMP : ARRAY (1 .. 4) OF INTEGER := (0, 0, 0, 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + + BEGIN + TEST ("C32001B", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR ARRAY TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + S1, S2 : ARR (1 .. F (1)) := (OTHERS => F (1)); + CS1, CS2 : CONSTANT ARR (1 .. F (2)) := (OTHERS => F (2)); + + PROCEDURE CHECK (A, B : ARR; STR1, STR2 : STRING) IS + BEGIN + IF A'LAST /= 1 THEN + FAILED ( "INCORRECT UPPER BOUND FOR " & STR1 ); + END IF; + + IF A (1) /= 2 THEN + FAILED ( "INCORRECT INITIAL VALUE FOR " & STR1 ); + END IF; + + IF B'LAST /= 3 THEN + FAILED ( "INCORRECT UPPER BOUND FOR " & STR2 ); + END IF; + + BEGIN + IF B (1 .. 3) = (4, 5, 6) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(4, 5, 6)" ); + ELSIF B (1 .. 3) = (5, 4, 6) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(5, 4, 6)" ); + ELSIF B (1 .. 3) = (4, 6, 5) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(4, 6, 5)" ); + ELSIF B (1 .. 3) = (6, 4, 5) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(6, 4, 5)" ); + ELSIF B (1 .. 3) = (6, 5, 4) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(6, 5, 4)" ); + ELSIF B (1 .. 3) = (5, 6, 4) THEN + COMMENT ( STR2 & " WAS INITIALIZED TO " & + "(5, 6, 4)" ); + ELSE + FAILED ( STR2 & " HAS INCORRECT INITIAL " & + "VALUE" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED - " & + STR2 ); + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - " & + STR2 ); + END; + END; + + BEGIN + CHECK (S1, S2, "S1", "S2"); + CHECK (CS1, CS2, "CS1", "CS2"); + END; + + DECLARE + + S3, S4 : ARRAY (1 .. F (3)) OF ARR (1 .. F (3)) := + (OTHERS => (OTHERS => F (3))); + + CS3, CS4 : CONSTANT ARRAY (1.. F (4)) OF + ARR (1 .. F (4)) := + (OTHERS => (OTHERS => F (4))); + BEGIN + IF S3'LAST = 1 THEN + IF S3 (1)'LAST = 2 THEN + COMMENT ( "S3 HAS BOUNDS 1 .. 1 AND " & + "COMPONENT TYPE ARR (1 .. 2)" ); + IF S3 (1)(1 .. 2) = (3, 4) THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "3 AND 4 - 1" ); + ELSIF S3 (1)(1 .. 2) = (4, 3) THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "4 AND 3 - 1" ); + ELSE + FAILED ( "S3 HAS WRONG INITIAL VALUES - 1" ); + END IF; + ELSE + FAILED ( "S3 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF S3'LAST = 2 THEN + IF S3 (1)'LAST = 1 THEN + COMMENT ( "S3 HAS BOUNDS 1 .. 2 AND " & + "COMPONENT TYPE ARR (1 .. 1)" ); + IF S3 (1) (1) = 3 AND S3 (2) (1) = 4 THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "3 AND 4 - 2" ); + ELSIF S3 (1) (1) = 4 AND S3 (2) (1) = 3 THEN + COMMENT ( "S3 HAS INITIAL VALUES " & + "4 AND 3 - 2" ); + ELSE + FAILED ( "S3 HAS WRONG INITIAL VALUES - 2" ); + END IF; + ELSE + FAILED ( "S3 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "S3 HAS INCORRECT BOUNDS" ); + END IF; + + IF S4'LAST = 5 THEN + IF S4 (1)'LAST = 6 THEN + COMMENT ( "S4 HAS BOUNDS 1 .. 5 AND " & + "COMPONENT TYPE ARR (1 .. 6)" ); + ELSE + FAILED ( "S4 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF S4'LAST = 6 THEN + IF S4 (1)'FIRST = 1 AND S4 (1)'LAST = 5 THEN + COMMENT ( "S4 HAS BOUNDS 1 .. 6 AND " & + "COMPONENT TYPE ARR (1 .. 5)" ); + ELSE + FAILED ( "S4 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "S4 HAS INCORRECT BOUNDS" ); + END IF; + + IF BUMP (3) /= 36 THEN + FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " & + "TIMES TO INITIALIZE S4" ); + END IF; + + IF CS3'FIRST = 1 AND CS3'LAST = 1 THEN + IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 2 THEN + COMMENT ( "CS3 HAS BOUNDS 1 .. 1 AND " & + "COMPONENT TYPE ARR (1 .. 2)" ); + IF CS3 (1)(1 .. 2) = (3, 4) THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "3 AND 4 - 1" ); + ELSIF CS3 (1)(1 .. 2) = (4, 3) THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "4 AND 3 - 1" ); + ELSE + FAILED ( "CS3 HAS WRONG INITIAL VALUES - 1" ); + END IF; + ELSE + FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF CS3'FIRST = 1 AND CS3'LAST = 2 THEN + IF CS3 (1)'FIRST = 1 AND CS3 (1)'LAST = 1 THEN + COMMENT ( "CS3 HAS BOUNDS 1 .. 2 AND " & + "COMPONENT TYPE ARR (1 .. 1)" ); + IF CS3 (1) (1) = 3 AND CS3 (2) (1) = 4 THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "3 AND 4 - 2" ); + ELSIF CS3 (1) (1) = 4 AND CS3 (2) (1) = 3 THEN + COMMENT ( "CS3 HAS INITIAL VALUES " & + "4 AND 3 - 2" ); + ELSE + FAILED ( "CS3 HAS WRONG INITIAL VALUES - 2" ); + END IF; + ELSE + FAILED ( "CS3 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "CS3 HAS INCORRECT BOUNDS" ); + END IF; + + IF CS4'FIRST = 1 AND CS4'LAST = 5 THEN + IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 6 THEN + COMMENT ( "CS4 HAS BOUNDS 1 .. 5 AND " & + "COMPONENT TYPE ARR (1 .. 6)" ); + ELSE + FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 1" ); + END IF; + ELSIF CS4'FIRST = 1 AND CS4'LAST = 6 THEN + IF CS4 (1)'FIRST = 1 AND CS4 (1)'LAST = 5 THEN + COMMENT ( "CS4 HAS BOUNDS 1 .. 6 AND " & + "COMPONENT TYPE ARR (1 .. 5)" ); + ELSE + FAILED ( "CS4 HAS WRONG COMPONENT TYPE - 2" ); + END IF; + ELSE + FAILED ( "CS4 HAS INCORRECT BOUNDS" ); + END IF; + + IF BUMP (4) /= 36 THEN + FAILED ( "FUNCTION F NOT INVOKED CORRECT NUMBER OF " & + "TIMES TO INITIALIZE CS4" ); + END IF; + END; + + RESULT; + END C32001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C32001C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN MULTIPLE OBJECT DECLARATIONS FOR RECORD TYPES, THE + -- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED + -- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE + -- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS + -- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + + -- RJW 7/16/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C32001C IS + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + F1, G1 : ARR; + BUMP : ARR := (0, 0); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + F1 (I) := BUMP (I); + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + G1 (I) := BUMP (I); + RETURN BUMP (I); + END G; + + FUNCTION H (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP(I) + 1; + RETURN BUMP (I); + END H; + + BEGIN + TEST ("C32001C", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR RECORD TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE REC (D1, D2 : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + R1, R2 : REC (F (1), G (1)) := + (F1 (1), G1 (1), VALUE => H (1)); + CR1, CR2 : CONSTANT REC (F (2), G (2)) := + (F1 (2), G1 (2), VALUE => H (2)); + + PROCEDURE CHECK + (R : REC; V1, V2, VAL : INTEGER; S : STRING) IS + BEGIN + IF R.D1 = V1 THEN + IF R.D2 = V2 THEN + COMMENT ( S & ".D1 INITIALIZED TO " & + INTEGER'IMAGE (V1) & " AND " & + S & ".D2 INITIALIZED TO " & + INTEGER'IMAGE (V2)); + ELSE + FAILED ( S & + ".D2 INITIALIZED INCORRECTLY - 1" ); + END IF; + ELSIF R.D1 = V2 THEN + IF R.D2 =V1 THEN + COMMENT ( S & ".D1 INITIALIZED TO " & + INTEGER'IMAGE (V2) & " AND " & + S & ".D2 INITIALIZED TO " & + INTEGER'IMAGE (V1)); + ELSE + FAILED ( S & + ".D2 INITIALIZED INCORRECTLY - 2" ); + END IF; + ELSE + FAILED ( S & ".D1 INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (R.D1) ); + END IF; + + IF R.VALUE /= VAL THEN + FAILED ( S & ".VALUE INITIALIZED INCORRECTLY" ); + END IF; + END CHECK; + + BEGIN + CHECK (R1, 1, 2, 3, "R1"); + CHECK (R2, 4, 5, 6, "R2"); + + CHECK (CR1, 1, 2, 3, "CR1"); + CHECK (CR2, 4, 5, 6, "CR2"); + END; + + RESULT; + END C32001C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C32001D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN MULTIPLE OBJECT DECLARATIONS FOR ACCESS TYPES, THE + -- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED + -- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE + -- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS + -- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + + -- RJW 7/16/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C32001D IS + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + BUMP : ARR := (0, 0); + F1 : ARR; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + F1 (I) := BUMP (I); + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END G; + + BEGIN + TEST ("C32001D", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR ACCESS TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + + TYPE CELL (SIZE : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + TYPE LINK IS ACCESS CELL; + + L1, L2 : LINK (F (1)) := NEW CELL'(F1 (1), G (1)); + + CL1, CL2 : CONSTANT LINK (F (2)) := NEW CELL'(F1 (2), G (2)); + + PROCEDURE CHECK (L : LINK; V1, V2 : INTEGER; S : STRING) IS + BEGIN + IF L.SIZE /= V1 THEN + FAILED ( S & ".SIZE INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (L.SIZE)); + END IF; + + IF L.VALUE /= V2 THEN + FAILED ( S & ".VALUE INITIALIZED INCORRECTLY TO " & + INTEGER'IMAGE (L.VALUE)); + END IF; + END CHECK; + + BEGIN + CHECK (L1, 1, 2, "L1"); + CHECK (L2, 3, 4, "L2"); + + CHECK (CL1, 1, 2, "CL1"); + CHECK (CL2, 3, 4, "CL2"); + END; + + RESULT; + END C32001D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32001e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32001e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,253 ---- + -- C32001E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN MULTIPLE OBJECT DECLARATIONS FOR PRIVATE TYPES, THE + -- SUBTYPE INDICATION AND THE INITIALIZATION EXPRESSIONS ARE EVALUATED + -- ONCE FOR EACH NAMED OBJECT THAT IS DECLARED AND THE SUBTYPE + -- INDICATION IS EVALUATED FIRST. ALSO, CHECK THAT THE EVALUATIONS + -- YIELD THE SAME RESULT AS A SEQUENCE OF SINGLE OBJECT DECLARATIONS. + + -- RJW 7/18/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C32001E IS + + BUMP : ARRAY (1 .. 10) OF INTEGER := (OTHERS => 0); + G1 : ARRAY (5 .. 6) OF INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + RETURN BUMP (I); + END F; + + FUNCTION G (I : INTEGER) RETURN INTEGER IS + BEGIN + BUMP (I) := BUMP (I) + 1; + G1 (I) := BUMP (I); + RETURN BUMP (I); + END G; + + BEGIN + TEST ("C32001E", "CHECK THAT IN MULTIPLE OBJECT DECLARATIONS " & + "FOR PRIVATE TYPES, THE SUBTYPE INDICATION " & + "AND THE INITIALIZATION EXPRESSIONS ARE " & + "EVALUATED ONCE FOR EACH NAMED OBJECT THAT " & + "IS DECLARED AND THE SUBTYPE INDICATION IS " & + "EVALUATED FIRST. ALSO, CHECK THAT THE " & + "EVALUATIONS YIELD THE SAME RESULT AS A " & + "SEQUENCE OF SINGLE OBJECT DECLARATIONS" ); + + DECLARE + PACKAGE PKG1 IS + TYPE PBOOL IS PRIVATE; + TYPE PINT IS PRIVATE; + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE PARR IS PRIVATE; + TYPE PACC IS PRIVATE; + + FUNCTION INIT1 (I : INTEGER) RETURN PBOOL; + FUNCTION INIT2 (I : INTEGER) RETURN PINT; + FUNCTION INIT3 (I : INTEGER) RETURN PREC; + FUNCTION INIT4 (I : INTEGER) RETURN PARR; + FUNCTION INIT5 (I : INTEGER) RETURN PACC; + + PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING); + PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING); + PROCEDURE CHECK3 (R : PREC; I, J : INTEGER; + S : STRING); + PROCEDURE CHECK4 (A : PARR; I, J : INTEGER; + S : STRING); + PROCEDURE CHECK5 (V : PACC; S : STRING); + PROCEDURE CHECK6 (V : PACC; S : STRING); + + PRIVATE + TYPE PBOOL IS NEW BOOLEAN; + TYPE PINT IS NEW INTEGER; + + TYPE PREC (D : INTEGER) IS + RECORD + VALUE : INTEGER; + END RECORD; + + TYPE PARR IS ARRAY (1 .. 2) OF INTEGER; + + TYPE VECTOR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE PACC IS ACCESS VECTOR; + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION INIT1 (I : INTEGER) RETURN PBOOL IS + BEGIN + RETURN PBOOL'VAL (F (I) - 1); + END INIT1; + + FUNCTION INIT2 (I : INTEGER) RETURN PINT IS + BEGIN + RETURN PINT'VAL (F (I)); + END INIT2; + + FUNCTION INIT3 (I : INTEGER) RETURN PREC IS + PR : PREC (G1 (I)) := (G1 (I), F (I)); + BEGIN + RETURN PR; + END INIT3; + + FUNCTION INIT4 (I : INTEGER) RETURN PARR IS + PA : PARR := (1 .. 2 => F (I)); + BEGIN + RETURN PA; + END INIT4; + + FUNCTION INIT5 (I : INTEGER) RETURN PACC IS + ACCV : PACC := NEW VECTOR'(1 .. F (I) => F (I)); + BEGIN + RETURN ACCV; + END INIT5; + + PROCEDURE CHECK1 (B : PBOOL; I : INTEGER; S : STRING) IS + BEGIN + IF B /= PBOOL'VAL (I) THEN + FAILED ( S & " HAS AN INCORRECT VALUE OF " & + PBOOL'IMAGE (B)); + END IF; + END CHECK1; + + PROCEDURE CHECK2 (I : PINT; J : INTEGER; S : STRING) IS + BEGIN + IF I /= PINT'VAL (J) THEN + FAILED ( S & " HAS AN INCORRECT VALUE OF " & + PINT'IMAGE (I)); + END IF; + END CHECK2; + + PROCEDURE CHECK3 (R : PREC; I, J : INTEGER; + S : STRING) IS + BEGIN + IF R.D /= I THEN + FAILED ( S & ".D HAS AN INCORRECT VALUE OF " + & INTEGER'IMAGE (R.D)); + END IF; + + IF R.VALUE /= J THEN + FAILED ( S & ".VALUE HAS AN INCORRECT " & + "VALUE OF " & + INTEGER'IMAGE (R.VALUE)); + END IF; + END CHECK3; + + PROCEDURE CHECK4 (A : PARR; I, J : INTEGER; + S : STRING) IS + BEGIN + IF A /= (I, J) AND A /= (J, I) THEN + FAILED ( S & " HAS AN INCORRECT VALUE" ); + END IF; + END CHECK4; + + PROCEDURE CHECK5 (V : PACC; S : STRING) IS + BEGIN + IF V'LAST /= 1 THEN + FAILED ( S & " HAS AN INCORRECT UPPER BOUND " + & "OF " & INTEGER'IMAGE (V'LAST)); + END IF; + + IF V (1) /= 2 THEN + FAILED ( S & " HAS AN INCORRECT COMPONENT " & + "VALUE" ); + END IF; + END CHECK5; + + PROCEDURE CHECK6 (V : PACC; S : STRING) IS + BEGIN + IF V'LAST /= 3 THEN + FAILED ( S & " HAS AN INCORRECT UPPER BOUND " + & "OF " & INTEGER'IMAGE (V'LAST)); + END IF; + + IF V.ALL = (4, 5, 6) OR V.ALL = (5, 4, 6) OR + V.ALL = (4, 6, 5) OR V.ALL = (6, 4, 5) OR + V.ALL = (5, 6, 4) OR V.ALL = (6, 5, 4) THEN + NULL; + ELSE + FAILED ( S & " HAS AN INCORRECT COMPONENT " & + "VALUE" ); + END IF; + END CHECK6; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + B1, B2 : PBOOL := INIT1 (1); + CB1, CB2 : CONSTANT PBOOL := INIT1 (2); + + I1, I2 : PINT := INIT2 (3); + CI1, CI2 : CONSTANT PINT := INIT2 (4); + + R1, R2 : PREC (G (5)) := INIT3 (5); + CR1, CR2 : CONSTANT PREC (G (6)) := INIT3 (6); + + A1, A2 : PARR := INIT4 (7); + CA1, CA2 : CONSTANT PARR := INIT4 (8); + + V1, V2 : PACC := INIT5 (9); + CV1, CV2 : CONSTANT PACC := INIT5 (10); + + BEGIN + CHECK1 (B1, 0, "B1"); + CHECK1 (B2, 1, "B2"); + CHECK1 (CB1, 0, "CB1"); + CHECK1 (CB2, 1, "CB2"); + + CHECK2 (I1, 1, "I1"); + CHECK2 (I2, 2, "I2"); + CHECK2 (CI1, 1, "CI1"); + CHECK2 (CI2, 2, "CI2"); + + CHECK3 (R1, 1, 2, "R1"); + CHECK3 (R2, 3, 4, "R2"); + CHECK3 (CR1, 1, 2, "CR1"); + CHECK3 (CR2, 3, 4, "CR2"); + + CHECK4 (A1, 1, 2, "A1"); + CHECK4 (A2, 3, 4, "A2"); + CHECK4 (CA1, 1, 2, "CA1"); + CHECK4 (CA2, 3, 4, "CA2"); + + CHECK5 (V1, "V1"); + CHECK6 (V2, "V2"); + CHECK5 (CV1, "CV1"); + CHECK6 (CV2, "CV2"); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; + END C32001E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32107a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,363 ---- + -- C32107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OBJECT DECLARATIONS ARE ELABORATED IN THE ORDER OF THEIR + -- OCCURRENCE, I.E., THAT EXPRESSIONS ASSOCIATED WITH ONE DECLARATION + -- (INCLUDING DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE EVALUATED BEFORE + -- ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. ALSO, CHECK THAT + -- EXPRESSIONS IN THE SUBTYPE INDICATION OR THE CONSTRAINED ARRAY + -- DEFINITION ARE EVALUATED BEFORE ANY INITIALIZATION EXPRESSIONS ARE + -- EVALUATED. + + -- R.WILLIAMS 9/24/86 + + WITH REPORT; USE REPORT; + PROCEDURE C32107A IS + + BUMP : INTEGER := 0; + + ORDER_CHECK : INTEGER; + + G1, H1, I1 : INTEGER; + + FIRST_CALL : BOOLEAN := TRUE; + + TYPE ARR1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE ARR1_NAME IS ACCESS ARR1; + + TYPE ARR2 IS ARRAY (POSITIVE RANGE <>, POSITIVE RANGE <>) OF + INTEGER; + + TYPE REC (D : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + G1 := BUMP; + RETURN BUMP; + END G; + + FUNCTION H RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + H1 := BUMP; + RETURN BUMP; + END H; + + FUNCTION I RETURN INTEGER IS + BEGIN + IF FIRST_CALL THEN + BUMP := BUMP + 1; + I1 := BUMP; + FIRST_CALL := FALSE; + END IF; + RETURN I1; + END I; + + BEGIN + TEST ( "C32107A", "CHECK THAT OBJECT DECLARATIONS ARE " & + "ELABORATED IN THE ORDER OF THEIR " & + "OCCURRENCE, I.E., THAT EXPRESSIONS " & + "ASSOCIATED WITH ONE DECLARATION (INCLUDING " & + "DEFAULT EXPRESSIONS, IF APPROPRIATE) ARE " & + "EVALUATED BEFORE ANY EXPRESSION BELONGING " & + "TO THE NEXT DECLARATION. ALSO, CHECK THAT " & + "EXPRESSIONS IN THE SUBTYPE INDICATION OR " & + "THE CONSTRAINED ARRAY DEFINITION ARE " & + "EVALUATED BEFORE ANY INITIALIZATION " & + "EXPRESSIONS ARE EVALUATED" ); + + DECLARE -- (A). + I1 : INTEGER := 10000 * F; + A1 : CONSTANT ARRAY (1 .. H) OF REC (G * 100) := + (1 .. H1 => (G1 * 100, I * 10)); + I2 : CONSTANT INTEGER := F * 1000; + BEGIN + ORDER_CHECK := I1 + I2 + A1'LAST + A1 (1).D + A1 (1).COMP; + IF ORDER_CHECK = 15243 OR ORDER_CHECK = 15342 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 15343 OR " & + "15242 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + END IF; + END; -- (A). + + BUMP := 0; + + DECLARE -- (B). + A : ARR2 (1 .. F, 1 .. F * 10); + R : REC (G * 100) := (G1 * 100, F * 1000); + I : INTEGER RANGE 1 .. H; + S : REC (F * 10); + BEGIN + ORDER_CHECK := + A'LAST (1) + A'LAST (2) + R.D + R.COMP; + IF (H1 + S.D = 65) AND + (ORDER_CHECK = 4321 OR ORDER_CHECK = 4312) THEN + COMMENT ( "ORDER_CHECK HAS VALUE 65 " & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 65 4321 OR " & + "65 4312 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (H1 + S.D) & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + END IF; + END; -- (B). + + BUMP := 0; + + DECLARE -- (C). + I1 : CONSTANT INTEGER RANGE 1 .. G * 10 := F; + A1 : ARRAY (1 .. F * 100) OF INTEGER RANGE 1 .. H * 1000; + BEGIN + ORDER_CHECK := I1 + (G1 * 10) + A1'LAST + (H1 * 1000); + IF ORDER_CHECK = 4312 OR ORDER_CHECK = 3412 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4312 OR " & + "3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (C)" ); + END IF; + END; -- (C). + + BUMP := 0; + FIRST_CALL := TRUE; + + DECLARE -- (D). + A1 : ARRAY (1 .. G) OF REC (H * 10000) := + (1 .. G1 => (H1 * 10000, I * 100)); + R1 : CONSTANT REC := (F * 1000, F * 10); + + BEGIN + ORDER_CHECK := + A1'LAST + A1 (1).D + A1 (1).COMP + R1.D + R1.COMP; + IF ORDER_CHECK = 25341 OR ORDER_CHECK = 24351 OR + ORDER_CHECK = 15342 OR ORDER_CHECK = 14352 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 25341, " & + "24351, 15342 OR 14352 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (D)" ); + END IF; + END; -- (D). + + BUMP := 0; + + DECLARE -- (E). + A1 : CONSTANT ARR1_NAME := NEW ARR1' (1 .. F => F * 10); + R1 : REC_NAME (H * 100) := NEW REC'(H1 * 100, F * 1000); + + BEGIN + ORDER_CHECK := A1.ALL'LAST + A1.ALL (1) + R1.D + R1.COMP; + IF ORDER_CHECK /= 4321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321 " & + "-- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (E)" ); + END IF; + END; -- (E). + + BUMP := 0; + FIRST_CALL := TRUE; + + DECLARE -- (F). + A1 : CONSTANT ARRAY (1 .. G) OF INTEGER RANGE 1 .. H * 100 := + (1 .. G1 => I * 10); + A2 : ARR1 (1 .. F * 1000); + BEGIN + ORDER_CHECK := + A1'LAST + (H1 * 100) + A1 (1) + A2'LAST; + IF ORDER_CHECK = 4231 OR ORDER_CHECK = 4132 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4231 OR " & + "4132 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (F)" ); + END IF; + END; -- (F). + + BUMP := 0; + + DECLARE -- (G). + A1 : ARR1_NAME (1 .. G) := NEW ARR1 (1 .. G1); + R1 : CONSTANT REC_NAME (H * 10) := + NEW REC'(H1 * 10, F * 100); + BEGIN + ORDER_CHECK := A1.ALL'LAST + R1.D + R1.COMP; + IF ORDER_CHECK /= 321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 321 OR " & + "-- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (G)" ); + END IF; + END; -- (G). + + BUMP := 0; + + DECLARE -- (H). + TYPE REC (D : INTEGER := F) IS + RECORD + COMP : INTEGER := F * 10; + END RECORD; + + R1 : REC; + R2 : REC (G * 100) := (G1 * 100, F * 1000); + BEGIN + ORDER_CHECK := R1.D + R1.COMP + R2.D + R2.COMP; + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3421 OR ORDER_CHECK = 3412 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, " & + "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (H)" ); + END IF; + END; -- (H). + + BUMP := 0; + + DECLARE -- (I). + TYPE REC2 (D1, D2 : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + R1 : REC2 (G * 1000, H * 10000) := + (G1 * 1000, H1 * 10000, F * 100); + R2 : REC2 (F, F * 10); + BEGIN + ORDER_CHECK := R1.D1 + R1.D2 + R1.COMP + R2.D1 + R2.D2; + IF ORDER_CHECK = 21354 OR ORDER_CHECK = 21345 OR + ORDER_CHECK = 12345 OR ORDER_CHECK = 12354 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 21354, " & + "21345, 12354, OR 12345 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (I)" ); + END IF; + + END; -- (I). + + BUMP := 0; + + DECLARE -- (J). + PACKAGE P IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + P1 : CONSTANT PRIV; + P2 : CONSTANT PRIV; + + FUNCTION GET_A (P : PRIV) RETURN INTEGER; + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + P1 : CONSTANT PRIV := (F , F * 10); + P2 : CONSTANT PRIV := (F * 100, F * 1000); + END P; + + PACKAGE BODY P IS + FUNCTION GET_A (P : PRIV) RETURN INTEGER IS + BEGIN + RETURN P.COMP; + END GET_A; + END P; + + USE P; + BEGIN + ORDER_CHECK := P1.D + GET_A (P1) + P2.D + GET_A (P2); + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, " & + "4312, 3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (J)" ); + END IF; + END; -- (J). + + BUMP := 0; + + DECLARE -- (K). + PACKAGE P IS + TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + USE P; + + P1 : PRIV (F, F * 10); + P2 : PRIV (F * 100, F * 1000); + + BEGIN + ORDER_CHECK := P1.D1 + P1.D2 + P2.D1 + P2.D2; + IF ORDER_CHECK = 4321 OR ORDER_CHECK = 4312 OR + ORDER_CHECK = 3412 OR ORDER_CHECK = 3421 THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER ORDER " & + "VALUE OF ORDER_CHECK SHOULD BE 4321, 4312, " & + "3421, OR 3412 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (K)" ); + END IF; + + END; -- (K). + + RESULT; + END C32107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32107c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32107c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32107c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32107c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C32107C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE ACTUAL PARAMETER IS A + -- TYPE WITH DEFAULT VALUES, CHECK THAT OBJECT DECLARATIONS ARE + -- ELABORATED IN THE ORDER OF THEIR OCCURRENCE, I.E., THAT EXPRESSIONS + -- ASSOCIATED WITH ONE DECLARATION (INCLUDING DEFAULT EXPRESSIONS) ARE + -- EVALUATED BEFORE ANY EXPRESSION BELONGING TO THE NEXT DECLARATION. + + -- R.WILLIAMS 9/24/86 + + WITH REPORT; USE REPORT; + PROCEDURE C32107C IS + + BUMP : INTEGER := 0; + + G1, H1 : INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + G1 := BUMP; + RETURN BUMP; + END G; + + FUNCTION H RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + H1 := BUMP; + RETURN BUMP; + END H; + + BEGIN + TEST ( "C32107C", "FOR OBJECTS OF A GENERIC FORMAL TYPE WHOSE " & + "ACTUAL PARAMETER IS A TYPE WITH DEFAULT " & + "VALUES, CHECK THAT OBJECT DECLARATIONS ARE " & + "ELABORATED IN THE ORDER OF THEIR " & + "OCCURRENCE, I.E., THAT EXPRESSIONS " & + "ASSOCIATED WITH ONE DECLARATION (INCLUDING " & + "DEFAULT EXPRESSIONS) ARE EVALUATED BEFORE " & + "ANY EXPRESSION BELONGING TO THE NEXT " & + "DECLARATION" ); + + DECLARE -- (A). + TYPE REC (D : INTEGER := F) IS + RECORD + A : INTEGER := F; + END RECORD; + + FUNCTION GET_A (R : REC) RETURN INTEGER IS + BEGIN + RETURN R.A; + END GET_A; + + GENERIC + TYPE T IS (<>); + TYPE PRIV (D : T) IS PRIVATE; + WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>; + PROCEDURE P; + + PROCEDURE P IS + P1 : PRIV (T'VAL (F)); + P2 : PRIV (T'VAL (F * 100)); + ORDER_CHECK : INTEGER; + + BEGIN + ORDER_CHECK := + T'POS (P1.D) + T'POS (P2.D) + + (GET_A (P1) * 10) + (GET_A (P2) * 1000); + IF ORDER_CHECK /= 4321 THEN + FAILED ( "OBJECTS NOT ELABORATED IN PROPER " & + "ORDER VALUE OF ORDER_CHECK SHOULD BE " & + "4321 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (ORDER_CHECK) & " - (A)" ); + END IF; + END P; + + PROCEDURE PROC IS NEW P (INTEGER, REC); + + BEGIN + PROC; + END; -- (A). + + BUMP := 0; + + DECLARE -- (B). + TYPE REC (D1 : INTEGER := F; D2 : INTEGER := F) IS + RECORD + A : INTEGER := F; + END RECORD; + + FUNCTION GET_A (R : REC) RETURN INTEGER IS + BEGIN + RETURN R.A; + END GET_A; + + GENERIC + TYPE T IS (<>); + TYPE PRIV (D1 : T; D2 : T) IS PRIVATE; + WITH FUNCTION GET_A (P : PRIV) RETURN INTEGER IS <>; + PROCEDURE P; + + PROCEDURE P IS + P1 : PRIV (T'VAL (F * 1000), T'VAL (F * 10000)); + P2 : PRIV (T'VAL (F), T'VAL (F * 10)); + ORDER_CHECK : INTEGER; + + BEGIN + ORDER_CHECK := + T'POS (P1.D1) + T'POS (P1.D2) + + T'POS (P2.D1) + T'POS (P2.D2) + + (GET_A (P1) * 100); + IF (GET_A (P2) = 6) AND + (ORDER_CHECK = 12345 OR ORDER_CHECK = 21345 OR + ORDER_CHECK = 21354 OR ORDER_CHECK = 12354) THEN + COMMENT ( "ORDER_CHECK HAS VALUE " & + INTEGER'IMAGE (ORDER_CHECK) & + " - (B)" ); + ELSE + FAILED ( "OBJECTS NOT ELABORATED IN PROPER " & + "ORDER VALUE OF ORDER_CHECK SHOULD BE " & + "6 12345, 6 21345, 6 21354, OR " & + "6 12354 -- ACTUAL VALUE IS " & + INTEGER'IMAGE (GET_A (P2)) & + INTEGER'IMAGE (ORDER_CHECK) & " - (B)" ); + END IF; + + END P; + + PROCEDURE PROC IS NEW P (INTEGER, REC); + + BEGIN + PROC; + END; -- (B). + + RESULT; + END C32107C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32108a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- C32108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DEFAULT EXPRESSIONS ARE NOT EVALUATED, IF INITIALIZATION + -- EXPRESSIONS ARE GIVEN FOR THE OBJECT DECLARATIONS. + + -- TBN 3/20/86 + + WITH REPORT; USE REPORT; + PROCEDURE C32108A IS + + FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS + BEGIN + IF NUMBER /= 0 THEN + FAILED ("DEFAULT EXPRESSIONS ARE EVALUATED -" & + INTEGER'IMAGE (NUMBER)); + END IF; + RETURN (1); + END DEFAULT_CHECK; + + BEGIN + TEST ("C32108A", "CHECK THAT DEFAULT EXPRESSIONS ARE NOT " & + "EVALUATED, IF INITIALIZATION EXPRESSIONS ARE " & + "GIVEN FOR THE OBJECT DECLARATIONS"); + + DECLARE -- (A) + + TYPE REC_TYP1 IS + RECORD + AGE : INTEGER := DEFAULT_CHECK (1); + END RECORD; + + REC1 : REC_TYP1 := (AGE => DEFAULT_CHECK (0)); + + + TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK (2)) IS + RECORD + NULL; + END RECORD; + + REC2 : REC_TYP2 (DEFAULT_CHECK (0)); + + + TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK (3)) IS + RECORD + A : INTEGER := DEFAULT_CHECK (4); + END RECORD; + + REC3 : REC_TYP3 := (D => DEFAULT_CHECK (0), + A => DEFAULT_CHECK (0)); + + BEGIN -- (A) + NULL; + END; -- (A) + + RESULT; + END C32108A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32108b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32108b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32108b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32108b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C32108B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DEFAULT EXPRESSION IS EVALUATED FOR A COMPONENT, NO + -- DEFAULT EXPRESSIONS ARE EVALUATED FOR ANY SUBCOMPONENTS. + + -- TBN 3/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE C32108B IS + + FUNCTION DEFAULT_CHECK (NUMBER : INTEGER) RETURN INTEGER IS + BEGIN + IF NUMBER /= 0 THEN + FAILED ("SUBCOMPONENT DEFAULT EXPRESSIONS ARE " & + "EVALUATED -" & INTEGER'IMAGE (NUMBER)); + END IF; + RETURN (1); + END DEFAULT_CHECK; + + BEGIN + TEST ("C32108B", "CHECK THAT IF A DEFAULT EXPRESSION IS " & + "EVALUATED FOR A COMPONENT, NO DEFAULT " & + "EXPRESSIONS ARE EVALUATED FOR ANY " & + "SUBCOMPONENTS"); + + DECLARE -- (A) + + TYPE REC_TYP1 IS + RECORD + AGE : INTEGER := DEFAULT_CHECK (1); + END RECORD; + + TYPE REC_TYP2 (D : INTEGER := DEFAULT_CHECK(2)) IS + RECORD + NULL; + END RECORD; + + TYPE REC_TYP3 (D : INTEGER := DEFAULT_CHECK(3)) IS + RECORD + A : INTEGER := DEFAULT_CHECK(4); + END RECORD; + + TYPE REC_TYP4 IS + RECORD + ONE : REC_TYP1 := (AGE => DEFAULT_CHECK (0)); + TWO : REC_TYP2 (DEFAULT_CHECK(0)); + THREE : REC_TYP3 := (D => DEFAULT_CHECK (0), + A => DEFAULT_CHECK (0)); + END RECORD; + + REC4 : REC_TYP4; + + BEGIN -- (A) + NULL; + END; -- (A) + + RESULT; + END C32108B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32111a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32111a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32111a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32111a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- C32111A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION, + -- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL VALUE, + -- CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES OUTSIDE THE + -- RANGE OF THE SUBTYPE. + + -- HISTORY: + -- RJW 07/20/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 IMPROVED DEFEAT OF COMPILER OPTIMIZATION. + + WITH REPORT; USE REPORT; + + PROCEDURE C32111A IS + + TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI); + SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED; + + SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9'; + + SUBTYPE SHORT IS INTEGER RANGE -100 .. 100; + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE PINT IS INT RANGE 1 .. 10; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0; + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0; + + BEGIN + TEST ("C32111A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING AN ENUMERATION, INTEGER, FLOAT OR " & + "FIXED TYPE IS DECLARED WITH AN INITIAL " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " & + "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " & + "SUBTYPE" ); + + BEGIN + DECLARE + D : MIDWEEK := WEEKDAY'VAL (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + IF D = TUES THEN + COMMENT ("VARIABLE 'D' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + END; + + BEGIN + DECLARE + D : CONSTANT WEEKDAY RANGE WED .. WED := + WEEKDAY'VAL (IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + IF D = TUES THEN + COMMENT ("INITIALIZE VARIABLE 'D'"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + END; + + BEGIN + DECLARE + P : CONSTANT DIGIT := IDENT_CHAR ('/'); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + IF P = '0' THEN + COMMENT ("VARIABLE 'P' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + END; + + BEGIN + DECLARE + Q : CHARACTER RANGE 'A' .. 'E' := IDENT_CHAR ('F'); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + IF Q = 'A' THEN + COMMENT ("VARIABLE 'Q' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + END; + + BEGIN + DECLARE + I : SHORT := IDENT_INT (-101); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + IF I = 1 THEN + COMMENT ("VARIABLE 'I' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + END; + + BEGIN + DECLARE + J : CONSTANT INTEGER RANGE 0 .. 100 := IDENT_INT (101); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + IF J = -1 THEN + COMMENT ("VARIABLE 'J' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + END; + + BEGIN + DECLARE + K : INT RANGE 0 .. 1 := INT (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + IF K = 2 THEN + COMMENT ("VARIABLE 'K' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + END; + + BEGIN + DECLARE + L : CONSTANT PINT := INT (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + IF L = 1 THEN + COMMENT ("VARIABLE 'L' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + END; + + BEGIN + DECLARE + FL : SFLT := FLT (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + IF FL = 3.14 THEN + COMMENT ("VARIABLE 'FL' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + END; + + BEGIN + DECLARE + FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 := + FLT (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + IF FL1 = 0.0 THEN + COMMENT ("VARIABLE 'FL1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + END; + + BEGIN + DECLARE + FI : FIXED RANGE 0.0 .. 0.0 := IDENT_INT (1) * 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + IF FI = 0.5 THEN + COMMENT ("VARIABLE 'FI' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + END; + + BEGIN + DECLARE + FI1 : CONSTANT SFIXED := IDENT_INT (-1) * 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + IF FI1 = 0.5 THEN + COMMENT ("VARIABLE 'FI1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + END; + + RESULT; + END C32111A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32111b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32111b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32111b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32111b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- C32111B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN ENUMERATION, + -- INTEGER, FLOAT OR FIXED TYPE IS DECLARED WITH AN INITIAL STATIC + -- VALUE, CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE LIES + -- OUTSIDE THE RANGE OF THE SUBTYPE. + + -- HISTORY: + -- JET 08/04/87 CREATED ORIGINAL TEST BASED ON C32111A BY RJW + -- BUT WITH STATIC VALUES INSTEAD OF DYNAMIC + -- IDENTITY FUNCTION. + + WITH REPORT; USE REPORT; + + PROCEDURE C32111B IS + + TYPE WEEKDAY IS (MON, TUES, WED, THURS, FRI); + SUBTYPE MIDWEEK IS WEEKDAY RANGE WED .. WED; + + SUBTYPE DIGIT IS CHARACTER RANGE '0' .. '9'; + + SUBTYPE SHORT IS INTEGER RANGE -100 .. 100; + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE PINT IS INT RANGE 1 .. 10; + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -5.0 .. 0.0; + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SFIXED IS FIXED RANGE 0.0 .. 5.0; + + BEGIN + TEST ("C32111B", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING AN ENUMERATION, INTEGER, FLOAT OR " & + "FIXED TYPE IS DECLARED WITH AN INITIAL STATIC " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF THE " & + "INITIAL VALUE LIES OUTSIDE THE RANGE OF THE " & + "SUBTYPE" ); + + BEGIN + DECLARE + D : MIDWEEK := WEEKDAY'VAL (1); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + IF D = TUES THEN + COMMENT ("VARIABLE 'D' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'D'" ); + END; + + BEGIN + DECLARE + D : CONSTANT WEEKDAY RANGE WED .. WED := + WEEKDAY'VAL (3); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + IF D = TUES THEN + COMMENT ("INITIALIZE VARIABLE 'D'"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'D'" ); + END; + + BEGIN + DECLARE + P : CONSTANT DIGIT := '/'; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + IF P = '0' THEN + COMMENT ("VARIABLE 'P' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'P'" ); + END; + + BEGIN + DECLARE + Q : CHARACTER RANGE 'A' .. 'E' := 'F'; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + IF Q = 'A' THEN + COMMENT ("VARIABLE 'Q' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'Q'" ); + END; + + BEGIN + DECLARE + I : SHORT := -101; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + IF I = 1 THEN + COMMENT ("VARIABLE 'I' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'I'" ); + END; + + BEGIN + DECLARE + J : CONSTANT INTEGER RANGE 0 .. 100 := 101; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + IF J = -1 THEN + COMMENT ("VARIABLE 'J' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'J'" ); + END; + + BEGIN + DECLARE + K : INT RANGE 0 .. 1 := 2; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + IF K = 2 THEN + COMMENT ("VARIABLE 'K' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'K'" ); + END; + + BEGIN + DECLARE + L : CONSTANT PINT := 0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + IF L = 1 THEN + COMMENT ("VARIABLE 'L' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'L'" ); + END; + + BEGIN + DECLARE + FL : SFLT := 1.0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + IF FL = 3.14 THEN + COMMENT ("VARIABLE 'FL' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FL'" ); + END; + + BEGIN + DECLARE + FL1 : CONSTANT FLT RANGE 0.0 .. 0.0 := -1.0; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + IF FL1 = 0.0 THEN + COMMENT ("VARIABLE 'FL1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FL1'" ); + END; + + BEGIN + DECLARE + FI : FIXED RANGE 0.0 .. 0.0 := 0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + IF FI = 0.5 THEN + COMMENT ("VARIABLE 'FI' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'FI'" ); + END; + + BEGIN + DECLARE + FI1 : CONSTANT SFIXED := -0.5; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + IF FI1 = 0.5 THEN + COMMENT ("VARIABLE 'FI1' INITIALIZED"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'FI1'" ); + END; + + RESULT; + END C32111B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32112b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32112b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32112b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32112b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C32112B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR THE DECLARATION OF A NULL + -- ARRAY OBJECT IF THE INITIAL VALUE IS NOT A NULL ARRAY. + + -- RJW 7/20/86 + -- GMT 7/01/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. + -- CHANGED THE RANGE VALUES OF A FEW DIMENSIONS. + + WITH REPORT; USE REPORT; + + PROCEDURE C32112B IS + + TYPE ARR1 IS ARRAY (NATURAL RANGE <>) OF INTEGER; + SUBTYPE NARR1 IS ARR1 (IDENT_INT (2) .. IDENT_INT (1)); + + + TYPE ARR2 IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + SUBTYPE NARR2 IS ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (0)); + + BEGIN + TEST ("C32112B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "THE DECLARATION OF A NULL ARRAY OBJECT IF " & + "THE INITIAL VALUE IS NOT A NULL ARRAY"); + + BEGIN + DECLARE + A : ARR1 (IDENT_INT(1) .. IDENT_INT(2)); + N1A : NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1A'"); + A(1) := IDENT_INT(N1A(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1A'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (2)); + N1B : CONSTANT NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1B'"); + A(1) := IDENT_INT(N1B(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1B'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (1)); + N1C : CONSTANT NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1C'"); + A(1) := IDENT_INT(N1C(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1C'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (1) .. IDENT_INT (1)); + N1D : NARR1 := (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1D'"); + A(1) := IDENT_INT(N1D(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1D'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (0) .. IDENT_INT (1)); + N1E : ARR1 (IDENT_INT (1) .. IDENT_INT (0)) := + (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1E'"); + A(1) := IDENT_INT(N1E(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N1E'"); + END; + + BEGIN + DECLARE + A : ARR1 (IDENT_INT (0) .. IDENT_INT (1)); + N1F : CONSTANT ARR1 (IDENT_INT (1) .. IDENT_INT (0)) := + (A'RANGE => 0); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1F'"); + A(1) := IDENT_INT(N1F(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N1F'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (1)); + N2A : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2'"); + A(1,1) := IDENT_INT(N2A(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2A'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (1)); + N2B : NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2B'"); + A(1,1) := IDENT_INT(N2B(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2B'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (3), + IDENT_INT (1) .. IDENT_INT (1)); + N2C : CONSTANT NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2C'"); + A(1,1) := IDENT_INT(N2C(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2C'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (3), + IDENT_INT (1) .. IDENT_INT (1)); + N2D : NARR2 := (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2D'"); + A(1,1) := IDENT_INT(N2D(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2D'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)); + N2E : CONSTANT ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)) := + (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2E'"); + A(1,1) := IDENT_INT(N2E(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'N2E'"); + END; + + BEGIN + DECLARE + A : ARR2 (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)); + N2F : ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (1)) := + (A'RANGE => (A'RANGE (2) =>0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2F'"); + A(1,1) := IDENT_INT(N2F(1,1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'N2F'"); + END; + + RESULT; + END C32112B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32113a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32113a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32113a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32113a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,534 ---- + -- C32113A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED TYPE + -- WITH DISCRIMINANTS IS DECLARED WITH AN INITIAL VALUE, + -- CONSTRAINT_ERROR IS RAISED IF THE CORRESPONDING DISCRIMINANTS OF + -- THE INITIAL VALUE AND THE SUBTYPE DO NOT HAVE THE SAME VALUE. + + -- HISTORY: + -- RJW 07/20/86 + -- DWC 06/22/87 ADDED SUBTYPE PRIVAS. ADDED CODE TO PREVENT DEAD + -- VARIABLE OPTIMIZATION. + + WITH REPORT; USE REPORT; + + PROCEDURE C32113A IS + + PACKAGE PKG IS + TYPE PRIVA (D : INTEGER := 0) IS PRIVATE; + SUBTYPE PRIVAS IS PRIVA (IDENT_INT (1)); + PRA1 : CONSTANT PRIVAS; + + TYPE PRIVB (D1, D2 : INTEGER) IS PRIVATE; + PRB12 : CONSTANT PRIVB; + + PRIVATE + TYPE PRIVA (D : INTEGER := 0) IS + RECORD + NULL; + END RECORD; + + TYPE PRIVB (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + PRA1 : CONSTANT PRIVAS := (D => (IDENT_INT (1))); + PRB12 : CONSTANT PRIVB := (IDENT_INT (1), IDENT_INT (2)); + END PKG; + + USE PKG; + + TYPE RECA (D : INTEGER := 0) IS + RECORD + NULL; + END RECORD; + + TYPE RECB (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + RA1 : CONSTANT RECA (IDENT_INT (1)) := (D => (IDENT_INT (1))); + + RB12 : CONSTANT RECB := (IDENT_INT (1), IDENT_INT (2)); + + BEGIN + TEST ("C32113A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING A CONSTRAINED TYPE IS DECLARED WITH " & + "AN INITIAL VALUE, CONSTRAINT_ERROR IS " & + "RAISED IF THE CORRESPONDING DISCRIMINANTS " & + "OF THE INITIAL VALUE AND THE SUBTYPE DO " & + "NOT HAVE THE SAME VALUE" ); + + BEGIN + DECLARE + PR1 : CONSTANT PRIVA (IDENT_INT (0)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR1'" ); + IF PR1 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR1'" ); + END; + + BEGIN + DECLARE + PR2 : CONSTANT PRIVA (IDENT_INT (2)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR2'" ); + IF PR2 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR2'" ); + END; + + BEGIN + DECLARE + PR3 : PRIVA (IDENT_INT (0)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR3'" ); + IF PR3 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR3'" ); + END; + + BEGIN + DECLARE + PR4 : PRIVA (IDENT_INT (2)) := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR4'" ); + IF PR4 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR4'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVA IS PRIVA (IDENT_INT (-1)); + PR5 : CONSTANT SPRIVA := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR5'" ); + IF PR5 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR5'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVA IS PRIVA (IDENT_INT (3)); + PR6 : SPRIVA := PRA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR6'" ); + IF PR6 = PRA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR6'" ); + END; + + BEGIN + DECLARE + PR7 : CONSTANT PRIVB (IDENT_INT (1), IDENT_INT (1)) := + PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR7'" ); + IF PR7 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR7'" ); + END; + + BEGIN + DECLARE + PR8 : CONSTANT PRIVB (IDENT_INT (2), IDENT_INT (2)) := + PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR8'" ); + IF PR8 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR8'" ); + END; + + BEGIN + DECLARE + PR9 : PRIVB (IDENT_INT (1), IDENT_INT (1)) := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR9'" ); + IF PR9 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR9'" ); + END; + + BEGIN + DECLARE + PR10 : PRIVB (IDENT_INT (2), IDENT_INT (2)) := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR10'" ); + IF PR10 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR10'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVB IS + PRIVB (IDENT_INT (-1), IDENT_INT (-2)); + PR11 : CONSTANT SPRIVB := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR11'" ); + IF PR11 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'PR11'" ); + END; + + BEGIN + DECLARE + SUBTYPE SPRIVB IS PRIVB (IDENT_INT (2), IDENT_INT (1)); + PR12 : SPRIVB := PRB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR12'" ); + IF PR12 = PRB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'PR12'" ); + END; + + BEGIN + DECLARE + R1 : CONSTANT RECA (IDENT_INT (0)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R1'" ); + IF R1 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R1'" ); + END; + + BEGIN + DECLARE + R2 : CONSTANT RECA (IDENT_INT (2)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R2'" ); + IF R2 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R2'" ); + END; + + BEGIN + DECLARE + R3 : RECA (IDENT_INT (0)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R3'" ); + IF R3 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R3'" ); + END; + + BEGIN + DECLARE + R4 : RECA (IDENT_INT (2)) := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R4'" ); + IF R4 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R4'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECA IS RECA (IDENT_INT (-1)); + R5 : CONSTANT SRECA := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R5'" ); + IF R5 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R5'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECA IS RECA (IDENT_INT (3)); + R6 : SRECA := RA1; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R6'" ); + IF R6 = RA1 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R6'" ); + END; + + BEGIN + DECLARE + R7 : CONSTANT RECB (IDENT_INT (1), IDENT_INT (1)) := + RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R7'" ); + IF R7 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R7'" ); + END; + + BEGIN + DECLARE + R8 : CONSTANT RECB (IDENT_INT (2), IDENT_INT (2)) := + RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R8'" ); + IF R8 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R8'" ); + END; + + BEGIN + DECLARE + R9 : RECB (IDENT_INT (1), IDENT_INT (1)) := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R9'" ); + IF R9 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R9'" ); + END; + + BEGIN + DECLARE + R10 : RECB (IDENT_INT (2), IDENT_INT (2)) := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R10'" ); + IF R10 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R10'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECB IS + RECB (IDENT_INT (-1), IDENT_INT (-2)); + R11 : CONSTANT SRECB := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R11'" ); + IF R11 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'R11'" ); + END; + + BEGIN + DECLARE + SUBTYPE SRECB IS RECB (IDENT_INT (2), IDENT_INT (1)); + R12 : SRECB := RB12; + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R12'" ); + IF R12 = RB12 THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'R12'" ); + END; + + RESULT; + END C32113A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32115a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32115a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32115a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32115a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- C32115A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING A CONSTRAINED + -- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE, + -- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT + -- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING + -- VALUE SPECIFIED FOR THE ACCESS SUBTYPE. + + -- HISTORY: + -- RJW 07/20/86 CREATED ORIGINAL TEST. + -- JET 08/05/87 ADDED DEFEAT OF DEAD VARIABLE OPTIMIZATION. + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C32115A IS + + PACKAGE PKG IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + TYPE ACCP IS ACCESS PRIV (IDENT_INT (1)); + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC (IDENT_INT (2)); + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE ACCA IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (2)); + + TYPE ACCN IS ACCESS ARR (IDENT_INT (1) .. IDENT_INT (0)); + + BEGIN + TEST ("C32115A", "CHECK THAT WHEN A VARIABLE OR CONSTANT " & + "HAVING A CONSTRAINED ACCESS TYPE IS " & + "DECLARED WITH AN INITIAL NON-NULL ACCESS " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " & + "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " & + "DESIGNATED OBJECT DOES NOT EQUAL THE " & + "CORRESPONDING VALUE SPECIFIED FOR THE " & + "ACCESS SUBTYPE" ); + + BEGIN + DECLARE + AC1 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (2))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + IF AC1 /= NULL THEN + COMMENT ("DEFEAT 'AC1' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + END; + + BEGIN + DECLARE + AC2 : ACCP := NEW PRIV (D => (IDENT_INT (2))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + IF AC2 /= NULL THEN + COMMENT ("DEFEAT 'AC2' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + END; + + BEGIN + DECLARE + AC3 : CONSTANT ACCP := NEW PRIV (D => (IDENT_INT (0))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + IF AC3 /= NULL THEN + COMMENT ("DEFEAT 'AC3' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + END; + + BEGIN + DECLARE + AC4 : ACCP := NEW PRIV (D => (IDENT_INT (0))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + IF AC4 /= NULL THEN + COMMENT ("DEFEAT 'AC4' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + END; + + BEGIN + DECLARE + AC5 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (1))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + IF AC5 /= NULL THEN + COMMENT ("DEFEAT 'AC5' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + END; + + BEGIN + DECLARE + AC6 : ACCR := NEW REC' (D => (IDENT_INT (1))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + IF AC6 /= NULL THEN + COMMENT ("DEFEAT 'AC6' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + END; + + BEGIN + DECLARE + AC7 : CONSTANT ACCR := NEW REC'(D => (IDENT_INT (3))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + IF AC7 /= NULL THEN + COMMENT ("DEFEAT 'AC7' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + END; + + BEGIN + DECLARE + AC8 : ACCR := NEW REC' (D => (IDENT_INT (3))); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + IF AC8 /= NULL THEN + COMMENT ("DEFEAT 'AC8' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + END; + + BEGIN + DECLARE + AC9 : CONSTANT ACCA := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + IF AC9 /= NULL THEN + COMMENT ("DEFEAT 'AC9' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + END; + + BEGIN + DECLARE + AC10 : ACCA := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (1) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + IF AC10 /= NULL THEN + COMMENT ("DEFEAT 'AC10' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + END; + + BEGIN + DECLARE + AC11 : CONSTANT ACCA := + NEW ARR' (IDENT_INT (0) .. IDENT_INT (2) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + IF AC11 /= NULL THEN + COMMENT ("DEFEAT 'AC11' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + END; + + BEGIN + DECLARE + AC12 : ACCA := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (2) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + IF AC12 /= NULL THEN + COMMENT ("DEFEAT 'AC12' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + END; + + + BEGIN + DECLARE + AC15 : CONSTANT ACCN := + NEW ARR' (IDENT_INT (0) .. IDENT_INT (0) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + IF AC15 /= NULL THEN + COMMENT ("DEFEAT 'AC15' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + END; + + BEGIN + DECLARE + AC16 : ACCN := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (0) => 0); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + IF AC16 /= NULL THEN + COMMENT ("DEFEAT 'AC16' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + END; + + RESULT; + END C32115A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32115b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32115b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c32115b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c32115b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,376 ---- + -- C32115B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A VARIABLE OR CONSTANT HAVING AN UNCONSTRAINED + -- ACCESS TYPE IS DECLARED WITH AN INITIAL NON-NULL ACCESS VALUE, + -- CONSTRAINT_ERROR IS RAISED IF AN INDEX BOUND OR A DISCRIMINANT + -- VALUE OF THE DESIGNATED OBJECT DOES NOT EQUAL THE CORRESPONDING + -- VALUE SPECIFIED FOR THE ACCESS SUBTYPE OF THE OBJECT. + + -- HISTORY: + -- JET 08/05/87 CREATED ORIGINAL TEST BASED ON C32115A BY RJW + -- BUT WITH UNCONSTRAINED ACCESS TYPES AND + -- CONSTRAINED VARIABLE/CONSTANT DECLARATIONS. + -- KAS 12/4/95 FIXED TYPO IN CALL TO REPORT.TEST + + WITH REPORT; USE REPORT; + + PROCEDURE C32115B IS + + PACKAGE PKG IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + TYPE ACCP IS ACCESS PRIV; + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + TYPE ACCN IS ACCESS ARR; + + BEGIN + TEST ("C32115B", "CHECK THAT WHEN CONSTRAINED VARIABLE OR " & + "CONSTANT HAVING AN UNCONSTRAINED ACCESS TYPE " & + "IS DECLARED WITH AN INITIAL NON-NULL ACCESS " & + "VALUE, CONSTRAINT_ERROR IS RAISED IF AN " & + "INDEX BOUND OR A DISCRIMINANT VALUE OF THE " & + "DESIGNATED OBJECT DOES NOT EQUAL THE " & + "CORRESPONDING VALUE SPECIFIED FOR THE " & + "ACCESS SUBTYPE OF THE OBJECT" ); + + BEGIN + DECLARE + AC1 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + IF AC1 /= NULL THEN + COMMENT ("DEFEAT 'AC1' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC1'" ); + END; + + BEGIN + DECLARE + AC2 : ACCP(1) := NEW PRIV (IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + IF AC2 /= NULL THEN + COMMENT ("DEFEAT 'AC2' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC2'" ); + END; + + BEGIN + DECLARE + AC3 : CONSTANT ACCP(1) := NEW PRIV (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + IF AC3 /= NULL THEN + COMMENT ("DEFEAT 'AC3' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC3'" ); + END; + + BEGIN + DECLARE + AC4 : ACCP(1) := NEW PRIV (IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + IF AC4 /= NULL THEN + COMMENT ("DEFEAT 'AC4' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC4'" ); + END; + + BEGIN + DECLARE + AC5 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + IF AC5 /= NULL THEN + COMMENT ("DEFEAT 'AC5' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC5'" ); + END; + + BEGIN + DECLARE + AC6 : ACCR(2) := NEW REC (IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + IF AC6 /= NULL THEN + COMMENT ("DEFEAT 'AC6' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC6'" ); + END; + + BEGIN + DECLARE + AC7 : CONSTANT ACCR(2) := NEW REC(IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + IF AC7 /= NULL THEN + COMMENT ("DEFEAT 'AC7' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC7'" ); + END; + + BEGIN + DECLARE + AC8 : ACCR(2) := NEW REC (IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + IF AC8 /= NULL THEN + COMMENT ("DEFEAT 'AC8' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC8'" ); + END; + + BEGIN + DECLARE + AC9 : CONSTANT ACCA(1 .. 2) := + NEW ARR(IDENT_INT(1) .. IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + IF AC9 /= NULL THEN + COMMENT ("DEFEAT 'AC9' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC9'" ); + END; + + BEGIN + DECLARE + AC10 : ACCA (1..2) := + NEW ARR(IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + IF AC10 /= NULL THEN + COMMENT ("DEFEAT 'AC10' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC10'" ); + END; + + BEGIN + DECLARE + AC11 : CONSTANT ACCA(1..2) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + IF AC11 /= NULL THEN + COMMENT ("DEFEAT 'AC11' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC11'" ); + END; + + BEGIN + DECLARE + AC12 : ACCA(1..2) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (2)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + IF AC12 /= NULL THEN + COMMENT ("DEFEAT 'AC12' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC12'" ); + END; + + BEGIN + DECLARE + AC13 : CONSTANT ACCA (1..2) := + NEW ARR(IDENT_INT (2) .. IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC13'" ); + IF AC13 /= NULL THEN + COMMENT ("DEFEAT 'AC13' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC13'" ); + END; + + BEGIN + DECLARE + AC14 : ACCA(1..2) := + NEW ARR(IDENT_INT (2) .. IDENT_INT (3)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC14'" ); + IF AC14 /= NULL THEN + COMMENT ("DEFEAT 'AC14' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC14'" ); + END; + + BEGIN + DECLARE + AC15 : CONSTANT ACCN(1..0) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + IF AC15 /= NULL THEN + COMMENT ("DEFEAT 'AC15' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF CONSTANT 'AC15'" ); + END; + + BEGIN + DECLARE + AC16 : ACCN(1..0) := + NEW ARR(IDENT_INT (0) .. IDENT_INT (0)); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + IF AC16 /= NULL THEN + COMMENT ("DEFEAT 'AC16' OPTIMIZATION"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INITIALIZATION " & + "OF VARIABLE 'AC16'" ); + END; + + RESULT; + END C32115B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c330001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c330001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c330001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c330001.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,354 ---- + -- C330001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a variable object of an indefinite type is properly + -- initialized/constrained by an initial value assignment that is + -- a) an aggregate, b) a function, or c) an object. Check that objects + -- of the above types do not need explicit constraints if they have + -- initial values. + -- + -- TEST DESCRIPTION: + -- An indefinite subtype is either: + -- a) An unconstrained array subtype. + -- b) A subtype with unknown discriminants. + -- c) A subtype with unconstrained discriminants without defaults. + -- + -- Declare several indefinite types in a parent package specification. + -- In the private part, complete one type with a discriminant without + -- default (indefinite) and the other with a default discriminant + -- (definite). Declare objects of both indefinite and definite subtypes + -- in children (private and public) with initialization expressions. The + -- test verifies all values of the objects. It also verifies that + -- Constraint_Error is raised if an attempt is made to change the + -- discriminants of the objects of the indefinite subtypes. + -- + -- + -- CHANGE HISTORY: + -- 15 Jan 95 SAIC Initial version for ACVC 2.1 + -- 25 Jul 96 SAIC Modified test description. Deleted use C330001_0. + -- 20 Nov 98 RLB Added Elaborate pragmas to avoid problems + -- with an unconventional, but legal, elaboration + -- order. + --! + + package C330001_0 is + + subtype Sub_Type is Integer range 1 .. 20; + + type Tag_W_Disc (D : Sub_Type) is tagged record + C1 : String (1 .. D); + end record; + + -- Indefinite type declarations. + + type FullViewDefinite_Unknown_Disc (<>) is private; + + type Indefinite_No_Disc is array (Positive range <>) of Integer; + + type Indefinite_Tag_W_Disc (D : Sub_Type) is tagged + record + C1 : Boolean := False; + end record; + + type Indefinite_New_W_Disc (ND : Sub_Type) is new + Indefinite_Tag_W_Disc (ND) with record + C2 : Integer := 9; + end record; + + type Indefinite_W_Inherit_Disc_1 is new Tag_W_Disc with + record + S : Sub_Type := 18; + end record; + + type Indefinite_W_Inherit_Disc_2 is + new Tag_W_Disc with private; + + function Indef_Func_1 return FullViewDefinite_Unknown_Disc; + + function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2; + + private + + type FullViewDefinite_Unknown_Disc (D : Sub_Type := 2) is + record + S : String (1 .. D) := "Hi"; + end record; + + type Indefinite_W_Inherit_Disc_2 is new Tag_W_Disc with + record + S : Sub_Type; + end record; + + end C330001_0; + + --==================================================================-- + + package body C330001_0 is + + function Indef_Func_1 return FullViewDefinite_Unknown_Disc is + Var_1 : FullViewDefinite_Unknown_Disc; -- No need for explicit + -- constraints, use initial + begin -- values. + return Var_1; + end Indef_Func_1; + + ------------------------------------------------------------------ + function Indef_Func_2 (P : Sub_Type) return Indefinite_W_Inherit_Disc_2 is + Var_2 : Indefinite_W_Inherit_Disc_2 := (D => 5, C1 => "Hello", S => P); + begin + return Var_2; + end Indef_Func_2; + + end C330001_0; + + --==================================================================-- + + with C330001_0; + pragma Elaborate(C330001_0); -- Insure that the functions can be called. + private + package C330001_0.C330001_1 is + + PrivateChild_Obj : Tag_W_Disc := (D => 4, C1 => "ACVC"); + + PrivateChild_Obj_01 : Indefinite_W_Inherit_Disc_1 + := Indefinite_W_Inherit_Disc_1'(PrivateChild_Obj with S => 15); + + -- Since full view of Indefinite_W_Inherit_Disc_2 is indefinite in + -- the parent package, Indefinite_W_Inherit_Disc_2 needs an initialization + -- expression. + + PrivateChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (19); + + -- Since full view of FullViewDefinite_Unknown_Disc is definite in the + -- parent package, no initialization expression needed for + -- PrivateChild_Obj_03. + + PrivateChild_Obj_03 : FullViewDefinite_Unknown_Disc; + + PrivateChild_Obj_04 : Indefinite_No_Disc := (12, 15); + + end C330001_0.C330001_1; + + --==================================================================-- + + with C330001_0; + pragma Elaborate(C330001_0); -- Insure that the functions can be called. + package C330001_0.C330001_2 is + + PublicChild_Obj_01 : FullViewDefinite_Unknown_Disc := Indef_Func_1; + + PublicChild_Obj_02 : Indefinite_W_Inherit_Disc_2 := Indef_Func_2 (4); + + PublicChild_Obj_03 : Indefinite_No_Disc := (38, 72, 21, 59); + + PublicChild_Obj_04 : Indefinite_Tag_W_Disc := (D => 7, C1 => True); + + PublicChild_Obj_05 : Indefinite_Tag_W_Disc := PublicChild_Obj_04; + + PublicChild_Obj_06 : Indefinite_New_W_Disc (6); + + procedure Assign_Private_Obj_3; + + function Raised_CE_PublicChild_Obj return Boolean; + + function Raised_CE_PrivateChild_Obj return Boolean; + + -- The following functions check the private types defined in the parent + -- and the private child package from within the client program. + + function Verify_Public_Obj_1 return Boolean; + + function Verify_Public_Obj_2 return Boolean; + + function Verify_Private_Obj_1 return Boolean; + + function Verify_Private_Obj_2 return Boolean; + + function Verify_Private_Obj_3 return Boolean; + + end C330001_0.C330001_2; + + --==================================================================-- + + with Report; + with C330001_0.C330001_1; + package body C330001_0.C330001_2 is + + procedure Assign_Private_Obj_3 is + begin + C330001_0.C330001_1.PrivateChild_Obj_03 := (5, "Aloha"); + end Assign_Private_Obj_3; + + ------------------------------------------------------------------ + function Raised_CE_PublicChild_Obj return Boolean is + begin + PublicChild_Obj_03 := (16, 13); -- C_E, can't change constraints + -- of PublicChild_Obj_03. + + Report.Failed ("Constraint_Error not raised - Public child"); + + -- Next line prevents dead assignment. + + Report.Comment ("PublicChild_Obj_03'First is" & Integer'Image + (PublicChild_Obj_03'First) ); + return False; + + exception + when Constraint_Error => + return True; -- Exception is expected. + when others => + return False; + end Raised_CE_PublicChild_Obj; + + ------------------------------------------------------------------ + function Raised_CE_PrivateChild_Obj return Boolean is + begin + C330001_0.C330001_1.PrivateChild_Obj_04 := (21, 87, 18); + -- C_E, can't change constraints + -- of PrivateChild_Obj_04. + + Report.Failed ("Constraint_Error not raised - Private child"); + + -- Next line prevents dead assignment. + + Report.Comment ("PrivateChild_Obj_04'Last is" & Integer'Image + (C330001_0.C330001_1.PrivateChild_Obj_04'Last) ); + return False; + + exception + when Constraint_Error => + return True; -- Exception is expected. + when others => + return False; + end Raised_CE_PrivateChild_Obj; + + ------------------------------------------------------------------ + function Verify_Public_Obj_1 return Boolean is + begin + return (PublicChild_Obj_01.D = 2 and PublicChild_Obj_01.S = "Hi"); + + end Verify_Public_Obj_1; + + ------------------------------------------------------------------ + function Verify_Public_Obj_2 return Boolean is + begin + return (PublicChild_Obj_02.D = 5 and + PublicChild_Obj_02.C1 = "Hello" and + PublicChild_Obj_02.S = 4); + + end Verify_Public_Obj_2; + + ------------------------------------------------------------------ + function Verify_Private_Obj_1 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_01.D = 4 and + C330001_0.C330001_1.PrivateChild_Obj_01.C1 = "ACVC" and + C330001_0.C330001_1.PrivateChild_Obj_01.S = 15); + + end Verify_Private_Obj_1; + + ------------------------------------------------------------------ + function Verify_Private_Obj_2 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_02.D = 5 and + C330001_0.C330001_1.PrivateChild_Obj_02.C1 = "Hello" and + C330001_0.C330001_1.PrivateChild_Obj_02.S = 19); + + end Verify_Private_Obj_2; + + ------------------------------------------------------------------ + function Verify_Private_Obj_3 return Boolean is + begin + return (C330001_0.C330001_1.PrivateChild_Obj_03.D = 5 and + C330001_0.C330001_1.PrivateChild_Obj_03.S = "Aloha"); + + end Verify_Private_Obj_3; + + end C330001_0.C330001_2; + + --==================================================================-- + + with C330001_0.C330001_2; + with Report; + + use C330001_0.C330001_2; + + procedure C330001 is + begin + Report.Test ("C330001", "Check that a variable object of an indefinite " & + "type is properly initialized/constrained by an initial " & + "value assignment that is a) an aggregate, b) a function, " & + "or c) an object. Check that objects of the above types " & + "do not need explicit constraints if they have initial " & + "values"); + + -- Verify values of public child objects. + + if not (Verify_Public_Obj_1 and Verify_Public_Obj_2) then + Report.Failed ("Wrong values for PublicChild_Obj_01 or " & + "PublicChild_Obj_02"); + end if; + + if PublicChild_Obj_03'First /= 1 or + PublicChild_Obj_03'Last /= 4 then + Report.Failed ("Wrong values for PublicChild_Obj_03"); + end if; + + if PublicChild_Obj_05.D /= 7 or + not PublicChild_Obj_05.C1 then + Report.Failed ("Wrong values for PublicChild_Obj_05"); + end if; + + if PublicChild_Obj_06.ND /= 6 or + PublicChild_Obj_06.C2 /= 9 or + PublicChild_Obj_06.C1 then + Report.Failed ("Wrong values for PublicChild_Obj_06"); + end if; + + -- Definite object can have its discriminant changed by assignment to + -- the entire object. + + Assign_Private_Obj_3; + + -- Verify values of private child objects. + + if not Verify_Private_Obj_1 or not + Verify_Private_Obj_2 or not + Verify_Private_Obj_3 then + Report.Failed ("Wrong values for PrivateChild_Obj_01 or " & + "PrivateChild_Obj_02 or PrivateChild_Obj_03"); + end if; + + -- Attempt to change the discriminants of the objects of the indefinite + -- subtypes: Constraint_Error. + + if not Raised_CE_PublicChild_Obj or not Raised_CE_PrivateChild_Obj then + Report.Failed ("Constraint_Error not raised"); + end if; + + Report.Result; + + end C330001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c330002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c330002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c330002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c330002.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,326 ---- + -- C330002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a subtype indication of a variable object defines an + -- indefinite subtype, then there is an initialization expression. + -- Check that the object remains so constrained throughout its lifetime. + -- Check for cases of tagged record, arrays and generic formal type. + -- + -- TEST DESCRIPTION: + -- An indefinite subtype is either: + -- a) An unconstrained array subtype. + -- b) A subtype with unknown discriminants (this includes class-wide + -- types). + -- c) A subtype with unconstrained discriminants without defaults. + -- + -- Declare tagged types with unconstrained discriminants without + -- defaults. Declare an unconstrained array. Declare a generic formal + -- type with an unknown discriminant and a formal object of this type. + -- In the generic package, declare an object of the formal type using + -- the formal object as its initial value. In the main program, + -- declare objects of tagged types. Instantiate the generic package. + -- The test checks that Constraint_Error is raised if an attempt is + -- made to change bounds as well as discriminants of the objects of the + -- indefinite subtypes. + -- + -- + -- CHANGE HISTORY: + -- 01 Nov 95 SAIC Initial prerelease version. + -- 27 Jul 96 SAIC Modified test description & Report.Test. Added + -- code to prevent dead variable optimization. + -- + --! + + package C330002_0 is + + subtype Small_Num is Integer range 1 .. 20; + + -- Types with unconstrained discriminants without defaults. + + type Tag_Type (Disc : Small_Num) is tagged + record + S : String (1 .. Disc); + end record; + + function Tag_Value return Tag_Type; + + procedure Assign_Tag (A : out Tag_Type); + + procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String); + + --------------------------------------------------------------------- + -- An unconstrained array type. + + type Array_Type is array (Positive range <>) of Integer; + + function Array_Value return Array_Type; + + procedure Assign_Array (A : out Array_Type); + + --------------------------------------------------------------------- + generic + -- Type with an unknown discriminant. + type Formal_Type (<>) is private; + FT_Obj : Formal_Type; + package Gen is + Gen_Obj : Formal_Type := FT_Obj; + end Gen; + + end C330002_0; + + --==================================================================-- + + with Report; + package body C330002_0 is + + procedure Assign_Tag (A : out Tag_Type) is + begin + A := (3, "Bye"); + end Assign_Tag; + + ---------------------------------------------------------------------- + procedure Avoid_Optimization_and_Fail (P : Tag_Type; Msg : String) is + Default : Tag_Type := (1, "!"); -- Unique value. + begin + if P = Default then -- Both If branches can't do the same thing. + Report.Failed (Msg & ": Constraint_Error not raised"); + else -- Subtests should always select this path. + Report.Failed ("Constraint_Error not raised " & Msg); + end if; + end Avoid_Optimization_and_Fail; + + ---------------------------------------------------------------------- + function Tag_Value return Tag_Type is + TO : Tag_Type := (4 , "ACVC"); + begin + return TO; + end Tag_Value; + + ---------------------------------------------------------------------- + function Array_Value return Array_Type is + IA : Array_Type := (20, 31); + begin + return IA; + end Array_Value; + + ---------------------------------------------------------------------- + procedure Assign_Array (A : out Array_Type) is + begin + A := (84, 36); + end Assign_Array; + + end C330002_0; + + --==================================================================-- + + with Report; + with C330002_0; + use C330002_0; + + procedure C330002 is + + begin + Report.Test ("C330002", "Check that if a subtype indication of a " & + "variable object defines an indefinite subtype, then " & + "there is an initialization expression. Check that " & + "the object remains so constrained throughout its " & + "lifetime. Check that Constraint_Error is raised " & + "if an attempt is made to change bounds as well as " & + "discriminants of the objects of the indefinite " & + "subtypes. Check for cases of tagged record and generic " & + "formal types"); + + TagObj_Block: + declare + TObj_ByAgg : Tag_Type := (5, "Hello"); -- Initial assignment is + -- aggregate. + TObj_ByObj : Tag_Type := TObj_ByAgg; -- Initial assignment is + -- an object. + TObj_ByFunc : Tag_Type := Tag_Value; -- Initial assignment is + -- function return value. + Ren_Obj : Tag_Type renames TObj_ByAgg; + + begin + + begin + if (TObj_ByAgg.Disc /= 5) or (TObj_ByAgg.S /= "Hello") then + Report.Failed ("Wrong initial values for TObj_ByAgg"); + end if; + + TObj_ByAgg := (2, "Hi"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByAgg, "Subtest 1"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 1"); + end; + + + begin + Assign_Tag (Ren_Obj); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (Ren_Obj, "Subtest 2"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 2"); + end; + + + begin + if (TObj_ByObj.Disc /= 5) or (TObj_ByObj.S /= "Hello") then + Report.Failed ("Wrong initial values for TObj_ByObj"); + end if; + + TObj_ByObj := (3, "Bye"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByObj, "Subtest 3"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 3"); + end; + + + begin + if (TObj_ByFunc.Disc /= 4) or (TObj_ByFunc.S /= "ACVC") then + Report.Failed ("Wrong initial values for TObj_ByFunc"); + end if; + + TObj_ByFunc := (5, "Aloha"); -- C_E, can't change the + -- value of the discriminant. + + Avoid_Optimization_and_Fail (TObj_ByFunc, "Subtest 4"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 4"); + end; + + end TagObj_Block; + + + ArrObj_Block: + declare + Arr_Const : constant Array_Type + := (9, 7, 6, 8); + Arr_ByAgg : Array_Type -- Initial assignment is + := (10, 11, 12); -- aggregate. + Arr_ByFunc : Array_Type -- Initial assignment is + := Array_Value; -- function return value. + Arr_ByObj : Array_Type -- Initial assignment is + := Arr_ByAgg; -- object. + + Arr_Obj : array (Positive range <>) of Integer + := (1, 2, 3, 4, 5); + begin + + begin + if (Arr_Const'First /= 1) or (Arr_Const'Last /= 4) then + Report.Failed ("Wrong bounds for Arr_Const"); + end if; + + if (Arr_ByAgg'First /= 1) or (Arr_ByAgg'Last /= 3) then + Report.Failed ("Wrong bounds for Arr_ByAgg"); + end if; + + if (Arr_ByFunc'First /= 1) or (Arr_ByFunc'Last /= 2) then + Report.Failed ("Wrong bounds for Arr_ByFunc"); + end if; + + if (Arr_ByObj'First /= 1) or (Arr_ByObj'Last /= 3) then + Report.Failed ("Wrong bounds for Arr_ByObj"); + end if; + + Assign_Array (Arr_ByObj); -- C_E, Arr_ByObj bounds are + -- 1..3. + + Report.Failed ("Constraint_Error not raised - Subtest 5"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 5"); + end; + + + begin + if (Arr_Obj'First /= 1) or (Arr_Obj'Last /= 5) then + Report.Failed ("Wrong bounds for Arr_Obj"); + end if; + + for I in 0 .. 5 loop + Arr_Obj (I + 1) := I + 5; -- C_E, Arr_Obj bounds are + end loop; -- 1..5. + + Report.Failed ("Constraint_Error not raised - Subtest 6"); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 6"); + end; + + end ArrObj_Block; + + + GenericObj_Block: + declare + type Rec (Disc : Small_Num) is + record + S : Small_Num := Disc; + end record; + + Rec_Obj : Rec := (2, 2); + package IGen is new Gen (Rec, Rec_Obj); + + begin + IGen.Gen_Obj := (3, 3); -- C_E, can't change the + -- value of the discriminant. + + Report.Failed ("Constraint_Error not raised - Subtest 7"); + + -- Next line prevents dead assignment. + Report.Comment ("Disc is" & Integer'Image (IGen.Gen_Obj.Disc)); + + exception + when Constraint_Error => null; -- Exception is expected. + when others => + Report.Failed ("Unexpected exception - Subtest 7"); + + end GenericObj_Block; + + Report.Result; + + end C330002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c332001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c332001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c332001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c332001.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- C332001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the static expression given for a number declaration may be + -- of any numeric type. Check that the type of a named number is + -- universal_integer or universal_real regardless of the type of the + -- static expression that provides its value. + -- + -- TEST DESCRIPTION: + -- This test defines a large cross section of mixed type named numbers. + -- Well, obviously the named numbers don't have types (other than + -- universal_integer and universal_real) associated with them. + -- This test uses typed static values in the definition of several named + -- numbers, and then mixes the named numbers to ensure that their typed + -- origins do not interfere with the use of their values. + -- + -- + -- CHANGE HISTORY: + -- 10 OCT 95 SAIC Initial version + -- 11 APR 96 SAIC Fixed a few arithmetic errors for 2.1 + -- 24 NOV 98 RLB Removed decimal types to insure that this + -- test is applicable to all implementations. + -- + --! + + ----------------------------------------------------------------- C332001_0 + + package C332001_0 is + + type Enumeration_Type is ( Ah, Gnome, Er, Ay, Shun ); + + type Integer_Type is range 0..1023; + + type Modular_Type is mod 256; + + type Floating_Type is digits 4; + + type Fixed_Type is delta 0.125 range -10.0 .. 10.0; + + type Mod_Array is array(Modular_Type) of Floating_Type; + + type Int_Array is array(Integer_Type) of Fixed_Type; + + type Record_Type is record + Pinkie : Integer_Type; + Ring : Modular_Type; + Middle : Floating_Type; + Index : Fixed_Type; + end record; + + Mod_Array_Object : Mod_Array; + Int_Array_Object : Int_Array; + + Record_Object : Record_Type; + + -- numeric_literals + + Nothing_New_Integer : constant := 1; + Nothing_New_Real : constant := 1.0; + + -- static constants + + Integ : constant Integer_Type := 2; + Modul : constant Modular_Type := 2; + Float : constant Floating_Type := 2.0; -- bad practice, good test + Fixed : constant Fixed_Type := 2.0; + + Named_Integer : constant := Integ; -- 2 + Named_Modular : constant := Modul; -- 2 + Named_Float : constant := Float; -- 2.0 + Named_Fixed : constant := Fixed; -- 2.0 + + -- function calls + -- parenthetical expressions + + Fn_Integer : constant := Integer_Type'Min(Integ * 2, 8); -- 4 + Fn_Modular : constant := Modular_Type'Max(Modul + 2, Modular_Type'First);--4 + Fn_Float : constant := (Float ** 2); -- 4.0 + Fn_Fixed : constant := - Fixed; -- -2.0 + -- attributes + + ITF : constant := Integer_Type'First; -- 0 + MTL : constant := Modular_Type'Last; -- 255 + MTM : constant := Modular_Type'Modulus; -- 256 + ENP : constant := Enumeration_Type'Pos(Ay); -- 3 + MTP : constant := Modular_Type'Pred(Modul); -- 1 + FTS : constant := Fixed_Type'Size; -- # impdef + ITS : constant := Integer_Type'Succ(Integ); -- 3 + + -- array attributes 'First, 'Last, 'Length + + MAFirst : constant := Mod_Array_Object'First; -- 0 + IALast : constant := Int_Array_Object'Last; -- 1023 + MAL : constant := Mod_Array_Object'Length; -- 255 + IAL : constant := Int_Array_Object'Length; -- 1024 + + -- type conversions + -- + -- F\T Int Mod Flt Fix + -- Int . X O X + -- Mod O . X O + -- Flt X O . X + -- Fix O X O . + + Int2Mod : constant := Modular_Type (Integ); -- 2 + Int2Fix : constant := Fixed_Type (Integ); -- 2.0 + Mod2Flt : constant := Floating_Type (Modul); -- 2.0 + Flt2Int : constant := Integer_Type(Float); -- 2 + Flt2Fix : constant := Fixed_Type (Float); -- 2.0 + Fix2Mod : constant := Modular_Type (Fixed); -- 2 + + procedure Check_Values; + + -- TRANSITION CHECKS + -- + -- The following were illegal in Ada83; they are now legal in Ada95 + -- + + Int_Base_First : constant := Integer'Base'First; -- # impdef + Int_First : constant := Integer'First; -- # impdef + Int_Last : constant := Integer'Last; -- # impdef + Int_Val : constant := Integer'Val(17); -- 17 + + -- END OF TRANSITION CHECKS + + end C332001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C332001_0 is + + procedure Assert( Truth : Boolean; Message: String ) is + begin + if not Truth then + Report.Failed("Assertion " & Message & " not true" ); + end if; + end Assert; + + procedure Check_Values is + begin + + Assert( Nothing_New_Integer * Named_Integer = Named_Modular, + "Nothing_New_Integer * Named_Integer = Named_Modular" ); -- 1*2 = 2 + Assert( Nothing_New_Real * Named_Float = Named_Fixed, + "Nothing_New_Real * Named_Float = Named_Fixed" );-- 1.0*2.0 = 2.0 + + Assert( Fn_Integer = Int2Mod + Flt2Int, + "Fn_Integer = Int2Mod + Flt2Int" ); -- 4 = 2+2 + Assert( Fn_Modular = Flt2Int * 2, + "Fn_Modular = Flt2Int * 2" ); -- 4 = 2*2 + Assert( Fn_Float = Mod2Flt ** Fix2Mod, + "Fn_Float = Mod2Flt ** Fix2Mod" ); -- 4.0 = 2.0**2 + Assert( Fn_Fixed = (- Mod2Flt), + "Fn_Fixed = (- Mod2Flt)" ); -- -2.0 = (-2.0) + + Assert( ITF = Modular_Type'First, + "ITF = Modular_Type'First" ); -- 0 = 0 + Assert( MTL < Integer_Type'Last, + "MTL < Integer_Type'Last" ); -- 255 < 1023 + Assert( MTM < Integer_Type'Last, + "MTM < Integer_Type'Last" ); -- 256 < 1023 + Assert( ENP > MTP, + "ENP > MTP" ); -- 3 > 1 + Assert( (FTS < MTL) or (FTS >= MTL), -- given FTS is impdef... + "(FTS < MTL) or (FTS >= MTL)" ); -- True + Assert( FTS > ITS, + "FTS > ITS" ); -- impdef > 3 + + Assert( MAFirst = Int_Array_Object'First, + "MAFirst = Int_Array_Object'First" ); -- 0 = 0 + Assert( IALast > MAFirst, + "IALast > MAFirst" ); -- 1023 > 0 + Assert( MAL < IAL, + "MAL < IAL" ); -- 255 < 1024 + + Assert( Mod2Flt = Flt2Fix, + "Mod2Flt = Flt2Fix" ); -- 2.0 = 2.0 + + end Check_Values; + + end C332001_0; + + ------------------------------------------------------------------- C332001 + + with Report; + with C332001_0; + procedure C332001 is + + begin -- Main test procedure. + + Report.Test ("C332001", "Check that the static expression given for a " & + "number declaration may be of any numeric type. " & + "Check that the type of the named number is " & + "universal_integer of universal_real regardless " & + "of the type of the static expression that " & + "provides its value" ); + + C332001_0.Check_Values; + + Report.Result; + + end C332001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340001.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,470 ---- + -- C340001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that user-defined equality operators are inherited by a + -- derived type except when the derived type is a nonlimited record + -- extension. In the latter case, ensure that the primitive + -- equality operation of the record extension compares any extended + -- components according to the predefined equality operators of the + -- component types. Also check that the parent portion of the extended + -- type is compared using the user-defined equality operation of the + -- parent type. + -- + -- TEST DESCRIPTION: + -- Declares a nonlimited tagged record and a limited tagged record + -- type, each in a separate package. A user-defined "=" operation is + -- defined for each type. Each type is extended with one new record + -- component added. + -- + -- Objects are declared for each parent and extended types and are + -- assigned values. For the limited type, modifier operations defined + -- in the package are used to assign values. + -- + -- To verify the use of the user-defined "=", values are assigned so + -- that predefined equality will return the opposite result if called. + -- Similarly, values are assigned to the extended type objects so that + -- one comparison will verify that the inherited components from the + -- parent are compared using the user-defined equality operation. + -- + -- A second comparison sets the values of the inherited components to + -- be the same so that equality based on the extended component may be + -- verified. For the nonlimited type, the test for equality should + -- fail, as the "=" defined for this type should include testing + -- equality of the extended component. For the limited type, "=" of the + -- parent should be inherited as-is, so the test for equality should + -- succeed even though the records differ in the extended component. + -- + -- A third package declares a discriminated tagged record. Equality + -- is user-defined and ignores the discriminant value. A type + -- extension is declared which also contains a discriminant. Since + -- an inherited discriminant may not be referenced other than in a + -- "new" discriminant, the type extension is also discriminated. The + -- discriminant is used as the constraint for the parent type. + -- + -- A variant part is declared in the type extension based on the new + -- discriminant. Comparisons are made to confirm that the user-defined + -- equality operator is used to compare values of the type extension. + -- Two record objects are given values so that user-defined equality + -- for the parent portion of the record succeeds, but the variant + -- parts in the type extended object differ. These objects are checked + -- to ensure that they are not equal. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- + --! + + with Ada.Calendar; + package C340001_0 is + + type DB_Record is tagged record + Key : Natural range 1 .. 9999; + Data : String (1..10); + end record; + + function "=" (L, R : in DB_Record) return Boolean; + + type Dated_Record is new DB_Record with record + Retrieval_Time : Ada.Calendar.Time; + end record; + + end C340001_0; + + package body C340001_0 is + + function "=" (L, R : in DB_Record) return Boolean is + -- Key is ignored in determining equality of records + begin + return L.Data = R.Data; + end "="; + + end C340001_0; + + package C340001_1 is + + type List_Contents is array (1..10) of Integer; + type List is tagged limited record + Length : Natural range 0..10 := 0; + Contents : List_Contents := (others => 0); + end record; + + procedure Add_To (L : in out List; New_Value : in Integer); + procedure Remove_From (L : in out List); + + function "=" (L, R : in List) return Boolean; + + subtype Revision_Mark is Character range 'A' .. 'Z'; + type Revisable_List is new List with record + Revision : Revision_Mark := 'A'; + end record; + + procedure Revise (L : in out Revisable_List); + + end C340001_1; + + package body C340001_1 is + + -- Note: This is not a complete abstraction of a list. Exceptions + -- are not defined and boundary checks are not made. + + procedure Add_To (L : in out List; New_Value : in Integer) is + begin + L.Length := L.Length + 1; + L.Contents (L.Length) := New_Value; + end Add_To; + + procedure Remove_From (L : in out List) is + -- The list length is decremented. "Old" values are left in the + -- array. They are overwritten when a new value is added. + begin + L.Length := L.Length - 1; + end Remove_From; + + function "=" (L, R : in List) return Boolean is + -- Two lists are equal if they are the same length and + -- the component values within that length are the same. + -- Values stored past the end of the list are ignored. + begin + return L.Length = R.Length + and then L.Contents (1..L.Length) = R.Contents (1..R.Length); + end "="; + + procedure Revise (L : in out Revisable_List) is + begin + L.Revision := Character'Succ (L.Revision); + end Revise; + + end C340001_1; + + package C340001_2 is + + type Media is (Paper, Electronic); + + type Transaction (Medium : Media) is tagged record + ID : Natural range 1000 .. 9999; + end record; + + function "=" (L, R : in Transaction) return Boolean; + + type Authorization (Kind : Media) is new Transaction (Medium => Kind) + with record + case Kind is + when Paper => + Signature_On_File : Boolean; + when Electronic => + Paper_Backup : Boolean; -- to retain opposing value + end case; + end record; + + end C340001_2; + + package body C340001_2 is + + function "=" (L, R : in Transaction) return Boolean is + -- There may be electronic and paper copies of the same transaction. + -- The ID uniquely identifies a transaction. The medium (stored in + -- the discriminant) is ignored. + begin + return L.ID = R.ID; + end "="; + + end C340001_2; + + + with C340001_0; -- nonlimited tagged record declarations + with C340001_1; -- limited tagged record declarations + with C340001_2; -- tagged variant declarations + with Ada.Calendar; + with Report; + procedure C340001 is + + DB_Rec1 : C340001_0.DB_Record := (Key => 1, + Data => "aaaaaaaaaa"); + DB_Rec2 : C340001_0.DB_Record := (Key => 55, + Data => "aaaaaaaaaa"); + -- DB_Rec1 = DB_Rec2 using user-defined equality + -- DB_Rec1 /= DB_Rec2 using predefined equality + + Some_Time : Ada.Calendar.Time := + Ada.Calendar.Time_Of (Month => 9, Day => 16, Year => 1993); + + Another_Time : Ada.Calendar.Time := + Ada.Calendar.Time_Of (Month => 9, Day => 19, Year => 1993); + + Dated_Rec1 : C340001_0.Dated_Record := (Key => 2, + Data => "aaaaaaaaaa", + Retrieval_Time => Some_Time); + Dated_Rec2 : C340001_0.Dated_Record := (Key => 77, + Data => "aaaaaaaaaa", + Retrieval_Time => Some_Time); + Dated_Rec3 : C340001_0.Dated_Record := (Key => 77, + Data => "aaaaaaaaaa", + Retrieval_Time => Another_Time); + -- Dated_Rec1 = Dated_Rec2 if DB_Record."=" used for parent portion + -- Dated_Rec2 /= Dated_Rec3 if extended component is compared + -- using Ada.Calendar.Time."=" + + List1 : C340001_1.List; + List2 : C340001_1.List; + + RList1 : C340001_1.Revisable_List; + RList2 : C340001_1.Revisable_List; + RList3 : C340001_1.Revisable_List; + + Current : C340001_2.Transaction (C340001_2.Paper) := + (C340001_2.Paper, 2001); + Last : C340001_2.Transaction (C340001_2.Electronic) := + (C340001_2.Electronic, 2001); + -- Current = Last using user-defined equality + -- Current /= Last using predefined equality + + Approval1 : C340001_2.Authorization (C340001_2.Paper) + := (Kind => C340001_2.Paper, + ID => 1040, + Signature_On_File => True); + Approval2 : C340001_2.Authorization (C340001_2.Paper) + := (Kind => C340001_2.Paper, + ID => 2167, + Signature_On_File => False); + Approval3 : C340001_2.Authorization (C340001_2.Electronic) + := (Kind => C340001_2.Electronic, + ID => 2167, + Paper_Backup => False); + -- Approval1 /= Approval2 if user-defined equality extended with + -- component equality. + -- Approval2 /= Approval3 if differing variant parts checked + + -- Direct visibility to operator symbols + use type C340001_0.DB_Record; + use type C340001_0.Dated_Record; + + use type C340001_1.List; + use type C340001_1.Revisable_List; + + use type C340001_2.Transaction; + use type C340001_2.Authorization; + + begin + + Report.Test ("C340001", "Inheritance of user-defined ""="""); + + -- Approval1 /= Approval2 if user-defined equality extended with + -- component equality. + -- Approval2 /= Approval3 if differing variant parts checked + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + + if not (DB_Rec1 = DB_Rec2) then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality did not override predefined " & + "equality"); + end if; + + if DB_Rec1 /= DB_Rec2 then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality did not override predefined " & + "inequality as well"); + end if; + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the type extension use the user-defined + -- equality operations from the parent to compare the inherited + -- components + --------------------------------------------------------------------- + + if not (Dated_Rec1 = Dated_Rec2) then + Report.Failed ("Nonlimited tagged record: " & + "User-defined equality was not used to compare " & + "components inherited from parent"); + end if; + + if Dated_Rec1 /= Dated_Rec2 then + Report.Failed ("Nonlimited tagged record: " & + "User-defined inequality was not used to compare " & + "components inherited from parent"); + end if; + + --------------------------------------------------------------------- + -- Check that equality and inequality for the type extension incorporate + -- the predefined equality operators for the extended component type + --------------------------------------------------------------------- + if Dated_Rec2 = Dated_Rec3 then + Report.Failed ("Nonlimited tagged record: " & + "Record equality was not extended with component " & + "equality"); + end if; + + if not (Dated_Rec2 /= Dated_Rec3) then + Report.Failed ("Nonlimited tagged record: " & + "Record inequality was not extended with component " & + "equality"); + end if; + + --------------------------------------------------------------------- + C340001_1.Add_To (List1, 1); + C340001_1.Add_To (List1, 2); + C340001_1.Add_To (List1, 3); + C340001_1.Remove_From (List1); + + C340001_1.Add_To (List2, 1); + C340001_1.Add_To (List2, 2); + + -- List1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0)) + -- List2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0)) + + -- List1 = List2 using user-defined equality + -- List1 /= List2 using predefined equality + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + if not (List1 = List2) then + Report.Failed ("Limited tagged record : " & + "User-defined equality incorrectly implemented " ); + end if; + + if List1 /= List2 then + Report.Failed ("Limited tagged record : " & + "User-defined equality incorrectly implemented " ); + end if; + + --------------------------------------------------------------------- + -- RList1 and RList2 are made equal but "different" by adding + -- a nonzero value to RList1 then removing it. Removal updates + -- the list Length only, not its contents. The two lists will be + -- equal according to the defined list abstraction, but the records + -- will contain differing component values. + + C340001_1.Add_To (RList1, 1); + C340001_1.Add_To (RList1, 2); + C340001_1.Add_To (RList1, 3); + C340001_1.Remove_From (RList1); + + C340001_1.Add_To (RList2, 1); + C340001_1.Add_To (RList2, 2); + + C340001_1.Add_To (RList3, 1); + C340001_1.Add_To (RList3, 2); + + C340001_1.Revise (RList3); + + -- RList1 contents are (2, (1, 2, 3, 0, 0, 0, 0, 0, 0, 0), 'A') + -- RList2 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'A') + -- RList3 contents are (2, (1, 2, 0, 0, 0, 0, 0, 0, 0, 0), 'B') + + -- RList1 = RList2 if List."=" inherited + -- RList2 /= RList3 if List."=" inherited and extended with Character "=" + + --------------------------------------------------------------------- + -- Check that "=" and "/=" are the user-defined operations inherited + -- from the parent type. + --------------------------------------------------------------------- + if not (RList1 = RList2) then + Report.Failed ("Limited tagged record : " & + "User-defined equality was not inherited"); + end if; + + if RList1 /= RList2 then + Report.Failed ("Limited tagged record : " & + "User-defined inequality was not inherited"); + end if; + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the type extension are NOT extended + -- with the predefined equality operators for the extended component. + -- A limited type extension should inherit the parent equality operation + -- as is. + --------------------------------------------------------------------- + if not (RList2 = RList3) then + Report.Failed ("Limited tagged record : " & + "Inherited equality operation was extended with " & + "component equality"); + end if; + + if RList2 /= RList3 then + Report.Failed ("Limited tagged record : " & + "Inherited inequality operation was extended with " & + "component equality"); + end if; + + --------------------------------------------------------------------- + -- Check that "=" and "/=" for the parent type call the user-defined + -- operation + --------------------------------------------------------------------- + if not (Current = Last) then + Report.Failed ("Variant record : " & + "User-defined equality did not override predefined " & + "equality"); + end if; + + if Current /= Last then + Report.Failed ("Variant record : " & + "User-defined inequality did not override predefined " & + "inequality"); + end if; + + --------------------------------------------------------------------- + -- Check that user-defined equality was incorporated and extended + -- with equality of extended components. + --------------------------------------------------------------------- + if not (Approval1 /= Approval2) then + Report.Failed ("Variant record : " & + "Inequality was not extended with component " & + "inequality"); + end if; + + if Approval1 = Approval2 then + Report.Failed ("Variant record : " & + "Equality was not extended with component " & + "equality"); + end if; + + --------------------------------------------------------------------- + -- Check that equality and inequality for the type extension + -- succeed despite the presence of differing variant parts. + --------------------------------------------------------------------- + if Approval2 = Approval3 then + Report.Failed ("Variant record : " & + "Equality succeeded even though variant parts " & + "in type extension differ"); + end if; + + if not (Approval2 /= Approval3) then + Report.Failed ("Variant record : " & + "Inequality failed even though variant parts " & + "in type extension differ"); + end if; + + --------------------------------------------------------------------- + Report.Result; + --------------------------------------------------------------------- + + end C340001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- C34001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES. + + -- JRK 8/20/86 + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34001A IS + + TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6); + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E2))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E5))); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E3))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E4))); + + X : T := E3; + W : PARENT := E1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + + BEGIN + TEST ("C34001A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES"); + + X := IDENT (E4); + IF X /= E4 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= E4 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= E4 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := E3; + END IF; + IF T (W) /= E3 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= E4 OR PARENT (T'VAL (0)) /= E1 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT ('A') /= 'A' THEN + FAILED ("INCORRECT 'A'"); + END IF; + + IF IDENT (E3) /= E3 OR IDENT (E4) = E1 THEN + FAILED ("INCORRECT ENUMERATION LITERAL"); + END IF; + + IF X = IDENT ('A') OR X = E1 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (E4) OR NOT (X /= E1) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (E4) OR X < E1 THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (E4) OR X > E6 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ('A') OR X <= E1 THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT ('A') >= X OR X >= E6 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR E1 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (E1 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 3 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= E3 OR T'BASE'FIRST /= E1 THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= "E4" OR T'IMAGE (E1) /= "E1" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= E4 OR T'BASE'LAST /= E6 THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 4 OR T'POS (E1) /= 0 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= 'A' OR T'PRED (E2) /= E1 THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 2 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 2 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (IDENT ('A')) /= X OR T'SUCC (E1) /= E2 THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (4)) /= X OR T'VAL (0) /= E1 THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("E4")) /= X OR T'VALUE ("E1") /= E1 THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 3 OR T'BASE'WIDTH /= 3 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; + END C34001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C34001C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 8/20/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34001C IS + + TYPE PARENT IS (E1, E2, E3, 'A', E4, E5, E6); + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (E3))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (E4))); + + SUBTYPE SUBPARENT IS PARENT RANGE E3 .. E4; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + BEGIN + TEST ("C34001C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ENUMERATION TYPES, EXCLUDING BOOLEAN TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'FIRST /= E1 OR T'BASE'LAST /= E6 OR + S'BASE'FIRST /= E1 OR S'BASE'LAST /= E6 THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (E2) /= E1 OR T'SUCC (E1) /= E2 OR + S'PRED (E2) /= E1 OR S'SUCC (E1) /= E2 THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= E3 OR T'LAST /= E4 OR + S'FIRST /= E3 OR S'LAST /= E4 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := E3; + Y := E3; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := E4; + Y := E4; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := E2; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E2"); + IF X = E2 THEN -- USE X. + COMMENT ("X ALTERED -- X := E2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := E2"); + END; + + BEGIN + X := E5; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := E5"); + IF X = E5 THEN -- USE X. + COMMENT ("X ALTERED -- X := E5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := E5"); + END; + + BEGIN + Y := E2; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E2"); + IF Y = E2 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := E2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := E2"); + END; + + BEGIN + Y := E5; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := E5"); + IF Y = E5 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := E5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := E5"); + END; + + RESULT; + END C34001C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C34001D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED BOOLEAN TYPES. + + -- JRK 8/20/86 + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34001D IS + + SUBTYPE PARENT IS BOOLEAN; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (TRUE))); + + X : T := TRUE; + W : PARENT := FALSE; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + + BEGIN + TEST ("C34001D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "BOOLEAN TYPES"); + + X := IDENT (TRUE); + IF X /= TRUE THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= TRUE THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= TRUE THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := TRUE; + END IF; + IF T (W) /= TRUE THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= TRUE OR PARENT (T'VAL (0)) /= FALSE THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (TRUE) /= TRUE OR IDENT (TRUE) = FALSE THEN + FAILED ("INCORRECT ENUMERATION LITERAL"); + END IF; + + IF NOT X /= FALSE OR NOT FALSE /= X THEN + FAILED ("INCORRECT ""NOT"""); + END IF; + + IF (X AND IDENT (TRUE)) /= TRUE OR (X AND FALSE) /= FALSE THEN + FAILED ("INCORRECT ""AND"""); + END IF; + + IF (X OR IDENT (TRUE)) /= TRUE OR (FALSE OR X) /= TRUE THEN + FAILED ("INCORRECT ""OR"""); + END IF; + + IF (X XOR IDENT (TRUE)) /= FALSE OR (X XOR FALSE) /= TRUE THEN + FAILED ("INCORRECT ""XOR"""); + END IF; + + IF (X AND THEN IDENT (TRUE)) /= TRUE OR + (X AND THEN FALSE) /= FALSE THEN + FAILED ("INCORRECT ""AND THEN"""); + END IF; + + IF (X OR ELSE IDENT (TRUE)) /= TRUE OR + (FALSE OR ELSE X) /= TRUE THEN + FAILED ("INCORRECT ""OR ELSE"""); + END IF; + + IF NOT (X = IDENT (TRUE)) OR X = FALSE THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (TRUE) OR NOT (X /= FALSE) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (TRUE) OR X < FALSE THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (TRUE) OR FALSE > X THEN + FAILED ("INCORRECT >"); + END IF; + + IF NOT (X <= IDENT (TRUE)) OR X <= FALSE THEN + FAILED ("INCORRECT <="); + END IF; + + IF NOT (X >= IDENT (TRUE)) OR FALSE >= X THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR FALSE IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (FALSE NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 1 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= TRUE OR T'BASE'FIRST /= FALSE THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= "TRUE" OR T'IMAGE (FALSE) /= "FALSE" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= TRUE OR T'BASE'LAST /= TRUE THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 1 OR T'POS (FALSE) /= 0 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= FALSE THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 1 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (T'VAL (IDENT_INT (0))) /= X THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (1)) /= X OR T'VAL (0) /= FALSE THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("TRUE")) /= X OR + T'VALUE ("FALSE") /= FALSE THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 4 OR T'BASE'WIDTH /= 5 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; + END C34001D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34001f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34001f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- C34001F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED BOOLEAN TYPES: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 8/20/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34001F IS + + SUBTYPE PARENT IS BOOLEAN; + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))) .. + PARENT'VAL (IDENT_INT (PARENT'POS (FALSE))); + + SUBTYPE SUBPARENT IS PARENT RANGE TRUE .. TRUE; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + BEGIN + TEST ("C34001F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "BOOLEAN TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'FIRST /= FALSE OR T'BASE'LAST /= TRUE OR + S'BASE'FIRST /= FALSE OR S'BASE'LAST /= TRUE THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (TRUE) /= FALSE OR T'SUCC (FALSE) /= TRUE OR + S'PRED (TRUE) /= FALSE OR S'SUCC (FALSE) /= TRUE THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= FALSE OR T'LAST /= FALSE OR + S'FIRST /= TRUE OR S'LAST /= TRUE THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := FALSE; + Y := TRUE; + IF NOT PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := TRUE; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := TRUE"); + IF X = TRUE THEN -- USE X. + COMMENT ("X ALTERED -- X := TRUE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := TRUE"); + END; + + BEGIN + Y := FALSE; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := FALSE"); + IF Y = FALSE THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := FALSE"); + END; + + RESULT; + END C34001F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34002a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,265 ---- + -- C34002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED INTEGER TYPES. + + -- JRK 8/21/86 + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34002A IS + + TYPE PARENT IS RANGE -100 .. 100; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT'VAL (IDENT_INT (-50)) .. + PARENT'VAL (IDENT_INT ( 50)); + + TYPE T IS NEW SUBPARENT RANGE + PARENT'VAL (IDENT_INT (-30)) .. + PARENT'VAL (IDENT_INT ( 30)); + + TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0; + + X : T := -30; + W : PARENT := -100; + N : CONSTANT := 1; + M : CONSTANT := 100; + B : BOOLEAN := FALSE; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (T'POS (X), T'POS (X)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + + BEGIN + TEST ("C34002A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "INTEGER TYPES"); + + X := IDENT (30); + IF X /= 30 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= 30 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30; + END IF; + IF T (W) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30 OR PARENT (T'VAL (-100)) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (T'VAL (-100)) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (T'VAL (-100)) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (T'VAL (-100)) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (N) /= 1 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30) /= 30 OR X = 100 THEN + FAILED ("INCORRECT INTEGER LITERAL"); + END IF; + + IF X = IDENT (0) OR X = 100 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30) OR NOT (X /= 100) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30) OR 100 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30) OR X > 100 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0) OR 100 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0) >= X OR X >= 100 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30 OR +T'VAL(-100) /= -100 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0 - 30 OR -T'VAL(-100) /= 100 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30 OR ABS T'VAL (-100) /= 100 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF X + IDENT (-1) /= 29 OR X + 70 /= 100 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30) /= 0 OR X - 100 /= -70 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF X * IDENT (-1) /= -30 OR IDENT (2) * 50 /= 100 THEN + FAILED ("INCORRECT *"); + END IF; + + IF X / IDENT (3) /= 10 OR 90 / X /= 3 THEN + FAILED ("INCORRECT /"); + END IF; + + IF X MOD IDENT (7) /= 2 OR 100 MOD X /= 10 THEN + FAILED ("INCORRECT MOD"); + END IF; + + IF X REM IDENT (7) /= 2 OR 100 REM X /= 10 THEN + FAILED ("INCORRECT REM"); + END IF; + + IF X ** IDENT_INT (1) /= 30 OR + T'VAL (100) ** IDENT_INT (1) /= 100 THEN + FAILED ("INCORRECT **"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 8 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'FIRST /= -30 OR + T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'IMAGE (X) /= " 30" OR T'IMAGE (-100) /= "-100" THEN + FAILED ("INCORRECT 'IMAGE"); + END IF; + + IF T'LAST /= 30 OR + T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'POS (X) /= 30 OR T'POS (-100) /= -100 THEN + FAILED ("INCORRECT 'POS"); + END IF; + + IF T'PRED (X) /= 29 OR T'PRED (100) /= 99 THEN + FAILED ("INCORRECT 'PRED"); + END IF; + + IF T'SIZE < 6 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 6 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'SUCC (IDENT (29)) /= X OR T'SUCC (99) /= 100 THEN + FAILED ("INCORRECT 'SUCC"); + END IF; + + IF T'VAL (IDENT_INT (30)) /= X OR T'VAL (100) /= 100 THEN + FAILED ("INCORRECT 'VAL"); + END IF; + + IF T'VALUE (IDENT_STR ("30")) /= X OR T'VALUE ("100") /= 100 THEN + FAILED ("INCORRECT 'VALUE"); + END IF; + + IF T'WIDTH /= 3 OR T'BASE'WIDTH < 4 THEN + FAILED ("INCORRECT 'WIDTH"); + END IF; + + RESULT; + END C34002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34002c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34002c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34002c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34002c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C34002C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED INTEGER TYPES: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 8/21/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34002C IS + + TYPE PARENT IS RANGE -100 .. 100; + + TYPE T IS NEW PARENT RANGE + PARENT'VAL (IDENT_INT (-30)) .. + PARENT'VAL (IDENT_INT ( 30)); + + SUBTYPE SUBPARENT IS PARENT RANGE -30 .. 30; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + BEGIN + TEST ("C34002C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "INTEGER TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'POS (T'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR + S'POS (S'BASE'FIRST) /= PARENT'POS (PARENT'BASE'FIRST) OR + T'POS (T'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) OR + S'POS (S'BASE'LAST) /= PARENT'POS (PARENT'BASE'LAST) THEN + FAILED ("INCORRECT 'BASE'FIRST OR 'BASE'LAST"); + END IF; + + IF T'PRED (100) /= 99 OR T'SUCC (99) /= 100 OR + S'PRED (100) /= 99 OR S'SUCC (99) /= 100 THEN + FAILED ("INCORRECT 'PRED OR 'SUCC"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= -30 OR T'LAST /= 30 OR + S'FIRST /= -30 OR S'LAST /= 30 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30; + Y := -30; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30; + Y := 30; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := -31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31"); + IF X = -31 THEN -- USE X. + COMMENT ("X ALTERED -- X := -31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -31"); + END; + + BEGIN + X := 31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31"); + IF X = 31 THEN -- USE X. + COMMENT ("X ALTERED -- X := 31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 31"); + END; + + BEGIN + Y := -31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31"); + IF Y = -31 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := -31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -31"); + END; + + BEGIN + Y := 31; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31"); + IF Y = 31 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := 31"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 31"); + END; + + RESULT; + END C34002C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34003a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,260 ---- + -- C34003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED FLOATING POINT TYPES. + + -- JRK 9/4/86 + -- GJD 11/14/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTES. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34003A IS + + TYPE PARENT IS DIGITS 5; + + SUBTYPE SUBPARENT IS PARENT RANGE + PARENT (IDENT_INT (-50)) .. + PARENT (IDENT_INT ( 50)); + + TYPE T IS NEW SUBPARENT DIGITS 4 RANGE + PARENT (IDENT_INT (-30)) .. + PARENT (IDENT_INT ( 30)); + + TYPE FIXED IS DELTA 0.1 RANGE -1000.0 .. 1000.0; + + X : T := -30.0; + W : PARENT := -100.0; + R : CONSTANT := 1.0; + M : CONSTANT := 100.0; + B : BOOLEAN := FALSE; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + Z : CONSTANT T := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + + BEGIN + TEST ("C34003A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "FLOATING POINT TYPES"); + + X := IDENT (30.0); + IF X /= 30.0 THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= 30.0 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30.0 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30.0; + END IF; + IF T (W) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (R) /= 1.0 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN + FAILED ("INCORRECT REAL LITERAL"); + END IF; + + IF X = IDENT (0.0) OR X = 100.0 THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30.0) OR 100.0 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30.0) OR X > 100.0 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0.0) OR 100.0 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0.0) >= X OR X >= 100.0 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100.0 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100.0 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF X * IDENT (-1.0) /= -30.0 OR IDENT (2.0) * 50.0 /= 100.0 THEN + FAILED ("INCORRECT *"); + END IF; + + IF X / IDENT (3.0) /= 10.0 OR 90.0 / X /= 3.0 THEN + FAILED ("INCORRECT /"); + END IF; + + IF X ** IDENT_INT (1) /= 30.0 OR + (Z + 100.0) ** IDENT_INT (1) /= 100.0 THEN + FAILED ("INCORRECT **"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'BASE'SIZE < 27 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'DIGITS /= 4 OR T'BASE'DIGITS < 5 THEN + FAILED ("INCORRECT 'DIGITS"); + END IF; + + IF T'FIRST /= -30.0 THEN + FAILED ("INCORRECT 'FIRST"); + END IF; + + IF T'LAST /= 30.0 THEN + FAILED ("INCORRECT 'LAST"); + END IF; + + IF T'MACHINE_EMAX < 1 OR T'BASE'MACHINE_EMAX /= T'MACHINE_EMAX THEN + FAILED ("INCORRECT 'MACHINE_EMAX"); + END IF; + + IF T'MACHINE_EMIN > -1 OR T'BASE'MACHINE_EMIN /= T'MACHINE_EMIN THEN + FAILED ("INCORRECT 'MACHINE_EMIN"); + END IF; + + IF T'MACHINE_MANTISSA < 1 OR + T'BASE'MACHINE_MANTISSA /= T'MACHINE_MANTISSA THEN + FAILED ("INCORRECT 'MACHINE_MANTISSA"); + END IF; + + IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN + FAILED ("INCORRECT 'MACHINE_OVERFLOWS"); + END IF; + + IF T'MACHINE_RADIX < 2 OR + T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN + FAILED ("INCORRECT 'MACHINE_RADIX"); + END IF; + + IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN + FAILED ("INCORRECT 'MACHINE_ROUNDS"); + END IF; + + IF T'SIZE < 23 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < 23 THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34003c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34003c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34003c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34003c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C34003C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED FLOATING POINT TYPES: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 9/4/86 + -- GJD 11/15/95 REMOVED USES OF OBSOLETE ADA 83 ATTRIBUTE (SAFE_LARGE). + + WITH REPORT; USE REPORT; + + PROCEDURE C34003C IS + + TYPE PARENT IS DIGITS 5; + + TYPE T IS NEW PARENT DIGITS 4 RANGE + PARENT (IDENT_INT (-30)) .. + PARENT (IDENT_INT ( 30)); + + SUBTYPE SUBPARENT IS PARENT DIGITS 4 RANGE -30.0 .. 30.0; + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + BEGIN + TEST ("C34003C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "FLOATING POINT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF T'BASE'DIGITS < 5 OR S'BASE'DIGITS < 5 THEN + FAILED ("INCORRECT 'BASE'DIGITS"); + END IF; + + IF 12344.0 + T'(1.0) + 1.0 /= 12346.0 OR + 12344.0 + S'(1.0) + 1.0 /= 12346.0 OR + -12344.0 - T'(1.0) - 1.0 /= -12346.0 OR + -12344.0 - S'(1.0) - 1.0 /= -12346.0 THEN + FAILED ("INCORRECT + OR -"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'DIGITS /= 4 OR S'DIGITS /= 4 THEN + FAILED ("INCORRECT 'DIGITS"); + END IF; + + IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR + S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30.0; + Y := -30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30.0; + Y := 30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := -31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := -31.0"); + IF X = -31.0 THEN -- USE X. + COMMENT ("X ALTERED -- X := -31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -31.0"); + END; + + BEGIN + X := 31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := 31.0"); + IF X = 31.0 THEN -- USE X. + COMMENT ("X ALTERED -- X := 31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 31.0"); + END; + + BEGIN + Y := -31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := -31.0"); + IF Y = -31.0 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := -31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -31.0"); + END; + + BEGIN + Y := 31.0; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := 31.0"); + IF Y = 31.0 THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := 31.0"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 31.0"); + END; + + RESULT; + END C34003C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34004a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C34004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED FIXED POINT TYPES. + + -- HISTORY: + -- JRK 09/08/86 CREATED ORIGINAL TEST. + -- JET 08/06/87 FIXED BUGS IN DELTAS AND RANGE ERROR. + -- JET 09/22/88 CHANGED USAGE OF X'SIZE. + -- RDH 04/16/90 ADDED TEST FOR REAL VARIABLE VALUES. + -- THS 09/25/90 REMOVED ALL REFERENCES TO B, MODIFIED CHECK OF + -- '=', INITIALIZED Z NON-STATICALLY, MOVED BINARY + -- CHECKS. + -- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES. + -- KAS 03/04/96 REMOVED COMPARISON OF T'SMALL TO T'BASE'SMALL + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34004A IS + + TYPE PARENT IS DELTA 2.0 ** (-7) RANGE -100.0 .. 100.0; + + SUBTYPE SUBPARENT IS PARENT RANGE + IDENT_INT (1) * (-50.0) .. + IDENT_INT (1) * ( 50.0); + + TYPE T IS NEW SUBPARENT DELTA 2.0 ** (-4) RANGE + IDENT_INT (1) * (-30.0) .. + IDENT_INT (1) * ( 30.0); + + TYPE FIXED IS DELTA 2.0 ** (-4) RANGE -1000.0 .. 1000.0; + + X : T := -30.0; + I : INTEGER := X'SIZE; --CHECK FOR THE AVAILABILITY OF 'SIZE. + W : PARENT := -100.0; + R : CONSTANT := 1.0; + M : CONSTANT := 100.0; + F : FLOAT := 0.0; + G : FIXED := 0.0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN T'FIRST; + END IDENT; + + BEGIN + + DECLARE + Z : CONSTANT T := IDENT(0.0); + BEGIN + TEST ("C34004A", "CHECK THAT THE REQUIRED PREDEFINED " & + "OPERATIONS ARE DECLARED (IMPLICITLY) " & + "FOR DERIVED FIXED POINT TYPES"); + + X := IDENT (30.0); + IF X /= 30.0 THEN + FAILED ("INCORRECT :="); + END IF; + + IF X + IDENT (-1.0) /= 29.0 OR X + 70.0 /= 100.0 THEN + FAILED ("INCORRECT BINARY +"); + END IF; + + IF X - IDENT (30.0) /= 0.0 OR X - 100.0 /= -70.0 THEN + FAILED ("INCORRECT BINARY -"); + END IF; + + IF T'(X) /= 30.0 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= 30.0 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := -30.0; + END IF; + IF T (W) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= 30.0 OR PARENT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF T (IDENT_INT (-30)) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM INTEGER"); + END IF; + + IF INTEGER (X) /= 30 OR INTEGER (Z - 100.0) /= -100 THEN + FAILED ("INCORRECT CONVERSION TO INTEGER"); + END IF; + + IF EQUAL (3, 3) THEN + F := -30.0; + END IF; + IF T (F) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FLOAT"); + END IF; + + IF FLOAT (X) /= 30.0 OR FLOAT (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FLOAT"); + END IF; + + IF EQUAL (3, 3) THEN + G := -30.0; + END IF; + IF T (G) /= -30.0 THEN + FAILED ("INCORRECT CONVERSION FROM FIXED"); + END IF; + + IF FIXED (X) /= 30.0 OR FIXED (Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT CONVERSION TO FIXED"); + END IF; + + IF IDENT (R) /= 1.0 OR X = M THEN + FAILED ("INCORRECT IMPLICIT CONVERSION"); + END IF; + + IF IDENT (30.0) /= 30.0 OR X = 100.0 THEN + FAILED ("INCORRECT REAL LITERAL"); + END IF; + + IF NOT (X = IDENT (30.0)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (30.0) OR NOT (X /= 100.0) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT (30.0) OR 100.0 < X THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT (30.0) OR X > 100.0 THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT (0.0) OR 100.0 <= X THEN + FAILED ("INCORRECT <="); + END IF; + + IF IDENT (0.0) >= X OR X >= 100.0 THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR 100.0 IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (100.0 NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + IF +X /= 30.0 OR +(Z - 100.0) /= -100.0 THEN + FAILED ("INCORRECT UNARY +"); + END IF; + + IF -X /= 0.0 - 30.0 OR -(Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT UNARY -"); + END IF; + + IF ABS X /= 30.0 OR ABS (Z - 100.0) /= 100.0 THEN + FAILED ("INCORRECT ABS"); + END IF; + + IF T (X * IDENT (-1.0)) /= -30.0 OR + T (IDENT (2.0) * (Z + 15.0)) /= 30.0 THEN + FAILED ("INCORRECT * (FIXED, FIXED)"); + END IF; + + IF X * IDENT_INT (-1) /= -30.0 OR + (Z + 50.0) * 2 /= 100.0 THEN + FAILED ("INCORRECT * (FIXED, INTEGER)"); + END IF; + + IF IDENT_INT (-1) * X /= -30.0 OR + 2 * (Z + 50.0) /= 100.0 THEN + FAILED ("INCORRECT * (INTEGER, FIXED)"); + END IF; + + IF T (X / IDENT (3.0)) /= 10.0 OR + T ((Z + 90.0) / X) /= 3.0 THEN + FAILED ("INCORRECT / (FIXED, FIXED)"); + END IF; + + IF X / IDENT_INT (3) /= 10.0 OR (Z + 90.0) / 30 /= 3.0 THEN + FAILED ("INCORRECT / (FIXED, INTEGER)"); + END IF; + + A (X'ADDRESS); + + IF T'AFT /= 2 OR T'BASE'AFT < 3 THEN + FAILED ("INCORRECT 'AFT"); + END IF; + + IF T'BASE'SIZE < 15 THEN + FAILED ("INCORRECT 'BASE'SIZE"); + END IF; + + IF T'DELTA /= 2.0 ** (-4) OR T'BASE'DELTA > 2.0 ** (-7) THEN + FAILED ("INCORRECT 'DELTA"); + END IF; + + + IF T'FORE /= 3 OR T'BASE'FORE < 4 THEN + FAILED ("INCORRECT 'FORE"); + END IF; + + + + IF T'MACHINE_OVERFLOWS /= T'BASE'MACHINE_OVERFLOWS THEN + FAILED ("INCORRECT 'MACHINE_OVERFLOWS"); + END IF; + + IF T'MACHINE_ROUNDS /= T'BASE'MACHINE_ROUNDS THEN + FAILED ("INCORRECT 'MACHINE_ROUNDS"); + END IF; + + + + + IF T'SIZE < 10 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF T'SMALL > 2.0 ** (-4) OR T'BASE'SMALL > 2.0 ** (-7) THEN + FAILED ("INCORRECT 'SMALL"); + END IF; + END; + + RESULT; + END C34004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34004c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C34004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED FIXED POINT TYPES: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 09/08/86 + -- JLH 09/25/87 REFORMATTED HEADER. + -- JRL 03/13/92 MODIFIED TO DEFEAT OPTIMIZATION WHEN ATTEMPTING TO + -- RAISE CONSTRAINT_ERROR. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + -- DTN 11/30/95 REMOVED NON ADA95 ATTRIBUTES. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34004C IS + + TYPE PARENT IS DELTA 0.01 RANGE -100.0 .. 100.0; + + TYPE T IS NEW PARENT DELTA 0.1 RANGE + IDENT_INT (1) * (-30.0) .. + IDENT_INT (1) * ( 30.0); + + SUBTYPE SUBPARENT IS PARENT DELTA 0.1 RANGE -30.0 .. 30.0; + + TYPE S IS NEW SUBPARENT; + + X,XA : T; + Y,YA : S; + + + FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : T ) RETURN BOOLEAN IS + BEGIN + IF ( VAR1 + VAR2 ) IN T THEN + RETURN FALSE ; + ELSE + RETURN TRUE ; + END IF ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN TRUE ; + END OUT_OF_BOUNDS ; + + + FUNCTION OUT_OF_BOUNDS ( VAR1 , VAR2 : S ) RETURN BOOLEAN IS + BEGIN + IF ( VAR1 + VAR2 ) IN S THEN + RETURN FALSE ; + ELSE + RETURN TRUE ; + END IF ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN TRUE ; + END OUT_OF_BOUNDS ; + + + BEGIN + TEST ("C34004C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "FIXED POINT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + DECLARE + TBD : CONSTANT := BOOLEAN'POS (T'BASE'DELTA <= 0.01); + SBD : CONSTANT := BOOLEAN'POS (S'BASE'DELTA <= 0.01); + BEGIN + IF TBD = 0 OR SBD = 0 THEN + FAILED ("INCORRECT 'BASE'DELTA"); + END IF; + END; + + + DECLARE + N : INTEGER := IDENT_INT (8); + BEGIN + IF 98.0 + T'(1.0) + N * 0.0078125 /= 99.0625 OR + 98.0 + S'(1.0) + 8 * 0.0078125 /= 99.0625 OR + -98.0 - T'(1.0) - N * 0.0078125 /= -99.0625 OR + -98.0 - S'(1.0) - 8 * 0.0078125 /= -99.0625 THEN + FAILED ("INCORRECT + OR -"); + END IF; + END; + + + IF T'FIRST /= -30.0 OR T'LAST /= 30.0 OR + S'FIRST /= -30.0 OR S'LAST /= 30.0 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := -30.0; + Y := -30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + X := 30.0; + Y := 30.0; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + + BEGIN + X := -30.0 ; + XA := -0.0625 ; + IF NOT OUT_OF_BOUNDS ( X , XA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := -30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := -30.0625"); + END; + + + BEGIN + X := 30.0 ; + XA := 0.0625 ; + IF NOT OUT_OF_BOUNDS ( X , XA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- X := 30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := 30.0625"); + END; + + + BEGIN + Y := -30.0 ; + YA := -0.0625 ; + IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := -30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := -30.0625"); + END; + + + BEGIN + Y := 30.0 ; + YA := 0.0625 ; + IF NOT OUT_OF_BOUNDS ( Y , YA ) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED -- Y := 30.0625" ) ; + END IF ; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := 30.0625"); + END; + + RESULT; + END C34004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,410 ---- + -- C34005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES + -- WHOSE COMPONENT TYPE IS A NON-LIMITED, NON-DISCRETE TYPE. + + -- HISTORY: + -- JRK 9/10/86 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005A IS + + SUBTYPE COMPONENT IS FLOAT; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 2.0); + W : PARENT (5 .. 7) := (OTHERS => 2.0); + C : COMPONENT := 1.0; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1.0; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => -1.0); + END IDENT; + + BEGIN + TEST ("C34005A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE"); + + X := IDENT ((1.0, 2.0, 3.0)); + IF X /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1.0, 2.0, 3.0); + END IF; + IF T (W) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (1.0, 2.0, 3.0) OR + PARENT (CREATE (2, 3, 4.0, X)) /= (4.0, 5.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (1.0, 2.0, 3.0); + END IF; + IF T (U) /= (1.0, 2.0, 3.0) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (1.0, 2.0, 3.0) OR + ARRT (CREATE (1, 2, 3.0, X)) /= (3.0, 4.0) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((1.0, 2.0, 3.0)) /= (1.0, 2.0, 3.0) OR + X = (1.0, 2.0) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 1.0 OR + CREATE (2, 3, 4.0, X) (3) /= 5.0 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 4.0; + IF X /= (1.0, 2.0, 4.0) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((1.0, 2.0, 3.0)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2.0, 3.0) OR + CREATE (1, 4, 4.0, X) (1 .. 3) /= (4.0, 5.0, 6.0) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (4.0, 5.0); + IF X /= (4.0, 5.0, 3.0) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ((1.0, 2.0, 3.0)); + IF X = IDENT ((1.0, 2.0, 4.0)) OR X = (1.0, 2.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1.0, 2.0, 3.0)) OR NOT (X /= (2.0, 3.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR (1.0, 2.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((1.0, 2.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (4.0, 5.0, 6.0) /= (1.0, 2.0, 3.0, 4.0, 5.0, 6.0) OR + CREATE (2, 3, 2.0, X) & (4.0, 5.0) /= + (2.0, 3.0, 4.0, 5.0) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 4.0 /= (1.0, 2.0, 3.0, 4.0) OR + CREATE (2, 3, 2.0, X) & 4.0 /= (2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 4.0 & X /= (4.0, 1.0, 2.0, 3.0) OR + 2.0 & CREATE (2, 3, 3.0, X) /= (2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 2.0; + END IF; + + BEGIN + IF C & 3.0 /= CREATE (2, 3, 2.0, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C34005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A + -- NON-LIMITED, NON-DISCRETE TYPE: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/10/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005C IS + + SUBTYPE COMPONENT IS FLOAT; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 2.0); + Y : S := (OTHERS => 2.0); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1.0; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34005C", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED, NON-DISCRETE TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 4.0, X) /= (4.0, 5.0) OR + CREATE (2, 3, 4.0, Y) /= (4.0, 5.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) OR + Y & (3.0, 4.0) /= (2.0, 2.0, 2.0, 3.0, 4.0) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (1.0, 2.0, 3.0); + Y := (1.0, 2.0, 3.0); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (1.0, 2.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1.0, 2.0)"); + IF X = (1.0, 2.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1.0, 2.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (1.0, 2.0)"); + END; + + BEGIN + X := (1.0, 2.0, 3.0, 4.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (1.0, 2.0, 3.0, 4.0)"); + IF X = (1.0, 2.0, 3.0, 4.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1.0, 2.0, 3.0, 4.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (1.0, 2.0, 3.0, 4.0)"); + END; + + BEGIN + Y := (1.0, 2.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1.0, 2.0)"); + IF Y = (1.0, 2.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1.0, 2.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (1.0, 2.0)"); + END; + + BEGIN + Y := (1.0, 2.0, 3.0, 4.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (1.0, 2.0, 3.0, 4.0)"); + IF Y = (1.0, 2.0, 3.0, 4.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1.0, 2.0, 3.0, 4.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (1.0, 2.0, 3.0, 4.0)"); + END; + + RESULT; + END C34005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,425 ---- + -- C34005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES + -- WHOSE COMPONENT TYPE IS A DISCRETE TYPE. + + -- HISTORY: + -- JRK 9/12/86 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005D IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 2); + W : PARENT (5 .. 7) := (OTHERS => 2); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => -1); + END IDENT; + + BEGIN + TEST ("C34005D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A DISCRETE TYPE"); + + X := IDENT ((1, 2, 3)); + IF X /= (1, 2, 3) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1, 2, 3) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1, 2, 3) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1, 2, 3); + END IF; + IF T (W) /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (1, 2, 3) OR + PARENT (CREATE (2, 3, 4, X)) /= (4, 5) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (1, 2, 3); + END IF; + IF T (U) /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (1, 2, 3) OR + ARRT (CREATE (1, 2, 3, X)) /= (3, 4) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((1, 2, 3)) /= (1, 2, 3) OR + X = (1, 2) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 1 OR + CREATE (2, 3, 4, X) (3) /= 5 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 4; + IF X /= (1, 2, 4) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((1, 2, 3)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR + CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5); + IF X /= (4, 5, 3) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ((1, 2, 3)); + IF X = IDENT ((1, 2, 4)) OR X = (1, 2) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1, 2, 3)) OR NOT (X /= (2, 3)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ((1, 2, 3)) OR X < (1, 2) THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ((1, 2, 3)) OR X > (1, 3) THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ((1, 2, 2)) OR X <= (1, 2, 2, 4) THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ((1, 2, 4)) OR X >= (1, 2, 3, 1) THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR (1, 2) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((1, 2) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (4, 5, 6) /= (1, 2, 3, 4, 5, 6) OR + CREATE (2, 3, 2, X) & (4, 5) /= (2, 3, 4, 5) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 4 /= (1, 2, 3, 4) OR + CREATE (2, 3, 2, X) & 4 /= (2, 3, 4) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 4 & X /= (4, 1, 2, 3) OR + 2 & CREATE (2, 3, 3, X) /= (2, 3, 4) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 2; + END IF; + + BEGIN + IF C & 3 /= CREATE (2, 3, 2, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C34005F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A + -- DISCRETE TYPE: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/12/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005F IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 2); + Y : S := (OTHERS => 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34005F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A DISCRETE TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 4, X) /= (4, 5) OR + CREATE (2, 3, 4, Y) /= (4, 5) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (3, 4) /= (2, 2, 2, 3, 4) OR + Y & (3, 4) /= (2, 2, 2, 3, 4) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (1, 2, 3); + Y := (1, 2, 3); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (1, 2); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (1, 2)"); + IF X = (1, 2) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1, 2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (1, 2)"); + END; + + BEGIN + X := (1, 2, 3, 4); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (1, 2, 3, 4)"); + IF X = (1, 2, 3, 4) THEN -- USE X. + COMMENT ("X ALTERED -- X := (1, 2, 3, 4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (1, 2, 3, 4)"); + END; + + BEGIN + Y := (1, 2); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (1, 2)"); + IF Y = (1, 2) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1, 2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (1, 2)"); + END; + + BEGIN + Y := (1, 2, 3, 4); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (1, 2, 3, 4)"); + IF Y = (1, 2, 3, 4) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (1, 2, 3, 4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (1, 2, 3, 4)"); + END; + + RESULT; + END C34005F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,423 ---- + -- C34005G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES + -- WHOSE COMPONENT TYPE IS A CHARACTER TYPE. + + -- HISTORY: + -- JRK 9/15/86 CREATED ORIGINAL TEST. + -- RJW 8/21/89 MODIFIED CHECKS FOR OBJECT AND TYPE SIZES. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005G IS + + TYPE COMPONENT IS NEW CHARACTER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => 'B'); + W : PARENT (5 .. 7) := (OTHERS => 'B'); + C : COMPONENT := 'A'; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := COMPONENT'SUCC (B); + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => '-'); + END IDENT; + + BEGIN + TEST ("C34005G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A CHARACTER TYPE"); + + X := IDENT ("ABC"); + IF X /= "ABC" THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= "ABC" THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= "ABC" THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := "ABC"; + END IF; + IF T (W) /= "ABC" THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= "ABC" OR + PARENT (CREATE (2, 3, 'D', X)) /= "DE" THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := "ABC"; + END IF; + IF T (U) /= "ABC" THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= "ABC" OR + ARRT (CREATE (1, 2, 'C', X)) /= "CD" THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ("ABC") /= ('A', 'B', 'C') OR + X = "AB" THEN + FAILED ("INCORRECT STRING LITERAL"); + END IF; + + IF IDENT (('A', 'B', 'C')) /= "ABC" OR + X = ('A', 'B') THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= 'A' OR + CREATE (2, 3, 'D', X) (3) /= 'E' THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := 'D'; + IF X /= "ABD" THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ("ABC"); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= "BC" OR + CREATE (1, 4, 'D', X) (1 .. 3) /= "DEF" THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := "DE"; + IF X /= "DEC" THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + X := IDENT ("ABC"); + IF X = IDENT ("ABD") OR X = "AB" THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ("ABC") OR NOT (X /= "BC") THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ("ABC") OR X < "AB" THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ("ABC") OR X > "AC" THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ("ABB") OR X <= "ABBD" THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ("ABD") OR X >= "ABCA" THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR "AB" IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ("AB" NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & "DEF" /= "ABCDEF" OR + CREATE (2, 3, 'B', X) & "DE" /= "BCDE" THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF X & 'D' /= "ABCD" OR + CREATE (2, 3, 'B', X) & 'D' /= "BCD" THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF 'D' & X /= "DABC" OR + 'B' & CREATE (2, 3, 'C', X) /= "BCD" THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + IF EQUAL (3, 3) THEN + C := 'B'; + END IF; + + BEGIN + IF C & 'C' /= CREATE (2, 3, 'B', X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + RESULT; + END C34005G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005i.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C34005I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A + -- CHARACTER TYPE: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/15/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005I IS + + TYPE COMPONENT IS NEW CHARACTER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => 'B'); + Y : S := (OTHERS => 'B'); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := COMPONENT'SUCC (B); + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34005I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A CHARACTER TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, 'D', X) /= "DE" OR + CREATE (2, 3, 'D', Y) /= "DE" THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & "CD" /= "BBBCD" OR + Y & "CD" /= "BBBCD" THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := "ABC"; + Y := "ABC"; + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := "AB"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := ""AB"""); + IF X = "AB" THEN -- USE X. + COMMENT ("X ALTERED -- X := ""AB"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := ""AB"""); + END; + + BEGIN + X := "ABCD"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := ""ABCD"""); + IF X = "ABCD" THEN -- USE X. + COMMENT ("X ALTERED -- X := ""ABCD"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := ""ABCD"""); + END; + + BEGIN + Y := "AB"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := ""AB"""); + IF Y = "AB" THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := ""AB"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := ""AB"""); + END; + + BEGIN + Y := "ABCD"; + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := ""ABCD"""); + IF Y = "ABCD" THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := ""ABCD"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := ""ABCD"""); + END; + + RESULT; + END C34005I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,482 ---- + -- C34005J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES + -- WHOSE COMPONENT TYPE IS A BOOLEAN TYPE. + + -- HISTORY: + -- JRK 9/16/86 CREATED ORIGINAL TEST. + -- RJW 8/21/89 MODIFIED CHECKS FOR TYPE AND OBJECT SIZES. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005J IS + + SUBTYPE COMPONENT IS BOOLEAN; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>) OF COMPONENT; + SUBTYPE ARR IS ARRT (2 .. 4); + + X : T := (OTHERS => TRUE); + W : PARENT (5 .. 7) := (OTHERS => TRUE); + C : COMPONENT := FALSE; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => C); + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := NOT B; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => FALSE); + END IDENT; + + BEGIN + TEST ("C34005J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A BOOLEAN TYPE"); + + X := IDENT ((TRUE, FALSE, TRUE)); + IF X /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (TRUE, FALSE, TRUE); + END IF; + IF T (W) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (TRUE, FALSE, TRUE) OR + PARENT (CREATE (2, 3, FALSE, X)) /= (FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := (TRUE, FALSE, TRUE); + END IF; + IF T (U) /= (TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= (TRUE, FALSE, TRUE) OR + ARRT (CREATE (1, 2, TRUE, X)) /= (TRUE, FALSE) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT ((TRUE, FALSE, TRUE)) /= (TRUE, FALSE, TRUE) OR + X = (TRUE, FALSE) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (5)) /= TRUE OR + CREATE (2, 3, FALSE, X) (3) /= TRUE THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (7)) := FALSE; + IF X /= (TRUE, FALSE, FALSE) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((TRUE, FALSE, TRUE)); + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (FALSE, TRUE) OR + CREATE (1, 4, FALSE, X) (1 .. 3) /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 4"); + END; + + X (IDENT_INT (5) .. IDENT_INT (6)) := (FALSE, TRUE); + IF X /= (FALSE, TRUE, TRUE) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + BEGIN + X := IDENT ((TRUE, FALSE, TRUE)); + IF NOT X /= (FALSE, TRUE, FALSE) OR + NOT CREATE (2, 3, FALSE, X) /= (TRUE, FALSE) THEN + FAILED ("INCORRECT ""NOT"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 5"); + END; + + BEGIN + IF (X AND IDENT ((TRUE, TRUE, FALSE))) /= + (TRUE, FALSE, FALSE) OR + (CREATE (1, 4, FALSE, X) AND + (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, FALSE, FALSE, TRUE) THEN + FAILED ("INCORRECT ""AND"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 6"); + END; + + BEGIN + IF (X OR IDENT ((TRUE, FALSE, FALSE))) /= + (TRUE, FALSE, TRUE) OR + (CREATE (1, 4, FALSE, X) OR (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, TRUE, TRUE, TRUE) THEN + FAILED ("INCORRECT ""OR"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 7"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 7"); + END; + + BEGIN + IF (X XOR IDENT ((TRUE, TRUE, FALSE))) /= + (FALSE, TRUE, TRUE) OR + (CREATE (1, 4, FALSE, X) XOR + (FALSE, FALSE, TRUE, TRUE)) /= + (FALSE, TRUE, TRUE, FALSE) THEN + FAILED ("INCORRECT ""XOR"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 8"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 8"); + END; + + IF X = IDENT ((TRUE, FALSE, FALSE)) OR X = (TRUE, FALSE) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((TRUE, FALSE, TRUE)) OR + NOT (X /= (FALSE, TRUE)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF X < IDENT ((TRUE, FALSE, TRUE)) OR X < (TRUE, FALSE) THEN + FAILED ("INCORRECT <"); + END IF; + + IF X > IDENT ((TRUE, FALSE, TRUE)) OR X > (TRUE, TRUE) THEN + FAILED ("INCORRECT >"); + END IF; + + IF X <= IDENT ((TRUE, FALSE, FALSE)) OR + X <= (TRUE, FALSE, FALSE, TRUE) THEN + FAILED ("INCORRECT <="); + END IF; + + IF X >= IDENT ((TRUE, TRUE, FALSE)) OR + X >= (TRUE, FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT >="); + END IF; + + IF NOT (X IN T) OR (TRUE, FALSE) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((TRUE, FALSE) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + BEGIN + IF X & (FALSE, TRUE, FALSE) /= + (TRUE, FALSE, TRUE, FALSE, TRUE, FALSE) OR + CREATE (2, 3, FALSE, X) & (FALSE, TRUE) /= + (FALSE, TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT & (ARRAY, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 9"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 9"); + END; + + BEGIN + IF X & FALSE /= (TRUE, FALSE, TRUE, FALSE) OR + CREATE (2, 3, FALSE, X) & FALSE /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT & (ARRAY, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 10"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 10"); + END; + + BEGIN + IF FALSE & X /= (FALSE, TRUE, FALSE, TRUE) OR + FALSE & CREATE (2, 3, TRUE, X) /= + (FALSE, TRUE, FALSE) THEN + FAILED ("INCORRECT & (COMPONENT, ARRAY)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 11"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 11"); + END; + + IF EQUAL (3, 3) THEN + C := FALSE; + END IF; + + BEGIN + IF C & TRUE /= CREATE (2, 3, FALSE, X) THEN + FAILED ("INCORRECT & (COMPONENT, COMPONENT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 12"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 12"); + END; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + RESULT; + END C34005J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C34005L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A + -- BOOLEAN TYPE: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/16/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005L IS + + SUBTYPE COMPONENT IS BOOLEAN; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => TRUE); + Y : S := (OTHERS => TRUE); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := NOT B; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34005L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A BOOLEAN TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (2, 3, FALSE, X) /= (FALSE, TRUE) OR + CREATE (2, 3, FALSE, Y) /= (FALSE, TRUE) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF X & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) OR + Y & (FALSE, TRUE) /= (TRUE, TRUE, TRUE, FALSE, TRUE) THEN + FAILED ("INCORRECT &"); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := (TRUE, FALSE, TRUE); + Y := (TRUE, FALSE, TRUE); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- X := (TRUE, FALSE)"); + IF X = (TRUE, FALSE) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- X := (TRUE, FALSE)"); + END; + + BEGIN + X := (TRUE, FALSE, TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (TRUE, FALSE, TRUE, FALSE)"); + IF X = (TRUE, FALSE, TRUE, FALSE) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, FALSE, TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (TRUE, FALSE, TRUE, FALSE)"); + END; + + BEGIN + Y := (TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- Y := (TRUE, FALSE)"); + IF Y = (TRUE, FALSE) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- Y := (TRUE, FALSE)"); + END; + + BEGIN + Y := (TRUE, FALSE, TRUE, FALSE); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (TRUE, FALSE, TRUE, FALSE)"); + IF Y = (TRUE, FALSE, TRUE, FALSE) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, FALSE, TRUE, FALSE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (TRUE, FALSE, TRUE, FALSE)"); + END; + + RESULT; + END C34005L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005m.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,353 ---- + -- C34005M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE + -- COMPONENT TYPE IS A NON-LIMITED TYPE. + + -- HISTORY: + -- JRK 9/17/86 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005M IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + COMPONENT; + + SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4); + + X : T := (OTHERS => (OTHERS => 2)); + W : PARENT (4 .. 5, 6 .. 8) := (OTHERS => (OTHERS => 2)); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + U : ARR := (OTHERS => (OTHERS => C)); + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN (OTHERS => (OTHERS => C)); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (OTHERS => (OTHERS => -1)); + END IDENT; + + BEGIN + TEST ("C34005M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED TYPE"); + + X := IDENT (((1, 2, 3), (4, 5, 6))); + IF X /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := ((1, 2, 3), (4, 5, 6)); + END IF; + IF T (W) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= ((1, 2, 3), (4, 5, 6)) OR + PARENT (CREATE (6, 9, 2, 3, 4, X)) /= + ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF EQUAL (3, 3) THEN + U := ((1, 2, 3), (4, 5, 6)); + END IF; + IF T (U) /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM ARRAY"); + END IF; + + BEGIN + IF ARR (X) /= ((1, 2, 3), (4, 5, 6)) OR + ARRT (CREATE (7, 9, 2, 5, 3, X)) /= + ((3, 4, 5, 6), (7, 8, 9, 10), (11, 12, 13, 14)) THEN + FAILED ("INCORRECT CONVERSION TO ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + IF IDENT (((1, 2, 3), (4, 5, 6))) /= ((1, 2, 3), (4, 5, 6)) OR + X = ((1, 2), (3, 4), (5, 6)) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR + CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X (IDENT_INT (5), IDENT_INT (8)) := 7; + IF X /= ((1, 2, 3), (4, 5, 7)) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + X := IDENT (((1, 2, 3), (4, 5, 6))); + IF X = IDENT (((1, 2, 3), (4, 5, 7))) OR + X = ((1, 2), (4, 5)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT (((1, 2, 3), (4, 5, 6))) OR + NOT (X /= ((1, 2, 3), (4, 5, 6), (7, 8, 9))) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR ((1, 2), (3, 4)) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (((1, 2, 3), (4, 5, 6), (7, 8, 9)) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 4 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 6 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 2 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, T'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34005M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005o.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,277 ---- + -- C34005O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE + -- IS A NON-LIMITED TYPE: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/17/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005O IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T := (OTHERS => (OTHERS => 2)); + Y : S := (OTHERS => (OTHERS => 2)); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34005O", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A NON-LIMITED TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (6, 9, 2, 3, 1, X) /= + ((1, 2), (3, 4), (5, 6), (7, 8)) OR + CREATE (6, 9, 2, 3, 1, Y) /= + ((1, 2), (3, 4), (5, 6), (7, 8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION"); + END; + + IF ((1, 2), (3, 4), (5, 6), (7, 8)) IN T OR + ((1, 2), (3, 4), (5, 6), (7, 8)) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 4 OR T'LAST /= 5 OR + S'FIRST /= 4 OR S'LAST /= 5 OR + T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR + S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := ((1, 2, 3), (4, 5, 6)); + Y := ((1, 2, 3), (4, 5, 6)); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (4 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 => (6 .. 8 => 0))"); + IF X = (4 => (6 .. 8 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 => (6 .. 8 => 0))"); + END; + + BEGIN + X := (4 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + IF X = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + X := (4 .. 5 => (6 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + IF X = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 5 => (6 .. 7 => 0))"); + END; + + BEGIN + X := (4 .. 5 => (6 .. 9 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + IF X = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (4 .. 5 => (6 .. 9 => 0))"); + END; + + BEGIN + Y := (4 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 => (6 .. 8 => 0))"); + IF Y = (4 => (6 .. 8 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := (4 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + IF Y = (4 .. 6 => (6 .. 8 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := (4 .. 5 => (6 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + IF Y = (4 .. 5 => (6 .. 7 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 5 => (6 .. 7 => 0))"); + END; + + BEGIN + Y := (4 .. 5 => (6 .. 9 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + IF Y = (4 .. 5 => (6 .. 9 => 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (4 .. 5 => (6 .. 9 => 0))"); + END; + + RESULT; + END C34005O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,405 ---- + -- C34005P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE + -- COMPONENT TYPE IS A LIMITED TYPE. + + -- HISTORY: + -- JRK 08/17/87 CREATED ORIGINAL TEST. + -- VCL 07/01/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE + -- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE + -- SIZES. ADDED EXCEPTION HANDLERS TO CATCH INCORRECT + -- TYPE CONVERSIONS TO DERIVED SUBTYPES. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + -- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND + -- SUPPORTING CODE. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005P IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T; + W : PARENT (5 .. 7); + C : COMPONENT; + B : BOOLEAN := FALSE; + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + ASSIGN (RESULT (I), C); + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F .. L LOOP + ASSIGN (A (I), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + IF NOT EQUAL (X (I), + Y (I - X'FIRST + Y'FIRST)) THEN + RETURN FALSE; + END IF; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR (X, Y, Z : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + ASSIGN (RESULT (INDEX'FIRST + 2), Z); + RETURN RESULT; + END AGGR; + + END PKG_P; + + BEGIN + TEST ("C34005P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + ASSIGN (X (IDENT_INT (5)), CREATE (1)); + ASSIGN (X (IDENT_INT (6)), CREATE (2)); + ASSIGN (X (IDENT_INT (7)), CREATE (3)); + + ASSIGN (W (5), CREATE (1)); + ASSIGN (W (6), CREATE (2)); + ASSIGN (W (7), CREATE (3)); + + ASSIGN (C, CREATE (2)); + + IF NOT EQUAL (T'(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T(W), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT(X), AGGR (C1, C2, C3)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + BEGIN + IF NOT EQUAL (PARENT(CREATE (2, 3, C4, X)), + AGGR (C4, C5)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE T - 1"); + END; + + IF NOT EQUAL (X(IDENT_INT (5)), C1) THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + BEGIN + IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)), + AGGR (C2, C3)) OR + NOT EQUAL (CREATE (1, 4, C4, X)(1..3), + AGGR (C4, C5, C6)) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICES"); + END; + + IF NOT (X IN T) OR AGGR (C1, C2) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (AGGR (C1, C2) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 5 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 7 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (T'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF X'SIZE < T'SIZE THEN + COMMENT ("X'SIZE < T'SIZE"); + ELSIF X'SIZE = T'SIZE THEN + COMMENT ("X'SIZE = T'SIZE"); + ELSE + COMMENT ("X'SIZE > T'SIZE"); + END IF; + + RESULT; + END C34005P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005r.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,346 ---- + -- C34005R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS A + -- LIMITED TYPE: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT + -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION + -- IS CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS + -- ALSO IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 08/19/87 CREATED ORIGINAL TEST. + -- VCL 07/01/88 ADDED EXCEPTION HANDLERS TO CATCH INCORRECT TYPE + -- CONVERSIONS TO DERIVED SUBTYPES. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005R IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 100; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>) OF COMPONENT; + + FUNCTION CREATE ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F, L : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F .. L); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F .. L LOOP + ASSIGN (A (I), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + IF NOT EQUAL (X (I), + Y (I - X'FIRST + Y'FIRST)) THEN + RETURN FALSE; + END IF; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (X, Y : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), X); + ASSIGN (RESULT (INDEX'FIRST + 1), Y); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR (W, X, Y, Z : COMPONENT) RETURN PARENT IS + RESULT : PARENT (INDEX'FIRST .. INDEX'FIRST + 3); + BEGIN + ASSIGN (RESULT (INDEX'FIRST ), W); + ASSIGN (RESULT (INDEX'FIRST + 1), X); + ASSIGN (RESULT (INDEX'FIRST + 2), Y); + ASSIGN (RESULT (INDEX'FIRST + 3), Z); + RETURN RESULT; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + FOR I IN X'RANGE LOOP + ASSIGN (X (I), Y (I)); + END LOOP; + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + FOR I IN X'RANGE LOOP + ASSIGN (X (I), Y (I)); + END LOOP; + END ASSIGN; + + BEGIN + TEST ("C34005R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ONE-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + ASSIGN (X (IDENT_INT (5)), CREATE (2)); + ASSIGN (X (IDENT_INT (6)), CREATE (3)); + ASSIGN (X (IDENT_INT (7)), CREATE (4)); + + ASSIGN (Y (5), C2); + ASSIGN (Y (6), C3); + ASSIGN (Y (7), C4); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF NOT EQUAL (CREATE (2, 3, C4, X), AGGR (C4, C5)) THEN + FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " & + "OF THE SUBTYPE T"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE T"); + END; + + BEGIN + IF NOT EQUAL (CREATE (2, 3, C4, Y), AGGR (C4, C5)) THEN + FAILED ("CANNOT CREATE BASE TYPE VALUES OUTSIDE " & + "OF THE SUBTYPE S"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING BASE TYPE " & + "VALUES OUTSIDE OF THE SUBTYPE S"); + END; + + BEGIN + IF NOT EQUAL (X(IDENT_INT (6)..IDENT_INT (7)), + AGGR (C3, C4)) THEN + FAILED ("INCORRECT SLICE OF X (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF X"); + END; + + BEGIN + IF NOT EQUAL (AGGR (C3, C4), + Y(IDENT_INT (6)..IDENT_INT (7))) THEN + FAILED ("INCORRECT SLICE OF Y (VALUE)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WHILE CHECKING SLICE OF Y"); + END; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 5 OR T'LAST /= 7 OR + S'FIRST /= 5 OR S'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + ASSIGN (X, CREATE (5, 7, C1, X)); + ASSIGN (Y, CREATE (5, 7, C1, Y)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, AGGR (C1, C2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (C1, C2))"); + IF EQUAL (X, AGGR (C1, C2)) THEN -- USE X. + COMMENT ("X ALTERED -- ASSIGN (X, AGGR (C1, C2))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (C1, C2))"); + END; + + BEGIN + ASSIGN (X, AGGR (C1, C2, C3, C4)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + IF EQUAL (X, AGGR (C1, C2, C3, C4)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (C1, C2, C3, C4))"); + END; + + BEGIN + ASSIGN (Y, AGGR (C1, C2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2))"); + IF EQUAL (Y, AGGR (C1, C2)) THEN -- USE Y. + COMMENT ("Y ALTERED -- ASSIGN (Y, AGGR (C1, C2))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2))"); + END; + + BEGIN + ASSIGN (Y, AGGR (C1, C2, C3, C4)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + IF EQUAL (Y, AGGR (C1, C2, C3, C4)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (C1, C2, C3, C4))"); + END; + + RESULT; + END C34005R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005s.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,404 ---- + -- C34005S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE + -- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 1 OF 2 + -- TESTS WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST + -- C34005V. + + -- HISTORY: + -- JRK 08/20/87 CREATED ORIGINAL TEST. + -- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34005S.ADA AND + -- C34005V.ADA + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005S IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + C9 : CONSTANT LP; + C10 : CONSTANT LP; + C11 : CONSTANT LP; + C12 : CONSTANT LP; + C13 : CONSTANT LP; + C14 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + C9 : CONSTANT LP := 9; + C10 : CONSTANT LP := 10; + C11 : CONSTANT LP := 11; + C12 : CONSTANT LP := 12; + C13 : CONSTANT LP := 13; + C14 : CONSTANT LP := 14; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + TYPE ARRT IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + COMPONENT; + + SUBTYPE ARR IS ARRT (8 .. 9, 2 .. 4); + + X : T; + W : PARENT (4 .. 5, 6 .. 8); + C : COMPONENT; + B : BOOLEAN := FALSE; + U : ARR; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + FOR J IN RESULT'RANGE(2) LOOP + ASSIGN (RESULT (I, J), C); + END LOOP; + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + END PKG_P; + + FUNCTION EQUAL (X, Y : ARRT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + BEGIN + TEST ("C34005S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE. THIS TEST IS PART " & + "1 OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " & + "SECOND PART IS IN TEST C34005V"); + + ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6)); + + ASSIGN (W (4, 6), CREATE (1)); + ASSIGN (W (4, 7), CREATE (2)); + ASSIGN (W (4, 8), CREATE (3)); + ASSIGN (W (5, 6), CREATE (4)); + ASSIGN (W (5, 7), CREATE (5)); + ASSIGN (W (5, 8), CREATE (6)); + + ASSIGN (C, CREATE (2)); + + ASSIGN (U (8, 2), CREATE (1)); + ASSIGN (U (8, 3), CREATE (2)); + ASSIGN (U (8, 4), CREATE (3)); + ASSIGN (U (9, 2), CREATE (4)); + ASSIGN (U (9, 3), CREATE (5)); + ASSIGN (U (9, 4), CREATE (6)); + + IF NOT EQUAL (X (IDENT_INT (4), IDENT_INT (6)), C1) OR + NOT EQUAL (CREATE (6, 9, 2, 3, C4, X) (9, 3), C11) THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF T'FIRST /= 4 THEN + FAILED ("INCORRECT TYPE'FIRST"); + END IF; + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF T'FIRST (N) /= 6 THEN + FAILED ("INCORRECT TYPE'FIRST (N)"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF T'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'LAST"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF T'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'LAST (N)"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF T'LENGTH /= 2 THEN + FAILED ("INCORRECT TYPE'LENGTH"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF T'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT TYPE'LENGTH (N)"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : PARENT (T'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT TYPE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, T'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT TYPE'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : PARENT (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < T'LENGTH * T'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < X'LENGTH * X'LENGTH (N) * COMPONENT'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34005S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005u.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005u.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005u.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005u.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,408 ---- + -- C34005U.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT TYPE IS + -- A LIMITED TYPE: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT + -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION + -- IS CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS + -- ALSO IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 08/21/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34005U IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); + RETURN X; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), Y (I, J)); + END LOOP; + END LOOP; + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), Y (I, J)); + END LOOP; + END LOOP; + END ASSIGN; + + BEGIN + TEST ("C34005U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE"); + + FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + ASSIGN (X (I, J), C2); + ASSIGN (Y (I, J), C2); + END LOOP; + END LOOP; + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + BEGIN + IF NOT EQUAL (CREATE (6, 9, 2, 3, C1, X), + AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) OR + NOT EQUAL (CREATE (6, 9, 2, 3, C1, Y), + AGGR (C1, C2, C3, C4, C5, C6, C7, C8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR WHEN TRYING TO CREATE BASE " & + "TYPE VALUES OUTSIDE THE SUBTYPE"); + WHEN OTHERS => + FAILED ("EXCEPTION WHEN TRYING TO CREATE BASE TYPE " & + "VALUES OUTSIDE THE SUBTYPE"); + END; + + IF AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN T OR + AGGR (C1, C2, C3, C4, C5, C6, C7, C8) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF T'FIRST /= 4 OR T'LAST /= 5 OR + S'FIRST /= 4 OR S'LAST /= 5 OR + T'FIRST (2) /= 6 OR T'LAST (2) /= 8 OR + S'FIRST (2) /= 6 OR S'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 8, C1, X)); + ASSIGN (Y, CREATE (4, 5, 6, 8, C1, Y)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 4, 6, 8, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + IF EQUAL (X, CREATE (4, 4, 6, 8, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 4, 6, 8, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 6, 6, 8, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + IF EQUAL (X, CREATE (4, 6, 6, 8, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 6, 6, 8, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 7, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + IF EQUAL (X, CREATE (4, 5, 6, 7, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 7, C1, X))"); + END; + + BEGIN + ASSIGN (X, CREATE (4, 5, 6, 9, C1, X)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + IF EQUAL (X, CREATE (4, 5, 6, 9, C1, X)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CREATE (4, 5, 6, 9, C1, X))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + IF EQUAL (Y, CREATE (4, 4, 6, 8, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 4, 6, 8, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + IF EQUAL (Y, CREATE (4, 6, 6, 8, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 6, 6, 8, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + IF EQUAL (Y, CREATE (4, 5, 6, 7, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 7, C1, Y))"); + END; + + BEGIN + ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + IF EQUAL (Y, CREATE (4, 5, 6, 9, C1, Y)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CREATE (4, 5, 6, 9, C1, Y))"); + END; + + RESULT; + END C34005U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34005v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34005v.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,336 ---- + -- C34005V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED MULTI-DIMENSIONAL ARRAY TYPES WHOSE + -- COMPONENT TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 OF 2 + -- TESTS WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST + -- C34005S. + + -- HISTORY: + -- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34005S.ADA. + -- RLB 10/03/02 REMOVED ILLEGAL (BY AI-246) TYPE CONVERSIONS AND + -- SUPPORTING CODE. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34005V IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION VALUE (X : LP) RETURN INTEGER; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + C2 : CONSTANT LP; + C3 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + C7 : CONSTANT LP; + C8 : CONSTANT LP; + C9 : CONSTANT LP; + C10 : CONSTANT LP; + C11 : CONSTANT LP; + C12 : CONSTANT LP; + C13 : CONSTANT LP; + C14 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + C2 : CONSTANT LP := 2; + C3 : CONSTANT LP := 3; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + C7 : CONSTANT LP := 7; + C8 : CONSTANT LP := 8; + C9 : CONSTANT LP := 9; + C10 : CONSTANT LP := 10; + C11 : CONSTANT LP := 11; + C12 : CONSTANT LP := 12; + C13 : CONSTANT LP := 13; + C14 : CONSTANT LP := 14; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + FIRST : CONSTANT := 0; + LAST : CONSTANT := 10; + + SUBTYPE INDEX IS INTEGER RANGE FIRST .. LAST; + + TYPE PARENT IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) OF + COMPONENT; + + FUNCTION CREATE ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT; + + FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) + RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + X : T; + W : PARENT (4 .. 5, 6 .. 8); + C : COMPONENT; + B : BOOLEAN := FALSE; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + RESULT : T; + BEGIN + FOR I IN RESULT'RANGE LOOP + FOR J IN RESULT'RANGE(2) LOOP + ASSIGN (RESULT (I, J), C); + END LOOP; + END LOOP; + RETURN RESULT; + END V; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION VALUE (X : LP) RETURN INTEGER IS + BEGIN + RETURN INTEGER (X); + END VALUE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( F1, L1 : INDEX; + F2, L2 : INDEX; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT (F1 .. L1, F2 .. L2); + B : COMPONENT; + BEGIN + ASSIGN (B, C); + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + ASSIGN (A (I, J), B); + ASSIGN (B, CREATE (VALUE (B) + 1)); + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X'LENGTH /= Y'LENGTH OR + X'LENGTH(2) /= Y'LENGTH(2) THEN + RETURN FALSE; + ELSE FOR I IN X'RANGE LOOP + FOR J IN X'RANGE(2) LOOP + IF NOT EQUAL (X (I, J), + Y (I - X'FIRST + Y'FIRST, + J - X'FIRST(2) + + Y'FIRST(2))) THEN + RETURN FALSE; + END IF; + END LOOP; + END LOOP; + END IF; + RETURN TRUE; + END EQUAL; + + FUNCTION AGGR (A, B, C, D : COMPONENT) RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F : COMPONENT) RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 1, + INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F, G, H : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 3, + INDEX'FIRST .. INDEX'FIRST + 1); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), D); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), E); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), F); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 3, INDEX'FIRST + 1), H); + RETURN X; + END AGGR; + + FUNCTION AGGR (A, B, C, D, E, F, G, H, I : COMPONENT) + RETURN PARENT IS + X : PARENT (INDEX'FIRST .. INDEX'FIRST + 2, + INDEX'FIRST .. INDEX'FIRST + 2); + BEGIN + ASSIGN (X (INDEX'FIRST , INDEX'FIRST ), A); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 1), B); + ASSIGN (X (INDEX'FIRST , INDEX'FIRST + 2), C); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST ), D); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 1), E); + ASSIGN (X (INDEX'FIRST + 1, INDEX'FIRST + 2), F); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST ), G); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 1), H); + ASSIGN (X (INDEX'FIRST + 2, INDEX'FIRST + 2), I); + RETURN X; + END AGGR; + + END PKG_P; + + BEGIN + TEST ("C34005V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "MULTI-DIMENSIONAL ARRAY TYPES WHOSE COMPONENT " & + "TYPE IS A LIMITED TYPE. THIS TEST IS PART 2 " & + "OF 2 TESTS WHICH COVER THE OBJECTIVE. THE " & + "FIRST PART IS IN TEST C34005S"); + + ASSIGN (X (IDENT_INT (4), IDENT_INT (6)), CREATE (1)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (7)), CREATE (2)); + ASSIGN (X (IDENT_INT (4), IDENT_INT (8)), CREATE (3)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (6)), CREATE (4)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (7)), CREATE (5)); + ASSIGN (X (IDENT_INT (5), IDENT_INT (8)), CREATE (6)); + + ASSIGN (W (4, 6), CREATE (1)); + ASSIGN (W (4, 7), CREATE (2)); + ASSIGN (W (4, 8), CREATE (3)); + ASSIGN (W (5, 6), CREATE (4)); + ASSIGN (W (5, 7), CREATE (5)); + ASSIGN (W (5, 8), CREATE (6)); + + ASSIGN (C, CREATE (2)); + + IF NOT EQUAL (T'(X), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T (W), AGGR (C1, C2, C3, C4, C5, C6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF NOT EQUAL (PARENT (X), AGGR (C1, C2, C3, C4, C5, C6)) OR + NOT EQUAL (PARENT (CREATE (6, 9, 2, 3, C4, X)), + AGGR (C4, C5, C6, C7, C8, C9, C10, C11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR WHEN PREPARING TO CONVERT " & + "TO PARENT"); + WHEN OTHERS => + FAILED ("EXCEPTION WHEN PREPARING TO CONVERT " & + "TO PARENT"); + END; + + IF NOT (X IN T) OR AGGR (C1, C2, C3, C4) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (AGGR (C1, C2, C3, C4, C5, C6, C7, C8, C9) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + RESULT; + END C34005V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C34006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS + -- AND WITH NON-LIMITED COMPONENT TYPES. + + -- HISTORY: + -- JRK 09/22/86 CREATED ORIGINAL TEST. + -- BCB 09/26/88 REMOVED COMPARISONS INVOLVING SIZE. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34006A IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE PARENT IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + TYPE T IS NEW PARENT; + + X : T := (2, FALSE); + K : INTEGER := X'SIZE; + W : PARENT := (2, FALSE); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X.C, X.C) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (-1, FALSE); + END IDENT; + + BEGIN + TEST ("C34006A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + X := IDENT ((1, TRUE)); + IF X /= (1, TRUE) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (1, TRUE) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (1, TRUE) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (1, TRUE); + END IF; + IF T (W) /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT ((1, TRUE)) /= (1, TRUE) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + IF X.C /= 1 OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.C := IDENT_INT (3); + X.B := IDENT_BOOL (FALSE); + IF X /= (3, FALSE) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X := IDENT ((1, TRUE)); + IF X = IDENT ((1, FALSE)) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((1, TRUE)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + + RESULT; + END C34006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,238 ---- + -- C34006D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH + -- NON-LIMITED COMPONENT TYPES. + + -- HISTORY: + -- JRK 09/22/86 CREATED ORIGINAL TEST. + -- BCB 11/13/87 CHANGED TEST SO AN OBJECT'S SIZE MAY BE LESS THAN + -- THAT OF ITS TYPE. + -- RJW 08/21/89 MODIFIED CHECKS FOR SIZE. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34006D IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := (TRUE, 3, 2, "AAA", 2); + W : PARENT := (TRUE, 3, 2, "AAA", 2); + C : COMPONENT := 1; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (X.I, X.I) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN (TRUE, 3, -1, "---", -1); + END IDENT; + + BEGIN + TEST ("C34006D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + X := IDENT ((TRUE, 3, 1, "ABC", 4)); + IF X /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := (TRUE, 3, 1, "ABC", 4); + END IF; + IF T (W) /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + BEGIN + IF PARENT (X) /= (TRUE, 3, 1, "ABC", 4) OR + PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + IF IDENT ((TRUE, 3, 1, "ABC", 4)) /= (TRUE, 3, 1, "ABC", 4) OR + X = (FALSE, 3, 1, 4.0) THEN + FAILED ("INCORRECT AGGREGATE"); + END IF; + + BEGIN + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + BEGIN + IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 3"); + END; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + X.C := IDENT_INT (9); + IF X /= (TRUE, 3, 7, "XYZ", 9) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X := IDENT ((TRUE, 3, 1, "ABC", 4)); + IF X = IDENT ((TRUE, 3, 1, "ABC", 5)) OR + X = (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= IDENT ((TRUE, 3, 1, "ABC", 4)) OR + NOT (X /= (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT ((FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + RESULT; + END C34006D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,228 ---- + -- C34006F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH NON-LIMITED + -- COMPONENT TYPES: + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR + -- THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 9/22/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34006F IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := (TRUE, 3, 2, "AAA", 2); + Y : S := (TRUE, 3, 2, "AAA", 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34006F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH " & + "NON-LIMITED COMPONENT TYPES"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + BEGIN + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= + (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE " & + "SUBTYPE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 1"); + END; + + BEGIN + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CALL TO CREATE RAISED CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("CALL TO CREATE RAISED EXCEPTION - 2"); + END; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + X := (TRUE, 3, 1, "ABC", 4); + Y := (TRUE, 3, 1, "ABC", 4); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (FALSE, 3, 2, 6.0)"); + IF X = (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (FALSE, 3, 2, 6.0)"); + IF Y = (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; + END C34006F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,199 ---- + -- C34006G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED RECORD TYPES WITHOUT DISCRIMINANTS AND + -- WITH A LIMITED COMPONENT TYPE. + + -- HISTORY: + -- JRK 08/24/87 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34006G IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C1 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C1 : CONSTANT LP := 1; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + TYPE PARENT IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL (X.C, Y.C) AND X.B = Y.B; + END EQUAL; + + FUNCTION AGGR (C : COMPONENT; B : BOOLEAN) RETURN PARENT IS + RESULT : PARENT; + BEGIN + ASSIGN (RESULT.C, C); + RESULT.B := B; + RETURN RESULT; + END AGGR; + + END PKG_P; + + BEGIN + TEST ("C34006G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITHOUT DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + ASSIGN (X.C, CREATE (1)); + X.B := IDENT_BOOL (TRUE); + + ASSIGN (W.C, CREATE (1)); + W.B := IDENT_BOOL (TRUE); + + IF NOT EQUAL (T'(X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T (W), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), AGGR (C1, TRUE)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF NOT EQUAL (X.C, C1) OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.B := IDENT_BOOL (FALSE); + IF NOT EQUAL (X, AGGR (C1, FALSE)) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X.B := IDENT_BOOL (TRUE); + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + IF X'SIZE < T'SIZE OR + X.C'SIZE < COMPONENT'SIZE OR + X.B'SIZE < BOOLEAN'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34006G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,311 ---- + -- C34006J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH + -- A LIMITED COMPONENT TYPE. + + -- HISTORY: + -- JRK 08/25/87 CREATED ORIGINAL TEST. + -- VCL 06/28/88 MODIFIED THE STATEMENTS INVOLVING THE 'SIZE + -- ATTRIBUTE TO REMOVE ANY ASSUMPTIONS ABOUT THE + -- SIZES. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34006J IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C4 : CONSTANT LP; + C5 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + A : PARENT (B, L); + BEGIN + A.I := I; + CASE B IS + WHEN TRUE => + A.S := S; + ASSIGN (A.C, C); + WHEN FALSE => + A.F := F; + END CASE; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN + RETURN FALSE; + END IF; + CASE X.B IS + WHEN TRUE => + RETURN X.S = Y.S AND EQUAL (X.C, Y.C); + WHEN FALSE => + RETURN X.F = Y.F; + END CASE; + END EQUAL; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.S := S; + ASSIGN (RESULT.C, C); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.F := F; + RETURN RESULT; + END AGGR; + + END PKG_P; + + BEGIN + TEST ("C34006J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + X.I := IDENT_INT (1); + X.S := IDENT_STR ("ABC"); + ASSIGN (X.C, CREATE (4)); + + W.I := IDENT_INT (1); + W.S := IDENT_STR ("ABC"); + ASSIGN (W.C, CREATE (4)); + + IF NOT EQUAL (T'(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T(X), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF NOT EQUAL (T(W), AGGR (TRUE, 3, 1, "ABC", C4)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT(X), AGGR (TRUE, 3, 1, "ABC", C4)) OR + NOT EQUAL (PARENT(CREATE (FALSE, 2, 3, "XX", C5, 6.0, X)), + AGGR (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.I /= 1 OR X.S /= "ABC" OR NOT EQUAL (X.C, C4) OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).I /= 3 OR + CREATE (FALSE, 2, 3, "XX", C5, 6.0, X).F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + IF NOT EQUAL (X, AGGR (TRUE, 3, 7, "XYZ", C4)) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + X.I := IDENT_INT (1); + X.S := IDENT_STR ("ABC"); + IF NOT (X IN T) OR AGGR (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (AGGR (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + IF X.C'FIRST_BIT < 0 THEN + FAILED ("INCORRECT 'FIRST_BIT"); + END IF; + + IF X.C'LAST_BIT < 0 OR + X.C'LAST_BIT - X.C'FIRST_BIT + 1 /= X.C'SIZE THEN + FAILED ("INCORRECT 'LAST_BIT"); + END IF; + + IF X.C'POSITION < 0 THEN + FAILED ("INCORRECT 'POSITION"); + END IF; + + IF X'SIZE < T'SIZE THEN + COMMENT ("X'SIZE < T'SIZE"); + ELSIF X'SIZE = T'SIZE THEN + COMMENT ("X'SIZE = T'SIZE"); + ELSE + COMMENT ("X'SIZE > T'SIZE"); + END IF; + + RESULT; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE CHECKING BASIC " & + "OPERATIONS"); + RESULT; + END C34006J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34006l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34006l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,345 ---- + -- C34006L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED RECORD TYPES WITH DISCRIMINANTS AND WITH A LIMITED + -- COMPONENT TYPE: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT + -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION + -- IS CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS + -- ALSO IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 08/26/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34006L IS + + PACKAGE PKG_L IS + + TYPE LP IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN LP; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP); + + C2 : CONSTANT LP; + C4 : CONSTANT LP; + C5 : CONSTANT LP; + C6 : CONSTANT LP; + + PRIVATE + + TYPE LP IS NEW INTEGER; + + C2 : CONSTANT LP := 2; + C4 : CONSTANT LP := 4; + C5 : CONSTANT LP := 5; + C6 : CONSTANT LP := 6; + + END PKG_L; + + USE PKG_L; + + SUBTYPE COMPONENT IS LP; + + PACKAGE PKG_P IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT; + + FUNCTION AGGR ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG_L IS + + FUNCTION CREATE (X : INTEGER) RETURN LP IS + BEGIN + RETURN LP (IDENT_INT (X)); + END CREATE; + + FUNCTION EQUAL (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT LP; Y : LP) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG_L; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + A : PARENT (B, L); + BEGIN + A.I := I; + CASE B IS + WHEN TRUE => + A.S := S; + ASSIGN (A.C, C); + WHEN FALSE => + A.F := F; + END CASE; + RETURN A; + END CREATE; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + IF X.B /= Y.B OR X.L /= Y.L OR X.I /= Y.I THEN + RETURN FALSE; + END IF; + CASE X.B IS + WHEN TRUE => + RETURN X.S = Y.S AND EQUAL (X.C, Y.C); + WHEN FALSE => + RETURN X.F = Y.F; + END CASE; + END EQUAL; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.S := S; + ASSIGN (RESULT.C, C); + RETURN RESULT; + END AGGR; + + FUNCTION AGGR + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + RESULT : PARENT (B, L); + BEGIN + RESULT.I := I; + RESULT.F := F; + RETURN RESULT; + END AGGR; + + END PKG_P; + + PROCEDURE ASSIGN (X : IN OUT T; Y : T) IS + BEGIN + X.I := Y.I; + X.S := Y.S; + ASSIGN (X.C, Y.C); + END ASSIGN; + + PROCEDURE ASSIGN (X : IN OUT S; Y : S) IS + BEGIN + X.I := Y.I; + X.S := Y.S; + ASSIGN (X.C, Y.C); + END ASSIGN; + + BEGIN + TEST ("C34006L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "RECORD TYPES WITH DISCRIMINANTS AND WITH A " & + "LIMITED COMPONENT TYPE"); + + ASSIGN (X.C, CREATE (2)); + ASSIGN (Y.C, C2); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X), + AGGR (FALSE, 2, 3, 6.0)) OR + NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y), + AGGR (FALSE, 2, 3, 6.0)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", C5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + ASSIGN (X, AGGR (TRUE, 3, 1, "ABC", C4)); + ASSIGN (Y, AGGR (TRUE, 3, 1, "ABC", C4)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, AGGR (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + IF EQUAL (X, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + IF EQUAL (X, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END; + + BEGIN + ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + IF EQUAL (Y, AGGR (FALSE, 3, 2, 6.0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + IF EQUAL (Y, AGGR (TRUE, 4, 2, "ZZZZ", C6)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, AGGR (TRUE, 4, 2, ""ZZZZ"", C6))"); + END; + + RESULT; + END C34006L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,181 ---- + -- C34007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS + -- NOT AN ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A TYPE WITH + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/24/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007A IS + + TYPE DESIGNATED IS RANGE -100 .. 100; + + SUBTYPE SUBDESIGNATED IS DESIGNATED RANGE + DESIGNATED'VAL (IDENT_INT (-50)) .. + DESIGNATED'VAL (IDENT_INT ( 50)); + + TYPE PARENT IS ACCESS SUBDESIGNATED RANGE + DESIGNATED'VAL (IDENT_INT (-30)) .. + DESIGNATED'VAL (IDENT_INT ( 30)); + + TYPE T IS NEW PARENT; + + X : T := NEW DESIGNATED'(-30); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'( 30); + W : PARENT := NEW DESIGNATED'( 30); + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (DESIGNATED'POS (X.ALL), DESIGNATED'POS (X.ALL)) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED; + END IDENT; + + BEGIN + TEST ("C34007A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS NOT AN " & + "ARRAY TYPE, A TASK TYPE, A RECORD TYPE, OR A " & + "TYPE WITH DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= 30 THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(-30); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= -30 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= 30 OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(30)); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= 30 THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.ALL /= 30 THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := DESIGNATED'VAL (IDENT_INT (10)); + IF X /= Y OR Y.ALL /= 10 THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := 30; + X := IDENT (NULL); + BEGIN + IF X.ALL = 0 THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL OF COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- C34007D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 1 OF 2 TESTS + -- WHICH COVER THE OBJECTIVE. THE SECOND PART IS IN TEST C34007V. + + -- HISTORY: + -- JRK 09/25/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- BCB 04/12/90 SPLIT ORIGINAL TEST INTO C34007D.ADA AND + -- C34007V.ADA. PUT CHECK FOR 'STORAGE_SIZE IN + -- EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007D IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) .. + IDENT_INT (7)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + K : INTEGER := X'SIZE; + Y : T := NEW SUBDESIGNATED'(1, 2, 3); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2); + C : COMPONENT := 1; + N : CONSTANT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => C); + END V; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + + BEGIN + TEST ("C34007D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " & + "PART 1 OF 2 TESTS WHICH COVER THE OBJECTIVE. " & + "THE SECOND PART IS IN TEST C34007V"); + + IF Y = NULL OR ELSE Y.ALL /= (1, 2, 3) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW SUBDESIGNATED'(1, 2, 3); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (1, 2, 3) OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW SUBDESIGNATED'(1, 2, 3)); + IF (X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, 2, 3)) OR + X = NEW DESIGNATED'(1, 2) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (NULL); + BEGIN + IF X.ALL = (0, 0, 0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + X (IDENT_INT (7)) := 4; + IF X /= Y OR Y.ALL /= (1, 2, 4) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + X (IDENT_INT (5) .. IDENT_INT (6)) := (4, 5); + IF X /= Y OR Y.ALL /= (4, 5, 3) THEN + FAILED ("INCORRECT SLICE (ASSIGNMENT)"); + END IF; + + A (X'ADDRESS); + + IF X'FIRST /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF X'FIRST (N) /= 5 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 5 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF X'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF X'LAST (N) /= 7 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 7 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF X'LENGTH /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : DESIGNATED (X'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (X'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE (N)); + BEGIN + IF Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C34007F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A ONE-DIMENSIONAL + -- ARRAY TYPE: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 9/25/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34007F IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (5 .. 7); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + SUBTYPE SUBPARENT IS PARENT (5 .. 7); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + Y : S := NEW SUBDESIGNATED'(OTHERS => 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34007F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (2, 3, 4, X) . ALL /= (4, 5) OR + CREATE (2, 3, 4, Y) . ALL /= (4, 5) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (2, 3, 4, X) IN T OR + CREATE (2, 3, 4, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X'FIRST /= 5 OR X'LAST /= 7 OR + Y'FIRST /= 5 OR Y'LAST /= 7 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := NEW SUBDESIGNATED'(1, 2, 3); + Y := NEW SUBDESIGNATED'(1, 2, 3); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(6 .. 8 => 0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + IF X = NULL OR ELSE X.ALL = (0, 0, 0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(6 .. 8 => 0)"); + END; + + BEGIN + Y := NEW DESIGNATED'(6 .. 8 => 0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + IF Y = NULL OR ELSE Y.ALL = (0, 0, 0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(6 .. 8 => 0)"); + END; + + RESULT; + END C34007F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- C34007G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- MULTI-DIMENSIONAL ARRAY TYPE. + + -- HISTORY: + -- JRK 09/25/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007G IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF + COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED + (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + Y : T := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + C : COMPONENT := 1; + N : CONSTANT := 2; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => (OTHERS => C)); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + + BEGIN + TEST ("C34007G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "MULTI-DIMENSIONAL ARRAY TYPE"); + + IF Y = NULL OR ELSE Y.ALL /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= ((1, 2, 3), (4, 5, 6)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= ((1, 2, 3), (4, 5, 6)) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (6, 9, 2, 3, 4, X)); + IF W = NULL OR ELSE + W.ALL /= ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6))); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= ((1, 2, 3), (4, 5, 6))) OR + X = NEW DESIGNATED'((1, 2), (3, 4), (5, 6)) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.ALL /= ((1, 2, 3), (4, 5, 6)) OR + CREATE (6, 9, 2, 3, 4, X) . ALL /= + ((4, 5), (6, 7), (8, 9), (10, 11)) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := ((10, 11, 12), (13, 14, 15)); + IF X /= Y OR Y.ALL /= ((10, 11, 12), (13, 14, 15)) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := ((1, 2, 3), (4, 5, 6)); + BEGIN + CREATE (6, 9, 2, 3, 4, X) . ALL := + ((20, 21), (22, 23), (24, 25), (26, 27)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = ((0, 0, 0), (0, 0, 0)) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X (IDENT_INT (4), IDENT_INT (6)) /= 1 OR + CREATE (6, 9, 2, 3, 4, X) (9, 3) /= 11 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + X (IDENT_INT (5), IDENT_INT (8)) := 7; + IF X /= Y OR Y.ALL /= ((1, 2, 3), (4, 5, 7)) THEN + FAILED ("INCORRECT INDEX (ASSIGNMENT)"); + END IF; + + Y.ALL := ((1, 2, 3), (4, 5, 6)); + X := IDENT (Y); + BEGIN + CREATE (6, 9, 2, 3, 4, X) (6, 2) := 15; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)"); + END; + + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (6, 9, 2, 3, 4, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (7, 9, 2, 4, 1, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (2, 3, 4, 5, 1, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CREATE (7, 9, 2, 4, 1, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF X'FIRST /= 4 THEN + FAILED ("INCORRECT OBJECT'FIRST"); + END IF; + + IF V'FIRST /= 4 THEN + FAILED ("INCORRECT VALUE'FIRST"); + END IF; + + IF X'FIRST (N) /= 6 THEN + FAILED ("INCORRECT OBJECT'FIRST (N)"); + END IF; + + IF V'FIRST (N) /= 6 THEN + FAILED ("INCORRECT VALUE'FIRST (N)"); + END IF; + + IF X'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'LAST"); + END IF; + + IF V'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'LAST"); + END IF; + + IF X'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'LAST (N)"); + END IF; + + IF V'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'LAST (N)"); + END IF; + + IF X'LENGTH /= 2 THEN + FAILED ("INCORRECT OBJECT'LENGTH"); + END IF; + + IF V'LENGTH /= 2 THEN + FAILED ("INCORRECT VALUE'LENGTH"); + END IF; + + IF X'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT OBJECT'LENGTH (N)"); + END IF; + + IF V'LENGTH (N) /= 3 THEN + FAILED ("INCORRECT VALUE'LENGTH (N)"); + END IF; + + DECLARE + Y : DESIGNATED (X'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT OBJECT'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (V'RANGE, 1 .. 3); + BEGIN + IF Y'FIRST /= 4 OR Y'LAST /= 5 THEN + FAILED ("INCORRECT VALUE'RANGE"); + END IF; + END; + + DECLARE + Y : DESIGNATED (1 .. 2, X'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT OBJECT'RANGE (N)"); + END IF; + END; + + DECLARE + Y : DESIGNATED (1 .. 2, V'RANGE (N)); + BEGIN + IF Y'FIRST (N) /= 6 OR Y'LAST (N) /= 8 THEN + FAILED ("INCORRECT VALUE'RANGE (N)"); + END IF; + END; + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007i.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- C34007I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A MULTI-DIMENSIONAL + -- ARRAY TYPE: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 9/25/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34007I IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) OF + COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (4 .. 5, 6 .. 8); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (4) .. IDENT_INT (5), + IDENT_INT (6) .. IDENT_INT (8)); + + SUBTYPE SUBPARENT IS PARENT (4 .. 5, 6 .. 8); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + Y : S := NEW SUBDESIGNATED'(OTHERS => (OTHERS => 2)); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F1, L1 : NATURAL; + F2, L2 : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F1 .. L1, F2 .. L2); + B : COMPONENT := C; + BEGIN + FOR I IN F1 .. L1 LOOP + FOR J IN F2 .. L2 LOOP + A (I, J) := B; + B := B + 1; + END LOOP; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34007I", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "MULTI-DIMENSIONAL ARRAY TYPE"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (6, 9, 2, 3, 1, X) . ALL /= + ((1, 2), (3, 4), (5, 6), (7, 8)) OR + CREATE (6, 9, 2, 3, 1, Y) . ALL /= + ((1, 2), (3, 4), (5, 6), (7, 8)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (6, 9, 2, 3, 1, X) IN T OR + CREATE (6, 9, 2, 3, 1, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X'FIRST /= 4 OR X'LAST /= 5 OR + Y'FIRST /= 4 OR Y'LAST /= 5 OR + X'FIRST (2) /= 6 OR X'LAST (2) /= 8 OR + Y'FIRST (2) /= 6 OR Y'LAST (2) /= 8 THEN + FAILED ("INCORRECT 'FIRST OR 'LAST"); + END IF; + + BEGIN + X := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + Y := NEW SUBDESIGNATED'((1, 2, 3), (4, 5, 6)); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + IF X = NULL OR ELSE + X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(5 .. 6 => " & + "(6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + IF X = NULL OR ELSE + X.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(4 .. 5 => " & + "(5 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + IF Y = NULL OR ELSE + Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => " & + "(6 .. 8 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(5 .. 6 => (6 .. 8 => 0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + IF Y = NULL OR ELSE + Y.ALL = ((0, 0, 0), (0, 0, 0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => " & + "(5 .. 7 => 0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(4 .. 5 => (5 .. 7 => 0))"); + END; + + RESULT; + END C34007I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,258 ---- + -- C34007J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE + -- IS A TASK TYPE. + + -- HISTORY: + -- JRK 09/26/86 CREATED ORIGINAL TEST. + -- JLH 09/25/87 REFORMATTED HEADER. + -- BCB 09/26/88 REMOVED COMPARISION INVOLVING OBJECT SIZE. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007J IS + + TASK TYPE DESIGNATED IS + ENTRY E (I : IN OUT INTEGER); + ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER); + ENTRY R (I : OUT INTEGER); + ENTRY W (I : INTEGER); + END DESIGNATED; + + TYPE PARENT IS ACCESS DESIGNATED; + + TYPE T IS NEW PARENT; + + X : T; + K : INTEGER := X'SIZE; + Y : T; + W : PARENT; + I : INTEGER := 0; + J : INTEGER := 0; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW DESIGNATED; + END V; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF (X = NULL OR ELSE X'CALLABLE) OR IDENT_BOOL (TRUE) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED; + END IDENT; + + TASK BODY DESIGNATED IS + N : INTEGER := 1; + BEGIN + LOOP + SELECT + ACCEPT E (I : IN OUT INTEGER) DO + I := I + N; + END E; + OR + ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO + J := I + N; + END F; + OR + ACCEPT R (I : OUT INTEGER) DO + I := N; + END R; + OR + ACCEPT W (I : INTEGER) DO + N := I; + END W; + OR + TERMINATE; + END SELECT; + END LOOP; + END DESIGNATED; + + BEGIN + TEST ("C34007J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "TASK TYPE"); + + X := NEW DESIGNATED; + Y := NEW DESIGNATED; + W := NEW DESIGNATED; + + IF Y = NULL THEN + FAILED ("INCORRECT INITIALIZATION - 1"); + ELSE Y.W (2); + Y.R (I); + IF I /= 2 THEN + FAILED ("INCORRECT INITIALIZATION - 2"); + END IF; + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED; + W.W (3); + END IF; + X := T (W); + IF X = NULL OR X = Y THEN + FAILED ("INCORRECT CONVERSION FROM PARENT - 1"); + ELSE I := 5; + X.E (I); + IF I /= 8 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT - 2"); + END IF; + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + ELSE I := 5; + W.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED); + IF X = NULL OR X = Y THEN + FAILED ("INCORRECT ALLOCATOR - 1"); + ELSE I := 5; + X.E (I); + IF I /= 6 THEN + FAILED ("INCORRECT ALLOCATOR - 2"); + END IF; + END IF; + + X := IDENT (Y); + I := 5; + X.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT SELECTION (ENTRY)"); + END IF; + + I := 5; + X.F (IDENT_INT (2)) (I, J); + IF J /= 7 THEN + FAILED ("INCORRECT SELECTION (FAMILY)"); + END IF; + + I := 5; + X.ALL.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT .ALL"); + END IF; + + X := IDENT (NULL); + BEGIN + IF X.ALL'CALLABLE THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF NOT X'CALLABLE THEN + FAILED ("INCORRECT OBJECT'CALLABLE"); + END IF; + + IF NOT V'CALLABLE THEN + FAILED ("INCORRECT VALUE'CALLABLE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + IF X'TERMINATED THEN + FAILED ("INCORRECT OBJECT'TERMINATED"); + END IF; + + IF V'TERMINATED THEN + FAILED ("INCORRECT VALUE'TERMINATED"); + END IF; + + RESULT; + END C34007J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007m.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C34007M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- RECORD TYPE WITHOUT DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/29/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007M IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS + RECORD + C : COMPONENT; + B : BOOLEAN := TRUE; + END RECORD; + + TYPE PARENT IS ACCESS DESIGNATED; + + TYPE T IS NEW PARENT; + + X : T := NEW DESIGNATED'(2, FALSE); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'(1, TRUE); + W : PARENT := NEW DESIGNATED'(2, FALSE); + C : COMPONENT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.C, X.C) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(-1, FALSE); + END IDENT; + + BEGIN + TEST ("C34007M", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITHOUT DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(1, TRUE); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (1, TRUE) OR ELSE T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(1, TRUE)); + IF X = NULL OR ELSE X = Y OR ELSE X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.C /= 1 OR X.B /= TRUE THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.C := IDENT_INT (3); + X.B := IDENT_BOOL (FALSE); + IF X /= Y OR Y.ALL /= (3, FALSE) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, TRUE); + X := IDENT (Y); + IF X.ALL /= (1, TRUE) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (10, FALSE); + IF X /= Y OR Y.ALL /= (10, FALSE) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, TRUE); + X := IDENT (NULL); + BEGIN + IF X.ALL = (0, FALSE) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW DESIGNATED OR NOT (X = Y) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,283 ---- + -- C34007P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- RECORD TYPE WITH DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/29/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007P IS + + SUBTYPE COMPONENT IS INTEGER; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE), + IDENT_INT (3)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + W : PARENT := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + C : COMPONENT := 1; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN NEW DESIGNATED'(TRUE, L, I, S, C); + WHEN FALSE => + RETURN NEW DESIGNATED'(FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.I, X.I) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(TRUE, 3, -1, "---", -1); + END IDENT; + + BEGIN + TEST ("C34007P", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITH DISCRIMINANTS"); + + IF Y = NULL OR ELSE Y.ALL /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE W.ALL /= (TRUE, 3, 1, "ABC", 4) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)); + IF W = NULL OR ELSE W.ALL /= (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4)); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= (TRUE, 3, 1, "ABC", 4)) OR + X = NEW DESIGNATED'(FALSE, 3, 1, 4.0) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.I /= 1 OR X.S /= "ABC" OR X.C /= 4 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F /= 6.0 THEN + FAILED ("INCORRECT SELECTION (VALUE)"); + END IF; + + X.I := IDENT_INT (7); + X.S := IDENT_STR ("XYZ"); + X.C := IDENT_INT (9); + IF X /= Y OR Y.ALL /= (TRUE, 3, 7, "XYZ", 9) THEN + FAILED ("INCORRECT SELECTION (ASSIGNMENT)"); + END IF; + + Y.ALL := (TRUE, 3, 1, "ABC", 4); + X := IDENT (Y); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . I := 10; + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . F := 10.0; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR SELECTION (ASSIGNMENT)"); + END; + + IF X.ALL /= (TRUE, 3, 1, "ABC", 4) OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (TRUE, 3, 10, "ZZZ", 15); + IF X /= Y OR Y.ALL /= (TRUE, 3, 10, "ZZZ", 15) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (TRUE, 3, 1, "ABC", 4); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL := + (FALSE, 2, 10, 15.0); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = (FALSE, 0, 0, 0.0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007r.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,218 ---- + -- C34007R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A RECORD TYPE + -- WITH DISCRIMINANTS: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 9/29/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34007R IS + + SUBTYPE COMPONENT IS INTEGER; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + C : COMPONENT; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + Y : S := NEW DESIGNATED'(TRUE, 3, 2, "AAA", 2); + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN NEW DESIGNATED'(TRUE, L, I, S, C); + WHEN FALSE => + RETURN NEW DESIGNATED'(FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG; + + BEGIN + TEST ("C34007R", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "RECORD TYPE WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) . ALL /= + (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) . ALL /= + (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + BEGIN + X := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + Y := NEW DESIGNATED'(TRUE, 3, 1, "ABC", 4); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + IF X = NULL OR ELSE X.ALL = (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = NULL OR ELSE + X.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + IF Y = NULL OR ELSE Y.ALL = (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := NEW DESIGNATED'(TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = NULL OR ELSE + Y.ALL = (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'(TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; + END C34007R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007s.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,299 ---- + -- C34007S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- PRIVATE TYPE WITH DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/30/86 CREATED ORIGINAL TEST. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. REVISED TEST SO + -- T'STORAGE_SIZE IS NOT REQUIRED TO BE > 1. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- BCB 03/07/90 PUT CHECK FOR 'STORAGE_SIZE IN EXCEPTION HANDLER. + -- THS 09/18/90 REMOVED DECLARATION OF B, MADE THE BODY OF + -- PROCEDURE A NULL, AND DELETED ALL REFERENCES TO B. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007S IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG_D IS + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED; + + PRIVATE + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG_D; + + USE PKG_D; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_BOOL (TRUE), + IDENT_INT (3)); + + PACKAGE PKG_P IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T := NEW DESIGNATED (TRUE, 3); + K : INTEGER := X'SIZE; + Y : T := NEW DESIGNATED (TRUE, 3); + W : PARENT := NEW DESIGNATED (TRUE, 3); + + PROCEDURE A (X : ADDRESS) IS + BEGIN + NULL; + END A; + + PACKAGE BODY PKG_D IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG_D; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F)); + END CREATE; + + END PKG_P; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE EQUAL (X.L, X.L) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW DESIGNATED'(CREATE (TRUE, 3, -1, "---", -1, -1.0)); + END IDENT; + + BEGIN + TEST ("C34007S", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "PRIVATE TYPE WITH DISCRIMINANTS"); + + Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0); + IF Y = NULL OR ELSE + Y.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + X := IDENT (Y); + IF X /= Y THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= Y THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= Y THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + END IF; + X := T (W); + IF X = NULL OR ELSE X = Y OR ELSE + X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + X := IDENT (Y); + W := PARENT (X); + IF W = NULL OR ELSE + W.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR ELSE + T (W) /= Y THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 1"); + END IF; + + W := PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)); + IF W = NULL OR ELSE + W.ALL /= CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + IF IDENT (NULL) /= NULL OR X = NULL THEN + FAILED ("INCORRECT NULL"); + END IF; + + X := IDENT (NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0))); + IF (X = NULL OR ELSE X = Y OR ELSE + X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0)) OR + X = NEW DESIGNATED'(CREATE (FALSE, 3, 1, "XXX", 5, 4.0)) THEN + FAILED ("INCORRECT ALLOCATOR"); + END IF; + + X := IDENT (Y); + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X.ALL /= CREATE (TRUE, 3, 1, "ABC", 4, 2.0) OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := CREATE (TRUE, 3, 10, "ZZZ", 15, 1.0); + IF X /= Y OR Y.ALL /= CREATE (TRUE, 3, 10, "ZZZ", 15, 2.0) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := CREATE (TRUE, 3, 1, "ABC", 4, 1.0); + BEGIN + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . ALL := + CREATE (FALSE, 2, 10, "ZZ", 7, 15.0); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + X := IDENT (NULL); + BEGIN + IF X.ALL = CREATE (FALSE, 0, 0, "", 0, 0.0) THEN + FAILED ("NO EXCEPTION FOR NULL.ALL - 1"); + ELSE FAILED ("NO EXCEPTION FOR NULL.ALL - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION FOR NULL.ALL"); + END; + + X := IDENT (Y); + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR + NOT (X /= CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR + NOT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + A (X'ADDRESS); + + IF T'SIZE < 1 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + BEGIN + IF T'STORAGE_SIZE /= PARENT'STORAGE_SIZE THEN + FAILED ("COLLECTION SIZE OF DERIVED TYPE IS NOT " & + "EQUAL TO COLLECTION SIZE OF PARENT TYPE"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED FOR " & + "UNDEFINED STORAGE_SIZE (AI-00608)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + END C34007S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007u.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007u.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007u.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007u.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- C34007U.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A PRIVATE TYPE + -- WITH DISCRIMINANTS: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT FOR THE + -- DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION IS + -- CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS ALSO + -- IMPOSED ON THE DERIVED SUBTYPE. + + -- JRK 9/30/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C34007U IS + + SUBTYPE COMPONENT IS INTEGER; + + PACKAGE PKG_D IS + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. 10; + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED; + + PRIVATE + + TYPE DESIGNATED (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + C : COMPONENT := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG_D; + + USE PKG_D; + + PACKAGE PKG_P IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG_P; + + USE PKG_P; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T := NEW DESIGNATED (TRUE, 3); + Y : S := NEW DESIGNATED (TRUE, 3); + + PACKAGE BODY PKG_D IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT + ) RETURN DESIGNATED + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, C); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + END PKG_D; + + PACKAGE BODY PKG_P IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + C : COMPONENT; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + RETURN NEW DESIGNATED'(CREATE (B, L, I, S, C, F)); + END CREATE; + + END PKG_P; + + BEGIN + TEST ("C34007U", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "PRIVATE TYPE WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "WW", 5, 6.0, X) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) OR + CREATE (FALSE, 2, 3, "WW", 5, 6.0, Y) . ALL /= + CREATE (FALSE, 2, 3, "ZZ", 7, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + BEGIN + X := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + Y := NEW DESIGNATED'(CREATE (TRUE, 3, 1, "ABC", 4, 1.0)); + IF PARENT (X) = PARENT (Y) OR -- USE X AND Y. + X.ALL /= Y.ALL THEN + FAILED ("INCORRECT ALLOCATOR OR CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + IF X = NULL OR ELSE + X.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END; + + BEGIN + X := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + IF X = NULL OR ELSE + X.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + IF Y = NULL OR ELSE + Y.ALL = CREATE (FALSE, 3, 2, "ZZZ", 5, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (FALSE, 3, 2, ""ZZZ"", 5, 6.0))"); + END; + + BEGIN + Y := NEW DESIGNATED'(CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + IF Y = NULL OR ELSE + Y.ALL = CREATE (TRUE, 4, 2, "ZZZZ", 6, 7.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := NEW DESIGNATED'" & + "(CREATE (TRUE, 4, 2, ""ZZZZ"", 6, 7.0))"); + END; + + RESULT; + END C34007U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34007v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34007v.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C34007V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED ACCESS TYPES WHOSE DESIGNATED TYPE IS A + -- ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS PART 2 OF 2 TESTS + -- WHICH COVER THE OBJECTIVE. THE FIRST PART IS IN TEST C34007D. + + -- HISTORY: + -- BCB 04/12/90 CREATED ORIGINAL TEST FROM SPLIT OF C34007D.ADA. + -- THS 09/18/90 REMOVED DECLARATION OF B, DELETED PROCEDURE A, + -- AND REMOVED ALL REFERENCES TO B. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34007V IS + + SUBTYPE COMPONENT IS INTEGER; + + TYPE DESIGNATED IS ARRAY (NATURAL RANGE <>) OF COMPONENT; + + SUBTYPE SUBDESIGNATED IS DESIGNATED (IDENT_INT (5) .. + IDENT_INT (7)); + + PACKAGE PKG IS + + TYPE PARENT IS ACCESS DESIGNATED; + + FUNCTION CREATE ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_INT (5) .. IDENT_INT (7)); + + X : T := NEW SUBDESIGNATED'(OTHERS => 2); + K : INTEGER := X'SIZE; + Y : T := NEW SUBDESIGNATED'(1, 2, 3); + W : PARENT := NEW SUBDESIGNATED'(OTHERS => 2); + C : COMPONENT := 1; + N : CONSTANT := 1; + + FUNCTION V RETURN T IS + BEGIN + RETURN NEW SUBDESIGNATED'(OTHERS => C); + END V; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( F, L : NATURAL; + C : COMPONENT; + DUMMY : PARENT + ) RETURN PARENT + IS + A : PARENT := NEW DESIGNATED (F .. L); + B : COMPONENT := C; + BEGIN + FOR I IN F .. L LOOP + A (I) := B; + B := B + 1; + END LOOP; + RETURN A; + END CREATE; + + END PKG; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF X = NULL OR ELSE + EQUAL (X'LENGTH, X'LENGTH) THEN + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN NEW SUBDESIGNATED; + END IDENT; + + BEGIN + TEST ("C34007V", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "ACCESS TYPES WHOSE DESIGNATED TYPE IS A " & + "ONE-DIMENSIONAL ARRAY TYPE. THIS TEST IS " & + "PART 2 OF 2 TESTS WHICH COVER THE OBJECTIVE. " & + "THE FIRST PART IS IN TEST C34007V"); + + W := PARENT (CREATE (2, 3, 4, X)); + IF W = NULL OR ELSE W.ALL /= (4, 5) THEN + FAILED ("INCORRECT CONVERSION TO PARENT - 2"); + END IF; + + X := IDENT (Y); + IF X.ALL /= (1, 2, 3) OR CREATE (2, 3, 4, X) . ALL /= (4, 5) THEN + FAILED ("INCORRECT .ALL (VALUE)"); + END IF; + + X.ALL := (10, 11, 12); + IF X /= Y OR Y.ALL /= (10, 11, 12) THEN + FAILED ("INCORRECT .ALL (ASSIGNMENT)"); + END IF; + + Y.ALL := (1, 2, 3); + BEGIN + CREATE (2, 3, 4, X) . ALL := (10, 11); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR .ALL (ASSIGNMENT)"); + END; + + + X := IDENT (Y); + IF X (IDENT_INT (5)) /= 1 OR + CREATE (2, 3, 4, X) (3) /= 5 THEN + FAILED ("INCORRECT INDEX (VALUE)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + BEGIN + CREATE (2, 3, 4, X) (2) := 10; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR INDEX (ASSIGNMENT)"); + END; + + IF X (IDENT_INT (6) .. IDENT_INT (7)) /= (2, 3) OR + CREATE (1, 4, 4, X) (1 .. 3) /= (4, 5, 6) THEN + FAILED ("INCORRECT SLICE (VALUE)"); + END IF; + + Y.ALL := (1, 2, 3); + X := IDENT (Y); + BEGIN + CREATE (1, 4, 4, X) (2 .. 4) := (10, 11, 12); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR SLICE (ASSIGNMENT)"); + END; + + IF X = NULL OR X = NEW SUBDESIGNATED OR NOT (X = Y) OR + X = CREATE (2, 3, 4, X) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= Y OR NOT (X /= NULL) OR NOT (X /= CREATE (2, 3, 4, X)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CREATE (2, 3, 4, X) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CREATE (2, 3, 4, X) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + RESULT; + END C34007V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34008a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- C34008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED TASK TYPES. + + -- HISTORY: + -- JRK 08/27/87 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + -- DTN 11/30/95 REMOVED ATTIBUTES OF NON-OBJECTS. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34008A IS + + PACKAGE PKG IS + + TASK TYPE PARENT IS + ENTRY E (I : IN OUT INTEGER); + ENTRY F (1 .. 3) (I : INTEGER; J : OUT INTEGER); + ENTRY G; + ENTRY H (1 .. 3); + ENTRY R (I : OUT INTEGER); + ENTRY W (I : INTEGER); + END PARENT; + + FUNCTION ID (X : PARENT) RETURN INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + TASK TYPE AUX; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + I : INTEGER := 0; + J : INTEGER := 0; + A1, A2 : AUX; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + FUNCTION V RETURN T IS + BEGIN + RETURN X; + END V; + + PACKAGE BODY PKG IS + + TASK BODY PARENT IS + N : INTEGER := 1; + BEGIN + LOOP + SELECT + ACCEPT E (I : IN OUT INTEGER) DO + I := I + N; + END E; + OR + ACCEPT F (2) (I : INTEGER; J : OUT INTEGER) DO + J := I + N; + END F; + OR + ACCEPT G DO + WHILE H(2)'COUNT < 2 LOOP + DELAY 5.0; + END LOOP; + ACCEPT H (2) DO + IF E'COUNT /= 0 OR + F(1)'COUNT /= 0 OR + F(2)'COUNT /= 0 OR + F(3)'COUNT /= 0 OR + G'COUNT /= 0 OR + H(1)'COUNT /= 0 OR + H(2)'COUNT /= 1 OR + H(3)'COUNT /= 0 OR + R'COUNT /= 0 OR + W'COUNT /= 0 THEN + FAILED ("INCORRECT 'COUNT"); + END IF; + END H; + ACCEPT H (2); + END G; + OR + ACCEPT R (I : OUT INTEGER) DO + I := N; + END R; + OR + ACCEPT W (I : INTEGER) DO + N := I; + END W; + OR + TERMINATE; + END SELECT; + END LOOP; + END PARENT; + + FUNCTION ID (X : PARENT) RETURN INTEGER IS + I : INTEGER; + BEGIN + X.R (I); + RETURN I; + END ID; + + END PKG; + + TASK BODY AUX IS + BEGIN + X.H (2); + END AUX; + + BEGIN + TEST ("C34008A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED TASK " & + "TYPES"); + + X.W (IDENT_INT (2)); + IF ID (X) /= 2 THEN + FAILED ("INCORRECT INITIALIZATION"); + END IF; + + IF ID (T'(X)) /= 2 THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF ID (T (X)) /= 2 THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + W.W (IDENT_INT (3)); + IF ID (T (W)) /= 3 THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF ID (PARENT (X)) /= 2 THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + I := 5; + X.E (I); + IF I /= 7 THEN + FAILED ("INCORRECT SELECTION (ENTRY)"); + END IF; + + I := 5; + X.F (IDENT_INT (2)) (I, J); + IF J /= 7 THEN + FAILED ("INCORRECT SELECTION (FAMILY)"); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT OBJECT'ADDRESS"); + END IF; + + IF NOT X'CALLABLE THEN + FAILED ("INCORRECT OBJECT'CALLABLE"); + END IF; + + IF NOT V'CALLABLE THEN + FAILED ("INCORRECT VALUE'CALLABLE"); + END IF; + + X.G; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + IF T'STORAGE_SIZE < 0 THEN + FAILED ("INCORRECT TYPE'STORAGE_SIZE"); + END IF; + + IF X'STORAGE_SIZE < 0 THEN + FAILED ("INCORRECT OBJECT'STORAGE_SIZE"); + END IF; + + IF X'TERMINATED THEN + FAILED ("INCORRECT OBJECT'TERMINATED"); + END IF; + + IF V'TERMINATED THEN + FAILED ("INCORRECT VALUE'TERMINATED"); + END IF; + + RESULT; + END C34008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C34009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITHOUT + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 08/28/87 CREATED ORIGINAL TEST. + -- BCB 09/26/88 REMOVED COMPARISON INVOLVING OBJECT SIZE. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34009A IS + + PACKAGE PKG IS + + TYPE PARENT IS PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN PARENT; + + FUNCTION CON (X : INTEGER) RETURN PARENT; + + PRIVATE + + TYPE PARENT IS NEW INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + X : T; + K : INTEGER := X'SIZE; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (IDENT_INT (X)); + END CREATE; + + FUNCTION CON (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (X); + END CON; + + END PKG; + + BEGIN + TEST ("C34009A", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITHOUT " & + "DISCRIMINANTS"); + + X := CREATE (30); + IF X /= CON (30) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= CON (30) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= CON (30) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + W := CREATE (-30); + IF T (W) /= CON (-30) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= CON (30) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X = CON (0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= CON (30) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + RESULT; + END C34009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- C34009D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED NON-LIMITED PRIVATE TYPES WITH + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 08/31/87 CREATED ORIGINAL TEST. + -- WMC 03/13/92 REVISED TYPE'SIZE CHECKS. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34009D IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + J : INTEGER; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + END PKG; + + BEGIN + TEST ("C34009D", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + X := CON (TRUE, 3, 2, "AAA", 2); + W := CON (TRUE, 3, 2, "AAA", 2); + + IF EQUAL (3, 3) THEN + X := CON (TRUE, 3, 1, "ABC", 4); + END IF; + IF X /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT :="); + END IF; + + IF T'(X) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF T (X) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + W := CON (TRUE, 3, 1, "ABC", 4); + END IF; + IF T (W) /= CON (TRUE, 3, 1, "ABC", 4) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF PARENT (X) /= CON (TRUE, 3, 1, "ABC", 4) OR + PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)) /= + CON (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF X = CON (TRUE, 3, 1, "ABC", 5) OR + X = CON (FALSE, 2, 3, 6.0) THEN + FAILED ("INCORRECT ="); + END IF; + + IF X /= CON (TRUE, 3, 1, "ABC", 4) OR + NOT (X /= CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT /="); + END IF; + + IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT OBJECT'CONSTRAINED"); + END IF; + + IF T'SIZE <= 0 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE OR + X.B'SIZE < BOOLEAN'SIZE OR + X.L'SIZE < LENGTH'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34009D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- C34009F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT + -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION + -- IS CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS + -- ALSO IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 08/31/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34009F IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 1) IS + RECORD + I : INTEGER; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L); + J : INTEGER; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + END PKG; + + BEGIN + TEST ("C34009F", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "NON-LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + X := CON (TRUE, 3, 2, "AAA", 2); + Y := CON (TRUE, 3, 2, "AAA", 2); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) /= + CON (FALSE, 2, 3, 6.0) OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) /= + CON (FALSE, 2, 3, 6.0) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + X := CON (TRUE, 3, 1, "ABC", 4); + Y := CON (TRUE, 3, 1, "ABC", 4); + IF PARENT (X) /= PARENT (Y) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGNMENT"); + END; + + BEGIN + X := CON (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := CON (FALSE, 3, 2, 6.0)"); + IF X = CON (FALSE, 3, 2, 6.0) THEN -- USE X. + COMMENT ("X ALTERED -- X := CON (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := CON (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + X := CON (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF X = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "X := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + BEGIN + Y := CON (FALSE, 3, 2, 6.0); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := CON (FALSE, 3, 2, 6.0)"); + IF Y = CON (FALSE, 3, 2, 6.0) THEN -- USE Y. + COMMENT ("Y ALTERED -- Y := CON (FALSE, 3, 2, 6.0)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := CON (FALSE, 3, 2, 6.0)"); + END; + + BEGIN + Y := CON (TRUE, 4, 2, "ZZZZ", 6); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + IF Y = CON (TRUE, 4, 2, "ZZZZ", 6) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "Y := CON (TRUE, 4, 2, ""ZZZZ"", 6)"); + END; + + RESULT; + END C34009F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- C34009G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITHOUT + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/01/87 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34009G IS + + PACKAGE PKG IS + + TYPE PARENT IS LIMITED PRIVATE; + + FUNCTION CREATE (X : INTEGER) RETURN PARENT; + + FUNCTION CON (X : INTEGER) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT IS NEW INTEGER; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT; + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (IDENT_INT (X)); + END CREATE; + + FUNCTION CON (X : INTEGER) RETURN PARENT IS + BEGIN + RETURN PARENT (X); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + + BEGIN + TEST ("C34009G", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS"); + + ASSIGN (X, CREATE (30)); + IF NOT EQUAL (T'(X), CON (30)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), CON (30)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + ASSIGN (W, CREATE (-30)); + IF NOT EQUAL (T (W), CON (-30)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), CON (30)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF NOT (X IN T) THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + IF X'SIZE < T'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34009G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,225 ---- + -- C34009J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE REQUIRED PREDEFINED OPERATIONS ARE DECLARED + -- (IMPLICITLY) FOR DERIVED LIMITED PRIVATE TYPES WITH + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 09/01/87 CREATED ORIGINAL TEST. + -- WMC 03/13/92 REVISED TYPE'SIZE CHECKS. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C34009J IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + LIMITED PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + J : INTEGER := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + X : T; + W : PARENT; + B : BOOLEAN := FALSE; + + PROCEDURE A (X : ADDRESS) IS + BEGIN + B := IDENT_BOOL (TRUE); + END A; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + + BEGIN + TEST ("C34009J", "CHECK THAT THE REQUIRED PREDEFINED OPERATIONS " & + "ARE DECLARED (IMPLICITLY) FOR DERIVED " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + IF EQUAL (3, 3) THEN + ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4)); + END IF; + IF NOT EQUAL (T'(X), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT QUALIFICATION"); + END IF; + + IF NOT EQUAL (T (X), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT SELF CONVERSION"); + END IF; + + IF EQUAL (3, 3) THEN + ASSIGN (W, CON (TRUE, 3, 1, "ABC", 4)); + END IF; + IF NOT EQUAL (T (W), CON (TRUE, 3, 1, "ABC", 4)) THEN + FAILED ("INCORRECT CONVERSION FROM PARENT"); + END IF; + + IF NOT EQUAL (PARENT (X), CON (TRUE, 3, 1, "ABC", 4)) OR + NOT EQUAL (PARENT (CREATE (FALSE, 2, 3, "XX", 5, 6.0, X)), + CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + + IF X.B /= TRUE OR X.L /= 3 OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . B /= FALSE OR + CREATE (FALSE, 2, 3, "XX", 5, 6.0, X) . L /= 2 THEN + FAILED ("INCORRECT SELECTION (DISCRIMINANT)"); + END IF; + + IF NOT (X IN T) OR CON (FALSE, 2, 3, 6.0) IN T THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + IF X NOT IN T OR NOT (CON (FALSE, 2, 3, 6.0) NOT IN T) THEN + FAILED ("INCORRECT ""NOT IN"""); + END IF; + + B := FALSE; + A (X'ADDRESS); + IF NOT B THEN + FAILED ("INCORRECT 'ADDRESS"); + END IF; + + + IF NOT X'CONSTRAINED THEN + FAILED ("INCORRECT OBJECT'CONSTRAINED"); + END IF; + + IF T'SIZE <= 0 THEN + FAILED ("INCORRECT TYPE'SIZE"); + END IF; + + IF X'SIZE < T'SIZE OR + X.B'SIZE < BOOLEAN'SIZE OR + X.L'SIZE < LENGTH'SIZE THEN + FAILED ("INCORRECT OBJECT'SIZE"); + END IF; + + RESULT; + END C34009J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34009l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34009l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,270 ---- + -- C34009L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DERIVED LIMITED PRIVATE TYPES WITH DISCRIMINANTS: + + -- CHECK THAT ALL VALUES OF THE PARENT (BASE) TYPE ARE PRESENT + -- FOR THE DERIVED (BASE) TYPE WHEN THE DERIVED TYPE DEFINITION + -- IS CONSTRAINED. + + -- CHECK THAT ANY CONSTRAINT IMPOSED ON THE PARENT SUBTYPE IS + -- ALSO IMPOSED ON THE DERIVED SUBTYPE. + + -- HISTORY: + -- JRK 09/01/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34009L IS + + PACKAGE PKG IS + + MAX_LEN : CONSTANT := 10; + + SUBTYPE LENGTH IS NATURAL RANGE 0 .. MAX_LEN; + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + LIMITED PRIVATE; + + FUNCTION CREATE ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT -- TO RESOLVE OVERLOADING. + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT; + + FUNCTION CON ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT); + + PRIVATE + + TYPE PARENT (B : BOOLEAN := TRUE; L : LENGTH := 3) IS + RECORD + I : INTEGER := 2; + CASE B IS + WHEN TRUE => + S : STRING (1 .. L) := (1 .. L => 'A'); + J : INTEGER := 2; + WHEN FALSE => + F : FLOAT := 5.0; + END CASE; + END RECORD; + + END PKG; + + USE PKG; + + TYPE T IS NEW PARENT (IDENT_BOOL (TRUE), IDENT_INT (3)); + + SUBTYPE SUBPARENT IS PARENT (TRUE, 3); + + TYPE S IS NEW SUBPARENT; + + X : T; + Y : S; + + PACKAGE BODY PKG IS + + FUNCTION CREATE + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER; + F : FLOAT; + X : PARENT + ) RETURN PARENT + IS + BEGIN + CASE B IS + WHEN TRUE => + RETURN (TRUE, L, I, S, J); + WHEN FALSE => + RETURN (FALSE, L, I, F); + END CASE; + END CREATE; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + S : STRING; + J : INTEGER + ) RETURN PARENT + IS + BEGIN + RETURN (TRUE, L, I, S, J); + END CON; + + FUNCTION CON + ( B : BOOLEAN; + L : LENGTH; + I : INTEGER; + F : FLOAT + ) RETURN PARENT + IS + BEGIN + RETURN (FALSE, L, I, F); + END CON; + + FUNCTION EQUAL (X, Y : PARENT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END EQUAL; + + PROCEDURE ASSIGN (X : OUT PARENT; Y : PARENT) IS + BEGIN + X := Y; + END ASSIGN; + + END PKG; + + BEGIN + TEST ("C34009L", "CHECK THAT ALL VALUES OF THE PARENT (BASE) " & + "TYPE ARE PRESENT FOR THE DERIVED (BASE) TYPE " & + "WHEN THE DERIVED TYPE DEFINITION IS " & + "CONSTRAINED. ALSO CHECK THAT ANY CONSTRAINT " & + "IMPOSED ON THE PARENT SUBTYPE IS ALSO IMPOSED " & + "ON THE DERIVED SUBTYPE. CHECK FOR DERIVED " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS"); + + -- CHECK THAT BASE TYPE VALUES NOT IN THE SUBTYPE ARE PRESENT. + + IF NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X), + CON (FALSE, 2, 3, 6.0)) OR + NOT EQUAL (CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y), + CON (FALSE, 2, 3, 6.0)) THEN + FAILED ("CAN'T CREATE BASE TYPE VALUES OUTSIDE THE SUBTYPE"); + END IF; + + IF CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, X) IN T OR + CREATE (FALSE, 2, 3, "ZZ", 5, 6.0, Y) IN S THEN + FAILED ("INCORRECT ""IN"""); + END IF; + + -- CHECK THE DERIVED SUBTYPE CONSTRAINT. + + IF X.B /= TRUE OR X.L /= 3 OR + Y.B /= TRUE OR Y.L /= 3 THEN + FAILED ("INCORRECT SELECTION OF DISCRIMINANT VALUES"); + END IF; + + IF NOT X'CONSTRAINED OR NOT Y'CONSTRAINED THEN + FAILED ("INCORRECT 'CONSTRAINED"); + END IF; + + BEGIN + ASSIGN (X, CON (TRUE, 3, 1, "ABC", 4)); + ASSIGN (Y, CON (TRUE, 3, 1, "ABC", 4)); + IF NOT EQUAL (PARENT (X), PARENT (Y)) THEN -- USE X AND Y. + FAILED ("INCORRECT CONVERSION TO PARENT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY OK ASSIGN CALL"); + END; + + BEGIN + ASSIGN (X, CON (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + IF EQUAL (X, CON (FALSE, 3, 2, 6.0)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CON (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (X, CON (TRUE, 4, 2, "ZZZZ", 6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + IF EQUAL (X, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE X. + COMMENT ("X ALTERED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (X, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END; + + BEGIN + ASSIGN (Y, CON (FALSE, 3, 2, 6.0)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + IF EQUAL (Y, CON (FALSE, 3, 2, 6.0)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CON (FALSE, 3, 2, 6.0))"); + END; + + BEGIN + ASSIGN (Y, CON (TRUE, 4, 2, "ZZZZ", 6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + IF EQUAL (Y, CON (TRUE, 4, 2, "ZZZZ", 6)) THEN -- USE Y. + COMMENT ("Y ALTERED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -- " & + "ASSIGN (Y, CON (TRUE, 4, 2, ""ZZZZ"", 6))"); + END; + + RESULT; + END C34009L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34011b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34011b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34011b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34011b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,343 ---- + -- C34011B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED TYPE DECLARATION IS NOT CONSIDERED EXACTLY + -- EQUIVALENT TO AN ANONYMOUS DECLARATION OF THE DERIVED TYPE + -- FOLLOWED BY A SUBTYPE DECLARATION OF THE DERIVED SUBTYPE. IN + -- PARTICULAR, CHECK THAT CONSTRAINT_ERROR CAN BE RAISED WHEN THE + -- SUBTYPE INDICATION OF THE DERIVED TYPE DECLARATION IS ELABORATED + -- (EVEN THOUGH THE CONSTRAINT WOULD SATISFY THE DERIVED (BASE) + -- TYPE). + + -- HISTORY: + -- JRK 09/04/87 CREATED ORIGINAL TEST. + -- EDS 07/29/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + + PROCEDURE C34011B IS + + SUBTYPE BOOL IS BOOLEAN RANGE FALSE .. FALSE; + + SUBTYPE FLT IS FLOAT RANGE -10.0 .. 10.0; + + SUBTYPE DUR IS DURATION RANGE 0.0 .. 10.0; + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC (D : INT := 0) IS + RECORD + I : INTEGER; + END RECORD; + + PACKAGE PT IS + TYPE PRIV (D : POSITIVE := 1) IS PRIVATE; + PRIVATE + TYPE PRIV (D : POSITIVE := 1) IS + RECORD + I : INTEGER; + END RECORD; + END PT; + + USE PT; + + TYPE ACC_ARR IS ACCESS ARR; + + TYPE ACC_REC IS ACCESS REC; + + BEGIN + TEST ("C34011B", "CHECK THAT CONSTRAINT_ERROR CAN BE RAISED " & + "WHEN THE SUBTYPE INDICATION OF A DERIVED TYPE " & + "DECLARATION IS ELABORATED"); + + BEGIN + DECLARE + TYPE T IS NEW BOOL RANGE FALSE .. BOOL(IDENT_BOOL(TRUE)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_BOOL(TRUE)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE - BOOL " & + T'IMAGE(T1) ); --USE T1); + END; + + FAILED ("EXCEPTION NOT RAISED - BOOL"); + + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - BOOL"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - BOOL"); + END; + + BEGIN + DECLARE + TYPE T IS NEW POSITIVE RANGE IDENT_INT (0) .. 10; + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(1)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR - POSITIVE " & + T'IMAGE(T1)); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - POSITIVE" ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - POSITIVE"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - POSITIVE"); + END; + + BEGIN + DECLARE + TYPE T IS NEW FLT RANGE 0.0 .. FLT(IDENT_INT(20)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(0)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE " & + T'IMAGE(T1) ); --USE T1 + + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE "); + END; + FAILED ("EXCEPTION NOT RAISED - FLT" ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - FLT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLT"); + END; + + BEGIN + DECLARE + TYPE T IS NEW DUR RANGE DUR(IDENT_INT(-1)) .. 5.0; + + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := T(IDENT_INT(2)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR" & + " AT PROPER PLACE " & + T'IMAGE(T1) ); -- USE T1 + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + FAILED ("EXCEPTION NOT RAISED - DUR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - DUR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DUR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ARR (IDENT_INT (-1) .. 10); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T := (OTHERS => IDENT_INT(3)); + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1(1)) ); --USE T1 + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + FAILED ("EXCEPTION NOT RAISED - ARR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ARR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ARR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW REC (IDENT_INT (11)); + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - REC " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - REC"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REC"); + END; + + BEGIN + DECLARE + TYPE T IS NEW PRIV (IDENT_INT (0)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - PRIV " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - PRIV"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PRIV"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ACC_ARR (0 .. IDENT_INT (11)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1(1)) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - ACC_ARR " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ACC_ARR"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ACC_ARR"); + END; + + BEGIN + DECLARE + TYPE T IS NEW ACC_REC (IDENT_INT (-1)); --RAISES C_E + + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE T AND USE IT TO AVOID OPTIMIZATION + T1 : T; + BEGIN + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR " & + "AT PROPER PLACE " & + INTEGER'IMAGE(T1.D) ); --USE T1 + END; + FAILED ("EXCEPTION NOT RAISED - ACC_REC " ); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER ENTERED - ACC_REC"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ACC_REC"); + END; + + RESULT; + END C34011B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34012a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C34012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DEFAULT EXPRESSIONS IN DERIVED RECORD TYPES AND + -- DERIVED SUBPROGRAMS ARE EVALUATED USING THE ENTITIES DENOTED BY + -- THE EXPRESSIONS IN THE PARENT TYPE. + + -- HISTORY: + -- RJW 06/19/86 CREATED ORIGINAL TEST. + -- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED + -- PACKAGE B SO WOULD HAVE ONE CASE WHERE DEFAULT IS + -- DECLARED BEFORE THE DERIVED TYPE DECLARATION. + + WITH REPORT; USE REPORT; + + PROCEDURE C34012A IS + + BEGIN + TEST ("C34012A", "CHECK THAT DEFAULT EXPRESSIONS IN DERIVED " & + "RECORD TYPES AND DERIVED SUBPROGRAMS ARE " & + "EVALUATED USING THE ENTITIES DENOTED BY THE " & + "EXPRESSIONS IN THE PARENT TYPE" ); + + DECLARE + PACKAGE P IS + X : INTEGER := 5; + TYPE REC IS + RECORD + C : INTEGER := X; + END RECORD; + END P; + + PACKAGE Q IS + X : INTEGER := 6; + TYPE NEW_REC IS NEW P.REC; + QVAR : NEW_REC; + END Q; + + PACKAGE R IS + X : INTEGER := 7; + TYPE BRAND_NEW_REC IS NEW Q.NEW_REC; + RVAR : BRAND_NEW_REC; + END R; + + USE Q; + USE R; + BEGIN + IF QVAR.C = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR QVAR" ); + END IF; + + IF RVAR.C = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR RVAR" ); + END IF; + END; + + DECLARE + PACKAGE A IS + TYPE T IS RANGE 1 .. 10; + DEFAULT : T := 5; + FUNCTION F (X : T := DEFAULT) RETURN T; + END A; + + PACKAGE BODY A IS + FUNCTION F (X : T := DEFAULT) RETURN T IS + BEGIN + RETURN X; + END F; + END A; + + PACKAGE B IS + DEFAULT : A.T:= 6; + TYPE NEW_T IS NEW A.T; + BVAR : NEW_T := F; + END B; + + PACKAGE C IS + TYPE BRAND_NEW_T IS NEW B.NEW_T; + DEFAULT : BRAND_NEW_T := 7; + CVAR : BRAND_NEW_T :=F; + END C; + + USE B; + USE C; + BEGIN + IF BVAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR BVAR" ); + END IF; + + IF CVAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR CVAR" ); + END IF; + + DECLARE + VAR : BRAND_NEW_T := F; + BEGIN + IF VAR = 5 THEN + NULL; + ELSE + FAILED ( "INCORRECT VALUE FOR VAR" ); + END IF; + END; + END; + + RESULT; + END C34012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- C34014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER + -- DECLARED EXPLICITLY IN THE SAME VISIBLE PART. + + -- HISTORY: + -- JRK 09/08/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014A IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + + BEGIN + TEST ("C34014A", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE SAME VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + FUNCTION F IS NEW G (QT); + W : QT := F; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- C34014C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER + -- DECLARED EXPLICITLY IN THE PRIVATE PART. + + -- HISTORY: + -- JRK 09/11/87 CREATED ORIGINAL TEST. + -- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. + -- PWN 10/24/96 RESTORED CHECK WITH NEW ADA 95 RESULTS EXPECTED. + -- PWB.CTA 02/20/97 Made failure messages unique. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014C IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + + BEGIN + TEST ("C34014C", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE PRIVATE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + FUNCTION F IS NEW G (QT); + W : QT := F; + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- C34014E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC SUBPROGRAM IS LATER + -- DECLARED EXPLICITLY IN THE PACKAGE BODY. + + -- HISTORY: + -- JRK 09/15/87 CREATED ORIGINAL TEST. + -- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. + -- PWN 04/11/96 Restored subtests in Ada95 legal format. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014E IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + + BEGIN + TEST ("C34014E", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY IN " & + "THE PACKAGE BODY"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := F; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G RETURN T; + + FUNCTION G RETURN T IS + BEGIN + RETURN T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F IS NEW G (QT); + W : QT := F; + TYPE QS IS NEW QT; + Z : QS := F; + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C34014G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC SUBPROGRAM IS LATER + -- DECLARED EXPLICITLY. + + -- HISTORY: + -- JRK 09/16/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014G IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + + BEGIN + TEST ("C34014G", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " & + "SUBPROGRAM IS LATER DECLARED EXPLICITLY"); + + ----------------------------------------------------------------- + + COMMENT ("NO NEW SUBPROGRAM DECLARED EXPLICITLY"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := F; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := F; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - 1"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT VISIBLE - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD SUBPROGRAM NOT DERIVED - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014h.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,208 ---- + -- C34014H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED SUBPROGRAM IS IMPLICITLY DECLARED IN THE + -- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A + -- HOMOGRAPHIC SUBPROGRAM IN THE VISIBLE PART. + + -- HISTORY: + -- JRK 09/16/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014H IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION F RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION F RETURN T IS + BEGIN + RETURN T (IDENT_INT (1)); + END F; + END P; + + BEGIN + TEST ("C34014H", "CHECK THAT A DERIVED SUBPROGRAM IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "SUBPROGRAM IS IMPLICITLY DECLARED IN THE " & + "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " & + "DECLARATION OF A HOMOGRAPHIC SUBPROGRAM IN " & + "THE VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C2 : CONSTANT QT; + FUNCTION F RETURN QT; + TYPE QR1 IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION F RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END F; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := F; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG " & + "DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - SUBPROG DECL - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW SUBPROGRAM DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C2 : CONSTANT QT; + FUNCTION G RETURN QT; + FUNCTION F RETURN QT RENAMES G; + TYPE QR1 IS + RECORD + C : QT := F; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := F; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G RETURN QT IS + BEGIN + RETURN QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := F; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := F; + TYPE RT IS NEW QT; + Z : RT := F; + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW SUBPROGRAM NOT VISIBLE - RENAMING - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW SUBPROGRAM NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014n.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- C34014N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER + -- DECLARED EXPLICITLY IN THE SAME VISIBLE PART. + + -- HISTORY: + -- JRK 09/21/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014N IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + + BEGIN + TEST ("C34014N", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE SAME VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + PRIVATE + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,258 ---- + -- C34014P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER + -- DECLARED EXPLICITLY IN THE PRIVATE PART. + + -- HISTORY: + -- JRK 09/22/87 CREATED ORIGINAL TEST. + -- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. + -- PWN 04/11/96 Restored subtests in Ada95 legal format. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014P IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + + BEGIN + TEST ("C34014P", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE PRIVATE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014r.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- C34014R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC OPERATOR IS LATER + -- DECLARED EXPLICITLY IN THE PACKAGE BODY. + + -- HISTORY: + -- JRK 09/22/87 CREATED ORIGINAL TEST. + -- GJD 11/15/95 REMOVED ADA 83 INCOMPATIBILITIES. + -- PWN 04/11/96 Restored subtests in Ada95 legal format. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014R IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + + BEGIN + TEST ("C34014R", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND A HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY IN " & + "THE PACKAGE BODY"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - SUBPROG DECL - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + Y : QR; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - RENAMING - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY GENERIC INSTANTIATION"); + + DECLARE + + GENERIC + TYPE T IS RANGE <>; + FUNCTION G (Y : T) RETURN T; + + FUNCTION G (Y : T) RETURN T IS + BEGIN + RETURN Y + T (IDENT_INT (2)); + END G; + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" IS NEW G (QT); + W : QT := +0; + TYPE QS IS NEW QT; + Z : QS := +0; + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - " & + "INSTANTIATION - 1"); + END IF; + + IF W /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - " & + "INSTANTIATION"); + END IF; + + IF Z /= 2 THEN + FAILED ("OLD OPERATOR NOT DERIVED - " & + "INSTANTIATION - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - INSTANTIATION - " & + "2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - INSTANTIATION - " & + "2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014t.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014t.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014t.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014t.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C34014T.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE + -- VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC OPERATOR IS LATER + -- DECLARED EXPLICITLY. + + -- HISTORY: + -- JRK 09/22/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014T IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + + BEGIN + TEST ("C34014T", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "VISIBLE PART OF A PACKAGE AND NO HOMOGRAPHIC " & + "OPERATOR IS LATER DECLARED EXPLICITLY"); + + ----------------------------------------------------------------- + + COMMENT ("NO NEW OPERATOR DECLARED EXPLICITLY"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS NEW T; + X : QT := +0; + PRIVATE + TYPE QS IS NEW QT; + Z : QS := +0; + END Q; + USE Q; + + PACKAGE BODY Q IS + BEGIN + IF X /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - 1"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +0; + TYPE RT IS NEW QT; + Z : RT := +0; + END R; + USE R; + + BEGIN + IF Y /= 1 THEN + FAILED ("OLD OPERATOR NOT VISIBLE - 2"); + END IF; + + IF Z /= 1 THEN + FAILED ("OLD OPERATOR NOT DERIVED - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014T; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014u.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014u.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34014u.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34014u.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C34014U.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED OPERATOR IS VISIBLE AND FURTHER DERIVABLE + -- UNDER APPROPRIATE CIRCUMSTANCES. + + -- CHECK WHEN THE DERIVED OPERATOR IS IMPLICITLY DECLARED IN THE + -- PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT DECLARATION OF A + -- HOMOGRAPHIC OPERATOR IN THE VISIBLE PART. + + -- HISTORY: + -- JRK 09/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C34014U IS + + PACKAGE P IS + TYPE T IS RANGE -100 .. 100; + FUNCTION "+" (X : T) RETURN T; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "+" (X : T) RETURN T IS + BEGIN + RETURN X + T (IDENT_INT (1)); + END "+"; + END P; + + BEGIN + TEST ("C34014U", "CHECK THAT A DERIVED OPERATOR IS VISIBLE " & + "AND FURTHER DERIVABLE UNDER APPROPRIATE " & + "CIRCUMSTANCES. CHECK WHEN THE DERIVED " & + "OPERATOR IS IMPLICITLY DECLARED IN THE " & + "PRIVATE PART OF A PACKAGE AFTER AN EXPLICIT " & + "DECLARATION OF A HOMOGRAPHIC OPERATOR IN " & + "THE VISIBLE PART"); + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY SUBPROGRAM DECLARATION"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C0 : CONSTANT QT; + C2 : CONSTANT QT; + FUNCTION "+" (Y : QT) RETURN QT; + TYPE QR1 IS + RECORD + C : QT := +C0; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C0 : CONSTANT QT := 0; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION "+" (Y : QT) RETURN QT IS + BEGIN + RETURN Y + QT (IDENT_INT (2)); + END "+"; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG " & + "DECL - 2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG " & + "DECL - 1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +C0; + TYPE RT IS NEW QT; + Z : RT := +RT(C0); + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - SUBPROG DECL - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW OPERATOR NOT DERIVED - SUBPROG DECL - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + COMMENT ("NEW OPERATOR DECLARED BY RENAMING"); + + DECLARE + + PACKAGE Q IS + TYPE QT IS PRIVATE; + C0 : CONSTANT QT; + C2 : CONSTANT QT; + FUNCTION G (X : QT) RETURN QT; + FUNCTION "+" (Y : QT) RETURN QT RENAMES G; + TYPE QR1 IS + RECORD + C : QT := +C0; + END RECORD; + PRIVATE + TYPE QT IS NEW T; + C0 : CONSTANT QT := 0; + C2 : CONSTANT QT := 2; + TYPE QR2 IS + RECORD + C : QT := +0; + END RECORD; + TYPE QS IS NEW QT; + END Q; + USE Q; + + PACKAGE BODY Q IS + FUNCTION G (X : QT) RETURN QT IS + BEGIN + RETURN X + QT (IDENT_INT (2)); + END G; + + PACKAGE R IS + X : QR1; + Y : QR2; + Z : QS := +0; + END R; + USE R; + BEGIN + IF X.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "1"); + END IF; + + IF Y.C /= 2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - " & + "2"); + END IF; + + IF Z /= 2 THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - " & + "1"); + END IF; + END Q; + + PACKAGE R IS + Y : QT := +C0; + TYPE RT IS NEW QT; + Z : RT := +RT(C0); + END R; + USE R; + + BEGIN + IF Y /= C2 THEN + FAILED ("NEW OPERATOR NOT VISIBLE - RENAMING - 3"); + END IF; + + IF Z /= RT (C2) THEN + FAILED ("NEW OPERATOR NOT DERIVED - RENAMING - 2"); + END IF; + END; + + ----------------------------------------------------------------- + + RESULT; + END C34014U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34018a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34018a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c34018a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c34018a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- C34018A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CALLS OF DERIVED SUBPROGRAMS CHECK CONSTRAINTS OF THE + -- PARENT SUBPROGRAM, NOT THE CONSTRAINTS OF THE DERIVED SUBTYPE. + + -- JBG 11/15/85 + -- JRK 2/12/86 CORRECTED ERROR: RESOLVED AMBIGUOUS CALL G(41) TO + -- TYPE NEW_INT. + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C34018A IS + + PACKAGE P IS + TYPE INT IS RANGE 1..100; + SUBTYPE INT_50 IS INT RANGE 1..50; + SUBTYPE INT_51 IS INT RANGE 51..100; + + FUNCTION "+" (L, R : INT) RETURN INT; + FUNCTION G (X : INT_50) RETURN INT_51; + + TYPE STR IS ARRAY (1..10) OF CHARACTER; + FUNCTION F (X : STR) RETURN STR; + END P; + + USE P; + + TYPE NEW_STR IS NEW P.STR; + TYPE NEW_INT IS NEW P.INT RANGE 51..90; + + PACKAGE BODY P IS + + FUNCTION "+" (L, R : INT) RETURN INT IS + BEGIN + RETURN INT(INTEGER(L) + INTEGER(R)); + END "+"; + + FUNCTION G (X : INT_50) RETURN INT_51 IS + BEGIN + RETURN X + 10; + END G; + + FUNCTION F (X : STR) RETURN STR IS + BEGIN + RETURN X; + END F; + + END P; + + BEGIN + + TEST ("C34018A", "CHECK CONSTRAINTS PROCESSED CORRECTLY FOR " & + "CALLS OF DERIVED SUBPROGRAMS"); + + DECLARE + + Y : NEW_STR := F("1234567890"); -- UNAMBIGUOUS. + + BEGIN + IF Y /= "1234567890" THEN + FAILED ("DERIVED F"); + END IF; + END; + + DECLARE + + A : INT := 51; + B : NEW_INT := NEW_INT(IDENT_INT(90)); + + BEGIN + + BEGIN + A := A + 0; + FAILED ("NO EXCEPTION - A + 0 = " & INT'IMAGE(A) ); --Use A + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + IF B + 2 /= 92 THEN -- 92 IN INT. + FAILED ("WRONG RESULT - B + 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("WRONG CONSTRAINT FOR DERIVED ""+"""); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; + + BEGIN + IF B + 14 > 90 THEN -- 104 NOT IN INT. + FAILED ("NO EXCEPTION RAISED FOR DERIVED ""+"""); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 3"); + END; + + + BEGIN + IF G(B) > 90 THEN -- 90 NOT IN INT_50. + FAILED ("NO EXCEPTION RAISED FOR DERIVED G"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; + + BEGIN + IF C34018A.G(41) /= 51 THEN -- 41 CONVERTED TO + -- NEW_INT'BASE. + -- 41 IN INT_50. + -- 51 IN INT_51. + FAILED ("WRONG RESULT - G(41)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("C_E RAISED FOR LITERAL ARGUMENT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 5"); + END; + END; + + RESULT; + END C34018A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340a01.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C340A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a tagged type declared in a package specification + -- may be passed as a generic formal (tagged) private type to a generic + -- package declaration. Check that the formal type may be extended with + -- a record extension in the generic package. + -- + -- Check that, in the instance, the record extension inherits the + -- user-defined primitive subprograms of the tagged actual. + -- + -- TEST DESCRIPTION: + -- Declare a tagged type and an associated primitive subprogram in a + -- package specification (foundation code). Declare a generic package + -- which takes a tagged type as a formal parameter, and then extends + -- it with a record extension (foundation code). + -- + -- Instantiate the generic package with the tagged type from the first + -- package (the "generic" extension should now have inherited + -- the primitive subprogram of the tagged type from the first + -- package). + -- + -- In the main program, call the primitive subprogram inherited by the + -- "generic" extension, and verify the correctness of the components. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F340A000.A + -- F340A001.A + -- => C340A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous + -- comments. + -- + --! + + with F340A001; -- Book definitions. + package C340A01_0 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + end C340A01_0; + + + --==================================================================-- + + + -- Library-level instantiation. Actual parameter is tagged record. + + with F340A001; -- Book definitions. + with F340A000; -- Singly-linked list abstraction. + package C340A01_1 is new F340A000 (Parent_Type => F340A001.Book_Type); + + + --==================================================================-- + + + with Report; + + with F340A001; -- Book definitions. + with C340A01_0; -- Raw book data. + with C340A01_1; -- Instance. + + use F340A001; -- Primitive operations of Book_Type directly visible. + use C340A01_1; -- Operations inherited by Node_Type directly visible. + + procedure C340A01 is + + + List_Of_Books : Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C340A01_0.Data_List; + Head : in out Node_Ptr) is + + Book : Node_Type; -- Object of extended type. + Book_Ptr : Node_Ptr; + + begin + for I in C340A01_0.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call inherited + -- operation. + Book_Ptr := new Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + begin + return (List_Of_Books.Title.all /= "Ulysses" or + List_Of_Books.Author.all /= "Joyce, James" or + List_Of_Books.Next.Title.all /= "Heart of Darkness" or + List_Of_Books.Next.Author.all /= "Conrad, Joseph" or + List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or + List_Of_Books.Next.Next.Author.all /= "Bronte, Emily"); + end Bad_List_Contents; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C340A01", "Inheritance of primitive operations: record " & + "extension of formal tagged private type; actual is " & + "an ultimate ancestor type"); + + -- Create linked list using inherited operation: + Create_List (C340A01_0.Title_List, C340A01_0.Author_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operation"); + end if; + + Report.Result; + + end C340A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c340a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c340a02.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,221 ---- + -- C340A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a record extension (declared in a package specification) of + -- a tagged type (declared in a different package specification) may be + -- passed as a generic formal (tagged) private type to a generic package + -- declaration. Check that the formal type may be further extended with a + -- record extension in the generic package. + -- + -- Check that, in the instance, the record extension inherits the + -- user-defined primitive subprograms of the tagged actual, including + -- those inherited by the actual from its parent. + -- + -- TEST DESCRIPTION: + -- Declare a tagged type and an associated primitive subprogram in a + -- package specification (foundation code). Declare a record extension + -- of the tagged type and an associated primitive subprogram in a second + -- package specification. Declare a generic package which takes a tagged + -- type as a formal parameter, and then extends it with a record + -- extension (foundation code). + -- + -- Instantiate the generic package with the record extension from the + -- second package (the "generic" extension should now have inherited + -- the primitive subprograms of the record extension from the second + -- package). + -- + -- In the main program, call the primitive subprograms inherited by the + -- "generic" extension. There are two: (1) Create_Book, declared for + -- the root tagged type in the first package (inherited by the record + -- extension of the second package, and then in turn by the "generic" + -- extension), and (2) Update_Pages, declared for the record extension + -- in the second package. Verify the correctness of the components. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F340A000.A + -- F340A001.A + -- => C340A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 12 Jun 96 SAIC ACVC 2.1: Modified prologue. Removed extraneous + -- comments. + -- + --! + + with F340A001; -- Book definitions. + package C340A02_0 is -- Extended book abstraction. + + + type Detailed_Book_Type is new F340A001.Book_Type with record + Pages : Natural; -- Record ext. + end record; -- of root tagged + -- type. + + -- Inherits Create_Book from Book_Type. + + procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op. + Pages : in Natural); -- of extension. + + + end C340A02_0; + + + --==================================================================-- + + + package body C340A02_0 is + + + procedure Update_Pages (Book : in out Detailed_Book_Type; + Pages : in Natural) is + begin + Book.Pages := Pages; + end Update_Pages; + + + end C340A02_0; + + + --==================================================================-- + + + with F340A001; -- Book definitions. + package C340A02_1 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F340A001.Text_Ptr; + type Page_Counts is array (Number_Of_Books) of Natural; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + Page_List : Page_Counts := (237, 215, 456); + + end C340A02_1; + + + --==================================================================-- + + + -- Library-level instantiation. Actual parameter is record extension. + + with C340A02_0; -- Extended book abstraction. + with F340A000; -- Singly-linked list abstraction. + package C340A02_2 is new F340A000 + (Parent_Type => C340A02_0.Detailed_Book_Type); + + + --==================================================================-- + + + with Report; + + with C340A02_0; -- Extended book abstraction. + with C340A02_1; -- Raw book data. + with C340A02_2; -- Instance. + + use C340A02_0; -- Primitive operations of Detailed_Book_Type directly visible. + use C340A02_2; -- Operations inherited by Node_Type directly visible. + + procedure C340A02 is + + + List_Of_Books : Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C340A02_1.Data_List; + Pages : in C340A02_1.Page_Counts; + Head : in out Node_Ptr) is + + Book : Node_Type; -- Object of extended type. + Book_Ptr : Node_Ptr; + + begin + for I in C340A02_1.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call twice-inherited + -- operation. + Update_Pages (Book, Pages (I)); -- Call inherited op. + Book_Ptr := new Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + begin + return (List_Of_Books.Title.all /= "Ulysses" or + List_Of_Books.Author.all /= "Joyce, James" or + List_Of_Books.Pages /= 456 or + List_Of_Books.Next.Title.all /= "Heart of Darkness" or + List_Of_Books.Next.Author.all /= "Conrad, Joseph" or + List_Of_Books.Next.Pages /= 215 or + List_Of_Books.Next.Next.Title.all /= "Wuthering Heights" or + List_Of_Books.Next.Next.Author.all /= "Bronte, Emily" or + List_Of_Books.Next.Next.Pages /= 237); + + end Bad_List_Contents; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C340A02", "Inheritance of primitive operations: record " & + "extension of formal tagged private type; actual is " & + "a record extension"); + + -- Create linked list using inherited operation: + Create_List (C340A02_1.Title_List, C340A02_1.Author_List, + C340A02_1.Page_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operations"); + end if; + + Report.Result; + + end C340A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a01.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C341A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that formal parameters of a class-wide type can be passed + -- values of any specific type within the class. + -- + -- TEST DESCRIPTION: + -- Define an object of a root tagged type and of various types derived + -- from the root. Define objects of the root class, and initialize them + -- by parameter association of objects of the specific types (root and + -- extended types) within the class. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- The following files comprise this test: + -- + -- => C341A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with F341A00_2; -- package Interest_Checking + with Report; + + procedure C341A01 is + + package Bank renames F341A00_0; + use type Bank.Dollar_Amount; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Initialize objects of specific tagged types. + B_Acct : Bank.Account := (Current_Balance => 10.00); + C_Acct : Checking.Account := (100.00, 10.00); + IC_Acct : Interest_Checking.Account := (1000.00, 10.00, 0.030); + + -- Define and initialize (by parameter association) objects of class-wide + -- type originating from the root type (Bank.Account). + + -- Define an account auditing procedure with a class-wide + -- variable that can hold a value of any object within the class. + procedure Audit (Next_Account : Bank.Account'Class) is + begin + Bank_Balance := Bank_Balance + Next_Account.Current_Balance; + end Audit; + + + begin -- C341A01 + + Report.Test ("C341A01", "Check that objects of a class-wide type can " & + "be initialized, by direct assignment, to a " & + "value of any specific type within the class" ); + + -- Perform nightly audit of total funds on deposit in bank. + Audit (B_Acct); + Audit (C_Acct); + Audit (IC_Acct); + + if Bank_Balance /= 1110.00 then + Report.Failed ("Class-wide object processing failed"); + end if; + + Report.Result; + + end C341A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a02.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C341A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that class-wide objects can be reassigned with objects from + -- the same specific type used to initialize them. + -- + -- TEST DESCRIPTION: + -- Define new objects of specific types from within a class. Reassign + -- previously declared class-wide objects with the new specific type + -- objects. Check that new assignments were performed. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- The following files comprise this test: + -- + -- => C341A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with F341A00_2; -- package Interest_Checking + with Report; + + procedure C341A02 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Define and initialize objects of specific types. + B_Acct : aliased Bank.Account := (Current_Balance => 10.00); + C_Acct : aliased Checking.Account := (100.00, 10.00); + IC_Acct : aliased Interest_Checking.Account := (1000.00, 10.00, 0.030); + New_B_Acct : aliased Bank.Account := (Current_Balance => 20.00); + New_C_Acct : aliased Checking.Account := (200.00, 20.00); + New_IC_Acct : aliased Interest_Checking.Account := (2000.00, 20.00, 0.060); + + + -- Define and initialize (by direct assignment) objects of a class-wide + -- type originating from the root type (Bank.Account). + + type ATM_Card is access all Bank.Account'Class; + + Accounts : array (1 .. Max_Accts) of ATM_Card := + (1 => B_Acct'Access, 2 => C_Acct'Access, 3 => IC_Acct'Access); + + New_Accounts : array (1 .. Max_Accts) of ATM_Card := + (1 => New_B_Acct'Access, + 2 => New_C_Acct'Access, + 3 => New_IC_Acct'Access); + + -- Define an account auditing procedure with a class-wide + -- variable that can hold a value of any object within the class, + -- and once initialized, can hold other values of the same specific type. + + procedure Audit (Num : in integer; + Amt : out Bank.Dollar_Amount) is + Account_Being_Audited : Bank.Account'Class := Accounts(Num).all; + use type Bank.Dollar_Amount; + begin + Amt := Account_Being_Audited.Current_Balance; + -- Reassign class-wide variable to another object of the type used to + -- initialize it. + Account_Being_Audited := New_Accounts(Num).all; + Amt := Amt + Account_Being_Audited.Current_Balance; -- Reading OUT + end Audit; -- parameter. + + + begin + + Report.Test ("C341A02", "Check that class-wide objects can be " & + "reassigned with objects from the same " & + "specific type used to initialize them" ); + Night_Audit: + declare + use type Bank.Dollar_Amount; + Acct_Value : Bank.Dollar_Amount := 0.00; + begin + -- Perform nightly audit of total funds on deposit in bank. + for i in 1 .. Max_Accts loop + Audit (i, Acct_Value); + Bank_Balance := Bank_Balance + Acct_Value; + end loop; + + if Bank_Balance /= 3330.00 then + Report.Failed ("Class-wide object processing failed"); + end if; + + end Night_Audit; + + Report.Result; + + end C341A02; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a03.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- C341A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an object of one class-wide type can initialize a + -- class-wide object of a different type when the operation is embedded + -- in a generic unit. + -- + -- TEST DESCRIPTION: + -- Declare specific-type objects of an extended type. Declare an array + -- of access values designating class-wide objects, initialized to point + -- to the objects of the specific type. Define a generic subprogram + -- having a generic formal derived type parameter. Within the generic, + -- declare a class-wide variable of the formal parameter type. Verify + -- that the variable can be initialized with the value of an object + -- of another class-wide type within the class. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Dec 94 SAIC Changed level of 'Class for ATM_Card + -- + --! + + with F341A00_0; -- package Bank + generic + type Account_Type is new F341A00_0.Account with private; -- new Bank.Account + function C341A03_0 (The_Account : Account_Type'Class) -- function Audit + return F341A00_0.Dollar_Amount; + + function C341A03_0 (The_Account : Account_Type'Class) + return F341A00_0.Dollar_Amount is + Acct : Account_Type'Class := The_Account; -- Init. of class-wide with + begin -- another class-wide object. + return Acct.Current_Balance; + end C341A03_0; + + + --=================================================================-- + + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with C341A03_0; -- generic function Audit + with Report; + + procedure C341A03 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + + Current_Checking_Accounts : constant := 3; + + Checking_Acct1 : aliased Checking.Account := (Current_Balance => 10.00, + Overdraft_Fee => 5.00); + Checking_Acct2 : aliased Checking.Account := (Current_Balance => 20.00, + Overdraft_Fee => 5.00); + Checking_Acct3 : aliased Checking.Account := (Current_Balance => 30.00, + Overdraft_Fee => 5.00); + + type ATM_Card is access all Checking.Account'Class; + + -- Declare array of accesses to class-wide objects. + Account_Array : array (1 .. Current_Checking_Accounts) of + ATM_Card := (Checking_Acct1'Access, + Checking_Acct2'Access, + Checking_Acct3'Access); + begin -- C341A03 + + Report.Test ("C341A03", "Check that an object of one class-wide type " & + "can initialize a class-wide object of a " & + "different type when the operation is embedded " & + "in a generic unit" ); + + Audit_Checking_Accounts: + declare + Balance_In_Checking_Accounts : Bank.Dollar_Amount := 0.00; + -- Instantiate with a specific extended type. + function Checking_Audit is new C341A03_0 (Checking.Account); + use type Bank.Dollar_Amount; + begin + + for I in 1 .. Current_Checking_Accounts loop + Balance_In_Checking_Accounts := Balance_In_Checking_Accounts + + Checking_Audit (Account_Array (I).all); + end loop; + + if Balance_In_Checking_Accounts /= 60.00 then + Report.Failed ("Incorrect initialization of class-wide object"); + end if; + + end Audit_Checking_Accounts; + + Report.Result; + + end C341A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a04.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a04.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c341a04.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c341a04.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- C341A04.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that class-wide objects can be initialized using allocation. + -- + -- TEST DESCRIPTION: + -- Declare access types that refer to class-wide types, one with basis + -- of the root type, another with basis of a type extended from the root. + -- Declare objects of these access types, and allocate class-wide + -- objects, initialized to values of specific types within the particular + -- classes. + -- + -- The particular root and extended types used in this abstraction are + -- defined in foundation code (F341A00.A), and are graphically displayed + -- as follows: + -- + -- package Bank + -- type Account + -- | + -- | + -- | + -- package Checking + -- type Account + -- | + -- | + -- | + -- package Interest_Checking + -- type Account + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F341A00.A + -- + -- The following files comprise this test: + -- + -- => C341A04.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F341A00_0; -- package Bank + with F341A00_1; -- package Checking + with F341A00_2; -- package Interest_Checking + with Report; + + procedure C341A04 is + + package Bank renames F341A00_0; + package Checking renames F341A00_1; + package Interest_Checking renames F341A00_2; + + use type Bank.Dollar_Amount; + + Max_Accts : constant := 3; + Bank_Balance : Bank.Dollar_Amount := 0.00; + + -- Define access types referring to class of types rooted at + -- Bank.Account (root). + + type Bank_Account_Pointer is access Bank.Account'Class; + + -- + -- Define class-wide objects, initializing them through allocation. + -- + + -- Initialized to specific type that is basis of class. + Bank_Acct : Bank_Account_Pointer := + new Bank.Account'(Current_Balance => 10.00); + + -- Initialized to specific type that has been extended from the basis + -- of the class. + Checking_Acct : Bank_Account_Pointer := + new Checking.Account'(Current_Balance => 100.00, + Overdraft_Fee => 10.00); + + -- Initialized to specific type that has been twice extended from the + -- basis of the class. + IC_Acct : Bank_Account_Pointer := + new Interest_Checking.Account'(Current_Balance => 1000.00, + Overdraft_Fee => 10.00, + Rate => 0.030); + + -- Declare and initialize array of pointers to objects of + -- Bank.Account'Class. + + Accounts : array (1 .. Max_Accts) of Bank_Account_Pointer := + (Bank_Acct, Checking_Acct, IC_Acct); + + + -- Audit will process any account object within Bank.Account'Class. + + function Audit (Ptr : Bank_Account_Pointer) return Bank.Dollar_Amount is + begin + return (Ptr.Current_Balance); + end Audit; + + + begin -- C341A04 + + Report.Test ("C341A04", "Check that class-wide objects were " & + "successfully initialized using allocation" ); + + for i in 1 .. Max_Accts loop + Bank_Balance := Bank_Balance + Audit (Accounts(i)); + end loop; + + if Bank_Balance /= 1110.00 then + Report.Failed ("Failed class-wide object allocation"); + end if; + + Report.Result; + + end C341A04; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C35003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR AN INTEGER OR + -- ENUMERATION SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND + -- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + + -- HISTORY: + -- JET 01/25/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C35003A IS + + TYPE ENUM IS (ZERO, ONE, TWO, THREE); + SUBTYPE SUBENUM IS ENUM RANGE ONE..TWO; + TYPE INT IS RANGE 1..10; + SUBTYPE SUBINT IS INTEGER RANGE -10..10; + TYPE A1 IS ARRAY (0..11) OF INTEGER; + TYPE A2 IS ARRAY (INTEGER RANGE -11..10) OF INTEGER; + + BEGIN + TEST ("C35003A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR AN " & + "INTEGER OR ENUMERATION SUBTYPE INDICATION " & + "WHEN THE LOWER OR UPPER BOUND OF A NON-NULL " & + "RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE SUBSUBENUM IS SUBENUM RANGE ZERO..TWO; + BEGIN + FAILED ("NO EXCEPTION RAISED (E1)"); + DECLARE + Z : SUBSUBENUM := ONE; + BEGIN + IF NOT EQUAL(SUBSUBENUM'POS(Z),SUBSUBENUM'POS(Z)) + THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (E1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E1)"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (SUBENUM RANGE ONE..THREE) OF INTEGER; + BEGIN + FAILED ("NO EXCEPTION RAISED (E2)"); + DECLARE + Z : A := (OTHERS => 0); + BEGIN + IF NOT EQUAL(Z(ONE),Z(ONE)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (E2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E2)"); + END; + + BEGIN + DECLARE + TYPE I IS ACCESS INT RANGE INT(IDENT_INT(0))..10; + BEGIN + FAILED ("NO EXCEPTION RAISED (I1)"); + DECLARE + Z : I := NEW INT'(1); + BEGIN + IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (I1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I1)"); + END; + + BEGIN + DECLARE + TYPE I IS NEW INT RANGE 1..INT'SUCC(10); + BEGIN + FAILED ("NO EXCEPTION RAISED (I2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (I2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I2)"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + A : SUBINT RANGE IDENT_INT(-11)..0; + END RECORD; + BEGIN + FAILED ("NO EXCEPTION RAISED (S1)"); + DECLARE + Z : R := (A => 1); + BEGIN + IF NOT EQUAL(INTEGER(Z.A),INTEGER(Z.A)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (S1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (S1)"); + END; + + BEGIN + DECLARE + Z : SUBINT RANGE 0..IDENT_INT(11) := 0; + BEGIN + FAILED ("NO EXCEPTION RAISED (S2)"); + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (S2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (S2)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A1'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R1)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (R1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R1)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A2'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (R2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R2)"); + END; + + RESULT; + + END C35003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,217 ---- + -- C35003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A SUBTYPE INDICATION + -- OF A DISCRETE GENERIC FORMAL TYPE WHEN THE LOWER OR UPPER BOUND + -- OF A NON-NULL RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + + -- HISTORY: + -- JET 07/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C35003B IS + + TYPE ENUM IS (WE, LOVE, WRITING, TESTS); + TYPE INT IS RANGE -10..10; + + GENERIC + TYPE GEN_ENUM IS (<>); + TYPE GEN_INT IS RANGE <>; + PACKAGE GEN_PACK IS + SUBTYPE SUBENUM IS GEN_ENUM RANGE + GEN_ENUM'SUCC(GEN_ENUM'FIRST) .. + GEN_ENUM'PRED(GEN_ENUM'LAST); + SUBTYPE SUBINT IS GEN_INT RANGE + GEN_INT'SUCC(GEN_INT'FIRST) .. + GEN_INT'PRED(GEN_INT'LAST); + TYPE A1 IS ARRAY (0..GEN_INT'LAST) OF INTEGER; + TYPE A2 IS ARRAY (GEN_INT RANGE GEN_INT'FIRST..0) OF INTEGER; + END GEN_PACK; + + PACKAGE BODY GEN_PACK IS + BEGIN + TEST ("C35003B", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR A SUBTYPE INDICATION OF A DISCRETE " & + "GENERIC FORMAL TYPE WHEN THE LOWER OR " & + "UPPER BOUND OF A NON-NULL RANGE LIES " & + "OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE SUBSUBENUM IS SUBENUM RANGE + GEN_ENUM'FIRST..SUBENUM'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (E1)"); + DECLARE + Z : SUBSUBENUM := SUBENUM'FIRST; + BEGIN + IF NOT EQUAL(SUBSUBENUM'POS(Z), + SUBSUBENUM'POS(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG " & + "PLACE (E1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E1)"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (SUBENUM RANGE SUBENUM'FIRST .. + GEN_ENUM'LAST) OF INTEGER; + BEGIN + FAILED ("NO EXCEPTION RAISED (E2)"); + DECLARE + Z : A := (OTHERS => 0); + BEGIN + IF NOT EQUAL(Z(SUBENUM'FIRST), + Z(SUBENUM'FIRST)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(E2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (E2)"); + END; + + BEGIN + DECLARE + TYPE I IS ACCESS SUBINT RANGE + GEN_INT'FIRST..SUBINT'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (I1)"); + DECLARE + Z : I := NEW SUBINT'(SUBINT'FIRST); + BEGIN + IF NOT EQUAL(INTEGER(Z.ALL),INTEGER(Z.ALL)) + THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(I1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I1)"); + END; + + BEGIN + DECLARE + TYPE I IS NEW + SUBINT RANGE SUBINT'FIRST..GEN_INT'LAST; + BEGIN + FAILED ("NO EXCEPTION RAISED (I2)"); + DECLARE + Z : I := I'FIRST; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(I2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (I2)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A1'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R1)"); + DECLARE + Z : I := SUBINT'FIRST; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(R1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R1)"); + END; + + BEGIN + DECLARE + SUBTYPE I IS SUBINT RANGE A2'RANGE; + BEGIN + FAILED ("NO EXCEPTION RAISED (R2)"); + DECLARE + Z : I := 1; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE " & + "(R2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (R2)"); + END; + END GEN_PACK; + + PACKAGE ENUM_PACK IS NEW GEN_PACK(ENUM, INT); + + BEGIN + RESULT; + END C35003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35003d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35003d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C35003D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A FLOATING-POINT + -- SUBTYPE INDICATION WHEN THE LOWER OR UPPER BOUND OF A NON-NULL + -- RANGE LIES OUTSIDE THE RANGE OF THE TYPE MARK. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C35003D IS + + SUBTYPE FLT1 IS FLOAT RANGE -100.0 .. 100.0; + + BEGIN + TEST ("C35003D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "FLOATING-POINT SUBTYPE INDICATION WHEN THE " & + "LOWER OR UPPER BOUND OF A NON-NULL RANGE LIES " & + "OUTSIDE THE RANGE OF THE TYPE MARK"); + BEGIN + DECLARE + SUBTYPE F IS FLT1 RANGE 0.0..101.0+FLT1(IDENT_INT(0)); + BEGIN + FAILED ("NO EXCEPTION RAISED (F1)"); + DECLARE + Z : F := 1.0; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (F1)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (F1)"); + END; + + BEGIN + DECLARE + SUBTYPE F IS FLT1 RANGE -101.0..0.0; + BEGIN + FAILED ("NO EXCEPTION RAISED (F2)"); + DECLARE + Z : F := -1.0; + BEGIN + IF NOT EQUAL(INTEGER(Z),INTEGER(Z)) THEN + COMMENT ("DON'T OPTIMIZE Z"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG PLACE (F2)"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED (F2)"); + END; + + RESULT; + + END C35003D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35102a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,364 ---- + -- C35102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ENUMERATION LITERAL BELONGING TO ONE ENUMERATION TYPE + -- MAY BE DECLARED IN ANOTHER ENUMERATION TYPE DEFINITION IN THE SAME + -- DECLARATIVE REGION. + + -- R.WILLIAMS 8/20/86 + -- GMT 6/30/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY + -- CREATED PACKAGE NAMED SHOW_TEST_HEADER. + -- ADDED CODE FOR MY_PACK AND MY_FTN. + + + WITH REPORT; USE REPORT; + PROCEDURE C35102A IS + + TYPE E1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE E2 IS ('A', 'C', RED, BLUE); + + PACKAGE SHOW_TEST_HEADER IS + -- PURPOSE OF THIS PACKAGE: + -- WE WANT THE TEST HEADER INFORMATION TO BE + -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES. + END SHOW_TEST_HEADER; + + PACKAGE BODY SHOW_TEST_HEADER IS + BEGIN + TEST ( "C35102A", + "CHECK THAT AN ENUMERATION LITERAL BELONGING " & + "TO ONE ENUMERATION TYPE MAY BE DECLARED IN " & + "ANOTHER ENUMERATION TYPE DEFINITION IN THE " & + "SAME DECLARATIVE REGION" ); + END SHOW_TEST_HEADER; + + FUNCTION MY_FTN ( E : E1 ) RETURN E2 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN MY_FTN - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN MY_FTN - 1" ); + END IF; + + RETURN E2'VAL ( IDENT_INT ( E1'POS(E) ) ); + END MY_FTN; + + + PACKAGE MY_PACK IS + END MY_PACK; + + PACKAGE BODY MY_PACK IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + BEGIN -- MY_PACK + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN MY_PACK - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN MY_PACK - 1" ); + END IF; + END MY_PACK; + + PACKAGE PKG IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PKG - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PKG - 1" ); + END IF; + END PKG; + + PACKAGE PRIV IS + TYPE ENUM1 IS PRIVATE; + TYPE ENUM2 IS PRIVATE; + + FUNCTION FE1 (E : E1) RETURN ENUM1; + + FUNCTION FE2 (E : E2) RETURN ENUM2; + + PRIVATE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END PRIV; + + PACKAGE BODY PRIV IS + FUNCTION FE1 (E : E1) RETURN ENUM1 IS + BEGIN + RETURN ENUM1'VAL (IDENT_INT (E1'POS (E))); + END FE1; + + FUNCTION FE2 (E : E2) RETURN ENUM2 IS + BEGIN + RETURN ENUM2'VAL (IDENT_INT (E2'POS (E))); + END FE2; + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PRIV - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PRIV - 1" ); + END IF; + END PRIV; + + PACKAGE LPRIV IS + TYPE ENUM1 IS LIMITED PRIVATE; + TYPE ENUM2 IS LIMITED PRIVATE; + + FUNCTION FE1 (E : E1) RETURN ENUM1; + + FUNCTION FE2 (E : E2) RETURN ENUM2; + + FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN; + + FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN; + + PRIVATE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + END LPRIV; + + PACKAGE BODY LPRIV IS + FUNCTION FE1 (E : E1) RETURN ENUM1 IS + BEGIN + RETURN ENUM1'VAL (IDENT_INT (E1'POS (E))); + END FE1; + + FUNCTION FE2 (E : E2) RETURN ENUM2 IS + BEGIN + RETURN ENUM2'VAL (IDENT_INT (E2'POS (E))); + END FE2; + + FUNCTION EQUALS (A, B : ENUM1) RETURN BOOLEAN IS + BEGIN + IF A = B THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUALS; + + FUNCTION EQUALS (A, B : ENUM2) RETURN BOOLEAN IS + BEGIN + IF A = B THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUALS; + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN LPRIV - 1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN LPRIV - 2" ); + END IF; + END LPRIV; + + TASK T1; + + TASK BODY T1 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN T1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN T1" ); + END IF; + END T1; + + TASK T2 IS + ENTRY E; + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E DO + DECLARE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN T2.E" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN " & + "ENUM1 IN T2.E" ); + END IF; + END; + END E; + END T2; + + GENERIC + PROCEDURE GP1; + + PROCEDURE GP1 IS + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN GP1" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN GP1" ); + END IF; + END GP1; + + GENERIC + TYPE E1 IS (<>); + TYPE E2 IS (<>); + PROCEDURE GP2; + + PROCEDURE GP2 IS + BEGIN + IF E2'SUCC (E2'VALUE ("'A'")) /= E2'VALUE ("'C'") THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN E2 " & + "IN GP2" ); + END IF; + + IF E1'POS (E1'VALUE ("RED")) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN E1 " & + "IN GP2" ); + END IF; + END GP2; + + PROCEDURE NEWGP1 IS NEW GP1; + PROCEDURE NEWGP2 IS NEW GP2 (E1, E2); + + BEGIN + + DECLARE + TYPE ENUM1 IS ('A', 'B', 'C', RED, YELLOW, BLUE); + TYPE ENUM2 IS ('A', 'C', RED, BLUE); + + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN BLOCK" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN BLOCK" ); + END IF; + END; + + DECLARE + USE PKG; + BEGIN + IF ENUM2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PKG - 2" ); + END IF; + + IF ENUM1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PKG - 2" ); + END IF; + END; + + DECLARE + USE PRIV; + BEGIN + IF FE2 (E2'SUCC('A')) /= FE2 ('C') THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN PRIV - 2" ); + END IF; + + IF FE1 (RED) /= FE1 (E1'VAL (3)) THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN PRIV - 2" ); + END IF; + END; + + DECLARE + USE LPRIV; + BEGIN + IF NOT EQUALS (FE2 (E2'SUCC('A')), FE2 ('C')) THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN ENUM2 " & + "IN LPRIV - 2" ); + END IF; + + IF NOT EQUALS (FE1 (RED), FE1 (E1'VAL (3))) THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN ENUM1 " & + "IN LPRIV - 2" ); + END IF; + END; + + BEGIN + IF E2'SUCC ('A') /= 'C' THEN + FAILED ( "'A' NOT DECLARED CORRECTLY IN E2" ); + END IF; + + IF E1'POS (RED) /= 3 THEN + FAILED ( "RED NOT DECLARED CORRECTLY IN E1" ); + END IF; + END; + + NEWGP1; + NEWGP2; + T2.E; + + RESULT; + END C35102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c352001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c352001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c352001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c352001.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,270 ---- + -- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c354002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c354002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c354002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c354002.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,335 ---- + -- + -- C354002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the attributes of modular types yield + -- correct values/results. The attributes checked are: + -- + -- First, Last, Range, Base, Min, Max, Succ, Pred, + -- Image, Width, Value, Pos, and Val + -- + -- TEST DESCRIPTION: + -- This test defines several modular types. One type defined at + -- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, + -- a power of two half that of System.Max_Binary_Modulus, one less + -- than that power of two; one more than that power of two, two + -- less than a (large) power of two. For each of these types, + -- determine the correct operation of the following attributes: + -- + -- First, Last, Range, Base, Min, Max, Succ, Pred, Image, Width, + -- Value, Pos, Val, and Modulus + -- + -- The attributes Wide_Image and Wide_Value are deferred to C354003. + -- + -- + -- + -- CHANGE HISTORY: + -- 08 SEP 94 SAIC Initial version + -- 17 NOV 94 SAIC Revised version + -- 13 DEC 94 SAIC split off Wide_String attributes into C354003 + -- 06 JAN 95 SAIC Promoted to next release + -- 19 APR 95 SAIC Revised in accord with reviewer comments + -- 27 JAN 96 SAIC Eliminated 32/64 bit potential conflict for 2.1 + -- + --! + + with Report; + with System; + with TCTouch; + procedure C354002 is + + function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; + function ID(Local_Value: String) return String renames Report.Ident_Str; + + Power_2_Bits : constant := System.Storage_Unit; + Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; + + type Max_Binary is mod System.Max_Binary_Modulus; + type Max_NonBinary is mod System.Max_Nonbinary_Modulus; + type Half_Max_Binary is mod Half_Max_Binary_Value; + + type Medium is mod 2048; + type Medium_Plus is mod 2042; + type Medium_Minus is mod 2111; + + type Small is mod 2; + type Finger is mod 5; + + MBL : constant := Max_NonBinary'Last; + MNBM : constant := Max_NonBinary'Modulus; + + Ones_Complement_Permission : constant Boolean := MBL = MNBM; + + type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); + + subtype Midrange is Medium_Minus range 222 .. 1111; + + -- a few numbers for testing purposes + Max_Binary_Mod_Over_3 : constant := Max_Binary'Modulus / 3; + Max_NonBinary_Mod_Over_4 : constant := Max_NonBinary'Modulus / 4; + System_Max_Bin_Mod_Pred : constant := System.Max_Binary_Modulus - 1; + System_Max_NonBin_Mod_Pred : constant := System.Max_Nonbinary_Modulus - 1; + Half_Max_Bin_Value_Pred : constant := Half_Max_Binary_Value - 1; + + AMB, BMB : Max_Binary; + AHMB, BHMB : Half_Max_Binary; + AM, BM : Medium; + AMP, BMP : Medium_Plus; + AMM, BMM : Medium_Minus; + AS, BS : Small; + AF, BF : Finger; + + TC_Pass_Case : Boolean := True; + + procedure Value_Fault( S: String ) is + -- check 'Value for failure modes + begin + -- the evaluation of the 'Value expression should raise C_E + TCTouch.Assert_Not( Midrange'Value(S) = 0, "Value_Fault" ); + if Midrange'Value(S) not in Midrange'Base then + Report.Failed("'Value(" & S & ") raised no exception"); + end if; + exception + when Constraint_Error => null; -- expected case + when others => + Report.Failed("'Value(" & S & ") raised wrong exception"); + end Value_Fault; + + begin -- Main test procedure. + + Report.Test ("C354002", "Check attributes of modular types" ); + + -- Base + TCTouch.Assert( Midrange'Base'First = 0, "Midrange'Base'First" ); + TCTouch.Assert( Midrange'Base'Last = Medium_Minus'Last, + "Midrange'Base'Last" ); + + -- First + TCTouch.Assert( Max_Binary'First = 0, "Max_Binary'First" ); + TCTouch.Assert( Max_NonBinary'First = 0, "Max_NonBinary'First" ); + TCTouch.Assert( Half_Max_Binary'First = 0, "Half_Max_Binary'First" ); + + TCTouch.Assert( Medium'First = Medium(ID(0)), "Medium'First" ); + TCTouch.Assert( Medium_Plus'First = Medium_Plus(ID(0)), + "Medium_Plus'First" ); + TCTouch.Assert( Medium_Minus'First = Medium_Minus(ID(0)), + "Medium_Minus'First" ); + + TCTouch.Assert( Small'First = Small(ID(0)), "Small'First" ); + TCTouch.Assert( Finger'First = Finger(ID(0)), "Finger'First" ); + TCTouch.Assert( Midrange'First = Midrange(ID(222)), + "Midrange'First" ); + + -- Image + TCTouch.Assert( Half_Max_Binary'Image(255) = " 255", + "Half_Max_Binary'Image" ); + TCTouch.Assert( Medium'Image(0) = ID(" 0"), "Medium'Image" ); + TCTouch.Assert( Medium_Plus'Image(Medium_Plus'Last) = " 2041", + "Medium_Plus'Image" ); + TCTouch.Assert( Medium_Minus'Image(Medium_Minus(ID(1024))) = " 1024", + "Medium_Minus'Image" ); + TCTouch.Assert( Small'Image(Small(ID(1))) = " 1", "Small'Image" ); + TCTouch.Assert( Midrange'Image(Midrange(ID(333))) = " 333", + "Midrange'Image" ); + + -- Last + TCTouch.Assert( Max_Binary'Last = System_Max_Bin_Mod_Pred, + "Max_Binary'Last"); + if Ones_Complement_Permission then + TCTouch.Assert( Max_NonBinary'Last >= System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Last (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Last = System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Last"); + end if; + TCTouch.Assert( Half_Max_Binary'Last = Half_Max_Bin_Value_Pred, + "Half_Max_Binary'Last"); + + TCTouch.Assert( Medium'Last = Medium(ID(2047)), "Medium'Last"); + TCTouch.Assert( Medium_Plus'Last = Medium_Plus(ID(2041)), + "Medium_Plus'Last"); + TCTouch.Assert( Medium_Minus'Last = Medium_Minus(ID(2110)), + "Medium_Minus'Last"); + TCTouch.Assert( Small'Last = Small(ID(1)), "Small'Last"); + TCTouch.Assert( Finger'Last = Finger(ID(4)), "Finger'Last"); + TCTouch.Assert( Midrange'Last = Midrange(ID(1111)), "Midrange'Last"); + + -- Max + TCTouch.Assert( Max_Binary'Max(Power_2_Bits, Max_Binary'Last) + = Max_Binary'Last, "Max_Binary'Max"); + TCTouch.Assert( Max_NonBinary'Max(100,2000) = 2000, "Max_NonBinary'Max"); + TCTouch.Assert( Half_Max_Binary'Max(123,456) = 456, + "Half_Max_Binary'Max"); + + TCTouch.Assert( Medium'Max(0,2040) = 2040, "Medium'Max"); + TCTouch.Assert( Medium_Plus'Max(0,1) = 1, "Medium_Plus'Max"); + TCTouch.Assert( Medium_Minus'Max(2001,1995) = 2001, "Medium_Minus'Max"); + TCTouch.Assert( Small'Max(1,0) = 1, "Small'Max"); + TCTouch.Assert( Finger'Max(Finger'Last+1,4) = 4, "Finger'Max"); + TCTouch.Assert( Midrange'Max(Midrange'First+1,222) = Midrange'First+1, + "Midrange'Max"); + + -- Min + TCTouch.Assert( Max_Binary'Min(Power_2_Bits, Max_Binary'Last) + = Power_2_Bits, "Max_Binary'Min"); + TCTouch.Assert( Max_NonBinary'Min(100,2000) = 100, "Max_NonBinary'Min"); + TCTouch.Assert( Half_Max_Binary'Min(123,456) = 123, + "Half_Max_Binary'Min"); + + TCTouch.Assert( Medium'Min(0,Medium(ID(2040))) = 0, "Medium'Min"); + TCTouch.Assert( Medium_Plus'Min(0,1) = 0, "Medium_Plus'Min"); + TCTouch.Assert( Medium_Minus'Min(2001,1995) = 1995, "Medium_Minus'Min"); + TCTouch.Assert( Small'Min(1,0) = 0, "Small'Min"); + TCTouch.Assert( Finger'Min(Finger'Last+1,4) /= 4, "Finger'Min"); + TCTouch.Assert( Midrange'Min(Midrange'First+1,222) = 222, + "Midrange'Min"); + -- Modulus + TCTouch.Assert( Max_Binary'Modulus = System.Max_Binary_Modulus, + "Max_Binary'Modulus"); + TCTouch.Assert( Max_NonBinary'Modulus = System.Max_Nonbinary_Modulus, + "Max_NonBinary'Modulus"); + TCTouch.Assert( Half_Max_Binary'Modulus = Half_Max_Binary_Value, + "Half_Max_Binary'Modulus"); + + TCTouch.Assert( Medium'Modulus = 2048, "Medium'Modulus"); + TCTouch.Assert( Medium_Plus'Modulus = 2042, "Medium_Plus'Modulus"); + TCTouch.Assert( Medium_Minus'Modulus = 2111, "Medium_Minus'Modulus"); + TCTouch.Assert( Small'Modulus = 2, "Small'Modulus"); + TCTouch.Assert( Finger'Modulus = 5, "Finger'Modulus"); + TCTouch.Assert( Midrange'Modulus = ID(2111), "Midrange'Modulus"); + + -- Pos + declare + Int : Natural := 222; + begin + for I in Midrange loop + TC_Pass_Case := TC_Pass_Case and Midrange'Pos(I) = Int; + + Int := Int +1; + end loop; + end; + + TCTouch.Assert( TC_Pass_Case, "Midrange'Pos"); + + -- Pred + TCTouch.Assert( Max_Binary'Pred(0) = System_Max_Bin_Mod_Pred, + "Max_Binary'Pred(0)"); + if Ones_Complement_Permission then + TCTouch.Assert( Max_NonBinary'Pred(0) >= System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Pred(0) (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Pred(0) = System_Max_NonBin_Mod_Pred, + "Max_NonBinary'Pred(0)"); + end if; + TCTouch.Assert( Half_Max_Binary'Pred(0) = Half_Max_Bin_Value_Pred, + "Half_Max_Binary'Pred(0)"); + + TCTouch.Assert( Medium'Pred(Medium(ID(0))) = 2047, "Medium'Pred(0)"); + TCTouch.Assert( Medium_Plus'Pred(0) = 2041, "Medium_Plus'Pred(0)"); + TCTouch.Assert( Medium_Minus'Pred(0) = 2110, "Medium_Minus'Pred(0)"); + TCTouch.Assert( Small'Pred(0) = 1, "Small'Pred(0)"); + TCTouch.Assert( Finger'Pred(Finger(ID(0))) = 4, "Finger'Pred(0)"); + TCTouch.Assert( Midrange'Pred(222) = 221, "Midrange'Pred('First)"); + + -- Range + for I in Midrange'Range loop + if I not in Midrange then + Report.Failed("Midrange loop test"); + end if; + end loop; + for I in Medium'Range loop + if I not in Medium then + Report.Failed("Medium loop test"); + end if; + end loop; + for I in Medium_Minus'Range loop + if I not in 0..2110 then + Report.Failed("Medium loop test"); + end if; + end loop; + + -- Succ + TCTouch.Assert( Max_Binary'Succ(System_Max_Bin_Mod_Pred) = 0, + "Max_Binary'Succ('Last)"); + if Ones_Complement_Permission then + TCTouch.Assert( (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0) + or (Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) + = Max_NonBinary'Last), + "Max_NonBinary'Succ('Last) (ones comp)"); + else + TCTouch.Assert( Max_NonBinary'Succ(System_Max_NonBin_Mod_Pred) = 0, + "Max_NonBinary'Succ('Last)"); + end if; + TCTouch.Assert( Half_Max_Binary'Succ(Half_Max_Bin_Value_Pred) = 0, + "Half_Max_Binary'Succ('Last)"); + + TCTouch.Assert( Medium'Succ(2047) = 0, "Medium'Succ('Last)"); + TCTouch.Assert( Medium_Plus'Succ(2041) = 0, "Medium_Plus'Succ('Last)"); + TCTouch.Assert( Medium_Minus'Succ(2110) = 0, "Medium_Minus'Succ('Last)"); + TCTouch.Assert( Small'Succ(1) = 0, "Small'Succ('Last)"); + TCTouch.Assert( Finger'Succ(4) = 0, "Finger'Succ('Last)"); + TCTouch.Assert( Midrange'Succ(Midrange(ID(1111))) = 1112, + "Midrange'Succ('Last)"); + + -- Val + for I in Natural range ID(222)..ID(1111) loop + TCTouch.Assert( Midrange'Val(I) = Medium_Minus(I), "Midrange'Val"); + end loop; + + -- Value + + TCTouch.Assert( Half_Max_Binary'Value("255") = 255, + "Half_Max_Binary'Value" ); + + TCTouch.Assert( Medium'Value(" 1e2") = 100, "Medium'Value(""1e2"")" ); + TCTouch.Assert( Medium'Value(" 0 ") = 0, "Medium'Value" ); + TCTouch.Assert( Medium_Plus'Value(ID("2041")) = 2041, + "Medium_Plus'Value" ); + TCTouch.Assert( Medium_Minus'Value(ID("+10_24")) = 1024, + "Medium_Minus'Value" ); + + TCTouch.Assert( Small'Value("+1") = 1, "Small'Value" ); + TCTouch.Assert( Midrange'Value(ID("333")) = 333, "Midrange'Value" ); + TCTouch.Assert( Midrange'Value("1E3") = 1000, + "Midrange'Value(""1E3"")" ); + + Value_Fault( "bad input" ); + Value_Fault( "-333" ); + Value_Fault( "9999" ); + Value_Fault( ".1" ); + Value_Fault( "1e-1" ); + + -- Width + TCTouch.Assert( Medium'Width = 5, "Medium'Width"); + TCTouch.Assert( Medium_Plus'Width = 5, "Medium_Plus'Width"); + TCTouch.Assert( Medium_Minus'Width = 5, "Medium_Minus'Width"); + TCTouch.Assert( Small'Width = 2, "Small'Width"); + TCTouch.Assert( Finger'Width = 2, "Finger'Width"); + TCTouch.Assert( Midrange'Width = 5, "Midrange'Width"); + + Report.Result; + + end C354002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c354003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c354003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c354003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c354003.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,211 ---- + -- C354003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Wide_String attributes of modular types yield + -- correct values/results. The attributes checked are: + -- + -- Wide_Image + -- Wide_Value + -- + -- TEST DESCRIPTION: + -- This test is split from C354002. It tests only the attributes: + -- + -- Wide_Image, Wide_Value + -- + -- This test defines several modular types. One type defined at + -- each of System.Max_Binary_Modulus, System.Max_Nonbinary_Modulus, + -- a power of two half that of System.Max_Binary_Modulus, one less + -- than that power of two; one more than that power of two, two + -- less than a (large) power of two. For each of these types, + -- determine the correct operation of the Wide_String attributes. + -- + -- + -- CHANGE HISTORY: + -- 13 DEC 94 SAIC Initial version + -- 06 JAN 94 SAIC Promoted to future release + -- 19 APR 95 SAIC Revised in accord with reviewer comments + -- 01 DEC 95 SAIC Corrected for 2.0.1 + -- 27 JAN 96 SAIC Eliminated potential 32/64 bit conflict for 2.1 + -- 24 FEB 97 PWB.CTA Corrected out-of-range value + --! + + with Report; + with System; + with TCTouch; + with Ada.Characters.Handling; + procedure C354003 is + + function ID(Local_Value: Integer) return Integer renames Report.Ident_Int; + function ID(Local_Value: String) return String renames Report.Ident_Str; + + function ID(Local_Value: String) return Wide_String is + begin + return Ada.Characters.Handling.To_Wide_String( ID( Local_Value ) ); + end ID; + + Half_Max_Binary_Value : constant := System.Max_Binary_Modulus / 2; + + type Max_Binary is mod System.Max_Binary_Modulus; + type Max_NonBinary is mod System.Max_Nonbinary_Modulus; + type Half_Max_Binary is mod Half_Max_Binary_Value; + + type Medium is mod 2048; + type Medium_Plus is mod 2042; + type Medium_Minus is mod 2111; + + type Small is mod 2; + type Finger is mod 5; + + type Finger_Id is (Thumb, Index, Middle, Ring, Pinkie); + + subtype Midrange is Medium_Minus range 222 .. 1111; + + AMB, BMB : Max_Binary; + AHMB, BHMB : Half_Max_Binary; + AM, BM : Medium; + AMP, BMP : Medium_Plus; + AMM, BMM : Medium_Minus; + AS, BS : Small; + AF, BF : Finger; + + procedure Wide_Value_Fault( S: Wide_String ) is + -- check 'Wide_Value for failure modes + begin + -- the evaluation of the 'Wide_Value expression should raise C_E + TCTouch.Assert_Not( Midrange'Wide_Value(S) = 0, "Wide_Value_Fault" ); + if Midrange'Wide_Value(S) not in Midrange'Base then + Report.Failed("'Wide_Value raised no exception"); + end if; + exception + when Constraint_Error => null; -- expected case + when others => + Report.Failed("'Wide_Value raised wrong exception"); + end Wide_Value_Fault; + + + The_Cap, The_Toe : Natural; + + procedure Check_Non_Static_Cases( Lower_Bound,Upper_Bound : Medium ) is + subtype Non_Static is Medium range Lower_Bound..Upper_Bound; + begin + -- First, Last, Range, Min, Max, Succ, Pred, Pos, and Val + + TCTouch.Assert( Non_Static'First = Medium(The_Toe), "Non_Static'First" ); + TCTouch.Assert( Non_Static'Last = Non_Static(The_Cap), + "Non_Static'Last" ); + TCTouch.Assert( Non_Static(The_Cap/2) in Non_Static'Range, + "Non_Static'Range" ); + TCTouch.Assert( Non_Static'Min(Medium(Report.Ident_Int(100)), + Medium(Report.Ident_Int(200))) = 100, + "Non_Static'Min" ); + TCTouch.Assert( Non_Static'Max(Medium(Report.Ident_Int(100)), + Medium(Report.Ident_Int(200))) = 200, + "Non_Static'Max" ); + TCTouch.Assert( Non_Static'Succ(Non_Static(The_Cap)) + = Medium'Succ(Upper_Bound), + "Non_Static'Succ" ); + TCTouch.Assert( Non_Static'Pred(Medium(Report.Ident_Int(The_Cap))) + = Non_Static(Report.Ident_Int(The_Cap-1)), + "Non_Static'Pred" ); + TCTouch.Assert( Non_Static'Pos(Upper_Bound) = Non_Static(The_Cap), + "Non_Static'Pos" ); + TCTouch.Assert( Non_Static'Val(Non_Static(The_Cap)) = Upper_Bound, + "Non_Static'Val" ); + + end Check_Non_Static_Cases; + + + begin -- Main test procedure. + + Report.Test ("C354003", "Check Wide_String attributes of modular types" ); + + Wide_Strings_Needed: declare + + Max_Bin_Mod_Div_3 : constant := Max_Binary'Modulus/3; + Max_Non_Mod_Div_4 : constant := Max_NonBinary'Modulus/4; + + begin + + -- Wide_Image + + TCTouch.Assert( Half_Max_Binary'Wide_Image(255) = " 255", + "Half_Max_Binary'Wide_Image" ); + + TCTouch.Assert( Medium'Wide_Image(0) = " 0", "Medium'Wide_Image" ); + + TCTouch.Assert( Medium_Plus'Wide_Image(Medium_Plus'Last) = " 2041", + "Medium_Plus'Wide_Image" ); + + TCTouch.Assert( Medium_Minus'Wide_Image(Medium_Minus(ID(1024))) = " 1024", + "Medium_Minus'Wide_Image" ); + + TCTouch.Assert( Small'Wide_Image(1) = " 1", "Small'Wide_Image" ); + + TCTouch.Assert( Midrange'Wide_Image(Midrange(ID(333))) = " 333", + "Midrange'Wide_Image" ); + + -- Wide_Value + + TCTouch.Assert( Half_Max_Binary'Wide_Value("255") = 255, + "Half_Max_Binary'Wide_Value" ); + + TCTouch.Assert( Medium'Wide_Value(" 0 ") = 0, "Medium'Wide_Value" ); + + TCTouch.Assert( Medium_Plus'Wide_Value(ID("2041")) = Medium_Plus'Last, + "Medium_Plus'Wide_Value" ); + + TCTouch.Assert( Medium_Minus'Wide_Value("+1_4 ") = 14, + "Medium_Minus'Wide_Value" ); + + TCTouch.Assert( Small'Wide_Value("+1") = 1, "Small'Wide_Value" ); + + TCTouch.Assert( Midrange'Wide_Value(ID("333")) = 333, + "Midrange'Wide_Value" ); + + TCTouch.Assert( Midrange'Wide_Value(ID("1E3")) = 1000, + "Midrange'Wide_Value(""1E3"")" ); + + Wide_Value_Fault( "bad input" ); + Wide_Value_Fault( "-333" ); + Wide_Value_Fault( "9999" ); + Wide_Value_Fault( ".1" ); + Wide_Value_Fault( "1e-1" ); + + end Wide_Strings_Needed; + + The_Toe := Report.Ident_Int(25); + The_Cap := Report.Ident_Int(256); + Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), + Medium(Report.Ident_Int(The_Cap)) ); + + The_Toe := Report.Ident_Int(40); + The_Cap := Report.Ident_Int(2047); + Check_Non_Static_Cases( Medium(Report.Ident_Int(The_Toe)), + Medium(Report.Ident_Int(The_Cap)) ); + + Report.Result; + + end C354003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C35502A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS + -- WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR + -- A CHARACTER TYPE. + + -- RJW 5/05/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502A IS + + BEGIN + + TEST( "C35502A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS AN ENUMERATION TYPE OTHER THAN " & + "A BOOLEAN OR A CHARACTER TYPE" ); + + DECLARE + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + SUBTYPE NOENUM IS ENUM RANGE ABC .. A; + + TYPE NEWENUM IS NEW ENUM; + + BEGIN + + IF ENUM'WIDTH /= IDENT_INT(5) THEN + FAILED( "INCORRECT WIDTH FOR ENUM" ); + END IF; + + IF NEWENUM'WIDTH /= IDENT_INT(5) THEN + FAILED( "INCORRECT WIDTH FOR NEWENUM" ); + END IF; + + IF SUBENUM'WIDTH /= IDENT_INT(3) THEN + FAILED( "INCORRECT WIDTH FOR SUBENUM" ); + END IF; + + IF NOENUM'WIDTH /= IDENT_INT(0) THEN + FAILED( "INCORRECT WIDTH FOR NOENUM" ); + END IF; + + END; + + RESULT; + END C35502A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C35502B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS + -- WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR CHARACTER + -- TYPE. + + -- RJW 5/05/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502B IS + + BEGIN + + TEST( "C35502B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " & + "TYPE" ); + + DECLARE + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + SUBTYPE NOENUM IS ENUM RANGE ABC .. A; + + TYPE NEWENUM IS NEW ENUM; + + GENERIC + TYPE E IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'WIDTH /= IDENT_INT(W) THEN + FAILED ( "INCORRECT E'WIDTH FOR " & STR ); + END IF; + IF NOENUM'WIDTH /= IDENT_INT(0) THEN + FAILED ( "INCORRECT NOENUM'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE PROC1 IS NEW P (ENUM, 5); + PROCEDURE PROC2 IS NEW P (SUBENUM, 3); + PROCEDURE PROC3 IS NEW P (NEWENUM, 5); + PROCEDURE PROC4 IS NEW P (NOENUM, 0); + + BEGIN + PROC1 ( "ENUM" ); + PROC2 ( "SUBENUM" ); + PROC3 ( "NEWENUM" ); + PROC4 ( "NOENUM" ); + END; + + RESULT; + END C35502B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,318 ---- + -- C35502C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN + -- OR A CHARACTER TYPE. + -- SUBTESTS ARE: + -- PART (A). TESTS FOR IMAGE. + -- PART (B). TESTS FOR VALUE. + + -- RJW 5/07/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502C IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, abcd); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + + FUNCTION IDENT (X : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL (ENUM'POS (X), ENUM'POS(X)) THEN + RETURN X; + END IF; + RETURN ENUM'FIRST; + END IDENT; + + BEGIN + + TEST( "C35502C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS " & + "WHEN THE PREFIX IS AN ENUMERATION TYPE " & + "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" ); + + -- PART (A). + + BEGIN + + IF ENUM'IMAGE ( IDENT(ABC) ) /= "ABC" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR ABC" ); + END IF; + IF ENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC IN ENUM" ); + END IF; + + IF ENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR A_B_C" ); + END IF; + IF ENUM'IMAGE ( IDENT(A_B_C) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR A_B_C IN ENUM" ); + END IF; + + IF SUBENUM'IMAGE ( IDENT(A_B_C) ) /= "A_B_C" THEN + FAILED ( "INCORRECT SUBENUM'IMAGE FOR A_B_C" ); + END IF; + IF SUBENUM'IMAGE ( IDENT(ABC) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC " & + "IN SUBENUM" ); + END IF; + + IF NEWENUM'IMAGE ( ABC ) /= IDENT_STR("ABC") THEN + FAILED ( "INCORRECT NEWENUM'IMAGE FOR ABC" ); + END IF; + IF NEWENUM'IMAGE ( ABC )'FIRST /= IDENT_INT(1) THEN + FAILED ( "INCORRECT LOWER BOUND FOR ABC" & + "IN NEWENUM" ); + END IF; + + IF ENUM'IMAGE ( IDENT(abcd) ) /= "ABCD" THEN + FAILED ( "INCORRECT ENUM'IMAGE FOR abcd" ); + END IF; + IF ENUM'IMAGE ( IDENT(abcd) )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR abcd IN ENUM" ); + END IF; + + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + BEGIN + IF ENUM'VALUE (IDENT_STR("ABC")) /= ABC THEN + FAILED ( "INCORRECT VALUE FOR ""ABC""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("abc")) /= abc THEN + FAILED ( "INCORRECT VALUE FOR ""abc""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""abc""" ); + END; + + BEGIN + IF ENUM'VALUE ("ABC") /= ABC THEN + FAILED ( "INCORRECT VALUE FOR ABC" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ABC" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("abcd")) /= abcd THEN + FAILED ( "INCORRECT VALUE FOR ""abcd""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""abcd""" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("ABCD")) /= abcd THEN + FAILED ( "INCORRECT VALUE FOR ""ABCD""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""ABCD""" ); + END; + + BEGIN + IF NEWENUM'VALUE ("abcd") /= abcd THEN + FAILED ( "INCORRECT VALUE FOR abcd" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR abcd" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("A_B_C")) /= A_B_C THEN + FAILED ( "INCORRECT VALUE FOR ""A_B_C""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""A_B_C""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("ABC ")) /= ABC THEN + FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE WITH " & + "TRAILING BLANKS" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR(" A_B_C")) /= A_B_C THEN + FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE WITH LEADING " & + "BLANKS" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A_BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A_BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A_BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("A&BC")) /= ABC THEN + FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""A&BC"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""A&BC""" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_CHAR(ASCII.HT) & "BC") /= BC THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF NEWENUM'VALUE ("A" & (IDENT_CHAR(ASCII.HT))) /= A THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + BEGIN + IF ENUM'VALUE (IDENT_STR("B__C")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "CONSECUTIVE UNDERSCORES" ); + END; + + BEGIN + IF NEWENUM'VALUE (IDENT_STR("BC_")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "TRAILING UNDERSCORE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "TRAILING UNDERSCORE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "TRAILING UNDERSCORE" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("_BC")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "LEADING UNDERSCORE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "LEADING UNDERSCORE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "LEADING UNDERSCORE" ); + END; + + BEGIN + IF SUBENUM'VALUE (IDENT_STR("0BC")) /= BC THEN + FAILED ( "NO EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "FIRST CHARACTER IS A DIGIT" ); + END; + + RESULT; + END C35502C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502d.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502d.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502d.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502d.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C35502D.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE + -- LONGEST POSSIBLE ENUMERATION LITERAL. + + -- RJW 2/21/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502D IS + + BEGIN + TEST ("C35502D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LONGEST POSSIBLE " & + "ENUMERATION LITERAL"); + + -- BIG_ID1 IS A MAXIMUM LENGTH IDENTIFIER. BIG_STRING1 AND + -- BIG_STRING2 ARE TWO STRING LITERALS WHICH WHEN CONCATENATED + -- FORM THE IMAGE OF BIG_ID1; + + + DECLARE + TYPE ENUM IS ( + $BIG_ID1 + ); + + BEGIN + BEGIN + IF ENUM'VALUE ( + $BIG_STRING1 + & + $BIG_STRING2 + ) /= + $BIG_ID1 + THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'VALUE'" ); + END; + BEGIN + IF ENUM'IMAGE( + $BIG_ID1 + ) /= + ( + $BIG_STRING1 + & + $BIG_STRING2 + ) THEN + FAILED ( "INCORRECT RESULTS FOR 'IMAGE'" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR 'IMAGE'" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR 'IMAGE'" ); + END; + END; + + RESULT; + END C35502D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- C35502E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A + -- CHARACTER TYPE. + -- SUBTESTS ARE: + -- PART (A). TESTS FOR IMAGE. + -- PART (B). TESTS FOR VALUE. + + -- RJW 5/13/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502E IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, abcd); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + + BEGIN + + TEST( "C35502E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS AN ENUMERATION TYPE " & + "OTHER THAN A BOOLEAN OR A CHARACTER TYPE" ); + + -- PART (A). + DECLARE + GENERIC + TYPE E IS (<>); + STR1 : STRING; + PROCEDURE P ( E1 : E; STR2 : STRING ); + + PROCEDURE P ( E1 : E; STR2 : STRING ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF SE'IMAGE ( E1 ) /= STR2 THEN + FAILED ( "INCORRECT SE'IMAGE FOR " & STR2 & " IN " + & STR1 ); + END IF; + IF SE'IMAGE ( E1 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 + & " IN " & STR1 ); + END IF; + END P; + + PROCEDURE PE IS NEW P ( ENUM , "ENUM" ); + PROCEDURE PS IS NEW P ( SUBENUM, "SUBENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE ( ABC, "ABC" ); + PE ( A_B_C, "A_B_C" ); + PS ( BC, "BC" ); + PN ( ABC, "ABC" ); + PE ( abcd, "ABCD" ); + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + DECLARE + GENERIC + TYPE E IS (<>); + STR1 : STRING; + PROCEDURE P ( STR2 : STRING ; E1 : E ); + + PROCEDURE P ( STR2 : STRING ; E1 : E ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF E'VALUE ( STR2 ) /= E1 THEN + FAILED ( "INCORRECT " & STR1 & "'VALUE FOR """ & + STR2 & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - " & STR1 & "'VALUE " & + "FOR """ & STR2 & """" ); + END P; + + PROCEDURE PE IS NEW P ( ENUM , "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PN ("abcd", abcd); + PN ("A_B_C", A_B_C); + PE ("ABC ", ABC); + PE (" A_B_C", A_B_C); + END; + + + DECLARE + GENERIC + TYPE E IS (<>); + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + IF SE'VALUE (STR) = SE'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED - " & STR & " - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & STR & " - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & STR ); + END P; + + PROCEDURE PE IS NEW P ( ENUM ); + PROCEDURE PS IS NEW P ( SUBENUM ); + PROCEDURE PN IS NEW P ( NEWENUM ); + + BEGIN + PS ("A BC"); + PN ("A&BC"); + PE (ASCII.HT & "BC"); + PE ("A" & ASCII.HT); + PS ("_BC"); + PN ("BC_"); + PE ("B__C"); + PE ("0BC"); + + END; + + RESULT; + END C35502E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502f.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502f.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502f.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502f.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C35502F.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMAGE AND VALUE ATTRIBUTES ARE CORRECT FOR A FORMAL + -- DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN ENUMERATED TYPE + -- WITH THE LONGEST POSSIBLE IDENTIFIER AS ONE CONSTANT. + + -- PWB 03/05/86 + -- DWC 07/22/87 -- ADDED THE CONSTANT STRING 'STR'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35502F IS + + -- BIG_ID1 IS AN IDENTIFIER OF MAXIMUM LENGTH. + TYPE ENUM IS ( EVAL1, + $BIG_ID1 + ); + + -- BIG_STRING1 & BIG_STRING2 YIELDS BIG_ID. + STR1 : CONSTANT STRING := + $BIG_STRING1; + STR2 : CONSTANT STRING := + $BIG_STRING2; + STR : CONSTANT STRING := STR1 & STR2; + + GENERIC + TYPE FORMAL IS (<>); + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + VALUE_CHECK: + BEGIN + IF FORMAL'VALUE (STR) /= FORMAL'LAST THEN + FAILED ("VALUE OF LONG STRING NOT LONG IDENTIFIER"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CHECKING " & + "VALUE ATTRIBUTE"); + END VALUE_CHECK; + + IMAGE_CHECK: + BEGIN + IF FORMAL'IMAGE (FORMAL'LAST) /= STR + THEN + FAILED ("IMAGE OF LONG IDENTIFIER NOT LONG STRING"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CHECKING " & + "IMAGE ATTRIBUTE"); + END IMAGE_CHECK; + + END GEN_PROC; + + PROCEDURE TEST_PROC IS NEW GEN_PROC (ENUM); + + BEGIN -- C35502F + + TEST ("C35502F", "IMAGE AND VALUE ATTRIBUTES FOR A FORMAL " & + "DISCRETE TYPE WITH ONE ACTUAL VALUE HAVING " & + "LONGEST POSSIBLE IDENTIFIER"); + TEST_PROC; + RESULT; + + END C35502F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C35502G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A + -- CHARACTER TYPE. + + -- RJW 5/27/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502G IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE" ); + + BEGIN + FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP + IF SUBENUM'PRED (I) /= + ENUM'VAL (ENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBENUM'PRED(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP + IF SUBENUM'SUCC (I) /= + ENUM'VAL (ENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBENUM'SUCC(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + BEGIN + FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP + IF SUBNEW'PRED (I) /= + NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBNEW'PRED(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP + IF SUBNEW'SUCC (I) /= + NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBNEW'SUCC(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + RESULT; + END C35502G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502h.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C35502H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS + -- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE. + + -- RJW 5/27/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502H IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + + TYPE NEWENUM IS NEW ENUM; + + BEGIN + TEST ("C35502H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "ARGUMENT IS AN ENUMERATION TYPE OTHER THAN " & + "A CHARACTER OR A BOOLEAN TYPE" ); + + DECLARE + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + BEGIN + FOR I IN E'VAL (1) .. E'VAL (4) LOOP + IF SE'PRED (I) /= + E'VAL (E'POS (I) - 1) THEN + FAILED ("INCORRECT " & STR & "'PRED(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN E'VAL (0) .. E'VAL (3) LOOP + IF SE'SUCC (I) /= + E'VAL (E'POS (I) + 1) THEN + FAILED ("INCORRECT " & STR & "'SUCC(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE; + PN; + END; + + RESULT; + END C35502H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502i.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C35502I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A + -- CHARACTER TYPE, WITH A REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 05/27/86 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35502I IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502I", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE, OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE, WITH A REPRESENTATION " & + "CLAUSE" ); + + BEGIN + FOR I IN ENUM'VAL (1) .. ENUM'VAL (4) LOOP + IF SUBENUM'PRED (I) /= + ENUM'VAL (ENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBENUM'PRED(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN ENUM'VAL (0) .. ENUM'VAL (3) LOOP + IF SUBENUM'SUCC (I) /= + ENUM'VAL (ENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBENUM'SUCC(" & + ENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + BEGIN + FOR I IN NEWENUM'VAL (1) .. NEWENUM'VAL (4) LOOP + IF SUBNEW'PRED (I) /= + NEWENUM'VAL (NEWENUM'POS (I) - 1) THEN + FAILED ("INCORRECT SUBNEW'PRED(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN NEWENUM'VAL (0) .. NEWENUM'VAL (3) LOOP + IF SUBNEW'SUCC (I) /= + NEWENUM'VAL (NEWENUM'POS (I) + 1) THEN + FAILED ("INCORRECT SUBNEW'SUCC(" & + NEWENUM'IMAGE (I) & ")" ); + END IF; + END LOOP; + END; + + RESULT; + END C35502I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C35502J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS + -- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE, + -- WITH AN ENUMERATION REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 05/27/86 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35502J IS + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + + TYPE NEWENUM IS NEW ENUM; + + BEGIN + TEST ("C35502J", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS " & + "A FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "ARGUMENT IS AN ENUMERATION TYPE, OTHER THAN " & + "A CHARACTER OR A BOOLEAN TYPE, WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + + BEGIN + FOR I IN E'VAL (1) .. E'VAL (4) + LOOP + IF SE'PRED (I) /= + E'VAL (E'POS (I) - 1) THEN + FAILED ("INCORRECT " & STR & "'PRED(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + FOR I IN E'VAL (0) .. E'VAL (3) + LOOP + IF SE'SUCC (I) /= + E'VAL (E'POS (I) + 1) THEN + FAILED ("INCORRECT " & STR & "'SUCC(" & + E'IMAGE (I) & ")" ); + END IF; + END LOOP; + + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + + BEGIN + PE; + PN; + END; + + RESULT; + END C35502J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502k.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- C35502K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A + -- CHARACTER TYPE. + + -- RJW 5/27/86 + -- GMT 7/02/87 ADDED ENUM'VAL(3) CHECK NEAR END OF 2ND BLOCK STATEMENT. + + + WITH REPORT; USE REPORT; + + PROCEDURE C35502K IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE" ); + + DECLARE + POSITION : INTEGER; + BEGIN + POSITION := 0; + + FOR E IN ENUM LOOP + IF SUBENUM'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBENUM'POS (" & + ENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBENUM'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBENUM'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + POSITION := 0; + FOR E IN NEWENUM LOOP + IF SUBNEW'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBNEW'POS (" & + NEWENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBNEW'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBNEW'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + + BEGIN + IF ENUM'VAL (0) /= A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 1" ); + END IF; + + IF ENUM'VAL (0) = C35502K.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 2" ); + END IF; + + IF ENUM'VAL (3) /= C35502K.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (3) WHEN HIDDEN " & + "BY FUNCTION - 3" ); + END IF; + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (-1)) = A THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (-1)) = A THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (5)) = A THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR ENUM'VAL (IDENT_INT (5))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (5)) = A THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5))" ); + END; + + RESULT; + END C35502K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C35502L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS + -- AN ENUMERATION TYPE OTHER THAN A BOOLEAN OR A CHARACTER TYPE. + + -- RJW 5/27/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35502L IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " & + "IS AN ENUMERATION TYPE OTHER THAN A " & + "CHARACTER OR A BOOLEAN TYPE" ); + + DECLARE + + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + POSITION : INTEGER; + BEGIN + + POSITION := 0; + + FOR E1 IN E + LOOP + IF SE'POS (E1) /= POSITION THEN + FAILED ( "INCORRECT SE'POS (" & + E'IMAGE (E1) & ")" ); + END IF; + + IF SE'VAL (POSITION) /= E1 THEN + FAILED ( "INCORRECT " & STR & "'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF E'VAL (-1) = E'VAL (1) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (-1)" ); + END; + + BEGIN + IF E'VAL (5) = E'VAL (4) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (5)" ); + END; + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + BEGIN + PE; + PN; + END; + + DECLARE + GENERIC + TYPE E IS (<>); + FUNCTION F (E1 : E) RETURN BOOLEAN; + + FUNCTION F (E1 : E) RETURN BOOLEAN IS + BEGIN + RETURN E'VAL (0) = E1; + END F; + + FUNCTION FE IS NEW F (ENUM); + + BEGIN + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + BEGIN + IF FE (A_B_C) THEN + NULL; + ELSE + FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " & + "BY A FUNCTION" ); + END IF; + + IF FE (C35502L.A_B_C) THEN + FAILED ( "INCORRECT VAL FOR C35502L.A_B_C" ); + END IF; + END; + END; + + RESULT; + END C35502L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502m.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,177 ---- + -- C35502M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A + -- CHARACTER TYPE, WITH AN ENUMERATION REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 05/27/86 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35502M IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 2, BC => 4, ABC => 6, + A_B_C => 8, ABCD => 10); + + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502M", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "ENUMERATION TYPE, OTHER THAN A CHARACTER " & + "OR A BOOLEAN TYPE, WITH AN ENUMERATION " & + "REPRESENTATION CLAUSE" ); + + DECLARE + POSITION : INTEGER; + BEGIN + POSITION := 0; + + FOR E IN ENUM + LOOP + IF SUBENUM'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBENUM'POS (" & + ENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBENUM'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBENUM'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + POSITION := 0; + FOR E IN NEWENUM + LOOP + IF SUBNEW'POS (E) /= POSITION THEN + FAILED ( "INCORRECT SUBNEW'POS (" & + NEWENUM'IMAGE (E) & ")" ); + END IF; + + IF SUBNEW'VAL (POSITION) /= E THEN + FAILED ( "INCORRECT SUBNEW'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN A; + END A_B_C; + + BEGIN + IF ENUM'VAL (0) /= A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 1" ); + END IF; + + IF ENUM'VAL (0) = C35502M.A_B_C THEN + FAILED ( "WRONG ENUM'VAL (0) WHEN HIDDEN " & + "BY FUNCTION - 2" ); + END IF; + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (-1)) = ENUM'FIRST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (-1)) = NEWENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (-1))" ); + END; + + BEGIN + IF ENUM'VAL (IDENT_INT (5)) = ENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "ENUM'VAL (IDENT_INT (5))" ); + END; + + BEGIN + IF NEWENUM'VAL (IDENT_INT (5)) = NEWENUM'LAST THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWENUM'VAL (IDENT_INT (5))" ); + END; + + RESULT; + END C35502M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502n.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C35502N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT IS + -- AN ENUMERATION TYPE, OTHER THAN A BOOLEAN OR A CHARACTER TYPE, + -- WITH AN ENUMERATION REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 05/27/86 + -- DWC 07/22/87 ADDED THE PARAMETER 'N' TO FUNCTION F. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35502N IS + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + FOR ENUM USE (A => 1, BC => 4, ABC => 5, A_B_C => 6, + ABCD => 8); + + SUBTYPE SUBENUM IS ENUM RANGE A .. BC; + + TYPE NEWENUM IS NEW ENUM; + SUBTYPE SUBNEW IS NEWENUM RANGE A .. BC; + + BEGIN + TEST ("C35502N", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT " & + "IS AN ENUMERATION TYPE, OTHER THAN A " & + "CHARACTER OR A BOOLEAN TYPE, WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + + GENERIC + TYPE E IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SE IS E RANGE E'VAL(0) .. E'VAL(1); + POSITION : INTEGER; + BEGIN + + POSITION := 0; + + FOR E1 IN E LOOP + IF SE'POS (E1) /= POSITION THEN + FAILED ( "INCORRECT " & STR & "'POS (" & + E'IMAGE (E1) & ")" ); + END IF; + + IF SE'VAL (POSITION) /= E1 THEN + FAILED ( "INCORRECT " & STR & "'VAL (" & + INTEGER'IMAGE (POSITION) & + ")" ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF E'VAL (-1) = E'VAL (1) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (-1)" ); + END; + + BEGIN + IF E'VAL (5) = E'VAL (4) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'VAL (5) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'VAL (5)" ); + END; + END P; + + PROCEDURE PE IS NEW P ( ENUM, "ENUM" ); + PROCEDURE PN IS NEW P ( NEWENUM, "NEWENUM" ); + BEGIN + PE; + PN; + END; + + DECLARE + FUNCTION A_B_C RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (0)); + END A_B_C; + + GENERIC + TYPE E IS (<>); + FUNCTION F (N : INTEGER; + E1 : E) RETURN BOOLEAN; + + FUNCTION F (N : INTEGER; + E1 : E) RETURN BOOLEAN IS + BEGIN + RETURN E'VAL (N) = E1; + END F; + + FUNCTION FE IS NEW F (ENUM); + + BEGIN + + IF NOT FE (0, A_B_C) THEN + FAILED ( "INCORRECT VAL FOR A_B_C WHEN HIDDEN " & + "BY A FUNCTION" ); + END IF; + + IF NOT FE (3, C35502N.A_B_C) THEN + FAILED ( "INCORRECT VAL FOR C35502N.A_B_C" ); + END IF; + END; + + RESULT; + END C35502N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502o.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- C35502O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'FIRST AND 'LAST GIVE CORRECT RESULTS FOR TYPES + -- AND SUBTYPES. + + -- DAT 3/17/81 + -- R. WILLIAMS 11/11/86 RENAMED FROM C35104A.ADA. + + WITH REPORT; USE REPORT; + PROCEDURE C35502O IS + + TYPE E IS (E1, E2, E3, E4, E5); + + SUBTYPE S IS E RANGE E2 .. E4; + + BEGIN + TEST ("C35502O", "CHECK THAT 'FIRST AND 'LAST WORK FOR" + & " ENUMERATION TYPES AND SUBTYPES"); + + IF E'FIRST /= E1 OR E'LAST /= E5 + OR E'BASE'FIRST /= E1 OR E'BASE'LAST /= E5 + OR S'BASE'FIRST /= E1 OR S'BASE'LAST /= E5 + OR S'FIRST /= E2 OR S'LAST /= E4 + OR BOOLEAN'FIRST /= FALSE OR BOOLEAN'LAST /= TRUE + THEN + FAILED ("'FIRST OR 'LAST GIVES WRONG RESULTS"); + END IF; + + RESULT; + END C35502O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35502p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35502p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C35502P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR AN ENUMERATION TYPE OTHER THAN BOOLEAN OR CHARACTER TYPE, + -- CHECK THAT THE RESULTS AND TYPE PRODUCED BY THE ATTRIBUTES + -- ARE CORRECT. + + -- CHECK THAT 'FIRST AND 'LAST YIELD CORRECT RESULTS WHEN THE + -- PREFIX DENOTES A NULL SUBTYPE. + + -- HISTORY: + -- RJW 05/05/86 CREATED ORIGINAL TEST. + -- CJJ 06/09/87 CHANGED "=" COMPARISONS IN GENERIC + -- PROCEDURE Q TO "/=". + + + WITH REPORT; USE REPORT; + + PROCEDURE C35502P IS + + BEGIN + + TEST( "C35502P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN ENUMERATION " & + "TYPE OTHER THAN A CHARACTER OR A BOOLEAN " & + "TYPE" ); + + DECLARE + -- FOR THESE DECLARATIONS, 'FIRST AND 'LAST REFER TO THE + -- SUBTYPE VALUES, BUT 'VAL AND 'POS ARE INHERITED FROM THE + -- BASE TYPE. + + TYPE ENUM IS (A, BC, ABC, A_B_C, ABCD); + SUBTYPE SUBENUM IS ENUM RANGE A .. ABC; + + TYPE NEWENUM IS NEW ENUM RANGE BC .. A_B_C; + TYPE NONEWENUM IS NEW ENUM RANGE ABCD .. A; + GENERIC + TYPE E IS (<>); + F, L : E; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'FIRST /= F THEN + FAILED ( "INCORRECT E'FIRST FOR " & STR ); + END IF; + IF NOENUM'FIRST /= E'VAL (2) THEN + FAILED ( "INCORRECT NOENUM'FIRST FOR " & STR ); + END IF; + + IF E'LAST /= L THEN + FAILED ( "INCORRECT E'LAST FOR " & STR ); + END IF; + IF NOENUM'LAST /= E'VAL (1) THEN + FAILED ( "INCORRECT NOENUM'LAST FOR " & STR ); + END IF; + END P; + + GENERIC + TYPE E IS (<>); + PROCEDURE Q; + + PROCEDURE Q IS + SUBTYPE NOENUM IS E RANGE + E'VAL (IDENT_INT(2)) .. E'VAL (IDENT_INT(1)); + BEGIN + IF E'FIRST /= E'VAL (IDENT_INT(4)) THEN + FAILED ( "INCORRECT E'FIRST FOR NONEWENUM" ); + END IF; + IF NOENUM'FIRST /= E'VAL (2) THEN + FAILED ( "INCORRECT NOENUM'FIRST FOR NONEWENUM"); + END IF; + + IF E'LAST /= E'VAL (IDENT_INT(0)) THEN + FAILED ( "INCORRECT E'LAST FOR NONEWENUM"); + END IF; + IF NOENUM'LAST /= E'VAL (1) THEN + FAILED ( "INCORRECT NOENUM'LAST FOR NONEWENUM"); + END IF; + END Q; + + PROCEDURE PROC1 IS NEW P (ENUM, A, ABCD); + PROCEDURE PROC2 IS NEW P (SUBENUM, A, ABC); + PROCEDURE PROC3 IS NEW P (NEWENUM, BC, A_B_C); + PROCEDURE PROC4 IS NEW Q (NONEWENUM); + + BEGIN + PROC1 ( "ENUM" ); + PROC2 ( "SUBENUM" ); + PROC3 ( "NEWENUM" ); + PROC4; + END; + + RESULT; + END C35502P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C35503A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS AN + -- INTEGER TYPE. + + -- RJW 3/12/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35503A IS + + BEGIN + TEST ("C35503A", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " & + "RESULT WHEN THE PREFIX IS AN INTEGER TYPE" ); + + DECLARE + SUBTYPE SINTEGER IS INTEGER; + + TYPE INT IS RANGE -1000 .. 1000; + TYPE INT2 IS NEW INT RANGE 1E2 .. 1E2; + + SUBTYPE SINT1 IS INT RANGE 00000 .. 100; + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + SUBTYPE SINT3 IS INT RANGE -100 .. 9; + SUBTYPE NOINT IS INT RANGE 1 .. -1; + + BEGIN + IF IDENT_INT(SINTEGER'WIDTH) /= INTEGER'WIDTH THEN + FAILED ( "WRONG WIDTH FOR 'SINTEGER'" ); + END IF; + + IF IDENT_INT(INT'WIDTH) /= 5 THEN + FAILED ( "WRONG WIDTH FOR 'INT'" ); + END IF; + + IF IDENT_INT(INT2'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'INT2'"); + END IF; + + IF IDENT_INT(SINT1'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT1'" ); + END IF; + + IF IDENT_INT(SINT2'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT2'" ); + END IF; + + IF IDENT_INT(SINT3'WIDTH) /= 4 THEN + FAILED ( "WRONG WIDTH FOR 'SINT3'" ); + END IF; + + IF IDENT_INT(NOINT'WIDTH) /= 0 THEN + FAILED ( "WRONG WIDTH FOR 'NOINT'" ); + END IF; + END; + + RESULT; + END C35503A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C35503B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'WIDTH' YIELDS THE CORRECT RESULT WHEN THE PREFIX IS A + -- GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN INTEGER + -- TYPE. + + -- RJW 3/17/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35503B IS + + BEGIN + TEST ("C35503B", "CHECK THAT 'WIDTH' YIELDS THE CORRECT " & + "RESULT WHEN THE PREFIX IS A GENERIC FORMAL " & + "DISCRETE TYPE WHOSE ACTUAL PARAMETER IS AN " & + "INTEGER TYPE" ); + + DECLARE + + TYPE INT IS RANGE -1000 .. 1000; + TYPE INT2 IS NEW INT RANGE 0E8 .. 1E3; + SUBTYPE SINT1 IS INT RANGE 00000 .. 300; + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + + GENERIC + TYPE I IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SUBI IS I + RANGE I'VAL (IDENT_INT(224)) .. I'VAL (255); + SUBTYPE NORANGE IS I + RANGE I'VAL (255) .. I'VAL (IDENT_INT(224)); + BEGIN + IF IDENT_INT(I'WIDTH) /= W THEN + FAILED ( "INCORRECT I'WIDTH FOR " & STR ); + END IF; + + IF IDENT_INT(SUBI'WIDTH) /= 4 THEN + FAILED ( "INCORRECT SUBI'WIDTH FOR " & STR ); + END IF; + + IF IDENT_INT(NORANGE'WIDTH) /= 0 THEN + FAILED ( "INCORRECT NORANGE'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE P_INTEGER IS NEW P (INTEGER, INTEGER'WIDTH); + PROCEDURE P_INT IS NEW P (INT, 5); + PROCEDURE P_INT2 IS NEW P (INT2, 5); + PROCEDURE P_SINT1 IS NEW P (SINT1, 4); + PROCEDURE P_SINT2 IS NEW P (SINT2, 4); + + BEGIN + P_INTEGER ("'INTEGER'"); + P_INT ("'INT'"); + P_INT2 ("'INT2'"); + P_SINT1 ("'SINT1'"); + P_SINT2 ("'SINT2'"); + END; + + RESULT; + END C35503B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,543 ---- + -- C35503C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS AN INTEGER TYPE. + -- SUBTESTS ARE : + -- PART (A). TESTS FOR 'IMAGE'. + -- PART (B). TESTS FOR 'VALUE'. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- VCL 10/23/87 MODIFIED THIS HEADER, ADDED A CHECK THAT + -- CONSTRAINT_ERROR IS RAISED FOR THE ATTRIBUTE + -- 'VALUE' IF THE FINAL SHARP OR COLON IS MISSING + -- FROM A BASED LITERAL. + + WITH REPORT; USE REPORT; + PROCEDURE C35503C IS + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -1000 .. 1000; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + IF EQUAL (INT'POS (X), INT'POS(X)) THEN + RETURN X; + END IF; + RETURN INT'FIRST; + END IDENT; + + BEGIN + TEST ("C35503C", "THE ATTIBUTES 'IMAGE' AND 'VALUE' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + -- PART (A). + + BEGIN + IF INTEGER'IMAGE (-500) /= "-500" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-500'" ); + END IF; + IF INTEGER'IMAGE (-500)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-500'" ); + END IF; + + IF NEWINT'IMAGE (2 ** 6) /= " 64" THEN + FAILED ( "INCORRECT 'IMAGE' OF '2 ** 6'" ); + END IF; + IF NEWINT'IMAGE (2 ** 6)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '2 ** 6'" ); + END IF; + + IF NATURAL'IMAGE (-1E2) /= "-100" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1E2'" ); + END IF; + IF NATURAL'IMAGE (-1E2)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1E2'" ); + END IF; + + IF NEWINT'IMAGE (3_45) /= " 345" THEN + FAILED ( "INCORRECT 'IMAGE' OF '3_45'" ); + END IF; + IF NEWINT'IMAGE (3_45)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '3_45'" ); + END IF; + + IF INTEGER'IMAGE (-2#1111_1111#) /= "-255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-2#1111_1111#'" ); + END IF; + IF INTEGER'IMAGE (-2#1111_1111#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-2#1111_1111#'" ); + END IF; + + IF NEWINT'IMAGE (16#FF#) /= " 255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '16#FF#'" ); + END IF; + IF NEWINT'IMAGE (16#FF#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '16#FF#'" ); + END IF; + + IF INTEGER'IMAGE (-016#0FF#) /= "-255" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-016#0FF#'" ); + END IF; + IF INTEGER'IMAGE (-016#0FF#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-016#0FF#'" ); + END IF; + + IF NEWINT'IMAGE (2#1110_0000#) /= " 224" THEN + FAILED ( "INCORRECT 'IMAGE' OF '2#1110_0000#'" ); + END IF; + IF NEWINT'IMAGE (2#1110_0000#)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '2#1110_0000#'" ); + END IF; + + IF POSITIVE'IMAGE (-16#E#E1) /= "-224" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-16#E#E1'" ); + END IF; + IF POSITIVE'IMAGE (-16#E#E1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-16#E#E1'" ); + END IF; + + IF INT'IMAGE (IDENT(-1000)) /= "-1000" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1000'" ); + END IF; + IF INT'IMAGE (IDENT(-1000))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1000'" ); + END IF; + + IF INT'IMAGE (IDENT(-999)) /= "-999" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-999'" ); + END IF; + IF INT'IMAGE (IDENT(-999))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-999'" ); + END IF; + + IF INT'IMAGE (IDENT(-10)) /= "-10" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1000'" ); + END IF; + IF INT'IMAGE (IDENT(-10))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-10'" ); + END IF; + + IF INT'IMAGE (IDENT(-9)) /= "-9" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-9'" ); + END IF; + IF INT'IMAGE (IDENT(-9))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-9'" ); + END IF; + + IF INT'IMAGE (IDENT(-1)) /= "-1" THEN + FAILED ( "INCORRECT 'IMAGE' OF '-1'" ); + END IF; + IF INT'IMAGE (IDENT(-1))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '-1'" ); + END IF; + + IF INT'IMAGE (IDENT(0)) /= " 0" THEN + FAILED ( "INCORRECT 'IMAGE' OF '0'" ); + END IF; + IF INT'IMAGE (IDENT(0))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '0'" ); + END IF; + + IF INT'IMAGE (IDENT(1)) /= " 1" THEN + FAILED ( "INCORRECT 'IMAGE' OF '1'" ); + END IF; + IF INT'IMAGE (IDENT(1))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '1'" ); + END IF; + + IF INT'IMAGE (IDENT(9)) /= " 9" THEN + FAILED ( "INCORRECT 'IMAGE' OF '9'" ); + END IF; + IF INT'IMAGE (IDENT(9))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '9'" ); + END IF; + + IF INT'IMAGE (IDENT(10)) /= " 10" THEN + FAILED ( "INCORRECT 'IMAGE' OF '10'" ); + END IF; + IF INT'IMAGE (IDENT(10))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '10'" ); + END IF; + + IF INT'IMAGE (IDENT(999)) /= " 999" THEN + FAILED ( "INCORRECT 'IMAGE' OF '999'" ); + END IF; + IF INT'IMAGE (IDENT(999))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '999'" ); + END IF; + + IF INT'IMAGE (IDENT(1000)) /= " 1000" THEN + FAILED ( "INCORRECT 'IMAGE' OF '1000'" ); + END IF; + IF INT'IMAGE (IDENT(1000))'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR '1000'" ); + END IF; + + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + BEGIN + IF POSITIVE'VALUE (IDENT_STR("-500")) /= -500 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-500""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""-500""" ); + END; + + BEGIN + IF NEWINT'VALUE (" -001E2") /= -100 THEN + FAILED ( "INCORRECT 'VALUE' OF "" -001E2""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF "" -001E2""" ); + END; + + BEGIN + IF INTEGER'VALUE ("03_45") /= 345 THEN + FAILED ( "INCORRECT 'VALUE' OF ""03_45""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""03_45""" ); + END; + + BEGIN + IF NEWINT'VALUE ("-2#1111_1111#") /= -255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-2#1111_1111#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF "& + """-2#1111_1111#""" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16#FF#")) /= 255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""16#FF#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF ""16#FF#""" ); + END; + + BEGIN + IF NATURAL'VALUE (IDENT_STR("-016#0FF#")) /= -255 THEN + FAILED ( "INCORRECT 'VALUE' OF ""-016#0FF#""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """-016#0FF#""" ); + END; + + BEGIN + IF INTEGER'VALUE ("2#1110_0000# ") /= 224 THEN + FAILED ( "INCORRECT 'VALUE' OF " & + """2#1110_0000# """ ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """2#1110_0000# """ ); + END; + + BEGIN + IF NEWINT'VALUE (" -16#E#E1") /= -224 THEN + FAILED ( "INCORRECT 'VALUE' OF "" -16#E#E1""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - 'VALUE' OF " & + """ -16#E#E1""" ); + END; + + BEGIN + IF INTEGER'VALUE ("5/0") = 0 THEN + FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""5/0"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""5/0""" ); + END; + + DECLARE + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 10; + BEGIN + IF SUBINT'VALUE (IDENT_STR("-500")) /= -500 THEN + FAILED ( "INCORRECT VALUE WITH ""-500"" AND SUBINT" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - SUBINT" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1.0")) = 1 THEN + FAILED ( "NO EXCEPTION RAISED - "" 1.0"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""1.0"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""1.0"" " ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_CHAR(ASCII.HT) & "244") /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF INTEGER'VALUE ("244" & (IDENT_CHAR(ASCII.HT))) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("2__44")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - CONSECUTIVE '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH CONSECUTIVE '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("_244")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING '_' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING '_'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_E1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'E' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'E'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244E_1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' " & + "FOLLOWING 'E' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' FOLLOWING 'E' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- '_' FOLLOWING 'E'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244_e1")) /= 2440 THEN + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - '_' BEFORE 'e' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - '_' BEFORE 'e'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16#_FF#")) /= 255 THEN + FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " & + "LITERAL - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING '_' IN BASED " & + "LITERAL - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- LEADING '_' IN BASED LITERAL" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1E-0")) /= 1 THEN + FAILED ( "NO EXCEPTION RAISED - NEGATIVE " & + "EXPONENT - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - NEGATIVE EXPONENT - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- NEGATIVE EXPONENT" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("244.")) /= 244 THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING '.' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING '.'" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("8#811#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "DIGITS NOT IN CORRECT RANGE" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("1#000#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - BASE LESS THAN 2 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- BASE LESS THAN 2" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("17#0#")) /= 0 THEN + FAILED ( "NO EXCEPTION RAISED " & + "- BASE GREATER THAN 16 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "- BASE GREATER THAN 16 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "- BASE GREATER THAN 16" ); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("8#666")) /= 438 THEN + FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 1"); + ELSE + FAILED ("NO EXCEPTION RAISED - MISSING FINAL SHARP - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL SHARP"); + END; + + BEGIN + IF INTEGER'VALUE (IDENT_STR("16:FF")) /= 255 THEN + FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 1"); + ELSE + FAILED ("NO EXCEPTION RAISED - MISSING FINAL COLON - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MISSING FINAL COLON"); + END; + + RESULT; + END C35503C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503d.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503d.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503d.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503d.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C35503D.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE + -- LARGEST/SMALLEST INTEGER LITERAL FOR THE LONGEST INTEGER TYPE. + + -- HISTORY: + -- RJW 02/26/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C35503D IS + + TYPE INT IS RANGE MIN_INT .. MAX_INT; + + FUNCTION IDENT (X:INT) RETURN INT IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT; + + BEGIN + TEST ("C35503D", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LARGEST/SMALLEST "& + "INTEGER LITERAL FOR THE LARGEST INTEGER TYPE"); + + -- MIN_INT IS THE DECIMAL LITERAL FOR SYSTEM.MIN_INT. + -- MAX_INT IS THE DECIMAL LITERAL FOR SYSTEM.MAX_INT. + + BEGIN + IF INT'VALUE (IDENT_STR("$MIN_INT")) /= MIN_INT THEN + FAILED("INCORRECT RESULTS FOR 'VALUE' - MIN_INT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MIN_INT"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MIN_INT"); + END; + + BEGIN + IF INT'IMAGE (IDENT(MIN_INT)) /= "$MIN_INT" THEN + FAILED("INCORRECT RESULTS FOR 'IMAGE' - MIN_INT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR 'IMAGE' - MIN_INT"); + END; + + BEGIN + IF INT'VALUE (IDENT_STR("$MAX_INT")) /= MAX_INT THEN + FAILED("INCORRECT RESULTS FOR 'VALUE' - MAX_INT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED FOR 'VALUE' - MAX_INT"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED FOR 'VALUE' - MAX_INT"); + END; + + BEGIN + IF INT'IMAGE (IDENT(MAX_INT)) /= ' ' & "$MAX_INT" THEN + FAILED("INCORRECT RESULTS FOR 'IMAGE' - MAXINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR 'IMAGE' - MAXINT"); + END; + + RESULT; + END C35503D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C35503E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULTS WHEN + -- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS AN INTEGER TYPE. + -- SUBTESTS ARE : + -- PART (A). TESTS FOR 'IMAGE'. + -- PART (B). TESTS FOR 'VALUE'. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503E IS + + BEGIN + TEST ("C35503E", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS AN INTEGER TYPE" ); + -- PART (A). + + DECLARE + TYPE NEWINT IS NEW INTEGER RANGE -2000 .. 2000; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (I1 : INT; STR : STRING ); + + PROCEDURE P (I1 : INT; STR : STRING) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(-1000)) .. + INT'VAL (IDENT_INT(1000)); + BEGIN + + IF INT'IMAGE (I1) /= STR THEN + FAILED ( "INCORRECT INT'IMAGE OF " & STR ); + END IF; + IF INT'IMAGE (I1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR INT'IMAGE OF " & + STR ); + END IF; + + IF SUBINT'IMAGE (I1) /= STR THEN + FAILED ( "INCORRECT SUBINT'IMAGE OF " & STR ); + END IF; + IF SUBINT'IMAGE (I1)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR SUBINT'IMAGE " & + "OF " & STR ); + END IF; + + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 (-500, "-500"); + PROC2 (0, " 0"); + PROC2 (99," 99"); + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + DECLARE + TYPE NEWINT IS NEW INTEGER; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING; I1 : INT ); + + PROCEDURE P (STR : STRING; I1 : INT) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(0)) .. + INT'VAL (IDENT_INT(10)); + + BEGIN + BEGIN + IF INT'VALUE (STR) /= I1 THEN + FAILED ( "INCORRECT INT'VALUE OF """ & + STR & """"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INT'VALUE OF """ & + STR & """"); + END; + BEGIN + IF SUBINT'VALUE (STR) /= I1 THEN + FAILED ( "INCORRECT SUBINT'VALUE OF """ & + STR & """"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED SUBINT'VALUE " & + "OF """ & STR & """"); + END; + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 ("-500" , -500); + PROC2 (" -001E2 " , -100); + PROC1 ("3_45" , 345); + PROC2 ("-2#1111_1111#" , -255); + PROC1 ("16#FF#" , 255); + PROC2 ("-016#0FF#" , -255); + PROC1 ("2#1110_0000# " , 224); + PROC2 ("-16#E#E1" , -224); + + END; + + DECLARE + TYPE NEWINT IS NEW INTEGER; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING); + + PROCEDURE P (STR1 : STRING; I1 : INT; STR2 : STRING) IS + SUBTYPE SUBINT IS INT + RANGE INT'VAL (IDENT_INT(0)) .. + INT'VAL (IDENT_INT(10)); + + BEGIN + BEGIN + IF INT'VALUE (STR1) = I1 THEN + FAILED ( "NO EXCEPTION RAISED - INT'VALUE " & + "WITH " & STR2 & " - EQUAL"); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "- INT'VALUE WITH " & + STR2 & " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "INT'VALUE WITH " & STR2 ); + END; + BEGIN + IF SUBINT'VALUE (STR1) = I1 THEN + FAILED ( "NO EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & STR2 + & " - EQUAL" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & + STR2 & " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "SUBINT'VALUE WITH " & STR2 ); + END; + END P; + + PROCEDURE PROC1 IS NEW P (INTEGER); + PROCEDURE PROC2 IS NEW P (NEWINT); + + BEGIN + PROC1 ("1.0" , 1, "DECIMAL POINT"); + PROC1 (ASCII.HT & "244", 244, "LEADING 'HT'" ); + PROC2 ("244" & ASCII.HT, 244, "TRAILING 'HT'" ); + PROC1 ("2__44" , 244, "CONSECUTIVE '_'" ); + PROC2 ("_244" , 244, "LEADING '_'" ); + PROC1 ("244_" , 244, "TRAILING '_'" ); + PROC2 ("244_E1" , 2440, "'_' BEFORE 'E'" ); + PROC1 ("244E_1" , 2440, "'_' FOLLOWING 'E'" ); + PROC2 ("244_e1" , 2440, "'_' BEFORE 'e'" ); + PROC1 ("16#_FF#" , 255, "'_' IN BASED LITERAL" ); + PROC2 ("1E-0" , 0, "NEGATIVE EXPONENT" ); + PROC1 ("244." , 244, "TRAILING '.'" ); + PROC2 ("8#811#" , 0, "DIGITS OUTSIDE OF RANGE" ); + PROC1 ("1#000#" , 0, "BASE LESS THAN 2" ); + PROC2 ("17#0#" , 0, "BASE GREATER THAN 16" ); + END; + + RESULT; + END C35503E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503f.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503f.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503f.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503f.tst 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C35503F.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'IMAGE' AND 'VALUE' YIELD THE CORRECT RESULT FOR THE + -- LARGEST/SMALLEST INTEGER LITERAL AND A FORMAL DISCRETE TYPE WHOSE + -- ACTUAL PARAMETER IS AN INTEGER TYPE. + + -- HISTORY + -- RJW 05/12/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C35503F IS + + TYPE LONGEST_INT IS RANGE MIN_INT .. MAX_INT; + + BEGIN + TEST ("C35503F", "CHECK THAT 'IMAGE' AND 'VALUE' YIELD " & + "CORRECT RESULTS FOR THE LARGEST/SMALLEST "& + "INTEGER LITERAL AND A FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL PARAMETER IS AN INTEGER TYPE"); + + -- INTEGER_FIRST IS THE DECIMAL LITERAL IMAGE OF INTEGER'FIRST. + -- INTEGER_LAST IS THE DECIMAL LITERAL IMAGE OF INTEGER'LAST. + -- MIN_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MIN_INT. + -- MAX_INT IS THE DECIMAL LITERAL IMAGE OF SYSTEM.MAX_INT. + + DECLARE + GENERIC + TYPE INT IS (<>); + PROCEDURE P ( FS, LS : STRING; FI, LI : INT ); + + PROCEDURE P ( FS, LS : STRING; FI, LI : INT ) IS + BEGIN + BEGIN + IF INT'VALUE (FS) /= FI THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " & + FS ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + "'VALUE' OF " & FS ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + "'VALUE' OF " & FS ); + END; + + BEGIN + IF INT'VALUE (LS) /= LI THEN + FAILED ( "INCORRECT RESULTS FOR 'VALUE' OF " & + LS ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + "'VALUE' OF " & LS ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + "'VALUE' OF " & LS ); + END; + END P; + + GENERIC + TYPE INT IS (<>); + PROCEDURE Q ( FS, LS : STRING; FI, LI : INT ); + + PROCEDURE Q ( FS, LS : STRING; FI, LI : INT ) IS + BEGIN + BEGIN + IF INT'IMAGE(FI) /= FS THEN + FAILED ( "INCORRECT RESULTS FOR " & + "'IMAGE' WITH " & FS ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " & + "WITH " & FS ); + END; + + BEGIN + IF INT'IMAGE(LI) /= LS THEN + FAILED ( "INCORRECT RESULTS FOR " & + "'IMAGE' WITH " & LS ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR 'IMAGE' " & + "WITH " & LS ); + END; + END Q; + + PROCEDURE P1 IS NEW P ( INTEGER ); + PROCEDURE Q1 IS NEW Q ( INTEGER ); + PROCEDURE P2 IS NEW P ( LONGEST_INT ); + PROCEDURE Q2 IS NEW Q ( LONGEST_INT ); + BEGIN + P1 ("$INTEGER_FIRST", "$INTEGER_LAST", INTEGER'FIRST, + INTEGER'LAST); + P2 ("$MIN_INT", "$MAX_INT", MIN_INT, MAX_INT); + Q1 ("$INTEGER_FIRST"," $INTEGER_LAST", INTEGER'FIRST, + INTEGER'LAST); + Q2 ("$MIN_INT", " $MAX_INT", MIN_INT, MAX_INT); + + END; + + RESULT; + END C35503F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C35503G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE + -- PREFIX IS AN INTEGER TYPE. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503G IS + + BEGIN + TEST ("C35503G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULT WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE -4 .. 4; + + BEGIN + + FOR I IN INT'FIRST + 1 .. INT'LAST LOOP + BEGIN + IF SINT'PRED (I) /= I - 1 THEN + FAILED ( "WRONG SINT'PRED FOR " & + INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINT'PRED OF " & + INT'IMAGE (I)); + END; + END LOOP; + + FOR I IN INT'FIRST .. INT'LAST - 1 LOOP + BEGIN + IF SINT'SUCC (I) /= I + 1 THEN + FAILED ( "WRONG SINT'SUCC FOR " & + INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINT'SUCC OF " & + INT'IMAGE (I)); + END; + END LOOP; + + END; + + DECLARE + SUBTYPE INTRANGE IS INTEGER RANGE IDENT_INT(-6) .. + IDENT_INT(6); + SUBTYPE SINTEGER IS INTEGER RANGE IDENT_INT(-4) .. + IDENT_INT(4); + + BEGIN + FOR I IN INTRANGE LOOP + BEGIN + IF SINTEGER'PRED (I) /= I - IDENT_INT(1) THEN + FAILED ( "WRONG SINTEGER'PRED FOR " & + INTEGER'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINTEGER'PRED OF " & + INTEGER'IMAGE (I)); + END; + BEGIN + IF SINTEGER'SUCC (I) /= I + IDENT_INT(1) THEN + FAILED ( "WRONG SINTEGER'SUCC FOR " & + INTEGER'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + "SINTEGER'SUCC OF " & + INTEGER'IMAGE (I)); + END; + END LOOP; + + END; + + RESULT; + END C35503G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503h.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C35503H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULT WHEN THE + -- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER + -- IS AN INTEGER TYPE. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503H IS + + BEGIN + TEST ("C35503H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULT WHEN THE PREFIX IS A GENERIC " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS AN INTEGER TYPE" ); + + DECLARE + TYPE INTRANGE IS RANGE -6 .. 6; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SINT IS INT + RANGE INT'VAL (IDENT_INT(-4)) .. + INT'VAL (IDENT_INT(4)); + BEGIN + FOR I IN INT'VAL (IDENT_INT(-6)) .. + INT'VAL (IDENT_INT(6)) + LOOP + BEGIN + IF SINT'PRED (I) /= + SINT'VAL (SINT'POS (I) - 1) THEN + FAILED ( "WRONG " & STR & "'PRED " & + "FOR " & INT'IMAGE (I) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'PRED OF " & + INT'IMAGE (I)); + END; + BEGIN + IF SINT'SUCC (I) /= + SINT'VAL (SINT'POS (I) + 1) THEN + FAILED ( "WRONG " & STR & "'SUCC " & + "FOR " & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'SUCC OF " & + INT'IMAGE (I)); + END; + END LOOP; + END P; + + PROCEDURE PROC1 IS NEW P (INTRANGE); + PROCEDURE PROC2 IS NEW P (INTEGER); + BEGIN + PROC1 ("INTRANGE"); + PROC2 ("INTEGER"); + END; + + RESULT; + END C35503H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503k.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C35503K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS AN INTEGER TYPE. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- PWN 11/30/94 REMOVED ATTRIBUTE TESTS ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C35503K IS + + BEGIN + TEST ("C35503K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE -4 .. 4; + + PROCEDURE P (I : INTEGER; STR : STRING) IS + BEGIN + BEGIN + IF INTEGER'POS (I) /= I THEN + FAILED ( "WRONG POS FOR " & STR); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR POS OF " & + STR); + END; + BEGIN + IF INTEGER'VAL (I) /= I THEN + FAILED ( "WRONG VAL FOR " & STR); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + STR); + END; + END P; + + BEGIN + P ( INTEGER'FIRST, "INTEGER'FIRST"); + P ( INTEGER'LAST, "INTEGER'LAST"); + P ( 0, "'0'"); + + FOR I IN INT'FIRST .. INT'LAST LOOP + BEGIN + IF SINT'POS (I) /= I THEN + FAILED ( "WRONG POS FOR " + & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR POS OF " + & INT'IMAGE (I)); + END; + BEGIN + IF SINT'VAL (I) /= I THEN + FAILED ( "WRONG VAL FOR " + & INT'IMAGE (I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " + & INT'IMAGE (I)); + END; + END LOOP; + + BEGIN + IF INT'VAL (INTEGER'(0)) /= 0 THEN + FAILED ( "WRONG VAL FOR INT WITH INTEGER" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + "INT WITH INTEGER" ); + END; + + BEGIN + IF INTEGER'VAL (INT'(0)) /= 0 THEN + FAILED ( "WRONG VAL FOR INTEGER WITH INT" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR VAL OF " & + "INTEGER WITH INT" ); + END; + END; + + RESULT; + END C35503K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C35503L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER + -- IS AN INTEGER TYPE. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503L IS + + BEGIN + TEST ("C35503L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS AN INTEGER TYPE" ); + + DECLARE + TYPE INTRANGE IS RANGE -6 .. 6; + + GENERIC + TYPE INT IS (<>); + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SINT IS INT RANGE + INT'VAL (IDENT_INT(-4)) .. INT'VAL (IDENT_INT(4)); + I :INTEGER; + BEGIN + I := IDENT_INT(-6); + FOR S IN INT'VAL (IDENT_INT(-6)) .. + INT'VAL (IDENT_INT(6)) + LOOP + BEGIN + IF SINT'POS (S) /= I THEN + FAILED ( "WRONG VALUE FOR " & + STR & "'POS OF " + & INT'IMAGE (S) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'POS " + & "OF " & INT'IMAGE (S) ); + END; + BEGIN + IF SINT'VAL (I) /= S THEN + FAILED ( "WRONG VALUE FOR " & + STR & "'VAL " + & "OF " & INT'IMAGE (S) ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR " & + STR & "'VAL " + & "OF " & INT'IMAGE (S) ); + END; + I := I + 1; + END LOOP; + END P; + + PROCEDURE P1 IS NEW P (INTRANGE); + PROCEDURE P2 IS NEW P (INTEGER); + + BEGIN + P1 ("INTRANGE"); + P2 ("INTEGER"); + END; + + RESULT; + + END C35503L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503o.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C35503O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS AN INTEGER TYPE. + + -- HISTORY: + -- RJW 03/17/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503O IS + + BEGIN + TEST ("C35503O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS AN " & + "INTEGER TYPE" ); + + DECLARE + SUBTYPE SINTEGER IS INTEGER; + SUBTYPE SMALL IS INTEGER RANGE IDENT_INT(-10) .. + IDENT_INT(10); + SUBTYPE NOINTEGER IS INTEGER + RANGE IDENT_INT(5) .. IDENT_INT(-7); + + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT + RANGE INT(IDENT_INT(-4)) .. INT(IDENT_INT(4)); + SUBTYPE NOINT IS INT + RANGE INT(IDENT_INT(1)) .. INT(IDENT_INT(-1)); + TYPE NEWINT IS NEW INTEGER RANGE IDENT_INT(-9) .. + IDENT_INT(-2); + SUBTYPE SNEWINT IS NEWINT RANGE -7 .. -5; + SUBTYPE NONEWINT IS NEWINT RANGE 3 .. -15; + + BEGIN + IF SINTEGER'FIRST /= INTEGER'FIRST THEN + FAILED ( "WRONG VALUE FOR SINTEGER'FIRST" ); + END IF; + IF SINTEGER'LAST /= INTEGER'LAST THEN + FAILED ( "WRONG VALUE FOR SINTEGER'LAST" ); + END IF; + + IF SMALL'FIRST /= -10 THEN + FAILED ( "WRONG VALUE FOR SMALL'FIRST" ); + END IF; + IF SMALL'LAST /= 10 THEN + FAILED ( "WRONG VALUE FOR SMALL'LAST" ); + END IF; + + IF NOINTEGER'FIRST /= 5 THEN + FAILED ( "WRONG VALUE FOR NOINTEGER'FIRST" ); + END IF; + IF NOINTEGER'LAST /= -7 THEN + FAILED ( "WRONG VALUE FOR NOINTEGER'LAST" ); + END IF; + + IF INT'FIRST /= -6 THEN + FAILED ( "WRONG VALUE FOR INT'FIRST" ); + END IF; + IF INT'LAST /= 6 THEN + FAILED ( "WRONG VALUE FOR INT'LAST" ); + END IF; + + IF SINT'FIRST /= -4 THEN + FAILED ( "WRONG VALUE FOR SINT'FIRST" ); + END IF; + IF SINT'LAST /= 4 THEN + FAILED ( "WRONG VALUE FOR SINT'LAST" ); + END IF; + + IF NOINT'FIRST /= 1 THEN + FAILED ( "WRONG VALUE FOR NOINT'FIRST" ); + END IF; + IF NOINT'LAST /= -1 THEN + FAILED ( "WRONG VALUE FOR NOINT'LAST" ); + END IF; + + IF NEWINT'FIRST /= -9 THEN + FAILED ( "WRONG VALUE FOR NEWINT'FIRST" ); + END IF; + IF NEWINT'LAST /= -2 THEN + FAILED ( "WRONG VALUE FOR NEWINT'LAST" ); + END IF; + + IF SNEWINT'FIRST /= -7 THEN + FAILED ( "WRONG VALUE FOR SNEWINT'FIRST" ); + END IF; + IF SNEWINT'LAST /= -5 THEN + FAILED ( "WRONG VALUE FOR SNEWINT'LAST" ); + END IF; + + IF NONEWINT'FIRST /= 3 THEN + FAILED ( "WRONG VALUE FOR NONEWINT'FIRST" ); + END IF; + IF NONEWINT'LAST /= -15 THEN + FAILED ( "WRONG VALUE FOR NONEWINT'LAST" ); + END IF; + END; + + RESULT; + END C35503O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35503p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35503p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C35503P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT IS AN + -- INTEGER TYPE. + + -- HISTORY: + -- RJW 03/24/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35503P IS + + BEGIN + TEST ("C35503P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ARGUMENT " & + "IS AN INTEGER TYPE" ); + + + DECLARE + + TYPE INT IS RANGE -6 .. 6; + SUBTYPE SINT IS INT RANGE INT(IDENT_INT(-4)) .. + INT(IDENT_INT(4)); + SUBTYPE NOINT IS INT RANGE INT(IDENT_INT(1)) .. + INT(IDENT_INT(-1)); + + GENERIC + TYPE I IS (<>); + F, L : I; + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + BEGIN + IF I'FIRST /= F THEN + FAILED ( "INCORRECT 'FIRST' FOR " & STR ); + END IF; + IF I'LAST /= L THEN + FAILED ( "INCORRECT 'LAST' FOR " & STR ); + END IF; + END P; + + GENERIC + TYPE I IS (<>); + F, L : I; + PROCEDURE Q; + + PROCEDURE Q IS + SUBTYPE SI IS I; + BEGIN + IF SI'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR INTEGER'FIRST" ); + END IF; + IF SI'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR INTEGER'LAST" ); + END IF; + END Q; + + GENERIC + TYPE I IS (<>); + PROCEDURE R; + + PROCEDURE R IS + SUBTYPE SI IS I; + BEGIN + IF SI'FIRST /= SI'VAL (IDENT_INT(1)) THEN + FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" ); + END IF; + IF SI'LAST /= SI'VAL (IDENT_INT(-1)) THEN + FAILED ( "INCORRECT VALUE FOR NOINT'LAST" ); + END IF; + END R; + + PROCEDURE P1 IS NEW P ( I => INT, F => -6, L => 6 ); + PROCEDURE P2 IS NEW P ( I => SINT, F => -4, L => 4 ); + PROCEDURE Q1 IS NEW Q + ( I => INTEGER, F => INTEGER'FIRST, L => INTEGER'LAST ); + PROCEDURE R1 IS NEW R ( I => NOINT); + + BEGIN + P1 ( "INT" ); + P2 ( "SINT" ); + Q1; + R1; + END; + + RESULT; + END C35503P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35504a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35504a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35504a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35504a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C35504A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE USER-DEFINED + -- ENUMERATION ARGUMENT TO 'SUCC, 'PRED, 'POS, 'VAL, 'IMAGE, AND 'VALUE + -- IS NOT IN THE ATTRIBUTED SUBTYPE'S RANGE CONSTRAINT. + + -- DAT 3/18/81 + -- SPS 01/13/83 + + WITH REPORT; USE REPORT; + + PROCEDURE C35504A IS + + TYPE E IS (A, 'A', B, 'B', C, 'C', D, 'D', XYZ); + + SUBTYPE S IS E RANGE B .. C; + + BEGIN + TEST ("C35504A", "CONSTRAINT_ERROR IS NOT RAISED IN T'SUCC(X)," + & " T'PRED(X), T'POS(X), T'VAL(X), T'IMAGE(X), AND" + & " T'VALUE(X) WHEN THE VALUES ARE NOT WITHIN T'S" + & " RANGE CONSTRAINT, FOR USER-DEFINED ENUMERATION TYPES"); + + BEGIN + FOR X IN E LOOP + IF (X /= A AND THEN S'SUCC(S'PRED(X)) /= X) + OR (X /= XYZ AND THEN S'PRED(S'SUCC(X)) /= X) + OR S'VAL(S'POS(X)) /= X + OR S'VALUE(S'IMAGE(X)) /= X + THEN + FAILED ("WRONG ATTRIBUTE VALUE"); + END IF; + END LOOP; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR RAISED" + & " WHEN IT SHOULDN'T HAVE BEEN"); + WHEN OTHERS => FAILED ("INCORRECT EXCEPTION RAISED"); + END; + + RESULT; + END C35504A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35504b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35504b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35504b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35504b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C35504B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR I'SUCC, I'PRED, + -- I'POS, I'VAL, I'IMAGE, AND I'VALUE FOR INTEGER ARGUMENTS + -- OUTSIDE THE RANGE OF I. + + -- DAT 3/30/81 + -- SPS 01/13/83 + + WITH REPORT; + USE REPORT; + + PROCEDURE C35504B IS + + SUBTYPE I IS INTEGER RANGE 0 .. 0; + + BEGIN + TEST ("C35504B", "CONSTRAINT_ERROR IS NOT RAISED FOR" + & " INTEGER SUBTYPE ATTRIBUTES 'SUCC, 'PRED, 'POS, 'VAL," + & " 'IMAGE, AND 'VALUE WHOSE ARGUMENTS ARE OUTSIDE THE" + & " SUBTYPE"); + + BEGIN + IF I'SUCC(-1) /= I'PRED(1) + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 1"); + END IF; + + IF I'SUCC (100) /= 101 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 2"); + END IF; + + IF I'PRED (100) /= 99 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 3"); + END IF; + + IF I'POS (-100) /= -100 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 4"); + END IF; + + IF I'VAL(-100) /= -100 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 5"); + END IF; + + IF I'IMAGE(1234) /= " 1234" + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 6"); + END IF; + + IF I'VALUE("999") /= 999 + THEN + FAILED ("WRONG ATTRIBUTE VALUE - 7"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + END C35504B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C35505C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED', + -- IF THE RETURNED VALUES WOULD BE OUTSIDE OF THE BASE TYPE, + -- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT + -- IS A USER-DEFINED ENUMERATION TYPE. + + -- HISTORY: + -- RJW 06/05/86 CREATED ORIGINAL TEST. + -- VCL 08/19/87 REMOVED THE FUNCTION 'IDENT' IN THE GENERIC + -- PROCEDURE 'P' AND REPLACED ALL CALLS TO 'IDENT' + -- WITH "T'VAL(IDENT_INT(T'POS(...)))". + + WITH REPORT; USE REPORT; + + PROCEDURE C35505C IS + + TYPE B IS ('Z', 'X', Z, X); + + SUBTYPE C IS B RANGE 'X' .. Z; + + BEGIN + TEST ( "C35505C", "CHECK THAT 'SUCC' AND 'PRED' RAISE " & + "CONSTRAINT_ERROR APPROPRIATELY WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ARGUMENT IS A USER-DEFINED ENUMERATION TYPE" ); + + DECLARE + GENERIC + TYPE T IS (<>); + STR : STRING; + PROCEDURE P; + + PROCEDURE P IS + + BEGIN + BEGIN + IF T'PRED (T'VAL (IDENT_INT (T'POS + (T'BASE'FIRST)))) = T'FIRST THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED - 1" ); + END; + + BEGIN + IF T'SUCC (T'VAL (IDENT_INT (T'POS + (T'BASE'LAST)))) = T'LAST THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC - 1" ); + END; + END P; + + PROCEDURE PB IS NEW P (B, "B"); + PROCEDURE PC IS NEW P (C, "C"); + BEGIN + PB; + PC; + END; + RESULT; + END C35505C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C35505E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR 'SUCC' AND 'PRED', + -- IF THE RESULT WOULD BE OUTSIDE THE RANGE OF THE BASE TYPE, + -- WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL ARGUMENT + -- IS TYPE CHARACTER OR A SUBTYPE OF TYPE CHARACTER. + + -- HISTORY: + -- DWC 07/01/87 + + WITH REPORT; USE REPORT; + + PROCEDURE C35505E IS + + TYPE CHAR IS ('A', B, C); + SUBTYPE NEWCHAR IS CHAR; + + BEGIN + TEST ( "C35505E", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "'SUCC' AND 'PRED', IF THE RESULT WOULD BE " & + "OUTSIDE THE RANGE OF THE BASE TYPE, WHEN " & + "THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL ARGUMENT IS A CHARACTER TYPE "); + + DECLARE + GENERIC + TYPE SUBCH IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + + FUNCTION IDENT (C : SUBCH) RETURN SUBCH IS + BEGIN + RETURN SUBCH'VAL (IDENT_INT (SUBCH'POS (C))); + END IDENT; + + BEGIN + BEGIN + IF SUBCH'PRED (SUBCH'BASE'FIRST) = SUBCH'VAL (0) + THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'PRED - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED - 1" ); + END; + + BEGIN + IF SUBCH'SUCC (SUBCH'BASE'LAST) = SUBCH'VAL (0) THEN + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 1" ); + ELSE + FAILED ( "CONSTRAINT_ERROR NOT RAISED FOR " & + STR & "'SUCC - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC - 1" ); + END; + + BEGIN + IF SUBCH'PRED (IDENT (SUBCH'BASE'FIRST)) = + SUBCH'VAL (I1) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'PRED " & + "(IDENT (SUBCH'BASE'FIRST))" ); + END; + + BEGIN + IF SUBCH'SUCC (IDENT(SUBCH'BASE'LAST)) = + SUBCH'VAL (I2) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'SUCC " & + "(IDENT (SUBCH'BASE'LAST))" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + BEGIN + PCHAR; + PNCHAR; + END; + RESULT; + END C35505E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35505f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35505f.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C35505F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT ERROR IS RAISED BY THE ATTRIBUTES + -- 'PRED' AND 'SUCC' WHEN THE PREFIX IS A CHARACTER TYPE + -- AND THE RESULT IS OUTSIDE OF THE BASE TYPE. + + -- HISTORY: + -- JET 08/18/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C35505F IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + + BEGIN + + TEST( "C35505F" , "CHECK THAT CONSTRAINT ERROR IS RAISED BY " & + "THE ATTRIBUTES 'PRED' AND 'SUCC' WHEN THE " & + "PREFIX IS A CHARACTER TYPE AND THE RESULT " & + "IS OUTSIDE OF THE BASE TYPE" ); + + BEGIN + IF CHAR'PRED (IDENT ('A')) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A')) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A')) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'PRED (IDENT ('A'))" ); + END; + + BEGIN + IF CHAR'SUCC (IDENT (B)) = B THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'SUCC (IDENT (B))" ); + END; + + BEGIN + IF NEWCHAR'PRED (IDENT ('A')) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A')) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A')) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'PRED (IDENT ('A'))" ); + END; + + BEGIN + IF NEWCHAR'SUCC (IDENT (B)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'SUCC (IDENT (B))" ); + END; + + BEGIN + IF CHARACTER'PRED (IDENT_CHAR (CHARACTER'BASE'FIRST)) = 'A' + THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'PRED " & + "(IDENT_CHAR (CHARACTER'BASE'FIRST))" ); + END; + + BEGIN + IF CHARACTER'SUCC (IDENT_CHAR (CHARACTER'BASE'LAST)) = 'Z' + THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'SUCC " & + "(IDENT_CHAR (CHARACTER'BASE'LAST))" ); + END; + + RESULT; + + END C35505F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C35507A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS + -- WHEN THE PREFIX IS A CHARACTER TYPE. + + -- RJW 5/29/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35507A IS + + BEGIN + + TEST( "C35507A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A CHARACTER TYPE" ); + + DECLARE + TYPE CHAR1 IS (A, 'A'); + + SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z'; + + SUBTYPE NOCHAR IS CHARACTER RANGE 'Z' .. 'A'; + + TYPE NEWCHAR IS NEW CHARACTER + RANGE 'A' .. 'Z'; + + BEGIN + IF CHAR1'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR CHAR1" ); + END IF; + + IF CHAR2'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR CHAR2" ); + END IF; + + IF NEWCHAR'WIDTH /= 3 THEN + FAILED( "INCORRECT WIDTH FOR NEWCHAR" ); + END IF; + + IF NOCHAR'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOCHAR" ); + END IF; + END; + + DECLARE + SUBTYPE NONGRAPH IS CHARACTER + RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31); + + MAX : INTEGER := 0; + + BEGIN + FOR CH IN NONGRAPH + LOOP + IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN + MAX := CHARACTER'IMAGE (CH)'LENGTH; + END IF; + END LOOP; + + IF NONGRAPH'WIDTH /= MAX THEN + FAILED ( "INCORRECT WIDTH FOR NONGRAPH" ); + END IF; + END; + + RESULT; + END C35507A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C35507B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS + -- WHEN THE PREFIX IS FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS + -- A CHARACTER TYPE. + + -- RJW 5/29/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35507B IS + + GENERIC + TYPE CH IS (<>); + PROCEDURE P ( STR : STRING; W : INTEGER ); + + PROCEDURE P ( STR : STRING; W : INTEGER ) IS + + SUBTYPE NOCHAR IS CH RANGE CH'VAL (1) .. CH'VAL(0); + BEGIN + IF CH'WIDTH /= W THEN + FAILED( "INCORRECT WIDTH FOR " & STR ); + END IF; + + IF NOCHAR'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOCHAR WITH " & STR ); + END IF; + END P; + + + BEGIN + + TEST( "C35507B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX " & + "IS A FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + TYPE CHAR1 IS (A, 'A'); + + SUBTYPE CHAR2 IS CHARACTER RANGE 'A' .. 'Z'; + + TYPE NEWCHAR IS NEW CHARACTER + RANGE 'A' .. 'Z'; + + PROCEDURE P1 IS NEW P (CHAR1); + PROCEDURE P2 IS NEW P (CHAR2); + PROCEDURE P3 IS NEW P (NEWCHAR); + BEGIN + P1 ("CHAR1", 3); + P2 ("CHAR2", 3); + P3 ("NEWCHAR", 3); + END; + + DECLARE + SUBTYPE NONGRAPH IS CHARACTER + RANGE CHARACTER'VAL (0) .. CHARACTER'VAL (31); + + MAX : INTEGER := 0; + + PROCEDURE PN IS NEW P (NONGRAPH); + BEGIN + FOR CH IN NONGRAPH + LOOP + IF CHARACTER'IMAGE (CH)'LENGTH > MAX THEN + MAX := CHARACTER'IMAGE (CH)'LENGTH; + END IF; + END LOOP; + + PN ("NONGRAPH", MAX); + END; + + RESULT; + END C35507B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,360 ---- + -- C35507C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + -- SUBTESTS ARE: + -- (A). TESTS FOR IMAGE. + -- (B). TESTS FOR VALUE. + + -- HISTORY: + -- RJW 05/29/86 CREATED ORIGINAL TEST. + -- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. + -- CORRECTED ERROR MESSAGES AND ADDED CALLS TO + -- IDENT_STR. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507C IS + + TYPE CHAR IS ('A', 'a'); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END IDENT; + + PROCEDURE CHECK_BOUND (STR1, STR2 : STRING) IS + BEGIN + IF STR1'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & + "'IMAGE ('" & STR1 & "')" ); + END IF; + END CHECK_BOUND; + + BEGIN + + TEST( "C35507C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN -- (A). + IF CHAR'IMAGE ('A') /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'('A')" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE ('A'), "CHAR"); + + IF CHAR'IMAGE ('a') /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'('a')" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE ('a'), "CHAR"); + + IF NEWCHAR'IMAGE ('A') /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('A')" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE ('A'), "NEWCHAR"); + + IF NEWCHAR'IMAGE ('a') /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'('a')" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE ('a'), "NEWCHAR"); + + IF CHAR'IMAGE (IDENT ('A')) /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('A'))" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE (IDENT ('A')), "IDENT OF CHAR"); + + IF CHAR'IMAGE (IDENT ('a')) /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR CHAR'( IDENT ('a'))" ); + END IF; + + CHECK_BOUND (CHAR'IMAGE (IDENT ('a')), "IDENT OF CHAR"); + + IF NEWCHAR'IMAGE (IDENT ('A')) /= "'A'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('A'))" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('A')), "IDENT OF NEWCHAR"); + + IF NEWCHAR'IMAGE (IDENT ('a')) /= "'a'" THEN + FAILED ( "INCORRECT IMAGE FOR NEWCHAR'( IDENT ('a'))" ); + END IF; + + CHECK_BOUND (NEWCHAR'IMAGE (IDENT ('a')), "IDENT OF NEWCHAR"); + + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + IF CHARACTER'IMAGE (CH) /= ("'" & CH) & "'" THEN + FAILED ( "INCORRECT IMAGE FOR CHARACTER'(" & + CH & ")" ); + END IF; + + CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER"); + + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + CHECK_BOUND (CHARACTER'IMAGE (CH), "CHARACTER"); + END LOOP; + + CHECK_BOUND (CHARACTER'IMAGE (CHARACTER'VAL (127)), + "CHARACTER"); + + END; + + --------------------------------------------------------------- + + DECLARE -- (B). + + SUBTYPE SUBCHAR IS CHARACTER + RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127); + BEGIN + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + IF SUBCHAR'VALUE (("'" & CH) & "'") /= CH THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & CH ); + END IF; + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + IF SUBCHAR'VALUE (CHARACTER'IMAGE (CH)) /= CH THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + IF SUBCHAR'VALUE (CHARACTER'IMAGE (CHARACTER'VAL (127))) /= + CHARACTER'VAL (127) THEN + FAILED ( "INCORRECT SUBCHAR'VALUE FOR " & + "CHARACTER'VAL (127)" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE ("'A'") /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(""'A'"")" ); + END IF; + + IF CHAR'VALUE ("'a'") /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(""'a'"")" ); + END IF; + + IF NEWCHAR'VALUE ("'A'") /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'A'"")" ); + END IF; + + IF NEWCHAR'VALUE ("'a'") /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(""'a'"")" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" & + "(""'A'""))" ); + END IF; + + IF CHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'(IDENT_STR" & + "(""'a'""))" ); + END IF; + + IF NEWCHAR'VALUE (IDENT_STR("'A'")) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" & + "(""'A'""))" ); + END IF; + + IF NEWCHAR'VALUE (IDENT_STR("'a'")) /= 'a' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'(IDENT_STR" & + "(""'a'""))" ); + END IF; + END; + + BEGIN + IF CHAR'VALUE (IDENT_STR ("'B'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'VALUE (IDENT_STR (""'B'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_CHAR (ASCII.HT) & "'A'") = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"") - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE " & + "(IDENT_CHAR (ASCII.HT) & ""'A'"")" ); + END; + + BEGIN + IF CHARACTER'VALUE ("'B'" & IDENT_CHAR (ASCII.HT)) = 'B' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (""'B'"" & " & + "IDENT_CHAR (ASCII.HT)) " ); + END; + + BEGIN + IF CHARACTER'VALUE ("'C'" & IDENT_CHAR (ASCII.BEL)) = 'C' + THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (""'C'"" & " & + "IDENT_CHAR (ASCII.BEL))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'")) = ''' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("''")) = ''' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""''"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""''"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""''""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'A")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'A"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'A"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE IDENT_STR (""'A""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("A'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""A'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""A'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE (IDENT_STR (""A'""))" ); + END; + + BEGIN + IF CHARACTER'VALUE (IDENT_STR ("'AB'")) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHARACTER'VALUE (IDENT_STR (""'AB'"")) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VALUE IDENT_STR (""'AB'""))" ); + END; + + RESULT; + END C35507C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + -- C35507E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE. + -- SUBTESTS ARE: + -- (A). TESTS FOR IMAGE. + -- (B). TESTS FOR VALUE. + + -- HISTORY: + -- RJW 05/29/86 CREATED ORIGINAL TEST. + -- VCL 10/23/87 MODIFIED THIS HEADER, CHANGED THE CALLS TO + -- PROCEDURE 'PCH', IN THE SECOND PART OF SUBTEST B, + -- TO INCLUDE ANOTHER CALL TO PROCEDURE 'PCHAR' AND + -- CALLS TO PROCEDURE 'PNCHAR'. + + WITH REPORT; USE REPORT; + PROCEDURE C35507E IS + + TYPE CHAR IS ('A', 'a'); + + TYPE NEWCHAR IS NEW CHAR; + + PROCEDURE CHECK_LOWER_BOUND (STR1, STR2 : STRING) IS + BEGIN + IF STR1'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR " & STR2 & "'(" & + STR1 & ")" ); + END IF; + END CHECK_LOWER_BOUND; + + BEGIN + + TEST( "C35507E" , "THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE -- (A). + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (CH : CHTYPE; STR2 : STRING); + + PROCEDURE P (CH : CHTYPE; STR2 : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'IMAGE (CH) /= STR2 THEN + FAILED ( "INCORRECT IMAGE FOR " & STR1 & "'(" & + STR2 & ")" ); + END IF; + + CHECK_LOWER_BOUND (SUBCH'IMAGE (CH), STR1); + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + + BEGIN + PCHAR ('A', "'A'"); + PCHAR ('a', "'a'"); + PNCHAR ('A', "'A'"); + PNCHAR ('a', "'a'"); + + FOR CH IN CHARACTER'VAL (32) .. CHARACTER'VAL (126) LOOP + PCH (CH, ("'" & CH) & "'" ); + END LOOP; + END; + + DECLARE + + GENERIC + TYPE CHTYPE IS (<>); + PROCEDURE P (CH : CHTYPE; STR : STRING); + + PROCEDURE P (CH : CHTYPE; STR : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + CHECK_LOWER_BOUND (CHTYPE'IMAGE (CH), "CHARACTER"); + END P; + + PROCEDURE PN IS NEW P (CHARACTER); + + BEGIN + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + PN (CH, CHARACTER'IMAGE (CH)); + END LOOP; + + PN (ASCII.DEL, CHARACTER'IMAGE (ASCII.DEL)); + END; + + --------------------------------------------------------------- + + DECLARE -- (B). + + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (STR2 : STRING; CH : CHTYPE); + + PROCEDURE P (STR2 : STRING; CH : CHTYPE) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'VALUE (STR2) /= CH THEN + FAILED ( "INCORRECT " & STR1 & "'VALUE FOR " & + STR2 ); + END IF; + END P; + + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + + BEGIN + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (31) LOOP + PCH (CHARACTER'IMAGE (CH), CH ); + END LOOP; + + PCH (CHARACTER'IMAGE (CHARACTER'VAL (127)), + CHARACTER'VAL (127)); + + PCHAR ("'A'", 'A'); + PCHAR ("'a'", 'a' ); + PNCHAR ("'A'", 'A'); + PNCHAR ("'a'", 'a'); + END; + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR1 : STRING; + PROCEDURE P (STR2 : STRING); + + PROCEDURE P (STR2 : STRING) IS + SUBTYPE SUBCH IS CHTYPE; + BEGIN + IF SUBCH'VALUE (STR2) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + STR1 & "'VALUE (" & STR2 & ") - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + STR1 & "'VALUE (" & STR2 & ") - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR1 & "'VALUE (" & STR2 & ")" ); + END P; + + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER"); + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR"); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR"); + + BEGIN + PCHAR ("'B'"); + PCH (ASCII.HT & "'A'"); + PCH ("'B'" & ASCII.HT); + PCH ("'C'" & ASCII.BEL); + PCH ("'"); + PNCHAR ("''"); + PCHAR ("'A"); + PNCHAR ("A'"); + PCH ("'AB'"); + END; + + RESULT; + END C35507E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C35507G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST. + -- JET 08/13/87 REMOVED TESTS INTENDED FOR C35505F. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507G IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + + BEGIN + + TEST( "C35507G" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF CHAR'SUCC ('A') /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" ); + END IF; + + IF CHAR'PRED (IDENT (B)) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" ); + END IF; + END; + + BEGIN + IF NEWCHAR'SUCC (IDENT ('A')) /= B THEN + FAILED ( "INCORRECT VALUE FOR " & + "IDENT (NEWCHAR'SUCC('A'))" ); + END IF; + + IF NEWCHAR'PRED (B) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" ); + END IF; + END; + + FOR CH IN CHARACTER'VAL (1) .. CHARACTER'VAL (127) LOOP + IF CHARACTER'PRED (CH) /= + CHARACTER'VAL (CHARACTER'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'PRED OF " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN CHARACTER'VAL (0) .. CHARACTER'VAL (126) LOOP + IF CHARACTER'SUCC (CH) /= + CHARACTER'VAL (CHARACTER'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'SUCC OF " & + CHARACTER'IMAGE (CH) ); + END IF; + END LOOP; + + RESULT; + + END C35507G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507h.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C35507H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE. + + -- RJW 6/03/86 + -- DWC 7/01/87 -- ADDED THIRD VALUE TO CHAR TYPE. + -- REMOVED SECTION OF CODE AND PLACED INTO + -- C35505E.ADA. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507H IS + + TYPE CHAR IS ('A', B, C); + + TYPE NEWCHAR IS NEW CHAR; + + BEGIN + + TEST( "C35507H" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE + RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2); + + BEGIN + FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP + IF SUBCH'PRED (CH) /= + SUBCH'VAL (SUBCH'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'PRED OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP + IF SUBCH'SUCC (CH) /= + SUBCH'VAL (SUBCH'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'SUCC OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 0, 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; + END C35507H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507i.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C35507I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION + -- REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- DTN 11/26/91 DELETED CONSTRAINT_ERROR FOR ATTRIBUTES PRED AND + -- SUCC SUBTESTS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507I IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 2, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END; + + BEGIN + + TEST( "C35507I" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE WITH AN " & + "ENUMERATION REPRESENTATION CLAUSE" ); + + BEGIN + IF CHAR'SUCC ('A') /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'SUCC('A')" ); + END IF; + + IF CHAR'PRED (IDENT (B)) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'PRED (IDENT (B))" ); + END IF; + END; + + BEGIN + IF IDENT (NEWCHAR'SUCC ('A')) /= B THEN + FAILED ( "INCORRECT VALUE FOR " & + "IDENT (NEWCHAR'SUCC('A'))" ); + END IF; + + IF NEWCHAR'PRED (B) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'PRED(B)" ); + END IF; + END; + + RESULT; + END C35507I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507j.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C35507J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'PRED' AND 'SUCC' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION + -- CLAUSE. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST. + -- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507J IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + BEGIN + + TEST( "C35507J" , "CHECK THAT THE ATTRIBUTES 'PRED' AND " & + "'SUCC' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE WITH " & + "WITH AN ENUMERATION REPRESENTATION CLAUSE" ); + + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1, I2 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE + RANGE CHTYPE'VAL (I1) .. CHTYPE'VAL (I2); + BEGIN + FOR CH IN SUBCH'VAL (I1 + 1) .. SUBCH'VAL (I2) LOOP + IF SUBCH'PRED (CH) /= + SUBCH'VAL (SUBCH'POS (CH) - 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'PRED OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + FOR CH IN SUBCH'VAL (I1) .. SUBCH'VAL (I2 - 1) LOOP + IF SUBCH'SUCC (CH) /= + SUBCH'VAL (SUBCH'POS (CH) + 1) THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'SUCC OF " & SUBCH'IMAGE (CH) ); + END IF; + END LOOP; + + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 0, 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 0, 1); + + BEGIN + PCHAR; + PNCHAR; + + END; + + RESULT; + END C35507J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507k.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- C35507K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + + -- HISTORY: + -- RJW 06/03/86 + -- JLH 07/28/87 MODIFIED FUNCTION IDENT. + -- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507K IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SUBTYPE SCHAR IS CHARACTER + RANGE CHARACTER'VAL (127) .. CHARACTER'VAL (127); + + BLANK : CONSTANT CHARACTER := ' '; + + POSITION : INTEGER; + + NONGRAPH : ARRAY (0 .. 31) OF CHARACTER := + (ASCII.NUL, ASCII.SOH, ASCII.STX, ASCII.ETX, + ASCII.EOT, ASCII.ENQ, ASCII.ACK, ASCII.BEL, + ASCII.BS, ASCII.HT, ASCII.LF, ASCII.VT, + ASCII.FF, ASCII.CR, ASCII.SO, ASCII.SI, + ASCII.DLE, ASCII.DC1, ASCII.DC2, ASCII.DC3, + ASCII.DC4, ASCII.NAK, ASCII.SYN, ASCII.ETB, + ASCII.CAN, ASCII.EM, ASCII.SUB, ASCII.ESC, + ASCII.FS, ASCII.GS, ASCII.RS, ASCII.US); + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL (CHAR'POS (CH), CHAR'POS (CH)) THEN + RETURN CH; + END IF; + RETURN CHAR'FIRST; + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + IF EQUAL (NEWCHAR'POS (CH), NEWCHAR'POS (CH)) THEN + RETURN CH; + END IF; + RETURN NEWCHAR'FIRST; + END IDENT; + + BEGIN + + TEST( "C35507K" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF CHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') - 1" ); + END IF; + + IF CHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS(B) - 1" ); + END IF; + + IF CHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" ); + END IF; + + IF CHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" ); + END IF; + + IF CHAR'POS (IDENT ('A')) /= 0 THEN + FAILED ( "INCORRECT VALUE " & + "FOR CHAR'POS (IDENT ('A')) - 2" ); + END IF; + + IF CHAR'POS (IDENT (B)) /= 1 THEN + FAILED ( "INCORRECT VALUE " & + "FOR CHAR'POS (IDENT (B)) - 2" ); + END IF; + + END; + + BEGIN + IF NEWCHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" ); + END IF; + + IF NEWCHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) - 1" ); + END IF; + + IF NEWCHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) - 1" ); + END IF; + + IF NEWCHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" ); + END IF; + + IF NEWCHAR'VAL (IDENT_INT (1)) /= B THEN + FAILED ( "INCORRECT VALUE " & + "FOR NEWCHAR'POS (IDENT (B)) - 2" ); + END IF; + + IF (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN + FAILED ( "INCORRECT VALUE " & + "FOR IDENT (NEWCHAR'VAL (0)) - 2" ); + END IF; + + END; + + BEGIN + IF CHAR'VAL (IDENT_INT (2)) = B THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHAR'VAL (IDENT_INT (2))" ); + END; + + BEGIN + IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1))" ); + END; + + POSITION := 0; + + FOR CH IN CHARACTER LOOP + IF SCHAR'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR SCHAR'POS OF " & + CHARACTER'IMAGE (CH) ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + FOR POSITION IN 0 .. 31 LOOP + IF CHARACTER'VAL (POSITION) /= NONGRAPH (POSITION) THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " & + "NONGRAPHIC CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + END LOOP; + + POSITION := 32; + + FOR CH IN BLANK .. ASCII.TILDE LOOP + IF SCHAR'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR SCHAR'VAL OF " & + "GRAPHIC CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + + POSITION := POSITION + 1; + END LOOP; + + IF CHARACTER'VAL (127) /= ASCII.DEL THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'VAL OF " & + "NONGRAPHIC CHARACTER IN POSITION - 127" ); + END IF; + + BEGIN + IF CHARACTER'VAL (IDENT_INT (-1)) = ASCII.NUL THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR CHARACTER'VAL (IDENT_INT (-1))" ); + END; + + RESULT; + END C35507K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C35507L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE. + + -- RJW 6/03/86 + -- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507L IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + BEGIN + + TEST( "C35507L" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE; + CH : CHTYPE; + POSITION : INTEGER; + BEGIN + POSITION := 0; + FOR CH IN CHTYPE LOOP + IF SUBCH'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'POS OF " & CHTYPE'IMAGE (CH) ); + END IF; + + IF SUBCH'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'VAL OF CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1)" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; + END C35507L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507m.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- C35507M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE WITH AN ENUMERATION + -- REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST + -- JLH 07/28/87 MODIFIED FUNCTION IDENT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507M IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN CH; + ELSE + RETURN 'A'; + END IF; + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN CH; + ELSE + RETURN 'A'; + END IF; + END IDENT; + + BEGIN + + TEST( "C35507M" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE WITH AN " & + "ENUMERATION REPESENTATION CLAUSE" ); + + BEGIN + IF CHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A')" ); + END IF; + + IF CHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS(B)" ); + END IF; + + IF CHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(0)" ); + END IF; + + IF CHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1)" ); + END IF; + END; + + BEGIN + IF NEWCHAR'POS ('A') /= 0 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS('A')" ); + END IF; + + IF NEWCHAR'POS (B) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B)" ); + END IF; + + IF NEWCHAR'VAL (0) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0)" ); + END IF; + + IF NEWCHAR'VAL (1) /= B THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(1)" ); + END IF; + END; + + BEGIN + IF CHAR'POS (IDENT ('A')) /= 0 THEN + FAILED ( "INCORRECT VALUE FOR CHAR'POS('A') WITH " & + "IDENT" ); + END IF; + + IF NEWCHAR'POS (IDENT (B)) /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'POS(B) WITH " & + "IDENT" ); + END IF; + + IF IDENT (NEWCHAR'VAL (IDENT_INT(0))) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'VAL(0) WITH " & + "IDENT" ); + END IF; + + IF IDENT (CHAR'VAL (IDENT_INT(1))) /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'VAL(1) WITH IDENT" ); + END IF; + END; + + BEGIN + IF CHAR'VAL (IDENT_INT(2)) = B THEN + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "CHAR'VAL (IDENT_INT(2))" ); + END; + + BEGIN + IF NEWCHAR'VAL (IDENT_INT (-1)) = 'A' THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1)) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR NEWCHAR'VAL (IDENT_INT (-1))" ); + END; + + RESULT; + END C35507M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507n.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C35507N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'POS' AND 'VAL' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE WITH AN ENUMERATION REPRESENTATION + -- CLAUSE. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST. + -- JET 09/22/87 MADE REPRESENTATION VALUES CONSECUTIVE. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507N IS + + TYPE CHAR IS ('A', B); + FOR CHAR USE ('A' => 4, B => 5); + + TYPE NEWCHAR IS NEW CHAR; + + BEGIN + + TEST( "C35507N" , "CHECK THAT THE ATTRIBUTES 'POS' AND " & + "'VAL' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE " & + "WITH AN ENUMERATION REPRESENTATION CLAUSE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + I1 : INTEGER; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE SUBCH IS CHTYPE; + CH : CHTYPE; + POSITION : INTEGER; + BEGIN + POSITION := 0; + FOR CH IN CHTYPE LOOP + IF SUBCH'POS (CH) /= POSITION THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'POS OF " & CHTYPE'IMAGE (CH) ); + END IF; + + IF SUBCH'VAL (POSITION) /= CH THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'VAL OF CHARACTER IN POSITION - " & + INTEGER'IMAGE (POSITION) ); + END IF; + POSITION := POSITION + 1; + END LOOP; + + BEGIN + IF SUBCH'VAL (-1) = SUBCH'VAL (0) THEN + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1) - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "FOR " & STR & "'VAL (-1)" ); + END; + END P; + + PROCEDURE PCHAR IS NEW P (CHAR, "CHAR", 1); + PROCEDURE PNCHAR IS NEW P (NEWCHAR, "NEWCHAR", 1); + PROCEDURE PCH IS NEW P (CHARACTER, "CHARACTER", 127); + BEGIN + PCHAR; + PNCHAR; + PCH; + END; + + RESULT; + END C35507N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507o.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C35507O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A CHARACTER TYPE. + + -- RJW 6/03/86 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + -- REMOVED PART OF TEST INVALID FOR ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507O IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SPACE : CONSTANT CHARACTER := CHARACTER'(' '); + + SUBTYPE NOCHAR IS CHARACTER RANGE CHARACTER'('Z') .. CHARACTER'('A'); + SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE; + SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US; + + FUNCTION IDENT (CH : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (CH))); + END IDENT; + + FUNCTION IDENT (CH : NEWCHAR) RETURN NEWCHAR IS + BEGIN + RETURN NEWCHAR'VAL (IDENT_INT (NEWCHAR'POS (CH))); + END IDENT; + + BEGIN + + TEST( "C35507O" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A CHARACTER TYPE" ); + + BEGIN + IF IDENT (CHAR'FIRST) /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR CHAR'FIRST" ); + END IF; + + IF CHAR'LAST /= B THEN + FAILED ( "INCORRECT VALUE FOR CHAR'LAST" ); + END IF; + END; + + BEGIN + IF NEWCHAR'FIRST /= 'A' THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'FIRST" ); + END IF; + + IF NEWCHAR'LAST /= IDENT (B) THEN + FAILED ( "INCORRECT VALUE FOR NEWCHAR'LAST" ); + END IF; + END; + + BEGIN + IF NOCHAR'FIRST /= CHARACTER'('Z') THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST" ); + END IF; + + IF NOCHAR'LAST /= CHARACTER'('A') THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST" ); + END IF; + END; + + BEGIN + IF CHARACTER'FIRST /= ASCII.NUL THEN + FAILED ( "INCORRECT VALUE FOR CHARACTER'FIRST" ); + END IF; + + END; + + BEGIN + IF NONGRAPHIC'FIRST /= IDENT_CHAR (ASCII.NUL) THEN + FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'FIRST" ); + END IF; + + IF NONGRAPHIC'LAST /= ASCII.US THEN + FAILED ( "INCORRECT VALUE FOR NONGRAPHIC'LAST" ); + END IF; + END; + + BEGIN + IF GRAPHIC'FIRST /= SPACE THEN + FAILED ( "INCORRECT VALUE FOR GRAPHIC'FIRST" ); + END IF; + + IF GRAPHIC'LAST /= ASCII.TILDE THEN + FAILED ( "INCORRECT VALUE FOR GRAPHIC'LAST" ); + END IF; + END; + + RESULT; + END C35507O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35507p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35507p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C35507P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'FIRST' AND 'LAST' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A CHARACTER TYPE. + + -- RJW 6/03/86 + -- PWN 11/30/94 REMOVED TESTS BASED ON 128 CHARACTERS FOR ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35507P IS + + TYPE CHAR IS ('A', B); + + TYPE NEWCHAR IS NEW CHAR; + + SPACE : CONSTANT CHARACTER := ' '; + + SUBTYPE GRAPHIC IS CHARACTER RANGE SPACE .. ASCII.TILDE; + SUBTYPE NONGRAPHIC IS CHARACTER RANGE ASCII.NUL .. ASCII.US; + BEGIN + + TEST( "C35507P" , "CHECK THAT THE ATTRIBUTES 'FIRST' AND " & + "'LAST' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A FORMAL DISCRETE TYPE WHOSE " & + "ACTUAL PARAMETER IS A CHARACTER TYPE" ); + + DECLARE + GENERIC + TYPE CHTYPE IS (<>); + STR : STRING; + F, L : CHTYPE; + PROCEDURE P; + + PROCEDURE P IS + SUBTYPE NOCHAR IS CHTYPE RANGE L .. F; + BEGIN + IF CHTYPE'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" ); + END IF; + + IF CHTYPE'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" ); + END IF; + + IF NOCHAR'FIRST /= L THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'FIRST AS A " & + "SUBTYPE OF " & STR ); + END IF; + + IF NOCHAR'LAST /= F THEN + FAILED ( "INCORRECT VALUE FOR NOCHAR'LAST AS A " & + "SUBTYPE OF " & STR ); + END IF; + END P; + + PROCEDURE P1 IS NEW P (CHAR, "CHAR", 'A', B); + PROCEDURE P2 IS NEW P (NEWCHAR, "NEWCHAR", 'A', B); + PROCEDURE P3 IS NEW P + (GRAPHIC, "GRAPHIC", SPACE, ASCII.TILDE); + PROCEDURE P4 IS NEW P + (NONGRAPHIC, "NONGRAPHIC", ASCII.NUL, ASCII.US); + BEGIN + P1; + P2; + P3; + P4; + END; + + RESULT; + END C35507P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C35508A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN + -- THE PREFIX IS A BOOLEAN TYPE. + + -- RJW 3/14/86 COMPLETELY REVISED. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508A IS + + BEGIN + + TEST( "C35508A" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + SUBTYPE FRANGE IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE TRANGE IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + + BEGIN + + IF BOOLEAN'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR BOOLEAN" ); + END IF; + + IF NEWBOOL'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR NEWBOOL" ); + END IF; + + IF FRANGE'WIDTH /= 5 THEN + FAILED( "INCORRECT WIDTH FOR FRANGE" ); + END IF; + + IF TRANGE'WIDTH /= 4 THEN + FAILED( "INCORRECT WIDTH FOR TRANGE" ); + END IF; + + IF NOBOOL'WIDTH /= 0 THEN + FAILED( "INCORRECT WIDTH FOR NOBOOL" ); + END IF; + + END; + + RESULT; + END C35508A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C35508B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS THE CORRECT RESULTS WHEN + -- THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL + -- PARAMETER IS A BOOLEAN TYPE. + + -- RJW 3/19/86 COMPLETELY REVISED. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508B IS + + BEGIN + + TEST( "C35508B" , "CHECK THAT THE ATTRIBUTE 'WIDTH' YIELDS " & + "THE CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A BOOLEAN TYPE" ); + + DECLARE + SUBTYPE FRANGE IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE TRANGE IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE B IS (<>); + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE NOBOOL IS B RANGE + B'VAL (IDENT_INT(1)) .. B'VAL (IDENT_INT(0)); + BEGIN + IF B'WIDTH /= W THEN + FAILED ( "INCORRECT B'WIDTH FOR " & STR ); + END IF; + IF NOBOOL'WIDTH /= 0 THEN + FAILED ( "INCORRECT NOBOOL'WIDTH FOR " & STR ); + END IF; + END P; + + PROCEDURE PROC1 IS NEW P (BOOLEAN, 5); + PROCEDURE PROC2 IS NEW P (FRANGE, 5); + PROCEDURE PROC3 IS NEW P (TRANGE, 4); + PROCEDURE PROC4 IS NEW P (NEWBOOL, 5); + + BEGIN + PROC1 ( "BOOLEAN" ); + PROC2 ( "FRANGE" ); + PROC3 ( "TRANGE"); + PROC4 ( "NEWBOOL" ); + END; + + RESULT; + END C35508B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C35508C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A BOOLEAN TYPE. + + -- SUBTESTS ARE: + -- (A). TESTS FOR IMAGE. + -- (B). TESTS FOR VALUE. + + -- RJW 3/19/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35508C IS + + TYPE NEWBOOL IS NEW BOOLEAN; + + BEGIN + + TEST( "C35508C" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A BOOLEAN TYPE" ); + -- PART (A). + + DECLARE + + A5, B5 : INTEGER := IDENT_INT(5); + C6 : INTEGER := IDENT_INT(6); + BEGIN + + IF BOOLEAN'IMAGE ( A5 = B5 ) /= "TRUE" THEN + FAILED ( "INCORRECT IMAGE FOR 'A5 = B5'" ); + END IF; + IF BOOLEAN'IMAGE ( A5 = B5 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'A5 = B5'" ); + END IF; + + IF BOOLEAN'IMAGE ( C6 = A5 ) /= "FALSE" THEN + FAILED ( "INCORRECT IMAGE FOR 'C6 = A5'" ); + END IF; + IF BOOLEAN'IMAGE ( C6 = A5 )'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'C6 = A5'" ); + END IF; + + IF BOOLEAN'IMAGE (TRUE) /= "TRUE" THEN + FAILED ( "INCORRECT IMAGE FOR 'TRUE'" ); + END IF; + IF BOOLEAN'IMAGE (TRUE)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR 'TRUE'" ); + END IF; + + IF NEWBOOL'IMAGE (FALSE) /= "FALSE" THEN + FAILED ( "INCORRECT IMAGE FOR NEWBOOL'FALSE'" ); + END IF; + IF NEWBOOL'IMAGE (FALSE)'FIRST /= 1 THEN + FAILED ( "INCORRECT LOWER BOUND FOR NEWBOOL'FALSE'" ); + END IF; + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("TRUE")) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR ""TRUE""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""TRUE""" ); + END; + + BEGIN + IF NEWBOOL'VALUE (IDENT_STR("FALSE")) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR ""FALSE""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""FALSE""" ); + END; + + BEGIN + IF BOOLEAN'VALUE ("true") /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR ""true""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR ""true""" ); + END; + + BEGIN + IF NEWBOOL'VALUE ("false") /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR ""false""" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE FOR " & + """false""" ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("TRUE ")) /= TRUE THEN + FAILED ( "INCORRECT VALUE WITH TRAILING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE - " & + "TRAILING BLANKS" ); + END; + + BEGIN + IF NEWBOOL'VALUE (" FALSE") /= FALSE THEN + FAILED ( "INCORRECT VALUE WITH LEADING BLANKS" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - VALUE - LEADING " & + "BLANKS" ); + END; + + DECLARE + SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE .. FALSE; + BEGIN + IF SUBBOOL'VALUE (IDENT_STR("TRUE")) /= TRUE THEN + FAILED ( "INCORRECT VALUE - ""TRUE"" AND " & + "SUBBOOL" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - SUBBOOL" ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_STR("MAYBE")) = TRUE THEN + FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - ""MAYBE"" - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - ""MAYBE"" " ); + END; + + BEGIN + IF BOOLEAN'VALUE (IDENT_CHAR(ASCII.HT) & "TRUE") = TRUE THEN + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - LEADING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - LEADING 'HT'" ); + END; + + BEGIN + IF NEWBOOL'VALUE ("FALSE" & ASCII.HT) = FALSE THEN + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED - TRAILING 'HT' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - TRAILING 'HT'" ); + END; + + RESULT; + END C35508C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508e.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- C35508E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTES 'IMAGE' AND 'VALUE' YIELD THE CORRECT + -- RESULTS WHEN THE PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE + -- ACTUAL ARGUMENT IS A BOOLEAN TYPE. + + -- SUBTESTS ARE: + -- (A). TESTS FOR IMAGE. + -- (B). TESTS FOR VALUE. + + -- HISTORY: + -- RJW 03/19/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508E IS + + BEGIN + + TEST( "C35508E" , "CHECK THAT THE ATTRIBUTES 'IMAGE' AND " & + "'VALUE' YIELD THE CORRECT RESULTS WHEN THE " & + "PREFIX IS A GENERIC FORMAL DISCRETE TYPE " & + "WHOSE ACTUAL ARGUMENT IS A BOOLEAN TYPE" ); + -- PART (A). + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (B : BOOL; STR : STRING ); + + PROCEDURE P (B : BOOL; STR : STRING) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + BEGIN + + IF BOOL'IMAGE (B) /= STR THEN + FAILED ( "INCORRECT BOOL'IMAGE OF " & STR ); + END IF; + IF BOOL'IMAGE (B)'FIRST /= 1 THEN + FAILED ( "INCORRECT BOOL'FIRST FOR " & STR ); + END IF; + + IF SUBBOOL'IMAGE (B) /= STR THEN + FAILED ( "INCORRECT SUBBOOL'IMAGE OF " & STR ); + END IF; + IF SUBBOOL'IMAGE (B)'FIRST /= 1 THEN + FAILED ( "INCORRECT SUBBOOL'FIRST FOR " & STR ); + END IF; + END P; + + PROCEDURE NP1 IS NEW P ( BOOLEAN ); + PROCEDURE NP2 IS NEW P ( NEWBOOL ); + BEGIN + NP1 ( TRUE, "TRUE" ); + NP2 ( FALSE, "FALSE" ); + + END; + + ----------------------------------------------------------------------- + + -- PART (B). + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR : STRING; B : BOOL ); + + PROCEDURE P (STR : STRING; B : BOOL) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + + BEGIN + BEGIN + IF BOOL'VALUE (STR) /= B THEN + FAILED ( "INCORRECT BOOL'VALUE OF """ & + STR & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BOOL'VALUE OF """ & + STR & """" ); + END; + BEGIN + IF SUBBOOL'VALUE (STR) /= B THEN + FAILED ( "INCORRECT SUBBOOL'VALUE OF """ & + STR & """" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED SUBBOOL'VALUE " & + "OF """ & STR & """" ); + END; + END P; + + PROCEDURE NP1 IS NEW P ( BOOLEAN ); + PROCEDURE NP2 IS NEW P ( NEWBOOL ); + + BEGIN + NP1 ( "TRUE", TRUE ); + NP2 ( "FALSE", FALSE ); + NP2 ( "true", TRUE ); + NP1 ( "false", FALSE ); + NP1 ( " TRUE", TRUE ); + NP2 ( "FALSE ", FALSE ); + END; + + DECLARE + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING); + + PROCEDURE P (STR1 : STRING; B : BOOL; STR2 : STRING) IS + SUBTYPE SUBBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. + BOOL'VAL (IDENT_INT(0)); + + BEGIN + BEGIN + IF BOOL'VALUE (STR1) = B THEN + FAILED ( "NO EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 & + "- EQUAL " ); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 & + " - NOT EQUAL" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "BOOL'VALUE WITH " & STR2 ); + END; + BEGIN + IF SUBBOOL'VALUE (STR1) /= B THEN + FAILED ( "NO EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & + STR2 & " - EQUAL"); + ELSE + FAILED ( "NO EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & + STR2 & " - NOT EQUAL"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - " & + "SUBBOOL'VALUE WITH " & STR2 ); + END; + END P; + + PROCEDURE NP IS NEW P ( BOOLEAN ); + BEGIN + NP ( "MAYBE", TRUE, "NON-BOOLEAN VALUE"); + NP ( ASCII.HT & "TRUE", TRUE, "LEADING 'HT'" ); + NP ( "FALSE" & ASCII.HT , FALSE, "TRAILING 'HT'" ); + END; + + RESULT; + END C35508E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508g.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C35508G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A BOOLEAN TYPE. + + -- HISTORY: + -- RJW 03/19/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508G IS + + BEGIN + TEST ("C35508G", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + BEGIN + IF BOOLEAN'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR PRED OF TRUE" ); + END IF; + IF BOOLEAN'SUCC (IDENT_BOOL(FALSE)) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR SUCC OF FALSE" ); + END IF; + END; + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + BEGIN + IF NEWBOOL'PRED (TRUE) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR NEWBOOL'PRED OF TRUE" ); + END IF; + IF NEWBOOL'SUCC (FALSE) /= TRUE THEN + FAILED ( "INCORRECT VALUE FOR NEWBOOL'SUCC OF FALSE" ); + END IF; + END; + + DECLARE + + SUBTYPE SBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(TRUE); + + BEGIN + BEGIN + IF SBOOL'PRED (IDENT_BOOL(TRUE)) /= FALSE THEN + FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " & + "OF TRUE" ); + END IF; + END; + + BEGIN + IF SBOOL'PRED (IDENT_BOOL(SBOOL'BASE'FIRST)) = TRUE THEN + FAILED("'PRED('FIRST) WRAPPED AROUNT TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + "'PRED (SBOOL'BASE'FIRST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "'PRED (SBOOL'BASE'FIRST)" ); + END; + + BEGIN + IF SBOOL'SUCC (IDENT_BOOL(SBOOL'BASE'LAST)) = FALSE THEN + FAILED("'SUCC('LAST) WRAPPED AROUNT TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + "'SUCC (SBOOL'BASE'LAST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "'SUCC (SBOOL'BASE'LAST)" ); + END; + END; + + RESULT; + END C35508G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508h.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C35508H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'PRED' AND 'SUCC' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A + -- BOOLEAN TYPE. + + -- HISTORY: + -- RJW 03/24/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508H IS + + BEGIN + TEST ("C35508H", "CHECK THAT 'PRED' AND 'SUCC' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS A BOOLEAN TYPE" ); + + DECLARE + + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + F, T : BOOL; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + SUBTYPE SBOOL IS BOOL RANGE T .. T; + BEGIN + BEGIN + IF BOOL'PRED (T) /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'PRED OF T" ); + END IF; + IF BOOL'SUCC (F) /= T THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'SUCC OF F" ); + END IF; + END; + + BEGIN + IF SBOOL'PRED (T) /= F THEN + FAILED ( "INCORRECT VALUE FOR SBOOL'PRED " & + "OF T FOR " & STR); + END IF; + END; + + BEGIN + IF SBOOL'PRED (SBOOL'BASE'FIRST) = T THEN + FAILED("'PRED('FIRST) WRAPPED AROUND " & + "TO TRUE FOR " & STR); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'PRED (SBOOL'BASE'FIRST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED (SBOOL'BASE'FIRST)" ); + END; + + BEGIN + IF SBOOL'SUCC (SBOOL'BASE'LAST) = F THEN + FAILED("'SUCC('LAST) WRAPPED AROUND TO " & + "FALSE FOR " & STR); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & STR & + "'SUCC (SBOOL'BASE'LAST)" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC (SBOOL'BASE'LAST)" ); + END; + END P; + + PROCEDURE NP1 IS NEW P + ( BOOL => BOOLEAN, F => FALSE, T => TRUE ); + + PROCEDURE NP2 IS NEW P + ( BOOL => NEWBOOL, F => FALSE, T => TRUE ); + BEGIN + NP1 ("BOOLEAN"); + NP2 ("NEWBOOL"); + END; + + RESULT; + END C35508H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508k.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C35508K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A BOOLEAN TYPE. + + -- RJW 3/19/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508K IS + + TYPE NEWBOOL IS NEW BOOLEAN; + + BEGIN + TEST ("C35508K", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + BEGIN + IF BOOLEAN'POS (IDENT_BOOL(FALSE)) /= 0 THEN + FAILED ( "WRONG POS FOR 'FALSE'" ); + END IF; + IF BOOLEAN'POS (IDENT_BOOL(TRUE)) /= 1 THEN + FAILED ( "WRONG POS FOR 'TRUE'" ); + END IF; + + IF BOOLEAN'VAL (IDENT_INT(0)) /= FALSE THEN + FAILED ( "WRONG VAL FOR '0'" ); + END IF; + IF BOOLEAN'VAL (IDENT_INT(1)) /= TRUE THEN + FAILED ( "WRONG VAL FOR '1'" ); + END IF; + END; + + BEGIN + IF BOOLEAN'VAL (IDENT_INT(-1)) = TRUE THEN + FAILED("'VAL(-1) WRAPPED AROUND TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR VAL OF '-1'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '-1'" ); + END; + + BEGIN + IF BOOLEAN'VAL (IDENT_INT(2)) = FALSE THEN + FAILED("BOOLEAN'VAL(2) WRAPPED AROUND TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR VAL OF '2'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VAL OF '2'" ); + END; + + BEGIN + IF NEWBOOL'POS (FALSE) /= 0 THEN + FAILED ( "WRONG POS FOR NEWBOOL'(FALSE)" ); + END IF; + IF NEWBOOL'POS (TRUE) /= 1 THEN + FAILED ( "WRONG POS FOR NEWBOOL'(TRUE)" ); + END IF; + + IF NEWBOOL'VAL (0) /= FALSE THEN + FAILED ( "WRONG NEWBOOL'VAL FOR '0'" ); + END IF; + IF NEWBOOL'VAL (1) /= TRUE THEN + FAILED ( "WRONG NEWBOOL'VAL FOR '1'" ); + END IF; + END; + + BEGIN + IF NEWBOOL'VAL (IDENT_INT(-1)) = TRUE THEN + FAILED("NEWBOOL'VAL(-1) WRAPPED AROUND TO TRUE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '-1'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWBOOL'VAL OF '-1'" ); + END; + + BEGIN + IF NEWBOOL'VAL (IDENT_INT(2)) = FALSE THEN + FAILED("NEWBOOL'VAL(2) WRAPPED AROUND TO FALSE"); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR NEWBOOL'VAL OF '2'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWBOOL'VAL OF '2'" ); + END; + + RESULT; + END C35508K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508l.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C35508L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'POS' AND 'VAL' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER IS A + -- BOOLEAN TYPE. + + -- RJW 3/24/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35508L IS + + BEGIN + TEST ("C35508L", "CHECK THAT 'POS' AND 'VAL' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER " & + "IS A BOOLEAN TYPE" ); + + DECLARE + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER); + + PROCEDURE P (STR : STRING; B : BOOL; I : INTEGER) IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0)); + BEGIN + IF BOOL'POS (B) /= I THEN + FAILED ( "WRONG " & STR & "'POS FOR " & + BOOL'IMAGE (B) & " - 1" ); + END IF; + IF BOOL'VAL (I) /= B THEN + FAILED ( "WRONG " & STR & "'VAL FOR " & + INTEGER'IMAGE (I) & " - 1" ); + END IF; + + IF SBOOL'POS (B) /= I THEN + FAILED ( "WRONG " & STR & "'POS FOR " & + BOOL'IMAGE (B) & " - 2" ); + END IF; + + IF SBOOL'VAL (I) /= B THEN + FAILED ( "WRONG " & STR & "'VAL FOR " & + INTEGER'IMAGE (I) & " - 2" ); + END IF; + END P; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER); + + PROCEDURE Q (STR : STRING; B : BOOL; I : INTEGER) IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (IDENT_INT(0)) .. BOOL'VAL (IDENT_INT(0)); + BEGIN + BEGIN + IF BOOL'VAL (I) = B THEN + FAILED (STR & "'VAL OF " & INTEGER'IMAGE (I) & + " = " & BOOL'IMAGE (B)); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR " & STR & + "'VAL OF " & INTEGER'IMAGE (I) ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & STR & + "'VAL " & "OF " & + INTEGER'IMAGE (I) ); + END; + + BEGIN + IF SBOOL'VAL (I) = B THEN + FAILED (STR & " SBOOL'VAL OF " & + INTEGER'IMAGE(I) & " = " & + BOOL'IMAGE (B) ); + END IF; + FAILED( "NO EXCEPTION RAISED FOR VAL OF " & + INTEGER'IMAGE (I) & + "WITH SBOOL OF " & STR); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & STR & + "'VAL " & "OF " & + INTEGER'IMAGE (I) & + "WITH SBOOL " ); + END; + END Q; + + PROCEDURE NP1 IS NEW P ( BOOL => BOOLEAN ); + PROCEDURE NP2 IS NEW P ( BOOL => NEWBOOL ); + PROCEDURE NQ1 IS NEW Q ( BOOL => BOOLEAN ); + PROCEDURE NQ2 IS NEW Q ( BOOL => NEWBOOL ); + BEGIN + NP1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(0) ); + NP1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(1) ); + NP2 ( "NEWBOOL", FALSE , 0 ); + NP2 ( "NEWBOOL", TRUE , 1 ); + NQ1 ( "BOOLEAN", IDENT_BOOL(FALSE) , IDENT_INT(-1) ); + NQ1 ( "BOOLEAN", IDENT_BOOL(TRUE) , IDENT_INT(2) ); + NQ2 ( "NEWBOOL", FALSE , -1 ); + NQ2 ( "NEWBOOL", TRUE , 2 ); + END; + + RESULT; + END C35508L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508o.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C35508O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A BOOLEAN TYPE. + + -- HISTORY: + -- RJW 03/19/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508O IS + + BEGIN + TEST ("C35508O", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "BOOLEAN TYPE" ); + + DECLARE + SUBTYPE TBOOL IS BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(TRUE); + SUBTYPE FBOOL IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + TYPE NEWBOOL IS NEW BOOLEAN; + TYPE NIL IS NEW BOOLEAN RANGE IDENT_BOOL(TRUE) .. + IDENT_BOOL(FALSE); + + BEGIN + IF IDENT_BOOL(BOOLEAN'FIRST) /= FALSE THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST" ); + END IF; + IF IDENT_BOOL(BOOLEAN'LAST) /= TRUE THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'LAST" ); + END IF; + + IF TBOOL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR TBOOL'FIRST" ); + END IF; + IF TBOOL'LAST /= TRUE THEN + FAILED ( "WRONG VALUE FOR TBOOL'LAST" ); + END IF; + + IF FBOOL'FIRST /= FALSE THEN + FAILED ( "WRONG VALUE FOR FBOOL'FIRST" ); + END IF; + IF FBOOL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR FBOOL'LAST" ); + END IF; + + IF NOBOOL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NOBOOL'FIRST" ); + END IF; + IF NOBOOL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NOBOOL'LAST" ); + END IF; + + IF NEWBOOL'FIRST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NEWBOOL'FIRST" ); + END IF; + IF NEWBOOL'LAST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NEWBOOL'LAST" ); + END IF; + IF NIL'FIRST /= TRUE THEN + FAILED ( "WRONG VALUE FOR NIL'FIRST" ); + END IF; + IF NIL'LAST /= FALSE THEN + FAILED ( "WRONG VALUE FOR NIL'LAST" ); + END IF; + + END; + + RESULT; + END C35508O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35508p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35508p.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- C35508P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'FIRST' AND 'LAST' YIELD THE CORRECT RESULTS WHEN THE + -- PREFIX IS A GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL PARAMETER + -- IS A BOOLEAN TYPE. + + -- HISTORY: + -- RJW 03/19/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C35508P IS + + BEGIN + TEST ("C35508P", "CHECK THAT 'FIRST' AND 'LAST' YIELD THE " & + "CORRECT RESULTS WHEN THE PREFIX IS A " & + "GENERIC FORMAL DISCRETE TYPE WHOSE ACTUAL " & + "PARAMETER IS A BOOLEAN TYPE" ); + DECLARE + SUBTYPE TBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE); + SUBTYPE FBOOL IS BOOLEAN + RANGE IDENT_BOOL(FALSE) .. IDENT_BOOL(FALSE); + SUBTYPE NOBOOL IS BOOLEAN + RANGE IDENT_BOOL(TRUE) .. IDENT_BOOL(FALSE); + TYPE NEWBOOL IS NEW BOOLEAN; + + GENERIC + TYPE BOOL IS (<>); + F, L : BOOL; + PROCEDURE P ( STR : STRING ); + + PROCEDURE P ( STR : STRING ) IS + BEGIN + IF BOOL'FIRST /= F THEN + FAILED ( "WRONG VALUE FOR " & STR & "'FIRST" ); + END IF; + IF BOOL'LAST /= L THEN + FAILED ( "WRONG VALUE FOR " & STR & "'LAST" ); + END IF; + END P; + + GENERIC + TYPE BOOL IS (<>); + PROCEDURE Q; + + PROCEDURE Q IS + BEGIN + IF BOOL'FIRST /= BOOL'VAL (IDENT_INT(1)) THEN + FAILED ( "WRONG 'FIRST FOR NOBOOL" ); + END IF; + IF BOOL'LAST /= BOOL'VAL (IDENT_INT(0)) THEN + FAILED ( "WRONG 'LAST FOR NOBOOL" ); + END IF; + END Q; + + GENERIC + TYPE BOOL IS (<>); + F, L : BOOL; + PROCEDURE R; + + PROCEDURE R IS + SUBTYPE SBOOL IS BOOL + RANGE BOOL'VAL (0) .. BOOL'VAL (1); + BEGIN + IF SBOOL'FIRST /= F THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'FIRST AS " & + "SUBTYPE " ); + END IF; + IF SBOOL'LAST /= L THEN + FAILED ( "WRONG VALUE FOR BOOLEAN'LAST AS " & + "SUBTYPE" ); + END IF; + END R; + + PROCEDURE P1 IS NEW P + ( BOOL => BOOLEAN, F => IDENT_BOOL(FALSE), + L => IDENT_BOOL(TRUE) ); + + PROCEDURE P2 IS NEW P + ( BOOL => TBOOL, F => IDENT_BOOL(TRUE), + L => IDENT_BOOL(TRUE) ); + + PROCEDURE P3 IS NEW P + ( BOOL => FBOOL, F => IDENT_BOOL(FALSE), + L => IDENT_BOOL(FALSE) ); + + PROCEDURE P4 IS NEW P + (BOOL => NEWBOOL, F => FALSE, L => TRUE ); + + PROCEDURE Q1 IS NEW Q + ( BOOL => NOBOOL ); + + PROCEDURE R1 IS NEW R + ( BOOL => BOOLEAN, F => FALSE, L => TRUE ); + + BEGIN + P1 ( "BOOLEAN" ); + P2 ( "TBOOL" ); + P3 ( "FBOOL" ); + P4 ( "NEWBOOL" ); + Q1; + R1; + END; + + RESULT; + END C35508P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35703a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35703a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35703a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35703a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C35703A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'FIRST AND 'LAST EXIST AND CAN BE ASSIGNED. CHECK THAT + -- 'FIRST IS LESS THAN OR EQUAL TO 'LAST. + + -- BAW 5 SEPT 80 + -- R.WILLIAMS 8/21/86 ADDED A TYPE DECLARED WITHOUT A RANGE + -- CONSTRAINT. RENAMED TO -B. ADDED EXCEPTION + -- HANDLERS. + -- GMT 6/29/87 MOVED THE CALL TO REPORT.TEST INTO A NEWLY + -- CREATED PACKAGE NAMED SHOW_TEST_HEADER. + + + WITH REPORT; USE REPORT; + PROCEDURE C35703A IS + + TYPE REAL1 IS DIGITS 2 RANGE 0.25..0.5; + TYPE REAL2 IS DIGITS 3; + + PACKAGE SHOW_TEST_HEADER IS + -- PURPOSE OF THIS PACKAGE: + -- WE WANT THE TEST HEADER INFORMATION TO BE + -- PRINTED BEFORE ANY OF THE PASS/FAIL MESSAGES. + END SHOW_TEST_HEADER; + + PACKAGE BODY SHOW_TEST_HEADER IS + BEGIN + TEST( "C35703A", + "CHECK THAT FIRST AND LAST CAN BE ASSIGNED " & + "AND THAT FIRST <= LAST" ); + END SHOW_TEST_HEADER; + + PACKAGE XPKG IS + X : REAL1; + END XPKG; + + PACKAGE BODY XPKG IS + BEGIN + X := REAL1'FIRST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL1'FIRST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL1'FIRST" ); + END XPKG; + + PACKAGE YPKG IS + Y : REAL1; + END YPKG; + + PACKAGE BODY YPKG IS + BEGIN + Y := REAL1'LAST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL1'LAST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL1'LAST" ); + END YPKG; + + PACKAGE APKG IS + A : REAL2; + END APKG; + + PACKAGE BODY APKG IS + BEGIN + A := REAL2'FIRST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL2'FIRST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL2'FIRST" ); + END APKG; + + PACKAGE BPKG IS + B : REAL2; + END BPKG; + + PACKAGE BODY BPKG IS + BEGIN + B := REAL2'LAST; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY ASSIGNMENT OF " & + "REAL2'LAST" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY ASSIGNMENT OF " & + "REAL2'LAST" ); + END BPKG; + + + BEGIN + + DECLARE + USE XPKG; + USE YPKG; + BEGIN + IF X > Y THEN + FAILED ( "REAL1'FIRST IS GREATER THAN REAL1'LAST" ); + END IF; + END; + + DECLARE + USE APKG; + USE BPKG; + BEGIN + IF A > B THEN + FAILED ( "REAL2'FIRST IS GREATER THEN REAL2'LAST" ); + END IF; + END; + + RESULT; + + END C35703A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C35704A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FIXED POINT VALUES CAN BE USED IN FLOATING POINT RANGE + -- CONSTRAINT IN TYPE DEFINITION. + + -- BAW 9/5/80 + -- JCR 4/7/82 + + WITH REPORT; + PROCEDURE C35704A IS + + USE REPORT; + + BEGIN + TEST ("C35704A","CHECK THAT L AND R CAN BE FIXED POINT" & + " IN A FLOATING POINT TYPE DEFINITION"); + + DECLARE + + + TYPE F IS DELTA 0.5 RANGE -5.0..5.0; + + F1 : CONSTANT F := -4.0; + F2 : CONSTANT F := 4.0; + + TYPE G1 IS DIGITS 5 RANGE F1..F2; + BEGIN + + IF (ABS(G1'FIRST)-4.0) /= 0.0 OR + (ABS(G1'LAST)-4.0) /= 0.0 + THEN FAILED ("ERROR IN USING FIXED-POINT IN RANGE " & + "CONSTRAINT"); + END IF; + + END; + RESULT; + + END C35704A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- C35704B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DIFFERENT FLOATING POINT TYPES FROM SAME PARENT CAN BE + -- USED IN A FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION. + + -- JCR 4/7/82 + + WITH REPORT; + PROCEDURE C35704B IS + + USE REPORT; + + BEGIN + TEST ("C35704B", "DIFFERENT FLOATING POINT TYPES " & + "FROM THE SAME PARENT IN FLOATING POINT" & + "TYPE DEFINITION'S RANGE CONSTRAINT"); + + DECLARE + TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0; + + TYPE F1 IS NEW F; + + TYPE G1 IS DIGITS 5 RANGE F1'FIRST..F'LAST; + TYPE G2 IS DIGITS 5 RANGE F'FIRST..F1'LAST; + + BEGIN + + IF G1'FIRST /= G1(G2'FIRST) OR G1'LAST /= G1(G2'LAST) OR + G2'FIRST /= G2(F'FIRST) OR G2'LAST /= G2(F'LAST) + THEN + FAILED ("USING DIFF FLOATING POINT TYPES " & + "FROM SAME PARENT"); + + END IF; + + END; + + RESULT; + + END C35704B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- C35704C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DIFFERENT FLOATING POINT TYPES FROM DIFFERENT PARENTS + -- CAN BE USE IN FLOATING POINT RANGE CONSTRAINTS IN TYPE DEFINITIONS. + + -- JCR 4/7/82 + + WITH REPORT; + PROCEDURE C35704C IS + + USE REPORT; + + BEGIN + TEST ("C35704C", "DIFFERENT FLOATING POINT TYPES " & + "FROM DIFFERENT PARENTS IN FLOATING POINT RANGE " & + "CONSTRAINT IN TYPE DEFINITION"); + + DECLARE + + TYPE F IS DIGITS 5 RANGE -5.0 .. 5.0; + TYPE F1 IS DIGITS 5 RANGE -5.0 .. 5.0; + + TYPE G1 IS DIGITS 5 RANGE F'FIRST..F1'LAST; + TYPE G2 IS DIGITS 5 RANGE F1'FIRST..F'LAST; + + BEGIN + + + IF G1'FIRST /= G1(F'FIRST) OR G1'FIRST /= G1(G2'FIRST) OR + G1'FIRST /= G1(F1'FIRST) OR G1'LAST /= G1(F'LAST) OR + G1'LAST /= G1(G2'LAST) OR G1'LAST /= G1(F1'LAST) + + THEN FAILED ("USING FLOAT FROM DIFF PARENTS"); + + END IF; + END; + + RESULT; + + END C35704C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35704d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35704d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C35704D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A COMBINATION OF FIXED AND FLOAT CAN BE USED IN A + -- FLOATING POINT RANGE CONSTRAINT IN A TYPE DEFINITION. + + -- JCR 4/7/82 + + WITH REPORT; + PROCEDURE C35704D IS + + USE REPORT; + + BEGIN + TEST ("C35704D","MIXED FIXED AND FLOAT IN FLOATING " & + "POINT RANGE CONSTRAINT IN A TYPE DEFINITION"); + + DECLARE + + TYPE F IS DIGITS 5; + TYPE R IS DELTA 0.5 RANGE -5.0 .. 5.0; + + T1 : CONSTANT F := -4.0; + T2 : CONSTANT F := 4.0; + + R1 : CONSTANT R := -4.0; + R2 : CONSTANT R := 4.0; + + TYPE G1 IS DIGITS 5 RANGE T1..R2; + TYPE G2 IS DIGITS 5 RANGE R1..T2; + + BEGIN + + IF (ABS(G1'FIRST)- 4.0) /= 0.0 OR + (ABS(G1'LAST) - 4.0) /= 0.0 OR + (ABS(G2'FIRST)- 4.0) /= 0.0 OR + (ABS(G2'LAST) - 4.0) /= 0.0 + + THEN FAILED ("MIXED FIXED AND FLOAT IN FLOAT RANGE " & + "CONSTRAINT"); + + END IF; + + END; + + RESULT; + + + END C35704D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35801d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35801d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35801d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35801d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C35801D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ATTRIBUTES FIRST AND LAST RETURN VALUES HAVING THE + -- SAME BASE TYPE AS THE PREFIX WHEN THE PREFIX IS A GENERIC FORMAL + -- SUBTYPE WHOSE ACTUAL ARGUMENT IS A FLOATING POINT TYPE. + + -- R.WILLIAMS 8/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE C35801D IS + TYPE REAL IS DIGITS 3 RANGE -100.0 .. 100.0; + + TYPE NFLT IS NEW FLOAT; + + GENERIC + TYPE F IS DIGITS <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + SUBTYPE SF IS F RANGE -1.0 .. 1.0; + F1 : SF := 0.0; + F2 : SF := 0.0; + + BEGIN + IF EQUAL (3, 3) THEN + F1 := SF'FIRST; + F2 := SF'LAST; + END IF; + + IF F1 /= -1.0 OR F2 /= 1.0 THEN + FAILED ( "WRONG RESULTS FROM " & STR & "'FIRST OR " & + STR & "'LAST" ); + END IF; + END P; + + PROCEDURE NP1 IS NEW P (FLOAT); + + PROCEDURE NP2 IS NEW P (NFLT); + + PROCEDURE NP3 IS NEW P (REAL); + + BEGIN + TEST ( "C35801D", "CHECK THAT THE ATTRIBUTES FIRST AND " & + "LAST RETURN VALUES HAVING THE SAME " & + "BASE TYPE AS THE PREFIX WHEN THE " & + "PREFIX IS A GENERIC FORMAL SUBTYPE " & + "WHOSE ACTUAL ARGUMENT IS A FLOATING " & + "POINT TYPE" ); + + + NP1 ("FLOAT"); + NP2 ("NFLT"); + NP3 ("REAL"); + + RESULT; + END C35801D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35902d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35902d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35902d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35902d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- C35902D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BINARY POINT IN THE MANTISSA OF A FIXED POINT NUMBER + -- CAN LIE OUTSIDE THE MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT). + + -- WRG 7/18/86 + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C35902D IS + + BEGIN + + TEST ("C35902D", "CHECK THAT THE BINARY POINT IN THE MANTISSA " & + "OF A FIXED POINT NUMBER CAN LIE OUTSIDE THE " & + "MANTISSA (EITHER TO THE LEFT OR TO THE RIGHT)"); + + COMMENT ("VALUE OF SYSTEM.MAX_MANTISSA IS" & + POSITIVE'IMAGE(MAX_MANTISSA) ); + + A: DECLARE + + RS : CONSTANT := 2.0; + + TYPE ONE_TO_THE_RIGHT IS + DELTA RS + RANGE -(2.0 ** (MAX_MANTISSA+1) ) .. + 2.0 ** (MAX_MANTISSA+1); + -- THE BINARY POINT IS ONE PLACE TO THE RIGHT OF THE + -- LARGEST POSSIBLE MANTISSA. + + R1, R2 : ONE_TO_THE_RIGHT; + + BEGIN + + R1 := RS; + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + R1 := R1 * IDENT_INT (2); + END LOOP; + R2 := R1 - RS; + R2 := R2 + R1; + -- AT THIS POINT, R2 SHOULD EQUAL ONE_TO_THE_RIGHT'LARGE. + R2 := -R2; + R2 := R2 + (R1 - RS); + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + R2 := R2 / IDENT_INT (2); + END LOOP; + IF R2 /= -RS THEN + FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - A"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A"); + + END A; + + B: DECLARE + + LS : CONSTANT := 2.0 ** (-(MAX_MANTISSA+1) ); + + TYPE ONE_TO_THE_LEFT IS + DELTA LS + RANGE -(2.0 ** (-1) ) .. + 2.0 ** (-1); + -- THE BINARY POINT IS ONE PLACE TO THE LEFT OF THE + -- LARGEST POSSIBLE MANTISSA. + + L1, L2 : ONE_TO_THE_LEFT; + + BEGIN + + L1 := LS; + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + L1 := L1 * IDENT_INT (2); + END LOOP; + L2 := L1 - LS; + L2 := L2 + L1; + -- AT THIS POINT, L2 SHOULD EQUAL ONE_TO_THE_LEFT'LARGE. + L2 := -L2; + L2 := L2 + (L1 - LS); + FOR I IN POSITIVE RANGE 1 .. MAX_MANTISSA - 1 LOOP + L2 := L2 / IDENT_INT (2); + END LOOP; + IF L2 /= -LS THEN + FAILED ("IDENTITY-PRESERVING OPERATIONS ARE FLAKY - B"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B"); + + END B; + + RESULT; + + END C35902D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35904a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35904a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35904a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35904a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C35904A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE + -- APPROPRIATE EXCEPTIONS. + + + -- HISTORY: + -- RJK 05/17/83 CREATED ORIGINAL TEST. + -- PWB 02/03/86 CORRECTED TEST ERROR: + -- ADDED POSSIBLITY OF NUMERIC_ERROR + -- IN DECLARATIONS OF SFX3 AND SFX4. + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED RANGE + -- CONSTRAINTS OF SUBTYPE SFX1. CHANGED UPPER BOUND + -- OF THE CONSTRAINT OF SFX4. CHANGED RANGE + -- CONSTRAINTS OF FIX. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + -- EDS 07/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C35904A IS + + TYPE FIX IS DELTA 0.5 RANGE -3.0 .. 3.0; + + BEGIN + + TEST ("C35904A", "CHECK THAT INCOMPATIBLE FIXED POINT " & + "CONSTRAINTS RAISE APPROPRIATE EXCEPTION"); + + -- TEST FOR CORRECT SUBTYPE DEFINITION FOR COMPATIBILITY BETWEEN TYPE + -- AND SUBTYPE CONSTRAINTS. + + BEGIN + + DECLARE + + SUBTYPE SFX1 IS FIX DELTA 1.0 RANGE 0.0 .. 2.0; -- OK. + SFX1_VAR : SFX1; + + BEGIN + SFX1_VAR := 1.0; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("FIXED POINT CONSTRAINTS ARE NOT IN ERROR"); + WHEN OTHERS => + FAILED ("EXCEPTION SHOULD NOT BE RAISED WHILE " & + "CHECKING DELTA CONSTRAINT"); + END; + + -- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND + -- SUBTYPE DEFINITIONS. + + BEGIN + + DECLARE + + SUBTYPE SFX IS FIX DELTA 0.1; -- DELTA IS SMALLER FOR + -- SUBTYPE THAN FOR TYPE. + -- DEFINE AN OBJECT OF SUBTYPE SFX AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + SFX_VAR : SFX := FIX(IDENT_INT(1)); + + BEGIN + FAILED ("NO EXCEPTION RAISED FOR INCOMPATABLE DELTA " & + FIX'IMAGE(SFX_VAR) ); --USE SFX_VAR + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "DELTA CONSTRAINT"); + END; + + RESULT; + + END C35904A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35904b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35904b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35904b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35904b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C35904B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INCOMPATIBLE FIXED POINT CONSTRAINTS RAISE + -- CONSTRAINT_ERROR FOR GENERIC FORMAL TYPES. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- RJW 6/20/86 + -- DWC 07/24/87 -- ADDED NUMERIC_ERROR HANDLERS. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + -- EDS 07/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C35904B IS + + GENERIC + TYPE FIX IS DELTA <>; + PROCEDURE PROC (STR : STRING); + + PROCEDURE PROC (STR : STRING) IS + SUBTYPE SFIX IS FIX DELTA 0.1 RANGE -1.0 .. 1.0; + -- DEFINE AN OBJECT OF SUBTYPE SFIX AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + SFIX_VAR : SFIX := SFIX(IDENT_INT(0)); + BEGIN + FAILED ("NO EXCEPTION RAISED FOR " & STR & " " & + SFIX'IMAGE(SFIX_VAR) ); --USE SFIX_VAR + END PROC; + + BEGIN + + TEST ( "C35904B", "CHECK THAT INCOMPATIBLE FIXED POINT " & + "CONSTRAINTS RAISE CONSTRAINT_ERROR " & + "FOR GENERIC FORMAL TYPES" ); + + -- TEST FOR INCORRECT SUBTYPE DEFINITION ON ACCURACY BETWEEN TYPE AND + -- SUBTYPE DEFINITIONS. + + BEGIN + + DECLARE + + TYPE FIX1 IS DELTA 0.5 -- DELTA IS SMALLER FOR + RANGE -2.0 .. 2.0; -- SUBTYPE THEN FOR + -- TYPE. + + PROCEDURE NPROC IS NEW PROC (FIX1); + + BEGIN + NPROC ( "INCOMPATIBLE DELTA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "DELTA CONSTRAINT"); + END; + + -- TEST THAT CONSTRAINT_ERROR IS RAISED + -- FOR A RANGE VIOLATION. + + BEGIN + + DECLARE + + TYPE FIX2 IS DELTA 0.1 RANGE 0.0 .. 2.0; -- LOWER + -- BOUND. + + PROCEDURE NPROC IS NEW PROC (FIX2); + + BEGIN + NPROC ("FIXED POINT LOWER BOUND CONSTRAINT VIOLATION"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR " & + "LOWER BOUND VIOLATION"); + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "FIXED POINT LOWER BOUND CONSTRAINT"); + END; + + -- TEST THAT CONSTRAINT_ERROR IS RAISED + -- FOR A RANGE VIOLATION. + + BEGIN + + DECLARE + + TYPE FIX3 IS DELTA 0.1 RANGE -2.0 .. 0.0; -- UPPER + -- BOUND. + + PROCEDURE NPROC IS NEW PROC (FIX3); + BEGIN + NPROC ("FIXED POINT UPPER BOUND CONSTRAINT VIOLATION"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR " & + "UPPER BOUND VIOLATION"); + WHEN OTHERS => + FAILED ("INCORRECT EXCEPTION RAISED WHILE CHECKING " & + "FIXED POINT UPPER BOUND CONSTRAINT"); + END; + + RESULT; + + END C35904B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a02a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C35A02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT T'DELTA YIELDS CORRECT VALUES FOR SUBTYPE T. + + -- RJW 2/27/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C35A02A IS + + BEGIN + + TEST ( "C35A02A", "CHECK THAT T'DELTA YIELDS CORRECT VALUES " & + "FOR SUBTYPE T" ); + + DECLARE + D : CONSTANT := 0.125; + SD : CONSTANT := 1.0; + + TYPE VOLT IS DELTA D RANGE 0.0 .. 255.0; + SUBTYPE ROUGH_VOLTAGE IS VOLT DELTA SD; + + GENERIC + TYPE FIXED IS DELTA <> ; + FUNCTION F RETURN FIXED; + + FUNCTION F RETURN FIXED IS + BEGIN + RETURN FIXED'DELTA; + END F; + + FUNCTION VF IS NEW F (VOLT); + FUNCTION RF IS NEW F (ROUGH_VOLTAGE); + + BEGIN + IF VOLT'DELTA /= D THEN + FAILED ( "INCORRECT VALUE FOR VOLT'DELTA" ); + END IF; + IF ROUGH_VOLTAGE'DELTA /= SD THEN + FAILED ( "INCORRECT VALUE FOR ROUGH_VOLTAGE'DELTA" ); + END IF; + + IF VF /= D THEN + FAILED ( "INCORRECT VALUE FOR VF" ); + END IF; + IF RF /= SD THEN + FAILED ( "INCORRECT VALUE FOR RF" ); + END IF; + END; + + RESULT; + + END C35A02A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C35A05A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD + -- THE CORRECT VALUES. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- WRG 8/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C35A05A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5; + TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0; + TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0; + TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0; + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0; + TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0; + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16 + DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0; + SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE -2.0 .. 2.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_FORE_AND_AFT + (NAME : STRING; + ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE; + ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS + BEGIN + IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN + FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) ); + END IF; + IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN + FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) ); + END IF; + END CHECK_FORE_AND_AFT; + + BEGIN + + TEST ("C35A05A", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "BASIC TYPES"); + + CHECK_FORE_AND_AFT ("LEFT_OUT_M1", LEFT_OUT_M1'FORE, 2, + LEFT_OUT_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("LEFT_EDGE_M1", LEFT_EDGE_M1'FORE, 2, + LEFT_EDGE_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("RIGHT_EDGE_M1", RIGHT_EDGE_M1'FORE, 2, + RIGHT_EDGE_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("RIGHT_OUT_M1", RIGHT_OUT_M1'FORE, 2, + RIGHT_OUT_M1'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M2", MIDDLE_M2'FORE, 2, + MIDDLE_M2'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M3", MIDDLE_M3'FORE, 2, + MIDDLE_M3'AFT, 1); + + CHECK_FORE_AND_AFT ("MIDDLE_M15", MIDDLE_M15'FORE, 4, + MIDDLE_M15'AFT, 2); + + CHECK_FORE_AND_AFT ("MIDDLE_M16", MIDDLE_M16'FORE, 5, + MIDDLE_M16'AFT, 2); + + CHECK_FORE_AND_AFT ("LIKE_DURATION_M23", LIKE_DURATION_M23'FORE, 6, + LIKE_DURATION_M23'AFT, 2); + + CHECK_FORE_AND_AFT ("DECIMAL_M18", DECIMAL_M18'FORE, 6, + DECIMAL_M18'AFT, 1); + + IF DECIMAL_M4'FORE /= 5 AND DECIMAL_M4'FORE /= 4 THEN + FAILED ("DECIMAL_M4'FORE =" & + INTEGER'IMAGE(DECIMAL_M4'FORE) ); + END IF; + IF DECIMAL_M4'AFT /= 1 THEN + FAILED ("DECIMAL_M4'AFT =" & + INTEGER'IMAGE(DECIMAL_M4'AFT) ); + END IF; + + CHECK_FORE_AND_AFT ("DECIMAL_M11", DECIMAL_M11'FORE, 4, + DECIMAL_M11'AFT, 2); + + CHECK_FORE_AND_AFT ("DECIMAL2_M18", DECIMAL2_M18'FORE, 5, + DECIMAL2_M18'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_LEFT_EDGE_M6", ST_LEFT_EDGE_M6'FORE, 2, + ST_LEFT_EDGE_M6'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M14", ST_MIDDLE_M14'FORE, 4, + ST_MIDDLE_M14'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M2", ST_MIDDLE_M2'FORE, 2, + ST_MIDDLE_M2'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_MIDDLE_M3", ST_MIDDLE_M3'FORE, 2, + ST_MIDDLE_M3'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_DECIMAL_M7", ST_DECIMAL_M7'FORE, 5, + ST_DECIMAL_M7'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_DECIMAL_M3", ST_DECIMAL_M3'FORE, 4, + ST_DECIMAL_M3'AFT, 1); + + RESULT; + + END C35A05A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C35A05D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD + -- THE CORRECT VALUES. + + -- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC. + + -- WRG 8/14/86 + + WITH REPORT; USE REPORT; + PROCEDURE C35A05D IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := 23; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MICRO_ANGLE_ERROR_M15 IS + DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19; + TYPE TRACK_RANGE_M15 IS + DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12; + TYPE SECONDS_MM IS + DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8; + TYPE RANGE_CELL_MM IS + DELTA 2.0 ** (-5) + RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5); + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_FORE_AND_AFT + (NAME : STRING; + ACTUAL_FORE : INTEGER; CORRECT_FORE : POSITIVE; + ACTUAL_AFT : INTEGER; CORRECT_AFT : POSITIVE) IS + BEGIN + IF ACTUAL_FORE /= IDENT_INT (CORRECT_FORE) THEN + FAILED (NAME & "'FORE =" & INTEGER'IMAGE(ACTUAL_FORE) ); + END IF; + IF ACTUAL_AFT /= IDENT_INT (CORRECT_AFT) THEN + FAILED (NAME & "'AFT =" & INTEGER'IMAGE(ACTUAL_AFT) ); + END IF; + END CHECK_FORE_AND_AFT; + + BEGIN + + TEST ("C35A05D", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "TYPICAL TYPES"); + + CHECK_FORE_AND_AFT ("MICRO_ANGLE_ERROR_M15", + MICRO_ANGLE_ERROR_M15'FORE, 7, + MICRO_ANGLE_ERROR_M15'AFT, 1); + + CHECK_FORE_AND_AFT ("TRACK_RANGE_M15", TRACK_RANGE_M15'FORE, 5, + TRACK_RANGE_M15'AFT, 1); + + CHECK_FORE_AND_AFT ("SECONDS_MM", SECONDS_MM'FORE, 4, + SECONDS_MM'AFT, 5); + + CHECK_FORE_AND_AFT ("RANGE_CELL_MM", RANGE_CELL_MM'FORE, 7, + RANGE_CELL_MM'AFT, 2); + + CHECK_FORE_AND_AFT ("PIXEL_M10", PIXEL_M10'FORE, 2, + PIXEL_M10'AFT, 4); + + CHECK_FORE_AND_AFT ("RULER_M8", RULER_M8'FORE, 3, + RULER_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("HOURS_M16", HOURS_M16'FORE, 3, + HOURS_M16'AFT, 4); + + CHECK_FORE_AND_AFT ("MILES_M16", MILES_M16'FORE, 5, + MILES_M16'AFT, 2); + + CHECK_FORE_AND_AFT ("SYMMETRIC_DEGREES_M7", + SYMMETRIC_DEGREES_M7'FORE, 4, + SYMMETRIC_DEGREES_M7'AFT, 1); + + CHECK_FORE_AND_AFT ("NATURAL_DEGREES_M15", + NATURAL_DEGREES_M15'FORE, 4, + NATURAL_DEGREES_M15'AFT, 2); + + CHECK_FORE_AND_AFT ("SYMMETRIC_RADIANS_M16", + SYMMETRIC_RADIANS_M16'FORE, 2, + SYMMETRIC_RADIANS_M16'AFT, 5); + + CHECK_FORE_AND_AFT ("NATURAL_RADIANS_M8", + NATURAL_RADIANS_M8'FORE, 2, + NATURAL_RADIANS_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_MILES_M8", ST_MILES_M8'FORE, 3, + ST_MILES_M8'AFT, 2); + + CHECK_FORE_AND_AFT ("ST_NATURAL_DEGREES_M11", + ST_NATURAL_DEGREES_M11'FORE, 4, + ST_NATURAL_DEGREES_M11'AFT, 1); + + CHECK_FORE_AND_AFT ("ST_SYMMETRIC_RADIANS_M8", + ST_SYMMETRIC_RADIANS_M8'FORE, 2, + ST_SYMMETRIC_RADIANS_M8'AFT, 2); + + RESULT; + + END C35A05D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05n.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C35A05N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD + -- THE CORRECT VALUES. + + -- CASE N: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE, + -- FOR GENERICS. + + -- WRG 8/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE C35A05N IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LEFT_OUT_M1 IS DELTA 0.25 RANGE -0.5 .. 0.5; + TYPE LEFT_EDGE_M1 IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE RIGHT_EDGE_M1 IS DELTA 1.0 RANGE -2.0 .. 2.0; + TYPE RIGHT_OUT_M1 IS DELTA 2.0 RANGE -4.0 .. 4.0; + TYPE MIDDLE_M2 IS DELTA 0.5 RANGE -2.0 .. 2.0; + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE MIDDLE_M16 IS DELTA 2.0 **(-6) RANGE -1024.0 .. 1024.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + TYPE DECIMAL_M11 IS DELTA 0.09999 RANGE -100.0 .. 100.0; + TYPE DECIMAL2_M18 IS DELTA 0.1 RANGE -9999.0 .. 9999.0; + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M14 IS MIDDLE_M16 + DELTA 2.0 ** (-5) RANGE -512.0 .. IDENT_INT (1) * 512.0; + SUBTYPE ST_MIDDLE_M2 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE -2.0 .. 2.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + + ------------------------------------------------------------------- + + TYPE FORE_AND_AFT IS + RECORD + FORE, AFT : INTEGER; + END RECORD; + + GENERIC + TYPE T IS DELTA <>; + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT; + + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS + BEGIN + RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) ); + END ATTRIBUTES; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_ATTRIBUTES + (NAME : STRING; + ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS + BEGIN + IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN + FAILED ("GENERIC 'FORE FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) ); + END IF; + IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN + FAILED ("GENERIC 'AFT FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) ); + END IF; + END CHECK_ATTRIBUTES; + + ------------------------------------------------------------------- + + FUNCTION FA_LEFT_OUT_M1 IS NEW ATTRIBUTES(LEFT_OUT_M1 ); + FUNCTION FA_LEFT_EDGE_M1 IS NEW ATTRIBUTES(LEFT_EDGE_M1 ); + FUNCTION FA_RIGHT_EDGE_M1 IS NEW ATTRIBUTES(RIGHT_EDGE_M1 ); + FUNCTION FA_RIGHT_OUT_M1 IS NEW ATTRIBUTES(RIGHT_OUT_M1 ); + FUNCTION FA_MIDDLE_M2 IS NEW ATTRIBUTES(MIDDLE_M2 ); + FUNCTION FA_MIDDLE_M3 IS NEW ATTRIBUTES(MIDDLE_M3 ); + FUNCTION FA_MIDDLE_M15 IS NEW ATTRIBUTES(MIDDLE_M15 ); + FUNCTION FA_MIDDLE_M16 IS NEW ATTRIBUTES(MIDDLE_M16 ); + FUNCTION FA_LIKE_DURATION_M23 IS NEW ATTRIBUTES(LIKE_DURATION_M23); + FUNCTION FA_DECIMAL_M18 IS NEW ATTRIBUTES(DECIMAL_M18 ); + FUNCTION FA_DECIMAL_M4 IS NEW ATTRIBUTES(DECIMAL_M4 ); + FUNCTION FA_DECIMAL_M11 IS NEW ATTRIBUTES(DECIMAL_M11 ); + FUNCTION FA_DECIMAL2_M18 IS NEW ATTRIBUTES(DECIMAL2_M18 ); + FUNCTION FA_ST_LEFT_EDGE_M6 IS NEW ATTRIBUTES(ST_LEFT_EDGE_M6 ); + FUNCTION FA_ST_MIDDLE_M14 IS NEW ATTRIBUTES(ST_MIDDLE_M14 ); + FUNCTION FA_ST_MIDDLE_M2 IS NEW ATTRIBUTES(ST_MIDDLE_M2 ); + FUNCTION FA_ST_MIDDLE_M3 IS NEW ATTRIBUTES(ST_MIDDLE_M3 ); + FUNCTION FA_ST_DECIMAL_M7 IS NEW ATTRIBUTES(ST_DECIMAL_M7 ); + FUNCTION FA_ST_DECIMAL_M3 IS NEW ATTRIBUTES(ST_DECIMAL_M3 ); + + BEGIN + + TEST ("C35A05N", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "BASIC TYPES, GENERICS"); + + CHECK_ATTRIBUTES ("LEFT_OUT_M1", FA_LEFT_OUT_M1, (2, 1) ); + CHECK_ATTRIBUTES ("LEFT_EDGE_M1", FA_LEFT_EDGE_M1, (2, 1) ); + CHECK_ATTRIBUTES ("RIGHT_EDGE_M1", FA_RIGHT_EDGE_M1, (2, 1) ); + CHECK_ATTRIBUTES ("RIGHT_OUT_M1", FA_RIGHT_OUT_M1, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M2", FA_MIDDLE_M2, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M3", FA_MIDDLE_M3, (2, 1) ); + CHECK_ATTRIBUTES ("MIDDLE_M15", FA_MIDDLE_M15, (4, 2) ); + CHECK_ATTRIBUTES ("MIDDLE_M16", FA_MIDDLE_M16, (5, 2) ); + CHECK_ATTRIBUTES ("LIKE_DURATION_M23", + FA_LIKE_DURATION_M23, (6, 2) ); + CHECK_ATTRIBUTES ("DECIMAL_M18", FA_DECIMAL_M18, (6, 1) ); + + IF FA_DECIMAL_M4.FORE /= 5 AND FA_DECIMAL_M4.FORE /= 4 THEN + FAILED ("GENERIC 'FORE FOR DECIMAL_M4 =" & + INTEGER'IMAGE(FA_DECIMAL_M4.FORE) ); + END IF; + IF FA_DECIMAL_M4.AFT /= 1 THEN + FAILED ("GENERIC 'AFT FOR DECIMAL_M4 =" & + INTEGER'IMAGE(FA_DECIMAL_M4.AFT) ); + END IF; + + CHECK_ATTRIBUTES ("DECIMAL_M11", FA_DECIMAL_M11, (4, 2) ); + CHECK_ATTRIBUTES ("DECIMAL2_M18", FA_DECIMAL2_M18, (5, 1) ); + CHECK_ATTRIBUTES ("ST_LEFT_EDGE_M6", FA_ST_LEFT_EDGE_M6, (2, 2) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M14", FA_ST_MIDDLE_M14, (4, 2) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M2", FA_ST_MIDDLE_M2, (2, 1) ); + CHECK_ATTRIBUTES ("ST_MIDDLE_M3", FA_ST_MIDDLE_M3, (2, 1) ); + CHECK_ATTRIBUTES ("ST_DECIMAL_M7", FA_ST_DECIMAL_M7, (5, 1) ); + CHECK_ATTRIBUTES ("ST_DECIMAL_M3", FA_ST_DECIMAL_M3, (4, 1) ); + + RESULT; + + END C35A05N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a05q.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C35A05Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FORE AND AFT ATTRIBUTES YIELD + -- THE CORRECT VALUES. + + -- CASE Q: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC, + -- FOR GENERICS. + + -- WRG 8/20/86 + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C35A05Q IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := 23; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MICRO_ANGLE_ERROR_M15 IS + DELTA 16.0 RANGE -(2.0 ** 19) .. 2.0 ** 19; + TYPE TRACK_RANGE_M15 IS + DELTA 0.125 RANGE -(2.0 ** 12) .. 2.0 ** 12; + TYPE SECONDS_MM IS + DELTA 2.0 ** (8 - MM) RANGE -(2.0 ** 8) .. 2.0 ** 8; + TYPE RANGE_CELL_MM IS + DELTA 2.0 ** (-5) + RANGE -(2.0 ** (MM - 5) ) .. 2.0 ** (MM - 5); + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + + ------------------------------------------------------------------- + + TYPE FORE_AND_AFT IS + RECORD + FORE, AFT : INTEGER; + END RECORD; + + GENERIC + TYPE T IS DELTA <>; + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT; + + FUNCTION ATTRIBUTES RETURN FORE_AND_AFT IS + BEGIN + RETURN ( IDENT_INT (T'FORE), IDENT_INT (T'AFT) ); + END ATTRIBUTES; + + ------------------------------------------------------------------- + + PROCEDURE CHECK_ATTRIBUTES + (NAME : STRING; + ACTUAL_ATTRIBUTES, CORRECT_ATTRIBUTES : FORE_AND_AFT) IS + BEGIN + IF ACTUAL_ATTRIBUTES.FORE /= CORRECT_ATTRIBUTES.FORE THEN + FAILED ("GENERIC 'FORE FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.FORE) ); + END IF; + IF ACTUAL_ATTRIBUTES.AFT /= CORRECT_ATTRIBUTES.AFT THEN + FAILED ("GENERIC 'AFT FOR " & NAME & " =" & + INTEGER'IMAGE(ACTUAL_ATTRIBUTES.AFT ) ); + END IF; + END CHECK_ATTRIBUTES; + + ------------------------------------------------------------------- + + FUNCTION FA_MICRO_ANGLE_ERROR_M15 + IS NEW ATTRIBUTES(MICRO_ANGLE_ERROR_M15 ); + FUNCTION FA_TRACK_RANGE_M15 + IS NEW ATTRIBUTES(TRACK_RANGE_M15 ); + FUNCTION FA_SECONDS_MM IS NEW ATTRIBUTES(SECONDS_MM ); + FUNCTION FA_RANGE_CELL_MM + IS NEW ATTRIBUTES(RANGE_CELL_MM ); + FUNCTION FA_PIXEL_M10 IS NEW ATTRIBUTES(PIXEL_M10 ); + FUNCTION FA_RULER_M8 IS NEW ATTRIBUTES(RULER_M8 ); + FUNCTION FA_HOURS_M16 IS NEW ATTRIBUTES(HOURS_M16 ); + FUNCTION FA_MILES_M16 IS NEW ATTRIBUTES(MILES_M16 ); + FUNCTION FA_SYMMETRIC_DEGREES_M7 + IS NEW ATTRIBUTES(SYMMETRIC_DEGREES_M7 ); + FUNCTION FA_NATURAL_DEGREES_M15 + IS NEW ATTRIBUTES(NATURAL_DEGREES_M15 ); + FUNCTION FA_SYMMETRIC_RADIANS_M16 + IS NEW ATTRIBUTES(SYMMETRIC_RADIANS_M16 ); + FUNCTION FA_NATURAL_RADIANS_M8 + IS NEW ATTRIBUTES(NATURAL_RADIANS_M8 ); + FUNCTION FA_ST_MILES_M8 IS NEW ATTRIBUTES(ST_MILES_M8 ); + FUNCTION FA_ST_NATURAL_DEGREES_M11 + IS NEW ATTRIBUTES(ST_NATURAL_DEGREES_M11 ); + FUNCTION FA_ST_SYMMETRIC_RADIANS_M8 + IS NEW ATTRIBUTES(ST_SYMMETRIC_RADIANS_M8); + + BEGIN + + TEST ("C35A05Q", "CHECK THAT FOR FIXED POINT TYPES THE FORE AND " & + "AFT ATTRIBUTES YIELD THE CORRECT VALUES - " & + "TYPICAL TYPES, GENERICS"); + + CHECK_ATTRIBUTES ("MICRO_ANGLE_ERROR_M15", + FA_MICRO_ANGLE_ERROR_M15, (7, 1) ); + + CHECK_ATTRIBUTES ("TRACK_RANGE_M15", FA_TRACK_RANGE_M15, (5, 1) ); + + CHECK_ATTRIBUTES ("SECONDS_MM", FA_SECONDS_MM, (4, 5) ); + + CHECK_ATTRIBUTES ("RANGE_CELL_MM", FA_RANGE_CELL_MM, (7, 2) ); + + CHECK_ATTRIBUTES ("PIXEL_M10", FA_PIXEL_M10, (2, 4) ); + + CHECK_ATTRIBUTES ("RULER_M8", FA_RULER_M8, (3, 2) ); + + CHECK_ATTRIBUTES ("HOURS_M16", FA_HOURS_M16, (3, 4) ); + + CHECK_ATTRIBUTES ("MILES_M16", FA_MILES_M16, (5, 2) ); + + CHECK_ATTRIBUTES ("SYMMETRIC_DEGREES_M7", + FA_SYMMETRIC_DEGREES_M7, (4, 1) ); + + CHECK_ATTRIBUTES ("NATURAL_DEGREES_M15", + FA_NATURAL_DEGREES_M15, (4, 2) ); + + CHECK_ATTRIBUTES ("SYMMETRIC_RADIANS_M16", + FA_SYMMETRIC_RADIANS_M16, (2, 5) ); + + CHECK_ATTRIBUTES ("NATURAL_RADIANS_M8", + FA_NATURAL_RADIANS_M8, (2, 2) ); + + CHECK_ATTRIBUTES ("ST_MILES_M8", FA_ST_MILES_M8, (3, 2) ); + + CHECK_ATTRIBUTES ("ST_NATURAL_DEGREES_M11", + FA_ST_NATURAL_DEGREES_M11, (4, 1) ); + + CHECK_ATTRIBUTES ("ST_SYMMETRIC_RADIANS_M8", + FA_ST_SYMMETRIC_RADIANS_M8, (2, 2) ); + + RESULT; + + END C35A05Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a07a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C35A07A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD + -- CORRECT VALUES. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- WRG 8/25/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE C35A07A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE MIDDLE_M15 IS DELTA 2.0 **(-6) RANGE -512.0 .. 512.0; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M18 IS DELTA 0.1 RANGE -10_000.0 .. 10_000.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + -- LARGEST MODEL NUMBER IS 960.0. + + ------------------------------------------------------------------- + + SUBTYPE ST_LEFT_EDGE_M6 IS MIDDLE_M15 + DELTA 2.0 ** (-6) RANGE IDENT_INT (1) * (-1.0) .. 1.0; + SUBTYPE ST_MIDDLE_M3 IS LIKE_DURATION_M23 + DELTA 0.5 RANGE 0.0 .. 2.5; + SUBTYPE ST_DECIMAL_M7 IS DECIMAL_M18 + DELTA 10.0 RANGE -1000.0 .. 1000.0; + -- LARGEST MODEL NUMBER IS 1016.0. + SUBTYPE ST_DECIMAL_M3 IS DECIMAL_M4 + DELTA 100.0 RANGE -500.0 .. 500.0; + -- LARGEST MODEL NUMBER IS 448.0. + SUBTYPE ST_MIDDLE_M15 IS MIDDLE_M15 + RANGE 6.0 .. 3.0; + + BEGIN + + TEST ("C35A07A", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " & + "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " & + "BASIC TYPES"); + + ------------------------------------------------------------------- + + + IF MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("MIDDLE_M3'FIRST /= 0.0"); + END IF; + IF MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN + FAILED ("MIDDLE_M3'LAST /= 2.5"); + END IF; + + ------------------------------------------------------------------- + + + IF LIKE_DURATION_M23'FIRST /= IDENT_INT (1) * (-86_400.0) THEN + FAILED ("LIKE_DURATION_M23'FIRST /= -86_400.0"); + END IF; + IF LIKE_DURATION_M23'LAST /= IDENT_INT (1) * 86_400.0 THEN + FAILED ("LIKE_DURATION_M23'LAST /= 86_400.0"); + END IF; + + ------------------------------------------------------------------- + + IF DECIMAL_M18'FIRST /= IDENT_INT (1) * (-10_000.0) THEN + FAILED ("DECIMAL_M18'FIRST /= -10_000.0"); + END IF; + IF DECIMAL_M18'LAST /= IDENT_INT (1) * 10_000.0 THEN + FAILED ("DECIMAL_M18'LAST /= 10_000.0"); + END IF; + + ------------------------------------------------------------------- + + + IF ST_MIDDLE_M3'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_MIDDLE_M3'FIRST /= 0.0"); + END IF; + IF ST_MIDDLE_M3'LAST /= IDENT_INT (1) * 2.5 THEN + FAILED ("ST_MIDDLE_M3'LAST /= 2.5"); + END IF; + + ------------------------------------------------------------------- + + IF ST_DECIMAL_M7'FIRST /= IDENT_INT (1) * (-1000.0) THEN + FAILED ("ST_DECIMAL_M7'FIRST /= -1000.0"); + END IF; + IF ST_DECIMAL_M7'LAST /= IDENT_INT (1) * 1000.0 THEN + FAILED ("ST_DECIMAL_M7'LAST /= 1000.0"); + END IF; + + ------------------------------------------------------------------- + + + IF ST_MIDDLE_M15'FIRST /= IDENT_INT (1) * 6.0 THEN + FAILED ("ST_MIDDLE_M15'FIRST /= 6.0"); + END IF; + IF ST_MIDDLE_M15'LAST /= IDENT_INT (1) * 3.0 THEN + FAILED ("ST_MIDDLE_M15'LAST /= 3.0"); + END IF; + + ------------------------------------------------------------------- + + RESULT; + + END C35A07A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a07d.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C35A07D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE FIRST AND LAST ATTRIBUTES YIELD + -- CORRECT VALUES. + + -- CASE D: TYPES TYPICAL OF APPLICATIONS USING FIXED POINT ARITHMETIC. + + -- WRG 8/25/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C35A07D IS + + PI : CONSTANT := 3.14159_26535_89793_23846; + TWO_PI : CONSTANT := 2 * PI; + HALF_PI : CONSTANT := PI / 2; + + MM : CONSTANT := MAX_MANTISSA; + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE PIXEL_M10 IS DELTA 1.0 / 1024.0 RANGE 0.0 .. 1.0; + TYPE RULER_M8 IS DELTA 1.0 / 16.0 RANGE 0.0 .. 12.0; + + TYPE HOURS_M16 IS DELTA 24.0 * 2.0 ** (-15) RANGE 0.0 .. 24.0; + TYPE MILES_M16 IS DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 3000.0; + + TYPE SYMMETRIC_DEGREES_M7 IS + DELTA 2.0 RANGE -180.0 .. 180.0; + TYPE NATURAL_DEGREES_M15 IS + DELTA 2.0 ** (-6) RANGE 0.0 .. 360.0; + TYPE SYMMETRIC_RADIANS_M16 IS + DELTA PI * 2.0 ** (-15) RANGE -PI .. PI; + -- 'SMALL = 2.0 ** (-14) = 0.00006_10351_5625. + TYPE NATURAL_RADIANS_M8 IS + DELTA TWO_PI * 2.0 ** ( -7) RANGE 0.0 .. TWO_PI; + -- 'SMALL = 2.0 ** ( -5) = 0.03125. + + ------------------------------------------------------------------- + + SUBTYPE ST_MILES_M8 IS MILES_M16 + DELTA 3000.0 * 2.0 ** (-15) RANGE 0.0 .. 10.0; + SUBTYPE ST_NATURAL_DEGREES_M11 IS NATURAL_DEGREES_M15 + DELTA 0.25 RANGE 0.0 .. 360.0; + SUBTYPE ST_SYMMETRIC_RADIANS_M8 IS SYMMETRIC_RADIANS_M16 + DELTA HALF_PI * 2.0 ** (-7) RANGE -HALF_PI .. HALF_PI; + -- 'SMALL = 2.0 ** ( -7) = 0.00781_25. + + BEGIN + + TEST ("C35A07D", "CHECK THAT FOR FIXED POINT TYPES THE FIRST " & + "AND LAST ATTRIBUTES YIELD CORRECT VALUES - " & + "TYPICAL TYPES"); + + ------------------------------------------------------------------- + + + IF PIXEL_M10'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("PIXEL_M10'FIRST /= 0.0"); + END IF; + + ------------------------------------------------------------------- + + IF RULER_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("RULER_M8'FIRST /= 0.0"); + END IF; + IF RULER_M8'LAST /= IDENT_INT (1) * 12.0 THEN + FAILED ("RULER_M8'LAST /= 12.0"); + END IF; + + ------------------------------------------------------------------- + + IF HOURS_M16'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("HOURS_M16'FIRST /= 0.0"); + END IF; + IF HOURS_M16'LAST /= IDENT_INT (1) * 24.0 THEN + FAILED ("HOURS_M16'LAST /= 24.0"); + END IF; + + ------------------------------------------------------------------- + + IF MILES_M16'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("MILES_M16'FIRST /= 0.0"); + END IF; + IF MILES_M16'LAST /= IDENT_INT (1) * 3000.0 THEN + FAILED ("MILES_M16'LAST /= 3000.0"); + END IF; + + ------------------------------------------------------------------- + + IF SYMMETRIC_DEGREES_M7'FIRST /= IDENT_INT (1) * (-180.0) THEN + FAILED ("SYMMETRIC_DEGREES_M7'FIRST /= -180.0"); + END IF; + IF SYMMETRIC_DEGREES_M7'LAST /= IDENT_INT (1) * 180.0 THEN + FAILED ("SYMMETRIC_DEGREES_M7'LAST /= 180.0"); + END IF; + + ------------------------------------------------------------------- + + IF NATURAL_DEGREES_M15'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("NATURAL_DEGREES_M15'FIRST /= 0.0"); + END IF; + IF NATURAL_DEGREES_M15'LAST /= IDENT_INT (1) * 360.0 THEN + FAILED ("NATURAL_DEGREES_M15'LAST /= 360.0"); + END IF; + + ------------------------------------------------------------------- + + -- PI IS IN 3.0 + 2319 * 'SMALL .. 3.0 + 2320 * 'SMALL. + IF SYMMETRIC_RADIANS_M16'FIRST NOT IN + -3.14160_15625 .. -3.14154_05273_4375 THEN + FAILED ("SYMMETRIC_RADIANS_M16'FIRST NOT IN " & + "-3.14160_15625 .. -3.14154_05273_4375"); + END IF; + IF SYMMETRIC_RADIANS_M16'LAST NOT IN + 3.14154_05273_4375 .. 3.14160_15625 THEN + FAILED ("SYMMETRIC_RADIANS_M16'LAST NOT IN " & + "3.14154_05273_4375 .. 3.14160_15625"); + END IF; + + ------------------------------------------------------------------- + + IF NATURAL_RADIANS_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("NATURAL_RADIANS_M8'FIRST /= 0.0"); + END IF; + -- TWO_PI IS IN 201 * 'SMALL .. 202 * 'SMALL. + IF NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125 THEN + FAILED ("NATURAL_RADIANS_M8'LAST NOT IN 6.28125 .. 6.3125"); + END IF; + + ------------------------------------------------------------------- + + IF ST_MILES_M8'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_MILES_M8'FIRST /= 0.0"); + END IF; + IF ST_MILES_M8'LAST /= IDENT_INT (1) * 10.0 THEN + FAILED ("ST_MILES_M8'LAST /= 10.0"); + END IF; + + ------------------------------------------------------------------- + + IF ST_NATURAL_DEGREES_M11'FIRST /= IDENT_INT (1) * 0.0 THEN + FAILED ("ST_NATURAL_DEGREES_M11'FIRST /= 0.0"); + END IF; + IF ST_NATURAL_DEGREES_M11'LAST /= IDENT_INT (1) * 360.0 THEN + FAILED ("ST_NATURAL_DEGREES_M11'LAST /= 360.0"); + END IF; + + ------------------------------------------------------------------- + + -- HALF_PI IS IN 201 * 'SMALL .. 202 * 'SMALL. + IF ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN + -1.57812_5 .. -1.57031_25 THEN + FAILED ("ST_SYMMETRIC_RADIANS_M8'FIRST NOT IN " & + "-1.57812_5 .. -1.57031_25"); + END IF; + IF ST_SYMMETRIC_RADIANS_M8'LAST NOT IN + 1.57031_25 .. 1.57812_5 THEN + FAILED ("ST_SYMMETRIC_RADIANS_M8'LAST NOT IN " & + "1.57031_25 .. 1.57812_5"); + END IF; + + ------------------------------------------------------------------- + + RESULT; + + END C35A07D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c35a08b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C35A08B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE MULTIPLICATION AND DIVISION OPERATORS FOR TWO + -- FIXED POINT OPERANDS ARE DECLARED IN STANDARD AND ARE DIRECTLY + -- VISIBLE. + + -- HISTORY: + -- BCB 01/21/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C35A08B IS + + PACKAGE P IS + TYPE T1 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0; + TYPE T2 IS DELTA 2.0**(-4) RANGE -100.0 .. 100.0; + END P; + USE P; + + X1 : P.T1 := 6.0; + X2 : P.T1 := 2.0; + X3 : P.T1; + X4 : P.T1; + X5 : P.T1; + X6 : P.T1; + + X7 : P.T2 := 2.0; + + FUNCTION IDENT_FIXED(X : P.T1) RETURN P.T1 IS + BEGIN + RETURN X * IDENT_INT(1); + END IDENT_FIXED; + + BEGIN + TEST ("C35A08B", "CHECK THAT THE MULTIPLICATION AND DIVISION " & + "OPERATORS FOR TWO FIXED POINT OPERANDS ARE " & + "DECLARED IN STANDARD AND ARE DIRECTLY VISIBLE"); + + X3 := P.T1 (X1 * X2); + X4 := P.T1 (X1 / X2); + + X5 := P.T1 (STANDARD."*" (X1,X2)); + X6 := P.T1 (STANDARD."/" (X1,X2)); + + IF X3 /= IDENT_FIXED (12.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 1"); + END IF; + + IF X4 /= IDENT_FIXED (3.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 1"); + END IF; + + X3 := P.T1 (X1 * X7); + X4 := P.T1 (X1 / X7); + + X5 := P.T1 (STANDARD."*" (X1,X7)); + X6 := P.T1 (STANDARD."/" (X1,X7)); + + IF X3 /= IDENT_FIXED (12.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT MULTIPLICATION - 2"); + END IF; + + IF X4 /= IDENT_FIXED (3.0) THEN + FAILED ("IMPROPER VALUE FOR FIXED POINT DIVISION - 2"); + END IF; + + RESULT; + END C35A08B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c360002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c360002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c360002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c360002.a 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,268 ---- + -- C360002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that modular types may be used as array indices. + -- + -- Check that if aliased appears in the component_definition of an + -- array_type that each component of the array is aliased. + -- + -- Check that references to aliased array objects produce correct + -- results, and that out-of-bounds indexing correctly produces + -- Constraint_Error. + -- + -- TEST DESCRIPTION: + -- This test defines several array types and subtypes indexed by modular + -- types; some aliased some not, some with aliased components, some not. + -- + -- It then checks that assignments move the correct data. + -- + -- + -- CHANGE HISTORY: + -- 28 SEP 95 SAIC Initial version + -- 23 APR 96 SAIC Doc fixes, fixed constrained/unconstrained conflict + -- 13 FEB 97 PWB.CTA Removed illegal declarations and affected code + --! + + ------------------------------------------------------------------- C360002 + + with Report; + + procedure C360002 is + + Verbose : Boolean := Report.Ident_Bool( False ); + + type Mod_128 is mod 128; + + function Ident_128( I: Integer ) return Mod_128 is + begin + return Mod_128( Report.Ident_Int( I ) ); + end Ident_128; + + type Unconstrained_Array + is array( Mod_128 range <> ) of Integer; + + type Unconstrained_Array_Aliased + is array( Mod_128 range <> ) of aliased Integer; + + type Access_All_Unconstrained_Array + is access all Unconstrained_Array; + + type Access_All_Unconstrained_Array_Aliased + is access all Unconstrained_Array_Aliased; + + subtype Array_01_10 + is Unconstrained_Array(01..10); + + subtype Array_11_20 + is Unconstrained_Array(11..20); + + subtype Array_Aliased_01_10 + is Unconstrained_Array_Aliased(01..10); + + subtype Array_Aliased_11_20 + is Unconstrained_Array_Aliased(11..20); + + subtype Access_All_01_10_Array + is Access_All_Unconstrained_Array(01..10); + + subtype Access_All_01_10_Array_Aliased + is Access_All_Unconstrained_Array_Aliased(01..10); + + subtype Access_All_11_20_Array + is Access_All_Unconstrained_Array(11..20); + + subtype Access_All_11_20_Array_Aliased + is Access_All_Unconstrained_Array_Aliased(11..20); + + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- these 'filler' functions create unique values for every element that + -- is used and/or tested in this test. + + Well_Bottom : Integer := 0; + + function Filler( Size : Mod_128 ) return Unconstrained_Array is + It : Unconstrained_Array( 0..Size-1 ); + begin + for Eyes in It'Range loop + It(Eyes) := Integer( Eyes ) + Well_Bottom; + end loop; + Well_Bottom := Well_Bottom + It'Length; + return It; + end Filler; + + function Filler( Size : Mod_128 ) return Unconstrained_Array_Aliased is + It : Unconstrained_Array_Aliased( 0..Size-1 ); + begin + for Ayes in It'Range loop + It(Ayes) := Integer( Ayes ) + Well_Bottom; + end loop; + Well_Bottom := Well_Bottom + It'Length; + return It; + end Filler; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + An_Integer : Integer; + + type AAI is access all Integer; + + An_Integer_Access : AAI; + + Array_Item_01_10 : Array_01_10 := Filler(10); -- 0..9 + + Array_Item_11_20 : Array_11_20 := Filler(10); -- 10..19 (sliding) + + Array_Aliased_Item_01_10 : Array_Aliased_01_10 := Filler(10); -- 20..29 + + Array_Aliased_Item_11_20 : Array_Aliased_11_20 := Filler(10); -- 30..39 + + Aliased_Array_Item_01_10 : aliased Array_01_10 := Filler(10); -- 40..49 + + Aliased_Array_Item_11_20 : aliased Array_11_20 := Filler(10); -- 50..59 + + Aliased_Array_Aliased_Item_01_10 : aliased Array_Aliased_01_10 + := Filler(10); -- 60..69 + + Aliased_Array_Aliased_Item_11_20 : aliased Array_Aliased_11_20 + := Filler(10); -- 70..79 + + Check_Item : Access_All_Unconstrained_Array; + + Check_Aliased_Item : Access_All_Unconstrained_Array_Aliased; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + procedure Fail( Message : String; CI, SB : Integer ) is + begin + Report.Failed("Wrong value passed " & Message); + if Verbose then + Report.Comment("got" & Integer'Image(CI) & + " should be" & Integer'Image(SB) ); + end if; + end Fail; + + procedure Check_Array_01_10( Checked_Item : Array_01_10; + Low_SB : Integer ) is + begin + for Index in Checked_Item'Range loop + if (Checked_Item(Index) /= (Low_SB +Integer(Index)-1)) then + Fail("unaliased 1..10", Checked_Item(Index), + (Low_SB +Integer(Index)-1)); + end if; + end loop; + end Check_Array_01_10; + + procedure Check_Array_11_20( Checked_Item : Array_11_20; + Low_SB : Integer ) is + begin + for Index in Checked_Item'Range loop + if (Checked_Item(Index) /= (Low_SB +Integer(Index)-11)) then + Fail("unaliased 11..20", Checked_Item(Index), + (Low_SB +Integer(Index)-11)); + end if; + end loop; + end Check_Array_11_20; + + procedure Check_Single_Integer( The_Integer, SB : Integer; + Message : String ) is + begin + if The_Integer /= SB then + Report.Failed("Wrong integer value for " & Message ); + end if; + end Check_Single_Integer; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("C360002", "Check that modular types may be used as array " & + "indices. Check that if aliased appears in " & + "the component_definition of an array_type that " & + "each component of the array is aliased. Check " & + "that references to aliased array objects " & + "produce correct results, and that out of bound " & + "references to aliased objects correctly " & + "produce Constraint_Error" ); + -- start with checks that the Filler assignments produced the expected + -- result. This is a "case 0" test to check that nothing REALLY surprising + -- is happening + + Check_Array_01_10( Array_Item_01_10, 0 ); + Check_Array_11_20( Array_Item_11_20, 10 ); + + -- check that having the variable aliased makes no difference + Check_Array_01_10( Aliased_Array_Item_01_10, 40 ); + Check_Array_11_20( Aliased_Array_Item_11_20, 50 ); + + -- now check that conversion between array types where the only + -- difference in the definitions is that the components are aliased works + + Check_Array_01_10( Unconstrained_Array( Array_Aliased_Item_01_10 ), 20 ); + Check_Array_11_20( Unconstrained_Array( Array_Aliased_Item_11_20 ), 30 ); + + -- check that conversion of an aliased object with aliased components + -- also works + + Check_Array_01_10( Unconstrained_Array( Aliased_Array_Aliased_Item_01_10 ), + 60 ); + Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), + 70 ); + + -- check that the bounds will slide + + Check_Array_01_10( Array_01_10( Array_Item_11_20 ), 10 ); + Check_Array_11_20( Array_11_20( Array_Item_01_10 ), 0 ); + + -- point at some of the components and check them + + An_Integer_Access := Array_Aliased_Item_01_10(5)'Access; + + Check_Single_Integer( An_Integer_Access.all, 24, + "Aliased component 'Access"); + + An_Integer_Access := Aliased_Array_Aliased_Item_01_10(7)'Access; + + Check_Single_Integer( An_Integer_Access.all, 66, + "Aliased Aliased component 'Access"); + + -- check some assignments + + Array_Item_01_10 := Aliased_Array_Item_01_10; + Check_Array_01_10( Array_Item_01_10, 40 ); + + Aliased_Array_Item_01_10 := Aliased_Array_Item_11_20(11..20); + Check_Array_01_10( Aliased_Array_Item_01_10, 50 ); + + Aliased_Array_Aliased_Item_11_20(11..20) + := Aliased_Array_Aliased_Item_01_10; + Check_Array_11_20( Unconstrained_Array( Aliased_Array_Aliased_Item_11_20 ), + 60 ); + + Report.Result; + + end C360002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36104a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,359 ---- + -- C36104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE, + -- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS, + -- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES, + -- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, + -- WHERE AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE. + -- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT + -- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES. + -- ONLY STATIC CASES ARE CHECKED HERE. + + -- DAT 2/3/81 + -- JRK 2/25/81 + -- VKG 1/21/83 + -- L.BROWN 7/15/86 1) ADDED ACCESS TYPES. + -- 2) DELETED "NULL INDEX RANGES, CONSTRAINT_ERROR + -- RAISED" SECTION. + -- 3) DELETED ANY MENTION OF CASE STATEMENT CHOICES + -- AND VARIANT CHOICES IN THE ABOVE COMMENT. + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C36104A IS + + USE REPORT; + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK; + SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI; + SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU; + + TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10; + TYPE I_10 IS NEW INT_10; + SUBTYPE I_5 IS I_10 RANGE -5 .. 5; + TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5; + + BEGIN + TEST ("C36104A", "CONSTRAINT_ERROR IS RAISED OR NOT IN STATIC " + & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS"); + + -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5; + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + A1 : A := (OTHERS => I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " & + I_5'IMAGE(A1(1)) ); --USE A1 + END; + EXCEPTION + --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS + --REPORT FAILED. + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE MON .. MON LOOP + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + END LOOP; + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (I_5 RANGE 0 .. 6); + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + TYPE PA IS NEW P; + -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID + -- OPTIMIZATION OF TYPE + PA1 : PA := NEW I_5_ARRAY'(0 .. I_5(IDENT_INT(6)) => + I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " & + I_5'IMAGE(PA1(1))); --USE PA1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (MID_WEEK RANGE MON .. WED => WED); + -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (WORK_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION. + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI); + -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR. + BEGIN + W := (W'RANGE => WED); -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 9"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. TUE); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + W1 : W := (OTHERS => WED); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " & + MID_WEEK'IMAGE(W1(WED))); --USE W1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 10"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. WED); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + W1 : W := (OTHERS => (WED)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W1(WED))); --USE W1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE -5 .. -6) OF I_5; + A1 : A; + BEGIN + IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE SAT .. SUN LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN MID_WEEK RANGE FRI .. WED LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN MID_WEEK RANGE MON .. SUN LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 10 .. -10 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 10 .. 9 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE -10 .. -11 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE -10 .. -20 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + FOR I IN I_5 RANGE 6 .. 5 LOOP + FAILED("LOOP WAS EXECUTED WITH NULL DISCRETE/INDEX RANGES"); + END LOOP; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (-5 .. -6); + PA1 : P := NEW I_5_ARRAY (-5 .. -6); + BEGIN + IF PA1'LENGTH /= IDENT_INT(0) THEN + FAILED ("'LENGTH OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 5"); + END; + + DECLARE + TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARR IS INTEGER RANGE 1 .. 2; + W : NARR(SNARR) := (1,2); + BEGIN + IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN + FAILED("EVALUATION OF EXPRESSION IS INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN); + BEGIN + IF (W'FIRST /= MON) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + W1 : W; + BEGIN + IF (W1'FIRST /= TUE) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + W1 : W; + BEGIN + IF (W1'FIRST /= TUE) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 12"); + END; + + -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED. + + BEGIN + IF SUN IN SAT .. SUN + OR SAT IN FRI .. WED + OR WED IN THU .. TUE + OR THU IN MON .. SUN + OR FRI IN SAT .. FRI + OR WED IN FRI .. MON + THEN + FAILED ("INCORRECT 'IN' EVALUATION 1"); + END IF; + + IF INTEGER'(0) IN 10 .. -10 + OR INTEGER'(0) IN 10 .. 9 + OR INTEGER'(0) IN -10 .. -11 + OR INTEGER'(0) IN -10 .. -20 + OR INTEGER'(0) IN 6 .. 5 + OR INTEGER'(0) IN 5 .. 3 + OR INTEGER'(0) IN 7 .. 3 + THEN + FAILED ("INCORRECT 'IN' EVALUATION 2"); + END IF; + + IF WED NOT IN THU .. TUE + AND INTEGER'(0) NOT IN 4 .. -4 + THEN NULL; + ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 52"); + END; + + + RESULT; + END C36104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36104b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36104b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36104b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36104b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,421 ---- + -- C36104B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED OR NOT, AS APPROPRIATE, + -- DURING DISCRETE_RANGE ELABORATIONS/EVALUATIONS IN LOOPS, + -- ARRAY_TYPE_DEFINITIONS, ARRAY AGGREGATES, SLICES, + -- AND INDEX CONSTRAINTS IN OBJECT AND TYPE DECLARATIONS, WHERE + -- AN EXPLICIT (SUB)TYPE IS INCLUDED IN EACH DISCRETE_RANGE. + -- MEMBERSHIP OPERATORS ARE CHECKED HERE, ALSO, TO ENSURE THAT + -- EXCEPTIONS ARE NOT RAISED FOR NULL RANGES. + -- ONLY DYNAMIC CASES ARE CHECKED HERE. + + -- DAT 2/3/81 + -- JRK 2/25/81 + -- L.BROWN 7/15/86 1) ADDED ACCESS TYPES. + -- 2) DELETED "NULL INDEX RANGE, CONSTRAINT_ERROR + -- RAISED" SECTION. + -- 3) MADE USE OF DYNAMIC-RESULT FUNCTIONS. + -- 4) DELETED ALL REFERENCES TO CASE STATEMENT CHOICES + -- AND VARIANT PART CHOICES IN THE ABOVE COMMENT. + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C36104B IS + + USE REPORT; + + TYPE WEEK IS (SSUN, SMON, STUE, SWED, STHU, SFRI, SSAT); + SUN : WEEK := WEEK'VAL(IDENT_INT(0)); + MON : WEEK := WEEK'VAL(IDENT_INT(1)); + TUE : WEEK := WEEK'VAL(IDENT_INT(2)); + WED : WEEK := WEEK'VAL(IDENT_INT(3)); + THU : WEEK := WEEK'VAL(IDENT_INT(4)); + FRI : WEEK := WEEK'VAL(IDENT_INT(5)); + SAT : WEEK := WEEK'VAL(IDENT_INT(6)); + TYPE WEEK_ARRAY IS ARRAY (WEEK RANGE <>) OF WEEK; + SUBTYPE WORK_WEEK IS WEEK RANGE MON .. FRI; + SUBTYPE MID_WEEK IS WORK_WEEK RANGE TUE .. THU; + + TYPE INT_10 IS NEW INTEGER RANGE -10 .. 10; + TYPE I_10 IS NEW INT_10; + SUBTYPE I_5 IS I_10 RANGE I_10(IDENT_INT(-5)) .. + I_10(IDENT_INT(5)); + TYPE I_5_ARRAY IS ARRAY (I_5 RANGE <>) OF I_5; + + FUNCTION F(DAY : WEEK) RETURN WEEK IS + BEGIN + RETURN DAY; + END; + + BEGIN + TEST ("C36104B", "CONSTRAINT_ERROR IS RAISED OR NOT IN DYNAMIC " + & "DISCRETE_RANGES WITH EXPLICIT TYPE_MARKS"); + + -- NON-NULL RANGES, CONSTRAINT_ERROR RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE 0 .. 6) OF I_5; + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + -- DEFINE AN OBJECT OF TYPE A AND USE IT TO AVOID + -- OPTIMIZATION OF SUBTYPE + A1 : A := (A'RANGE => I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 1 " & + I_5'IMAGE(A1(1)) ); --USE A1 + END; + EXCEPTION + --MAKE SURE THAT CONSTRAINT_ERROR FROM ABOVE STATEMENTS + --REPORT FAILED. + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 1"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE MON .. MON LOOP + + IF EQUAL(2,2) THEN + SAT := SSAT; + END IF; + + END LOOP; + FAILED ("CONSTRAINT_ERROR NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (0 .. 6); + -- ABOVE DECLARATION RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + TYPE PA IS NEW P; + -- DEFINE AN OBJECT OF TYPE PA AND USE IT TO AVOID + -- OPTIMIZATION OF TYPE + PA1 : PA :=NEW I_5_ARRAY'(0.. I_5(IDENT_INT(6)) => + I_5(IDENT_INT(1))); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 4 " & + I_5'IMAGE(PA1(1))); --USE PA1 + END; + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (MID_WEEK RANGE MON .. WED => WED); + -- CONSTRAINT_ERROR RAISED. + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 7 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 7"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (WORK_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (MON .. WED) := W (MID_WEEK RANGE MON .. WED); -- EXCEPTION. + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED 8 " & + MID_WEEK'IMAGE(W(WED))); --USE W + EXCEPTION + WHEN OTHERS => FAILED ("UNHANDLED EXCEPTION RAISED 8"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. FRI); + -- ELABORATION OF ABOVE RAISES CONSTRAINT_ERROR. + BEGIN + W(WED) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 9 " & + WEEK'IMAGE(W(WED))); -- USE W + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE SUN .. WED); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + X : W; -- OK. + BEGIN + X(TUE) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 10 " & + WEEK'IMAGE(X(TUE))); -- USE X + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE MON .. THU); + -- RAISES CONSTRAINT_ERROR. + BEGIN + DECLARE + T : W; -- OK. + BEGIN + T(TUE) := THU; -- OK. + FAILED ("CONSTRAINT_ERROR NOT RAISED 11 " & + WEEK'IMAGE(T(TUE))); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DID NOT RAISE CONSTRAINT_ERROR AT PROPER PLACE"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + -- NULL DISCRETE/INDEX RANGES, EXCEPTION NOT RAISED. + + BEGIN + DECLARE + TYPE A IS ARRAY (I_5 RANGE I_5(IDENT_INT(-5)) .. -6) OF I_5; + A1 : A; + BEGIN + IF A1'FIRST /= I_5(IDENT_INT(-5)) THEN + FAILED ("'FIRST OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + FOR I IN MID_WEEK RANGE SAT .. SUN LOOP + + IF EQUAL(2,2) THEN + TUE := STUE; + END IF; + + END LOOP; + FOR I IN MID_WEEK RANGE FRI .. WED LOOP + + IF EQUAL(2,2) THEN + MON := SMON; + END IF; + + END LOOP; + FOR I IN MID_WEEK RANGE MON .. SUN LOOP + + IF EQUAL(3,3) THEN + WED := SWED; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 10 .. -10 LOOP + + IF EQUAL(2,2) THEN + TUE := STUE; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 10 .. 9 LOOP + + IF EQUAL(2,2) THEN + THU := STHU; + END IF; + + END LOOP; + FOR I IN I_5 RANGE -10 .. -11 LOOP + + IF EQUAL(2,2) THEN + SAT := SSAT; + END IF; + + END LOOP; + FOR I IN I_5 RANGE -10 .. -20 LOOP + + IF EQUAL(2,2) THEN + SUN := SSUN; + END IF; + + END LOOP; + FOR I IN I_5 RANGE 6 .. 5 LOOP + + IF EQUAL(2,2) THEN + MON := SMON; + END IF; + + END LOOP; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE P IS ACCESS I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6); + PA1 : P := NEW I_5_ARRAY (I_5(IDENT_INT(-5)) .. -6); + BEGIN + IF PA1'LENGTH /= IDENT_INT(0) THEN + FAILED ("'LENGTH OF NULL ARRAY INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 5"); + END; + + DECLARE + TYPE NARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARR IS INTEGER RANGE 1 .. 2; + W : NARR(SNARR) := (1,2); + BEGIN + IF W = (SNARR RANGE IDENT_INT(4) .. 2 => 5) THEN + FAILED("EVALUATION OF EXPRESSION IS INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + DECLARE + W : WEEK_ARRAY (MID_WEEK); + BEGIN + W := (W'RANGE => WED); -- OK. + W (TUE .. MON) := W (MID_WEEK RANGE MON .. SUN); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + W : WEEK_ARRAY (MID_WEEK RANGE MON .. SUN); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + TUE := STUE; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE W IS NEW WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + MON := SMON; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + SUBTYPE W IS WEEK_ARRAY (MID_WEEK RANGE TUE .. MON); + BEGIN + + IF EQUAL(W'LENGTH,0) THEN + WED := SWED; + END IF; + + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 12"); + END; + + -- NULL MEMBERSHIP RANGES, EXCEPTION NOT RAISED. + + BEGIN + IF F(SUN) IN SAT .. SUN + OR SAT IN FRI .. WED + OR F(WED) IN THU .. TUE + OR THU IN MON .. SUN + OR F(FRI) IN SAT .. FRI + OR WED IN FRI .. MON + THEN + FAILED ("INCORRECT 'IN' EVALUATION 1"); + END IF; + + IF IDENT_INT(0) IN 10 .. IDENT_INT(-10) + OR 0 IN IDENT_INT(10) .. 9 + OR IDENT_INT(0) IN IDENT_INT(-10) .. -11 + OR 0 IN -10 .. IDENT_INT(-20) + OR IDENT_INT(0) IN 6 .. IDENT_INT(5) + OR 0 IN 5 .. IDENT_INT(3) + OR IDENT_INT(0) IN 7 .. IDENT_INT(3) + THEN + FAILED ("INCORRECT 'IN' EVALUATION 2"); + END IF; + + IF F(WED) NOT IN THU .. TUE + AND IDENT_INT(0) NOT IN IDENT_INT(4) .. -4 + THEN NULL; + ELSE FAILED ("INCORRECT 'NOT IN' EVALUATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 52"); + END; + + RESULT; + END C36104B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- C36172A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED APPROPRIATELY + -- ON DISCRETE_RANGES USED AS INDEX_CONSTRAINTS. + + -- DAT 2/9/81 + -- SPS 4/7/82 + -- JBG 6/5/85 + + WITH REPORT; + PROCEDURE C36172A IS + + USE REPORT; + + SUBTYPE INT_10 IS INTEGER RANGE 1 .. 10; + TYPE A IS ARRAY (INT_10 RANGE <> ) OF INTEGER; + + SUBTYPE INT_11 IS INTEGER RANGE 0 .. 11; + SUBTYPE NULL_6_4 IS INTEGER RANGE 6 .. 4; + SUBTYPE NULL_11_10 IS INTEGER RANGE 11 .. 10; + SUBTYPE INT_9_11 IS INTEGER RANGE 9 .. 11; + + TYPE A_9_11 IS ARRAY (9..11) OF BOOLEAN; + TYPE A_11_10 IS ARRAY (11 .. 10) OF INTEGER; + SUBTYPE A_1_10 IS A(INT_10); + + BEGIN + TEST ("C36172A", "CONSTRAINT_ERROR IS RAISED APPROPRIATELY" & + " FOR INDEX_RANGES"); + + BEGIN + DECLARE + V : A (9 .. 11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("OUT-OF-BOUNDS INDEX_RANGE 1"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 1"); + END; + + BEGIN + DECLARE + V : A (11 .. 10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 2"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 2"); + END; + + BEGIN + DECLARE + V : A (6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 3"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 3"); + END; + + BEGIN + DECLARE + V : A (INT_9_11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("OUT-OF-BOUNDS INDEX RANGE 4"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 4"); + END; + + BEGIN + DECLARE + V : A (NULL_11_10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 5"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 5"); + END; + + BEGIN + DECLARE + V : A (NULL_6_4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 6"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 6"); + END; + + BEGIN + DECLARE + V : A (INT_9_11 RANGE 10 .. 11); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("BAD NON-NULL INDEX RANGE 7"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 7"); + END; + + BEGIN + DECLARE + V : A (NULL_11_10 RANGE 11 .. 10); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 8"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 8"); + END; + + BEGIN + DECLARE + V : A (NULL_6_4 RANGE 6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 9"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 9"); + END; + + BEGIN + DECLARE + V : A (A_9_11'RANGE); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("BAD INDEX RANGE 10"); + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 10"); + END; + + BEGIN + DECLARE + V : A (A_11_10'RANGE); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 11"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 11"); + END; + + BEGIN + DECLARE + V : A (6 .. 4); + BEGIN + IF EQUAL (V'FIRST, V'FIRST) THEN + NULL; + ELSE + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => FAILED ("CONSTRAINT_ERROR " & + "RAISED INAPPROPRIATELY 12"); + WHEN OTHERS => FAILED ("EXCEPTION RAISED WHEN NONE " & + "SHOULD BE 12"); + END; + + RESULT; + END C36172A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172b.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- C36172B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A MULTIDIMENSIONAL INDEX + -- CONSTRAINT IF ONE OF THE RANGES IS A NULL RANGE AND THE OTHER IS A + -- NON-NULL RANGE WITH A BOUND THAT LIES OUTSIDE THE INDEX SUBTYPE. + + -- CHECK THAT NO EXCEPTION IS RAISED IF ALL DISCRETE RANGES ARE NULL. + + -- JBG 6/5/85 + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C36172B IS + SUBTYPE INT_10 IS INTEGER RANGE 1..10; + TYPE ARR2 IS ARRAY (INT_10 RANGE <>, INT_10 RANGE <>) OF INTEGER; + BEGIN + TEST ("C36172B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "NON-NULL DIMENSION OF A NULL MULTIDIMENSIONAL " & + "INDEX CONSTRAINT IF A BOUND LIES OUTSIDE THE " & + "INDEX SUBTYPE"); + + BEGIN + DECLARE + V : ARR2 (6..4, 9..11); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (13) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13"); + END; + + BEGIN + DECLARE + V : ARR2 (0..3, 8..7); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (14) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14"); + END; + + BEGIN + DECLARE + V : ARR2 (6..4, IDENT_INT(0)..2); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (15) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15"); + END; + + BEGIN + DECLARE + V : ARR2 (9..IDENT_INT(11), 6..4); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (16) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 16"); + END; + + BEGIN + DECLARE + V : ARR2 (6..IDENT_INT(4), 9..IDENT_INT(11)); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (17) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17"); + END; + + BEGIN + DECLARE + V : ARR2 (IDENT_INT(-1)..2, IDENT_INT(6)..4); + BEGIN + FAILED ("EXCEPTION NOT RAISED WHEN NON-NULL RANGE OF " & + "NULL INDEX CONSTRAINT HAS A BOUND OUTSIDE " & + "THE INDEX SUBTYPE (18) " & INTEGER'IMAGE(V'FIRST)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 18"); + END; + + BEGIN + DECLARE + V : ARR2 (6..-1, 11..9); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 19"); + END; + + BEGIN + DECLARE + V : ARR2 (IDENT_INT(11)..9, 6..IDENT_INT(0)); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED FOR NULL CONSTRAINT - 20"); + END; + + RESULT; + END C36172B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36172c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36172c.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- C36172C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NO EXCEPTION IS RAISED FOR A NULL ARRAY WHOSE DIFFERENCE + -- IN BOUNDS LIES OUTSIDE THE INDEX BASE TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- JBG 6/5/85 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C36172C IS + BEGIN + TEST ("C36172C", "CHECK THAT NO EXCEPTION IS RAISED FOR A NULL " & + "ARRAY WHOSE DIFFERENCE IN BOUNDS LIES OUTSIDE " & + "THE INDEX BASE TYPE"); + + BEGIN + DECLARE + V : STRING (INTEGER'LAST .. -2); + BEGIN + IF NOT EQUAL (V'FIRST, V'FIRST) THEN + FAILED ("IMPOSSIBLE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; + END C36172C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36174a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36174a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36174a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36174a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C36174A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS. + + -- DAT 2/9/81 + -- JBG 12/8/83 + + + WITH REPORT; + PROCEDURE C36174A IS + + USE REPORT; + + S0 : CONSTANT STRING := ""; + S1 : CONSTANT STRING := S0; + S2 : CONSTANT STRING := (1 .. 0 => 'Z'); + S3 : CONSTANT STRING := ('A', 'B', 'C'); + S4 : CONSTANT STRING := S3 & "ABC" & S3 & S2 & "Z"; + S9 : CONSTANT STRING := S0 & S1 & S2 & S3(3..1); + + TYPE A4 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>, + INTEGER RANGE <>, INTEGER RANGE <>) OF STRING (1 .. 0); + C4 : CONSTANT A4 := + (-6 .. -4 => + (4 .. 5 => + (-4 .. -5 => + (1000 .. 2000 => + S9)))); + S10 : CONSTANT STRING := (10 .. 9 => 'Q'); + + TYPE I_12 IS NEW INTEGER RANGE 10 .. 12; + TYPE A_12 IS ARRAY (I_12 RANGE <>, I_12 RANGE <>) OF I_12; + A12 : CONSTANT A_12 := + (11 .. 12 => (10 .. 10 => 10)); + B12 : CONSTANT A_12 := + (11 => (10 | 12 => 10, 11 => 11), + 10 => (10 | 12 | 11 => 12)); + + N6 : CONSTANT INTEGER := IDENT_INT (6); + S6 : CONSTANT STRING := (N6 .. N6 + 6 => 'Z'); + S7 : CONSTANT STRING := S6 (N6 .. N6 + IDENT_INT (-1)); + + BEGIN + TEST ("C36174A", "INDEX_CONSTRAINTS MAY BE OMITTED FOR CONSTANTS"); + + IF S0'FIRST /= 1 OR S0'LAST /= 0 + OR S1'FIRST /= 1 OR S1'LAST /= 0 + OR S2'FIRST /= 1 OR S2'LAST /= 0 + OR S3'FIRST /= 1 OR S3'LAST /= 3 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 1"); + END IF; + + IF S4'FIRST /= 1 OR S4'LAST /= 10 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 2"); + END IF; + + IF S9'FIRST /= 3 OR S9'LAST /= 1 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 3"); + END IF; + + IF C4'FIRST(1) /= -6 OR C4'LAST(1) /= -4 + OR C4'FIRST(2) /= 4 OR C4'LAST(2) /= 5 + OR C4'FIRST(3) /= -4 OR C4'LAST(3) /= -5 + OR C4'FIRST(4) /= 1000 OR C4'LAST(4) /= 2000 + THEN + FAILED ("INVALID ARRAY CONSTANT BOUNDS"); + END IF; + + IF S10'FIRST /= 10 OR S10'LAST /= 9 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 10"); + END IF; + + IF A12'FIRST /= 11 OR A12'LAST /= 12 + OR A12'FIRST(2) /= 10 OR A12'LAST(2) /= 10 + THEN FAILED ("INVALID ARRAY CONSTANT BOUNDS 2"); + END IF; + + IF B12'FIRST /= 10 OR B12'LAST /= 11 + OR B12'FIRST(2) /= 10 OR B12'LAST(2) /= 12 + THEN + FAILED ("INVALID ARRAY CONSTANT BOUNDS 3"); + END IF; + + IF S6'FIRST /= 6 OR S6'LAST /= 12 OR S6'LENGTH /= 7 + THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 12"); + END IF; + + IF S7'FIRST /= 6 OR S7'LAST /= 5 THEN + FAILED ("INVALID STRING CONSTANT BOUNDS 13"); + END IF; + + RESULT; + END C36174A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36180a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36180a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36180a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36180a.ada 2003-10-27 11:28:50.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C36180A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INDEX CONSTRAINT CAN HAVE THE FORM A'RANGE, + -- WHERE A IS A PREVIOUSLY DECLARED ARRAY OBJECT OR CONSTRAINED + -- ARRAY SUBTYPE. + + -- HISTORY: + -- BCB 01/21/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C36180A IS + + TYPE J IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE K IS ARRAY (1..10) OF INTEGER; + + SUBTYPE A IS J (0 .. 50); + + SUBTYPE W IS J (A'RANGE); + + SUBTYPE X IS J (K'RANGE); + + TYPE Y IS ACCESS J; + + TYPE Z IS ACCESS J; + + TYPE F IS NEW J (A'RANGE); + + TYPE G IS NEW J (K'RANGE); + + B : ARRAY (A'RANGE) OF INTEGER; + + C : ARRAY (K'RANGE) OF INTEGER; + + D : ARRAY (1 .. 10) OF INTEGER; + + E : ARRAY (D'RANGE) OF INTEGER; + + H : J (A'RANGE); + + I : J (K'RANGE); + + L : J (D'RANGE); + + V1 : W; + + V2 : X; + + V3 : Y := NEW J (A'RANGE); + + V4 : Z := NEW J (K'RANGE); + + V5 : F; + + V6 : G; + + BEGIN + TEST ("C36180A", "CHECK THAT AN INDEX CONSTRAINT CAN HAVE THE " & + "FORM A'RANGE, WHERE A IS A PREVIOUSLY " & + "DECLARED ARRAY OBJECT OR CONSTRAINED ARRAY " & + "SUBTYPE"); + + IF B'FIRST /= IDENT_INT (0) OR B'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR B'FIRST OR B'LAST"); + END IF; + + IF C'FIRST /= IDENT_INT (1) OR C'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR C'FIRST OR C'LAST"); + END IF; + + IF E'FIRST /= IDENT_INT (1) OR E'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR E'FIRST OR E'LAST"); + END IF; + + IF H'FIRST /= IDENT_INT (0) OR H'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR H'FIRST OR H'LAST"); + END IF; + + IF I'FIRST /= IDENT_INT (1) OR I'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR I'FIRST OR I'LAST"); + END IF; + + IF L'FIRST /= IDENT_INT (1) OR L'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR L'FIRST OR L'LAST"); + END IF; + + IF V1'FIRST /= IDENT_INT (0) OR V1'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V1'FIRST OR V1'LAST"); + END IF; + + IF V2'FIRST /= IDENT_INT (1) OR V2'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V2'FIRST OR V2'LAST"); + END IF; + + IF V3.ALL'FIRST /= IDENT_INT (0) OR V3.ALL'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V3'FIRST OR V3'LAST"); + END IF; + + IF V4.ALL'FIRST /= IDENT_INT (1) OR V4.ALL'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V4'FIRST OR V4'LAST"); + END IF; + + IF V5'FIRST /= IDENT_INT (0) OR V5'LAST /= IDENT_INT (50) + THEN FAILED ("IMPROPER VALUE FOR V5'FIRST OR V5'LAST"); + END IF; + + IF V6'FIRST /= IDENT_INT (1) OR V6'LAST /= IDENT_INT (10) + THEN FAILED ("IMPROPER VALUE FOR V6'FIRST OR V6'LAST"); + END IF; + + RESULT; + END C36180A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36202c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36202c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36202c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36202c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C36202C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'LENGTH DOES NOT RAISE AN EXCEPTION + -- WHEN APPLIED TO A NULL ARRAY A, EVEN IF A'LAST - A'FIRST + -- WOULD RAISE CONSTRAINT_ERROR. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- L.BROWN 07/29/86 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE C36202C IS + + TYPE LRG_INT IS RANGE MIN_INT .. MAX_INT; + + BEGIN + TEST("C36202C", "NO EXCEPTION IS RAISED FOR 'LENGTH "& + "WHEN APPLIED TO A NULL ARRAY"); + + DECLARE + TYPE LRG_ARR IS ARRAY + (LRG_INT RANGE MAX_INT .. MIN_INT) + OF INTEGER; + LRG_OBJ : LRG_ARR; + + BEGIN + IF LRG_OBJ'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM NULL ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED " & + "FOR ONE-DIM NULL ARRAY"); + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR ONE-DIM " & + "NULL ARRAY"); + END; + + DECLARE + TYPE LRG2_ARR IS ARRAY (LRG_INT RANGE 1 .. 3 , + LRG_INT RANGE MAX_INT .. MIN_INT) + OF INTEGER; + BEGIN + IF LRG2_ARR'LENGTH(2) /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR TWO-DIM NULL ARRAY"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED " & + "FOR TWO-DIM NULL ARRAY"); + WHEN OTHERS => + FAILED("EXCEPTION RAISED FOR TWO-DIM " & + "NULL ARRAY"); + END; + + RESULT; + + END C36202C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36203a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- C36203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'LENGTH YIELDS A RESULT OF TYPE UNIVERSAL INTEGER. + + -- L.BROWN 07/31/86 + + WITH REPORT; USE REPORT; + PROCEDURE C36203A IS + + TYPE NINT IS NEW INTEGER RANGE 1 .. 5; + + TYPE INT_ARR IS ARRAY(INTEGER RANGE 1 .. 3) OF INTEGER; + TYPE INT2_ARR IS ARRAY(INTEGER RANGE 1 .. 3, + INTEGER RANGE 1 .. 2) OF INTEGER; + + OBJA : INTEGER := 3; + OBJB : NINT := 3; + + BEGIN + TEST("C36203A", "'LENGTH YIELDS A RESULT OF TYPE " & + "UNIVERSAL INTEGER"); + IF (OBJA + INT_ARR'LENGTH) /= IDENT_INT(6) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT_ARR'LENGTH) /= 6 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR ONE-DIM ARRAY TYPE 2"); + END IF; + + IF (OBJA + INT2_ARR'LENGTH(1)) /= IDENT_INT(6) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT2_ARR'LENGTH(1)) /= 6 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR FIRST DIMENSION OF TWO-DIM ARRAY TYPE 2"); + END IF; + + IF (OBJA + INT2_ARR'LENGTH(2)) /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 1"); + END IF; + + IF (OBJB + INT2_ARR'LENGTH(2)) /= 5 THEN + FAILED("INCORRECT VALUE RETURNED BY 'LENGTH " & + "FOR SECOND DIMENSION OF TWO-DIM ARRAY TYPE 2"); + END IF; + + RESULT; + + END C36203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C36204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES. + -- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. + + -- DAT 2/12/81 + -- SPS 11/1/82 + -- WMC 03/16/92 CREATED TYPE RANGE CHECK FOR AE_TYPE. + + WITH REPORT; + PROCEDURE C36204A IS + + USE REPORT; + + BEGIN + TEST ("C36204A", "ARRAY ATTRIBUTES RETURN CORRECT VALUES"); + + DECLARE + A1 : ARRAY (BOOLEAN, + INTEGER RANGE IDENT_INT(1)..IDENT_INT(10)) + OF STRING(IDENT_INT(5)..IDENT_INT(7)); + TYPE NI IS RANGE -3 .. 3; + N : NI := NI(IDENT_INT(2)); + SUBTYPE SNI IS NI RANGE -N .. N; + TYPE AA IS ARRAY (NI, SNI, BOOLEAN) + OF NI; + A1_1_1 : BOOLEAN := A1'FIRST; + A1_1_2 : BOOLEAN := A1'LAST(1); + A1_2_1 : INTEGER RANGE A1'RANGE(2) := A1'FIRST(2); -- 1 + A1_2_2 : INTEGER RANGE A1'RANGE(2) := A1'LAST(2); -- 10 + SUBTYPE AE_TYPE IS INTEGER RANGE A1(TRUE,5)'RANGE; -- RANGE 5..7 + A2 : AA; + A4 : ARRAY (A1_1_1 .. A1_1_2, A1_2_1 .. A1_2_2) OF + STRING (IDENT_INT(1)..IDENT_INT(3)); + + I : INTEGER; + B : BOOLEAN; + BEGIN + IF A4'FIRST /= IDENT_BOOL(FALSE) + OR A4'LAST /= IDENT_BOOL(TRUE) + OR A4'FIRST(2) /= INTEGER'(1) + OR A4'LAST(2) /= INTEGER'(10) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 1"); + END IF; + + IF A4'LENGTH /= INTEGER'(2) + OR A4'LENGTH /= NI'(2) + OR A4'LENGTH(1) /= N + OR A4'LENGTH(2) /= A4'LAST(2) + THEN + FAILED ("INCORRECT 'LENGTH - 1"); + END IF; + + A4 := (BOOLEAN => (1 .. 10 => "XYZ")); + FOR L1 IN A1'RANGE(1) LOOP + FOR L2 IN A4'RANGE(2) LOOP + A1(L1,L2) := A4(L1,L2); + END LOOP; + END LOOP; + + IF AA'FIRST(1) /= NI'(-3) + OR AA'LAST(1) /= N + 1 + OR AA'FIRST(2) /= -N + OR AA'LAST(2) /= N + OR AA'FIRST(3) /= IDENT_BOOL(FALSE) + OR AA'LAST(3) /= IDENT_BOOL(TRUE) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 2"); + END IF; + + IF N NOT IN AA'RANGE(2) + OR IDENT_BOOL(FALSE) NOT IN AA'RANGE(3) + OR N + 1 NOT IN AA'RANGE + OR N + 1 IN AA'RANGE(2) + THEN + FAILED ("INCORRECT 'RANGE - 1"); + END IF; + + IF AA'LENGTH /= INTEGER'(7) + OR AA'LENGTH(2) - 3 /= N + OR AA'LENGTH(3) /= 2 + THEN + FAILED ("INCORRECT 'LENGTH - 2"); + END IF; + + IF A2'FIRST(1) /= NI'(-3) + OR A2'LAST(1) /= N + 1 + OR A2'FIRST(2) /= -N + OR A2'LAST(2) /= N + OR A2'FIRST(3) /= IDENT_BOOL(FALSE) + OR A2'LAST(3) /= IDENT_BOOL(TRUE) + THEN + FAILED ("INCORRECT 'FIRST OR 'LAST - 3"); + END IF; + + IF N NOT IN A2'RANGE(2) + OR IDENT_BOOL(FALSE) NOT IN A2'RANGE(3) + OR N + 1 NOT IN A2'RANGE + OR N + 1 IN A2'RANGE(2) + THEN + FAILED ("INCORRECT 'RANGE - 2"); + END IF; + + IF A2'LENGTH /= INTEGER'(7) + OR A2'LENGTH(2) - 3 /= INTEGER(N) + OR A2'LENGTH(3) /= 2 + THEN + FAILED ("INCORRECT 'LENGTH - 3"); + END IF; + + IF (AE_TYPE'FIRST /= 5) OR (AE_TYPE'LAST /= 7) THEN + FAILED ("INCORRECT TYPE RANGE DEFINED FOR AE_TYPE"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED ?"); + END; + + RESULT; + END C36204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- C36204B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES WITH + -- ACCESS VALUES AND FUNCTION CALLS AS THE PREFIXES. + + -- HISTORY: + -- L.BROWN 08/05/86 + -- DWC 07/24/87 DELETED BLANK AT END OF TEST DESCRIPTION. + + WITH REPORT; USE REPORT; + + PROCEDURE C36204B IS + + BEGIN + TEST("C36204B", "ARRAY ATTRIBUTES RETURN CORRECT VALUES " & + "FOR ACCESS VALUES AND FUNCTION CALLS AS " & + "PREFIXES"); + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(10)) OF INTEGER ; + TYPE ARR2 IS ARRAY (BOOLEAN, + INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(3)) OF INTEGER ; + + TYPE PTR1 IS ACCESS ARR1; + TYPE PTR2 IS ACCESS ARR2; + + PT1 : PTR1 := NEW ARR1'(ARR1'RANGE => 0); + PT2 : PTR2 := NEW ARR2'(ARR2'RANGE(1) => + (ARR2'RANGE(2) => 0)); + SUBTYPE ARR1_RANGE IS INTEGER RANGE PT1'RANGE; + BEGIN + IF PT1'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 1"); + END IF; + + IF PT2'FIRST(2) /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 1"); + END IF; + + IF ARR1_RANGE'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 2"); + END IF; + + IF PT1'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 3"); + END IF; + + IF PT2'LAST(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 2"); + END IF; + + IF ARR1_RANGE'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 4"); + END IF; + + IF PT1'LENGTH /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 5"); + END IF; + + IF PT2'LENGTH(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING ACCESS TYPES AS PREFIXES 3"); + END IF; + + END; + + DECLARE + + TYPE UNCON IS ARRAY (INTEGER RANGE <>) OF INTEGER ; + TYPE UNCON2 IS ARRAY (INTEGER RANGE <>, + INTEGER RANGE <>) OF INTEGER ; + + ARY1 : STRING(IDENT_INT(5) .. IDENT_INT(8)); + F : INTEGER := IDENT_INT(1); + L : INTEGER := IDENT_INT(3); + + FUNCTION FUN( LO,HI : INTEGER ) RETURN UNCON IS + ARR : UNCON(IDENT_INT(LO) .. IDENT_INT(HI)); + BEGIN + ARR := (ARR'RANGE => 0); + RETURN ARR; + END FUN; + + FUNCTION FUN2( LO,HI : INTEGER ) RETURN UNCON2 IS + AR2 : UNCON2(IDENT_INT(LO) .. IDENT_INT(HI), + IDENT_INT(LO) .. IDENT_INT(HI)); + BEGIN + AR2 := (AR2'RANGE(1) =>(AR2'RANGE(2) => 0)); + RETURN AR2; + END FUN2; + BEGIN + + ARY1 := (ARY1'RANGE => 'A'); + + IF FUN(F,L)'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 1"); + END IF; + + IF FUN2(F,L)'FIRST(2) /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 1"); + END IF; + + IF "&"(ARY1,"XX")'FIRST /= IDENT_INT(5) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 2"); + END IF; + + IF FUN(F,L)'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 3"); + END IF; + + IF FUN2(F,L)'LAST(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 2"); + END IF; + + IF "&"(ARY1,"YY")'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 4"); + END IF; + + IF FUN(F,L)'LENGTH /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 5"); + END IF; + + IF FUN2(F,L)'LENGTH(2) /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR TWO-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 3"); + END IF; + + IF "&"(ARY1,"XX")'LENGTH /= IDENT_INT(6) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR ONE-DIM " & + "ARRAY USING FUNCTION RESULTS AS " & + "PREFIXES 6"); + END IF; + + DECLARE + + SUBTYPE SMIN IS INTEGER RANGE FUN(F,L)'RANGE; + SUBTYPE SMIN2 IS INTEGER RANGE FUN2(F,L)'RANGE(2); + SUBTYPE SMIN3 IS INTEGER RANGE "&"(ARY1,"YY")'RANGE; + + BEGIN + IF SMIN'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 7"); + END IF; + + IF SMIN2'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "TWO-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 4"); + END IF; + + IF SMIN3'FIRST /= IDENT_INT(5) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 8"); + END IF; + + IF SMIN'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 9"); + END IF; + + IF SMIN2'LAST /= IDENT_INT(3) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "TWO-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 5"); + END IF; + + IF SMIN3'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT ATTRIBUTE VALUE FOR " & + "ONE-DIM ARRAY USING FUNCTION " & + "RESULTS AS PREFIXES 10"); + END IF; + + END; + + END; + + RESULT; + + END C36204B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,221 ---- + -- C36204C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE 'RANGE ATTRIBUTE CAN BE USED TO DECLARE OBJECTS + -- AND IN A SUBTYPE AND TYPE DECLARATION. + + -- HISTORY: + -- LB 08/13/86 CREATED ORIGINAL TEST. + -- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. + -- REARRANGED STATEMENTS SO TEST IS CALLED FIRST. + -- ELIMINATED DEAD VARIABLE OPTIMIZATION. CHECKED + -- RANGE VALUES FOR A SMALL INTEGER. + + WITH REPORT; USE REPORT; + PROCEDURE C36204C IS + + BEGIN + TEST("C36204C","USING 'RANGE TO DECLARE OBJECTS AND " & + "IN A SUBTYPE AND TYPE DECLARATION " & + "RETURNS THE CORRECT VALUES."); + + DECLARE + + ARR : ARRAY(IDENT_INT(4) .. IDENT_INT(10)) OF INTEGER; + OBJ1 : ARRAY(ARR'RANGE) OF BOOLEAN; + + SUBTYPE SMALL_INT IS INTEGER RANGE ARR'RANGE ; + SML : SMALL_INT; + + TYPE OTHER_ARR IS ARRAY(ARR'RANGE) OF CHARACTER; + OBJ2 : OTHER_ARR; + + TYPE ARR_TYPE IS ARRAY(INTEGER RANGE IDENT_INT(1) .. + IDENT_INT(10)) OF INTEGER; + TYPE ARR_PTR IS ACCESS ARR_TYPE; + PTR : ARR_PTR := NEW ARR_TYPE'(ARR_TYPE'RANGE => 0); + + FUNCTION F RETURN ARR_TYPE IS + AR : ARR_TYPE := (ARR_TYPE'RANGE => 0); + BEGIN + RETURN AR; + END F; + + BEGIN + BEGIN + IF OBJ1'FIRST /= IDENT_INT(4) THEN + FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " & + "DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING " & + "OBJECT DECLARATION 1"); + END; + + BEGIN + IF OBJ1'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR AN OBJECT " & + "DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING " & + "OBJECT DECLARATION 2"); + END; + + BEGIN + IF SMALL_INT'FIRST /= 4 THEN + FAILED("INCORRECT RANGE VALUE FOR A SMALL " & + "INTEGER DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" & + " INTEGER DECLARATION 1"); + END; + + BEGIN + IF SMALL_INT'LAST /= 10 THEN + FAILED("INCORRECT RANGE VALUE FOR A SMALL " & + "INTEGER DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING SMALL" & + " INTEGER DECLARATION 2"); + END; + + BEGIN + SML := IDENT_INT(3) ; + IF SML = 3 THEN + COMMENT("VARIABLE SML OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 1"); + END; + + BEGIN + SML := IDENT_INT(11) ; + IF SML = 11 THEN + COMMENT("VARIABLE SML OPTIMIZED VALUE 2"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 2"); + END; + + BEGIN + IF OBJ2'FIRST /= IDENT_INT(4) THEN + FAILED("INCORRECT RANGE VALUE FOR A TYPE " & + "DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING A " & + "TYPE DECLARATION 1"); + END; + + BEGIN + IF OBJ2'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR A TYPE " & + "DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING A " & + "TYPE DECLARATION 2"); + END; + + BEGIN + IF PTR'FIRST /= IDENT_INT(1) THEN + FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " & + "TYPE DECLARATION 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING AN " & + "ACCESS TYPE DECLARATION 1"); + END; + + BEGIN + IF PTR'LAST /= IDENT_INT(10) THEN + FAILED("INCORRECT RANGE VALUE FOR AN ACCESS " & + "TYPE DECLARATION 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHEN CHECKING AN " & + "ACCESS TYPE DECLARATION 2"); + END; + + DECLARE + OBJ_F1 : INTEGER RANGE F'RANGE ; + BEGIN + OBJ_F1 := IDENT_INT(0) ; + IF OBJ_F1 = 0 THEN + COMMENT("VARIABLE OBJ_F1 OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 3"); + END; + + DECLARE + OBJ_F2 : INTEGER RANGE F'RANGE ; + BEGIN + OBJ_F2 := IDENT_INT(11) ; + IF OBJ_F2 = 11 THEN + COMMENT("VARIABLE OBJ_F2 OPTIMIZED VALUE 1"); + END IF; + FAILED("NO EXCEPTION RAISED FOR OUT-OF RANGE " & + "VALUE 4"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED FOR OUT-OF " & + "RANGE VALUE 4"); + END; + END; + RESULT; + + END C36204C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36204d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36204d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,598 ---- + -- C36204D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EACH ARRAY ATTRIBUTE YIELDS THE CORRECT VALUES. + -- BOTH ARRAY OBJECTS AND TYPES ARE CHECKED. THIS TEST CHECKS + -- THE ABOVE FOR ARRAYS WITHIN GENERIC PROGRAM UNITS. + + -- HISTROY + -- EDWARD V. BERARD, 9 AUGUST 1990 + + WITH REPORT ; + WITH SYSTEM ; + + PROCEDURE C36204D IS + + SHORT_START : CONSTANT := -10 ; + SHORT_END : CONSTANT := 10 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + SUBTYPE MID_YEAR IS MONTH_TYPE RANGE MAY .. AUG ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 10, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ; + RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN + RENAMES SYSTEM."=" ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + PACKAGE ARRAY_ATTRIBUTE_TEST IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + END ARRAY_ATTRIBUTE_TEST ; + + PACKAGE BODY ARRAY_ATTRIBUTE_TEST IS + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- ARRAY_ATTRIBUTE_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST - PACKAGE") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST - PACKAGE") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH - PACKAGE") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - PACKAGE") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - PACKAGE") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- PACKAGE") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- PACKAGE") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- PACKAGE") ; + END IF ; + + END ARRAY_ATTRIBUTE_TEST ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + PROCEDURE PROC_ARRAY_ATT_TEST ; + + PROCEDURE PROC_ARRAY_ATT_TEST IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- PROC_ARRAY_ATT_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " & + "- PROCEDURE") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " & + "- PROCEDURE") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " & + "- PROCEDURE") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - PROCEDURE") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - PROCEDURE") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- PROCEDURE") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- PROCEDURE") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- PROCEDURE") ; + END IF ; + + END PROC_ARRAY_ATT_TEST ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + FIRST_INDEX_LENGTH : IN NATURAL ; + FIRST_TEST_VALUE : IN FIRST_INDEX ; + TYPE SECOND_INDEX IS (<>) ; + SECOND_INDEX_LENGTH : IN NATURAL ; + SECOND_TEST_VALUE : IN SECOND_INDEX ; + TYPE THIRD_INDEX IS (<>) ; + THIRD_INDEX_LENGTH : IN NATURAL ; + THIRD_TEST_VALUE : IN THIRD_INDEX ; + TYPE FIRST_COMPONENT_TYPE IS PRIVATE ; + FIRST_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + SECOND_DEFAULT_VALUE : IN FIRST_COMPONENT_TYPE ; + TYPE SECOND_COMPONENT_TYPE IS PRIVATE ; + THIRD_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + FOURTH_DEFAULT_VALUE : IN SECOND_COMPONENT_TYPE ; + + FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN ; + + FUNCTION FUNC_ARRAY_ATT_TEST RETURN BOOLEAN IS + + TYPE MATRIX IS ARRAY (FIRST_INDEX, SECOND_INDEX) + OF FIRST_COMPONENT_TYPE ; + + TYPE CUBE IS ARRAY (FIRST_INDEX, SECOND_INDEX, THIRD_INDEX) + OF SECOND_COMPONENT_TYPE ; + + FIRST_ARRAY : MATRIX := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + FIRST_DEFAULT_VALUE)) ; + + SECOND_ARRAY : CUBE := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + THIRD_DEFAULT_VALUE))) ; + + THIRD_ARRAY : CONSTANT MATRIX + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + SECOND_DEFAULT_VALUE)) ; + + FOURTH_ARRAY : CONSTANT CUBE + := (FIRST_INDEX'FIRST .. FIRST_INDEX'LAST => + (SECOND_INDEX'FIRST .. SECOND_INDEX'LAST => + (THIRD_INDEX'FIRST .. THIRD_INDEX'LAST => + FOURTH_DEFAULT_VALUE))) ; + + FA1 : FIRST_INDEX := FIRST_ARRAY'FIRST (1) ; + FA2 : FIRST_INDEX := FIRST_ARRAY'LAST (1) ; + FA3 : SECOND_INDEX := FIRST_ARRAY'FIRST (2) ; + FA4 : SECOND_INDEX := FIRST_ARRAY'LAST (2) ; + + SA1 : FIRST_INDEX := SECOND_ARRAY'FIRST (1) ; + SA2 : FIRST_INDEX := SECOND_ARRAY'LAST (1) ; + SA3 : SECOND_INDEX := SECOND_ARRAY'FIRST (2) ; + SA4 : SECOND_INDEX := SECOND_ARRAY'LAST (2) ; + SA5 : THIRD_INDEX := SECOND_ARRAY'FIRST (3) ; + SA6 : THIRD_INDEX := SECOND_ARRAY'LAST (3) ; + + FAL1 : NATURAL := FIRST_ARRAY'LENGTH (1) ; + FAL2 : NATURAL := FIRST_ARRAY'LENGTH (2) ; + + SAL1 : NATURAL := SECOND_ARRAY'LENGTH (1) ; + SAL2 : NATURAL := SECOND_ARRAY'LENGTH (2) ; + SAL3 : NATURAL := SECOND_ARRAY'LENGTH (3) ; + + MATRIX_SIZE : NATURAL := MATRIX'SIZE ; + CUBE_SIZE : NATURAL := CUBE'SIZE ; + + FAA : SYSTEM.ADDRESS := FIRST_ARRAY'ADDRESS ; + SAA : SYSTEM.ADDRESS := SECOND_ARRAY'ADDRESS ; + TAA : SYSTEM.ADDRESS := THIRD_ARRAY'ADDRESS ; + FRAA : SYSTEM.ADDRESS := FOURTH_ARRAY'ADDRESS ; + + BEGIN -- FUNC_ARRAY_ATT_TEST + + IF (FA1 /= FIRST_INDEX'FIRST) OR + (FA3 /= SECOND_INDEX'FIRST) OR + (SA1 /= FIRST_INDEX'FIRST) OR + (SA3 /= SECOND_INDEX'FIRST) OR + (SA5 /= THIRD_INDEX'FIRST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'FIRST " & + "- FUNCTION") ; + END IF ; + + IF (FA2 /= FIRST_INDEX'LAST) OR + (FA4 /= SECOND_INDEX'LAST) OR + (SA2 /= FIRST_INDEX'LAST) OR + (SA4 /= SECOND_INDEX'LAST) OR + (SA6 /= THIRD_INDEX'LAST) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LAST " & + "- FUNCTION") ; + END IF ; + + IF (FAL1 /= FIRST_INDEX_LENGTH) OR + (FAL2 /= SECOND_INDEX_LENGTH) OR + (SAL1 /= FIRST_INDEX_LENGTH) OR + (SAL2 /= SECOND_INDEX_LENGTH) OR + (SAL3 /= THIRD_INDEX_LENGTH) THEN + REPORT.FAILED ("INCORRECT VALUE RETURNED FOR 'LENGTH " & + "- FUNCTION") ; + END IF ; + + FOR OUTER_INDEX IN FIRST_ARRAY'RANGE (1) LOOP + FOR INNER_INDEX IN FIRST_ARRAY'RANGE (2) LOOP + FIRST_ARRAY (OUTER_INDEX, INNER_INDEX) := + SECOND_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + + IF FIRST_ARRAY /= THIRD_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 2-DIMENSIONAL ARRAY. - FUNCTION") ; + END IF ; + + FOR OUTER_INDEX IN SECOND_ARRAY'RANGE (1) LOOP + FOR MIDDLE_INDEX IN SECOND_ARRAY'RANGE (2) LOOP + FOR INNER_INDEX IN SECOND_ARRAY'RANGE (3) LOOP + SECOND_ARRAY (OUTER_INDEX, MIDDLE_INDEX, INNER_INDEX) + := FOURTH_DEFAULT_VALUE ; + END LOOP ; + END LOOP ; + END LOOP ; + + IF SECOND_ARRAY /= FOURTH_ARRAY THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "FOR 3-DIMENSIONAL ARRAY. - FUNCTION") ; + END IF ; + + IF (FIRST_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (1)) OR + (FIRST_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (1)) OR + (SECOND_TEST_VALUE NOT IN FIRST_ARRAY'RANGE (2)) OR + (SECOND_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (2)) OR + (THIRD_TEST_VALUE NOT IN SECOND_ARRAY'RANGE (3)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUTE " & + "- FUNCTION") ; + END IF ; + + IF (MATRIX_SIZE = 0) OR (CUBE_SIZE = 0) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'SIZE ATTRIBUTE. " & + "- FUNCTION") ; + END IF ; + + IF (FAA = TAA) OR (SAA = FRAA) OR (FAA = SAA) OR (FAA = FRAA) + OR (SAA = TAA) OR (TAA = FRAA) THEN + REPORT.FAILED ("INCORRECT HANDLING OF THE 'ADDRESS ATTRIBUTE. " & + "- FUNCTION") ; + END IF ; + + RETURN TRUE ; + + END FUNC_ARRAY_ATT_TEST ; + + + BEGIN -- C36204D + + REPORT.TEST ("C36204D", "ARRAY ATTRIBUTES RETURN CORRECT " & + "VALUES WITHIN GENERIC PROGRAM UNITS.") ; + + LOCAL_BLOCK: + + DECLARE + + DUMMY : BOOLEAN := FALSE ; + + PACKAGE NEW_ARRAY_ATTRIBUTE_TEST IS NEW ARRAY_ATTRIBUTE_TEST ( + FIRST_INDEX => SHORT_RANGE, + FIRST_INDEX_LENGTH => SHORT_LENGTH, + FIRST_TEST_VALUE => -7, + SECOND_INDEX => MONTH_TYPE, + SECOND_INDEX_LENGTH => 12, + SECOND_TEST_VALUE => AUG, + THIRD_INDEX => BOOLEAN, + THIRD_INDEX_LENGTH => 2, + THIRD_TEST_VALUE => FALSE, + FIRST_COMPONENT_TYPE => MONTH_TYPE, + FIRST_DEFAULT_VALUE => JAN, + SECOND_DEFAULT_VALUE => DEC, + SECOND_COMPONENT_TYPE => DATE, + THIRD_DEFAULT_VALUE => TODAY, + FOURTH_DEFAULT_VALUE => FIRST_DATE) ; + + PROCEDURE NEW_PROC_ARRAY_ATT_TEST IS NEW PROC_ARRAY_ATT_TEST ( + FIRST_INDEX => MONTH_TYPE, + FIRST_INDEX_LENGTH => 12, + FIRST_TEST_VALUE => AUG, + SECOND_INDEX => SHORT_RANGE, + SECOND_INDEX_LENGTH => SHORT_LENGTH, + SECOND_TEST_VALUE => -7, + THIRD_INDEX => BOOLEAN, + THIRD_INDEX_LENGTH => 2, + THIRD_TEST_VALUE => FALSE, + FIRST_COMPONENT_TYPE => DATE, + FIRST_DEFAULT_VALUE => TODAY, + SECOND_DEFAULT_VALUE => FIRST_DATE, + SECOND_COMPONENT_TYPE => MONTH_TYPE, + THIRD_DEFAULT_VALUE => JAN, + FOURTH_DEFAULT_VALUE => DEC) ; + + FUNCTION NEW_FUNC_ARRAY_ATT_TEST IS NEW FUNC_ARRAY_ATT_TEST ( + FIRST_INDEX => DAY_TYPE, + FIRST_INDEX_LENGTH => 31, + FIRST_TEST_VALUE => 25, + SECOND_INDEX => SHORT_RANGE, + SECOND_INDEX_LENGTH => SHORT_LENGTH, + SECOND_TEST_VALUE => -7, + THIRD_INDEX => MID_YEAR, + THIRD_INDEX_LENGTH => 4, + THIRD_TEST_VALUE => JUL, + FIRST_COMPONENT_TYPE => DATE, + FIRST_DEFAULT_VALUE => TODAY, + SECOND_DEFAULT_VALUE => FIRST_DATE, + SECOND_COMPONENT_TYPE => MONTH_TYPE, + THIRD_DEFAULT_VALUE => JAN, + FOURTH_DEFAULT_VALUE => DEC) ; + + BEGIN -- LOCAL_BLOCK + + NEW_PROC_ARRAY_ATT_TEST ; + + DUMMY := NEW_FUNC_ARRAY_ATT_TEST ; + IF NOT DUMMY THEN + REPORT.FAILED ("WRONG VALUE RETURNED BY FUNCTION.") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + + END C36204D ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C36205A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS + -- PARAMETERS + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205A IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205A", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - BASIC CHECKS"); + + IF A10'FIRST /= 1 + OR A2_10'FIRST(1) /= 1 + OR A2_10'FIRST(2) /= IDENT_INT(13) + OR A2_20'FIRST /= 11 + OR A2_20'FIRST(2) /= 21 + THEN + FAILED ("'FIRST FOR OBJECTS IS WRONG"); + END IF; + + + IF A10'LAST(1) /= 10 + OR A2_10'LAST /= 10 + OR A2_10'LAST(2) /= 20 + OR A2_20'LAST(1) /= 30 + OR A2_20'LAST(2) /= IDENT_INT(20) + THEN + FAILED ("'LAST FOR OBJECTS IS WRONG"); + END IF; + IF A10'LENGTH /= IDENT_INT(10) + OR A2_10'LENGTH(1) /= 10 + OR A2_10'LENGTH(2) /= IDENT_INT(8) + OR A2_20'LENGTH /= 20 + OR A2_20'LENGTH(2) /= IDENT_INT(0) + THEN + FAILED ("'LENGTH FOR OBJECTS IS WRONG"); + END IF; + + IF 0 IN A10'RANGE + OR IDENT_INT(11) IN A10'RANGE(1) + OR IDENT_INT(0) IN A2_10'RANGE(1) + OR 11 IN A2_10'RANGE + OR 12 IN A2_10'RANGE(2) + OR IDENT_INT(21) IN A2_10'RANGE(2) + OR 10 IN A2_20'RANGE + OR IDENT_INT(31) IN A2_20'RANGE(1) + OR IDENT_INT(20) IN A2_20'RANGE(2) + OR 0 IN A2_20'RANGE(2) + THEN + FAILED ("'RANGE FOR OBJECTS IS WRONG"); + END IF; + + P1 (A10, 1, 10, "P1 1"); + P1 (A20, 18, 20, "P1 A20"); + P2(A2_10, 1, 10, 13, 20, "P2 1"); + P2 (A2_20, 11, 30, 21, 20, "P2 2"); + S1 (ALF, 1, 5, "X0"); + S1 (ARF, 5, 9, "ARF1"); + + RESULT; + + END C36205A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,169 ---- + -- C36205B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF NON-NULL STATIC SLICES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205B IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205B", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NON-NULL STATIC SLICES"); + + P1 (A10(1 .. 10), 1, 10, "P1 2"); + P1 (A10(1..9), 1, 9, "P1 3"); + P1 (A10(2..10), 2, 10, "P1 4"); + P1 (A10 (2..9), 2, 9, "P1 5"); + P1 (A10 (4 .. 5), 4, 5, "P1 6"); + P1 (A10 (5 .. 5), 5, 5, "P1 7"); + + RESULT; + END C36205B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C36205C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF NON-NULL DYNAMIC SLICES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205C IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205C", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NON-NULL DYNAMIC SLICES"); + + P1 (A10 (I10..I10), 10, 10, "P1 8"); + P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9"); + + RESULT; + END C36205C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,180 ---- + -- C36205D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF NULL STATIC SLICES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205D IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205D", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - NULL STATIC SLICES"); + + P1 (A10 (1 .. 0), 1, 0, "P1 11"); + P1 (A10 (2 .. 1), 2, 1, "P1 12"); + + P1 (A10, 1, 10, "P1 1"); + P1 (A10(1 .. 10), 1, 10, "P1 2"); + P1 (A10(1..9), 1, 9, "P1 3"); + P1 (A10(2..10), 2, 10, "P1 4"); + P1 (A10 (2..9), 2, 9, "P1 5"); + P1 (A10 (4 .. 5), 4, 5, "P1 6"); + P1 (A10 (5 .. 5), 5, 5, "P1 7"); + P1 (A10 (I10..I10), 10, 10, "P1 8"); + P1 (A10 (I10 - 9 .. I10), 1, 10, "P1 9"); + P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10"); + P1 (A10 (9 .. 10), 9, 10, "P1 13"); + P1 (A10 (10 .. 9), 10, 9, "P1 14"); + P1 (A10 (9 .. I10 - 1), 9, 9, "P1 15"); + P1 (A10 (9 .. 8), 9, 8, "P1 16"); + + RESULT; + END C36205D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C36205E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF DYNAMIC NULL SLICES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205E IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205E", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NULL SLICES"); + + P1 (A10 (I10 .. I10 - 1), 10, 9, "P1 10"); + + RESULT; + END C36205E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205f.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C36205F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF STATIC NON-NULL AGGREGATES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205F IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205F", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - STATIC NON-NULL AGGREGATES"); + + P1 ((3 .. 5 => 2), 3, 5, "P1 16"); + P1 ((5 .. 5 => 5), 5, 5, "P1 17"); + + RESULT; + END C36205F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205g.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C36205G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF DYNAMIC NON-NULL AGGREGATES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205G IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205G", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NON-NULL AGGREGATES"); + + P1 ((IDENT_INT(3) .. IDENT_INT(5) => 2), 3, 5, "P1 16"); + P1 ((IDENT_INT(5) .. 5 => 5), 5, 5, "P1 17"); + + RESULT; + END C36205G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205h.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + -- C36205H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF STATIC NULL AGGREGATES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205H IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205H", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - STATIC NULL AGGREGATES"); + + P1 ((5 .. 4 => 4), 5, 4, "P1 18"); + P1 ((1 .. 0 => 0), 1, 0, "P1 19"); + P1 ((-12 .. -13 => 3), -12, -13, "P1 21"); + + RESULT; + END C36205H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205i.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- C36205I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF DYNAMIC NULL AGGREGATES + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205I IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10*I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + SUBTYPE STR IS STRING; + ALF : CONSTANT STR(IDENT_INT(1)..IDENT_INT(5)) := "ABCDE"; + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205I", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - DYNAMIC NULL AGGREGATES"); + + + P1 ((IDENT_INT(5) .. IDENT_INT(4) => 4), 5, 4, "P1 18"); + P1 ((IDENT_INT(1) .. IDENT_INT(0) => 0), 1, 0, "P1 19"); + P1 ((IDENT_INT(-12) .. -13 => 3), -12, -13, "P1 21"); + + RESULT; + END C36205I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205j.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,180 ---- + -- C36205J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF SLICES AND AGGREGATES OF MORE COMPLEX FORMS + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205J IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + TYPE STR IS NEW STRING; + ALF : CONSTANT STR := STR(IDENT_STR("ABCDE")); + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205J", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - COMPLEX MIXTURE OF SLICES/AGGREGATES"); + + FOR J IN IDENT_INT (-3) .. IDENT_INT (3) LOOP + FOR K IN J - 1 .. 2 LOOP + P1 ((J .. K => 0), J, K, "X"); + P1 (A10 (J + 4 .. K + 4), J+4, K+4, "Y"); + END LOOP; + END LOOP; + FOR I IN 18 .. 20 LOOP + FOR J IN I-1 .. 20 LOOP + P1 (A20 (I .. J), I, J, "A20 88"); + END LOOP; + END LOOP; + FOR I IN 1 .. 5 LOOP + FOR J IN I - 1 .. 5 LOOP + S1( ALF (I .. J), I, J, "ALF 1"); + S1 (ARF (I+4..J+4), I+4, J+4, "ARF 4"); + END LOOP; + END LOOP; + + RESULT; + END C36205J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205k.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- C36205K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ATTRIBUTES GIVE THE CORRECT VALUES FOR + -- UNCONSTRAINED FORMAL PARAMETERS. + + -- ATTRIBUTES OF SLICE OF SLICE + + -- DAT 2/17/81 + -- JBG 9/11/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36205K IS + + USE REPORT; + + TYPE I_A IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + TYPE I_A_2 IS ARRAY (INTEGER RANGE <> , + INTEGER RANGE <> ) OF INTEGER; + A10 : I_A (1 .. 10); + A20 : I_A (18 .. 20); + I10 : INTEGER := IDENT_INT (10); + A2_10 : I_A_2 (1 .. I10, 3+I10 .. I10+I10); -- 1..10, 13..20 + A2_20 : I_A_2 (11 .. 3*I10, I10+11 .. I10+I10); -- 11..30, 21..20 + TYPE STR IS NEW STRING; + ALF : CONSTANT STR := STR(IDENT_STR("ABCDE")); + ARF : STR(5 .. 9) := ALF; + + PROCEDURE P1 (A : I_A; FIR, LAS: INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= FIR + OR A'FIRST(1) /= FIR + THEN + FAILED ("'FIRST IS WRONG " & S); + END IF; + + IF A'LAST /= LAS + OR A'LAST(1) /= LAS + THEN + FAILED ("'LAST IS WRONG " & S); + END IF; + + IF A'LENGTH /= LAS - FIR + 1 + OR A'LENGTH /= A'LENGTH(1) + THEN + FAILED ("'LENGTH IS WRONG " & S); + END IF; + + IF (LAS NOT IN A'RANGE AND LAS >= FIR) + OR (FIR NOT IN A'RANGE AND LAS >= FIR) + OR FIR - 1 IN A'RANGE + OR LAS + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE IS WRONG " & S); + END IF; + + END P1; + + PROCEDURE P2 (A : I_A_2; F1,L1,F2,L2 : INTEGER; S : STRING) IS + BEGIN + IF A'FIRST /= A'FIRST(1) + OR A'FIRST /= F1 + THEN + FAILED ("'FIRST(1) IS WRONG " & S); + END IF; + + IF A'LAST(1) /= L1 THEN + FAILED ("'LAST(1) IS WRONG " & S); + END IF; + + IF A'LENGTH(1) /= A'LENGTH + OR A'LENGTH /= L1 - F1 + 1 + THEN + FAILED ("'LENGTH(1) IS WRONG " & S); + END IF; + + IF F1 - 1 IN A'RANGE + OR (F1 NOT IN A'RANGE AND F1 <= L1) + OR (L1 NOT IN A'RANGE(1) AND F1 <= L1) + OR L1 + 1 IN A'RANGE(1) + THEN + FAILED ("'RANGE(1) IS WRONG " & S); + END IF; + + IF A'FIRST(2) /= F2 THEN + FAILED ("'FIRST(2) IS WRONG " & S); + END IF; + + IF A'LAST(2) /= L2 THEN + FAILED ("'LAST(2) IS WRONG " & S); + END IF; + + IF L2 - F2 /= A'LENGTH(2) - 1 THEN + FAILED ("'LENGTH(2) IS WRONG " & S); + END IF; + + IF F2 - 1 IN A'RANGE(2) + OR (F2 NOT IN A'RANGE(2) AND A'LENGTH(2) > 0) + OR (L2 NOT IN A'RANGE(2) AND A'LENGTH(2) /= 0) + OR L2 + 1 IN A'RANGE(2) + THEN + FAILED ("'RANGE(2) IS WRONG " & S); + END IF; + END P2; + + PROCEDURE S1 (S:STR; F,L:INTEGER; MESS:STRING) IS + BEGIN + IF S'FIRST /= F THEN + FAILED ("STRING 'FIRST IS WRONG " & MESS); + END IF; + + IF S'LAST(1) /= L THEN + FAILED ("STRING 'LAST IS WRONG " & MESS); + END IF; + + IF S'LENGTH /= L - F + 1 + OR S'LENGTH(1) /= S'LENGTH + THEN + FAILED ("STRING 'LENGTH IS WRONG " & MESS); + END IF; + + IF (F <= L AND + (F NOT IN S'RANGE + OR L NOT IN S'RANGE + OR F NOT IN S'RANGE(1) + OR L NOT IN S'RANGE(1))) + OR F - 1 IN S'RANGE + OR L + 1 IN S'RANGE(1) + THEN + FAILED ("STRING 'RANGE IS WRONG " & MESS); + END IF; + END S1; + + BEGIN + TEST ( "C36205K", "CHECKING ATTRIBUTE VALUES POSSESSED BY FORMAL "& + "PARAMETERS WHOSE ACTUALS ARE UNCONSTRAINED " & + "ARRAYS - SLICES OF SLICES"); + + FOR I IN 18 .. 20 LOOP + FOR J IN I-1 .. 20 LOOP + P1 (A20 (A20'RANGE)(I..J), I, J, "A20 99"); + END LOOP; + END LOOP; + FOR I IN 1 .. 5 LOOP + FOR J IN I - 1 .. 5 LOOP + S1 (ALF (1..5)(I..J),I,J,"ALF 3"); + END LOOP; + END LOOP; + + RESULT; + END C36205K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36205l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36205l.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,288 ---- + -- C36205L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE + -- FOR GENERIC PROCEDURES, CHECK THAT ATTRIBUTES GIVE THE + -- CORRECT VALUES FOR UNCONSTRAINED FORMAL PARAMETERS. + -- BASIC CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS PASSED AS + -- PARAMETERS TO GENERIC PROCEDURES + + -- HISTORY + -- EDWARD V. BERARD, 9 AUGUST 1990 + -- DAS 8 OCT 1990 ADDED OUT MODE PARAMETER TO GENERIC + -- PROCEDURE TEST_PROCEDURE AND FORMAL + -- GENERIC PARAMETER COMPONENT_VALUE. + + WITH REPORT ; + + PROCEDURE C36205L IS + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + MEDIUM_START : CONSTANT := 1 ; + MEDIUM_END : CONSTANT := 100 ; + TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ; + MEDIUM_LENGTH : CONSTANT NATURAL := (MEDIUM_END - MEDIUM_START + + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 9, + YEAR => 1990) ; + + SUBTYPE SHORT_STRING IS STRING (1 ..5) ; + + DEFAULT_STRING : SHORT_STRING := "ABCDE" ; + + TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>, + MEDIUM_RANGE RANGE <>) OF DATE ; + + TYPE SECOND_TEMPLATE IS ARRAY (MONTH_TYPE RANGE <>, + DAY_TYPE RANGE <>) OF SHORT_STRING ; + + TYPE THIRD_TEMPLATE IS ARRAY (CHARACTER RANGE <>, + BOOLEAN RANGE <>) OF DAY_TYPE ; + + FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 27 .. 35) + := (-10 .. 10 => + (27 .. 35 => TODAY)) ; + SECOND_ARRAY : SECOND_TEMPLATE (JAN .. JUN, 1 .. 25) + := (JAN .. JUN => + (1 .. 25 => DEFAULT_STRING)) ; + THIRD_ARRAY : THIRD_TEMPLATE ('A' .. 'Z', FALSE .. TRUE) + := ('A' .. 'Z' => + (FALSE .. TRUE => DAY_TYPE (9))) ; + + FOURTH_ARRAY : FIRST_TEMPLATE (0 .. 27, 75 .. 100) + := (0 .. 27 => + (75 .. 100 => TODAY)) ; + FIFTH_ARRAY : SECOND_TEMPLATE (JUL .. OCT, 6 .. 10) + := (JUL .. OCT => + (6 .. 10 => DEFAULT_STRING)) ; + SIXTH_ARRAY : THIRD_TEMPLATE ('X' .. 'Z', TRUE .. TRUE) + := ('X' .. 'Z' => + (TRUE .. TRUE => DAY_TYPE (31))) ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + TYPE UNCONSTRAINED_ARRAY IS ARRAY (FIRST_INDEX RANGE <>, + SECOND_INDEX RANGE <>) OF COMPONENT_TYPE ; + COMPONENT_VALUE: IN COMPONENT_TYPE; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : OUT UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : OUT UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- TEST_PROCEDURE + + IF (FIRST'FIRST /= FFIFS) OR + (FIRST'FIRST (1) /= FFIFS) OR + (FIRST'FIRST (2) /= FSIFS) OR + (SECOND'FIRST /= SFIFS) OR + (SECOND'FIRST (1) /= SFIFS) OR + (SECOND'FIRST (2) /= SSIFS) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FFILS) OR + (FIRST'LAST (1) /= FFILS) OR + (FIRST'LAST (2) /= FSILS) OR + (SECOND'LAST /= SFILS) OR + (SECOND'LAST (1) /= SFILS) OR + (SECOND'LAST (2) /= SSILS) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= FFLEN) OR + (FIRST'LENGTH (1) /= FFLEN) OR + (FIRST'LENGTH (2) /= FSLEN) OR + (SECOND'LENGTH /= SFLEN) OR + (SECOND'LENGTH (1) /= SFLEN) OR + (SECOND'LENGTH (2) /= SSLEN) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE " & + "ATTRIBUTE. " & REMARKS) ; + END IF ; + + -- ASSIGN VALUES TO THE ARRAY PARAMETER OF MODE OUT + FOR I IN SECOND'RANGE(1) LOOP + FOR J IN SECOND'RANGE(2) LOOP + SECOND(I, J) := COMPONENT_VALUE; + END LOOP; + END LOOP; + + END TEST_PROCEDURE ; + + PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + COMPONENT_TYPE => DATE, + UNCONSTRAINED_ARRAY => FIRST_TEMPLATE, + COMPONENT_VALUE => TODAY) ; + + PROCEDURE SECOND_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => MONTH_TYPE, + SECOND_INDEX => DAY_TYPE, + COMPONENT_TYPE => SHORT_STRING, + UNCONSTRAINED_ARRAY => SECOND_TEMPLATE, + COMPONENT_VALUE => DEFAULT_STRING) ; + + PROCEDURE THIRD_TEST_PROCEDURE IS NEW TEST_PROCEDURE ( + FIRST_INDEX => CHARACTER, + SECOND_INDEX => BOOLEAN, + COMPONENT_TYPE => DAY_TYPE, + UNCONSTRAINED_ARRAY => THIRD_TEMPLATE, + COMPONENT_VALUE => DAY_TYPE'FIRST) ; + + + BEGIN -- C36205L + + REPORT.TEST ( "C36205L","FOR GENERIC PROCEDURES, CHECK THAT " & + "ATTRIBUTES GIVE THE CORRECT VALUES FOR " & + "UNCONSTRAINED FORMAL PARAMETERS. BASIC " & + "CHECKS OF ARRAY OBJECTS AND WHOLE ARRAYS " & + "PASSED AS PARAMETERS TO GENERIC PROCEDURES"); + + FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY, + FFIFS => -10, + FFILS => 10, + FSIFS => 27, + FSILS => 35, + FFLEN => 21, + FSLEN => 9, + FFIRT => 0, + FSIRT => 29, + SECOND => FOURTH_ARRAY, + SFIFS => 0, + SFILS => 27, + SSIFS => 75, + SSILS => 100, + SFLEN => 28, + SSLEN => 26, + SFIRT => 5, + SSIRT => 100, + REMARKS => "FIRST_TEST_PROCEDURE") ; + + SECOND_TEST_PROCEDURE (FIRST => SECOND_ARRAY, + FFIFS => JAN, + FFILS => JUN, + FSIFS => 1, + FSILS => 25, + FFLEN => 6, + FSLEN => 25, + FFIRT => MAR, + FSIRT => 17, + SECOND => FIFTH_ARRAY, + SFIFS => JUL, + SFILS => OCT, + SSIFS => 6, + SSILS => 10, + SFLEN => 4, + SSLEN => 5, + SFIRT => JUL, + SSIRT => 6, + REMARKS => "SECOND_TEST_PROCEDURE") ; + + THIRD_TEST_PROCEDURE (FIRST => THIRD_ARRAY, + FFIFS => 'A', + FFILS => 'Z', + FSIFS => FALSE, + FSILS => TRUE, + FFLEN => 26, + FSLEN => 2, + FFIRT => 'T', + FSIRT => TRUE, + SECOND => SIXTH_ARRAY, + SFIFS => 'X', + SFILS => 'Z', + SSIFS => TRUE, + SSILS => TRUE, + SFLEN => 3, + SSLEN => 1, + SFIRT => 'Z', + SSIRT => TRUE, + REMARKS => "THIRD_TEST_PROCEDURE") ; + + REPORT.RESULT ; + + END C36205L ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36301a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36301a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36301a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36301a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C36301A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PREDEFINED POSITIVE AND STRING TYPES + -- ARE CORRECTLY DEFINED. + + -- DAT 2/17/81 + -- JBG 12/27/82 + -- RJW 1/20/86 - CHANGED 'NATURAL' TO 'POSITIVE'. ADDED ADDITIONAL + -- CASES, INCLUDING A CHECK FOR STRINGS WITH BOUNDS + -- OF INTEGER'FIRST AND INTEGER'LAST. + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + + PROCEDURE C36301A IS + + BEGIN + TEST ( "C36301A", "CHECK ATTRIBUTES OF PREDEFINED POSITIVE " & + "AND STRING" ); + + BEGIN + IF POSITIVE'FIRST /= 1 THEN + FAILED ( "POSITIVE'FIRST IS WRONG" ); + END IF; + + IF POSITIVE'LAST /= INTEGER'LAST THEN + FAILED ( "POSITIVE'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + C : STRING (1..2) := ( 'A', 'B' ); + + BEGIN + IF C'LENGTH /= 2 THEN + FAILED ( "LENGTH OF C IS WRONG" ); + END IF; + + IF C'FIRST /= 1 THEN + FAILED ( "C'FIRST IS WRONG" ); + END IF; + + IF C'LAST /= 2 THEN + FAILED ( "C'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + SUBTYPE LARGE IS STRING ( INTEGER'LAST - 3 .. INTEGER'LAST ); + + BEGIN + IF LARGE'LENGTH /= 4 THEN + FAILED ( "LENGTH OF LARGE IS WRONG" ); + END IF; + + IF LARGE'FIRST /= INTEGER'LAST - 3 THEN + FAILED ( "LARGE'FIRST IS WRONG" ); + END IF; + + IF LARGE'LAST /= INTEGER'LAST THEN + FAILED ( "LARGE'LAST IS WRONG" ); + END IF; + END; + + DECLARE + + SUBTYPE LARGER IS STRING ( 1 .. INTEGER'LAST ); + + BEGIN + IF LARGER'LENGTH /= INTEGER'LAST THEN + FAILED ( "LENGTH OF LARGER IS WRONG" ); + END IF; + + IF LARGER'FIRST /= 1 THEN + FAILED ( "LARGER'FIRST IS WRONG" ); + END IF; + + IF LARGER'LAST /= INTEGER'LAST THEN + FAILED ( "LARGER'LAST IS WRONG" ); + END IF; + END; + + BEGIN + DECLARE + + D : STRING ( INTEGER'FIRST .. INTEGER'FIRST + 3 ); + + BEGIN + IF D'FIRST /= INTEGER'FIRST THEN -- USE D + FAILED ("D'FIRST IS INCORRECT " & INTEGER'IMAGE(D'FIRST)); + END IF; + FAILED ( "NO EXCEPTION RAISED" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + + BEGIN + DECLARE + + E : STRING ( -1 .. INTEGER'FIRST ); + + BEGIN + IF E'LENGTH /= 0 THEN + FAILED ( "LENGTH OF E IS WRONG" ); + END IF; + + IF E'FIRST /= -1 THEN + FAILED ( "E'FIRST IS WRONG" ); + END IF; + + IF E'LAST /= INTEGER'FIRST THEN + FAILED ( "E'LAST IS WRONG" ); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED FOR NULL STRING" ); + END; + + RESULT; + END C36301A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36301b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36301b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36301b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36301b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- C36301B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PREDEFINED STRING ATTRIBUTES ARE CORRECTLY IMPLEMENTED. + + -- CASE B: STRING OF LENGTH INTEGER'LAST + + -- DAT 2/17/81 + -- JBG 12/28/82 + + WITH REPORT; + PROCEDURE C36301B IS + + USE REPORT; + + SUBTYPE STR2 IS STRING (1..INTEGER'LAST); + + BEGIN + TEST("C36301B", "CHECK ATTRIBUTES OF LONGEST STRING"); + + IF STR2'FIRST /= 1 THEN + FAILED ("STR'FIRST NOT 1"); + END IF; + + IF STR2'LAST /= INTEGER'LAST THEN + FAILED ("STR'LAST NOT INTEGER'LAST"); + END IF; + + IF STR2'LENGTH /= INTEGER'LAST THEN + FAILED ("'LENGTH NOT INTEGER'LAST"); + END IF; + + RESULT; + END C36301B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36302a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36302a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36302a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36302a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- C36302A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STRING VARIABLE MAY BE DECLARED WITH AN INDEX + -- STARTING WITH AN INTEGER GREATER THAN 1. + + -- DAT 2/17/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C36302A IS + + USE REPORT; + + S5 : STRING (5 .. 10); + SX : STRING (INTEGER'LAST - 5 .. INTEGER'LAST); + + BEGIN + TEST ("C36302A", "STRING VARIABLE INDICES NEEDN'T START AT 1"); + + IF S5'FIRST /= 5 + OR S5'LAST /= 10 + OR S5'LENGTH /= 6 + OR SX'FIRST /= INTEGER'LAST - 5 + OR SX'LAST /= INTEGER'LAST + OR SX'LENGTH /= 6 + THEN + FAILED ("WRONG STRING ATTRIBUTES"); + END IF; + + RESULT; + END C36302A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36304a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C36304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BOUNDS OF CONSTANT STRING OBJECTS IF NOT GIVEN IN + -- THE DECLARATIONS ARE DETERMINED BY THE STRINGS' INITIAL VALUES. + + -- DAT 2/17/81 + -- JBG 8/21/83 + + WITH REPORT; + PROCEDURE C36304A IS + + USE REPORT; + + I3 : INTEGER := IDENT_INT (3); + + S3 : CONSTANT STRING := "ABC"; + S0 : CONSTANT STRING := ""; + S1 : CONSTANT STRING := "A"; + S2 : CONSTANT STRING := "AB"; + S5 : CONSTANT STRING := "ABCDE"; + S3A : CONSTANT STRING (I3 .. I3 + 2) := S3(I3 - 2 .. I3); + S3C : CONSTANT STRING := S3A; + S3D : CONSTANT STRING := S3C & ""; + S3E : CONSTANT STRING := S3D; + X3 : CONSTANT STRING := (I3 .. 5 => 'X'); + Y3 : CONSTANT STRING := X3; + Z0 : CONSTANT STRING := (-3..-5 => 'A'); + + PROCEDURE C (S : STRING; + FIRST, LAST, LENGTH : INTEGER; + ID : STRING) IS + BEGIN + IF S'FIRST /= FIRST THEN + FAILED ("'FIRST IS " & INTEGER'IMAGE(S'FIRST) & + " INSTEAD OF " & INTEGER'IMAGE(FIRST) & + " FOR " & ID); + END IF; + + IF S'LAST /= LAST THEN + FAILED ("'LAST IS " & INTEGER'IMAGE(S'LAST) & + " INSTEAD OF " & INTEGER'IMAGE(LAST) & + " FOR " & ID); + END IF; + + IF S'LENGTH /= LENGTH THEN + FAILED ("'LENGTH IS " & INTEGER'IMAGE(S'LENGTH) & + " INSTEAD OF " & INTEGER'IMAGE(LENGTH) & + " FOR " & ID); + END IF; + END C; + + BEGIN + TEST ("C36304A", "CHECK UNUSUAL CONSTANT STRING BOUNDS"); + + + C(S0, 1, 0, 0, "S0"); + C(S1, 1, 1, 1, "S1"); + C(S2, 1, 2, 2, "S2"); + C(S5, 1, 5, 5, "S5"); + C(S3, 1, 3, 3, "S3"); + C(S3C, 3, 5, 3, "S3C"); + C(S3D, 3, 5, 3, "S3D"); + C(S3E, 3, 5, 3, "S3E"); + C(X3, 3, 5, 3, "X3"); + C(Y3, 3, 5, 3, "Y3"); + C(Z0, IDENT_INT(-3), IDENT_INT(-5), IDENT_INT(0), "Z0"); + + RESULT; + END C36304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c36305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c36305a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C36305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STRING VARIABLE IS CONSIDERED AN ARRAY. + + -- DAT 2/17/81 + -- SPS 10/25/82 + -- EDS 07/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C36305A IS + + USE REPORT; + + S : STRING (IDENT_INT(5) .. IDENT_INT (10)); + T : STRING (S'RANGE); + U : STRING (T'FIRST .. T'LAST); + SUBTYPE I_5 IS INTEGER RANGE U'RANGE(1); + I5 : I_5; + C : CONSTANT STRING := "ABCDEF"; + + BEGIN + TEST ("C36305A", "CHECK THAT STRINGS ARE REALLY ARRAYS"); + + IF S'FIRST /= 5 + OR S'LAST /= 10 + OR S'LENGTH /= 6 + OR U'FIRST(1) /= 5 + OR U'LAST(1) /= 10 + OR U'LENGTH(1) /= 6 + THEN + FAILED ("INCORRECT STRING ATTRIBUTE VALUES"); + END IF; + + IF 4 IN U'RANGE + OR 3 IN U'RANGE(1) + OR 0 IN U'RANGE + OR 1 IN U'RANGE + OR 5 NOT IN U'RANGE + OR 7 NOT IN U'RANGE + OR 10 NOT IN U'RANGE + OR NOT (11 NOT IN U'RANGE) + THEN + FAILED ("INCORRECT STRING RANGE ATTRIBUTE"); + END IF; + + BEGIN + BEGIN + BEGIN + I5 := 4; + FAILED ("BAD I5 SUBRANGE 1 " & INTEGER'IMAGE(I5)); --use I5 + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + I5 := INTEGER'(11); + FAILED ("BAD I5 SUBRANGE 2 " & INTEGER'IMAGE(I5)); --use I5 + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1"); + END; + I5 := INTEGER'(5); + I5 := I5 + I5; + I5 := NATURAL'(8); + EXCEPTION + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + FOR I IN S'RANGE LOOP + S(I) := C(11 - I); + END LOOP; + T := S; + FOR I IN REVERSE U'RANGE LOOP + U(I) := T(15 - I); + END LOOP; + + FOR I IN 1 .. C'LENGTH LOOP + IF C(1 .. I) /= U(5 .. I + 4) + OR U(I + 4 .. U'LAST) /= C(I .. C'LAST) + OR C(I) /= U (I + 4) + OR C(I .. I)(I .. I)(I) /= U(U'RANGE)(I + 4) THEN + FAILED ("INCORRECT CHARACTER MISMATCH IN STRING"); + EXIT; + END IF; + END LOOP; + + IF U /= C + OR U /= "ABCDEF" + OR U(U'RANGE) /= C(C'RANGE) + OR U(5 .. 10) /= C(1 .. 6) + OR U(5 .. 6) /= C(1 .. 2) + THEN + FAILED ("STRINGS AS ARRAYS BEHAVE INCORRECTLY"); + END IF; + + RESULT; + END C36305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37002a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C37002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INDEX CONSTRAINTS WITH NON-STATIC EXPRESSIONS CAN BE + -- USED TO CONSTRAIN RECORD COMPONENTS HAVING AN ARRAY TYPE. + + -- RJW 2/28/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C37002A IS + + BEGIN + TEST ( "C37002A", "CHECK THAT INDEX CONSTRAINTS WITH " & + "NON-STATIC EXPRESSIONS CAN BE USED TO " & + "CONSTRAIN RECORD COMPONENTS HAVING AN " & + "ARRAY TYPE" ); + + DECLARE + X : INTEGER := IDENT_INT(5); + SUBTYPE S IS INTEGER RANGE 1 .. X; + TYPE AR1 IS ARRAY (S) OF INTEGER; + + SUBTYPE T IS INTEGER RANGE X .. 10; + TYPE AR2 IS ARRAY (T) OF INTEGER; + TYPE U IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE V IS INTEGER RANGE 1 .. 10; + + TYPE R IS + RECORD + A : STRING (1 .. X); + B : STRING (X .. 10); + C : AR1; + D : AR2; + E : STRING (S); + F : U(T); + G : U(V RANGE 1 ..X); + H : STRING (POSITIVE RANGE X .. 10); + I : U(AR1'RANGE); + J : STRING (AR2'RANGE); + END RECORD; + RR : R; + + BEGIN + IF RR.A'LAST /= 5 OR RR.B'FIRST /= 5 OR + RR.C'LAST /= 5 OR RR.D'FIRST /= 5 OR + RR.E'LAST /= 5 OR RR.F'FIRST /= 5 OR + RR.G'LAST /= 5 OR RR.H'FIRST /= 5 OR + RR.I'LAST /= 5 OR RR.J'FIRST /= 5 THEN + + FAILED("WRONG VALUE FOR NON-STATIC BOUND"); + + END IF; + + END; + + RESULT; + END C37002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37003a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- C37003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MULTIPLE COMPONENT DECLARATIONS ARE TREATED AS A SERIES + -- OF SINGLE COMNENT DECLARATIONS, I.E., THE COMPONENTS ALL HAVE THE + -- SAME TYPE AND ANY EXPRESSION USED IN CONSTRAINTS OR INITIALIZATIONS + -- IS EVALUATED ONCE FOR EACH COMPONENT. + + -- DAT 3/30/81 + -- SPS 10/26/82 + -- JWC 10/23/85 RENAMED FROM C37013A-AB.ADA. + -- ADDED TEST TO ENSURE THAT ANY EXPRESSION USED + -- IN A CONSTRAINT IS EVALUATED ONCE FOR EACH + -- COMPONENT. + -- JRK 11/15/85 ADDED INITIALIZATION EVALUATION CHECKS. + + WITH REPORT; USE REPORT; + + PROCEDURE C37003A IS + + X : INTEGER := 0; + + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + PROCEDURE RESET IS + BEGIN + X := 0; + END RESET; + + BEGIN + TEST ("C37003A", "CHECK THAT MULTIPLE COMPONENT DECLARATIONS " & + "ARE TREATED AS A SERIES OF SINGLE COMPONENT " & + "DECLARATIONS"); + + DECLARE + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE REC1 IS RECORD + A1, A2 : ARR (1 .. F) := (OTHERS => F); + END RECORD; + + R1 : REC1 := (OTHERS => (OTHERS => 1)); + Y : INTEGER := X; + R1A : REC1; + + BEGIN + + IF R1.A1 = R1.A2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR ARRAYS"); + END IF; + + IF X /= 5 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " & + "EACH ARRAY COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC2 IS RECORD + I1, I2 : INTEGER RANGE 1 .. F := F * IDENT_INT(0) + 1; + END RECORD; + + R2 : REC2 := (OTHERS => 1); + Y : INTEGER := X; + R2A : REC2; + + BEGIN + + IF R2.I1 = R2.I2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR SCALARS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED FOR " & + "EACH SCALAR COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC3X (DSC : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE REC3Y IS RECORD + I : INTEGER; + END RECORD; + + TYPE REC3 IS RECORD + RX1, RX2 : REC3X (F); + RY1, RY2 : REC3Y := (I => F); + END RECORD; + + R3 : REC3 := ((DSC => 1), (DSC => 2), (I => 0), (I => 0)); + Y : INTEGER := X; + R3A : REC3; + + BEGIN + + IF R3.RX1 = R3.RX2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR RECORDS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " & + "FOR EACH RECORD COMPONENT"); + END IF; + + RESET; + + END; + + DECLARE + + TYPE REC4X (DSC : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE ACR IS ACCESS REC4X; + TYPE ACI IS ACCESS INTEGER; + + TYPE REC4 IS RECORD + AC1, AC2 : ACR (F); + AC3, AC4 : ACI := NEW INTEGER'(F); + END RECORD; + + R4 : REC4 := (NULL, NULL, NULL, NULL); + Y : INTEGER := X; + R4A : REC4; + + BEGIN + + IF R4.AC1 = R4.AC2 THEN -- TEST TO SEE IF THE COMPONENTS + NULL; -- ARE OF THE SAME TYPE. + END IF; + + IF Y /= 2 THEN + FAILED ("CONSTRAINT EXPRESSION NOT EVALUATED TWICE " & + "FOR ACCESS"); + END IF; + + IF X /= 4 THEN + FAILED ("INITIALIZATION EXPRESSION NOT EVALUATED " & + "FOR EACH ACCESS COMPONENT"); + END IF; + + END; + + RESULT; + END C37003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37003b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- C37003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR A RECORD WITH MULTIPLE DISCRIMINANTS WHICH HAVE + -- DEFAULT EXPRESSIONS, THE EXPRESSIONS ARE EVALUATED ONCE FOR + -- EACH DISCRIMINANT IN THE ASSOCIATION. + + -- HISTORY: + -- DHH 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37003B IS + + X : INTEGER := 0; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F1; + + BEGIN + TEST("C37003B", "CHECK THAT FOR A RECORD WITH MULTIPLE " & + "DISCRIMINANTS WHICH HAVE DEFAULT EXPRESSIONS, " & + "THE EXPRESSIONS ARE EVALUATED ONCE FOR EACH " & + "DISCRIMINANT IN THE ASSOCIATION"); + + DECLARE + TYPE REC(D1, D2, D3, D4, D5 : INTEGER := F1) IS + RECORD + Y : INTEGER := (D1 + D2 + D3 + D4 + D5); + END RECORD; + + REC_F1 : REC; + + BEGIN + IF REC_F1.Y /= IDENT_INT(15) THEN + FAILED("MULTIPLE DISCRIMINANTS NOT EVALUATED " & + "SEPARATELY"); + END IF; + END; + + RESULT; + END C37003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37005a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C37005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SCALAR RECORD COMPONENTS MAY HAVE NON-STATIC + -- RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES. + + -- DAT 3/6/81 + -- JWC 6/28/85 RENAMED TO -AB + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C37005A IS + + USE REPORT; + + BEGIN + TEST ("C37005A", "SCALAR RECORD COMPONENTS MAY HAVE NON-STATIC" + & " RANGE CONSTRAINTS OR DEFAULT INITIAL VALUES"); + + DECLARE + SUBTYPE DT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5); + L : INTEGER := IDENT_INT (DT'FIRST); + R : INTEGER := IDENT_INT (DT'LAST); + SUBTYPE DT2 IS INTEGER RANGE L .. R; + M : INTEGER := (L + R) / 2; + + TYPE REC IS + RECORD + C1 : INTEGER := M; + C2 : DT2 := (L + R) / 2; + C3 : BOOLEAN RANGE (L < M) .. (R > M) + := IDENT_BOOL (TRUE); + C4 : INTEGER RANGE L .. R := DT'FIRST; + END RECORD; + + R1, R2 : REC := ((L+R)/2, M, M IN DT, L); + R3 : REC; + BEGIN + IF R3 /= R1 + THEN + FAILED ("INCORRECT RECORD VALUES"); + END IF; + + R3 := (R2.C2, R2.C1, R3.C3, R); -- CONSTRAINTS CHECKED BY := + IF EQUAL(IDENT_INT(1), 2) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(R3.C1)); --USE R3 + END IF; + + BEGIN + R3 := (M, M, IDENT_BOOL (FALSE), M); -- RAISES CON_ERR. + FAILED ("CONSTRAINT ERROR NOT RAISED " & INTEGER'IMAGE(R3.C1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + FOR I IN DT LOOP + R3 := (I, I, I /= 100, I); + R1.C2 := I; + IF EQUAL(IDENT_INT(1), 2) THEN + FAILED("IMPOSSIBLE " & + INTEGER'IMAGE(R3.C1 + R1.C2)); --USE R3, R1 + END IF; + END LOOP; + + EXCEPTION + WHEN OTHERS => FAILED ("INVALID EXCEPTION"); + END; + + RESULT; + END C37005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37006a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,272 ---- + -- C37006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A COMPONENT OF A RECORD, ACCESS, OR PRIVATE TYPE, OR FOR A + -- LIMITED PRIVATE COMPONENT, CHECK THAT A NON-STATIC EXPRESSION CAN + -- BE USED IN A DISCRIMINANT CONSTRAINT OR (EXCEPTING LIMITED PRIVATE + -- COMPONENTS) IN SPECIFYING A DEFAULT INITIAL VALUE. + + -- R.WILLIAMS 8/28/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37006A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 100; + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC1 (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + + TYPE REC1_NAME IS ACCESS REC1; + + PROCEDURE CHECK (AR : ARR; STR : STRING) IS + BEGIN + IF AR'FIRST /= 1 OR AR'LAST /= 2 THEN + FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN COMPONENT " & + "OF " & STR & " TYPE"); + ELSIF AR /= (3, 4) THEN + FAILED ( "INITIALIZATION OF R.COMP.A IN COMPONENT OF " & + STR & " TYPE FAILED" ); + END IF; + END CHECK; + + PACKAGE PACK IS + TYPE PRIV (D1, D2 : INT) IS PRIVATE; + TYPE LIM (D1, D2 : INT) IS LIMITED PRIVATE; + FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV; + PROCEDURE PRIV_CHECK (R : PRIV); + PROCEDURE LIM_CHECK (R : LIM); + + PRIVATE + TYPE PRIV (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + + TYPE LIM (D1, D2 : INT) IS + RECORD + A : ARR (D1 .. D2); + END RECORD; + END PACK; + + PACKAGE BODY PACK IS + + FUNCTION PRIV_FUN (PARM1, PARM2 : INTEGER) RETURN PRIV IS + BEGIN + RETURN (IDENT_INT (1), IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END PRIV_FUN; + + PROCEDURE PRIV_CHECK (R : PRIV) IS + BEGIN + CHECK (R.A, "PRIVATE TYPE" ); + END PRIV_CHECK; + + PROCEDURE LIM_CHECK (R : LIM) IS + BEGIN + IF R.A'FIRST /= 1 OR R.A'LAST /= 2 THEN + FAILED ( "INCORRECT BOUNDS FOR R.COMP.A IN " & + "COMPONENT OF LIMITED PRIVATE TYPE"); + END IF; + END LIM_CHECK; + END PACK; + + USE PACK; + + BEGIN + + TEST ( "C37006A", "FOR A COMPONENT OF A RECORD, ACCESS, " & + "OR PRIVATE TYPE, OR FOR A LIMITED PRIVATE " & + "COMPONENT, CHECK THAT A NON-STATIC " & + "EXPRESSION CAN BE USED IN A DISCRIMINANT " & + "CONSTRAINT OR (EXCEPTING LIMITED PRIVATE " & + "COMPONENTS) IN SPECIFYING A DEFAULT " & + "INITIAL VALUE" ); + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : REC1 (IDENT_INT (1), IDENT_INT (2)) := + (IDENT_INT (1), IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + CHECK (R.COMP.A, "RECORD"); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF RECORD TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "RECORD TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "RECORD TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF RECORD TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF RECORD TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : REC1_NAME (IDENT_INT (1), + IDENT_INT (2)) := + NEW REC1'(IDENT_INT (1), + IDENT_INT (2), + ARR'(1 => 3, 2 => 4)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + CHECK (R.COMP.A, "ACCESS"); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF ACCESS TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "ACCESS TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "ACCESS TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF ACCESS TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF ACCESS TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : PRIV (IDENT_INT (1), IDENT_INT (2)) := + PRIV_FUN (IDENT_INT (1), + IDENT_INT (2)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + PRIV_CHECK (R.COMP); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF PRIVATE TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "PRIVATE TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + "PRIVATE TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF PRIVATE TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF PRIVATE TYPE COMPONENT" ); + END; + + BEGIN + DECLARE + + TYPE REC2 IS + RECORD + COMP : LIM (IDENT_INT (1), IDENT_INT (2)); + END RECORD; + + R : REC2; + + BEGIN + IF R.COMP.D1 = 1 AND R.COMP.D2 = 2 THEN + LIM_CHECK (R.COMP); + ELSE + FAILED ( "INCORRECT VALUE FOR DISCRIMINANTS " & + "OF LIM PRIV TYPE COMPONENT" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + " LIM PRIV TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED IN STATEMENT " & + "SEQUENCE FOLLOWING DECLARATION OF " & + " LIM PRIV TYPE COMPONENT" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED BY DECLARATION " & + "OF LIM PRIV TYPE COMPONENT" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED BY DECLARATION " & + "OF LIM PRIV TYPE COMPONENT" ); + END; + + RESULT; + + END C37006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37008a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,270 ---- + -- C37008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SPECIFYING AN INVALID DEFAULT INITIALIZATION + -- RAISES CONSTRAINT_ERROR WHEN AN OBJECT IS DECLARED. + + -- DAT 3/6/81 + -- SPS 10/26/82 + -- RJW 1/9/86 - REVISED COMMENTS. ADDED 'IDENT_INT'. + -- EDS 7/22/98 AVOID OPTIMIZATION + + WITH REPORT; + USE REPORT; + PROCEDURE C37008A IS + BEGIN + TEST ("C37008A", "CHECK THAT INVALID DEFAULT RECORD" + & " COMPONENT INITIALIZATIONS RAISE" + & " CONSTRAINT_ERROR"); + + BEGIN + DECLARE + TYPE R1 IS RECORD + C1 : INTEGER RANGE 1 .. 5 := IDENT_INT (0); + END RECORD; + REC1 : R1; + BEGIN + FAILED ("NO EXCEPTION RAISED 1 " & INTEGER'IMAGE(REC1.C1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + C : CHARACTER RANGE 'A' .. 'Y' := 'Z'; + END RECORD; + REC2 : R; + BEGIN + FAILED ("NO EXCEPTION RAISED 1A " & (REC2.C)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 1A"); + END; + + BEGIN + DECLARE + TYPE R2 IS RECORD + C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE; + END RECORD; + REC3 : R2; + BEGIN + FAILED ("NO EXCEPTION RAISED 2 " & BOOLEAN'IMAGE(REC3.C2)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + TYPE E IS (E1, E2, E3); + TYPE R IS RECORD + C : E RANGE E2 .. E3 := E1; + END RECORD; + REC4 : R; + BEGIN + FAILED ("NO EXCEPTION RAISED 2A " & E'IMAGE(REC4.C)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2A"); + END; + + BEGIN + DECLARE + TYPE R3 IS RECORD + C3 : INTEGER RANGE 1 .. 5; + END RECORD; + REC5 : R3; + TYPE R3A IS RECORD + C3A : R3 := (OTHERS => IDENT_INT (6)); + END RECORD; + REC6 : R3A; + BEGIN + FAILED ("NO EXCEPTION RAISED 3 " & + INTEGER'IMAGE(REC6.C3A.C3)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9; + TYPE R4 IS RECORD + C4 : ARR + := (1 => 8, 2 => 9, 3 => 10); + END RECORD; + REC7 : R4; + BEGIN + FAILED ("NO EXCEPTION RAISED 4 " & + INTEGER'IMAGE(REC7.C4(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 4"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A; + + TYPE R5 IS RECORD + C5 : AA := NEW A' (4, 5, 6); + END RECORD; + REC8 : R5; + BEGIN + FAILED ("NO EXCEPTION RAISED 5 " & + INTEGER'IMAGE(REC8.C5(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (1 .. 3); + + TYPE R6 IS RECORD + C6 : AA := NEW A' (4, 4, 4, 4); + END RECORD; + REC9 : R6; + BEGIN + FAILED ("NO EXCEPTION RAISED 6 " & + INTEGER'IMAGE(REC9.C6(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 6"); + END; + + BEGIN + DECLARE + TYPE AI IS ACCESS INTEGER RANGE 6 .. 8; + + TYPE R7 IS RECORD + C7 : AI := NEW INTEGER' (5); + END RECORD; + REC10 : R7; + BEGIN + FAILED ("NO EXCEPTION RAISED 7 " & + INTEGER'IMAGE(REC10.C7.ALL)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 7"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. 5; + + SUBTYPE CA IS UA (7 .. 8); + + TYPE R8 IS RECORD + C8 : CA := (6 .. 8 => 4); + END RECORD; + REC11 : R8; + BEGIN + FAILED ("NO EXCEPTION RAISED 8 " & + INTEGER'IMAGE(REC11.C8(7))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. IDENT_INT(5); + + TYPE R9 IS RECORD + C9 : UA (11 .. 11) := (11 => 6); + END RECORD; + REC12 : R9; + BEGIN + FAILED ("NO EXCEPTION RAISED 9 " & + INTEGER'IMAGE(REC12.C9(11))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. IDENT_INT (5); + + TYPE AA IS ACCESS A; + + TYPE R10 IS RECORD + C10 : AA := NEW A '(4, 5, 6); + END RECORD; + REC13 : R10; + BEGIN + FAILED ("NO EXCEPTION RAISED 10 " & + INTEGER'IMAGE(REC13.C10(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3)); + + TYPE R11 IS RECORD + C11 : AA := NEW A '(4, 4, 4, 4); + END RECORD; + REC14 : R11; + BEGIN + FAILED ("NO EXCEPTION RAISED 11 " & + INTEGER'IMAGE(REC14.C11(1))); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 11"); + END; + + RESULT; + END C37008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37008b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,232 ---- + -- C37008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NO CONSTRAINT ERROR IS RAISED FOR AN UNUSED TYPE + -- DECLARATION WITH AN INVALID DEFAULT VALUE + + -- JBG 9/11/81 + -- SPS 10/25/82 + + WITH REPORT; + USE REPORT; + PROCEDURE C37008B IS + BEGIN + TEST ("C37008B", "CHECK THAT INVALID DEFAULT RECORD" + & " COMPONENT INITIALIZATIONS DO NOT RAISE" + & " CONSTRAINT_ERROR"); + + BEGIN + DECLARE + TYPE R1 IS RECORD + C1 : INTEGER RANGE 1 .. 5 := 0; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + TYPE R IS RECORD + C : CHARACTER RANGE 'A' .. 'Y' := 'Z'; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 1A"); + END; + + BEGIN + DECLARE + TYPE R2 IS RECORD + C2 : BOOLEAN RANGE FALSE .. FALSE := TRUE; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + TYPE E IS (E1, E2, E3); + TYPE R IS RECORD + C : E RANGE E2 .. E3 := E1; + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 2A"); + END; + + BEGIN + DECLARE + TYPE R3 IS RECORD + C3 : INTEGER RANGE 1 .. 5; + END RECORD; + TYPE R3A IS RECORD + C3A : R3 := (OTHERS => 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..3) OF INTEGER RANGE 8..9; + TYPE R4 IS RECORD + C4 : ARR + := (1 => 8, 2 => 9, 3 => 10); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 4"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A; + + TYPE R5 IS RECORD + C5 : AA := NEW A'(4, 5, 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (1 .. 3); + + TYPE R6 IS RECORD + C6 : AA := NEW A'(4, 4, 4, 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 6"); + END; + + BEGIN + DECLARE + TYPE AI IS ACCESS INTEGER RANGE 6 .. 8; + + TYPE R7 IS RECORD + C7 : AI := NEW INTEGER'(5); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 7"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. 5; + + SUBTYPE CA IS UA (7 .. 8); + + TYPE R8 IS RECORD + C8 : CA := (6 .. 8 => 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 8"); + END; + + BEGIN + DECLARE + TYPE UA IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 3 .. IDENT_INT(5); + + TYPE R9 IS RECORD + C9 : UA (11 .. 11) := (11 => 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 9"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. IDENT_INT (5); + + TYPE AA IS ACCESS A; + + TYPE R10 IS RECORD + C10 : AA := NEW A'(4, 5, 6); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 10"); + END; + + BEGIN + DECLARE + TYPE A IS ARRAY (NATURAL RANGE <> ) + OF INTEGER RANGE 1 .. 5; + + TYPE AA IS ACCESS A (IDENT_INT (1) .. IDENT_INT (3)); + + TYPE R11 IS RECORD + C11 : AA := NEW A'(4, 4, 4, 4); + END RECORD; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED 11"); + END; + + RESULT; + END C37008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37009a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C37009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN UNCONSTRAINED RECORD TYPE CAN BE USED TO DECLARE A + -- RECORD COMPONENT THAT CAN BE INITIALIZED WITH AN APPROPRIATE + -- EXPLICIT OR DEFAULT VALUE. + + -- HISTORY: + -- DHH 02/01/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C37009A IS + + TYPE FLOAT IS DIGITS 5; + TYPE COLOR IS (RED, YELLOW, BLUE); + + TYPE COMPONENT IS + RECORD + I : INTEGER := 1; + X : FLOAT := 3.5; + BOL : BOOLEAN := FALSE; + FIRST : COLOR := RED; + END RECORD; + TYPE COMP_DIS(A : INTEGER := 1) IS + RECORD + I : INTEGER := 1; + X : FLOAT := 3.5; + BOL : BOOLEAN := FALSE; + FIRST : COLOR := RED; + END RECORD; + SUBTYPE SMAL_INTEGER IS INTEGER RANGE 1 .. 10; + TYPE LIST IS ARRAY(INTEGER RANGE <>) OF FLOAT; + + TYPE DISCRIM(P : SMAL_INTEGER := 2) IS + RECORD + A : LIST(1 .. P) := (1 .. P => 1.25); + END RECORD; + + TYPE REC_T IS -- EXPLICIT INIT. + RECORD + T : COMPONENT := (5, 6.0, TRUE, YELLOW); + U : DISCRIM(3) := (3, (1 .. 3 => 2.25)); + L : COMP_DIS(5) := (A => 5, I => 5, X => 6.0, + BOL =>TRUE, FIRST => YELLOW); + END RECORD; + + TYPE REC_DEF_T IS -- DEFAULT INIT. + RECORD + T : COMPONENT; + U : DISCRIM; + L : COMP_DIS; + END RECORD; + + REC : REC_T; + REC_DEF : REC_DEF_T; + + FUNCTION IDENT_FLT(X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION IDENT_ENUM(X : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN BLUE; + END IF; + END IDENT_ENUM; + + BEGIN + TEST("C37009A", "CHECK THAT AN UNCONSTRAINED RECORD TYPE CAN " & + "BE USED TO DECLARE A RECORD COMPONENT THAT " & + "CAN BE INITIALIZED WITH AN APPROPRIATE " & + "EXPLICIT OR DEFAULT VALUE"); + + IF REC_DEF.T.I /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER"); + END IF; + + IF IDENT_BOOL(REC_DEF.T.BOL) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN"); + END IF; + + IF REC_DEF.T.X /= IDENT_FLT(3.5) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL"); + END IF; + + IF REC_DEF.T.FIRST /= IDENT_ENUM(RED) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION"); + END IF; + + FOR I IN 1 .. 2 LOOP + IF REC_DEF.U.A(I) /= IDENT_FLT(1.25) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ARRAY " & + "POSITION " & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + IF REC_DEF.L.A /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF DISCRIMINANT " & + "- L"); + END IF; + + IF REC_DEF.L.I /= IDENT_INT(1) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF INTEGER - L"); + END IF; + + IF IDENT_BOOL(REC_DEF.L.BOL) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF BOOLEAN - L"); + END IF; + + IF REC_DEF.L.X /= IDENT_FLT(3.5) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF REAL - L"); + END IF; + + IF REC_DEF.L.FIRST /= IDENT_ENUM(RED) THEN + FAILED("INCORRECT DEFAULT INITIALIZATION OF ENUMERATION - L"); + END IF; + -------------------------------------------------------------------- + IF REC.T.I /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER"); + END IF; + + IF NOT IDENT_BOOL(REC.T.BOL) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN"); + END IF; + + IF REC.T.X /= IDENT_FLT(6.0) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL"); + END IF; + + IF REC.T.FIRST /= YELLOW THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION"); + END IF; + + FOR I IN 1 .. 3 LOOP + IF REC.U.A(I) /= IDENT_FLT(2.25) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ARRAY " & + "POSITION " & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + IF REC.L.A /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF DISCRIMINANT " & + "- L"); + END IF; + + IF REC.L.I /= IDENT_INT(5) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF INTEGER - L"); + END IF; + + IF NOT IDENT_BOOL(REC.L.BOL) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF BOOLEAN - L"); + END IF; + + IF REC.L.X /= IDENT_FLT(6.0) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF REAL - L"); + END IF; + + IF REC.L.FIRST /= IDENT_ENUM(YELLOW) THEN + FAILED("INCORRECT EXPLICIT INITIALIZATION OF ENUMERATION " & + "- L"); + END IF; + + RESULT; + + END C37009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37010a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- C37010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXPRESSIONS IN CONSTRAINTS OF COMPONENT DECLARATIONS ARE + -- EVALUATED IN THE ORDER THE COMPONENTS APPEAR. + + -- R.WILLIAMS 8/22/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37010A IS + + TYPE R (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS R; + + TYPE ARR IS ARRAY (POSITIVE RANGE <> ) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + BUMP : INTEGER := 0; + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END; + + BEGIN + TEST ( "C37010A", "CHECK THAT EXPRESSIONS IN CONSTRAINTS OF " & + "COMPONENT DECLARATIONS ARE EVALUATED IN " & + "THE ORDER THE COMPONENTS APPEAR" ); + + DECLARE + + TYPE REC1 IS + RECORD + A1 : R (D => F); + B1 : STRING (1 .. F); + C1 : ACCR (F); + D1 : ACCA (1 .. F); + END RECORD; + + R1 : REC1; + + BEGIN + IF R1.A1.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R1.A1.D" ); + END IF; + + IF R1.B1'LAST /= 2 THEN + FAILED ( "INCORRECT VALUE FOR R1.B1'LAST" ); + END IF; + + BEGIN + R1.C1 := NEW R'(D => 3); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.C1" ); + END; + + BEGIN + R1.D1 := NEW ARR (1 .. 4); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.D1" ); + END; + + END; + + BUMP := 0; + + DECLARE + + TYPE REC2 (I : INTEGER) IS + RECORD + CASE I IS + WHEN 1 => + NULL; + WHEN OTHERS => + A2 : R (D => F); + B2 : ARR (1 .. F); + C2 : ACCR (F); + D2 : ACCA (1 .. F); + END CASE; + END RECORD; + + R2 : REC2 (IDENT_INT (2)); + + BEGIN + + IF R2.A2.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R2.A2.D" ); + END IF; + + IF R2.B2'LAST /= 2 THEN + FAILED ( "INCORRECT VALUE FOR R2.B2'LAST" ); + END IF; + + BEGIN + R2.C2 := NEW R (D => 3); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.C2" ); + END; + + BEGIN + R2.D2 := NEW ARR (1 .. 4); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.D2" ); + END; + + END; + + RESULT; + END C37010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37010b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37010b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37010b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37010b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C37010B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXPRESSIONS IN AN INDEX CONSTRAINT OR DISCRIMINANT + -- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT DECLARATION IS + -- ELABORATED EVEN IF SOME BOUNDS OR DISCRIMINANTS ARE GIVEN BY + -- A DISCRIMINANT OF AN ENCLOSING RECORD TYPE. + + -- R.WILLIAMS 8/22/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37010B IS + + INIT :INTEGER := IDENT_INT (5); + + TYPE R (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS R; + + TYPE ARR IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + + TYPE ACCA IS ACCESS ARR; + + FUNCTION RESET (N : INTEGER) RETURN INTEGER IS + BEGIN + INIT := IDENT_INT (N); + RETURN N; + END RESET; + + BEGIN + TEST ( "C37010B", "CHECK THAT EXPRESSIONS IN AN INDEX " & + "CONSTRAINT OR DISCRIMINANT CONSTRAINT " & + "ARE EVALUATED WHEN THE COMPONENT " & + "DECLARATION IS ELABORATED EVEN IF SOME " & + "BOUNDS OR DISCRIMINANTS ARE GIVEN BY " & + "A DISCRIMINANT OF AN ENCLOSING RECORD TYPE" ); + + DECLARE + + TYPE REC1 (D : INTEGER) IS + RECORD + W1 : R (D1 => INIT, D2 => D); + X1 : ARR (INIT .. D); + Y1 : ACCR (D, INIT); + Z1 : ACCA (D .. INIT); + END RECORD; + + INT1 : INTEGER := RESET (10); + + R1 : REC1 (D => 4); + + BEGIN + IF R1.W1.D1 /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R1.W1.D1" ); + END IF; + + IF R1.W1.D2 /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R1.W1.D2" ); + END IF; + + IF R1.X1'FIRST /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R1.X1'FIRST" ); + END IF; + + IF R1.X1'LAST /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R1.X1'LAST" ); + END IF; + + BEGIN + R1.Y1 := NEW R (4, 5); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.Y1" ); + END; + + BEGIN + R1.Z1 := NEW ARR (4 .. 5); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R1.Z1" ); + END; + + END; + + DECLARE + + TYPE REC2 (D : INTEGER) IS + RECORD + CASE D IS + WHEN 1 => + NULL; + WHEN 2 => + NULL; + WHEN OTHERS => + W2 : R (D1 => D, D2 => INIT); + X2 : ARR (D .. INIT); + Y2 : ACCR (INIT, D); + Z2 : ACCA (D .. INIT); + END CASE; + END RECORD; + + INT2 : INTEGER := RESET (20); + + R2 : REC2 (D => 6); + + BEGIN + IF R2.W2.D1 /= 6 THEN + FAILED ( "INCORRECT VALUE FOR R2.W2.D1" ); + END IF; + + IF R2.W2.D2 /= 10 THEN + FAILED ( "INCORRECT VALUE FOR R2.W2.D2" ); + END IF; + + IF R2.X2'FIRST /= 6 THEN + FAILED ( "INCORRECT VALUE FOR R2.X2'FIRST" ); + END IF; + + IF R2.X2'LAST /= 10 THEN + FAILED ( "INCORRECT VALUE FOR R2.X2'LAST" ); + END IF; + + BEGIN + R2.Y2 := NEW R (10, 6); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.Y2" ); + END; + + BEGIN + R2.Z2 := NEW ARR (6 .. 10); + EXCEPTION + WHEN OTHERS => + FAILED ( "INCORRECT VALUE FOR R2.Z2" ); + END; + + END; + + RESULT; + END C37010B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,388 ---- + -- C371001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a discriminant constraint depends on a discriminant, + -- the evaluation of the expressions in the constraint is deferred + -- until an object of the subtype is created. Check for cases of + -- records with private type component. + -- + -- TEST DESCRIPTION: + -- This transition test defines record type and incomplete types with + -- discriminant components which depend on the discriminants. The + -- discriminants are calculated by function calls. The test verifies + -- that Constraint_Error is raised during the object creations when + -- values of discriminants are incompatible with the subtypes. + -- + -- Inspired by C37214A.ADA and C37216A.ADA. + -- + -- + -- CHANGE HISTORY: + -- 11 Apr 96 SAIC Initial version for ACVC 2.1. + -- 06 Oct 96 SAIC Added LM references. Replaced "others exception" + -- with "unexpected exception" + -- + --! + + with Report; + + procedure C371001 is + + subtype Small_Int is Integer range 1..10; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + + + begin + Report.Test ("C371001", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + -- Constraint checks on an object declaration of a record. + + begin + + declare + + package C371001_0 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_0; + + --=====================================================-- + + Obj : C371001_0.Rec(Report.Ident_Int(0)); -- Constraint_Error raised. + + begin + Report.Failed ("Obj - Constraint_Error should be raised"); + if Obj.C1.D1 /= 0 then + Report.Failed ("Obj - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an array. + + begin + declare + + package C371001_1 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec_01 (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + type Arr is array (1 .. 5) of + Rec_01(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_1; + + --=====================================================-- + + begin + declare + Obj1 : C371001_1.Arr; -- Constraint_Error raised. + begin + Report.Failed ("Obj1 - Constraint_Error should be raised"); + if Obj1(1).D3 /= 0 then + Report.Failed ("Obj1 - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj1 - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj1 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Arr - Constraint_Error raised"); + when others => + Report.Failed ("Arr - unexpected exception raised"); + end; + + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an access type. + + begin + declare + + package C371001_2 is + + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1 : Integer) is + record + C : PT_W_Disc (D1); + end record; + + type Rec_02 (D3 : Integer) is + record + C1 : Rec_W_Private (D3); + end record; + + type Acc_Rec2 is access Rec_02 -- No Constraint_Error + (Report.Ident_Int(11)); -- raised. + + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_2; + + --=====================================================-- + + begin + declare + Obj2 : C371001_2.Acc_Rec2; -- No Constraint_Error + -- raised. + begin + Obj2 := new C371001_2.Rec_02 (Report.Ident_Int(11)); + -- Constraint_Error raised. + + Report.Failed ("Obj2 - Constraint_Error should be raised"); + if Obj2.D3 /= 1 then + Report.Failed ("Obj2 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj2 - unexpected exception raised in " & + "assignment"); + end; + + exception + when Constraint_Error => + Report.Failed ("Obj2 - Constraint_Error raised in declaration"); + when others => + Report.Failed ("Obj2 - unexpected exception raised in " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec2 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec2 - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of a subtype. + + Func1_Cons := -1; + + begin + declare + + package C371001_3 is + + type PT_W_Disc (D1, D2 : Small_Int) is private; + type Rec_W_Private (D3, D4 : Integer) is + record + C : PT_W_Disc (D3, D4); + end record; + + type Rec_03 (D5 : Integer) is + record + C1 : Rec_W_Private (D5, Func1); -- Func1 evaluated, + end record; -- value 0. + + subtype Subtype_Rec is Rec_03(1); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D1, D2 : Small_Int) is + record + Str1 : String (1 .. D1) := (others => '*'); + Str2 : String (1 .. D2) := (others => '*'); + end record; + + end C371001_3; + + --=====================================================-- + + begin + declare + Obj3 : C371001_3.Subtype_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj3 - Constraint_Error should be raised"); + if Obj3.D5 /= 1 then + Report.Failed ("Obj3 - Shouldn't get here"); + end if; + + exception + when others => + Report.Failed ("Obj3 - exception raised too late"); + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj3 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_Rec - unexpected exception raised"); + end; + + ------------------------------------------------------------------- + -- Constraint checks on an object declaration of an incomplete type. + + Func1_Cons := 10; + + begin + declare + + package C371001_4 is + + type Rec_04 (D3 : Integer); + type PT_W_Disc (D : Small_Int) is private; + type Rec_W_Private (D1, D2 : Small_Int) is + record + C : PT_W_Disc (D2); + end record; + + type Rec_04 (D3 : Integer) is + record + C1 : Rec_W_Private (D3, Func1); -- Func1 evaluated + end record; -- value 11. + + type Acc_Rec4 is access Rec_04 (1); -- No Constraint_Error + -- raised. + private + type PT_W_Disc (D : Small_Int) is + record + Str : String (1 .. D) := (others => '*'); + end record; + + end C371001_4; + + --=====================================================-- + + begin + declare + Obj4 : C371001_4.Acc_Rec4; -- No Constraint_Error + -- raised. + begin + Obj4 := new C371001_4.Rec_04 (1); -- Constraint_Error raised. + + Report.Failed ("Obj4 - Constraint_Error should be raised"); + if Obj4.D3 /= 1 then + Report.Failed ("Obj4 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj4 - unexpected exception raised in " & + "assignment"); + end; + + exception + when Constraint_Error => + Report.Failed ("Obj4 - Constraint_Error raised in declaration"); + when others => + Report.Failed ("Obj4 - unexpected exception raised in " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec4 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec4 - unexpected exception raised"); + end; + + Report.Result; + + exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + + end C371001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,364 ---- + -- C371002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a discriminant constraint depends on a discriminant, + -- the evaluation of the expressions in the constraint is deferred until + -- an object of the subtype is created. Check for cases of records. + -- + -- TEST DESCRIPTION: + -- This transition test defines record types with discriminant components + -- which depend on the discriminants. The discriminants are calculated + -- by function calls. The test verifies that Constraint_Error is raised + -- during the object creations when values of discriminants are + -- incompatible with the subtypes. + -- + -- Inspired by C37213A.ADA, C37213C.ADA, C37215A.ADA and C37215C.ADA. + -- + -- + -- CHANGE HISTORY: + -- 05 Apr 96 SAIC Initial version for ACVC 2.1. + -- + --! + + with Report; + + procedure C371002 is + + subtype Small_Int is Integer range 1..10; + + type Rec_W_Disc (Disc1, Disc2 : Small_Int) is + record + Str1 : String (1 .. Disc1) := (others => '*'); + Str2 : String (1 .. Disc2) := (others => '*'); + end record; + + type My_Array is array (Small_Int range <>) of Integer; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Chk (Cons : Integer; + Value : Integer; + Message : String) return Boolean is + begin + if Cons /= Value then + Report.Failed (Message & ": Func1_Cons is " & + Integer'Image(Func1_Cons)); + end if; + return True; + end Chk; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + + begin + Report.Test ("C371002", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + declare + type Rec1 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. + end record; + + Chk1 : Boolean := Chk (Func1_Cons, 1, + "Func1 not evaluated for Rec1"); + + Obj1 : Rec1 (1); -- Func1 not evaluated again. + Obj2 : Rec1 (2); -- Func1 not evaluated again. + + Chk2 : Boolean := Chk (Func1_Cons, 1, + "Func1 evaluated too many times"); + begin + if Obj1 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) or + Obj2 /= (D3 => 2, + C1 => (Disc1 => 2, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Failed ("Obj1 & Obj2 - Discriminant values not correct"); + end if; + end; + + --------------------------------------------------------- + Func1_Cons := -11; + + declare + type Rec_Of_Rec_01 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value -10. + end record; -- Constraint_Error not raised. + + type Rec_Of_MyArr_01 (D3 : Integer) is + record + C1 : My_Array (Func1 .. D3); -- Func1 evaluated, value -9. + end record; -- Constraint_Error not raised. + + type Rec_Of_Rec_02 (D3 : Integer) is + record + C1 : Rec_W_Disc (D3, 1); + end record; + + type Rec_Of_MyArr_02 (D3 : Integer) is + record + C1 : My_Array (D3 .. 1); + end record; + + begin + + --------------------------------------------------------- + begin + declare + Obj3 : Rec_Of_Rec_01(1); -- Constraint_Error raised. + begin + Report.Failed ("Obj3 - Constraint_Error should be raised"); + if Obj3 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("Obj3 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj3 - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + subtype Subtype_Rec is Rec_Of_Rec_01(1); + -- No Constraint_Error raised. + begin + declare + Obj4 : Subtype_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj4 - Constraint_Error should be raised"); + if Obj4 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("Obj4 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj4 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Arr is array (1..5) -- No Constraint_Error raised. + of Rec_Of_Rec_01(1); + + begin + declare + Obj5 : Arr; -- Constraint_Error raised. + begin + Report.Failed ("Obj5 - Constraint_Error should be raised"); + if Obj5 /= (1..5 => (1, (1, 1, others => (others => '*')))) then + Report.Comment ("Obj5 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj5 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Arr - Constraint_Error raised"); + when others => + Report.Failed ("Arr - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Rec_Of_Rec_Of_MyArr is + record + C1 : Rec_Of_MyArr_01(1); -- No Constraint_Error raised. + end record; + begin + declare + Obj6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. + begin + Report.Failed ("Obj6 - Constraint_Error should be raised"); + if Obj6 /= (C1 => (1, (1, 1))) then + Report.Comment ("Obj6 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj6 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Rec_Of_Rec_Of_MyArr - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type New_Rec is + new Rec_Of_MyArr_01(1); -- No Constraint_Error raised. + + begin + declare + Obj7 : New_Rec; -- Constraint_Error raised. + begin + Report.Failed ("Obj7 - Constraint_Error should be raised"); + if Obj7 /= (1, (1, 1)) then + Report.Comment ("Obj7 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj7 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("New_Rec - Constraint_Error raised"); + when others => + Report.Failed ("New_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Acc_Rec is + access Rec_Of_Rec_02 (Report.Ident_Int(0)); + -- No Constraint_Error raised. + begin + declare + Obj8 : Acc_Rec; -- No Constraint_Error raised. + + begin + Obj8 := new Rec_Of_Rec_02 (Report.Ident_Int(0)); + -- Constraint_Error raised. + + Report.Failed ("Obj8 - Constraint_Error should be raised"); + if Obj8.all /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("Obj8 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj8 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec - others exception raised"); + end; + + --------------------------------------------------------- + begin + declare + type Acc_Rec_MyArr is access + Rec_Of_MyArr_02; -- No Constraint_Error + -- raised for either + Obj9 : Acc_Rec_MyArr; -- declaration. + + begin + Obj9 := new Rec_Of_MyArr_02 (Report.Ident_Int(0)); + -- Constraint_Error raised. + + Report.Failed ("Obj9 - Constraint_Error should be raised"); + + if Obj9.all /= (1, (1, 1)) then + Report.Comment ("Obj9 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj9 - others exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_Rec_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Acc_Rec_MyArr - others exception raised"); + end; + + end; + + Report.Result; + + exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + + end C371002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c371003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c371003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,474 ---- + -- C371003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a discriminant constraint depends on a discriminant, + -- the evaluation of the expressions in the constraint is deferred + -- until an object of the subtype is created. Check for cases of + -- records where the component containing the constraint is present + -- in the subtype. + -- + -- TEST DESCRIPTION: + -- This transition test defines record types with discriminant components + -- which depend on the discriminants. The discriminants are calculated + -- by function calls. The test verifies that Constraint_Error is raised + -- during the object creations when values of discriminants are + -- incompatible with the subtypes. Also check for cases, where the + -- component is absent. + -- + -- Inspired by C37213E.ADA, C37213G.ADA, C37215E.ADA, and C37215G.ADA. + -- + -- + -- CHANGE HISTORY: + -- 10 Apr 96 SAIC Initial version for ACVC 2.1. + -- 14 Jul 96 SAIC Modified test description. Added exception handler + -- for VObj_10 assignment. + -- 26 Oct 96 SAIC Added LM references. + -- + --! + + with Report; + + procedure C371003 is + + subtype Small_Int is Integer range 1..10; + + type Rec_W_Disc (Disc1, Disc2 : Small_Int) is + record + Str1 : String (1 .. Disc1) := (others => '*'); + Str2 : String (1 .. Disc2) := (others => '*'); + end record; + + type My_Array is array (Small_Int range <>) of Integer; + + Func1_Cons : Integer := 0; + + --------------------------------------------------------- + function Chk (Cons : Integer; + Value : Integer; + Message : String) return Boolean is + begin + if Cons /= Value then + Report.Failed (Message & ": Func1_Cons is " & + Integer'Image(Func1_Cons)); + end if; + return True; + end Chk; + + --------------------------------------------------------- + function Func1 return Integer is + begin + Func1_Cons := Func1_Cons + Report.Ident_Int(1); + return Func1_Cons; + end Func1; + + + begin + Report.Test ("C371003", "Check that if a discriminant constraint " & + "depends on a discriminant, the evaluation of the " & + "expressions in the constraint is deferred until " & + "object declarations"); + + --------------------------------------------------------- + declare + type VRec_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (D3, Func1); -- Func1 evaluated, value 1. + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + Chk1 : Boolean := Chk (Func1_Cons, 1, + "Func1 not evaluated for VRec_01"); + + VObj_1 : VRec_01(1); -- Func1 not evaluated again + VObj_2 : VRec_01(2); -- Func1 not evaluated again + + Chk2 : Boolean := Chk (Func1_Cons, 1, + "Func1 evaluated too many times"); + + begin + if VObj_1 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) or + VObj_2 /= (D3 => 2, + C1 => (Disc1 => 2, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Failed ("VObj_1 & VObj_2 - Discriminant values not correct"); + end if; + end; + + --------------------------------------------------------- + Func1_Cons := -11; + + declare + type VRec_Of_VRec_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (Func1, D3); -- Func1 evaluated, value -10. + when others => -- Constraint_Error not raised. + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_VRec_02 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : Rec_W_Disc (1, D3); + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_MyArr_01 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : My_Array (Func1..D3); -- Func1 evaluated, value -9. + when others => -- Constraint_Error not raised. + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + type VRec_Of_MyArr_02 (D3 : Integer) is + record + case D3 is + when -5..10 => + C1 : My_Array (D3..1); + when others => + C2 : Integer := Report.Ident_Int(0); + end case; + end record; + + begin + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + VObj_3 : VRec_Of_VRec_01(1); -- Constraint_Error raised. + begin + Report.Failed ("VObj_3 - Constraint_Error should be raised"); + if VObj_3 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_3 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_3 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + subtype Subtype_VRec is -- No Constraint_Error raised. + VRec_Of_VRec_01(Report.Ident_Int(1)); + begin + declare + VObj_4 : Subtype_VRec; -- Constraint_Error raised. + begin + Report.Failed ("VObj_4 - Constraint_Error should be raised"); + if VObj_4 /= (D3 => 1, + C1 => (Disc1 => 1, + Disc2 => 1, + Str1 => (others => '*'), + Str2 => (others => '*'))) then + Report.Comment ("VObj_4 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_4 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Subtype_VRec - Constraint_Error raised"); + when others => + Report.Failed ("Subtype_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Arr is array (1..5) of + VRec_Of_VRec_01(Report.Ident_Int(-6)); -- No Constraint_Error + VObj_5 : Arr; -- for either declaration. + + begin + if VObj_5 /= (1 .. 5 => (-6, 0)) then + Report.Comment ("VObj_5 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Arr - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Rec_Of_Rec_Of_MyArr is + record + C1 : VRec_Of_MyArr_01(1); -- No Constraint_Error raised. + end record; + begin + declare + Obj_6 : Rec_Of_Rec_Of_MyArr; -- Constraint_Error raised. + begin + Report.Failed ("Obj_6 - Constraint_Error should be raised"); + if Obj_6 /= (C1 => (1, (1, 1))) then + Report.Comment ("Obj_6 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("Obj_6 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Rec_Of_Rec_Of_MyArr - Constraint_Error raised"); + when others => + Report.Failed ("Rec_Of_Rec_Of_MyArr - unexpected exception " & + "raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type New_VRec_Arr is + new VRec_Of_MyArr_01(11); -- No Constraint_Error raised + Obj_7 : New_VRec_Arr; -- for either declaration. + + begin + if Obj_7 /= (11, 0) then + Report.Failed ("Obj_7 - value incorrect"); + end if; + end; + + exception + when others => + Report.Failed ("New_VRec_Arr - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type New_VRec is new + VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + begin + declare + VObj_8 : New_VRec; -- Constraint_Error raised. + begin + Report.Failed ("VObj_8 - Constraint_Error should be raised"); + if VObj_8 /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_8 - Shouldn't get here"); + end if; + end; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_8 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("New_VRec - Constraint_Error raised"); + when others => + Report.Failed ("New_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + subtype Sub_VRec is + VRec_Of_VRec_02(Report.Ident_Int(11)); -- No Constraint_Error + VObj_9 : Sub_VRec; -- raised for either + -- declaration. + begin + if VObj_9 /= (11, 0) then + Report.Comment ("VObj_9 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Sub_VRec - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Acc_VRec_01 is access + VRec_Of_VRec_02(Report.Ident_Int(0)); -- No Constraint_Error + -- raised. + begin + declare + VObj_10 : Acc_VRec_01; -- No Constraint_Error + -- raised. + begin + VObj_10 := new VRec_Of_VRec_02 + (Report.Ident_Int(0)); -- Constraint_Error + -- raised. + Report.Failed ("VObj_10 - Constraint_Error should be raised"); + if VObj_10.all /= (1, (1, 1, others => (others => '*'))) then + Report.Comment ("VObj_10 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_10 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("VObj_10 - Constraint_Error exception raised"); + when others => + Report.Failed ("VObj_10 - unexpected exception raised at " & + "declaration"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_VRec_01 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_VRec_01 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Acc_VRec_02 is access + VRec_Of_VRec_02(11); -- No Constraint_Error + -- raised for either + VObj_11 : Acc_VRec_02; -- declaration. + + begin + VObj_11 := new VRec_Of_VRec_02(11); + if VObj_11.all /= (11, 0) then + Report.Comment ("VObj_11 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Acc_VRec_02 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is present. + begin + declare + type Acc_VRec_03 is access + VRec_Of_MyArr_02; -- No Constraint_Error + -- raised for either + VObj_12 : Acc_VRec_03; -- declaration. + begin + VObj_12 := new VRec_Of_MyArr_02 + (Report.Ident_Int(0)); -- Constraint_Error raised. + + Report.Failed ("VObj_12 - Constraint_Error should be raised"); + if VObj_12.all /= (1, (1, 1)) then + Report.Comment ("VObj_12 - Shouldn't get here"); + end if; + + exception + when Constraint_Error => -- Exception expected. + null; + when others => + Report.Failed ("VObj_12 - unexpected exception raised"); + end; + + exception + when Constraint_Error => + Report.Failed ("Acc_VRec_03 - Constraint_Error raised"); + when others => + Report.Failed ("Acc_VRec_03 - unexpected exception raised"); + end; + + --------------------------------------------------------- + -- Component containing the constraint is absent. + begin + declare + type Acc_VRec_04 is access + VRec_Of_MyArr_02(11); -- No Constraint_Error + -- raised for either + VObj_13 : Acc_VRec_04; -- declaration. + + begin + VObj_13 := new VRec_Of_MyArr_02(11); + if VObj_13.all /= (11, 0) then + Report.Comment ("VObj_13 - wrong values"); + end if; + end; + + exception + when others => + Report.Failed ("Acc_VRec_04 - unexpected exception raised"); + end; + + end; + + Report.Result; + + exception + when others => + Report.Failed ("Discriminant value checked too soon"); + Report.Result; + + end C371003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37102b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37102b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37102b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37102b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C37102B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT, FOR A RECORD TYPE, THE IDENTIFIER FOR A DISCRIMINANT + -- CAN BE USED AS A SELECTED COMPONENT IN AN INDEX OR DISCRIMINANT + -- CONSTRAINT, AS THE NAME OF A DISCRIMINANT IN A DISCRIMINANT + -- SPECIFICATION, AND AS THE PARAMETER NAME IN A FUNCTION CALL IN A + -- DISCRIMINANT OR INDEX CONSTRAINT. + + -- R.WILLIAMS 8/25/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37102B IS + + BEGIN + TEST ( "C37102B", "CHECK THAT, FOR A RECORD TYPE, THE " & + "IDENTIFIER FOR A DISCRIMINANT CAN BE USED " & + "AS A SELECTED COMPONENT IN AN INDEX OR " & + "DISCRIMINANT CONSTRAINT, AS THE NAME OF A " & + "DISCRIMINANT IN A DISCRIMINANT " & + "SPECIFICATION, AND AS THE PARAMETER NAME " & + "IN A FUNCTION CALL IN A DISCRIMINANT OR " & + "INDEX CONSTRAINT" ); + + DECLARE + + FUNCTION F (D : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (D); + END F; + + PACKAGE P IS + + TYPE D IS NEW INTEGER; + + TYPE REC1 IS + RECORD + D : INTEGER := IDENT_INT (1); + END RECORD; + + G : REC1; + + TYPE REC2 (D : INTEGER := 3) IS + RECORD + NULL; + END RECORD; + + H : REC2 (IDENT_INT (5)); + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE Q (D : INTEGER := 0) IS + RECORD + J : REC2 (D => H.D); + K : ARR (G.D .. F (D => 5)); + L : REC2 (F (D => 4)); + END RECORD; + + END P; + + USE P; + + BEGIN + DECLARE + R : Q; + + BEGIN + IF R.J.D /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R.J" ); + END IF; + + IF R.K'FIRST /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R.K'FIRST" ); + END IF; + + IF R.K'LAST /= 5 THEN + FAILED ( "INCORRECT VALUE FOR R.K'LAST" ); + END IF; + + IF R.L.D /= 4 THEN + FAILED ( "INCORRECT VALUE FOR R.L" ); + END IF; + END; + + END; + + RESULT; + END C37102B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37103a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C37103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DISCRIMINANTS MAY BE BOOLEAN, CHARACTER, USER_ENUM, + -- INTEGER, DERIVED CHARACTER, DERIVED USER_ENUM, DERIVED INTEGER, + -- AND DERIVED DERIVED USER_ENUM. + + -- DAT 5/18/81 + -- SPS 10/25/82 + + WITH REPORT; USE REPORT; + + PROCEDURE C37103A IS + BEGIN + TEST ("C37103A", "MANY DIFFERENT DISCRIMINANT TYPES"); + DECLARE + PACKAGE P1 IS + TYPE ENUM IS (A, Z, Q, 'W', 'A'); + END P1; + + PACKAGE P2 IS + TYPE E2 IS NEW P1.ENUM; + END P2; + + PACKAGE P3 IS + TYPE E3 IS NEW P2.E2; + END P3; + + USE P1, P2, P3; + TYPE INT IS NEW INTEGER RANGE -3 .. 7; + TYPE CHAR IS NEW CHARACTER; + TYPE R1 (D : ENUM) IS RECORD NULL; END RECORD; + TYPE R2 (D : INTEGER) IS RECORD NULL; END RECORD; + TYPE R3 (D : BOOLEAN) IS RECORD NULL; END RECORD; + TYPE R4 (D : CHARACTER) IS RECORD NULL; END RECORD; + TYPE R5 (D : CHAR) IS RECORD NULL; END RECORD; + TYPE R6 (D : E2) IS RECORD NULL; END RECORD; + TYPE R7 (D : E3) IS RECORD NULL; END RECORD; + TYPE R8 (D : INT) IS RECORD NULL; END RECORD; + O1 : R1(A) := (D => A); + O2 : R2(3) := (D => 3); + O3 : R3(TRUE) := (D => TRUE); + O4 : R4(ASCII.NUL) := (D => ASCII.NUL); + O5 : R5('A') := (D => 'A'); + O6 : R6('A') := (D => 'A'); + O7 : R7(A) := (D => A); + O8 : R8(2) := (D => 2); + BEGIN + IF O1.D /= A + OR O2.D /= 3 + OR NOT O3.D + OR O4.D IN 'A' .. 'Z' + OR O5.D /= 'A' + OR O6.D /= 'A' + OR O7.D /= A + OR O8.D /= 2 + THEN FAILED ("WRONG DISCRIMINANT VALUE"); + END IF; + END; + + RESULT; + END C37103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37105a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37105a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37105a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37105a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- C37105A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT RECORDS WITH ONLY DISCRIMINANTS ARE OK. + + -- DAT 5/18/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; USE REPORT; + + PROCEDURE C37105A IS + BEGIN + TEST ("C37105A", "RECORDS WITH ONLY DISCRIMINANTS"); + + DECLARE + TYPE R1 (D : BOOLEAN) IS RECORD + NULL; END RECORD; + TYPE R2 (D, E : BOOLEAN) IS RECORD + NULL; END RECORD; + TYPE R3 (A,B,C,D : INTEGER; W,X,Y,Z : CHARACTER) IS + RECORD NULL; END RECORD; + OBJ1 : R1 (IDENT_BOOL(TRUE)); + OBJ2 : R2 (IDENT_BOOL(FALSE), IDENT_BOOL(TRUE)); + OBJ3 : R3 (1,2,3,4,'A','B','C',IDENT_CHAR('D')); + BEGIN + IF OBJ1 = (D => (FALSE)) + OR OBJ2 /= (FALSE, (TRUE)) + OR OBJ3 /= (1,2,3,4,'A','B','C',('D')) + THEN FAILED ("DISCRIMINANT-ONLY RECORDS DON'T WORK"); + END IF; + END; + + RESULT; + END C37105A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37107a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- C37107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DEFAULT DISCRIMINANT EXPRESSION NEED NOT BE STATIC AND + -- IS EVALUATED ONLY WHEN NEEDED. + + -- R.WILLIAMS 8/25/86 + -- GMT 6/29/87 ADDED INTEGER ARGUMENT TO THE FUNCTION F. + + + WITH REPORT; USE REPORT; + PROCEDURE C37107A IS + + FUNCTION F ( B : BOOLEAN; + I : INTEGER ) RETURN INTEGER IS + BEGIN + IF NOT B THEN + FAILED ( "DEFAULT DISCRIMINANT EVALUATED " & + "UNNECESSARILY - " & + INTEGER'IMAGE(I) ); + END IF; + + RETURN IDENT_INT (1); + END F; + + BEGIN + TEST ( "C37107A", "CHECK THAT A DEFAULT DISCRIMINANT " & + "EXPRESSION NEED NOT BE STATIC AND IS " & + "EVALUATED ONLY WHEN NEEDED" ); + + DECLARE + TYPE REC1 ( D : INTEGER := F (TRUE,1) ) IS + RECORD + NULL; + END RECORD; + + R1 : REC1; + + TYPE REC2 ( D : INTEGER := F (FALSE,2) ) IS + RECORD + NULL; + END RECORD; + + R2 : REC2 (D => 0); + + BEGIN + IF R1.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R1.D" ); + END IF; + + IF R2.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R2.D" ); + END IF; + END; + + DECLARE + + PACKAGE PRIV IS + TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS PRIVATE; + TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS PRIVATE; + + PRIVATE + TYPE REC3 ( D : INTEGER := F (TRUE,3) ) IS + RECORD + NULL; + END RECORD; + + TYPE REC4 ( D : INTEGER := F (FALSE,4) ) IS + RECORD + NULL; + END RECORD; + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + R3 : REC3; + R4 : REC4 (D => 0); + + BEGIN + IF R3.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R3.D" ); + END IF; + + IF R4.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R4.D" ); + END IF; + END; + + END; + + DECLARE + + PACKAGE LPRIV IS + TYPE REC5 + ( D : INTEGER := F (TRUE,5) ) IS LIMITED PRIVATE; + TYPE REC6 + ( D : INTEGER := F (FALSE,6) ) IS LIMITED PRIVATE; + + PRIVATE + TYPE REC5 ( D : INTEGER := F (TRUE,5) ) IS + RECORD + NULL; + END RECORD; + + TYPE REC6 ( D : INTEGER := F (FALSE,6) ) IS + RECORD + NULL; + END RECORD; + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + R5 : REC5; + R6 : REC6 (D => 0); + + BEGIN + IF R5.D /= 1 THEN + FAILED ( "INCORRECT VALUE FOR R5.D" ); + END IF; + + IF R6.D /= 0 THEN + FAILED ( "INCORRECT VALUE FOR R6.D" ); + END IF; + END; + + END; + + RESULT; + END C37107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37108b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37108b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37108b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37108b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,247 ---- + -- C37108B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IN AN OBJECT DECLARATION IF + -- A DEFAULT INITIAL VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE + -- CONSTRAINTS OF A RECORD OR AN ARRAY TYPE WHOSE CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, AND NO EXPLICIT INITIALIZATION IS + -- PROVIDED FOR THE OBJECT. + + -- R.WILLIAMS 8/25/86 + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37108B IS + + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE R (P : POSITIVE) IS + RECORD + NULL; + END RECORD; + + BEGIN + TEST ( "C37108B", "CHECK THAT CONSTRAINT_ERROR IS RAISED IN " & + "AN OBJECT DECLARATION IF A DEFAULT INITIAL " & + "VALUE HAS BEEN SPECIFIED WHICH VIOLATES THE " & + "CONSTRAINTS OF A RECORD OR AN ARRAY TYPE " & + "WHOSE CONSTRAINT DEPENDS ON A DISCRIMINANT, " & + "AND NO EXPLICIT INITIALIZATION IS PROVIDED " & + "FOR THE OBJECT" ); + + + BEGIN + DECLARE + TYPE REC1 (D : NATURAL := IDENT_INT (0)) IS + RECORD + A : ARR (D .. 5); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + + BEGIN + R1.A (1) := IDENT_INT (2); + FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & + "R1" & INTEGER'IMAGE(R1.A(5))); --USE R2 + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC1" ); + END; + + BEGIN + DECLARE + TYPE REC2 (D : INTEGER := IDENT_INT (-1)) IS + RECORD + A : R (P => D); + END RECORD; + + BEGIN + DECLARE + R2 : REC2; + + BEGIN + R2.A := R'(P => IDENT_INT (1)); + FAILED ( "NO EXCEPTION RAISED AT DECLARATION OF " & + "R2" & INTEGER'IMAGE(R2.A.P)); --USE R2 + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R2 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC2" ); + END; + + BEGIN + DECLARE + PACKAGE PRIV IS + TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS + PRIVATE; + PROCEDURE PROC (R :REC3); + + PRIVATE + TYPE REC3 (D : INTEGER := IDENT_INT (-1)) IS + RECORD + A : R (P => D); + END RECORD; + END PRIV; + + PACKAGE BODY PRIV IS + PROCEDURE PROC (R : REC3) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.A.P); + IF EQUAL(2, IDENT_INT(1)) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I + END IF; + END PROC; + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + R3 : REC3; + + BEGIN + PROC (R3); + FAILED ( "NO EXCEPTION RAISED AT " & + "DECLARATION OF R3" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R3 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC3" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC4 (D : NATURAL := IDENT_INT (0)) + IS LIMITED PRIVATE; + PROCEDURE PROC (R :REC4); + + PRIVATE + TYPE REC4 (D : NATURAL := IDENT_INT (0)) IS + RECORD + A : ARR (D .. 5); + END RECORD; + END LPRIV; + + PACKAGE BODY LPRIV IS + PROCEDURE PROC (R : REC4) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.A'FIRST); + IF EQUAL(2, IDENT_INT(1)) THEN + FAILED("IMPOSSIBLE " & INTEGER'IMAGE(I)); --USE I + END IF; + END PROC; + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + R4 : REC4; + + BEGIN + PROC (R4); + FAILED ( "NO EXCEPTION RAISED AT " & + "DECLARATION OF R4" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R4 RAISED INSIDE " & + "BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE " & + "DECLARATION OF REC4" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE " & + "DECLARATION OF REC4" ); + END; + + RESULT; + END C37108B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37206a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C37206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A TYPE WITHOUT DEFAULT DISCRIMINANT VALUES (BUT WITH + -- DISCRIMINANTS) CHECK THAT A TYPEMARK WHICH DENOTES SUCH AN + -- UNCONSTRAINED TYPE CAN BE USED IN: + + -- 1) A SUBTYPE DECLARATION, AND THE SUBTYPE NAME ACTS SIMPLY AS A + -- NEW NAME FOR THE UNCONSTRAINED TYPE; + -- 2) IN A CONSTANT DECLARATION. + + -- HISTORY: + -- AH 08/21/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- DTN 11/13/91 DELETED SUBPARTS (2 and 3). + + WITH REPORT; USE REPORT; + PROCEDURE C37206A IS + BEGIN + + TEST ("C37206A", "FOR TYPE WITH DEFAULT-LESS DISCRIMINANTS, " & + "UNCONSTRAINED TYPE_MARK CAN BE USED IN A SUBTYPE " & + "DECLARATION OR IN A CONSTANT DECLARATION"); + + DECLARE + TYPE REC(DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE ST IS REC; -- 1. + + C1 : CONSTANT REC := (DISC => 5); -- 2. + C2 : CONSTANT REC := (DISC => IDENT_INT(5)); -- 2. + BEGIN + + IF C1 /= C2 OR C1 /= (DISC => 5) THEN + FAILED ("CONSTANT DECLARATIONS INCORRECT"); + END IF; + END; + + RESULT; + END C37206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37207a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37207a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37207a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37207a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- C37207A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + + -- FOR A TYPE WITH OR WITHOUT DEFAULT DISCRIMINANT VALUES, CHECK + -- THAT A DISCRIMINANT CONSTRAINT CAN BE SUPPLIED IN THE FOLLOWING + -- CONTEXTS AND HAS THE PROPER EFFECT: + + -- IN A 1) OBJECT_DECLARATION, 2) COMPONENT_DECLARATION OR + -- 3) SUBTYPE INDICATION OF AN ARRAY_TYPE_DEFINITION, AND HENCE, + -- ASSIGNMENTS CANNOT ATTEMPT TO CHANGE THE SPECIFIED DISCRIMINANT + -- VALUES WITHOUT RAISING CONSTRAINT_ERROR + + -- 4) IN AN ACCESS_TYPE_DEFINITION, AND HENCE, ACCESS VALUES + -- OF THIS ACCESS TYPE CANNOT BE ASSIGNED NON-NULL VALUES + -- DESIGNATING OBJECTS WITH DIFFERENT DISCRIMINANT VALUES. + + -- 5) IN AN ALLOCATOR, AND THE ALLOCATED OBJECT HAS THE SPECIFIED + -- DISCRIMINANT VALUES. + + -- 6) IN A FORMAL PARAMETER DECLARATION OF A SUBPROGRAM, AND + -- HENCE, ASSIGNMENTS TO THE FORMAL PARAMETER CANNOT ATTEMPT TO + -- CHANGE THE DISCRIMINANT VALUES WITHOUT RAISING CONSTRAINT_ERROR, + -- CONSTRAINED IS TRUE, AND IF ACTUAL PARAMETERS HAVE DISCRIMINANT + -- VALUES DIFFERENT FROM THE SPECIFIED ONES, CONSTRAINT_ERROR IS + -- RAISED. + + -- HISTORY: + + -- ASL 07/24/81 + -- RJW 08/28/86 CORRECTED SYNTAX ERRORS. + -- JLH 08/07/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. + -- EDS 07/16/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37207A IS + + BEGIN + TEST ("C37207A","DISCRIMINANT CONSTRAINT CAN BE SUPPLIED TO " & + "DECLARATIONS AND DEFINITIONS USING TYPES WITH OR WITHOUT " & + "DEFAULT DISCRIMINANT VALUES"); + + DECLARE + TYPE REC1 (DISC : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + + TYPE REC2 (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + OBJ1 : REC1(6); -- 1. + OBJ2 : REC2(6); -- 1. + BADOBJ1 : REC1(7); -- 1. + BADOBJ2 : REC2(7); -- 1. + + TYPE REC3 IS + RECORD + COMP1 : REC1(6); -- 2. + COMP2 : REC2(6); -- 2. + END RECORD; + + OBJ3 : REC3; + + TYPE ARR1 IS ARRAY (1..10) OF REC1(6); -- 3. + TYPE ARR2 IS ARRAY (1..10) OF REC2(6); -- 3. + + A1 : ARR1; + A2 : ARR2; + + TYPE REC1_NAME IS ACCESS REC1(6); -- 4. + TYPE REC2_NAME IS ACCESS REC2(6); -- 4. + + ACC1 : REC1_NAME; + ACC2 : REC2_NAME; + + SUBTYPE REC16 IS REC1(6); + SUBTYPE REC26 IS REC2(6); + + PROCEDURE PROC (P1 : IN OUT REC16; -- 6. + P2 : IN OUT REC26) IS -- 6. + BEGIN + IF NOT (P1'CONSTRAINED AND P2'CONSTRAINED) THEN -- 6. + FAILED ("'CONSTRAINED ATTRIBUTE INCORRECT FOR " & + "CONSTRAINED FORMAL PARAMETERS"); + END IF; + BEGIN + P1 := (DISC => 7); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED FORMAL PARAMETER " & + INTEGER'IMAGE(P1.DISC)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (1)"); + END; + BEGIN + P2 := (DISC => 7); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED FORMAL PARAMETER " & + INTEGER'IMAGE(P2.DISC)); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (2)"); + END; + END PROC; + BEGIN + --------------------------------------------------------------- + + BEGIN + OBJ1 := (DISC => IDENT_INT(7)); -- 1. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED OBJECT"); + IF OBJ1 = (DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (3)"); + END; + + --------------------------------------------------------------- + + BEGIN + OBJ3 := ((DISC => IDENT_INT(7)), -- 2. + (DISC => IDENT_INT(7))); -- 2. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED RECORD COMPONENT"); + IF OBJ3 = ((DISC => 7), (DISC => 7)) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (4)"); + END; + + -------------------------------------------------------------- + + BEGIN + A2(2) := (DISC => IDENT_INT(7)); -- 3. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO CHANGE DISCRIMINANT OF " & + "CONSTRAINED ARRAY COMPONENT"); + IF A2(2) = (DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (5)"); + END; + + -------------------------------------------------------------- + + BEGIN + ACC1 := NEW REC1(DISC => IDENT_INT(7)); -- 4. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & + "TO ACCESS VARIABLE"); + IF ACC1 = NEW REC1(DISC => 7) THEN + COMMENT ("PREVENTING DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (6)"); + END; + + ---------------------------------------------------------------- + + ACC1 := NEW REC1(DISC => IDENT_INT(6)); -- OK. + + BEGIN + ACC1.ALL := BADOBJ1; -- 5. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "ATTEMPT TO ASSIGN INCOMPATIBLE OBJECT " & + "TO ACCESSED OBJECT"); + IF ACC1.ALL = BADOBJ1 THEN + COMMENT ("PREVENT DEAD VARIABLE OPTIMIZATION"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (7)"); + END; + + ----------------------------------------------------------------- + + PROC (OBJ1,OBJ2); -- OK. + + BEGIN + PROC (BADOBJ1,BADOBJ2); -- 6. + FAILED ("CONSTRAINT_ERROR NOT RAISED UPON " & + "PASSING OF CONSTRAINED ACTUAL " & + "PARAMETERS TO DIFFERENTLY CONSTRAINED " & + "FORMAL PARAMETERS"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION (8)"); + END; + + --------------------------------------------------------------- + END; + + RESULT; + END C37207A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37208a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37208a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37208a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37208a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,172 ---- + -- C37208A.ADA (RA #534/1) + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A + -- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN: + + -- AN OBJECT DECLARATION, AND HENCE ASSIGNMENTS TO THE OBJECT CAN + -- CHANGE ITS DISCRIMINANTS; + + -- A COMPONENT_DECLARATION IN A RECORD TYPE DEFINITION, AND HENCE + -- ASSIGNMENTS TO THE COMPONENT CAN CHANGE THE VALUE OF ITS + -- DISCRIMINANTS; + + -- A SUBTYPE INDICATION IN AN ARRAY TYPE DEFINITION, AND HENCE + -- ASSIGNMENTS TO ONE OF THE COMPONENTS CAN CHANGE ITS + -- DISCRIMINANT VALUES; + + -- A FORMAL PARAMETER OF A SUBPROGRAM; EXCEPT FOR PARAMETERS OF + -- MODE IN, THE 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER + -- BECOMES THE 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER; + -- FOR IN OUT AND OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS + -- FALSE, ASSIGNMENTS TO THE FORMAL PARAMETER CAN CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED + -- ATTRIBUTE IS TRUE, ASSIGNNMENTS THAT ATTEMPT TO CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR. + + -- ASL 7/23/81 + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C37208A IS + + USE REPORT; + + BEGIN + TEST ("C37208A","DISCRIMINANT CONSTRAINT CAN BE OMITTED " & + "FROM OBJECT DECLARATION, COMPONENT DECLARATION, SUBTYPE " & + "INDICATION OR FORMAL SUBPROGRAM PARAMETER, IF THE TYPE " & + "HAS DEFAULT DISCRIMINANTS"); + + DECLARE + TYPE REC1(DISC : INTEGER := 7) IS + RECORD + NULL; + END RECORD; + + TYPE REC2 IS + RECORD + COMP : REC1; + END RECORD; + + R : REC2; + U1,U2,U3 : REC1 := (DISC => 3); + C1,C2,C3 : REC1(3) := (DISC => 3); + ARR : ARRAY(INTEGER RANGE 1..10) OF REC1; + ARR2 : ARRAY (1..10) OF REC1(4); + + PROCEDURE PROC(P_IN : IN REC1; + P_OUT : OUT REC1; + P_IN_OUT : IN OUT REC1; + CONSTR : IN BOOLEAN) IS + BEGIN + IF P_OUT'CONSTRAINED /= CONSTR + OR P_IN_OUT'CONSTRAINED /= CONSTR THEN + FAILED ("CONSTRAINED ATTRIBUTES DO NOT MATCH " & + "FOR ACTUAL AND FORMAL PARAMETERS"); + END IF; + + IF P_IN'CONSTRAINED /= IDENT_BOOL(TRUE) THEN + FAILED ("'CONSTRAINED IS FALSE FOR IN " & + "PARAMETER"); + END IF; + + IF NOT CONSTR THEN -- UNCONSTRAINED ACTUAL PARAM + P_OUT := (DISC => IDENT_INT(0)); + P_IN_OUT := (DISC => IDENT_INT(0)); + ELSE + BEGIN + P_OUT := (DISC => IDENT_INT(0)); + FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & + "PARAMETER ILLEGALLY CHANGED - 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + END; + + BEGIN + P_IN_OUT := (DISC => IDENT_INT(0)); + FAILED ("DISCRIMINANT OF CONSTRAINED ACTUAL " & + "PARAMETER ILLEGALLY CHANGED - 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + END; + END IF; + END PROC; + BEGIN + IF U1.DISC /= IDENT_INT(3) THEN + FAILED ("INITIAL DISCRIMINANT VALUE WRONG - U1"); + END IF; + + U1 := (DISC => IDENT_INT(5)); + IF U1.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR OBJECT"); + END IF; + + IF R.COMP.DISC /= IDENT_INT(7) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - R"); + END IF; + + R.COMP := (DISC => IDENT_INT(5)); + IF R.COMP.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR RECORD COMPONENT"); + END IF; + + FOR I IN 1..10 LOOP + IF ARR(I).DISC /= IDENT_INT(7) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG - ARR"); + END IF; + END LOOP; + + ARR(3) := (DISC => IDENT_INT(5)); + IF ARR(3).DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED FOR ARRAY COMPONENT"); + END IF; + + IF ARR /= (1..2|4..10 => (DISC => 7), 3 => (DISC => 5)) THEN + FAILED ("MODIFIED WRONG COMPONENTS"); + END IF; + + PROC(C1,C2,C3,IDENT_BOOL(TRUE)); + PROC(U1,U2,U3,IDENT_BOOL(FALSE)); + IF U2.DISC /= 0 OR U3.DISC /= 0 THEN + FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL PARAMETER " & + "FAILED TO CHANGE DISCRIMINANT"); + END IF; + + PROC(ARR(1), ARR(3), ARR(4), FALSE); + IF ARR(3).DISC /= 0 OR ARR(4).DISC /= 0 THEN + FAILED ("ARRAY COMPONENT ASSIGNMENTS DIDN'T CHANGE " & + "DISCRIMINANT OF COMPONENT"); + END IF; + + PROC (ARR2(2), ARR2(5), ARR2(10), TRUE); + END; + + RESULT; + END C37208A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37208b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37208b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37208b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37208b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C37208B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A TYPE WITH DEFAULT DISCRIMINANT VALUES, CHECK THAT A + -- DISCRIMINANT CONSTRAINT CAN BE OMITTED IN A GENERIC FORMAL + -- PARAMETER, AND HENCE, FOR BOTH IN AND IN OUT PARAMETERS, THE + -- 'CONSTRAINED ATTRIBUTE OF THE ACTUAL PARAMETER BECOMES THE + -- 'CONSTRAINED ATTRIBUTE OF THE FORMAL PARAMETER, AND, FOR IN + -- OUT PARAMETERS, IF THE 'CONSTRAINED ATTRIBUTE IS FALSE, + -- ASSIGNMENTS TO THE FORMAL PARAMETERS CAN CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER; IF THE 'CONSTRAINED + -- ATTRIBUTE IS TRUE, ASSIGNMENTS THAT ATTEMPT TO CHANGE THE + -- DISCRIMINANTS OF THE ACTUAL PARAMETER RAISE CONSTRAINT_ERROR. + + -- ASL 7/29/81 + -- VKG 1/20/83 + -- EDS 7/16/98 AVOID OPTIMIZATION + + WITH REPORT; + PROCEDURE C37208B IS + + USE REPORT; + + BEGIN + TEST ("C37208B","FOR TYPES WITH DEFAULT DISCRIMINANT " & + "VALUES, DISCRIMINANT CONSTRAINTS CAN BE OMITTED " & + "IN GENERIC FORMAL PARAMETERS, AND THE " & + "'CONSTRAINED ATTRIBUTE HAS CORRECT VALUES " & + "DEPENDING ON THE ACTUAL PARAMETERS"); + + DECLARE + TYPE REC(DISC : INTEGER := 7) IS + RECORD + NULL; + END RECORD; + + KC : CONSTANT REC(3) := (DISC => 3); + KU : CONSTANT REC := (DISC => 3); + OBJC1,OBJC2 : REC(3) := (DISC => 3); + OBJU1,OBJU2 : REC := (DISC => 3); + + GENERIC + P_IN1 : REC; + P_IN2 : REC; + P_IN_OUT : IN OUT REC; + STATUS : BOOLEAN; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + + IF P_IN1'CONSTRAINED /= TRUE OR + P_IN2'CONSTRAINED /= TRUE OR + P_IN_OUT'CONSTRAINED /= STATUS + THEN + + FAILED ("'CONSTRAINED ATTRIBUTES DO NOT MATCH " & + "FOR ACTUAL AND FORMAL PARAMETERS"); + END IF; + IF NOT STATUS THEN + BEGIN + P_IN_OUT := (DISC => IDENT_INT(7)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED " & + "WHEN TRYING TO " & + "CHANGE UNCONSTRAINED " & + "DISCRIMINANT VALUE"); + END; + ELSE + BEGIN + P_IN_OUT := (DISC => IDENT_INT(7)); + FAILED ("DISCRIMINANT OF CONSTRAINED " & + "ACTUAL PARAMETER ILLEGALLY " & + "CHANGED BY ASSIGNMENT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + END IF; + END PROC; + + BEGIN + + DECLARE + PROCEDURE PROC_C IS NEW PROC(KC,OBJC1,OBJC2,IDENT_BOOL(TRUE)); + PROCEDURE PROC_U IS NEW PROC(KU,OBJU1,OBJU2,IDENT_BOOL(FALSE)); + BEGIN + PROC_C; + PROC_U; + IF OBJU2.DISC /= 7 THEN + FAILED ("ASSIGNMENT TO UNCONSTRAINED ACTUAL " & + "PARAMETER FAILED TO CHANGE DISCRIMINANT "); + END IF; + END; + + END; + RESULT; + END C37208B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37209a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37209a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37209a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37209a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C37209A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR A CONSTANT OBJECT + -- DECLARATION WHOSE SUBTYPE INDICATION SPECIFIES AN UNCONSTRAINED + -- TYPE WITH DEFAULT DISCRIMINANT VALUES AND WHOSE INITIALIZATION + -- EXPRESSION SPECIFIES A VALUE WHOSE DISCRIMINANTS ARE NOT EQUAL TO + -- THE DEFAULT VALUE. + + -- R.WILLIAMS 8/25/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37209A IS + + BEGIN + TEST ( "C37209A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "FOR A CONSTANT OBJECT DECLARATION WHOSE " & + "SUBTYPE INDICATION SPECIFIES AN " & + "UNCONSTRAINED TYPE WITH DEFAULT " & + "DISCRIMINANT VALUES AND WHOSE " & + "INITIALIZATION EXPRESSION SPECIFIES A VALUE " & + "WHOSE DISCRIMINANTS ARE NOT EQUAL TO THE " & + "DEFAULT VALUE" ); + DECLARE + + TYPE REC1 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + BEGIN + DECLARE + R1 : CONSTANT REC1 := (D => IDENT_INT (10)); + BEGIN + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION OF R1" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " & + "R1" ); + END; + + + BEGIN + DECLARE + PACKAGE PRIV IS + TYPE REC2 (D : INTEGER:= IDENT_INT (5)) IS PRIVATE; + R2 : CONSTANT REC2; + + PRIVATE + TYPE REC2 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + R2 : CONSTANT REC2 := (D => IDENT_INT (10)); + END PRIV; + + USE PRIV; + + BEGIN + DECLARE + I : INTEGER := R2.D; + BEGIN + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC3 (D : INTEGER:= IDENT_INT (5)) IS + LIMITED PRIVATE; + + R3 : CONSTANT REC3; + + PRIVATE + TYPE REC3 (D : INTEGER := IDENT_INT (5)) IS + RECORD + NULL; + END RECORD; + + R3 : CONSTANT REC3 := (D => IDENT_INT (10)); + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + I : INTEGER; + BEGIN + I := R3.D; + COMMENT ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED AT DECLARATION OF " & + "R3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + RESULT; + END C37209A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37209b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37209b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37209b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37209b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + -- C37209B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE SUBTYPE + -- INDICATION IN A CONSTANT OBJECT DECLARATION SPECIFIES A + -- CONSTRAINED SUBTYPE WITH DISCRIMINANTS AND THE INITIALIZATION + -- VALUE DOES NOT BELONG TO THE SUBTYPE (I. E., THE DISCRIMINANT + -- VALUE DOES NOT MATCH THOSE SPECIFIED BY THE CONSTRAINT). + + -- HISTORY: + -- RJW 08/25/86 CREATED ORIGINAL TEST + -- VCL 08/19/87 CHANGED THE RETURN TYPE OF FUNTION 'INIT' IN + -- PACKAGE 'PRIV2' SO THAT 'INIT' IS UNCONSTRAINED, + -- THUS NOT RAISING A CONSTRAINT ERROR ON RETURN FROM + -- 'INIT'. + + WITH REPORT; USE REPORT; + PROCEDURE C37209B IS + + BEGIN + TEST ( "C37209B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "THE SUBTYPE INDICATION IN A CONSTANT " & + "OBJECT DECLARATION SPECIFIES A CONSTRAINED " & + "SUBTYPE WITH DISCRIMINANTS AND THE " & + "INITIALIZATION VALUE DOES NOT BELONG TO " & + "THE SUBTYPE (I. E., THE DISCRIMINANT VALUE " & + "DOES NOT MATCH THOSE SPECIFIED BY THE " & + "CONSTRAINT)" ); + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE REC1 IS REC (IDENT_INT (5)); + BEGIN + DECLARE + R1 : CONSTANT REC1 := (D => IDENT_INT (10)); + I : INTEGER := IDENT_INT (R1.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED FOR DECLARATION OF " & + "R1" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION FOR R1 RAISED INSIDE BLOCK" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION OF " & + "R1" ); + END; + + + BEGIN + DECLARE + PACKAGE PRIV1 IS + TYPE REC (D : INTEGER) IS PRIVATE; + SUBTYPE REC2 IS REC (IDENT_INT (5)); + R2 : CONSTANT REC2; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + R2 : CONSTANT REC2 := (D => IDENT_INT (10)); + END PRIV1; + + USE PRIV1; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (R2.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R2" ); + END; + + BEGIN + DECLARE + PACKAGE PRIV2 IS + TYPE REC (D : INTEGER) IS PRIVATE; + SUBTYPE REC3 IS REC (IDENT_INT (5)); + + FUNCTION INIT (D : INTEGER) RETURN REC; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + END PRIV2; + + PACKAGE BODY PRIV2 IS + FUNCTION INIT (D : INTEGER) RETURN REC IS + BEGIN + RETURN (D => IDENT_INT (D)); + END INIT; + END PRIV2; + + USE PRIV2; + + BEGIN + DECLARE + R3 : CONSTANT REC3 := INIT (10); + I : INTEGER := IDENT_INT (R3.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R3" ); + END; + + BEGIN + DECLARE + PACKAGE LPRIV IS + TYPE REC (D : INTEGER) IS + LIMITED PRIVATE; + SUBTYPE REC4 IS REC (IDENT_INT (5)); + + R4 : CONSTANT REC4; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + R4 : CONSTANT REC4 := (D => IDENT_INT (10)); + END LPRIV; + + USE LPRIV; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (R4.D); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED AT DECLARATION " & + "OF R4" ); + END; + + RESULT; + END C37209B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37210a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37210a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37210a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37210a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C37210A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXPRESSION IN A DISCRIMINANT ASSOCIATION WITH MORE + -- THAN ONE NAME IS EVALUATED ONCE FOR EACH NAME. + + -- R.WILLIAMS 8/28/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37210A IS + + BUMP : INTEGER := IDENT_INT (0); + + FUNCTION F RETURN INTEGER IS + BEGIN + BUMP := BUMP + 1; + RETURN BUMP; + END F; + + FUNCTION CHECK (STR : STRING) RETURN INTEGER IS + BEGIN + IF BUMP /= 2 THEN + FAILED ( "INCORRECT DISCRIMINANT VALUES FOR " & STR); + END IF; + BUMP := IDENT_INT (0); + RETURN 5; + END CHECK; + + BEGIN + TEST ( "C37210A", "CHECK THAT THE EXPRESSION IN A " & + "DISCRIMINANT ASSOCIATION WITH MORE THAN " & + "ONE NAME IS EVALUATED ONCE FOR EACH NAME" ); + + DECLARE + TYPE REC (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + R : REC (D1 | D2 => F); + + I1 : INTEGER := CHECK ( "R" ); + + TYPE ACC IS ACCESS REC; + + AC : ACC (D1 | D2 => F); + + I2 : INTEGER := CHECK ( "AC" ); + + PACKAGE PKG IS + TYPE PRIV (D1, D2 : INTEGER) IS PRIVATE; + TYPE PACC IS ACCESS PRIV; + + TYPE LIM (D1, D2 : INTEGER) IS LIMITED PRIVATE; + TYPE LACC IS ACCESS LIM; + + PRIVATE + TYPE PRIV (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE LIM (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + BEGIN + + DECLARE + P : PRIV (D1 | D2 => F); + + I1 : INTEGER := CHECK ( "P" ); + + PA : PACC (D1 | D2 => F); + + I2 : INTEGER := CHECK ( "PA" ); + + L : LIM (D1 | D2 => F); + + I3 : INTEGER := CHECK ( "L" ); + + LA : LACC (D1 | D2 => F); + + I : INTEGER; + BEGIN + I := CHECK ( "LA" ); + END; + END; + + RESULT; + END C37210A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- C37211A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT + -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE + -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE + -- INDICATIONS WHERE THE TYPE MARK DENOTES A RECORD TYPE. + + -- R.WILLIAMS 8/28/86 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37211A IS + + TYPE REC (D : POSITIVE) IS + RECORD + NULL; + END RECORD; + + BEGIN + TEST ( "C37211A", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A RECORD TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBREC IS REC (IDENT_INT (-1)); + BEGIN + DECLARE + SR : SUBREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBREC " & INTEGER'IMAGE(SR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBREC" ); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1 .. 10) OF REC (IDENT_INT (-1)); + BEGIN + DECLARE + AR : ARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ARR " & INTEGER'IMAGE(AR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ARR" ); + END; + + BEGIN + DECLARE + TYPE REC1 IS + RECORD + X : REC (IDENT_INT (-1)); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE REC1" ); + END; + + BEGIN + DECLARE + TYPE ACCREC IS ACCESS REC (IDENT_INT (-1)); + BEGIN + DECLARE + ACR : ACCREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCREC " & INTEGER'IMAGE(ACR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCREC" ); + END; + + BEGIN + DECLARE + TYPE NEWREC IS NEW REC (IDENT_INT (-1)); + BEGIN + DECLARE + NR : NEWREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWREC " & INTEGER'IMAGE(NR.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWREC" ); + END; + + BEGIN + DECLARE + R : REC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "R " & INTEGER'IMAGE(R.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING R" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "R" ); + END; + + BEGIN + DECLARE + TYPE REC_NAME IS ACCESS REC; + BEGIN + DECLARE + RN : REC_NAME := NEW REC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT RN " & INTEGER'IMAGE(RN.D)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT RN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "REC_NAME" ); + END; + + BEGIN + DECLARE + TYPE BAD_REC (D : POSITIVE := IDENT_INT (-1)) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + BR : BAD_REC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BR " & INTEGER'IMAGE(BR.D)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BR" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_REC" ); + END; + + RESULT; + END C37211A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,495 ---- + -- C37211B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT + -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE + -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE + -- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED + -- PRIVATE TYPE, AND THE DISCRIMINANT CONSTRAINT OCCURS AFTER THE FULL + -- DECLARATION OF THE TYPE. + + -- R.WILLIAMS 8/28/86 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37211B IS + + SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE; + + PACKAGE PKG IS + TYPE PRIV (L : LIES) IS PRIVATE; + TYPE LIM (L : LIES) IS LIMITED PRIVATE; + + PRIVATE + TYPE PRIV (L : LIES) IS + RECORD + NULL; + END RECORD; + + TYPE LIM (L : LIES) IS + RECORD + NULL; + END RECORD; + END PKG; + + USE PKG; + + BEGIN + TEST ( "C37211B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A PRIVATE OR LIMITED " & + "PRIVATE TYPE, AND THE DISCRIMINANT " & + "CONSTRAINT OCCURS AFTER THE FULL " & + "DECLARATION OF THE TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBPRIV IS PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + SP : SUBPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBPRIV " & + BOOLEAN'IMAGE(SP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBPRIV" ); + END; + + BEGIN + DECLARE + SUBTYPE SUBLIM IS LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + SL : SUBLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBLIM" & + BOOLEAN'IMAGE(SL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SL " ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBLIM" ); + END; + + BEGIN + DECLARE + TYPE PARR IS ARRAY (1 .. 5) OF PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + PAR : PARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PARR " & + BOOLEAN'IMAGE(PAR(1).L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT PAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PARR" ); + END; + + BEGIN + DECLARE + TYPE LARR IS ARRAY (1 .. 10) OF LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + LAR : LARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LARR " & + BOOLEAN'IMAGE(LAR(1).L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT LAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LARR" ); + END; + + BEGIN + DECLARE + TYPE PRIV1 IS + RECORD + X : PRIV (IDENT_BOOL (TRUE)); + END RECORD; + + BEGIN + DECLARE + P1 : PRIV1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PRIV1 " & + BOOLEAN'IMAGE(P1.X.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT P1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PRIV1" ); + END; + + BEGIN + DECLARE + TYPE LIM1 IS + RECORD + X : LIM (IDENT_BOOL (TRUE)); + END RECORD; + + BEGIN + DECLARE + L1 : LIM1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LIM1 " & + BOOLEAN'IMAGE(L1.X.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT L1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LIM1" ); + END; + + BEGIN + DECLARE + TYPE ACCPRIV IS ACCESS PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + ACP : ACCPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCPRIV " & + BOOLEAN'IMAGE(ACP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCPRIV" ); + END; + + BEGIN + DECLARE + TYPE ACCLIM IS ACCESS LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + ACL : ACCLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCLIM " & + BOOLEAN'IMAGE(ACL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCLIM" ); + END; + + BEGIN + DECLARE + TYPE NEWPRIV IS NEW PRIV (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + NP : NEWPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWPRIV " & + BOOLEAN'IMAGE(NP.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWPRIV" ); + END; + + BEGIN + DECLARE + TYPE NEWLIM IS NEW LIM (IDENT_BOOL (TRUE)); + BEGIN + DECLARE + NL : NEWLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWLIM " & + BOOLEAN'IMAGE(NL.L)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWLIM" ); + END; + + BEGIN + DECLARE + P : PRIV (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "P " & BOOLEAN'IMAGE(P.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING P" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "P" ); + END; + + BEGIN + DECLARE + L : LIM (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "L " & BOOLEAN'IMAGE(L.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING L" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "L" ); + END; + + BEGIN + DECLARE + TYPE PRIV_NAME IS ACCESS PRIV; + BEGIN + DECLARE + PN : PRIV_NAME := NEW PRIV (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT PN " & + BOOLEAN'IMAGE(PN.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT PN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "PRIV_NAME" ); + END; + + BEGIN + DECLARE + TYPE LIM_NAME IS ACCESS LIM; + BEGIN + DECLARE + LN : LIM_NAME := NEW LIM (IDENT_BOOL (TRUE)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT LN " & + BOOLEAN'IMAGE(LN.L)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT LN" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "LIM_NAME" ); + END; + + BEGIN + DECLARE + PACKAGE PP IS + TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS + PRIVATE; + PRIVATE + TYPE BAD_PRIV (D : LIES := IDENT_BOOL (TRUE)) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + BP : BAD_PRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BP " & + BOOLEAN'IMAGE(BP.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BP" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_PRIV" ); + END; + + BEGIN + DECLARE + PACKAGE PL IS + TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS + LIMITED PRIVATE; + PRIVATE + TYPE BAD_LIM (D : LIES := IDENT_BOOL (TRUE)) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + BL : BAD_LIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BL " & + BOOLEAN'IMAGE(BL.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION ATTEMPTING TO USE OBJECT" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BL" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_LIM" ); + END; + + RESULT; + END C37211B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,426 ---- + -- C37211C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT + -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE + -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE + -- INDICATIONS WHERE THE TYPE MARK DENOTES A PRIVATE OR LIMITED + -- PRIVATE TYPE, THE DISCRIMINANT CONSTRAINT OCCURS BEFORE THE FULL + -- DECLARATION OF THE TYPE, AND THERE ARE NO COMPONENTS OF THE TYPE + -- DEPENDENT ON THE DISCRIMINANT. + + -- R.WILLIAMS 8/28/86 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37211C IS + + GLOBAL : BOOLEAN; + + SUBTYPE LIES IS BOOLEAN RANGE FALSE .. FALSE; + + FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS + BEGIN + GLOBAL := B; + RETURN B; + END SWITCH; + + BEGIN + TEST ( "C37211C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES A PRIVATE OR LIMITED " & + "PRIVATE TYPE, AND THE DISCRIMINANT " & + "CONSTRAINT OCCURS BEFORE THE FULL " & + "DECLARATION OF THE TYPE" ); + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV1 (D : LIES) IS PRIVATE; + SUBTYPE SUBPRIV IS PRIV1 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV1 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + SP : SUBPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBPRIV " & BOOLEAN'IMAGE(SP.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV1 NOT SUBTYPE SUBPRIV" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBPRIV" ); + END; + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM1 (D : LIES) IS LIMITED PRIVATE; + SUBTYPE SUBLIM IS LIM1 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM1 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + SL : SUBLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBLIM " & BOOLEAN'IMAGE(SL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM1 NOT SUBTYPE SUBLIM" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBLIM" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV2 (D : LIES) IS PRIVATE; + TYPE PARR IS ARRAY (1 .. 5) OF + PRIV2 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV2 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + PAR : PARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PARR " & BOOLEAN'IMAGE(PAR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT PAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV2 NOT TYPE PARR" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PARR" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM2 (D : LIES) IS LIMITED PRIVATE; + TYPE LARR IS ARRAY (1 .. 5) OF + LIM2 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM2 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + LAR : LARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LARR " & BOOLEAN'IMAGE(LAR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT LAR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM2 NOT TYPE LARR" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LARR" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV3 (D : LIES) IS PRIVATE; + + TYPE PRIV4 IS + RECORD + X : PRIV3 (IDENT_BOOL (TRUE)); + END RECORD; + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV3 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + BEGIN + DECLARE + P4 : PRIV4; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE PRIV4 " & BOOLEAN'IMAGE(P4.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT P4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV3 NOT TYPE PRIV4" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE PRIV4" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM3 (D : LIES) IS LIMITED PRIVATE; + + TYPE LIM4 IS + RECORD + X : LIM3 (IDENT_BOOL (TRUE)); + END RECORD; + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM3 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + BEGIN + DECLARE + L4 : LIM4; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE LIM4 " & BOOLEAN'IMAGE(L4.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT L4" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM3 NOT TYPE LIM4" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE LIM4" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PP IS + TYPE PRIV5 (D : LIES) IS PRIVATE; + TYPE ACCPRIV IS ACCESS PRIV5 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE PRIV5 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PP; + + USE PP; + + BEGIN + DECLARE + ACP : ACCPRIV; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCPRIV " & BOOLEAN'IMAGE(ACP.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACP" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE PRIV5 NOT TYPE ACCPRIV" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCPRIV" ); + END; + + BEGIN + DECLARE + B1 : BOOLEAN := SWITCH (TRUE); + + PACKAGE PL IS + TYPE LIM5 (D : LIES) IS LIMITED PRIVATE; + TYPE ACCLIM IS ACCESS LIM5 (IDENT_BOOL (TRUE)); + + B2 : BOOLEAN := SWITCH (FALSE); + + PRIVATE + TYPE LIM5 (D : LIES) IS + RECORD + NULL; + END RECORD; + END PL; + + USE PL; + + BEGIN + DECLARE + ACL : ACCLIM; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCLIM " & BOOLEAN'IMAGE(ACL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACL" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE LIM5 NOT TYPE ACCLIM" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCLIM" ); + END; + + RESULT; + END C37211C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C37211D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT + -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE + -- OF THE DISCRIMINANT. THIS TEST CONTAINS CHECKS FOR SUBTYPE + -- INDICATIONS WHERE THE TYPE MARK DENOTES AN INCOMPLETE TYPE. + + -- R.WILLIAMS 8/28/86 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37211D IS + + GLOBAL : BOOLEAN; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI; + + FUNCTION SWITCH (B : BOOLEAN) RETURN BOOLEAN IS + BEGIN + GLOBAL := B; + RETURN B; + END SWITCH; + + FUNCTION IDENT (D : DAY) RETURN DAY IS + BEGIN + RETURN DAY'VAL (IDENT_INT (DAY'POS (D))); + END IDENT; + + BEGIN + TEST ( "C37211D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES AN INCOMPLETE TYPE" ); + + BEGIN + DECLARE + + B1 : BOOLEAN := SWITCH (TRUE); + + TYPE REC (D : WEEKDAY); + + TYPE ACCREC IS ACCESS REC (IDENT (SUN)); + + B2 : BOOLEAN := SWITCH (FALSE); + + TYPE REC (D : WEEKDAY) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + AC : ACCREC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCREC " & DAY'IMAGE(AC.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AC" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL THEN + NULL; + ELSE + FAILED ( "EXCEPTION RAISED AT ELABORATION OF " & + "FULL TYPE REC NOT TYPE ACCREC" ); + END IF; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCREC" ); + END; + + RESULT; + END C37211D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37211e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37211e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,233 ---- + -- C37211E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY A DISCRIMINANT CONSTRAINT + -- IF A VALUE SPECIFIED FOR A DISCRIMINANT DOES NOT LIE IN THE RANGE + -- OF THE DISCRIMINANT. + + -- R.WILLIAMS 8/28/86 + -- PWN 10/27/95 REMOVED CHECK WHERE CONSTRAINT RULES HAVE CHANGED. + -- PWN 12/03/95 CORRECTED FORMATING PROBLEM. + -- TMB 11/20/96 REINTRODUCED CHECK REMOVED ON 10/27 WITH ADA95 CHANGES + -- TMB 12/2/96 DELETED CHECK OF CONSTRAINED ACCESS TYPE + -- EDS 07/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C37211E IS + + TYPE REC (D : POSITIVE) IS + RECORD + NULL; + END RECORD; + + TYPE ACC IS ACCESS REC; + BEGIN + TEST ( "C37211E", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "A DISCRIMINANT CONSTRAINT IF A VALUE " & + "SPECIFIED FOR A DISCRIMINANT DOES NOT LIE " & + "IN THE RANGE OF THE DISCRIMINANT WHERE THE " & + "TYPE MARK DENOTES AN ACCESS TYPE" ); + + BEGIN + DECLARE + SUBTYPE SUBACC IS ACC (IDENT_INT (-1)); + BEGIN + DECLARE + SA : SUBACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF SUBTYPE SUBACC " & + INTEGER'IMAGE(SA.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT SA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "SUBTYPE SUBACC" ); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1 .. 10) OF ACC (IDENT_INT (-1)); + BEGIN + DECLARE + AR : ARR; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ARR " & + INTEGER'IMAGE(AR(1).D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT AR" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ARR" ); + END; + + BEGIN + DECLARE + TYPE REC1 IS + RECORD + X : ACC (IDENT_INT (-1)); + END RECORD; + + BEGIN + DECLARE + R1 : REC1; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE REC1 " & INTEGER'IMAGE(R1.X.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT R1" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE REC1" ); + END; + + BEGIN + DECLARE + TYPE ACCA IS ACCESS ACC (IDENT_INT (-1)); + BEGIN + DECLARE + ACA : ACCA; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE ACCA " & + INTEGER'IMAGE(ACA.ALL.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT ACA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE ACCA" ); + END; + + BEGIN + DECLARE + TYPE NEWACC IS NEW ACC (IDENT_INT (-1)); + BEGIN + DECLARE + NA : NEWACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "ELABORATION OF TYPE NEWACC " & + INTEGER'IMAGE(NA.D)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT DECLARATION OF " & + "OBJECT NA" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT ELABORATION OF " & + "TYPE NEWACC" ); + END; + + BEGIN + DECLARE + A : ACC (IDENT_INT (-1)); + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE DECLARATION OF " & + "A " & INTEGER'IMAGE(A.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "CONTAINING A" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION OF " & + "A" ); + END; + + + BEGIN + DECLARE + TYPE BAD_ACC (D : POSITIVE := IDENT_INT (-1)) IS + RECORD + NULL; + END RECORD; + BEGIN + DECLARE + BAC : BAD_ACC; + BEGIN + FAILED ( "NO EXCEPTION RAISED AT THE " & + "DECLARATION OF OBJECT BAC " & + INTEGER'IMAGE(BAC.D)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE BLOCK " & + "DECLARING BAC" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED AT DECLARATION " & + "OF OBJECT BAC" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED AT ELABORATION OF TYPE " & + "BAD_ACC" ); + END; + + RESULT; + END C37211E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,241 ---- + -- C37213B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- A DISCRIMINANT CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE + -- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS + -- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: + -- + -- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION. + + -- JBG 10/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37213B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + + BEGIN + TEST ("C37213B", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + + -- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, F1); -- F1 EVALUATED + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : REC(D3, F1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37213B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,240 ---- + -- C37213D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- AN INDEX CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE + -- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS + -- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: + -- + -- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION. + + -- JBG 10/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37213D IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + + BEGIN + TEST ("C37213D", "CHECK EVALUATION OF INDEX BOUNDS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + + -- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : MY_ARR (F1..D3); -- F1 EVALUATED. + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN + FAILED ("INDEX BOUNDS NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := 1) IS + RECORD + C1 : MY_ARR(D3..F1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37213D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213f.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,379 ---- + -- C37213F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- A DISCRIMINANT CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE NON-DISCRIMINANT EXPRESSIONS IN THE + -- CONSTRAINT ARE EVALUATED WHEN THE COMPONENT SUBTYPE DEFINITION IS + -- ELABORATED, BUT THE VALUES ARE CHECKED WHEN THE RECORD TYPE IS: + -- + -- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE. + + -- JBG 10/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37213F IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": CONS IS " & + INTEGER'IMAGE(CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + + BEGIN + TEST ("C37213F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT" & + "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " & + "BE CHECKED"); + + -- CASE D1: COMPONENT IS PRESENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, F1); -- F1 EVALUATED + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (1, (1, 1)) OR Y /= (1, (1, 1)) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + -- CASE C2 : COMPONENT IS ABSENT + + F1_CONS := 2; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, F1); -- F1 EVALUATED + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED - 2"); + X : CONS; -- F1 NOT EVALUATED AGAIN + Y : CONS; -- F1 NOT EVALUATED AGAIN + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED - 2"); + BEGIN + IF X /= (-6, 0) OR Y /= (-6, 0) THEN + FAILED ("DISCRIMINANT VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("WRONG VALUE FOR X - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE WRONG - 12"); + END IF; + END; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + X : ARR; + BEGIN + IF X /= (1..5 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + X : NREC; + BEGIN + IF X /= (C1 => (11, 0)) THEN + FAILED ("X VALUE IS INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + X : NREC; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS := NEW CONS; + BEGIN + IF X.ALL /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17"); + END; + END; + + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37213F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213h.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,457 ---- + -- C37213H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, WHERE AN INDEX CONSTRAINT DEPENDS ON A RECORD + -- DISCRIMINANT WITH A DEFAULT VALUE AND THE RECORD TYPE IS NOT + -- EXPLICITLY CONSTRAINED, THAT THE NON-DISCRIMINANT EXPRESSIONS + -- IN THE INDEX CONSTRAINT ARE: + -- 1) EVALUATED WHEN THE RECORD COMPONENT SUBTYPE DEFINITION + -- IS ELABORATED, + -- 2) PROPERLY CHECKED FOR COMPATIBILITY ONLY IN AN ALLOCATION + -- OR OBJECT DECLARATION AND ONLY IF THE DISCRIMINANT- + -- DEPENDENT COMPONENT IS PRESENT IN THE SUBTYPE. + + -- HISTORY: + -- JBG 10/17/86 CREATED ORIGINAL TEST. + -- VCL 10/23/87 MODIFIED THIS HEADER; MODIFIED THE CHECK OF + -- SUBTYPE 'SCONS', IN BOTH SUBPARTS OF THE TEST, + -- TO INDICATE FAILURE IF CONSTRAINT_ERROR IS RAISED + -- FOR THE SUBTYPE DECLARATION AND FAILURE IF + -- CONSTRAINT_ERROR IS NOT RAISED FOR AN OBJECT + -- DECLARATION OF THIS SUBTYPE; RELOCATED THE CALL TO + -- REPORT.TEST SO THAT IT COMES BEFORE ANY + -- DECLARATIONS; ADDED 'SEQUENCE_NUMBER' TO IDENTIFY + -- THE CURRENT SUBTEST (FOR EXCEPTIONS); CHANGE THE + -- TYPE OF THE DISCRIMINANT IN THE RECORD 'CONS' + -- TO AN INTEGER SUBTYPE. + -- VCL 03/30/88 MODIFIED HEADER AND MESSAGES OUTPUT BY REPORT + -- PACKAGE. + + WITH REPORT; USE REPORT; + PROCEDURE C37213H IS + BEGIN + TEST ("C37213H", "THE NON-DISCRIMINANT EXPRESSIONS OF AN " & + "INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT WITH A DEFAULT VALUE ARE " & + "PROPERLY EVALUATED AND CHECKED WHEN THE " & + "RECORD TYPE IS NOT EXPLICITLY CONSTRAINED AND " & + "THE COMPONENT IS AND IS NOT PRESENT IN THE " & + "SUBTYPE"); + + DECLARE + SEQUENCE_NUMBER : INTEGER; + + SUBTYPE DISCR IS INTEGER RANGE -50..50; + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + F1_CONS : INTEGER := 2; + + FUNCTION CHK ( + CONS : INTEGER; + VALUE : INTEGER; + MESSAGE : STRING) RETURN BOOLEAN IS + BEGIN + IF CONS /= VALUE THEN + FAILED (MESSAGE & ": F1_CONS IS " & + INTEGER'IMAGE(F1_CONS)); + END IF; + RETURN TRUE; + END CHK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + F1_CONS := F1_CONS - IDENT_INT(1); + RETURN F1_CONS; + END F1; + BEGIN + + + -- CASE 1: DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT. + + SEQUENCE_NUMBER :=1; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(F1..D3); -- F1 EVALUATED. + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + + X : CONS; -- F1 NOT EVALUATED AGAIN. + Y : CONS; -- F1 NOT EVALUATED AGAIN. + + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X.C1'FIRST /= 1 OR Y.C1'LAST /= 1 THEN + FAILED ("VALUES NOT CORRECT"); + END IF; + END; + + + F1_CONS := 12; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X - 1"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 2"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 3"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 3"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 3A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 4"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 4"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 4A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 5"); + IF X /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 5"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 5A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 6"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("INCORRECT VALUES FOR X " & + "- 6"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + COMMENT ("UNEXPECTED EXCEPTION " & + "RAISED - 6A"); + END; + EXCEPTION + WHEN OTHERS => + COMMENT ("UNEXPECTED EXCEPTION RAISED " & + "- 6B"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6C"); + END; + END; + + + -- CASE D2: DISCRIMINANT-DEPENDENT COMPONENT IS ABSENT. + + F1_CONS := 2; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); -- F1 EVALUATED. + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + CHK1 : BOOLEAN := CHK (F1_CONS, 1, "F1 NOT EVALUATED"); + + X : CONS; -- F1 NOT EVALUATED AGAIN. + Y : CONS; -- F1 NOT EVALUATED AGAIN. + + CHK2 : BOOLEAN := CHK (F1_CONS, 1, "F1 EVALUATED"); + BEGIN + IF X /= (-6, 0) OR Y /= (-6, 0) THEN + FAILED ("VALUES NOT CORRECT"); + END IF; + END; + + F1_CONS := 12; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE CONS (D3 : DISCR := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..F1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE IS INCORRECT - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 12"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "12A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + IF X /= (1..5 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "13A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (C1 => (11, 0)) THEN + FAILED ("X VALUE INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "14A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "15A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + IF X.ALL /= (11, 0) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - " & + "17A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17B"); + END; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("INDEX VALUES IMPROPERLY CHECKED - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; + END C37213H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213j.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,320 ---- + -- C37213J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN + -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE + -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN + -- OBJECT OR A SUBTYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS + -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: + -- 1) ONLY IN AN OBJECT DECLARATION, AND + -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT + -- IN THE SUBTYPE. + + -- HISTORY: + -- JBG 10/17/86 CREATED ORIGINAL TEST. + -- VCL 10/23/87 MODIFIED THIS HEADER; SEPARATED THIS TEST INTO + -- 3 NEW TESTS (J,K,L); CHANGED THE AGGREGATE FOR + -- THE PARAMETER 'VALUE' IN THE CALL OF PROCEDURE + -- 'SUBTYPE_CHK1'; MOVED THE CALL TO REPORT.TEST + -- SO THAT IT COMES BEFORE ANY DECLARATIONS; ADDED + -- A SEQUENCE COUNTER TO IDENTIFY WHICH SUBTEST + -- DECLARATION PART RAISES CONSTRAINT_ERROR. + -- VCL 03/28/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY + -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL + -- PARAMETERS TO THE GENERIC UNITS AND THE + -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE + -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE + -- ARE TOGETHER. + + WITH REPORT; USE REPORT; + PROCEDURE C37213J IS + BEGIN + TEST ("C37213J", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE AN OBJECT OR A " & + "SUBTYPE"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE OBJ_CHK IS END OBJ_CHK; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PACKAGE BODY OBJ_CHK IS + BEGIN -- DECLARE AN OBJECT OF THE FORMAL TYPE. + DECLARE + X : CONS; + + FUNCTION VALUE RETURN CONS IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE CONS - " & TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE CONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + END OBJ_CHK; + + PROCEDURE SUBTYP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN -- DECLARE A SUBTYPE OF THE FORMAL TYPE. + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + + FUNCTION VALUE RETURN SCONS IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF SUBTYPE SCONS - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF SUBTYPE SCONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF SUBTYPE SCONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING SUBTYPE DECLARATION - " & TAG); + END SUBTYP_CHK; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW OBJ_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW SUBTYP_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW OBJ_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW SUBTYP_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW OBJ_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW SUBTYP_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW OBJ_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW SUBTYP_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE,TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW OBJ_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW SUBTYP_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW OBJ_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW SUBTYP_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW OBJ_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW SUBTYP_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW OBJ_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW SUBTYP_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING DECLARATION / " & + "INSTANTIATION ELABORATION - " & + INTEGER'IMAGE(SEQUENCE_NUMBER)); + END; + + RESULT; + END C37213J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213k.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,324 ---- + -- C37213K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN + -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE + -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE AN + -- ARRAY OR RECORD COMPONENT, THAT THE NON-DISCRIMINANT EXPRESSIONS + -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: + -- 1) ONLY IN AN OBJECT DECLARATION, AND + -- 2) ONLY IF THE DESCRIMINANT-DEPENDENT COMPONENT IS PRESENT + -- IN THE SUBTYPE. + + -- HISTORY: + -- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J. + -- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY + -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL + -- PARAMETERS TO THE GENERIC UNITS AND THE + -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE + -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE + -- ARE TOGETHER; REWROTE ONE OF THE GENERIC + -- PACKAGES AS A GENERIC PROCEDURE TO BROADEN + -- COVERAGE OF TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37213K IS + BEGIN + TEST ("C37213K", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE AN ARRAY OR A " & + "RECORD COMPONENT"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE ARRAY_COMP_CHK IS END ARRAY_COMP_CHK; + + PACKAGE BODY ARRAY_COMP_CHK IS + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + + FUNCTION VALUE RETURN ARR IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE ARR - " & TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE ARR - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE ARR - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF ARR - " & TAG); + END ARRAY_COMP_CHK; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PROCEDURE REC_COMP_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + + FUNCTION VALUE RETURN NREC IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE NREC - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF TYPE NREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE NREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF NREC - " & TAG); + END; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW ARRAY_COMP_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW REC_COMP_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW ARRAY_COMP_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW REC_COMP_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW REC_COMP_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW REC_COMP_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE, TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW ARRAY_COMP_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW REC_COMP_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW REC_COMP_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW REC_COMP_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW ARRAY_COMP_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW REC_COMP_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "DECLARATION / INSTANTIATION ELABORATION - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; + END C37213K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37213l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37213l.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,329 ---- + -- C37213L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A GENERIC FORMAL TYPE - WHERE A DISCRIMINANT OR AN + -- INDEX CONSTRAINT DEPENDS ON A RECORD DISCRIMINANT AND THE + -- RECORD TYPE IS CONSTRAINED BY DEFAULT - USED TO DECLARE A + -- DERIVED OR AN ACCESS TYPE, THAT THE NON-DISCRIMINANT EXPRESSIONS + -- OF THE CONSTRAINT ARE CHECKED FOR COMPATIBILITY: + -- 1) ONLY IN AN OBJECT DECLARATION OR ALLOCATOR, AND + -- 2) ONLY IF THE DISCRIMINANT-DEPENDENT COMPONENT IS PRESENT + -- IN THE SUBTYPE. + + -- HISTORY: + -- VCL 10/23/88 CREATED ORIGINAL TEST BY SPLITTING FROM C37213J. + -- VCL 03/30/88 MODIFIED THE TEST DISCRIPTION TO MORE ACCURATELY + -- DESCRIBE THE OBJECTIVE; CHANGED THE FORMAL + -- PARAMETERS TO THE GENERIC UNITS AND THE + -- CORRESPONDING ACTUAL PARAMETERS; REORGANIZED THE + -- TEST SO THAT ALL OPERATIONS ON A SPECIFIC TYPE + -- ARE TOGETHER; REWROTE ONE OF THE GENERIC + -- PACKAGES AS A GENERIC PROCEDURE TO BROADEN + -- COVERAGE OF TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37213L IS + BEGIN + TEST ("C37213L", "THE NON-DISCRIMINANT VALUES OF A DISCRIMINANT " & + "OR AN INDEX CONSTRAINT THAT DEPEND ON A " & + "DISCRIMINANT ARE PROPERLY CHECKED WHEN THE " & + "RECORD TYPE IS CONSTRAINED BY DEFAULT AND " & + "USED AS THE ACTUAL PARAMETER TO A GENERIC " & + "FORMAL TYPE USED TO DECLARE A DERIVED OR AN " & + "ACCESS TYPE"); + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + + GENERIC + TYPE CONS IS PRIVATE; + OBJ_XCP : BOOLEAN; + TAG : STRING; + PACKAGE DER_CHK IS END DER_CHK; + + PACKAGE BODY DER_CHK IS + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + + FUNCTION VALUE RETURN DREC IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN X; + END IF; + END VALUE; + BEGIN + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING DECLARATION " & + "OF OBJECT OF TYPE DREC - " & + TAG); + ELSIF X /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT OF " & + "TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT CHECKED " & + "DURING DECLARATION OF OBJECT " & + "OF TYPE DREC - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF DREC - " & TAG); + END; + + GENERIC + TYPE CONS IS PRIVATE; + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING); + + PROCEDURE ACC_CHK (OBJ_XCP : BOOLEAN; + TAG : STRING) IS + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + + FUNCTION VALUE RETURN CONS IS + BEGIN + IF EQUAL (5, 5) THEN + RETURN X.ALL; + ELSE + RETURN X.ALL; + END IF; + END VALUE; + BEGIN + X := NEW CONS; + + IF OBJ_XCP THEN + FAILED ("NO CHECK DURING ALLOCATION " & + "OF OBJECT OF TYPE CONS - " & + TAG); + ELSIF X.ALL /= VALUE THEN + FAILED ("INCORRECT VALUE FOR OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OBJ_XCP THEN + FAILED ("IMPROPER CONSTRAINT " & + "CHECKED DURING " & + "ALLOCATION OF OBJECT " & + "OF TYPE CONS - " & TAG); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF X - " & TAG); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT IMPROPERLY CHECKED " & + "DURING DECLARATION OF ACC_CONS - " & TAG); + END ACC_CHK; + BEGIN + SEQUENCE_NUMBER := 1; + DECLARE + TYPE REC_DEF (D3 : INTEGER := 1) IS + RECORD + C1 : REC (D3, 0); + END RECORD; + + PACKAGE PACK1 IS NEW DER_CHK (REC_DEF, + OBJ_XCP => TRUE, + TAG => "PACK1"); + + PROCEDURE PROC1 IS NEW ACC_CHK (REC_DEF); + BEGIN + PROC1 (OBJ_XCP => TRUE, TAG => "PROC1"); + END; + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE ARR_DEF (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + C1 : MY_ARR (0..D3); + END RECORD; + + PACKAGE PACK2 IS NEW DER_CHK (ARR_DEF, + OBJ_XCP => TRUE, + TAG => "PACK2"); + + PROCEDURE PROC2 IS NEW ACC_CHK (ARR_DEF); + BEGIN + PROC2 (OBJ_XCP => TRUE, TAG => "PROC2"); + END; + + SEQUENCE_NUMBER := 3; + DECLARE + TYPE VAR_REC_DEF1 (D3 : INTEGER := 1) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK3 IS NEW DER_CHK (VAR_REC_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK3"); + + PROCEDURE PROC3 IS NEW ACC_CHK (VAR_REC_DEF1); + BEGIN + PROC3 (OBJ_XCP => TRUE, TAG => "PROC3"); + END; + + SEQUENCE_NUMBER := 4; + DECLARE + TYPE VAR_REC_DEF6 (D3 : INTEGER := IDENT_INT(-6)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK4 IS NEW DER_CHK (VAR_REC_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK4"); + + PROCEDURE PROC4 IS NEW ACC_CHK (VAR_REC_DEF6); + BEGIN + PROC4 (OBJ_XCP => FALSE, TAG => "PROC4"); + END; + + SEQUENCE_NUMBER := 5; + DECLARE + TYPE VAR_REC_DEF11 (D3 : INTEGER := 11) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC (D3, IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK5 IS NEW DER_CHK (VAR_REC_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK5"); + + PROCEDURE PROC5 IS NEW ACC_CHK (VAR_REC_DEF11); + BEGIN + PROC5 (OBJ_XCP => FALSE, TAG => "PROC5"); + END; + + SEQUENCE_NUMBER := 6; + DECLARE + TYPE VAR_ARR_DEF1 (D3 : INTEGER := IDENT_INT(1)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK6 IS NEW DER_CHK (VAR_ARR_DEF1, + OBJ_XCP => TRUE, + TAG => "PACK6"); + + PROCEDURE PROC6 IS NEW ACC_CHK (VAR_ARR_DEF1); + BEGIN + PROC6 (OBJ_XCP => TRUE, TAG => "PROC6"); + END; + + SEQUENCE_NUMBER := 7; + DECLARE + TYPE VAR_ARR_DEF6 (D3 : INTEGER := -6) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK7 IS NEW DER_CHK (VAR_ARR_DEF6, + OBJ_XCP => FALSE, + TAG => "PACK7"); + + PROCEDURE PROC7 IS NEW ACC_CHK (VAR_ARR_DEF6); + BEGIN + PROC7 (OBJ_XCP => FALSE, TAG => "PROC7"); + END; + + SEQUENCE_NUMBER := 8; + DECLARE + TYPE VAR_ARR_DEF11 (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..IDENT_INT(11)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + + PACKAGE PACK8 IS NEW DER_CHK (VAR_ARR_DEF11, + OBJ_XCP => FALSE, + TAG => "PACK8"); + + PROCEDURE PROC8 IS NEW ACC_CHK (VAR_ARR_DEF11); + BEGIN + PROC8 (OBJ_XCP => FALSE, TAG => "PROC8"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "DECLARATION / INSTANTIATION ELABORATION - " & + INTEGER'IMAGE (SEQUENCE_NUMBER)); + END; + + RESULT; + END C37213L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- C37215B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- A DISCRIMINANT CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR + -- COMPATIBILITY WHEN THE RECORD TYPE IS: + -- + -- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION. + + -- JBG 10/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37215B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + BEGIN + TEST ("C37215B", "CHECK COMPATIBILITY OF DISCRIMINANT EXPRESSIONS"& + " WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + + -- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + C1 : REC(D3, 1); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37215B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,202 ---- + -- C37215D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- AN INDEX CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR + -- COMPATIBILITY WHEN THE RECORD TYPE IS: + -- + -- CASE B: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION. + + -- JBG 10/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37215D IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + BEGIN + TEST ("C37215D", "CHECK COMPATIBILITY OF INDEX BOUNDS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "AND DISCRIMINANTS HAVE DEFAULTS"); + + -- CASE B + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + C1 : MY_ARR(2..D3); + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + BEGIN + IF X.ALL /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 2"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1 => 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("INDEX CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1 => 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37215D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215f.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,313 ---- + -- C37215F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF + -- A DISCRIMINANT CONSTRAINT + -- DEPENDS ON A DISCRIMINANT, THE DISCRIMINANT VALUE IS CHECKED FOR + -- COMPATIBILITY WHEN THE RECORD TYPE IS: + -- + -- CASE D: USED WITHOUT A CONSTRAINT ONLY IN AN ALLOCATOR OR OBJECT + -- DECLARATION AND THE COMPONENT IS PRESENT IN THE DEFAULT SUBTYPE. + + -- JBG 10/17/86 + -- PWN 05/31/96 Corrected format of call to "TEST" + + WITH REPORT; USE REPORT; + PROCEDURE C37215F IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + TYPE REC (D1, D2 : SM) IS + RECORD NULL; END RECORD; + + BEGIN + TEST ("C37215F", "CHECK EVALUATION OF DISCRIMINANT EXPRESSIONS " & + "WHEN CONSTRAINT DEPENDS ON DISCRIMINANT, " & + "DISCRIMINANTS HAVE DEFAULTS, AND COMPONENT " & + "SUBTYPE DETERMINES WHETHER CONSTRAINT SHOULD " & + "BE CHECKED"); + + -- CASE D1: COMPONENT IS PRESENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, 1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("DISCRIMINANT CHECK NOT PERFORMED - 2"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 3"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 3"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 4"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 4"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 5"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 5"); + END; + + BEGIN + DECLARE + TYPE DREC IS NEW CONS; + BEGIN + DECLARE + X : DREC; + BEGIN + FAILED ("DISCRIMINANT CHECK NOT " & + "PERFORMED - 6"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECKED TOO SOON - 6"); + END; + + END; + + -- CASE C2 : COMPONENT IS ABSENT + + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : REC(D3, IDENT_INT(1)); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("WRONG VALUE FOR X - 11"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE WRONG - 12"); + END IF; + END; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 12"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + X : ARR; + BEGIN + IF X /= (1..5 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 13"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + X : NREC; + BEGIN + IF X /= (C1 => (11, 5)) THEN + FAILED ("X VALUE IS INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 14"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + X : NREC; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 15"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS := NEW CONS; + BEGIN + IF X.ALL /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("NONEXISTENT CONSTRAINT CHECKED - 17"); + END; + END; + + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT CHECK DONE TOO EARLY"); + RESULT; + + END C37215F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37215h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37215h.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,345 ---- + -- C37215H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF AN INDEX CONSTRAINT DEPENDS ON A DISCRIMINANT, + -- THE DISCRIMINANT VALUE IS CHECKED FOR COMPATIBILITY WHEN THE + -- RECORD TYPE IS: + -- + -- CASE D: CONSTRAINED BY DEFAULT AND THE COMPONENT IS + -- PRESENT IN THE SUBTYPE. + + -- HISTORY: + -- JBG 10/17/86 CREATED ORIGINAL TEST. + -- RJW 10/13/87 CORRECTED VARIOUS CONSTRAINT ERRORS IN 'CASE D1'. + -- VCL 03/30/88 CORRECTED VARIOUS CONSTRAINT ERRORS WITH TYPE + -- DECLARATIONS THROUGHOUT THE TEST. ADDED SEQUENCE + -- NUMBERS. + + WITH REPORT; USE REPORT; + PROCEDURE C37215H IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + TYPE MY_ARR IS ARRAY (SM RANGE <>) OF INTEGER; + + SEQUENCE_NUMBER : INTEGER; + BEGIN + TEST ("C37215H", "THE DISCRIMINANT VALUES OF AN INDEX " & + "CONSTRAINT ARE PROPERLY CHECK FOR " & + "COMPATIBILITY WHEN THE DISCRIMINANT IS " & + "DEFINED BY DEFAULT AND THE COMPONENT IS AND " & + "IS NOT PRESENT IN THE SUBTYPE"); + + -- CASE D1: COMPONENT IS PRESENT + + SEQUENCE_NUMBER := 1; + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(0)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(D3..1); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(0); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 1"); + IF X /= (1, (1, 1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 2"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 3"); + IF X /= (1..5 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 4"); + IF X /= (C1 => (1, (1, 1))) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + FAILED ("INDEX CHECK NOT PERFORMED - 5"); + IF X /= (1, (1, 1)) THEN + COMMENT ("IRRELEVANT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + BEGIN + DECLARE + X : ACC_CONS; + BEGIN + X := NEW CONS; + FAILED ("INDEX CHECK NOT PERFORMED - 6"); + IF X.ALL /= (1, (1, 1)) THEN + COMMENT ("WRONG VALUE FOR X - 6"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "- 6A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6B"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6C"); + END; + END; + + -- CASE D2: COMPONENT IS ABSENT + + SEQUENCE_NUMBER := 2; + DECLARE + TYPE CONS (D3 : INTEGER := IDENT_INT(11)) IS + RECORD + CASE D3 IS + WHEN -5..10 => + C1 : MY_ARR(IDENT_INT(2)..D3); + WHEN OTHERS => + C2 : INTEGER := IDENT_INT(5); + END CASE; + END RECORD; + BEGIN + BEGIN + DECLARE + X : CONS; + BEGIN + IF X /= (11, 5) THEN + COMMENT ("X VALUE IS INCORRECT - 11"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 11"); + END; + + BEGIN + DECLARE + SUBTYPE SCONS IS CONS; + BEGIN + DECLARE + X : SCONS; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 12"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12B"); + END; + + BEGIN + DECLARE + TYPE ARR IS ARRAY (1..5) OF CONS; + BEGIN + DECLARE + X : ARR; + BEGIN + IF X /= (1..5 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 13"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 13B"); + END; + + BEGIN + DECLARE + TYPE NREC IS + RECORD + C1 : CONS; + END RECORD; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (C1 => (11, 5)) THEN + FAILED ("X VALUE INCORRECT - 14"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14B"); + END; + + BEGIN + DECLARE + TYPE NREC IS NEW CONS; + BEGIN + DECLARE + X : NREC; + BEGIN + IF X /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 15"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 15B"); + END; + + BEGIN + DECLARE + TYPE ACC_CONS IS ACCESS CONS; + X : ACC_CONS; + BEGIN + X := NEW CONS; + IF X.ALL /= (11, 5) THEN + FAILED ("X VALUE INCORRECT - 17"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17A"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 17B"); + END; + END; + + RESULT; + EXCEPTION + WHEN OTHERS => + FAILED ("INDEX VALUES CHECKED TOO SOON - " & + INTEGER'IMAGE(SEQUENCE_NUMBER)); + RESULT; + END C37215H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C37217A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER THE OPTIONAL COMPATIBILITY CHECK IS + -- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS + -- TYPE - AFTER THE TYPE'S FULL DECLARATION. + + -- HISTORY: + -- DHH 02/05/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37217A IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + BEGIN --C37217A BODY + TEST ("C37217A", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " & + "- AFTER THE TYPE'S FULL DECLARATION"); + + -- CHECK FULL DECLARATION + -- LOWER LIMIT + BEGIN + DECLARE + + TYPE SM_REC(D : SM) IS + RECORD + NULL; + END RECORD; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_REC(D1); + END RECORD; + + TYPE PTR IS ACCESS REC; + + Y : PTR(IDENT_INT(0)); -- OPTIONAL EXCEPTION. + BEGIN + COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " & + "- LOWER"); + Y := NEW REC(IDENT_INT(0)); -- MANDATORY EXCEPTION. + FAILED("CONSTRAINT ERROR NOT RAISED"); + + IF IDENT_INT(Y.INT.D) /= IDENT_INT(-1) THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE ALLOCATION - LOWER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL CONSTRAINT ERROR RAISED - LOWER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - LOWER"); + END; + --------------------------------------------------------------------- + -- CHECK FULL DECLARATION + -- UPPER LIMIT + BEGIN + DECLARE + TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_ARR(1 .. D1); + END RECORD; + + TYPE PTR IS ACCESS REC; + + Y : PTR(IDENT_INT(11)); -- OPTIONAL EXCEPTION. + BEGIN + COMMENT("OPTIONAL COMBATIBILITY CHECK NOT PERFORMED " & + "- UPPER"); + Y := NEW REC'(IDENT_INT(11), -- MANDATORY EXCEPTION. + INT => (OTHERS => IDENT_INT(0))); + FAILED("CONSTRAINT ERROR NOT RAISED"); + + IF IDENT_INT(Y.INT(IDENT_INT(1))) /= 11 THEN + COMMENT ("IRRELEVANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE ALLOCATION - UPPER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- UPPER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - UPPER"); + END; + + RESULT; + + END C37217A; -- BODY diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C37217B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER THE OPTIONAL COMPATIBILITY CHECK IS + -- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS + -- TYPE - BEFORE THE DESIGNATED TYPE'S FULL DECLARATION. + + -- HISTORY: + -- DHH 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37217B IS + + SUBTYPE SM IS INTEGER RANGE 1..10; + + BEGIN --C37217B BODY + TEST ("C37217B", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE - " & + "BEFORE THE DESIGNATED TYPE'S FULL DECLARATION"); + + --------------------------------------------------------------------- + -- INCOMPLETE DECLARATION + -- UPPER LIMIT + BEGIN -- F + DECLARE -- F + TYPE REC(D1 : INTEGER); + + TYPE PTR IS ACCESS REC; + X : PTR(IDENT_INT(11)); + + TYPE SM_REC(D : SM) IS + RECORD + NULL; + END RECORD; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_REC(D1); + END RECORD; + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " & + "- UPPER"); + X := NEW REC(IDENT_INT(11)); + FAILED("CONSTRAINT ERROR NOT RAISED - UPPER"); + + IF IDENT_INT(X.INT.D) /= IDENT_INT(1) THEN + COMMENT("IRREVELANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - INCOMPLETE UPPER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- INCOMPLETE UPPER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - INCOMPLETE UPPER"); + END; -- F + + ----------------------------------------------------------------------- + -- INCOMPLETE DECLARATION + -- LOWER LIMIT + BEGIN -- A + DECLARE -- A + TYPE REC(D1 : INTEGER); + + TYPE PTR IS ACCESS REC; + X : PTR(IDENT_INT(0)); + + TYPE SM_ARR IS ARRAY(SM RANGE <>) OF INTEGER; + + TYPE REC(D1 : INTEGER) IS + RECORD + INT : SM_ARR(D1 .. 2); + END RECORD; + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED " & + "- LOWER"); + X := NEW REC'(IDENT_INT(0), INT => + (OTHERS => IDENT_INT(1))); + FAILED("CONSTRAINT ERROR NOT RAISED - LOWER"); + + IF X.INT(IDENT_INT(1)) /= IDENT_INT(1) THEN + COMMENT("IRREVELANT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - INCOMPLETE LOWER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED " & + "- INCOMPLETE LOWER"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - INCOMPLETE LOWER"); + END; + ----------------------------------------------------------------------- + RESULT; + + END C37217B; -- BODY diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37217c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37217c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C37217C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER THE OPTIONAL COMPATIBILITY CHECK IS + -- PERFORMED WHEN A DISCRIMINANT CONSTRAINT IS GIVEN FOR AN ACCESS + -- TYPE - WHEN THERE IS A "LOOP" IN THE DESIGNATED TYPE'S FULL + -- DECLARATION. + + -- HISTORY: + -- DHH 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37217C IS + + BEGIN --C37217C BODY + TEST ("C37217C", "CHECK WHETHER THE OPTIONAL COMPATIBILITY " & + "CHECK IS PERFORMED WHEN A DISCRIMINANT " & + "CONSTRAINT IS GIVEN FOR AN ACCESS TYPE " & + "- WHEN THERE IS A ""LOOP"" IN THE DESIGNATED " & + "TYPE'S FULL DECLARATION"); + + BEGIN + DECLARE + TYPE R1(D1 : INTEGER); + TYPE R2(D2 : INTEGER); + TYPE R3(D3 : POSITIVE); + + TYPE ACC_R1 IS ACCESS R1; + TYPE ACC_R2 IS ACCESS R2; + TYPE ACC_R3 IS ACCESS R3; + + TYPE R1(D1 : INTEGER) IS + RECORD + C1 : ACC_R2(D1); + END RECORD; + + TYPE R2(D2 : INTEGER) IS + RECORD + C2 : ACC_R3(D2); + END RECORD; + + TYPE R3(D3 : POSITIVE) IS + RECORD + C3 : ACC_R1(D3); + END RECORD; + + X1 : ACC_R1(IDENT_INT(0)); + + BEGIN + COMMENT("OPTIONAL COMPATIBILITY CHECK NOT PERFORMED"); + + X1 := NEW R1'(D1 =>IDENT_INT(0), + C1 => NEW R2'(D2 => IDENT_INT(0), + C2 => NEW R3(IDENT_INT(0)))); + + FAILED("CONSTRAINT_ERROR NOT RAISED"); + + IF IDENT_INT(X1.C1.C2.D3) /= IDENT_INT(0) THEN + COMMENT("THIS LINE SHOULD NOT PRINT OUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE USE - LOOPED"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("OPTIONAL COMPATIBILITY CHECK PERFORMED"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "VARIABLE DECLARATION - LOOPED"); + END; + + RESULT; + + END C37217C; -- BODY diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37304a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C37304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL FORMS OF CHOICE ARE PERMITTED IN A VARIANT_PART, + -- AND, IN PARTICULAR, THAT FORMS LIKE ST RANGE L..R, AND ST ARE + -- PERMITTED. + + -- ASL 7/31/81 + -- RM 8/26/82 + -- SPS 1/21/83 + + WITH REPORT; + PROCEDURE C37304A IS + + USE REPORT; + + BEGIN + + TEST("C37304A","ALL FORMS OF CHOICE ALLOWED IN A VARIANT_PART"); + + DECLARE + + TYPE T IS RANGE 1 .. 10; + C5 : CONSTANT T := 5; + SUBTYPE S1 IS T RANGE 1 .. 5; + SUBTYPE S2 IS T RANGE C5 + 1 .. 7; + SUBTYPE SN IS T RANGE C5 + 4 .. C5 - 4 + 7; -- NULL RANGE. + SUBTYPE S10 IS T RANGE C5 + 5 .. T'LAST; + + TYPE VREC( DISC : T := 8 ) IS + RECORD + CASE DISC IS + WHEN SN -- 9..8 + | S1 RANGE 1 .. 0 -- 1..0 + | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6 + | 3 .. 2 -- 3..2 + => NULL; + + WHEN S1 RANGE 4 .. C5 -- 4..5 + | S1 RANGE C5 - 4 .. C5 / 2 -- 1..2 + | 3 .. 1 + C5 MOD 3 -- 3..3 + | SN -- 9..8 + | S1 RANGE 5 .. C5 - 1 -- 5..4 + | 6 .. 7 -- 6..7 + | S10 -- 10..10 + | 9 -- 9 + | S10 RANGE 10 .. 9 -- 10..9 + => NULL; + + WHEN C5 + C5 - 2 .. 8 -- 8 + => NULL; + + END CASE; + END RECORD; + + V : VREC; + + BEGIN + + IF EQUAL(3,3) THEN + V := (DISC => 5); + END IF; + IF V.DISC /= 5 THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + + END; + + RESULT; + + END C37304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37305a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C37305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CHOICES DENOTING A NULL RANGE OF VALUES ARE PERMITTED, + -- AND THAT FOR CHOICES CONSISTING OF A SUBTYPE NAME FOLLOWED BY A + -- RANGE CONSTRAINT WHERE THE LOWER BOUND IS GREATER THAN THE UPPER + -- BOUND, THE BOUNDS NEED NOT BE IN THE RANGE OF THE SUBTYPE VALUES. + + -- CHECK THAT AN OTHERS ALTERNATIVE CAN BE PROVIDED EVEN IF ALL VALUES + -- OF THE CASE EXPRESSION HAVE BEEN COVERED BY PRECEDING ALTERNATIVES. + + -- ASL 7/14/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C37305A IS + + USE REPORT; + + BEGIN + TEST ("C37305A","NULL RANGES ALLOWED IN CHOICES FOR VARIANT " & + "PARTS. OTHERS ALTERNATIVE ALLOWED AFTER ALL VALUES " & + "PREVIOUSLY COVERED"); + + DECLARE + SUBTYPE ST IS INTEGER RANGE 1..10; + + TYPE REC(DISC : ST := 1) IS + RECORD + CASE DISC IS + WHEN 0..-1 => NULL; + WHEN 1..-3 => NULL; + WHEN 6..5 => + COMP : INTEGER; + WHEN 11..10 => NULL; + WHEN 15..12 => NULL; + WHEN 11..0 => NULL; + WHEN 1..10 => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R : REC; + BEGIN + R := (DISC => 4); + + IF EQUAL(3,4) THEN + R := (DISC => 7); + END IF; + + IF R.DISC /= 4 THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + + END C37305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37306a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37306a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37306a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37306a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C37306A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN A VARIANT PART OF A RECORD THE CHOICES WITHIN AND + -- BETWEEN ALTERNATIVES CAN APPEAR IN NON-MONOTONIC ORDER. + + -- ASL 7/13/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE C37306A IS + + USE REPORT; + + BEGIN + TEST ("C37306A","NON-MONOTONIC ORDER OF CHOICES IN VARIANT PARTS"); + + DECLARE + TYPE COLOR IS (WHITE,RED,ORANGE,YELLOW,GREEN,AQUA,BLUE,BLACK); + + TYPE REC(DISC : COLOR := BLUE) IS + RECORD + CASE DISC IS + WHEN ORANGE => NULL; + WHEN GREEN | WHITE | BLACK => NULL; + WHEN YELLOW => NULL; + WHEN BLUE | RED => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R : REC; + BEGIN + R := (DISC => WHITE); + + IF EQUAL(3,4) THEN + R := (DISC => RED); + END IF; + + IF R.DISC /= WHITE THEN + FAILED ("ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + END C37306A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37309a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37309a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37309a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37309a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C37309A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DISCRIMINANT HAS A STATIC SUBTYPE, AN OTHERS + -- CHOICE CAN BE OMITTED IF ALL VALUES IN THE + -- SUBTYPE'S RANGE ARE COVERED IN A VARIANT PART. + + -- ASL 7/10/81 + -- SPS 10/25/82 + -- SPS 7/17/83 + + WITH REPORT; + PROCEDURE C37309A IS + + USE REPORT; + + BEGIN + TEST ("C37309A","OTHERS CHOICE CAN BE OMITTED IN VARIANT PART " & + "IF ALL VALUES IN STATIC SUBTYPE RANGE OF DISCRIMINANT " & + "ARE COVERED"); + + DECLARE + SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N'; + TYPE REC1(DISC : STATCHAR := 'J') IS + RECORD + CASE DISC IS + WHEN 'I' => NULL; + WHEN 'J' => NULL; + WHEN 'K' => NULL; + WHEN 'L' => NULL; + WHEN 'M' => NULL; + WHEN 'N' => NULL; + END CASE; + END RECORD; + + R1 : REC1; + BEGIN + R1 := (DISC => 'N'); + IF EQUAL(3,3) THEN + R1 := (DISC => 'K'); + END IF; + IF R1.DISC /= 'K' THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + + END C37309A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37310a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37310a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37310a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37310a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C37310A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DISCRIMINANT HAS A DYNAMIC SUBTYPE, AN OTHERS + -- CHOICE CAN BE OMITTED IF ALL VALUES IN THE BASE + -- TYPE'S RANGE ARE COVERED. + + -- ASL 7/10/81 + -- SPS 10/25/82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; + PROCEDURE C37310A IS + + USE REPORT; + + BEGIN + TEST ("C37310A", "CHECK DYNAMIC DISCRIMINANT SUBTYPES " & + "IN VARIANT RECORD DECLARATIONS"); + + DECLARE + + ACHAR : CHARACTER := IDENT_CHAR('A'); + ECHAR : CHARACTER := IDENT_CHAR('E'); + JCHAR : CHARACTER := IDENT_CHAR('J'); + MCHAR : CHARACTER := IDENT_CHAR('M'); + SUBTYPE STATCHAR IS CHARACTER RANGE 'I'..'N'; + SUBTYPE DYNCHAR IS CHARACTER RANGE ACHAR..ECHAR; + SUBTYPE SSTAT IS STATCHAR RANGE JCHAR..MCHAR; + + TYPE LETTER IS NEW CHARACTER RANGE 'A'..'Z'; + SUBTYPE DYNLETTER IS + LETTER RANGE LETTER(ECHAR)..LETTER(JCHAR); + + TYPE REC1(DISC : SSTAT := 'K') IS + RECORD + CASE DISC IS + WHEN ASCII.NUL..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC2(DISC : DYNCHAR := 'C') IS + RECORD + CASE DISC IS + WHEN ASCII.NUL..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC3(DISC: DYNCHAR := 'D') IS + RECORD + CASE DISC IS + WHEN CHARACTER'FIRST..CHARACTER'LAST => NULL; + END CASE; + END RECORD; + + TYPE REC4(DISC : DYNLETTER := 'F') IS + RECORD + CASE DISC IS + WHEN LETTER'BASE'FIRST.. + LETTER'BASE'LAST => NULL; + END CASE; + END RECORD; + + R1 : REC1; + R2 : REC2; + R3 : REC3; + R4 : REC4; + BEGIN + IF EQUAL(3,3) THEN + R1 := (DISC => 'L'); + END IF; + IF R1.DISC /= 'L' THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + R2 := (DISC => 'B'); + END IF; + IF R2.DISC /= 'B' THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + R3 := (DISC => 'B'); + END IF; + IF R3.DISC /= 'B' THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + IF EQUAL(3,3) THEN + R4 := (DISC => 'H'); + END IF; + IF R4.DISC /= 'H' THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + + END C37310A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37312a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37312a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37312a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37312a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C37312A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DISCRIMINANT CAN HAVE A GENERIC FORMAL DISCRETE + -- TYPE WHEN IT DOES NOT GOVERN A VARIANT PART AND THAT AN + -- OBJECT OF A GENERIC FORMAL TYPE CAN CONSTRAIN A COMPONENT + -- IN A VARIANT PART. + + -- HISTORY: + -- AH 08/22/86 CREATED ORIGINAL TEST. + -- JET 08/13/87 REVISED FROM CLASS 'A' TO CLASS 'C' TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C37312A IS + + BEGIN + TEST ("C37312A", "DISCRIMINANT TYPE IS GENERIC FORMAL TYPE"); + + DECLARE + TYPE T IS RANGE 1 ..5; + + GENERIC + TYPE G1 IS RANGE <>; + PACKAGE P IS + TYPE G2 (D1 : G1) IS + RECORD + R1 : G1; + R2 : BOOLEAN; + END RECORD; + + TYPE STR IS ARRAY(G1 RANGE <>) OF INTEGER; + TYPE G3 (D : G1; E : INTEGER) IS + RECORD + CASE E IS + WHEN 1 => + S1 : STR(G1'FIRST..D); + WHEN OTHERS => + S2 : INTEGER; + END CASE; + END RECORD; + + END P; + + PACKAGE PKG IS NEW P (G1 => T); + USE PKG; + + A2: G2(1) := (1, 5, FALSE); + A3: G3(5, 1) := (5, 1, (1, 2, 3, 4, 5)); + + BEGIN + A2.R2 := IDENT_BOOL (TRUE); + A3.S1(1) := IDENT_INT (6); + + IF A2 /= (1, 5, TRUE) THEN + FAILED ("INVALID CONTENTS OF RECORD A2"); + END IF; + IF A3 /= (5, 1, (6, 2, 3, 4, 5)) THEN + FAILED ("INVALID CONTENTS OF RECORD A3"); + END IF; + END; + + RESULT; + + END C37312A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37402a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,253 ---- + -- C37402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR + -- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT + -- HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN APPLIED TO FORMAL + -- PARAMETERS OF MODE IN AND HAS THE VALUE OF THE ACTUAL PARAMETER + -- FOR THE OTHER MODES. + + -- R.WILLIAMS 9/1/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37402A IS + + BEGIN + TEST ( "C37402A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " & + "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " & + "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " & + "HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' WHEN " & + "APPLIED TO FORMAL PARAMETERS OF MODE IN " & + "AND HAS THE VALUE OF THE ACTUAL PARAMETER " & + "FOR THE OTHER MODES" ); + + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + + TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>) + OF INTEGER; + + TYPE SQUARE (SIDE : INT := 1) IS + RECORD + MAT : MATRIX (1 .. SIDE, 1 .. SIDE); + END RECORD; + + SC : CONSTANT SQUARE := (2, ((0, 0), (0, 0))); + + AC : SQUARE (2) := (2, ((1, 2), (3, 4))); + AU : SQUARE := (SIDE => 1, MAT => (1 => (1 => 1))); + + BC : SQUARE (2) := AC; + BU : SQUARE := AU; + + CC : SQUARE (2); + CU : SQUARE; + + PROCEDURE P (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE) IS + + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 1" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 2" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 3" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF IN OUT MODE - 1" ); + END IF; + + IF OUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF OUT MODE - 1" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF IN OUT MODE " & + "- 1" ); + END IF; + + IF OUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF OUT MODE - 1" ); + END IF; + + OUT_CON := (2, ((1, 2), (3, 4))); + OUT_UNC := (2, ((1, 2), (3, 4))); + END P; + + TASK T IS + ENTRY Q (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE); + END T; + + TASK BODY T IS + BEGIN + ACCEPT Q (CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + OUT_CON : OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + OUT_UNC : OUT SQUARE) DO + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 4" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 5" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 6" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF OUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF OUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + OUT_CON := (2, ((1, 2), (3, 4))); + OUT_UNC := (2, ((1, 2), (3, 4))); + END; + END Q; + END T; + + GENERIC + CON, IN_CON : IN SQUARE; + INOUT_CON : IN OUT SQUARE; + IN_UNC : IN SQUARE; + INOUT_UNC : IN OUT SQUARE; + PACKAGE R IS END R; + + PACKAGE BODY R IS + BEGIN + IF CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 7" ); + END IF; + + IF IN_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 8" ); + END IF; + + IF IN_UNC'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 9" ); + END IF; + + IF INOUT_CON'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "CONSTRAINED OBJECT OF IN OUT MODE - 3" ); + END IF; + + IF INOUT_UNC'CONSTRAINED THEN + FAILED ( "'CONSTRAINED IS 'TRUE' FOR " & + "UNCONSTRAINED OBJECT OF IN OUT MODE " & + "- 3" ); + END IF; + + END R; + + PACKAGE S IS NEW R (SC, AC, BC, AU, BU); + + BEGIN + P (SC, AC, BC, CC, AU, BU, CU); + T.Q (SC, AC, BC, CC, AU, BU, CU); + END; + + RESULT; + END C37402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37403a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37403a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37403a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37403a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- C37403A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A FORMAL PARAMETER OF A SUBPROGRAM, ENTRY, OR + -- GENERIC UNIT HAS AN UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT DO + -- NOT HAVE DEFAULTS, 'CONSTRAINED IS 'TRUE' REGARDLESS OF THE MODE + -- OF THE PARAMETER. + + -- R.WILLIAMS 9/1/86 + + WITH REPORT; USE REPORT; + PROCEDURE C37403A IS + + BEGIN + TEST ( "C37403A", "CHECK THAT WHEN A FORMAL PARAMETER OF A " & + "SUBPROGRAM, ENTRY, OR GENERIC UNIT HAS AN " & + "UNCONSTRAINED TYPE WITH DISCRIMINANTS THAT " & + "DO NOT HAVE DEFAULTS, 'CONSTRAINED IS " & + "'TRUE' REGARDLESS OF THE MODE OF THE " & + "PARAMETER" ); + + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1.. 10; + + TYPE MATRIX IS ARRAY (INT RANGE <>, INT RANGE <>) + OF INTEGER; + + TYPE SQUARE (SIDE : INT) IS + RECORD + MAT : MATRIX (1 .. SIDE, 1 .. SIDE); + END RECORD; + + S1 : SQUARE (2) := (2, ((1, 2), (3, 4))); + + S2 : SQUARE (2) := S1; + + S3 : SQUARE (2); + + SC : CONSTANT SQUARE := (SIDE => 1, MAT => (1 => (1 => 1))); + + PROCEDURE P (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE) IS + + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 1" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 2" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN OUT MODE - 1" ); + END IF; + + IF POUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF OUT MODE - 1" ); + END IF; + + POUT := (2, ((1, 2), (3, 4))); + END P; + + TASK T IS + ENTRY Q (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE); + END T; + + TASK BODY T IS + BEGIN + ACCEPT Q (PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + POUT : OUT SQUARE) DO + + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 3" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN MODE - 4" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF " & + "IN OUT MODE - 2" ); + END IF; + + IF POUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF " & + "OUT MODE - 2" ); + END IF; + + POUT := (2, ((1, 2), (3, 4))); + END; + END Q; + END T; + + GENERIC + PIN1, PIN2 : IN SQUARE; + PINOUT : IN OUT SQUARE; + PACKAGE R IS END R; + + PACKAGE BODY R IS + BEGIN + IF PIN1'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 5" ); + END IF; + + IF PIN2'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR OBJECT " & + "OF IN MODE - 6" ); + END IF; + + IF PINOUT'CONSTRAINED THEN + NULL; + ELSE + FAILED ( "'CONSTRAINED IS 'FALSE' FOR " & + "OBJECT OF IN OUT MODE - 3" ); + END IF; + + END R; + + PACKAGE S IS NEW R (S1, SC, S2); + + BEGIN + P (S1, SC, S2, S3); + T.Q (S1, SC, S2, S3); + END; + + RESULT; + END C37403A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37404a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37404a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37404a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37404a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + --C37404A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'CONSTRAINED IS TRUE FOR VARIABLES DECLARED WITH A + -- CONSTRAINED TYPE, FOR CONSTANT OBJECTS (EVEN IF NOT DECLARED + -- WITH A CONSTRAINED TYPE), AND DESIGNATED OBJECTS. + + -- HISTORY: + -- DHH 02/25/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37404A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + TYPE REC(A : INT) IS + RECORD + I : INT; + END RECORD; + + TYPE ACC_REC IS ACCESS REC(4); + TYPE ACC_REC1 IS ACCESS REC; + SUBTYPE REC4 IS REC(4); + SUBTYPE REC5 IS REC; + + TYPE REC_DEF(A : INT := 5) IS + RECORD + I : INT := 1; + END RECORD; + + TYPE ACC_DEF IS ACCESS REC_DEF(4); + TYPE ACC_DEF1 IS ACCESS REC_DEF; + SUBTYPE REC6 IS REC_DEF(6); + SUBTYPE REC7 IS REC_DEF; + + A : REC4 := (A => 4, I => 1); -- CONSTRAINED. + B : REC5(4) := (A => 4, I => 1); -- CONSTRAINED. + C : REC6; -- CONSTRAINED. + D : REC7(6); -- CONSTRAINED. + E : ACC_REC1(4); -- CONSTRAINED. + F : ACC_DEF1(4); -- CONSTRAINED. + G : ACC_REC1; -- UNCONSTRAINED. + H : ACC_DEF1; -- UNCONSTRAINED. + + R : REC(5) := (A => 5, I => 1); -- CONSTRAINED. + T : REC_DEF(5); -- CONSTRAINED. + U : ACC_REC; -- CONSTRAINED. + V : ACC_DEF; -- CONSTRAINED. + W : CONSTANT REC(5) := (A => 5, I => 1); -- CONSTANT. + X : CONSTANT REC := (A => 5, I => 1); -- CONSTANT. + Y : CONSTANT REC_DEF(5) := (A => 5, I => 1); -- CONSTANT. + Z : CONSTANT REC_DEF := (A => 5, I => 1); -- CONSTANT. + + BEGIN + TEST("C37404A", "CHECK THAT 'CONSTRAINED IS TRUE FOR VARIABLES " & + "DECLARED WITH A CONSTRAINED TYPE, FOR " & + "CONSTANT OBJECTS (EVEN IF NOT DECLARED WITH A " & + "CONSTRAINED TYPE), AND DESIGNATED OBJECTS"); + + U := NEW REC(4); + V := NEW REC_DEF(4); + E := NEW REC(4); + F := NEW REC_DEF(4); + G := NEW REC(4); -- CONSTRAINED. + H := NEW REC_DEF(4); -- CONSTRAINED. + + IF NOT A'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE1"); + END IF; + + IF NOT B'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR SUBTYPE2"); + END IF; + + IF NOT C'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE1"); + END IF; + + IF NOT D'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT SUBTYPE2"); + END IF; + + IF NOT R'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR RECORD COMPONENT"); + END IF; + + IF NOT T'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT VARIABLE"); + END IF; + + IF NOT E.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 1"); + END IF; + + IF NOT F.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 1"); + END IF; + + IF NOT G.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 2"); + END IF; + + IF NOT H.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 2"); + END IF; + + IF NOT U.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR ACCESS 3"); + END IF; + + IF NOT V.ALL'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT ACCESS 3"); + END IF; + + IF NOT W'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, CONSTRAINED"); + END IF; + + IF NOT X'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR CONSTANT, UNCONSTRAINED"); + END IF; + + IF NOT Y'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " & + "CONSTRAINED"); + END IF; + + IF NOT Z'CONSTRAINED THEN + FAILED("'CONSTRAINED NOT TRUE FOR DEFAULT CONSTANT, " & + "UNCONSTRAINED"); + END IF; + + IF IDENT_INT(T.I) /= 1 OR + IDENT_INT(C.I) /= 1 OR + IDENT_INT(D.I) /= 1 OR + IDENT_INT(W.A) /= 5 OR + IDENT_INT(X.A) /= 5 OR + IDENT_INT(Y.A) /= 5 OR + IDENT_INT(Z.I) /= 1 OR + IDENT_INT(A.I) /= 1 OR + IDENT_INT(B.I) /= 1 OR + IDENT_BOOL(R.I /= 1) THEN + FAILED("INCORRECT INITIALIZATION VALUES"); + END IF; + + RESULT; + END C37404A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37404b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37404b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37404b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37404b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + --C37404B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'CONSTRAINED IS FALSE FOR VARIABLES THAT HAVE + -- DISCRIMINANTS WITH DEFAULT VALUES. + + -- HISTORY: + -- LDC 06/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C37404B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE REC_DEF(A : INT := 5) IS + RECORD + I : INT := 1; + END RECORD; + + SUBTYPE REC_DEF_SUB IS REC_DEF; + + TYPE REC_DEF_ARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF; + TYPE REC_DEF_SARR IS ARRAY (INTEGER RANGE -8..7) OF REC_DEF_SUB; + + PACKAGE PRI_PACK IS + TYPE REC_DEF_PRI(A : INTEGER := 5) IS PRIVATE; + TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS LIMITED PRIVATE; + + PRIVATE + + TYPE REC_DEF_PRI(A : INTEGER := 5) IS + RECORD + I : INTEGER := 1; + END RECORD; + + TYPE REC_DEF_LIM_PRI(A : INTEGER := 5) IS + RECORD + I : INTEGER := 1; + END RECORD; + + END PRI_PACK; + USE PRI_PACK; + + A : REC_DEF; + B : REC_DEF_SUB; + C : ARRAY (0..15) OF REC_DEF; + D : ARRAY (0..15) OF REC_DEF_SUB; + E : REC_DEF_ARR; + F : REC_DEF_SARR; + G : REC_DEF_PRI; + H : REC_DEF_LIM_PRI; + + Z : REC_DEF; + + PROCEDURE SUBPROG(REC : OUT REC_DEF) IS + + BEGIN + IF REC'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT " & + "PARAMETER INSIDE THE SUBPROGRAM"); + END IF; + END SUBPROG; + + BEGIN + TEST("C37404B", "CHECK THAT 'CONSTRAINED IS FALSE FOR VARIABLES" & + " THAT HAVE DISCRIMINANTS WITH DEFAULT VALUES."); + + IF A'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR RECORD COMPONENT"); + END IF; + + IF B'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBTYPE"); + END IF; + + IF C(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE"); + END IF; + + IF D(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE"); + END IF; + + IF E(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY TYPE"); + END IF; + + IF F(1)'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR ARRAY OF SUBTYPE"); + END IF; + + IF G'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR PRIVATE TYPE"); + END IF; + + IF H'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR LIMITED PRIVATE TYPE"); + END IF; + + SUBPROG(Z); + IF Z'CONSTRAINED THEN + FAILED("'CONSTRAINED TRUE FOR SUBPROGRAM OUT PARAMETER " & + "AFTER THE CALL"); + END IF; + + IF IDENT_INT(A.I) /= 1 OR + IDENT_INT(B.I) /= 1 OR + IDENT_INT(C(1).I) /= 1 OR + IDENT_INT(D(1).I) /= 1 OR + IDENT_INT(E(1).I) /= 1 OR + IDENT_INT(F(1).I) /= 1 OR + IDENT_INT(Z.I) /= 1 OR + IDENT_INT(A.A) /= 5 OR + IDENT_INT(B.A) /= 5 OR + IDENT_INT(C(1).A) /= 5 OR + IDENT_INT(D(1).A) /= 5 OR + IDENT_INT(E(1).A) /= 5 OR + IDENT_INT(F(1).A) /= 5 OR + IDENT_INT(G.A) /= 5 OR + IDENT_INT(H.A) /= 5 OR + IDENT_INT(Z.A) /= 5 THEN + FAILED("INCORRECT INITIALIZATION VALUES"); + END IF; + + RESULT; + END C37404B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37405a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37405a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37405a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37405a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- C37405A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN ASSIGNING TO A CONSTRAINED OR UNCONSTRAINED + -- OBJECT OR FORMAL PARAMETER OF A TYPE DECLARED WITH DEFAULT + -- DISCRIMINANTS, THE ASSIGNMENT DOES NOT CHANGE THE 'CONSTRAINED + -- ATTRIBUTE VALUE ASSOCIATED WITH THE OBJECT OR PARAMETER. + + -- ASL 7/21/81 + -- TBN 1/20/86 RENAMED FROM C37209A.ADA AND REVISED THE ASSIGNMENTS + -- OF CONSTRAINED AND UNCONSTRAINED OBJECTS TO ARRAY AND + -- RECORD COMPONENTS. + + WITH REPORT; USE REPORT; + PROCEDURE C37405A IS + + TYPE REC(DISC : INTEGER := 25) IS + RECORD + COMP : INTEGER; + END RECORD; + + SUBTYPE CONSTR IS REC(10); + SUBTYPE UNCONSTR IS REC; + + TYPE REC_C IS + RECORD + COMP: CONSTR; + END RECORD; + + TYPE REC_U IS + RECORD + COMP: UNCONSTR; + END RECORD; + + C1,C2 : CONSTR; + U1,U2 : UNCONSTR; + -- C2 AND U2 ARE NOT PASSED TO EITHER PROC1 OR PROC2. + + ARR_C : ARRAY (1..5) OF CONSTR; + ARR_U : ARRAY (1..5) OF UNCONSTR; + + REC_COMP_C : REC_C; + REC_COMP_U : REC_U; + + PROCEDURE PROC11(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := C2; + IF IDENT_BOOL(B) /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 1"); + END IF; + END PROC11; + + PROCEDURE PROC12(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + PARM := U2; + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 2"); + END IF; + END PROC12; + + PROCEDURE PROC1(PARM : IN OUT UNCONSTR; B : IN BOOLEAN) IS + BEGIN + IF B /= PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "PASSING PARAMETER"); + END IF; + + PROC11(PARM, B); + + PROC12(PARM, B); + + END PROC1; + + PROCEDURE PROC2(PARM : IN OUT CONSTR) IS + BEGIN + COMMENT ("CALLING PROC1 FROM PROC2"); -- IN CASE TEST FAILS. + PROC1(PARM,TRUE); + PARM := U2; + IF NOT PARM'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY " & + "ASSIGNMENT - 3"); + END IF; + END PROC2; + BEGIN + TEST("C37405A", "'CONSTRAINED ATTRIBUTE OF OBJECTS, FORMAL " & + "PARAMETERS CANNOT BE CHANGED BY ASSIGNMENT"); + + C2 := (DISC => IDENT_INT(10), COMP => 3); + U2 := (DISC => IDENT_INT(10), COMP => 4); + + ARR_C := (1..5 => U2); + ARR_U := (1..5 => C2); + + REC_COMP_C := (COMP => U2); + REC_COMP_U := (COMP => C2); + + C1 := U2; + U1 := C2; + + IF U1'CONSTRAINED OR NOT C1'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 4"); + END IF; + + IF ARR_U(3)'CONSTRAINED OR NOT ARR_C(4)'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 5"); + END IF; + + IF REC_COMP_U.COMP'CONSTRAINED + OR NOT REC_COMP_C.COMP'CONSTRAINED THEN + FAILED ("'CONSTRAINED ATTRIBUTE CHANGED BY ASSIGNMENT - 6"); + END IF; + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(C1,TRUE); + PROC2(C1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(U1,FALSE); + PROC2(U1); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_C(4), TRUE); + PROC2(ARR_C(5)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(ARR_U(2), FALSE); + PROC2(ARR_U(3)); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_C.COMP, TRUE); + PROC2(REC_COMP_C.COMP); + + COMMENT("CALLING PROC1 DIRECTLY"); + PROC1(REC_COMP_U.COMP, FALSE); + PROC2(REC_COMP_U.COMP); + + RESULT; + END C37405A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37411a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37411a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c37411a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c37411a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C37411A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATIONS OF ASSIGNMENT, COMPARISON, MEMBERSHIP + -- TESTS, QUALIFICATION, TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS, + -- ARE DEFINED FOR NULL RECORDS. + + -- HISTORY: + -- DHH 03/04/88 CREATED ORIGINAL TEST. + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C37411A IS + TYPE S IS + RECORD + NULL; + END RECORD; + + SUBTYPE SS IS S; + + U,V,W : S; + X : SS; + + BEGIN + + TEST("C37411A", "CHECK THAT THE OPERATIONS OF ASSIGNMENT, " & + "COMPARISON, MEMBERSHIP TESTS, QUALIFICATION, " & + "TYPE CONVERSION, 'BASE, 'SIZE AND 'ADDRESS, " & + "ARE DEFINED FOR NULL RECORDS"); + U := W; + IF U /= W THEN + FAILED("EQUALITY/ASSIGNMENT DOES NOT PERFORM CORRECTLY"); + END IF; + + IF V NOT IN S THEN + FAILED("MEMBERSHIP DOES NOT PERFORM CORRECTLY"); + END IF; + + IF X /= SS(V) THEN + FAILED("TYPE CONVERSION DOES NOT PERFORM CORRECTLY"); + END IF; + + IF S'(U) /= S'(W) THEN + FAILED("QUALIFIED EXPRESSION DOES NOT PERFORM CORRECTLY"); + END IF; + + IF X'SIZE /= V'SIZE THEN + FAILED("'BASE'SIZE DOES NOT PERFORM CORRECTLY WHEN PREFIX " & + "IS AN OBJECT"); + END IF; + + IF X'ADDRESS = V'ADDRESS THEN + COMMENT("NULL RECORDS HAVE THE SAME ADDRESS"); + ELSE + COMMENT("NULL RECORDS DO NOT HAVE THE SAME ADDRESS"); + END IF; + + RESULT; + END C37411A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C380001.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that checks are made properly when a per-object expression contains + -- an attribute whose prefix denotes the current instance of the type. + -- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, + -- RM95 3.8(18/1)). + -- + -- CHANGE HISTORY: + -- 9 FEB 2001 PHL Initial version. + -- 29 JUN 2002 RLB Readied for release. + -- + --! + with Ada.Exceptions; + use Ada.Exceptions; + with Report; + use Report; + procedure C380001 is + + type Negative is range Integer'First .. -1; + + type R1 is + record + C : Negative := Negative (Ident_Int (R1'Size)); + end record; + + + type R2; + + type R3 (D1 : access R2; D2 : Natural) is limited null record; + + type R2 is limited + record + C : R3 (R2'Access, Ident_Int (-1)); + end record; + + begin + Test ("C380001", "Check that checks are made properly when a " & + "per-object expression contains an attribute whose " & + "prefix denotes the current instance of the type"); + begin + declare + X : R1; + begin + Failed + ("No exception raised when evaluating a per-object expression " & + "containing an attribute - 1"); + end; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 1"); + end; + + declare + type A is access R1; + X : A; + begin + X := new R1; + Failed ("No exception raised when evaluating a per-object expression " & + "containing an attribute - 2"); + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 2"); + end; + + begin + declare + X : R2; + begin + Failed + ("No exception raised when elaborating a per-object constraint " & + "containing an attribute - 3"); + end; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 3"); + end; + + declare + type A is access R2; + X : A; + begin + X := new R2; + Failed + ("No exception raised when evaluating a per-object constraint " & + "containing an attribute - 4"); + exception + when Constraint_Error => + null; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E) & " - 4"); + end; + + Result; + end C380001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C380002.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an expression in a per-object discriminant constraint which is + -- part of a named association is evaluated once for each association. + -- (Defect Report 8652/0002, as reflected in Technical Corrigendum 1, + -- RM95 3.8(18.1/1)). + -- + -- CHANGE HISTORY: + -- 9 FEB 2001 PHL Initial version. + -- 29 JUN 2002 RLB Readied for release. + -- + --! + with Ada.Exceptions; + use Ada.Exceptions; + with Report; + use Report; + procedure C380002 is + + F_Val : Integer := Ident_Int (0); + + function F return Integer is + begin + F_Val := F_Val + Ident_Int (1); + return F_Val; + end F; + + type R1; + + type R2 (D0 : Integer; D1 : access R1; D2 : Integer; D3 : Integer) is + limited null record; + + type R1 is limited + record + C : R2 (D1 => R1'Access, D0 | D2 | D3 => F); + end record; + + begin + Test ("C380002", "Check that an expression in a per-object discriminant " & + "constraint which is part of a named association is " & + "evaluated once for each association"); + + if not Equal (F_Val, 3) then + Failed ("Expression not evaluated the proper number of times"); + end if; + + Result; + end C380002; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,223 ---- + -- C380003.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that per-object expressions are evaluated as specified for + -- protected components. (Defect Report 8652/0002, as reflected in + -- Technical Corrigendum 1, RM95 3.6(22/1) and 3.8(18/1)). + -- + -- CHANGE HISTORY: + -- 9 FEB 2001 PHL Initial version. + -- 29 JUN 2002 RLB Readied for release. + -- + --! + with Report; + use Report; + procedure C380003 is + + subtype Sm is Integer range 1 .. 10; + + type Rec (D1, D2 : Sm) is + record + null; + end record; + + begin + Test ("C380003", + "Check compatibility of discriminant expressions" & + " when the constraint depends on discriminants, " & + "and the discriminants have defaults - protected components"); + + declare + protected type Cons (D3 : Integer := Ident_Int (11)) is + function C1_D1 return Integer; + function C1_D2 return Integer; + private + C1 : Rec (D3, 1); + end Cons; + protected body Cons is + function C1_D1 return Integer is + begin + return C1.D1; + end C1_D1; + function C1_D2 return Integer is + begin + return C1.D2; + end C1_D2; + end Cons; + + function Is_Ok + (C : Cons; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) + return Boolean is + begin + return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; + end Is_Ok; + + begin + begin + declare + X : Cons; + begin + Failed ("Discriminant check not performed - 1"); + if not Is_Ok (X, 1, 1, 1) then + Comment ("Shouldn't get here"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception - 1"); + end; + + begin + declare + type Acc_Cons is access Cons; + X : Acc_Cons; + begin + X := new Cons; + Failed ("Discriminant check not performed - 2"); + begin + if not Is_Ok (X.all, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 2"); + end; + exception + when others => + Failed ("Constraint checked too soon - 2"); + end; + + begin + declare + subtype Scons is Cons; + begin + declare + X : Scons; + begin + Failed ("Discriminant check not performed - 3"); + if not Is_Ok (X, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 3"); + end; + exception + when others => + Failed ("Constraint checked too soon - 3"); + end; + + begin + declare + type Arr is array (1 .. 5) of Cons; + begin + declare + X : Arr; + begin + Failed ("Discriminant check not performed - 4"); + for I in Arr'Range loop + if not Is_Ok (X (I), 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end loop; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 4"); + end; + exception + when others => + Failed ("Constraint checked too soon - 4"); + end; + + begin + declare + type Nrec is + record + C1 : Cons; + end record; + begin + declare + X : Nrec; + begin + Failed ("Discriminant check not performed - 5"); + if not Is_Ok (X.C1, 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 5"); + end; + exception + when others => + Failed ("Constraint checked too soon - 5"); + end; + + begin + declare + type Drec is new Cons; + begin + declare + X : Drec; + begin + Failed ("Discriminant check not performed - 6"); + if not Is_Ok (Cons (X), 1, 1, 1) then + Comment ("Irrelevant"); + end if; + end; + exception + when Constraint_Error => + null; + when others => + Failed ("Unexpected exception raised - 6"); + end; + exception + when others => + Failed ("Constraint checked too soon - 6"); + end; + + end; + + Result; + + exception + when others => + Failed ("Constraint check done too early"); + Result; + end C380003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c380004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c380004.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,385 ---- + -- C380004.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that per-object expressions are evaluated as specified for entry + -- families and protected components. (Defect Report 8652/0002, + -- as reflected in Technical Corrigendum 1, RM95 3.6(22/1), 3.8(18/1), and + -- 9.5.2(22/1)). + -- + -- CHANGE HISTORY: + -- 9 FEB 2001 PHL Initial version. + -- 29 JUN 2002 RLB Readied for release. + -- + --! + with Report; + use Report; + procedure C380004 is + + type Rec (D1, D2 : Positive) is + record + null; + end record; + + F1_Poe : Integer; + + function Chk (Poe : Integer; Value : Integer; Message : String) + return Boolean is + begin + if Poe /= Value then + Failed (Message & ": Poe is " & Integer'Image (Poe)); + end if; + return True; + end Chk; + + function F1 return Integer is + begin + F1_Poe := F1_Poe - Ident_Int (1); + return F1_Poe; + end F1; + + generic + type T is limited private; + with function Is_Ok (X : T; + Param1 : Integer; + Param2 : Integer; + Param3 : Integer) return Boolean; + procedure Check; + + procedure Check is + begin + + declare + type Poe is new T; + Chk1 : Boolean := Chk (F1_Poe, 17, "F1 evaluated"); + X : Poe; -- F1 evaluated + Y : Poe; -- F1 evaluated + Chk2 : Boolean := Chk (F1_Poe, 15, "F1 not evaluated"); + begin + if not Is_Ok (T (X), 16, 16, 17) or + not Is_Ok (T (Y), 15, 15, 17) then + Failed ("Discriminant values not correct - 0"); + end if; + end; + + declare + type Poe is new T; + begin + begin + declare + X : Poe; + begin + if not Is_Ok (T (X), 14, 14, 17) then + Failed ("Discriminant values not correct - 1"); + end if; + end; + exception + when others => + Failed ("Unexpected exception - 1"); + end; + + declare + type Acc_Poe is access Poe; + X : Acc_Poe; + begin + X := new Poe; + begin + if not Is_Ok (T (X.all), 13, 13, 17) then + Failed ("Discriminant values not correct - 2"); + end if; + end; + exception + when others => + Failed ("Unexpected exception raised - 2"); + end; + + declare + subtype Spoe is Poe; + X : Spoe; + begin + if not Is_Ok (T (X), 12, 12, 17) then + Failed ("Discriminant values not correct - 3"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 3"); + end; + + declare + type Arr is array (1 .. 2) of Poe; + X : Arr; + begin + if Is_Ok (T (X (1)), 11, 11, 17) and then + Is_Ok (T (X (2)), 10, 10, 17) then + null; + elsif Is_Ok (T (X (2)), 11, 11, 17) and then + Is_Ok (T (X (1)), 10, 10, 17) then + null; + else + Failed ("Discriminant values not correct - 4"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 4"); + end; + + declare + type Nrec is + record + C1, C2 : Poe; + end record; + X : Nrec; + begin + if Is_Ok (T (X.C1), 8, 8, 17) and then + Is_Ok (T (X.C2), 9, 9, 17) then + null; + elsif Is_Ok (T (X.C2), 8, 8, 17) and then + Is_Ok (T (X.C1), 9, 9, 17) then + null; + else + Failed ("Discriminant values not correct - 5"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 5"); + end; + + declare + type Drec is new Poe; + X : Drec; + begin + if not Is_Ok (T (X), 7, 7, 17) then + Failed ("Discriminant values not correct - 6"); + end if; + exception + when others => + Failed ("Unexpected exception raised - 6"); + end; + end; + end Check; + + + begin + Test ("C380004", + "Check evaluation of discriminant expressions " & + "when the constraint depends on a discriminant, " & + "and the discriminants have defaults - discriminant-dependent" & + "entry families and protected components"); + + + Comment ("Discriminant-dependent entry families for task types"); + + F1_Poe := 18; + + declare + task type Poe (D3 : Positive := F1) is + entry E (D3 .. F1); -- F1 evaluated + entry Is_Ok (D3 : Integer; + E_First : Integer; + E_Last : Integer; + Ok : out Boolean); + end Poe; + task body Poe is + begin + loop + select + accept Is_Ok (D3 : Integer; + E_First : Integer; + E_Last : Integer; + Ok : out Boolean) do + declare + Cnt : Natural; + begin + if Poe.D3 = D3 then + -- Can't think of a better way to check the + -- bounds of the entry family. + begin + Cnt := E (E_First)'Count; + Cnt := E (E_Last)'Count; + exception + when Constraint_Error => + Ok := False; + return; + end; + begin + Cnt := E (E_First - 1)'Count; + Ok := False; + return; + exception + when Constraint_Error => + null; + when others => + Ok := False; + return; + end; + begin + Cnt := E (E_Last + 1)'Count; + Ok := False; + return; + exception + when Constraint_Error => + null; + when others => + Ok := False; + return; + end; + Ok := True; + else + Ok := False; + return; + end if; + end; + end Is_Ok; + or + terminate; + end select; + end loop; + end Poe; + + function Is_Ok + (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + Ok : Boolean; + begin + C.Is_Ok (D3, E_First, E_Last, Ok); + return Ok; + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + + Comment ("Discriminant-dependent entry families for protected types"); + + F1_Poe := 18; + + declare + protected type Poe (D3 : Integer := F1) is + entry E (D3 .. F1); -- F1 evaluated + function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean; + end Poe; + protected body Poe is + entry E (for I in D3 .. F1) when True is + begin + null; + end E; + function Is_Ok (D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + Cnt : Natural; + begin + if Poe.D3 = D3 then + -- Can't think of a better way to check the + -- bounds of the entry family. + begin + Cnt := E (E_First)'Count; + Cnt := E (E_Last)'Count; + exception + when Constraint_Error => + return False; + end; + begin + Cnt := E (E_First - 1)'Count; + return False; + exception + when Constraint_Error => + null; + when others => + return False; + end; + begin + Cnt := E (E_Last + 1)'Count; + return False; + exception + when Constraint_Error => + null; + when others => + return False; + end; + return True; + else + return False; + end if; + end Is_Ok; + end Poe; + + function Is_Ok + (C : Poe; D3 : Integer; E_First : Integer; E_Last : Integer) + return Boolean is + begin + return C.Is_Ok (D3, E_First, E_Last); + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + Comment ("Protected components"); + + F1_Poe := 18; + + declare + protected type Poe (D3 : Integer := F1) is + function C1_D1 return Integer; + function C1_D2 return Integer; + private + C1 : Rec (D3, F1); -- F1 evaluated + end Poe; + protected body Poe is + function C1_D1 return Integer is + begin + return C1.D1; + end C1_D1; + function C1_D2 return Integer is + begin + return C1.D2; + end C1_D2; + end Poe; + + function Is_Ok (C : Poe; D3 : Integer; C1_D1 : Integer; C1_D2 : Integer) + return Boolean is + begin + return C.D3 = D3 and C.C1_D1 = C1_D1 and C.C1_D2 = C1_D2; + end Is_Ok; + + procedure Chk is new Check (Poe, Is_Ok); + + begin + Chk; + end; + + Result; + + exception + when others => + Failed ("Unexpected exception"); + Result; + + end C380004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38002a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,420 ---- + -- C38002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT + -- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION + -- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT. + -- + -- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN + -- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT + -- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT + -- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION, + -- DERIVED TYPE DEFINITION, PRIVATE TYPE. + -- + -- CHECK FOR UNCONSTRAINED GENERIC FORMAL TYPE. + + -- HISTORY: + -- AH 09/02/86 CREATED ORIGINAL TEST. + -- DHH 08/16/88 REVISED HEADER AND ENTERED COMMENTS FOR PRIVATE TYPE + -- AND CORRECTED INDENTATION. + -- BCB 04/12/90 ADDED CHECKS FOR AN ARRAY AS A SUBPROGRAM RETURN + -- TYPE AND AN ARRAY AS A FORMAL PARAMETER. + -- LDC 10/01/90 ADDED CODE SO F, FPROC, G, GPROC AREN'T OPTIMIZED + -- AWAY + + WITH REPORT; USE REPORT; + PROCEDURE C38002A IS + + BEGIN + TEST ("C38002A", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " & + "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " & + "ARRAY OR RECORD TYPES"); + + DECLARE + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE ARR_NAME IS ACCESS ARR; + SUBTYPE ARR_NAME_3 IS ARR_NAME(1..3); + + TYPE REC(DISC : INTEGER) IS + RECORD + COMP : ARR_NAME(1..DISC); + END RECORD; + TYPE REC_NAME IS ACCESS REC; + + OBJ : REC_NAME(C3); + + TYPE ARR2 IS ARRAY (1..10) OF REC_NAME(C3); + + TYPE REC2 IS + RECORD + COMP2 : REC_NAME(C3); + END RECORD; + + TYPE NAME_REC_NAME IS ACCESS REC_NAME(C3); + + TYPE DERIV IS NEW REC_NAME(C3); + SUBTYPE REC_NAME_3 IS REC_NAME(C3); + + FUNCTION F (PARM : REC_NAME_3) RETURN REC_NAME_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END; + + PROCEDURE FPROC (PARM : REC_NAME_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END FPROC; + + FUNCTION G (PA : ARR_NAME_3) RETURN ARR_NAME_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE G AWAY"); + END IF; + RETURN PA; + END G; + + PROCEDURE GPROC (PA : ARR_NAME_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE GPROC AWAY"); + END IF; + END GPROC; + + BEGIN + DECLARE + R : REC_NAME; + BEGIN + R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5)); + R := F(R); + R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5)); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR RECORD"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - RECORD,FUNCTION"); + END IF; + END; + + DECLARE + R : REC_NAME; + BEGIN + R := NEW REC'(DISC => 3, COMP => NEW ARR'(1..3 => 5)); + FPROC(R); + R := NEW REC'(DISC => 4, COMP => NEW ARR'(1..4 => 5)); + FPROC(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR RECORD"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - RECORD,PROCEDURE"); + END IF; + END; + + DECLARE + A : ARR_NAME; + BEGIN + A := NEW ARR'(1..3 => 5); + A := G(A); + A := NEW ARR'(1..4 => 6); + A := G(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR ARRAY"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - ARRAY,FUNCTION"); + END IF; + END; + + DECLARE + A : ARR_NAME; + BEGIN + A := NEW ARR'(1..3 => 5); + GPROC(A); + A := NEW ARR'(1..4 => 6); + GPROC(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR ARRAY"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT OF " & + "ACCESS VALUE - ARRAY,PROCEDURE"); + END IF; + END; + END; + + DECLARE + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE REC (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE P_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE P_ARR_NAME IS ACCESS P_ARR; + + TYPE P_REC_NAME IS ACCESS REC; + + GENERIC + TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + PACKAGE P IS + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS UNCON_ARR; + TYPE ACC_P_ARR IS ACCESS P_ARR; + SUBTYPE ACC_P_ARR_3 IS ACC_P_ARR(1..3); + OBJ : ACC_REC(C3); + + TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3); + + TYPE REC1 IS + RECORD + COMP1 : ACC_REC(C3); + END RECORD; + + TYPE REC2 IS + RECORD + COMP2 : ACC_ARR(1..C3); + END RECORD; + + SUBTYPE ACC_REC_3 IS ACC_REC(C3); + + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3; + + PROCEDURE FPROC (PARM : ACC_REC_3); + + FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3; + + PROCEDURE GPROC (PA : ACC_P_ARR_3); + + TYPE ACC1 IS PRIVATE; + TYPE ACC2 IS PRIVATE; + TYPE DER1 IS PRIVATE; + TYPE DER2 IS PRIVATE; + + PRIVATE + + TYPE ACC1 IS ACCESS ACC_REC(C3); + TYPE ACC2 IS ACCESS ACC_ARR(1..C3); + TYPE DER1 IS NEW ACC_REC(C3); + TYPE DER2 IS NEW ACC_ARR(1..C3); + END P; + + PACKAGE BODY P IS + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END; + + PROCEDURE FPROC (PARM : ACC_REC_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END FPROC; + + FUNCTION G (PA : ACC_P_ARR_3) RETURN ACC_P_ARR_3 IS + BEGIN + IF NOT EQUAL(IDENT_INT(5), 3 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE G AWAY"); + END IF; + RETURN PA; + END; + + PROCEDURE GPROC (PA : ACC_P_ARR_3) IS + BEGIN + IF NOT EQUAL(IDENT_INT(6), 4 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE GPROC AWAY"); + END IF; + END GPROC; + END P; + + PACKAGE NP IS NEW P (UNCON_ARR => P_ARR); + + USE NP; + + BEGIN + DECLARE + R : ACC_REC; + BEGIN + R := NEW REC(DISC => 3); + R := F(R); + R := NEW REC(DISC => 4); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR A RECORD -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - RECORD," & + "FUNCTION -GENERIC"); + END IF; + END; + + DECLARE + R : ACC_REC; + BEGIN + R := NEW REC(DISC => 3); + FPROC(R); + R := NEW REC(DISC => 4); + FPROC(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR A RECORD -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - RECORD," & + "PROCEDURE -GENERIC"); + END IF; + END; + + DECLARE + A : ACC_P_ARR; + BEGIN + A := NEW P_ARR'(1..3 => 5); + A := G(A); + A := NEW P_ARR'(1..4 => 6); + A := G(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY FUNCTION FOR AN ARRAY -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - ARRAY," & + "FUNCTION -GENERIC"); + END IF; + END; + + DECLARE + A : ACC_P_ARR; + BEGIN + A := NEW P_ARR'(1..3 => 5); + GPROC(A); + A := NEW P_ARR'(1..4 => 6); + GPROC(A); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE FOR AN ARRAY -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF A = NULL OR ELSE A(4) /= 6 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - ARRAY," & + "PROCEDURE -GENERIC"); + END IF; + END; + END; + + DECLARE + TYPE CON_INT IS RANGE 1..10; + + GENERIC + TYPE UNCON_INT IS RANGE <>; + PACKAGE P2 IS + SUBTYPE NEW_INT IS UNCON_INT RANGE 1..5; + FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT; + + PROCEDURE PROC_INT (PARM : NEW_INT); + END P2; + + PACKAGE BODY P2 IS + FUNCTION FUNC_INT (PARM : NEW_INT) RETURN NEW_INT IS + BEGIN + IF NOT EQUAL(IDENT_INT(3), 1 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE F AWAY"); + END IF; + RETURN PARM; + END FUNC_INT; + + PROCEDURE PROC_INT (PARM : NEW_INT) IS + BEGIN + IF NOT EQUAL(IDENT_INT(4), 2 + IDENT_INT(2)) THEN + COMMENT("DON'T OPTIMIZE FPROC AWAY"); + END IF; + END PROC_INT; + END P2; + + PACKAGE NP2 IS NEW P2 (UNCON_INT => CON_INT); + + USE NP2; + + BEGIN + DECLARE + R : CON_INT; + BEGIN + R := 2; + R := FUNC_INT(R); + R := 8; + R := FUNC_INT(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON VALUE " & + "ACCEPTED BY FUNCTION -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= 8 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF VALUE -FUNCTION, GENERIC"); + END IF; + END; + + DECLARE + R : CON_INT; + BEGIN + R := 2; + PROC_INT(R); + R := 9; + PROC_INT(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE " & + "ACCEPTED BY PROCEDURE -GENERIC"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= 9 THEN + FAILED ("ERROR IN EVALUATION/ASSIGNMENT " & + "OF ACCESS VALUE - PROCEDURE, " & + "GENERIC"); + END IF; + END; + END; + + RESULT; + END C38002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38002b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C38002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN UNCONSTRAINED ARRAY TYPE OR A RECORD WITHOUT + -- DEFAULT DISCRIMINANTS CAN BE USED IN AN ACCESS_TYPE_DEFINITION + -- WITHOUT AN INDEX OR DISCRIMINANT CONSTRAINT. + -- + -- CHECK THAT (NON-STATIC) INDEX OR DISCRIMINANT CONSTRAINTS CAN + -- SUBSEQUENTLY BE IMPOSED WHEN THE TYPE IS USED IN AN OBJECT + -- DECLARATION, ARRAY COMPONENT DECLARATION, RECORD COMPONENT + -- DECLARATION, ACCESS TYPE DECLARATION, PARAMETER DECLARATION, + -- ALLOCATOR, DERIVED TYPE DEFINITION, PRIVATE TYPE, OR AS THE + -- RETURN TYPE IN A FUNCTION DECLARATION. + -- + -- CHECK FOR GENERIC FORMAL ACCESS TYPES. + + -- HISTORY: + -- AH 09/02/86 CREATED ORIGINAL TEST. + -- DHH 08/22/88 REVISED HEADER, ADDED 'PRIVATE TYPE' TO COMMENTS + -- AND CORRECTED INDENTATION. + + WITH REPORT; USE REPORT; + PROCEDURE C38002B IS + + C3 : CONSTANT INTEGER := IDENT_INT(3); + + TYPE UNCON_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE REC (DISC : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE P_ARR_NAME IS ACCESS UNCON_ARR; + TYPE P_REC_NAME IS ACCESS REC; + + GENERIC + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS UNCON_ARR; + PACKAGE P IS + OBJ : ACC_REC(C3); + + TYPE ARR2 IS ARRAY (1..10) OF ACC_REC(C3); + + TYPE REC1 IS + RECORD + COMP1 : ACC_REC(C3); + END RECORD; + + TYPE REC2 IS + RECORD + COMP2 : ACC_ARR(1..C3); + END RECORD; + + SUBTYPE ACC_REC_3 IS ACC_REC(C3); + R : ACC_REC; + + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3; + + TYPE ACC1 IS PRIVATE; + TYPE ACC2 IS PRIVATE; + TYPE DER1 IS PRIVATE; + TYPE DER2 IS PRIVATE; + + PRIVATE + + TYPE ACC1 IS ACCESS ACC_REC(C3); + TYPE ACC2 IS ACCESS ACC_ARR(1..C3); + TYPE DER1 IS NEW ACC_REC(C3); + TYPE DER2 IS NEW ACC_ARR(1..C3); + END P; + + PACKAGE BODY P IS + FUNCTION F (PARM : ACC_REC_3) RETURN ACC_REC_3 IS + BEGIN + RETURN PARM; + END; + END P; + + PACKAGE NP IS NEW P (ACC_REC => P_REC_NAME, ACC_ARR => P_ARR_NAME); + + USE NP; + BEGIN + TEST ("C38002B", "NON-STATIC CONSTRAINTS CAN BE IMPOSED " & + "ON ACCESS TYPES ACCESSING PREVIOUSLY UNCONSTRAINED " & + "ARRAY OR RECORD TYPES"); + + R := NEW REC(DISC => 3); + R := F(R); + R := NEW REC(DISC => 4); + R := F(R); + FAILED ("INCOMPATIBLE CONSTRAINT ON ACCESS VALUE ACCEPTED " & + "BY GENERIC FUNCTION"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R = NULL OR ELSE R.DISC /= 4 THEN + FAILED (" ERROR IN EVALUATION/ASSIGNMENT OF " & + "GENERIC ACCESS VALUE"); + END IF; + + RESULT; + END C38002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C38005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL (UNINITIALIZED) ACCESS OBJECTS ARE INITIALIZED + -- TO NULL BY DEFAULT. VARIABLES, ARRAYS, RECORDS, ARRAYS OF RECORDS, + -- ARRAYS OF ARRAYS, RECORDS WITH ARRAYS AND RECORD COMPONENTS + -- ARE ALL CHECKED. + -- FUNCTION RESULTS (I.E. RETURNED FROM IMPLICIT FUNCTION RETURN) + -- ARE NOT CHECKED. + + -- DAT 3/6/81 + -- VKG 1/5/83 + -- SPS 2/17/83 + + WITH REPORT; USE REPORT; + + PROCEDURE C38005A IS + + TYPE REC; + TYPE ACC_REC IS ACCESS REC; + TYPE VECTOR IS ARRAY ( NATURAL RANGE <> ) OF ACC_REC; + TYPE REC IS RECORD + VECT : VECTOR (3 .. 5); + END RECORD; + + TYPE ACC_VECT IS ACCESS VECTOR; + TYPE ARR_REC IS ARRAY (1 .. 2) OF REC; + TYPE REC2; + TYPE ACC_REC2 IS ACCESS REC2; + TYPE REC2 IS RECORD + C1 : ACC_REC; + C2 : ACC_VECT; + C3 : ARR_REC; + C4 : REC; + C5 : ACC_REC2; + END RECORD; + + N_REC : REC; + N_ACC_REC : ACC_REC; + N_VEC : VECTOR (3 .. IDENT_INT (5)); + N_ACC_VECT : ACC_VECT; + N_ARR_REC : ARR_REC; + N_REC2 : REC2; + N_ACC_REC2 : ACC_REC2; + N_ARR : ARRAY (1..2) OF VECTOR (1..2); + Q : REC2 := + (C1 => NEW REC, + C2 => NEW VECTOR'(NEW REC, NEW REC'(N_REC)), + C3 => (1 | 2 => (VECT=>(3|4=> NEW REC, + 5=>N_ACC_REC) + )), + C4 => N_REC2.C4, + C5 => NEW REC2'(N_REC2)); + + BEGIN + TEST ("C38005A", "DEFAULT VALUE FOR ACCESS OBJECTS IS NULL"); + + IF N_REC /= REC'(VECT => (3..5 => NULL)) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 1"); + END IF; + + IF N_ACC_REC /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 2"); + END IF; + + IF N_VEC /= N_REC.VECT + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 3"); + END IF; + + IF N_ARR /= ((NULL, NULL), (NULL, NULL)) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 4"); + END IF; + + IF N_ACC_VECT /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 5"); + END IF; + + IF N_ARR_REC /= (N_REC, N_REC) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 6"); + END IF; + + IF N_REC2 /= (NULL, NULL, N_ARR_REC, N_REC, NULL) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 7"); + END IF; + + IF N_ACC_REC2 /= NULL + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 8"); + END IF; + + IF Q /= (Q.C1, Q.C2, (Q.C3(1), Q.C3(2)), N_REC, Q.C5) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 9"); + END IF; + + IF Q.C1.ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 10"); + END IF; + + IF Q.C2.ALL(0).ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 11"); + END IF; + + IF Q.C2(1).VECT /= N_VEC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 12"); + END IF; + + IF Q.C3(2).VECT /= (3 => Q.C3(2).VECT(3), + 4 => Q.C3(2).VECT(4), + 5=>NULL) + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 13"); + END IF; + + IF Q.C3(2).VECT(3).ALL /= N_REC + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 14"); + END IF; + + IF Q.C5.ALL /= N_REC2 + THEN + FAILED ("INCORRECT ACCESS TYPE INITIALIZATION - 15"); + END IF; + + DECLARE + PROCEDURE T (R : OUT REC2) IS + BEGIN + NULL; + END T; + BEGIN + N_REC2 := Q; + T(Q); + IF Q /= N_REC2 THEN + FAILED ("INCORRECT OUT PARM INIT 2"); + END IF; + END; + + RESULT; + END C38005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C38005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ANY OBJECT WITH A FORMAL PRIVATE TYPE, WHOSE ACTUAL + -- TYPE IN AN INSTANTIATION IS AN ACCESS TYPE, IS INITIALIZED BY + -- DEFAULT TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH ARE ARRAY + -- AND RECORD COMPONENTS. + + -- HISTORY: + -- DHH 07/12/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C38005B IS + + BEGIN + TEST("C38005B", "CHECK THAT ANY OBJECT WITH A FORMAL PRIVATE " & + "TYPE, WHOSE ACTUAL TYPE IN AN INSTANTIATION " & + "IS AN ACCESS TYPE, IS INITIALIZED BY DEFAULT " & + "TO THE VALUE NULL. THIS INCLUDES OBJECTS WHICH " & + "ARE ARRAY AND RECORD COMPONENTS"); + DECLARE + TYPE ARRY IS ARRAY(1 .. 10) OF BOOLEAN; + TYPE REC1 IS + RECORD + A : INTEGER; + B : ARRY; + END RECORD; + + TYPE POINTER IS ACCESS REC1; + + GENERIC + TYPE NEW_PTR IS PRIVATE; + PACKAGE GEN_PACK IS + TYPE PTR_ARY IS ARRAY(1 .. 5) OF NEW_PTR; + TYPE RECORD1 IS + RECORD + A : NEW_PTR; + B : PTR_ARY; + END RECORD; + + OBJ : NEW_PTR; + ARY : PTR_ARY; + REC : RECORD1; + END GEN_PACK; + + PACKAGE TEST_P IS NEW GEN_PACK(POINTER); + USE TEST_P; + + BEGIN + IF OBJ /= NULL THEN + FAILED("OBJECT NOT INITIALIZED TO NULL"); + END IF; + + FOR I IN 1 .. 5 LOOP + IF ARY(I) /= NULL THEN + FAILED("ARRAY COMPONENT " & + INTEGER'IMAGE(I) & + " NOT INITIALIZED TO NULL"); + END IF; + END LOOP; + + IF REC.A /= NULL THEN + FAILED("RECORD OBJECT NOT INITIALIZED TO NULL"); + END IF; + + FOR I IN 1 .. 5 LOOP + IF REC.B(I) /= NULL THEN + FAILED("RECORD SUBCOMPONENT " & + INTEGER'IMAGE(I) & + " NOT INITIALIZED TO NULL"); + END IF; + END LOOP; + END; + + RESULT; + END C38005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38005c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C38005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ALL OBJECTS OF FORMAL ACCESS TYPE, INCLUDING ARRAY AND + -- RECORD COMPONENTS, ARE INITIALIZED BY DEFAULT WITH THE VALUE + -- NULL. + + -- HISTORY: + -- DHH 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C38005C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE ACC_I IS ACCESS INT; + + SUBTYPE NEW_NODE IS CHARACTER; + + TYPE ACC_CHAR IS ACCESS NEW_NODE; + + X : ACC_I := NEW INT'(IDENT_INT(5)); + Y : NEW_NODE := 'A'; + Z : ACC_CHAR := NEW NEW_NODE'(Y); + + GENERIC + TYPE ACC_INT IS ACCESS INT; + TYPE NODE IS PRIVATE; + TYPE LINK IS ACCESS NODE; + PROCEDURE P(U : ACC_INT; V : NODE; W : LINK); + + GENERIC + TYPE ACC_INT IS ACCESS INT; + TYPE NODE IS PRIVATE; + TYPE LINK IS ACCESS NODE; + PACKAGE PACK IS + + SUBTYPE NEW_ACC IS ACC_INT; + + SUBTYPE NEW_L IS LINK; + + TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT; + + TYPE REC IS + RECORD + I : ACC_INT; + L : LINK; + END RECORD; + + END PACK; + + PACKAGE NEW_PACK IS NEW PACK(ACC_I, NEW_NODE, ACC_CHAR); + USE NEW_PACK; + + A : NEW_PACK.NEW_ACC; + B : NEW_PACK.NEW_L; + C : NEW_PACK.ARR; + D : NEW_PACK.REC; + + PROCEDURE P(U : ACC_INT; V : NODE; W : LINK) IS + + TYPE ARR IS ARRAY(1 .. 4) OF ACC_INT; + + TYPE REC IS + RECORD + I : ACC_INT; + L : LINK; + END RECORD; + + A : ACC_INT; + B : LINK; + C : ARR; + D : REC; + + BEGIN + IF A /= NULL THEN + FAILED("OBJECT A NOT INITIALIZED - PROC"); + END IF; + + IF B /= NULL THEN + FAILED("OBJECT B NOT INITIALIZED - PROC"); + END IF; + + FOR I IN 1 .. 4 LOOP + IF C(I) /= NULL THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "NOT INITIALIZED - PROC"); + END IF; + END LOOP; + + IF D.I /= NULL THEN + FAILED("RECORD.I NOT INITIALIZED - PROC"); + END IF; + + IF D.L /= NULL THEN + FAILED("RECORD.L NOT INITIALIZED - PROC"); + END IF; + + END P; + + PROCEDURE PROC IS NEW P(ACC_I, NEW_NODE, ACC_CHAR); + + BEGIN + TEST("C38005C", "CHECK THAT ALL OBJECTS OF FORMAL ACCESS TYPE, " & + "INCLUDING ARRAY AND RECORD COMPONENTS, ARE " & + "INITIALIZED BY DEFAULT WITH THE VALUE NULL"); + + PROC(X, Y, Z); + + IF A /= NULL THEN + FAILED("OBJECT A NOT INITIALIZED - PACK"); + END IF; + + IF B /= NULL THEN + FAILED("OBJECT B NOT INITIALIZED - PACK"); + END IF; + + FOR I IN 1 .. 4 LOOP + IF C(I) /= NULL THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "NOT INITIALIZED - PACK"); + END IF; + END LOOP; + + IF D.I /= NULL THEN + FAILED("RECORD.I NOT INITIALIZED - PACK"); + END IF; + + IF D.L /= NULL THEN + FAILED("RECORD.L NOT INITIALIZED - PACK"); + END IF; + + RESULT; + END C38005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38006a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- C38006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OBJECTS ACCESSED BY CONSTANTS CAN BE MODIFIED. + + -- DAT 3/6/81 + -- SPS 10/25/82 + + WITH REPORT; USE REPORT; + + PROCEDURE C38006A IS + + TYPE AI IS ACCESS INTEGER; + + C : CONSTANT AI := NEW INTEGER'(1); + + BEGIN + TEST ("C38006A", "OBJECTS ACCESSED BY CONSTANTS MAY BE ASSIGNED"); + + FOR I IN 1 .. 10 LOOP + IF C.ALL /= I AND I > 1 THEN + FAILED ("OBJECT ACCESSED THRU CONSTANT NOT CHANGED"); + EXIT; + END IF; + C.ALL := C.ALL + 1; + END LOOP; + + RESULT; + END C38006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C38102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE DECLARATION CAN BE GIVEN FOR ANY TYPE. + -- FULL DECLARATIONS FOR INTEGER, ENUMERATION, CONSTRAINED AND + -- UNCONSTRAINED ARRAYS, RECORDS WITHOUT DISCRIMINANTS, + -- AN ACCESS TYPE, OR TYPES DERIVED FROM ANY OF THE ABOVE. + + -- (FLOAT, FIXED, TASKS AND RECORDS WITH DISCRIMINANTS ARE CHECKED + -- IN OTHER TESTS). + + -- DAT 3/24/81 + -- SPS 10/25/82 + -- SPS 2/17/82 + + WITH REPORT; USE REPORT; + + PROCEDURE C38102A IS + BEGIN + TEST ("C38102A", "ANY TYPE MAY BE INCOMPLETE"); + + DECLARE + + TYPE X1; + TYPE X2; + TYPE X3; + TYPE X4; + TYPE X5; + TYPE X6; + TYPE X7; + TYPE X8; + + TYPE D1; + TYPE D2; + TYPE D3; + TYPE D4; + TYPE D5; + TYPE D6; + + TYPE X1 IS RANGE 1 .. 10; + TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN); + TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10); + TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3; + TYPE AR1 IS ARRAY (X2) OF X3; + TYPE X5 IS RECORD + C1 : X4 (1..3); + C2 : AR1; + END RECORD; + TYPE X6 IS ACCESS X8; + TYPE X7 IS ACCESS X6; + TYPE X8 IS ACCESS X6; + + TYPE D1 IS NEW X1; + TYPE D2 IS NEW X2; + TYPE D3 IS NEW X3; + TYPE D4 IS NEW X4; + TYPE D5 IS NEW X5; + SUBTYPE D7 IS X7; + SUBTYPE D8 IS X8; + TYPE D6 IS ACCESS D8; + + PACKAGE P IS + + TYPE X1; + TYPE X2; + TYPE X3; + TYPE X4; + TYPE X5; + TYPE X6; + TYPE X7 IS PRIVATE; + TYPE X8 IS LIMITED PRIVATE; + + TYPE D1; + TYPE D2; + TYPE D3; + TYPE D4; + TYPE D5; + TYPE D6; + + TYPE X1 IS RANGE 1 .. 10; + TYPE X2 IS (TRUE, FALSE, MAYBE, GREEN); + TYPE X3 IS ARRAY (1 .. 3) OF STRING (1..10); + TYPE X4 IS ARRAY (NATURAL RANGE <> ) OF X3; + TYPE AR1 IS ARRAY (X2) OF X3; + TYPE X5 IS RECORD + C1 : X4 (1..3); + C2 : AR1; + END RECORD; + TYPE X6 IS ACCESS X8; + + TYPE D1 IS RANGE 1 .. 10; + TYPE D2 IS NEW X2; + TYPE D3 IS NEW X3; + TYPE D4 IS NEW X4; + TYPE D5 IS NEW X5; + TYPE D6 IS NEW X6; + SUBTYPE D7 IS X7; + SUBTYPE D8 IS X8; + TYPE D9 IS ACCESS D8; + + VX7 : CONSTANT X7; + + PRIVATE + + TYPE X7 IS RECORD + C1 : X1; + C3 : X3; + C5 : X5; + C6 : X6; + C8 : D9; + END RECORD; + + V3 : X3 := (X3'RANGE => "ABCDEFGHIJ"); + TYPE A7 IS ACCESS X7; + TYPE X8 IS ARRAY (V3'RANGE) OF A7; + + VX7 : CONSTANT X7 := (3, V3, ((1..3=>V3), + (TRUE..GREEN=>V3)), NULL, + NEW D8); + END P; + USE P; + + VD7: P.D7; + + PACKAGE BODY P IS + BEGIN + VD7 := D7(VX7); + END P; + + BEGIN + IF VX7 /= P.X7(VD7) THEN + FAILED ("WRONG VALUE SOMEWHERE"); + END IF; + END; + + RESULT; + END C38102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- C38102B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INCOMPLETE TYPES CAN BE FLOAT. + + -- DAT 3/24/81 + -- SPS 10/25/82 + + WITH REPORT; USE REPORT; + + PROCEDURE C38102B IS + + BEGIN + TEST ("C38102B", "INCOMPLETE TYPE CAN BE FLOAT"); + + DECLARE + + TYPE F; + TYPE G; + TYPE AF IS ACCESS F; + TYPE F IS DIGITS 2; + TYPE G IS NEW F RANGE 1.0 .. 1.5; + TYPE AG IS ACCESS G RANGE 1.0 .. 1.3; + + XF : AF := NEW F' (2.0); + XG : AG := NEW G' (G (XF.ALL/2.0)); + + BEGIN + IF XG.ALL NOT IN G THEN + FAILED ("ACCESS TO FLOAT"); + END IF; + END; + + RESULT; + END C38102B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C38102C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INCOMPLETE TYPES CAN BE FIXED. + + -- HISTORY: + -- DAT 03/24/81 CREATED ORIGINAL TEST. + -- SPS 10/25/82 + -- BCB 10/21/87 CHANGED HEADER TO STANDARD FORMAT. CHANGED VARIOUS + -- VALUES TO CORRECT CONSTRAINT PROBLEMS. CHANGED + -- THE VALUE OF F'DELTA, USING A POWER OF TWO. + + WITH REPORT; USE REPORT; + + PROCEDURE C38102C IS + BEGIN + TEST ("C38102C", "INCOMPLETE TYPE CAN BE FIXED"); + + DECLARE + + TYPE F; + TYPE G; + TYPE AF IS ACCESS F; + TYPE F IS DELTA 0.25 RANGE -2.0 .. 2.0; + TYPE G IS NEW F RANGE -1.0 .. 1.5; + TYPE AG IS ACCESS G RANGE -0.75 .. 1.25; + + XF : AF := NEW F '(1.0); + XG : AG := NEW G '(G (XF.ALL/2)); + + BEGIN + IF XG.ALL NOT IN G THEN + FAILED ("ACCESS TO FIXED"); + END IF; + END; + + RESULT; + END C38102C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- C38102D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE REDECLARED AS A TASK TYPE. + + -- AH 8/14/86 + + WITH REPORT; USE REPORT; + PROCEDURE C38102D IS + GLOBAL : INTEGER := 0; + BEGIN + TEST("C38102D", "INCOMPLETE TYPES CAN BE TASKS"); + DECLARE + TYPE T1; + TASK TYPE T1 IS + ENTRY E(LOCAL : IN OUT INTEGER); + END T1; + T1_OBJ : T1; + TASK BODY T1 IS + BEGIN + ACCEPT E(LOCAL : IN OUT INTEGER) DO + LOCAL := IDENT_INT(2); + END E; + END T1; + BEGIN + T1_OBJ.E(GLOBAL); + END; + + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("TASK NOT EXECUTED"); + END IF; + RESULT; + END C38102D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38102e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38102e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C38102E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE REDECLARED AS A DERIVED GENERIC + -- FORMAL TYPE. + + -- AH 8/15/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + -- DNT 11/28/95 CHANGED TO FLAG1 := F4. + + WITH REPORT; USE REPORT; + PROCEDURE C38102E IS + TYPE RAINBOW IS (RED, ORANGE, YELLOW, GREEN, BLUE, INDIGO, VIOLET); + TYPE T_FLOAT IS DIGITS 5 RANGE -4.0 .. 4.0; + TYPE T_FIXED IS DELTA 0.01 RANGE 0.0 .. 1.5; + SUBTYPE P1 IS INTEGER; + TYPE P2 IS RANGE 0 .. 10; + TYPE P3 IS ARRAY (P2) OF INTEGER; + TYPE P4 IS ARRAY (P2, P2) OF INTEGER; + + F1, F2 : BOOLEAN; + + GENERIC + TYPE G1 IS (<>); + TYPE G2 IS RANGE <>; + FUNCTION G_DISCRETE RETURN BOOLEAN; + + FUNCTION G_DISCRETE RETURN BOOLEAN IS + TYPE INC1; + TYPE INC2; + TYPE F1 IS NEW G1; + TYPE INC1 IS NEW G1; + TYPE INC2 IS NEW G2; + + OBJ1_0 : INC1; + OBJ1_1 : INC1; + OBJ2_0 : INC2; + OBJ2_1 : INC2; + OBJ3 : F1; + + RESULT_VALUE1 : BOOLEAN := FALSE; + RESULT_VALUE2 : BOOLEAN := FALSE; + BEGIN + OBJ3 := F1'LAST; + OBJ3 := F1'PRED(OBJ3); + IF INC1(OBJ3) = INC1'PRED(INC1'LAST) THEN + RESULT_VALUE1 := TRUE; + END IF; + OBJ2_0 := INC2'FIRST; + OBJ2_1 := INC2'LAST; + IF (OBJ2_0 + OBJ2_1) = (INC2'SUCC(OBJ2_0) + + INC2'PRED(OBJ2_1)) THEN + RESULT_VALUE2 := TRUE; + END IF; + + RETURN (RESULT_VALUE1 AND RESULT_VALUE2); + END G_DISCRETE; + + GENERIC + TYPE G3 IS DIGITS <>; + TYPE G4 IS DELTA <>; + PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN); + + PROCEDURE REALS (FLAG1, FLAG2 : OUT BOOLEAN) IS + F1, F2, F3, F4, F5, F6, F7, F8 : BOOLEAN; + TYPE INC3; + TYPE INC4; + TYPE P1 IS NEW G3; + TYPE P2 IS NEW G4; + TYPE INC3 IS NEW G3; + TYPE INC4 IS NEW G4; + BEGIN + F4 := P1'LAST = P1(INC3'LAST) AND P1'FIRST = P1(INC3'FIRST); + + F5 := P2'FORE = INC4'FORE; + F6 := P2'AFT = INC4'AFT; + F7 := ABS(P2'LAST - P2'FIRST) = P2(ABS(INC4'LAST - + INC4'FIRST)); + F8 := INC4(P2'LAST / P2'LAST) = INC4(INC4'LAST / INC4'LAST); + + FLAG1 := F4; + FLAG2 := F5 AND F6 AND F7 AND F8; + END REALS; + + GENERIC + TYPE ITEM IS PRIVATE; + TYPE INDEX IS RANGE <>; + TYPE G5 IS ARRAY (INDEX) OF ITEM; + TYPE G6 IS ARRAY (INDEX, INDEX) OF ITEM; + PACKAGE DIMENSIONS IS + TYPE INC5; + TYPE INC6; + TYPE D1 IS NEW G5; + TYPE D2 IS NEW G6; + TYPE INC5 IS NEW G5; + TYPE INC6 IS NEW G6; + FUNCTION CHECK RETURN BOOLEAN; + END DIMENSIONS; + + PACKAGE BODY DIMENSIONS IS + FUNCTION CHECK RETURN BOOLEAN IS + A1 : INC5; + A2 : INC6; + DIM1 : D1; + DIM2 : D2; + F1, F2 : BOOLEAN; + BEGIN + F1 := A1(INDEX'FIRST)'SIZE = DIM1(INDEX'FIRST)'SIZE; + F2 := A2(INDEX'FIRST, INDEX'LAST)'SIZE = + DIM2(INDEX'FIRST, INDEX'LAST)'SIZE; + + RETURN (F1 AND F2); + END CHECK; + END DIMENSIONS; + + PROCEDURE PROC IS NEW REALS (G3 => T_FLOAT, G4 => T_FIXED); + FUNCTION DISCRETE IS NEW G_DISCRETE (G1 => RAINBOW, G2 => P2); + PACKAGE PKG IS NEW DIMENSIONS (ITEM => P1, INDEX => P2, G5 => P3, + G6 => P4); + + USE PKG; + BEGIN + TEST ("C38102E", "INCOMPLETE TYPES CAN BE DERIVED GENERIC " & + "FORMAL TYPES"); + + IF NOT DISCRETE THEN + FAILED ("INTEGER AND ENUMERATED TYPES NOT DERIVED"); + END IF; + + PROC (F1, F2); + IF (NOT F1) THEN + FAILED ("FLOAT TYPES NOT DERIVED"); + END IF; + IF (NOT F2) THEN + FAILED ("FIXED TYPES NOT DERIVED"); + END IF; + + IF NOT CHECK THEN + FAILED ("ONE AND TWO DIMENSIONAL ARRAY TYPES NOT DERIVED"); + END IF; + + RESULT; + END C38102E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38104a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C38104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INCOMPLETE TYPE WITH DISCRIMINANTS CAN BE + -- USED IN AN ACCESS TYPE DEFINITION WITH A COMPATIBLE DISCRIMINANT + -- CONSTRAINT. + + -- HISTORY: + -- PMW 09/01/88 CREATED ORIGINAL TEST BY RENAMING E38104A.ADA. + + WITH REPORT; USE REPORT; + PROCEDURE C38104A IS + + BEGIN + + TEST ("C38104A","INCOMPLETELY DECLARED TYPE CAN BE USED AS TYPE " & + "MARK IN ACCESS TYPE DEFINITION, AND CAN BE CONSTRAINED " & + "THERE OR LATER IF INCOMPLETE TYPE HAD DISCRIMINANT(S)"); + + DECLARE + TYPE T1; + TYPE T1_NAME IS ACCESS T1; + + TYPE T1 IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE T2(DISC : INTEGER := 5); + TYPE T2_NAME1 IS ACCESS T2(5); + TYPE T2_NAME2 IS ACCESS T2; + + SUBTYPE SUB_T2_NAME2 IS T2_NAME2(5); + TYPE T2_NAME2_NAME IS ACCESS T2_NAME2(5); + X : T2_NAME2(5); + + TYPE T2(DISC : INTEGER := 5) IS + RECORD + COMP : T2_NAME2(DISC); + END RECORD; + + X1N : T1_NAME; + X2A,X2B : T2; + X2N2 : T2_NAME2; + + BEGIN + IF EQUAL(3,3) THEN + X1N := NEW T1 '(COMP => 5); + END IF; + + IF X1N.COMP /= 5 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + X2A := (DISC => IDENT_INT(7), COMP => NULL); + X2N2 := NEW T2(IDENT_INT(7)); + X2N2.ALL := X2A; + + IF EQUAL(3,3) THEN + X2B := (DISC => IDENT_INT(7), COMP => X2N2); + END IF; + + IF X2B.COMP.COMP /= NULL + OR X2B.COMP.DISC /= 7 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END; + + RESULT; + + END C38104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38107a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C38107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS DECLARED IN THE + -- VISIBLE PART OF A PACKAGE OR IN A DECLARATIVE PART, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT IS + -- SPECIFIED FOR THE TYPE AND ONE OF THE DISCRIMINANT VALUES DOES + -- NOT BELONG TO THE CORRESPONDING DISCRIMINANT'S SUBTYPE. + + -- HISTORY: + -- BCB 01/21/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C38107A IS + + BEGIN + TEST ("C38107A", "FOR AN INCOMPLETE TYPE WITH DISCRIMINANTS " & + "DECLARED IN THE VISIBLE PART OF A PACKAGE OR " & + "IN A DECLARATIVE PART, CHECK THAT CONSTRAINT_" & + "ERROR IS RAISED IF A DISCRIMINANT CONSTRAINT " & + "IS SPECIFIED FOR THE TYPE AND ONE OF THE " & + "DISCRIMINANT VALUES DOES NOT BELONG TO THE " & + "CORRESPONDING DISCRIMINANT'S SUBTYPE"); + + BEGIN + DECLARE + PACKAGE P IS + SUBTYPE INT6 IS INTEGER RANGE 1 .. 6; + TYPE T_INT6 (D6 : INT6); + TYPE TEST IS ACCESS T_INT6(7); -- CONSTRAINT_ERROR. + TYPE T_INT6 (D6 : INT6) IS + RECORD + NULL; + END RECORD; + END P; + USE P; + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); + DECLARE + T : P.TEST := NEW T_INT6(7); + BEGIN + IF EQUAL(T.D6, T.D6) THEN + COMMENT ("DON'T OPTIMIZE T.D6"); + END IF; + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 1"); + END; + + BEGIN + DECLARE + SUBTYPE INT7 IS INTEGER RANGE 1 .. 7; + TYPE T_INT7 (D7 : INT7); + TYPE TEST IS ACCESS T_INT7(8); -- CONSTRAINT_ERROR. + TYPE T_INT7 (D7 : INT7) IS + RECORD + NULL; + END RECORD; + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); + DECLARE + T : TEST := NEW T_INT7(6); + BEGIN + IF EQUAL(T.D7, T.D7) THEN + COMMENT ("DON'T OPTIMIZE T.D7"); + END IF; + END; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 2"); + END; + RESULT; + END C38107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38107b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38107b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38107b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38107b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + -- C38107B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF A DISCRIMINANT CONSTRAINT IS APPLIED TO AN ACCESS TYPE WHICH + -- DESIGNATES AN INCOMPLETE TYPE WHICH WAS DECLARED IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN A DECLARATIVE + -- PART, CONSTRAINT_ERROR IS RAISED IF ONE OF THE + -- DISCRIMINANT'S VALUES DOES NOT BELONG TO THE CORRESPONDING + -- DISCRIMINANT'S SUBTYPE. + + -- HISTORY: + -- DHH 08/05/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C38107B IS + + BEGIN + TEST("C38107B", "IF A DISCRIMINANT CONSTRAINT IS APPLIED TO AN " & + "ACCESS TYPE WHICH DESIGNATES AN INCOMPLETE " & + "TYPE WHICH WAS DECLARED IN THE VISIBLE OR " & + "PRIVATE PART OF A PACKAGE SPECIFICATION, OR IN " & + "A DECLARATIVE PART, CONSTRAINT_ERROR IS " & + "RAISED IF ONE OF THE DISCRIMINANT'S VALUES " & + "DOES NOT BELONG TO THE CORRESPONDING " & + "DISCRIMINANT'S SUBTYPE"); + + ------------------------------ VISIBLE ------------------------------ + BEGIN + DECLARE + PACKAGE PACK IS + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := A; + END RECORD; + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - VISIBLE"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(6) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED LATE " & + "- VISIBLE"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "LATE - VISIBLE"); + END PACK; + BEGIN + NULL; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- VISIBLE"); + END; + + ------------------------------ PRIVATE ------------------------------ + BEGIN + DECLARE + PACKAGE PACK2 IS + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE PRIV IS PRIVATE; + + PRIVATE + TYPE PRIV IS + RECORD + V : INTEGER; + END RECORD; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(0)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := A; + U : PRIV := (V => A ** IDENT_INT(2)); + END RECORD; + + END PACK2; + + PACKAGE BODY PACK2 IS + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - PRIVATE"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(0)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(0) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED TOO LATE " & + "- PRIVATE"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED LATE" & + "- PRIVATE"); + END PACK2; + BEGIN + NULL; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- PRIVATE"); + END; + + -------------------------- DECLARATIVE PART -------------------------- + BEGIN + DECLARE + SUBTYPE SMALLER IS INTEGER RANGE 1 .. 5; + + TYPE INCOMPLETE(A : SMALLER); + + TYPE ACC_INC IS ACCESS INCOMPLETE; + SUBTYPE SUB_ACC IS ACC_INC(IDENT_INT(6)); + + TYPE INCOMPLETE(A : SMALLER) IS + RECORD + T : INTEGER := INTEGER'(A); + END RECORD; + + BEGIN + FAILED("CONSTRAINT_ERROR NOT RAISED - BLOCK " & + "STATEMENT"); + DECLARE + Z : SUB_ACC := NEW INCOMPLETE(IDENT_INT(6)); + BEGIN + IF IDENT_INT(Z.T) = IDENT_INT(6) THEN + COMMENT("THIS LINE SHOULD NOT PRINT"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR RAISED TOO LATE " & + "- BLOCK STATEMENT"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED LATE" & + "- BLOCK STATEMENT"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED " & + "- BLOCK STATEMENT"); + END; + + RESULT; + END C38107B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C38108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF + -- A PACKAGE, WITH THE FULL DECLARATION OCCURRING IN THE PACKAGE BODY. + + -- AH 8/20/86 + + WITH REPORT; USE REPORT; + PROCEDURE C38108A IS + + PACKAGE P IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END P; + + PACKAGE BODY P IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + + END P; + + USE P; + BEGIN + + TEST ("C38108A", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION"); + DECLARE + VAL_1, VAL_2 : L; + BEGIN + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + END; + + RESULT; + END C38108A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- C38108B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF + -- A LIBRARY PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A + -- PACKAGE BODY. + + -- AH 8/20/86 + + PACKAGE C38108B_P IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END C38108B_P; + + PACKAGE BODY C38108B_P IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + + END C38108B_P; + + WITH REPORT; USE REPORT; + WITH C38108B_P; USE C38108B_P; + PROCEDURE C38108B IS + VAL_1, VAL_2 : L; + BEGIN + + TEST ("C38108B", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION - " & + "LIBRARY PACKAGE"); + + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + + RESULT; + END C38108B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c0.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- C38108C0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SPECIFICATION OF LIBRARY PACKAGE USED WITH C38108C1M. + + -- AH 8/20/86 + + PACKAGE C38108C0 IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END C38108C0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c1.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- C38108C1M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE DELCARED IN A SEPARATELY + -- COMPILED PACKAGE SPECIFICATION AND ITS FULL DECLARATION CAN LATER BE + -- GIVEN IN A SEPARATELY COMPILED BODY. + + -- AH 8/20/86 + + -- C38108C0 THE PACKAGE SPECIFICATION. + -- C38108C1M THE MAIN PROGRAM. + -- C38108C2 THE PACKAGE BODY. + + WITH REPORT; USE REPORT; + WITH C38108C0; USE C38108C0; + PROCEDURE C38108C1M IS + VAL_1, VAL_2 : L; + BEGIN + + TEST ("C38108C", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITHOUT FULL DECLARATION - " & + "LIBRARY PACKAGE"); + + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + + RESULT; + END C38108C1M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108c2.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + -- C38108C2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- PACKAGE BODY FOR USE WITH C38108C1M. + -- SPECIFICATION IS IN C38108C0. + + -- AH 8/20/86 + + PACKAGE BODY C38108C0 IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + + END C38108C0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108d0.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C38108D0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INCOMPLETE TYPE CAN BE DECLARED IN THE PRIVATE PART OF + -- A PACKAGE, WITH THE FULL DECLARATION OCCURRING LATER IN A + -- PACKAGE BODY SUBUNIT. + + -- OTHER FILES: C38108D1.ADA (PACKAGE BODY SUBUNIT.) + + -- AH 8/20/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C38108D0M IS + PACKAGE C38108D1 IS + TYPE L IS LIMITED PRIVATE; + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L); + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN; + PRIVATE + TYPE INC (D : INTEGER); + TYPE L IS ACCESS INC; + END C38108D1; + + PACKAGE BODY C38108D1 IS SEPARATE; + + USE C38108D1; + BEGIN + + TEST ("C38108D", "CHECK THAT INCOMPLETE TYPE CAN BE DECLARED IN " & + "PRIVATE PART WITH FULL DECLARATION IN " & + "A PACKAGE BODY SUBUNIT"); + + DECLARE + VAL_1, VAL_2 : L; + BEGIN + ASSIGN (2, VAL_1); + ASSIGN (2, VAL_2); + IF NOT "=" (VAL_1, VAL_2) THEN + FAILED ("INCOMPLETE TYPE NOT FULLY DECLARED"); + END IF; + END; + + RESULT; + END C38108D0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38108d1.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + -- C38108D1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- PACKAGE BODY SUBUNIT USED WITH C38108D0M. + + -- AH 8/20/86 + + SEPARATE (C38108D0M) + PACKAGE BODY C38108D1 IS + TYPE INC (D : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PROCEDURE ASSIGN (X : IN INTEGER; Y : IN OUT L) IS + BEGIN + Y := NEW INC(1); + Y.C := X; + END ASSIGN; + + FUNCTION "=" (X, Y : IN L) RETURN BOOLEAN IS + BEGIN + RETURN (X.C = Y.C); + END "="; + + END C38108D1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c38202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c38202a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- C38202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASKING ATTRIBUTES ARE DECLARED AND RETURN CORRECT + -- VALUES FOR OBJECTS HAVING AN ACCESS TYPE WHOSE DESIGNATED + -- TYPE IS A TASK TYPE. + -- CHECK THE ACCESS TYPE RESULTS OF FUNCTION CALLS. + + -- AH 9/12/86 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C38202A IS + BEGIN + TEST ("C38202A", "OBJECTS HAVING ACCESS TYPES WITH DESIGNATED " & + "TASK TYPE CAN BE PREFIX OF TASKING ATTRIBUTES"); + + -- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED. + -- (2) TASK IS NOT CALLABLE, TERMINATED. + + DECLARE + TASK TYPE TSK IS + ENTRY GO_ON; + END TSK; + + TASK DRIVER IS + ENTRY TSK_DONE; + END DRIVER; + + TYPE P_TYPE IS ACCESS TSK; + P : P_TYPE; + + TASK BODY TSK IS + I : INTEGER RANGE 0 .. 2; + BEGIN + ACCEPT GO_ON; + I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTAINT_ERROR NOT RAISED IN TASK " & + " TSK - 1A " & INTEGER'IMAGE(I)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + DRIVER.TSK_DONE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK " & + "TSK - 1A "); + DRIVER.TSK_DONE; + END TSK; + + TASK BODY DRIVER IS + COUNTER : INTEGER := 1; + BEGIN + P := NEW TSK; + IF NOT P'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1B"); + END IF; + + IF P'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1C"); + END IF; + + P.GO_ON; + ACCEPT TSK_DONE; + WHILE (NOT P'TERMINATED AND COUNTER <= 3) LOOP + DELAY 10.0; + COUNTER := COUNTER + 1; + END LOOP; + + IF COUNTER > 3 THEN + FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " & + "TIME - 1D"); + END IF; + + IF P'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1E"); + END IF; + + IF NOT P'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE - 1F"); + END IF; + END DRIVER; + + BEGIN + NULL; + END; -- BLOCK + + -- CHECK ACCESS TYPE RESULT RETURNED FROM FUNCTION. + -- CHECK TWO CASES: (1) TASK IS CALLABLE, NOT TERMINATED. + -- (2) TASK IS NOT CALLABLE, TERMINATED. + + DECLARE + TASK TYPE TSK IS + ENTRY GO_ON; + END TSK; + + TASK DRIVER IS + ENTRY TSK_DONE; + END DRIVER; + + TYPE P_TYPE IS ACCESS TSK; + P : P_TYPE; + + TSK_CREATED : BOOLEAN := FALSE; + + FUNCTION F1 RETURN P_TYPE IS + BEGIN + RETURN P; + END F1; + + TASK BODY TSK IS + I : INTEGER RANGE 0 .. 2; + BEGIN + ACCEPT GO_ON; + I := IDENT_INT(5); -- CONSTRAINT_ERROR RAISED. + FAILED ("CONSTRAINT_ERROR NOT RAISED IN TASK " & + "TSK - 2A " & INTEGER'IMAGE(I)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + DRIVER.TSK_DONE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK " & + "TSK - 2A "); + DRIVER.TSK_DONE; + END TSK; + + TASK BODY DRIVER IS + COUNTER : INTEGER := 1; + BEGIN + P := NEW TSK; -- ACTIVATE P.ALL (F1.ALL). + IF NOT F1'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2B"); + END IF; + + IF F1'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2C"); + END IF; + + F1.ALL.GO_ON; + ACCEPT TSK_DONE; + WHILE (NOT F1'TERMINATED AND COUNTER <= 3) LOOP + DELAY 10.0; + COUNTER := COUNTER + 1; + END LOOP; + + IF COUNTER > 3 THEN + FAILED ("TASK TSK NOT TERMINATED IN SUFFICIENT " & + "TIME - 2D"); + END IF; + + IF F1'CALLABLE THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2E"); + END IF; + + IF NOT F1'TERMINATED THEN + FAILED ("TASKING ATTRIBUTE RETURNS INCORRECT " & + "VALUE WHEN PREFIX IS VALUE FROM " & + "FUNCTION CALL - 2F"); + END IF; + END DRIVER; + + BEGIN + NULL; + END; -- BLOCK + + RESULT; + END C38202A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C3900010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900011.AM. + -- + -- TEST DESCRIPTION: + -- See C3900011.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- => C3900010.A + -- C3900011.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package C3900010 is + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + -- Declarations required for component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be inherited by + -- all derivatives. + + + + type Low_Alert_Type is new Alert_Type with record -- Record extension of + Level : Integer := 0; -- root tagged type. + end record; + + -- Inherits procedure Display from Alert. + -- Inherits procedure Handle from Alert. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + + -- Declarations required for component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; -- Record extension of + end record; -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits (inherited) procedure Handle from Low_Alert_Type. + + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + end C3900010; + + + --==================================================================-- + + + package body C3900010 is + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + end Handle; + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + end C3900010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900011.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900011.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900011.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900011.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,253 ---- + -- C3900011.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a record extension can be declared in the same package + -- as its parent, and that this parent may be a tagged record or a + -- record extension. Check that each derivative inherits all user- + -- defined primitive subprograms of its parent (including those that + -- its parent inherited), and that it may declare its own primitive + -- subprograms. + -- + -- Check that predefined equality operators are defined for the root + -- tagged type. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type in a package specification. Declare two + -- primitive subprograms for the type. + -- + -- Extend the root type with a record extension in the same package + -- specification. Declare a new primitive subprogram for the extension + -- (in addition to its two inherited subprograms). + -- + -- Extend the extension with a record extension in the same package + -- specification. Declare a new primitive subprogram for this second + -- extension (in addition to its three inherited subprograms). + -- + -- In the main program, declare operations for the root tagged type which + -- utilize aggregates and equality operators to verify the correctness + -- of the components. Overload these operations for the two type + -- extensions. Within each of these overloading operations, utilize type + -- conversion to call the parent's implementation of the same operation. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- C3900010.A + -- => C3900011.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with C3900010; + with Report; + procedure C3900011 is + + + package Check_Alert_Values is + + -- Declare functions to verify correctness of tagged record components + -- before and after calls to their primitive subprograms. + + + -- Alert_Type: + + function Initial_Values_Okay (A : in C3900010.Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in C3900010.Alert_Type) + return Boolean; + + + -- Low_Alert_Type: + + function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type) + return Boolean; + + function Bad_Final_Values (LA : in C3900010.Low_Alert_Type) + return Boolean; + + + -- Medium_Alert_Type: + + function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type) + return Boolean; + + function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type) + return Boolean; + + + end Check_Alert_Values; + + + --==========================================================-- + + + package body Check_Alert_Values is + + + function Initial_Values_Okay (A : in C3900010.Alert_Type) + return Boolean is + use type C3900010.Alert_Type; + begin -- "=" operator availability. + return (A = (Arrival_Time => C3900010.Default_Time, + Display_On => C3900010.Null_Device)); + end Initial_Values_Okay; + + + function Initial_Values_Okay (LA : in C3900010.Low_Alert_Type) + return Boolean is + begin -- Type conversion. + return (Initial_Values_Okay (C3900010.Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Initial_Values_Okay (MA : in C3900010.Medium_Alert_Type) + return Boolean is + use type C3900010.Person_Enum; + begin -- Type conversion. + return (Initial_Values_Okay (C3900010.Low_Alert_Type (MA)) and + MA.Action_Officer = C3900010.Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (A : in C3900010.Alert_Type) + return Boolean is + use type C3900010.Alert_Type; + begin -- "/=" operator availability. + return (A /= (Arrival_Time => C3900010.Alert_Time, + Display_On => C3900010.Null_Device)); + end Bad_Final_Values; + + + function Bad_Final_Values (LA : in C3900010.Low_Alert_Type) + return Boolean is + use type C3900010.Low_Alert_Type; + begin -- "=" operator availability. + return not ( LA = (Arrival_Time => C3900010.Alert_Time, + Display_On => C3900010.Teletype, + Level => 1) ); + end Bad_Final_Values; + + + function Bad_Final_Values (MA : in C3900010.Medium_Alert_Type) + return Boolean is + use type C3900010.Medium_Alert_Type; + begin -- "/=" operator availability. + return ( MA /= (C3900010.Alert_Time, + C3900010.Console, + 1, + C3900010.Duty_Officer) ); + end Bad_Final_Values; + + + end Check_Alert_Values; + + + --==========================================================-- + + + use Check_Alert_Values; + use C3900010; + + Root_Alarm : C3900010.Alert_Type; + Low_Alarm : C3900010.Low_Alert_Type; + Medium_Alarm : C3900010.Medium_Alert_Type; + + begin + + Report.Test ("C390001", "Primitive operation inheritance by type " & + "extensions: all extensions declared in same package " & + "as parent"); + + + -- Check root tagged type: + + if Initial_Values_Okay (Root_Alarm) then + Handle (Root_Alarm); -- Explicitly declared. + Display (Root_Alarm); -- Explicitly declared. + + if Bad_Final_Values (Root_Alarm) then + Report.Failed ("Wrong results after Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + + -- Check record extension of root tagged type: + + if Initial_Values_Okay (Low_Alarm) then + Handle (Low_Alarm); -- Inherited. + Low_Alarm.Display_On := Teletype; + Display (Low_Alarm); -- Inherited. + Low_Alarm.Level := Level_Of (Low_Alarm); -- Explicitly declared. + + if Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong results after Low_Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + + -- Check record extension of record extension: + + if Initial_Values_Okay (Medium_Alarm) then + Handle (Medium_Alarm); -- Inherited twice. + Medium_Alarm.Display_On := Console; + Display (Medium_Alarm); -- Inherited twice. + Medium_Alarm.Level := Level_Of (Medium_Alarm); -- Inherited. + Assign_Officer (Medium_Alarm, Duty_Officer); -- Explicitly declared. + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong results after Medium_Alert_Type calls"); + end if; + else + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + + -- Check final display counts: + + if C3900010.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong final values for display counts"); + end if; + + + Report.Result; + + end C3900011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C390002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a tagged base type may be declared, and derived + -- from in simple, private and extended forms. (Overlaps with C390B04) + -- Check that the package Ada.Tags is present and correctly implemented. + -- Check for the correct operation of Expanded_Name, External_Tag and + -- Internal_Tag within that package. Check that the exception Tag_Error + -- is correctly raised on calling Internal_Tag with bad input. + -- + -- TEST DESCRIPTION: + -- This test declares a tagged type, and derives three types from it. + -- These types are then used to test the presence and function of the + -- package Ada.Tags. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 27 Jan 96 SAIC Update RM references for 2.1 + -- + --! + + with Report; + with Ada.Tags; + + procedure C390002 is + + package Vehicle is + + type Object is tagged limited private; -- ancestor type + procedure Create( The_Vehicle : in out Object; Wheels : in Natural ); + function Wheels( The_Vehicle : Object ) return Natural; + + private + + type Object is tagged limited record + Wheel_Count : Natural := 0; + end record; + + end Vehicle; + + package Motivators is + + type Bicycle is new Vehicle.Object with null record; -- simple + + type Car is new Vehicle.Object with record -- extended + Convertible : Boolean; + end record; + + type Truck is new Vehicle.Object with private; -- private + + private + + type Truck is new Vehicle.Object with record + Air_Horn : Boolean; + end record; + + end Motivators; + + package body Vehicle is + + procedure Create( The_Vehicle : in out Object; Wheels : in Natural ) is + begin + The_Vehicle.Wheel_Count := Wheels; + end Create; + + function Wheels( The_Vehicle : Object ) return Natural is + begin + return The_Vehicle.Wheel_Count; + end Wheels; + + end Vehicle; + + function TC_ID_Tag( Tag : in Ada.Tags.Tag ) return Ada.Tags.Tag is + begin + return Ada.Tags.Internal_Tag( Ada.Tags.External_Tag( Tag ) ); + Report.Comment("This message intentionally blank."); + end TC_ID_Tag; + + procedure Check_Tags( Machine : in Vehicle.Object'Class; + Expected_Name : in String; + External_Tag : in String ) is + The_Tag : constant Ada.Tags.Tag := Machine'Tag; + use type Ada.Tags.Tag; + begin + if Ada.Tags.Expanded_Name(The_Tag) /= Expected_Name then + Report.Failed ("Failed in Check_Tags, Expanded_Name " + & Expected_Name); + end if; + if Ada.Tags.External_Tag(The_Tag) /= External_Tag then + Report.Failed ("Failed in Check_Tags, External_Tag " + & Expected_Name); + end if; + if Ada.Tags.Internal_Tag(External_Tag) /= The_Tag then + Report.Failed ("Failed in Check_Tags, Internal_Tag " + & Expected_Name); + end if; + end Check_Tags; + + procedure Check_Exception is + Boeing_777_Id : Ada.Tags.Tag; + begin + Boeing_777_Id := Ada.Tags.Internal_Tag("!@#$%^:*\/?"" not a tag!"); + Report.Failed ("Failed in Check_Exception, no exception"); + Boeing_777_Id := TC_ID_Tag( Boeing_777_Id ); + exception + when Ada.Tags.Tag_Error => null; + when others => + Report.Failed ("Failed in Check_Exception, wrong exception"); + end Check_Exception; + + use Motivators; + Two_Wheeler : Bicycle; + Four_Wheeler : Car; + Eighteen_Wheeler : Truck; + + begin -- Main test procedure. + + Report.Test ("C390002", "Check that a tagged type may be declared and " & + "derived from in simple, private and extended forms. " & + "Check package Ada.Tags" ); + + Create( Two_Wheeler, 2 ); + Create( Four_Wheeler, 4 ); + Create( Eighteen_Wheeler, 18 ); + + Check_Tags( Machine => Two_Wheeler, + Expected_Name => "C390002.MOTIVATORS.BICYCLE", + External_Tag => Bicycle'External_Tag ); + Check_Tags( Machine => Four_Wheeler, + Expected_Name => "C390002.MOTIVATORS.CAR", + External_Tag => Car'External_Tag ); + Check_Tags( Machine => Eighteen_Wheeler, + Expected_Name => "C390002.MOTIVATORS.TRUCK", + External_Tag => Truck'External_Tag ); + + Check_Exception; + + Report.Result; + + end C390002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,419 ---- + -- C390003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a subtype S of a tagged type T, S'Class denotes a + -- class-wide subtype. Check that T'Tag denotes the tag of the type T, + -- and that, for a class-wide tagged type X, X'Tag denotes the tag of X. + -- Check that the tags of stand alone objects, record and array + -- components, aggregates, and formal parameters identify their type. + -- Check that the tag of a value of a formal parameter is that of the + -- actual parameter, even if the actual is passed by a view conversion. + -- + -- TEST DESCRIPTION: + -- This test defines a class hierarchy (based on C390002) and + -- uses it to determine the correctness of the resulting tag + -- information generated by the compiler. A type is defined in the + -- class which contains components of the class as part of its + -- definition. This is to reduce the overall number of types + -- required, and to achieve the required nesting to accomplish + -- this test. The model is that of a car carrier truck; both car + -- and truck being in the class of Vehicle. + -- + -- Class Hierarchy: + -- Vehicle - - - - - - - (Bicycle) + -- / | \ / \ + -- Truck Car Q_Machine Tandem Motorcycle + -- | + -- Auto_Carrier + -- Contains: + -- Auto_Carrier( Car ) + -- Q_Machine( Car, Motorcycle ) + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed ARM references from objective text. + -- 20 Dec 94 SAIC Replaced three unnecessary extension + -- aggregates with simple aggregates. + -- 16 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + ----------------------------------------------------------------- C390003_1 + + with Ada.Tags; + package C390003_1 is -- Vehicle + + type TC_Keys is (Veh, MC, Tand, Car, Q, Truk, Heavy); + type States is (Good, Flat, Worn); + + type Wheel_List is array(Positive range <>) of States; + + type Object(Wheels: Positive) is tagged record + Wheel_State : Wheel_List(1..Wheels); + end record; + + procedure TC_Validate( It: Object; Key: TC_Keys ); + procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ); + + procedure Create( The_Vehicle : in out Object; Tyres : in States ); + procedure Rotate( The_Vehicle : in out Object ); + function Wheels( The_Vehicle : Object ) return Positive; + + end C390003_1; -- Vehicle; + + ----------------------------------------------------------------- C390003_2 + + with C390003_1; + package C390003_2 is -- Motivators + + package Vehicle renames C390003_1; + subtype Bicycle is Vehicle.Object(2); -- constrained subtype + + type Motorcycle is new Bicycle with record + Displacement : Natural; + end record; + procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ); + + type Tandem is new Bicycle with null record; + procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ); + + type Car is new Vehicle.Object(4) with -- extended, constrained + record + Displacement : Natural; + end record; + procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ); + + type Truck is new Vehicle.Object with -- extended, unconstrained + record + Tare : Natural; + end record; + procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ); + + end C390003_2; -- Motivators; + + ----------------------------------------------------------------- C390003_3 + + with C390003_1; + with C390003_2; + package C390003_3 is -- Special_Trucks + package Vehicle renames C390003_1; + package Motivators renames C390003_2; + Max_Cars_On_Vehicle : constant := 6; + type Cargo_Index is range 0..Max_Cars_On_Vehicle; + type Cargo is array(Cargo_Index range 1..Max_Cars_On_Vehicle) + of Motivators.Car; + type Auto_Carrier is new Motivators.Truck(18) with + record + Load_Count : Cargo_Index := 0; + Payload : Cargo; + end record; + procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ); + procedure Load ( The_Car : in Motivators.Car; + Onto : in out Auto_Carrier); + procedure Unload( The_Car : out Motivators.Car; + Off_of : in out Auto_Carrier); + end C390003_3; + + ----------------------------------------------------------------- C390003_4 + + with C390003_1; + with C390003_2; + package C390003_4 is -- James_Bond + + package Vehicle renames C390003_1; + package Motivators renames C390003_2; + + type Q_Machine is new Vehicle.Object(4) with record + Car_Part : Motivators.Car; + Bike_Part : Motivators.Motorcycle; + end record; + procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ); + + end C390003_4; + + ----------------------------------------------------------------- C390003_1 + + with Report; + with Ada.Tags; + package body C390003_1 is -- Vehicle + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + + procedure TC_Validate( It: Object; Key: TC_Keys ) is + begin + if Key /= Veh then + Report.Failed("Expected Veh Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Object'Class; The_Tag: Ada.Tags.Tag ) is + begin + if It'Tag /= The_Tag then + Report.Failed("Unexpected Tag for classwide formal"); + end if; + end TC_Validate; + + procedure Create( The_Vehicle : in out Object; Tyres : in States ) is + begin + The_Vehicle.Wheel_State := ( others => Tyres ); + end Create; + + function Wheels( The_Vehicle : Object ) return Positive is + begin + return The_Vehicle.Wheels; + end Wheels; + + procedure Rotate( The_Vehicle : in out Object ) is + Push : States; + Pulled : States + := The_Vehicle.Wheel_State(The_Vehicle.Wheel_State'Last); + begin + for Finger in + The_Vehicle.Wheel_State'First..The_Vehicle.Wheel_State'Last loop + Push := The_Vehicle.Wheel_State(Finger); + The_Vehicle.Wheel_State(Finger) := Pulled; + Pulled := Push; + end loop; + end Rotate; + + end C390003_1; -- Vehicle; + + ----------------------------------------------------------------- C390003_2 + + with Ada.Tags; + with Report; + package body C390003_2 is -- Motivators + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Motorcycle; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.MC then + Report.Failed("Expected MC Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Tandem; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Tand then + Report.Failed("Expected Tand Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Car; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Car then + Report.Failed("Expected Car Key"); + end if; + end TC_Validate; + + procedure TC_Validate( It: Truck; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Truk then + Report.Failed("Expected Truk Key"); + end if; + end TC_Validate; + end C390003_2; -- Motivators; + + ----------------------------------------------------------------- C390003_3 + + with Ada.Tags; + with Report; + package body C390003_3 is -- Special_Trucks + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Auto_Carrier; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Heavy then + Report.Failed("Expected Heavy Key"); + end if; + end TC_Validate; + + procedure Load ( The_Car : in Motivators.Car; + Onto : in out Auto_Carrier) is + begin + Onto.Load_Count := Onto.Load_Count +1; + Onto.Payload(Onto.Load_Count) := The_Car; + end Load; + procedure Unload( The_Car : out Motivators.Car; + Off_of : in out Auto_Carrier) is + begin + The_Car := Off_of.Payload(Off_of.Load_Count); + Off_of.Load_Count := Off_of.Load_Count -1; + end Unload; + + end C390003_3; + + ----------------------------------------------------------------- C390003_4 + + with Report, Ada.Tags; + package body C390003_4 is -- James_Bond + + function "="(A,B: Ada.Tags.Tag) return Boolean renames Ada.Tags."="; + function "="(A,B: Vehicle.TC_Keys) return Boolean renames Vehicle."="; + + procedure TC_Validate( It: Q_Machine; Key: Vehicle.TC_Keys ) is + begin + if Key /= Vehicle.Q then + Report.Failed("Expected Q Key"); + end if; + end TC_Validate; + + end C390003_4; + + ------------------------------------------------------------------- C390003 + + with Report; + with C390003_1; + with C390003_2; + with C390003_3; + with C390003_4; + procedure C390003 is + + package Vehicle renames C390003_1; use Vehicle; + package Motivators renames C390003_2; + package Special_Trucks renames C390003_3; + package James_Bond renames C390003_4; + + -- The cast, in order of complexity: + + Pennys_Bike : Motivators.Bicycle; + Weekender : Motivators.Tandem; + Qs_Moped : Motivators.Motorcycle; + Ms_Limo : Motivators.Car; + Yard_Van : Motivators.Truck(8); + Specter_X : Special_Trucks.Auto_Carrier; + Gen_II : James_Bond.Q_Machine; + + + -- Check compatibility with the corresponding class wide type. + + procedure Vehicle_Shop( It : in out Vehicle.Object'Class; + Key : in Vehicle.TC_Keys ) is + + -- Check that Subtype'Class is defined for tagged subtypes. + procedure Bike_Shop( Bike: in out Motivators.Bicycle'Class ) is + begin + -- Dispatch to appropriate TC_Validate + Vehicle.TC_Validate( Bike, Key ); + end Bike_Shop; + + begin + Vehicle.TC_Validate( It, Key ); + if Vehicle.Wheels( It ) = 2 then + Bike_Shop( It ); -- only call Bike_Shop when It has 2 wheels + end if; + end Vehicle_Shop; + + begin -- Main test procedure. + + Report.Test ("C390003", "Check that for a subtype S of a tagged type " & + "T, S'Class denotes a class-wide subtype. Check that " & + "T'Tag denotes the tag of the type T, and that, for a " & + "class-wide tagged type X, X'Tag denotes the tag of X. " & + "Check that the tags of stand alone objects, record and " & + "array components, aggregates, and formal parameters " & + "identify their type. Check that the tag of a value of a " & + "formal parameter is that of the actual parameter, even " & + "if the actual is passed by a view conversion" ); + + -- Check that the tags of stand alone objects, record and array + -- components, aggregates, and formal parameters identify their type. + -- Check that the tag of a value of a formal parameter is that of the + -- actual parameter, even if the actual is passed by a view conversion. + + Vehicle_Shop( Pennys_Bike, Veh ); + Vehicle_Shop( Weekender, Tand ); + Vehicle_Shop( Qs_Moped, MC ); + Vehicle_Shop( Ms_Limo, Car ); + Vehicle_Shop( Yard_Van, Truk ); + Vehicle_Shop( Specter_X, Heavy ); + Vehicle_Shop( Specter_X.Payload(1), Car ); + Vehicle_Shop( Gen_II, Q ); + Vehicle_Shop( Gen_II.Car_Part, Car ); + Vehicle_Shop( Gen_II.Bike_Part, MC ); + + Vehicle.TC_Validate( Pennys_Bike, Vehicle.Object'Tag ); + Vehicle.TC_Validate( Weekender, Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Qs_Moped, Motivators.Motorcycle'Tag ); + Vehicle.TC_Validate( Ms_Limo, Motivators.Car'Tag ); + Vehicle.TC_Validate( Yard_Van, Motivators.Truck'Tag ); + Vehicle.TC_Validate( Specter_X, Special_Trucks.Auto_Carrier'Tag ); + Vehicle.TC_Validate( Specter_X.Payload(1), Motivators.Car'Tag ); + Vehicle.TC_Validate( Gen_II, James_Bond.Q_Machine'Tag ); + Vehicle.TC_Validate( Gen_II.Car_Part, Motivators.Car'Tag ); + Vehicle.TC_Validate( Gen_II.Bike_Part, Motivators.Motorcycle'Tag ); + + -- Check the tag generated for an aggregate. + + Rentals: declare + Mikes_Rental : Vehicle.Object'Class := + Vehicle.Object'( 3, (Good, Flat, Worn)); + Diannes_Car : Vehicle.Object'Class := + Motivators.Tandem'( Wheels => 2, + Wheel_State => (Good, Good) ); + Jims_Bike : Vehicle.Object'Class := + Motivators.Motorcycle'( Pennys_Bike + with Displacement => 350 ); + Bills_Limo : Vehicle.Object'Class := + Motivators.Car'( Wheels => 4, + Wheel_State => (others => Good), + Displacement => 282 ); + Alans_Car : Vehicle.Object'Class := + Motivators.Truck'( 18, (others => Worn), + Tare => 5_500 ); + Pats_Truck : Vehicle.Object'Class := Specter_X; + Keiths_Car : Vehicle.Object'Class := Gen_II; + Isaacs_Bus : Vehicle.Object'Class := Keiths_Car; + + begin + Vehicle.TC_Validate( Mikes_Rental, Vehicle.Object'Tag ); + Vehicle.TC_Validate( Diannes_Car, Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Jims_Bike, Motivators.Motorcycle'Tag ); + Vehicle.TC_Validate( Bills_Limo, Motivators.Car'Tag ); + Vehicle.TC_Validate( Alans_Car, Motivators.Truck'Tag ); + Vehicle.TC_Validate( Pats_Truck, Special_Trucks.Auto_Carrier'Tag ); + Vehicle.TC_Validate( Keiths_Car, James_Bond.Q_Machine'Tag ); + end Rentals; + + -- Check the tag of parameters. + -- Check that the tag is not affected by view conversion. + + Vehicle.TC_Validate( Vehicle.Object( Gen_II ), James_Bond.Q_Machine'Tag ); + Vehicle.TC_Validate( Vehicle.Object( Ms_Limo ), Motivators.Car'Tag ); + Vehicle.TC_Validate( Motivators.Bicycle( Weekender ), + Motivators.Tandem'Tag ); + Vehicle.TC_Validate( Motivators.Bicycle( Gen_II.Bike_Part ), + Motivators.Motorcycle'Tag ); + + Report.Result; + + end C390003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390004.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,404 ---- + -- C390004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the tags of allocated objects correctly identify the + -- type of the allocated object. Check that the tag corresponds + -- correctly to the value resulting from both normal and view + -- conversion. Check that the tags of accessed values designating + -- aliased objects correctly identify the type of the object. Check + -- that the tag of a function result correctly evaluates. Check this + -- for class-wide functions. The tag of a class-wide function result + -- should be the tag appropriate to the actual value returned, not the + -- tag of the ancestor type. + -- + -- TEST DESCRIPTION: + -- This test defines a class hierarchy of types, with reference + -- semantics (an access type to the class-wide type). Similar in + -- structure to C392005, this test checks that dynamic allocation does + -- not adversely impact the tagging of types. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C390004_1 is -- DMV + type Equipment is ( T_Veh, T_Car, T_Con, T_Jep ); + + type Vehicle is tagged record + Wheels : Natural := 4; + Parked : Boolean := False; + end record; + + function Wheels ( It: Vehicle ) return Natural; + procedure Park ( It: in out Vehicle ); + procedure UnPark ( It: in out Vehicle ); + procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ); + procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ); + + type Car is new Vehicle with record + Passengers : Natural := 0; + end record; + + function Passengers ( It: Car ) return Natural; + procedure Load_Passengers( It: in out Car; To_Count: in Natural ); + procedure Park ( It: in out Car ); + procedure TC_Check ( It: in Car; To_Equip: in Equipment ); + + type Convertible is new Car with record + Top_Up : Boolean := True; + end record; + + function Top_Up ( It: Convertible ) return Boolean; + procedure Lower_Top( It: in out Convertible ); + procedure Park ( It: in out Convertible ); + procedure Raise_Top( It: in out Convertible ); + procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ); + + type Jeep is new Convertible with record + Windshield_Up : Boolean := True; + end record; + + function Windshield_Up ( It: Jeep ) return Boolean; + procedure Lower_Windshield( It: in out Jeep ); + procedure Park ( It: in out Jeep ); + procedure Raise_Windshield( It: in out Jeep ); + procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ); + + end C390004_1; + + with Report; + package body C390004_1 is + + procedure Set_Wheels( It: in out Vehicle; To_Count: in Natural ) is + begin + It.Wheels := To_Count; + end Set_Wheels; + + function Wheels( It: Vehicle ) return Natural is + begin + return It.Wheels; + end Wheels; + + procedure Park ( It: in out Vehicle ) is + begin + It.Parked := True; + end Park; + + procedure UnPark ( It: in out Vehicle ) is + begin + It.Parked := False; + end UnPark; + + procedure TC_Check ( It: in Vehicle; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Veh then + Report.Failed ("Failed, called Vehicle for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Car; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Car then + Report.Failed ("Failed, called Car for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Convertible; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Con then + Report.Failed ("Failed, called Convertible for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure TC_Check ( It: in Jeep; To_Equip: in Equipment ) is + begin + if To_Equip /= T_Jep then + Report.Failed ("Failed, called Jeep for " + & Equipment'Image(To_Equip)); + end if; + end TC_Check; + + procedure Load_Passengers( It: in out Car; To_Count: in Natural ) is + begin + It.Passengers := To_Count; + UnPark( It ); + end Load_Passengers; + + procedure Park( It: in out Car ) is + begin + It.Passengers := 0; + Park( Vehicle( It ) ); + end Park; + + function Passengers( It: Car ) return Natural is + begin + return It.Passengers; + end Passengers; + + procedure Raise_Top( It: in out Convertible ) is + begin + It.Top_Up := True; + end Raise_Top; + + procedure Lower_Top( It: in out Convertible ) is + begin + It.Top_Up := False; + end Lower_Top; + + function Top_Up ( It: Convertible ) return Boolean is + begin + return It.Top_Up; + end Top_Up; + + procedure Park ( It: in out Convertible ) is + begin + It.Top_Up := True; + Park( Car( It ) ); + end Park; + + procedure Raise_Windshield( It: in out Jeep ) is + begin + It.Windshield_Up := True; + end Raise_Windshield; + + procedure Lower_Windshield( It: in out Jeep ) is + begin + It.Windshield_Up := False; + end Lower_Windshield; + + function Windshield_Up( It: Jeep ) return Boolean is + begin + return It.Windshield_Up; + end Windshield_Up; + + procedure Park( It: in out Jeep ) is + begin + It.Windshield_Up := True; + Park( Convertible( It ) ); + end Park; + end C390004_1; + + with Report; + with Ada.Tags; + with C390004_1; + procedure C390004 is + package DMV renames C390004_1; + + The_Vehicle : aliased DMV.Vehicle; + The_Car : aliased DMV.Car; + The_Convertible : aliased DMV.Convertible; + The_Jeep : aliased DMV.Jeep; + + type C_Reference is access all DMV.Car'Class; + type V_Reference is access all DMV.Vehicle'Class; + + Designator : V_Reference; + Storage : Natural; + + procedure Valet( It: in out DMV.Vehicle'Class ) is + begin + DMV.Park( It ); + end Valet; + + procedure TC_Match( Object: DMV.Vehicle'Class; + Taglet: Ada.Tags.Tag; + Where : String ) is + use Ada.Tags; + begin + if Object'Tag /= Taglet then + Report.Failed("Tag mismatch: " & Where); + end if; + end TC_Match; + + procedure Parking_Validation( It: DMV.Vehicle; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 1 or not It.Parked then + Report.Failed ("Failed Vehicle " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Car; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 2 or DMV.Passengers( It ) /= 0 + or not It.Parked then + Report.Failed ("Failed Car " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Convertible; + TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 3 or DMV.Passengers( It ) /= 0 + or not DMV.Top_Up( It ) or not It.Parked then + Report.Failed ("Failed Convertible " & TC_Message); + end if; + end Parking_Validation; + + procedure Parking_Validation( It: DMV.Jeep; TC_Message: String ) is + begin + if DMV.Wheels( It ) /= 4 or DMV.Passengers( It ) /= 0 + or not DMV.Top_Up( It ) or not DMV.Windshield_Up( It ) + or not It.Parked then + Report.Failed ("Failed Jeep " & TC_Message); + end if; + end Parking_Validation; + + function Wash( It: V_Reference; TC_Expect : Ada.Tags.Tag ) + return DMV.Vehicle'Class is + This_Machine : DMV.Vehicle'Class := It.all; + begin + TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); + Storage := DMV.Wheels( This_Machine ); + return This_Machine; + end Wash; + + function Wash( It: C_Reference; TC_Expect : Ada.Tags.Tag ) + return DMV.Car'Class is + This_Machine : DMV.Car'Class := It.all; + begin + TC_Match( It.all, TC_Expect, "Class-wide object in Wash" ); + Storage := DMV.Wheels( This_Machine ); + return This_Machine; + end Wash; + + begin + + Report.Test( "C390004", "Check that the tags of allocated objects " + & "correctly identify the type of the allocated " + & "object. Check that tags resulting from " + & "normal and view conversions. Check tags of " + & "accessed values designating aliased objects. " + & "Check function result tags" ); + + DMV.Set_Wheels( The_Vehicle, 1 ); + DMV.Set_Wheels( The_Car, 2 ); + DMV.Set_Wheels( The_Convertible, 3 ); + DMV.Set_Wheels( The_Jeep, 4 ); + + Valet( The_Vehicle ); + Valet( The_Car ); + Valet( The_Convertible ); + Valet( The_Jeep ); + + Parking_Validation( The_Vehicle, "setup" ); + Parking_Validation( The_Car, "setup" ); + Parking_Validation( The_Convertible, "setup" ); + Parking_Validation( The_Jeep, "setup" ); + + -- Check that the tags of allocated objects correctly identify the type + -- of the allocated object. + + Designator := new DMV.Vehicle; + DMV.TC_Check( Designator.all, DMV.T_Veh ); + TC_Match( Designator.all, DMV.Vehicle'Tag, "allocated Vehicle" ); + + Designator := new DMV.Car; + DMV.TC_Check( Designator.all, DMV.T_Car ); + TC_Match( Designator.all, DMV.Car'Tag, "allocated Car"); + + Designator := new DMV.Convertible; + DMV.TC_Check( Designator.all, DMV.T_Con ); + TC_Match( Designator.all, DMV.Convertible'Tag, "allocated Convertible" ); + + Designator := new DMV.Jeep; + DMV.TC_Check( Designator.all, DMV.T_Jep ); + TC_Match( Designator.all, DMV.Jeep'Tag, "allocated Jeep" ); + + -- Check that view conversion causes the correct dispatch + DMV.TC_Check( DMV.Vehicle( The_Jeep ), DMV.T_Veh ); + DMV.TC_Check( DMV.Car( The_Jeep ), DMV.T_Car ); + DMV.TC_Check( DMV.Convertible( The_Jeep ), DMV.T_Con ); + + -- And that view conversion does not change the tag + TC_Match( DMV.Vehicle( The_Jeep ), DMV.Jeep'Tag, "View Conv Veh" ); + TC_Match( DMV.Car( The_Jeep ), DMV.Jeep'Tag, "View Conv Car" ); + TC_Match( DMV.Convertible( The_Jeep ), DMV.Jeep'Tag, "View Conv Jep" ); + + -- Check that the tags of accessed values designating aliased objects + -- correctly identify the type of the object. + Designator := The_Vehicle'Access; + DMV.TC_Check( Designator.all, DMV.T_Veh ); + TC_Match( Designator.all, DMV.Vehicle'Tag, "aliased Vehicle" ); + + Designator := The_Car'Access; + DMV.TC_Check( Designator.all, DMV.T_Car ); + TC_Match( Designator.all, DMV.Car'Tag, "aliased Car" ); + + Designator := The_Convertible'Access; + DMV.TC_Check( Designator.all, DMV.T_Con ); + TC_Match( Designator.all, DMV.Convertible'Tag, "aliased Convertible" ); + + Designator := The_Jeep'Access; + DMV.TC_Check( Designator.all, DMV.T_Jep ); + TC_Match( Designator.all, DMV.Jeep'Tag, "aliased Jeep" ); + + -- Check that the tag of a function result correctly evaluates. + -- Check this for class-wide functions. The tag of a class-wide + -- function result should be the tag appropriate to the actual value + -- returned, not the tag of the ancestor type. + Function_Check: declare + A_Vehicle : V_Reference := new DMV.Vehicle'( The_Vehicle ); + A_Car : C_Reference := new DMV.Car'( The_Car ); + A_Convertible : C_Reference := new DMV.Convertible'( The_Convertible ); + A_Jeep : C_Reference := new DMV.Jeep'( The_Jeep ); + begin + DMV.Unpark( A_Vehicle.all ); + DMV.Load_Passengers( A_Car.all, 5 ); + DMV.Load_Passengers( A_Convertible.all, 6 ); + DMV.Load_Passengers( A_Jeep.all, 7 ); + DMV.Lower_Top( DMV.Convertible(A_Convertible.all) ); + DMV.Lower_Top( DMV.Jeep(A_Jeep.all) ); + DMV.Lower_Windshield( DMV.Jeep(A_Jeep.all) ); + + if DMV.Wheels( Wash( A_Jeep, DMV.Jeep'Tag ) ) /= 4 + or Storage /= 4 then + Report.Failed("Did not correctly wash Jeep"); + end if; + + if DMV.Wheels( Wash( A_Convertible, DMV.Convertible'Tag ) ) /= 3 + or Storage /= 3 then + Report.Failed("Did not correctly wash Convertible"); + end if; + + if DMV.Wheels( Wash( A_Car, DMV.Car'Tag ) ) /= 2 + or Storage /= 2 then + Report.Failed("Did not correctly wash Car"); + end if; + + if DMV.Wheels( Wash( A_Vehicle, DMV.Vehicle'Tag ) ) /= 1 + or Storage /= 1 then + Report.Failed("Did not correctly wash Vehicle"); + end if; + + end Function_Check; + + Report.Result; + end C390004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900050.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900050.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900050.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900050.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- C3900050.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900053.AM. + -- + -- TEST DESCRIPTION: + -- See C3900053.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- => C3900050.A + -- C3900051.A + -- C3900052.A + -- C3900053.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package C3900050 is -- Alert system abstraction. + + -- Declarations used by component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + + type Alert_Type is tagged private; -- Root tagged type. + + procedure Set_Display (A : in out Alert_Type; -- To be inherited by + D : in Device_Enum); -- all derivatives. + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be overridden by + -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- root tagged type's private components. + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time; + + function Get_Display (A: Alert_Type) return Device_Enum; + + function Initial_Values_Okay (A : in Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in Alert_Type) + return Boolean; + + private + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + + end C3900050; + + + --==================================================================-- + + + package body C3900050 is -- Alert system abstraction. + + + procedure Set_Display (A : in out Alert_Type; + D : in Device_Enum) is + begin + A.Display_On := D; + end Set_Display; + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + Display (A); + end Handle; + + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time is + begin + return A.Arrival_Time; + end Get_Time; + + + function Get_Display (A: Alert_Type) return Device_Enum is + begin + return A.Display_On; + end Get_Display; + + + function Initial_Values_Okay (A : in Alert_Type) return Boolean is + begin + return (A = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device)); -- availability. + end Initial_Values_Okay; -- Aggregate with + -- named associations. + + function Bad_Final_Values (A : in Alert_Type) return Boolean is + begin + return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + + end C3900050; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900051.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900051.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900051.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900051.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- C3900051.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900053.AM. + -- + -- TEST DESCRIPTION: + -- See C3900053.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900050.A + -- => C3900051.A + -- C3900052.A + -- C3900053.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with C3900050; -- Alert system abstraction. + package C3900051 is -- Extended alert system abstraction. + + + type Low_Alert_Type is new C3900050.Alert_Type + with private; -- Private extension of + -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by + L : in Integer); -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Get_Level (LA: Low_Alert_Type) return Integer; + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + + private + + type Low_Alert_Type is new C3900050.Alert_Type with record + Level : Integer := 0; + end record; + + end C3900051; + + + --==================================================================-- + + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package body C3900051 is -- Extended alert system abstraction. + + use C3900050; -- Alert system abstraction. + + + procedure Set_Level (LA : in out Low_Alert_Type; + L : in Integer) is + begin + LA.Level := L; + end Set_Level; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + Set_Level (LA, 1); -- Call newly declared operation. + Set_Display (Alert_Type(LA), + Teletype); -- Call parent's operation (type conversion). + Display (LA); + end Handle; + + + function Get_Level (LA: Low_Alert_Type) return Integer is + begin + return LA.Level; + end Get_Level; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(LA) /= Alert_Time or + Get_Display(LA) /= Teletype or + LA.Level /= 1); + end Bad_Final_Values; + + + end C3900051; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900052.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900052.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900052.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900052.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C3900052.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900053.AM. + -- + -- TEST DESCRIPTION: + -- See C3900053.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900050.A + -- C3900051.A + -- => C3900052.A + -- C3900053.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 May 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with C3900051; -- Extended alert system abstraction. + package C3900052 is -- Further extended alert system abstraction. + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C3900051.Low_Alert_Type + with private; -- Private extension of + -- private extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + private + + type Medium_Alert_Type is new C3900051.Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + + end C3900052; + + + --==================================================================-- + + + with C3900050; -- Basic alert abstraction. + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package body C3900052 is -- Further extended alert system abstraction. + + use C3900050; -- Enumeration values directly visible. + use C3900051; -- Extended alert system abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + Set_Level (MA, 2); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + Set_Display (MA, Console); -- Call inherited operation. + Display (MA); -- Call doubly inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(MA) /= Alert_Time or + Get_Display(MA) /= Console or + Get_Level(MA) /= 2 or + MA.Action_Officer /= Duty_Officer); + end Bad_Final_Values; + + + end C3900052; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900053.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900053.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900053.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900053.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C3900053.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private tagged type declared in a package specification + -- may be extended with a private extension in a different package + -- specification, and that this private extension may in turn be extended + -- by a private extension in a third package. + -- + -- Check that each derivative inherits the user-defined primitive + -- subprograms of its parent (including those that its parent inherited), + -- that it may override these inherited primitive subprograms, and that it + -- may also declare its own primitive subprograms. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged private type and two associated primitive + -- subprograms in a package specification. Declare operations to verify + -- the correctness of the components. Declare operations which return + -- values of the type's private components, and which will be + -- inherited by later derivatives. + -- + -- Extend the root type with a private extension in a second package + -- specification. Declare a new primitive subprogram for the extension, + -- and override one of the two inherited subprograms. Within the + -- overriding subprogram, utilize type conversion to call the parent's + -- implementation of the same subprogram. Also within the overriding + -- subprogram, call the new primitive subprogram and each inherited + -- subprogram. Declare operations of the private extension which + -- override the verification operations of its parent. Declare operations + -- of the private extension which return values of the extension's + -- private components, and which will be inherited by later derivatives. + -- + -- Extend the extension with a private extension in a third package + -- specification. Declare a new primitive subprogram for this private + -- extension, and override one of the three inherited subprograms. + -- Within the overriding subprogram, utilize type conversion to call the + -- parent's implementation of the same subprogram. Also within the + -- overriding subprogram, call the new primitive subprogram and each + -- inherited subprogram. Declare operations of the private extension + -- which override the verification operations of its parent. + -- + -- In the main program, declare objects of the root tagged type and + -- the two type extensions. For each object, call the overriding + -- subprogram, and verify the correctness of the components by calling + -- the verification operations. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900050.A + -- C3900051.A + -- C3900052.A + -- => C3900053.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 May 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + with C3900050; -- Basic alert abstraction. + with C3900051; -- Extended alert abstraction. + with C3900052; -- Further extended alert abstraction. + + use C3900050; -- Primitive operations of Alert_Type directly visible. + + procedure C3900053 is + begin + + Report.Test ("C390005", "Primitive operation inheritance by type " & + "extensions: root type is private; all extensions are " & + "private and declared in different packages"); + + + ALERT_SUBTEST: ------------------------------------------------------------- + + declare + Alarm : C3900050.Alert_Type; -- Root tagged private type. + begin + if not Initial_Values_Okay (Alarm) then + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + Handle (Alarm); + + if Bad_Final_Values (Alarm) then + Report.Failed ("Wrong values for Alert_Type after Handle"); + end if; + end Alert_Subtest; + + + -- Check intermediate display counts: + + if C3900050.Display_Count_For (Null_Device) /= 1 or + C3900050.Display_Count_For (Teletype) /= 0 or + C3900050.Display_Count_For (Console) /= 0 or + C3900050.Display_Count_For (Big_Screen) /= 0 + then + Report.Failed ("Wrong display counts after Alert_Type"); + end if; + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C3900051.Low_Alert_Type; -- Priv. ext. of tagged type. + use C3900051; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Low_Alarm) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + if Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if C3900050.Display_Count_For /= (Null_Device => 2, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C3900052.Medium_Alert_Type; -- Priv. ext. of extension. + use C3900052; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if C3900050.Display_Count_For /= (Null_Device => 3, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + + end C3900053; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900060.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900060.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900060.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900060.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- C3900060.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900063.AM. + -- + -- TEST DESCRIPTION: + -- See C3900063.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- => C3900060.A + -- C3900061.A + -- C3900062.A + -- C3900063.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package C3900060 is -- Alert system abstraction. + + + -- Declarations used by component Arrival_Time. + + Default_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1901, 1, 1); + Alert_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_Of (1991, 6, 15); + + + -- Declarations used by component Display_On and procedure Display. + + type Device_Enum is (Null_Device, Teletype, Console, Big_Screen); + type Display_Counters is array (Device_Enum) of Natural; + + Display_Count_For : Display_Counters := (others => 0); + + + + type Alert_Type is tagged private; -- Root tagged type. + + procedure Set_Display (A : in out Alert_Type; -- To be inherited by + D : in Device_Enum); -- all derivatives. + + procedure Display (A : in Alert_Type); -- To be inherited by + -- all derivatives. + + procedure Handle (A : in out Alert_Type); -- To be overridden by + -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- root tagged type's private components. + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time; + + function Get_Display (A: Alert_Type) return Device_Enum; + + function Initial_Values_Okay (A : in Alert_Type) + return Boolean; + + function Bad_Final_Values (A : in Alert_Type) + return Boolean; + + private + + type Alert_Type is tagged record -- Root tagged type. + Arrival_Time : Ada.Calendar.Time := Default_Time; + Display_On : Device_Enum := Null_Device; + end record; + + + end C3900060; + + + --==================================================================-- + + + package body C3900060 is + + + procedure Set_Display (A : in out Alert_Type; + D : in Device_Enum) is + begin + A.Display_On := D; + end Set_Display; + + + procedure Display (A : in Alert_Type) is + begin + Display_Count_For (A.Display_On) := Display_Count_For (A.Display_On) + 1; + end Display; + + + procedure Handle (A : in out Alert_Type) is + begin + A.Arrival_Time := Alert_Time; + Display (A); + end Handle; + + + function Get_Time (A: Alert_Type) return Ada.Calendar.Time is + begin + return A.Arrival_Time; + end Get_Time; + + + function Get_Display (A: Alert_Type) return Device_Enum is + begin + return A.Display_On; + end Get_Display; + + + function Initial_Values_Okay (A : in Alert_Type) return Boolean is + begin + return (A = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device)); -- availability. + end Initial_Values_Okay; -- Aggregate with + -- named associations. + + function Bad_Final_Values (A : in Alert_Type) return Boolean is + begin + return (A /= (Alert_Time, Null_Device)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + + end C3900060; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900061.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900061.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900061.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900061.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C3900061.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900063.AM. + -- + -- TEST DESCRIPTION: + -- See C3900063.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900060.A + -- => C3900061.A + -- C3900062.A + -- C3900063.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with C3900060; -- Alert system abstraction. + package C3900061 is -- Extended alert abstraction. + + + type Low_Alert_Type is new C3900060.Alert_Type + with private; -- Private extension of + -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Set_Level (LA : in out Low_Alert_Type; -- To be inherited by + L : in Integer); -- all derivatives. + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Get_Level (LA: Low_Alert_Type) return Integer; + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (LA : in Low_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + + private + + type Low_Alert_Type is new C3900060.Alert_Type with record + Level : Integer := 0; + end record; + + end C3900061; + + + --==================================================================-- + + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package body C3900061 is + + use C3900060; -- Alert system abstraction. + + + procedure Set_Level (LA : in out Low_Alert_Type; + L : in Integer) is + begin + LA.Level := L; + end Set_Level; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + Set_Level (LA, 1); -- Call newly declared operation. + Set_Display (Alert_Type(LA), + Teletype); -- Call parent's operation (type conversion). + Display (LA); -- Call inherited operation. + end Handle; + + + function Get_Level (LA: Low_Alert_Type) return Integer is + begin + return LA.Level; + end Get_Level; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Alert_Type (LA)) and + LA.Level = 0); + end Initial_Values_Okay; + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(LA) /= Alert_Time or + Get_Display(LA) /= Teletype or + LA.Level /= 1); + end Bad_Final_Values; + + + end C3900061; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900062.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900062.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900062.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900062.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- C3900062.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C3900063.AM. + -- + -- TEST DESCRIPTION: + -- See C3900063.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900060.A + -- C3900061.A + -- => C3900062.A + -- C3900063.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. Added pragma Elaborate + -- for Ada.Calendar. + -- + --! + + with C3900061; -- Extended alert system abstraction. + package C3900062 is -- Further extended alert system abstraction. + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C3900061.Low_Alert_Type + with record -- Record extension of + Action_Officer : Person_Enum := Nobody; -- private extension. + end record; + + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- primitive subprog. + + function Bad_Final_Values (MA: in Medium_Alert_Type) -- Override parent's + return Boolean; -- primitive subprog. + + + end C3900062; + + + --==================================================================-- + + + with C3900060; -- Basic alert abstraction. + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package body C3900062 is + + use C3900060; -- Enumeration values directly visible. + use C3900061; -- Extended alert system abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + Set_Level (MA, 2); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + Set_Display (MA, Console); -- Call inherited operation. + Display (MA); -- Call doubly inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + use type Ada.Calendar.Time; + begin + return (Get_Time(MA) /= Alert_Time or + Get_Display(MA) /= Console or + Get_Level(MA) /= 2 or + MA.Action_Officer /= Duty_Officer); + end Bad_Final_Values; + + + end C3900062; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900063.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900063.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3900063.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3900063.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C3900063.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private tagged type declared in a package specification + -- may be extended with a private extension in a different package + -- specification, and that this private extension may in turn be extended + -- by a record extension in a third package. + -- + -- Check that each derivative inherits the user-defined primitive + -- subprograms of its parent (including those that its parent inherited), + -- that it may override these inherited primitive subprograms, and that it + -- may also declare its own primitive subprograms. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged private type and two associated primitive + -- subprograms in a package specification. Declare operations to verify + -- the correctness of the components. Declare operations which return + -- values of the type's private components, and which will be inherited + -- by later derivatives. + -- + -- Extend the root type with a private extension in a second package + -- specification. Declare a new primitive subprogram for the extension, + -- and override one of the two inherited subprograms. Within the + -- overriding subprogram, utilize type conversion to call the parent's + -- implementation of the same subprogram. Also within the overriding + -- subprogram, call the new primitive subprogram and each inherited + -- subprogram. Declare operations of the private extension which + -- override the verification operations of its parent. Declare + -- operations which return values of the extension's private components, + -- and which will be inherited by later derivatives. + -- + -- Extend the extension with a record extension in a third package + -- specification. Declare a new primitive subprogram for this record + -- extension, and override one of the three inherited subprograms. + -- Within the overriding subprogram, utilize type conversion to call the + -- parent's implementation of the same subprogram. Also within the + -- overriding subprogram, call the new primitive subprogram and each + -- inherited subprogram. Declare operations of the record extension + -- which override the verification operations of its parent. + -- + -- In the main program, declare objects of the root tagged type and + -- the two type extensions. For each object, call the overriding + -- subprogram, and verify the correctness of the components by calling + -- the verification operations. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- C3900060.A + -- C3900061.A + -- C3900062.A + -- => C3900063.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + with C3900060; -- Basic alert abstraction. + with C3900062; -- Further extended alert abstraction. + + use C3900060; -- Primitive operations of Alert_Type directly visible. + + procedure C3900063 is + begin + + Report.Test ("C390006", "Primitive operation inheritance by type " & + "extensions: all extensions declared in different " & + "packages; root type and 1st extension are private, " & + "2nd extension is record extension"); + + + -- The cases for type C3900060.Alert_Type and C3900061.Low_Alert_Type + -- are tested in C390005. Those subtests are not repeated here. + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C3900062.Medium_Alert_Type; -- Rec. ext. of extension. + use C3900062; -- Primitive operations of extension directly visible. + begin + if not Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if C3900060.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + + end C3900063; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390007.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,374 ---- + -- C390007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the tag of an object of a tagged type is preserved by + -- type conversion and parameter passing. + -- + -- TEST DESCRIPTION: + -- The fact that the tag of an object is not changed is verified by + -- making dispatching calls to primitive operations, and confirming that + -- the proper body is executed. Objects of both specific and class-wide + -- types are checked. + -- + -- The dispatching calls are made in two contexts. The first is a + -- straightforward dispatching call made from within a class-wide + -- operation. The second is a redispatch from within a primitive + -- operation. + -- + -- For the parameter passing case, the initial class-wide and specific + -- objects are passed directly in calls to the class-wide and primitive + -- operations. The redispatch is accomplished by initializing a local + -- class-wide object in the primitive operation to the value of the + -- formal parameter, and using the local object as the actual in the + -- (re)dispatching call. + -- + -- For the type conversion case, the initial class-wide object is assigned + -- a view conversion of an object of a specific type: + -- + -- type T is tagged ... + -- type DT is new T with ... + -- + -- A : DT; + -- B : T'Class := T(A); -- Despite conversion, tag of B is that of DT. + -- + -- The class-wide object is then passed directly in calls to the + -- class-wide and primitive operations. For the initial object of a + -- specific type, however, a view conversion of the object is passed, + -- forcing a non-dispatching call in the primitive operation case. Within + -- the primitive operation, a view conversion of the formal parameter to + -- a class-wide type is then used to force a (re)dispatching call. + -- + -- For the type conversion and parameter passing case, a combining of + -- view conversion and parameter passing of initial specific objects are + -- called directly to the class-wide and primitive operations. + -- + -- + -- CHANGE HISTORY: + -- 28 Jun 95 SAIC Initial prerelease version. + -- 23 Apr 96 SAIC Added use C390007_0 in the main. + -- + --! + + package C390007_0 is + + type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, + Derived_Outer, Derived_Inner); + + type Root_Type is abstract tagged null record; + + procedure Outer_Proc (X : in out Root_Type) is abstract; + procedure Inner_Proc (X : in out Root_Type) is abstract; + + procedure ClassWide_Proc (X : in out Root_Type'Class); + + end C390007_0; + + + --==================================================================-- + + + package body C390007_0 is + + procedure ClassWide_Proc (X : in out Root_Type'Class) is + begin + Inner_Proc (X); + end ClassWide_Proc; + + end C390007_0; + + + --==================================================================-- + + + package C390007_0.C390007_1 is + + type Param_Parent_Type is new Root_Type with record + Last_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Param_Parent_Type); + procedure Inner_Proc (X : in out Param_Parent_Type); + + end C390007_0.C390007_1; + + + --==================================================================-- + + + package body C390007_0.C390007_1 is + + procedure Outer_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Outer; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Parent_Type) is + begin + X.Last_Call := Parent_Inner; + end Inner_Proc; + + end C390007_0.C390007_1; + + + --==================================================================-- + + + package C390007_0.C390007_1.C390007_2 is + + type Param_Derived_Type is new Param_Parent_Type with null record; + + procedure Outer_Proc (X : in out Param_Derived_Type); + procedure Inner_Proc (X : in out Param_Derived_Type); + + end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + + package body C390007_0.C390007_1.C390007_2 is + + procedure Outer_Proc (X : in out Param_Derived_Type) is + Y : Root_Type'Class := X; + begin + Inner_Proc (Y); -- Redispatch. + Root_Type'Class (X) := Y; + end Outer_Proc; + + procedure Inner_Proc (X : in out Param_Derived_Type) is + begin + X.Last_Call := Derived_Inner; + end Inner_Proc; + + end C390007_0.C390007_1.C390007_2; + + + --==================================================================-- + + + package C390007_0.C390007_3 is + + type Convert_Parent_Type is new Root_Type with record + First_Call : Call_ID_Kind := None; + Second_Call : Call_ID_Kind := None; + end record; + + procedure Outer_Proc (X : in out Convert_Parent_Type); + procedure Inner_Proc (X : in out Convert_Parent_Type); + + end C390007_0.C390007_3; + + + --==================================================================-- + + + package body C390007_0.C390007_3 is + + procedure Outer_Proc (X : in out Convert_Parent_Type) is + begin + X.First_Call := Parent_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Parent_Type) is + begin + X.Second_Call := Parent_Inner; + end Inner_Proc; + + end C390007_0.C390007_3; + + + --==================================================================-- + + + package C390007_0.C390007_3.C390007_4 is + + type Convert_Derived_Type is new Convert_Parent_Type with null record; + + procedure Outer_Proc (X : in out Convert_Derived_Type); + procedure Inner_Proc (X : in out Convert_Derived_Type); + + end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + + package body C390007_0.C390007_3.C390007_4 is + + procedure Outer_Proc (X : in out Convert_Derived_Type) is + begin + X.First_Call := Derived_Outer; + Inner_Proc (Root_Type'Class(X)); -- Redispatch. + end Outer_Proc; + + procedure Inner_Proc (X : in out Convert_Derived_Type) is + begin + X.Second_Call := Derived_Inner; + end Inner_Proc; + + end C390007_0.C390007_3.C390007_4; + + + --==================================================================-- + + + with C390007_0.C390007_1.C390007_2; + with C390007_0.C390007_3.C390007_4; + use C390007_0; + + with Report; + procedure C390007 is + begin + Report.Test ("C390007", "Check that the tag of an object of a tagged " & + "type is preserved by type conversion and parameter passing"); + + + -- + -- Check that tags are preserved by parameter passing: + -- + + Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + ClassWide_A : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_A; + ClassWide_B : C390007_0.C390007_1.Param_Parent_Type'Class := Specific_B; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Specific_A); + if Specific_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (Specific_B); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if ClassWide_A.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if ClassWide_B.Last_Call /= Derived_Inner then + Report.Failed ("Parameter passing: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Parameter_Passing_Subtest; + + + -- + -- Check that tags are preserved by type conversion: + -- + + Type_Conversion_Subtest: + declare + Specific_A : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + Specific_B : C390007_0.C390007_3.C390007_4.Convert_Derived_Type; + + ClassWide_A : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_A); + ClassWide_B : C390007_0.C390007_3.Convert_Parent_Type'Class := + C390007_0.C390007_3.Convert_Parent_Type(Specific_B); + + use C390007_0.C390007_3; + use C390007_0.C390007_3.C390007_4; + begin + + Outer_Proc (Convert_Parent_Type(Specific_A)); + if (Specific_A.First_Call /= Parent_Outer) or + (Specific_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with specific operand"); + end if; + + Outer_Proc (ClassWide_A); + if (ClassWide_A.First_Call /= Derived_Outer) or + (ClassWide_A.Second_Call /= Derived_Inner) + then + Report.Failed ("Type conversion: tag not preserved in call to " & + "primitive operation with class-wide operand"); + end if; + + C390007_0.ClassWide_Proc (Convert_Parent_Type(Specific_B)); + if (Specific_B.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with specific operand"); + end if; + + C390007_0.ClassWide_Proc (ClassWide_B); + if (ClassWide_A.Second_Call /= Derived_Inner) then + Report.Failed ("Type conversion: tag not preserved in call to " & + "class-wide operation with class-wide operand"); + end if; + + end Type_Conversion_Subtest; + + + -- + -- Check that tags are preserved by type conversion and parameter passing: + -- + + Type_Conversion_And_Parameter_Passing_Subtest: + declare + Specific_A : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + Specific_B : C390007_0.C390007_1.C390007_2.Param_Derived_Type; + + use C390007_0.C390007_1; + use C390007_0.C390007_1.C390007_2; + begin + + Outer_Proc (Param_Parent_Type (Specific_A)); + if Specific_A.Last_Call /= Parent_Outer then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to primitive operation with " & + "specific operand"); + end if; + + C390007_0.ClassWide_Proc (Param_Parent_Type (Specific_B)); + if Specific_B.Last_Call /= Derived_Inner then + Report.Failed ("Type conversion and parameter passing: tag not " & + "preserved in call to class-wide operation with " & + "specific operand"); + end if; + + end Type_Conversion_And_Parameter_Passing_Subtest; + + + Report.Result; + + end C390007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- C390010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if S is a subtype of a tagged type T, and if S is + -- constrained, then the allowable values of S'Class are only those + -- that, when converted to T, belong to S. + -- + -- TEST DESCRIPTION: + -- This test defines a small tagged hierarchy of discriminated tagged + -- records, and constrained subtypes of those tagged record types. + -- It then uses access to the classwide of the constrained subtype + -- to check the objective. + -- + -- + -- CHANGE HISTORY: + -- 09 APR 96 SAIC Initial version + -- 03 NOV 96 SAIC Revised for 2.1 release + -- 31 DEC 97 EDS Restored use of intermediate access variable + -- to eliminate raising of Program_Error + -- 13 SEP 99 RLB Repaired previous change to avoid premature + -- subtype check. + -- 28 JUN 02 RLB Added pragma Elaborate_All (Report);. + --! + + ----------------------------------------------------------------- C390010_0 + + with Report; pragma Elaborate_All (Report); + package C390010_0 is + + -- the defined subprograms will allow checking the placement of + -- constraint_checks + + -- define a discriminated tagged type, and a constrained subtype of + -- that type: + + type Discr_Tag_Record( Disc: Boolean ) is tagged record + FieldA : Character := 'A'; + case Disc is + when True => FieldB : Character := 'B'; + when False => FieldC : Character := 'C'; + end case; + end record; + + procedure Dispatching_Op( DTO : in out Discr_Tag_Record ); + + Authentic : Boolean := Report.Ident_Bool( True ); + + subtype True_Record is Discr_Tag_Record( Authentic ); + + + -- derive a type, "passing through" one discriminant, adding one + -- discriminant, and a constrained subtype of THAT type: + + type Derived_Record( Disc1, Disc2: Boolean ) is + new Discr_Tag_Record( Disc1 ) with record + FieldD : Character := 'D'; + case Disc2 is + when True => FieldE : Character := 'E'; + when False => FieldF : Character := 'F'; + end case; + end record; + + procedure Dispatching_Op( DR : in out Derived_Record ); + + subtype True_True_Derived is Derived_Record( Authentic, Authentic ); + + + -- now, define an access to classwide type, using the classwide from the + -- constrained subtype of the root (or parent) type: + + type Subtype_Parent_Class_Access is access all True_Record'Class; + type Parent_Class_Access is access all Discr_Tag_Record'Class; + + procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ); + + end C390010_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C390010_0 + + with Report; + with TCTouch; + package body C390010_0 is + + procedure Dispatching_Op( DTO : in out Discr_Tag_Record ) is + begin + TCTouch.Touch('1'); --------------------------------------------------- 1 + if DTO.Disc then + TCTouch.Touch(DTO.FieldB); ------------------------------------------ B + else + TCTouch.Touch(DTO.FieldC); ------------------------------------------ C + end if; + end Dispatching_Op; + + + procedure Dispatching_Op( DR : in out Derived_Record ) is + begin + TCTouch.Touch('2'); --------------------------------------------------- 2 + if DR.Disc1 then + TCTouch.Touch(DR.FieldB); ------------------------------------------ B + else + TCTouch.Touch(DR.FieldC); ------------------------------------------ C + end if; + if DR.Disc2 then + TCTouch.Touch(DR.FieldE); ------------------------------------------ E + else + TCTouch.Touch(DR.FieldF); ------------------------------------------ F + end if; + end Dispatching_Op; + + procedure PCW_Op( SPCA : in Subtype_Parent_Class_Access ) is + begin + + -- the following line is the "heart" of this test, objects of all types + -- covered by the classwide type will be passed to this subprogram in + -- the execution of the test. + if SPCA.Disc then + TCTouch.Touch(SPCA.FieldB); ------------------------------------------ B + else + TCTouch.Touch(SPCA.FieldC); ------------------------------------------ C + end if; + + Dispatching_Op( SPCA.all ); -- check that this dispatches correctly, + -- with discriminants correctly represented + + end PCW_Op; + + end C390010_0; + + ------------------------------------------------------------------- C390010 + + with Report; + with TCTouch; + with C390010_0; + procedure C390010 is + + package CP renames C390010_0; + + procedure Check_Element( Item : access CP.Discr_Tag_Record'Class ) is + begin + + -- the implicit conversion from the general access parameter to the more + -- constrained subtype access type in the following call should cause + -- Constraint_Error in the cases where the object is not correctly + -- constrained + + CP.PCW_Op( Item.all'Access ); + + exception + when Constraint_Error => TCTouch.Touch('X'); -------------------------- X + when others => Report.Failed("Unanticipated exception in Check_Element"); + + end Check_Element; + + An_Item : CP.Parent_Class_Access; + + begin -- Main test procedure. + + Report.Test ("C390010", "Check that if S is a subtype of a tagged type " & + "T, and if S is constrained, then the allowable " & + "values of S'Class are only those that, when " & + "converted to T, belong to S" ); + + An_Item := new CP.Discr_Tag_Record(True); + Check_Element( An_Item ); + TCTouch.Validate("B1B","Case 1"); + + An_Item := new CP.Discr_Tag_Record(False); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 2"); + + An_Item := new CP.True_Record; + Check_Element( An_Item ); + TCTouch.Validate("B1B","Case 3"); + + An_Item := new CP.Derived_Record(False, False); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 4"); + + An_Item := new CP.Derived_Record(False, True); + Check_Element( An_Item ); + TCTouch.Validate("X","Case 5"); + + An_Item := new CP.Derived_Record(True, False); + Check_Element( An_Item ); + TCTouch.Validate("B2BF","Case 6"); + + An_Item := new CP.True_True_Derived; + Check_Element( An_Item ); + TCTouch.Validate("B2BE","Case 7"); + + Report.Result; + + end C390010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390011.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- C390011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that tagged types declared within generic package declarations + -- generate distinct tags for each instance of the generic. + -- + -- TEST DESCRIPTION: + -- This test defines a very simple generic package (with the expectation + -- that it should be easily be shared), and a few instances of that + -- package. In true user-like fashion, two of the instances are identical + -- (to wit: IIO is new Integer_IO(Integer)). The tags generated for each + -- of them are placed into a list. The last action of the test is to + -- check that everything in the list is unique. + -- + -- Almost as an aside, this test defines functions that return T'Base and + -- T'Class, and then exercises these functions. + -- + -- (JPR) persistent objects really need a function like: + -- function Get_Object return T'class; + -- + -- + -- CHANGE HISTORY: + -- 20 OCT 95 SAIC Initial version + -- 23 APR 96 SAIC Commentary Corrections 2.1 + -- + --! + + ----------------------------------------------------------------- C390011_0 + + with Ada.Tags; + package C390011_0 is + + procedure Add_Tag_To_List( T : Ada.Tags.Tag; X_Name, X_Tag: String ); + + procedure Check_List_For_Duplicates; + + end C390011_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C390011_0 is + + use type Ada.Tags.Tag; + type SP is access String; + + type List_Item; + type List_P is access List_Item; + type List_Item is record + The_Tag : Ada.Tags.Tag; + Exp_Name : SP; + Ext_Tag : SP; + Next : List_P; + end record; + + The_List : List_P; + + procedure Add_Tag_To_List ( T : Ada.Tags.Tag; X_Name, X_Tag: String ) is + begin -- prepend the tag information to the list + The_List := new List_Item'( The_Tag => T, + Exp_Name => new String'(X_Name), + Ext_Tag => new String'(X_Tag), + Next => The_List ); + end Add_Tag_To_List; + + procedure Check_List_For_Duplicates is + Finger : List_P; + Thumb : List_P := The_List; + begin -- + while Thumb /= null loop + Finger := Thumb.Next; + while Finger /= null loop + -- Check that the tag is unique + if Finger.The_Tag = Thumb.The_Tag then + Report.Failed("Duplicate Tag"); + end if; + + -- Check that the Expanded name is unique + if Finger.Exp_Name.all = Thumb.Exp_Name.all then + Report.Failed("Tag name " & Finger.Exp_Name.all & " repeats"); + end if; + + -- Check that the External Tag is unique + + if Finger.Ext_Tag.all = Thumb.Ext_Tag.all then + Report.Failed("External Tag " & Finger.Ext_Tag.all & " repeats"); + end if; + Finger := Finger.Next; + end loop; + Thumb := Thumb.Next; + end loop; + end Check_List_For_Duplicates; + + begin + -- some things I just don't trust... + if The_List /= null then + Report.Failed("Implicit default for The_List not null"); + end if; + end C390011_0; + + ----------------------------------------------------------------- C390011_1 + + generic + type Index is (<>); + type Item is private; + package C390011_1 is + + type List is array(Index range <>) of Item; + type ListP is access all List; + + type Table is tagged record + Data: ListP; + end record; + + function Sort( T: in Table'Class ) return Table'Class; + + function Stable_Table return Table'Class; + + function Table_End( T: Table ) return Index'Base; + + end C390011_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C390011_1 is + + -- In a user program this package would DO something + + function Sort( T: in Table'Class ) return Table'Class is + begin + return T; + end Sort; + + Empty : Table'Class := Table'( Data => null ); + + function Stable_Table return Table'Class is + begin + return Empty; + end Stable_Table; + + function Table_End( T: Table ) return Index'Base is + begin + return Index'Base( T.Data.all'Last ); + end Table_End; + + end C390011_1; + + ----------------------------------------------------------------- C390011_2 + + with C390011_1; + package C390011_2 is new C390011_1( Index => Character, Item => Float ); + + ----------------------------------------------------------------- C390011_3 + + with C390011_1; + package C390011_3 is new C390011_1( Index => Character, Item => Float ); + + ----------------------------------------------------------------- C390011_4 + + with C390011_1; + package C390011_4 is new C390011_1( Index => Integer, Item => Character ); + + ----------------------------------------------------------------- C390011_5 + + with C390011_3; + with C390011_4; + package C390011_5 is + + type Table_3 is new C390011_3.Table with record + Serial_Number : Integer; + end record; + + type Table_4 is new C390011_4.Table with record + Serial_Number : Integer; + end record; + + end C390011_5; + + -- no package body C390011_5 required + + ------------------------------------------------------------------- C390011 + + with Report; + with C390011_0; + with C390011_2; + with C390011_3; + with C390011_4; + with C390011_5; + with Ada.Tags; + procedure C390011 is + + begin -- Main test procedure. + + Report.Test ("C390011", "Check that tagged types declared within " & + "generic package declarations generate distinct " & + "tags for each instance of the generic. " & + "Check that 'Base may be used as a subtype mark. " & + "Check that T'Base and T'Class are allowed as " & + "the subtype mark in a function result" ); + + -- build the tag information table + C390011_0.Add_Tag_To_List(T => C390011_2.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_2.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_2.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_3.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_3.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_3.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_4.Table'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_4.Table'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_4.Table'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_5.Table_3'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_3'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_5.Table_3'Tag) ); + + C390011_0.Add_Tag_To_List(T => C390011_5.Table_4'Tag, + X_Name => Ada.Tags.Expanded_Name(C390011_5.Table_4'Tag), + X_Tag => Ada.Tags.External_Tag(C390011_5.Table_4'Tag) ); + + -- preform the check for distinct tags + C390011_0.Check_List_For_Duplicates; + + Report.Result; + + end C390011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- C39006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A + -- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE + -- FOLLOWING: + -- A) A FUNCTION IS CALLED IN THE INITIALIZATION EXPRESSION OF A + -- SCALAR VARIABLE OR A RECORD COMPONENT, AND THE SCALAR OR + -- RECORD VARIABLE'S DECLARATION IS ELABORATED BEFORE THE + -- SUBPROGRAM BODY IS ELABORATED. + + -- TBN 8/14/86 + + WITH REPORT; USE REPORT; + PROCEDURE C39006A IS + + BEGIN + TEST ("C39006A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " & + "BODY HAS NOT YET BEEN ELABORATED"); + BEGIN + DECLARE + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER; + + VAR1 : INTEGER := INIT_1 (1); + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + + FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER; + + TYPE REC1 IS + RECORD + NUMBER : INTEGER := INIT_2 (2); + END RECORD; + + VAR2 : REC1; + + FUNCTION INIT_2 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_2; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + + FUNCTION F1 RETURN INTEGER; + + PACKAGE PACK IS + VAR1 : INTEGER := F1; + END PACK; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END F1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + BEGIN + DECLARE + + PACKAGE PACK IS + FUNCTION F2 RETURN INTEGER; + VAR2 : INTEGER := F2; + END PACK; + + PACKAGE BODY PACK IS + FUNCTION F2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(3)); + END F2; + END PACK; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 4"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + + FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER; + + GENERIC + PACKAGE Q IS + VAR1 : INTEGER := INIT_3 (1); + END Q; + + PACKAGE NEW_Q IS NEW Q; + + FUNCTION INIT_3 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(3)); + END INIT_3; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 5"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + + FUNCTION FUN RETURN INTEGER; + + TYPE PARAM IS + RECORD + COMP : INTEGER := FUN; + END RECORD; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE GP IS + OBJ : T; + END GP; + + PACKAGE INST IS NEW GP(PARAM); + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(3)); + END FUN; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 6"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + + RESULT; + END C39006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C39006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A + -- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE + -- FOLLOWING: + -- B) THE SUBPROGRAM IS CALLED IN A PACKAGE BODY. + -- C) THE SUBPROGRAM IS AN ACTUAL GENERIC PARAMETER CALLED DURING + -- ELABORATION OF THE GENERIC INSTANTIATION. + -- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL + -- PACKAGE BODY. + + -- TBN 8/19/86 + + WITH REPORT; USE REPORT; + PROCEDURE C39006B IS + + BEGIN + TEST ("C39006B", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO CALL A SUBPROGRAM WHOSE " & + "BODY HAS NOT YET BEEN ELABORATED"); + BEGIN + DECLARE + PACKAGE PACK IS + FUNCTION FUN RETURN INTEGER; + PROCEDURE PROC (A : IN OUT INTEGER); + END PACK; + + PACKAGE BODY PACK IS + + VAR1 : INTEGER := 0; + + PROCEDURE PROC (A : IN OUT INTEGER) IS + BEGIN + IF A = IDENT_INT(1) THEN + A := A + FUN; + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + ELSE + A := IDENT_INT(1); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "1"); + END PROC; + + PACKAGE INSIDE IS + END INSIDE; + + PACKAGE BODY INSIDE IS + BEGIN + PROC (VAR1); + PROC (VAR1); + END INSIDE; + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END FUN; + + BEGIN + NULL; + END PACK; + + BEGIN + NULL; + END; + END; + + BEGIN + DECLARE + FUNCTION INIT_2 RETURN INTEGER; + + GENERIC + WITH FUNCTION FF RETURN INTEGER; + PACKAGE P IS + Y : INTEGER; + END P; + + GLOBAL_INT : INTEGER := IDENT_INT(1); + + PACKAGE BODY P IS + BEGIN + IF GLOBAL_INT = 1 THEN + Y := FF; + END IF; + END P; + + PACKAGE N IS + PACKAGE NEW_P IS NEW P(INIT_2); + END N; + + FUNCTION INIT_2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT (1)); + END INIT_2; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + DECLARE + + PROCEDURE ADD1 (A : IN OUT INTEGER); + + PACKAGE P IS + VAR : INTEGER := IDENT_INT(1); + END P; + + PACKAGE BODY P IS + BEGIN + IF VAR = 1 THEN + ADD1 (VAR); + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END P; + + PROCEDURE ADD1 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END ADD1; + + BEGIN + NULL; + END; + + RESULT; + END C39006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006c0.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C39006C0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO CALL A + -- SUBPROGRAM WHOSE BODY HAS NOT YET BEEN ELABORATED. CHECK THE + -- FOLLOWING: + -- D) THE SUBPROGRAM IS CALLED DURING ELABORATION OF AN OPTIONAL + -- PACKAGE BODY SUBUNIT THAT IS IN C39006C1.ADA. + + -- SEPARATE FILES ARE: + -- C39006C0M THE MAIN PROCEDURE. + -- C39006C1 A SUBUNIT PACKAGE BODY. + + -- TBN 8/19/86 + -- LDC 5/26/88 CHANGED TEST NAME PARAMETER FROM C39006C0M TO + -- C39006C IN THE TEST CALL. + + WITH REPORT; USE REPORT; + PROCEDURE C39006C0M IS + + PACKAGE CALL_TEST_FIRST IS + END CALL_TEST_FIRST; + + PACKAGE BODY CALL_TEST_FIRST IS + BEGIN + TEST ("C39006C", "CHECK THAT PROGRAM_ERROR IS RAISED IF " & + "THE SUBPROGRAM WHOSE BODY HAS NOT BEEN " & + "ELABORATED IS CALLED DURING " & + "ELABORATION OF AN OPTIONAL PACKAGE " & + "BODY SUBUNIT"); + END CALL_TEST_FIRST; + + PROCEDURE ADD1 (A : IN OUT INTEGER); + + PACKAGE C39006C1 IS + VAR : INTEGER := IDENT_INT(1); + END C39006C1; + + PACKAGE BODY C39006C1 IS SEPARATE; + + PROCEDURE ADD1 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END ADD1; + + BEGIN + RESULT; + END C39006C0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006c1.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + -- C39006C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- PACKAGE BODY SUBUNIT FOR C39006C0M.ADA. + + -- TBN 8/19/86 + + SEPARATE (C39006C0M) + PACKAGE BODY C39006C1 IS + BEGIN + IF VAR = IDENT_INT(1) THEN + ADD1 (VAR); + FAILED ("PROGRAM_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END C39006C1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C39006D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A FUNCTION IS USED IN A DEFAULT EXPRESSION FOR A + -- SUBPROGRAM OR FORMAL GENERIC PARAMETER, PROGRAM_ERROR IS RAISED + -- WHEN AN ATTEMPT IS MADE TO EVALUATE THE DEFAULT EXPRESSION, + -- BECAUSE THE FUNCTION'S BODY HAS NOT BEEN ELABORATED YET. + + -- TBN 8/20/86 + + WITH REPORT; USE REPORT; + PROCEDURE C39006D IS + + BEGIN + TEST ("C39006D", "CHECK THAT IF A FUNCTION IS USED IN A DEFAULT " & + "EXPRESSION FOR A SUBPROGRAM OR FORMAL GENERIC " & + "PARAMETER, PROGRAM_ERROR IS RAISED WHEN AN " & + "ATTEMPT IS MADE TO EVALUATE THE DEFAULT " & + "EXPRESSION"); + DECLARE + FUNCTION FUN RETURN INTEGER; + + PACKAGE P IS + PROCEDURE DEFAULT (A : INTEGER := FUN); + END P; + + PACKAGE BODY P IS + PROCEDURE DEFAULT (A : INTEGER := FUN) IS + B : INTEGER := 1; + BEGIN + B := B + IDENT_INT(A); + END DEFAULT; + BEGIN + DEFAULT (2); + DEFAULT; + FAILED ("PROGRAM_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END P; + + FUNCTION FUN RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END FUN; + BEGIN + NULL; + END; + + BEGIN + DECLARE + FUNCTION INIT_1 RETURN INTEGER; + + GENERIC + LENGTH : INTEGER := INIT_1; + PACKAGE P IS + TYPE ARRAY1 IS ARRAY (1 .. LENGTH) OF INTEGER; + END P; + + PACKAGE NEW_P1 IS NEW P (4); + PACKAGE NEW_P2 IS NEW P; + + FUNCTION INIT_1 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(2)); + END INIT_1; + + BEGIN + FAILED ("PROGRAM_ERROR NOT RAISED - 2"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + DECLARE + FUNCTION INIT_2 RETURN INTEGER; + + GLOBAL_INT : INTEGER := IDENT_INT(1); + + GENERIC + PACKAGE Q IS + PROCEDURE ADD1 (A : INTEGER := INIT_2); + END Q; + + PACKAGE BODY Q IS + PROCEDURE ADD1 (A : INTEGER := INIT_2) IS + B : INTEGER; + BEGIN + B := A; + END ADD1; + BEGIN + IF GLOBAL_INT = IDENT_INT(1) THEN + ADD1; + FAILED ("PROGRAM_ERROR NOT RAISED - 3"); + ELSE + ADD1 (2); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END Q; + + PACKAGE NEW_Q IS NEW Q; + + FUNCTION INIT_2 RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(1)); + END INIT_2; + + BEGIN + NULL; + END; + + RESULT; + END C39006D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- C39006E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS NOT RAISED IF A SUBPROGRAM'S BODY HAS + -- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: + -- A) A SUBPROGRAM CAN APPEAR IN A NON-ELABORATED DECLARATIVE PART + -- OR PACKAGE SPECIFICATION BEFORE ITS BODY. + + -- TBN 8/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE C39006E IS + + BEGIN + TEST ("C39006E", "CHECK THAT PROGRAM_ERROR IS NOT RAISED IF A " & + "SUBPROGRAM IS CALLED IN A NON-ELABORATED " & + "DECLARATIVE PART OR PACKAGE SPECIFICATION " & + "BEFORE ITS BODY IS ELABORATED"); + DECLARE -- (A) + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER; + + PACKAGE P IS + PROCEDURE USE_INIT1; + END P; + + PACKAGE BODY P IS + PROCEDURE USE_INIT1 IS + BEGIN + IF NOT EQUAL (3, 3) THEN + DECLARE + X : INTEGER := INIT_1 (1); + BEGIN + NULL; + END; + ELSE + NULL; + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END USE_INIT1; + + BEGIN + USE_INIT1; + END P; + + FUNCTION INIT_1 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_1; + + BEGIN -- (A) + NULL; + END; -- (A) + + DECLARE -- (B) + + PROCEDURE INIT_2 (A : IN OUT INTEGER); + + PACKAGE P IS + FUNCTION USE_INIT2 RETURN BOOLEAN; + END P; + + PACKAGE BODY P IS + FUNCTION USE_INIT2 RETURN BOOLEAN IS + BEGIN + IF NOT EQUAL (3, 3) THEN + DECLARE + X : INTEGER; + BEGIN + INIT_2 (X); + END; + END IF; + RETURN IDENT_BOOL (FALSE); + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 2"); + RETURN FALSE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + RETURN FALSE; + END USE_INIT2; + BEGIN + IF USE_INIT2 THEN + FAILED ("INCORRECT RESULTS FROM FUNCTION CALL - 2"); + END IF; + END P; + + PROCEDURE INIT_2 (A : IN OUT INTEGER) IS + BEGIN + A := A + IDENT_INT(1); + END INIT_2; + + BEGIN -- (B) + NULL; + END; -- (B) + + DECLARE -- (C) + FUNCTION INIT_3 RETURN INTEGER; + + PACKAGE Q IS + VAR : INTEGER; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF NOT EQUAL (3, 3) THEN + VAR := INIT_3; + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END Q; + + FUNCTION INIT_3 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END INIT_3; + + BEGIN -- (C) + NULL; + END; -- (C) + + DECLARE -- (D) + PROCEDURE INIT_4 (A : IN OUT INTEGER); + + PACKAGE Q IS + VAR : INTEGER := 1; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF NOT EQUAL (3, 3) THEN + INIT_4 (VAR); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 4"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END Q; + + PROCEDURE INIT_4 (A : IN OUT INTEGER) IS + BEGIN + A := IDENT_INT (4); + END INIT_4; + + BEGIN -- (D) + NULL; + END; -- (D) + + BEGIN -- (E) + + DECLARE + FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER; + + PROCEDURE USE_INIT5 IS + PACKAGE Q IS + X : INTEGER := INIT_5 (1); + END Q; + USE Q; + BEGIN + X := IDENT_INT (5); + + END USE_INIT5; + + FUNCTION INIT_5 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (A + IDENT_INT(1)); + END INIT_5; + + BEGIN + USE_INIT5; + END; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 5"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + + END; -- (E) + + RESULT; + END C39006E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f0.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + -- C39006F0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS + -- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: + -- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO + -- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE + -- SUBPROGRAM. + + -- THIS SUBPROGRAM LIBRARY UNIT IS USED BY C39006F2.ADA. + + -- HISTORY: + -- TBN 08/22/86 CREATED ORIGINAL TEST. + -- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL + -- TO 'TEST'. + + WITH REPORT; USE REPORT; + + FUNCTION C39006F0 (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT(A)); + END C39006F0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f1.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + -- C39006F1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS + -- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: + -- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO + -- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE + -- SUBPROGRAM. + + -- THIS LIBRARY PACKAGE SPECIFICATION IS USED BY C39006F3M.ADA. + + -- HISTORY: + -- TBN 08/22/86 CREATED ORIGINAL TEST. + -- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL + -- TO 'TEST'. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + PACKAGE C39006F1 IS + PROCEDURE REQUIRE_BODY; + END C39006F1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f2.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C39006F2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS + -- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: + -- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO + -- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE + -- SUBPROGRAM. + + -- THIS LIBRARY PACKAGE BODY IS USED BY C39006F3M.ADA. + + -- HISTORY: + -- TBN 08/22/86 CREATED ORIGINAL TEST. + -- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL + -- TO 'TEST'. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + WITH C39006F0; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (C39006F0, REPORT); + + PACKAGE BODY C39006F1 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + BEGIN + TEST ("C39006F", "CHECK THAT NO PROGRAM_ERROR IS RAISED IF A " & + "SUBPROGRAM'S BODY HAS BEEN ELABORATED " & + "BEFORE IT IS CALLED, WHEN A SUBPROGRAM " & + "LIBRARY UNIT IS USED IN ANOTHER UNIT AND " & + "PRAGMA ELABORATE IS USED"); + BEGIN + DECLARE + VAR1 : INTEGER := C39006F0 (IDENT_INT(1)); + BEGIN + IF VAR1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + END; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + VAR2 : INTEGER := 1; + + PROCEDURE CHECK (B : IN OUT INTEGER) IS + BEGIN + B := C39006F0 (IDENT_INT(2)); + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END CHECK; + BEGIN + CHECK (VAR2); + IF VAR2 /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + END; + + DECLARE + PACKAGE P IS + VAR3 : INTEGER; + END P; + + PACKAGE BODY P IS + BEGIN + VAR3 := C39006F0 (IDENT_INT(3)); + IF VAR3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 3"); + END P; + BEGIN + NULL; + END; + + DECLARE + GENERIC + VAR4 : INTEGER := 1; + PACKAGE Q IS + TYPE ARRAY_TYP1 IS ARRAY (1 .. VAR4) OF INTEGER; + ARRAY_1 : ARRAY_TYP1; + END Q; + + PACKAGE NEW_Q IS NEW Q (C39006F0 (IDENT_INT(4))); + + USE NEW_Q; + + BEGIN + IF ARRAY_1'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + END; + + END C39006F1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006f3.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + -- C39006F3M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO PROGRAM_ERROR IS RAISED IF A SUBPROGRAM'S BODY HAS + -- BEEN ELABORATED BEFORE IT IS CALLED. CHECK THE FOLLOWING: + -- B) FOR A SUBPROGRAM LIBRARY UNIT USED IN ANOTHER UNIT, NO + -- PROGRAM_ERROR IS RAISED IF PRAGMA ELABORATE NAMES THE + -- SUBPROGRAM. + + -- SEPARATE FILES ARE: + -- C39006F0 A LIBRARY FUNCTION. + -- C39006F1 A LIBRARY PACKAGE SPECIFICATION. + -- C39006F2 A LIBRARY PACKAGE BODY. + -- C39006F3M (THIS FILE) THE MAIN PROCEDURE. + + -- HISTORY: + -- TBN 08/22/86 CREATED ORIGINAL TEST. + -- BCB 03/29/90 CORRECTED HEADER. CHANGED TEST NAME IN CALL + -- TO 'TEST'. + + WITH C39006F1; + WITH REPORT; USE REPORT; + + PROCEDURE C39006F3M IS + BEGIN + RESULT; + END C39006F3M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39006g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39006g.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C39006G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO CALL A + -- SUBPROGRAM WHOSE BODY IS NOT YET ELABORATED. USE A PACKAGE + -- WITH OPTIONAL BODY, WHERE THE SUBPROGRAM IS CALLED IN THE BODY. + + -- HISTORY: + -- BCB 08/01/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C39006G IS + + PROCEDURE INIT (X : IN OUT INTEGER); + + PACKAGE P IS + END P; + + PACKAGE BODY P IS + X : INTEGER := IDENT_INT(5); + BEGIN + TEST ("C39006G", "CHECK THAT PROGRAM_ERROR IS RAISED BY " & + "AN ATTEMPT TO CALL A SUBPROGRAM WHOSE " & + "BODY IS NOT YET ELABORATED. USE A " & + "PACKAGE WITH OPTIONAL BODY, WHERE THE " & + "SUBPROGRAM IS CALLED IN THE BODY"); + INIT(X); + FAILED ("NO EXCEPTION RAISED"); + IF X /= IDENT_INT(10) THEN + COMMENT ("TOTALLY IRRELEVANT"); + END IF; + RESULT; + EXCEPTION + WHEN PROGRAM_ERROR => + RESULT; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION WAS RAISED"); + RESULT; + END P; + + PROCEDURE INIT (X : IN OUT INTEGER) IS + BEGIN + X := IDENT_INT(10); + END INIT; + + BEGIN + NULL; + END C39006G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39007a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C39007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS RAISED IF AN ATTEMPT IS MADE TO + -- INSTANTIATE A GENERIC UNIT WHOSE BODY HAS NOT BEEN ELABORATED. + -- CHECK THE FOLLOWING CASE: + -- A) A SIMPLE CASE WHERE THE GENERIC UNIT BODY OCCURS LATER IN + -- THE SAME DECLARATIVE PART. + + -- TBN 9/12/86 + + WITH REPORT; USE REPORT; + PROCEDURE C39007A IS + + BEGIN + TEST ("C39007A", "CHECK THAT PROGRAM_ERROR IS RAISED IF AN " & + "ATTEMPT IS MADE TO INSTANTIATE A GENERIC " & + "UNIT WHOSE BODY HAS NOT BEEN ELABORATED, " & + "BUT OCCURS IN THE SAME DECLARATIVE PART"); + + BEGIN + IF EQUAL (1, 1) THEN + DECLARE + GENERIC + PACKAGE P IS + A : INTEGER; + PROCEDURE ASSIGN (X : OUT INTEGER); + END P; + + PACKAGE NEW_P IS NEW P; + + PACKAGE BODY P IS + PROCEDURE ASSIGN (X : OUT INTEGER) IS + BEGIN + X := IDENT_INT (1); + END ASSIGN; + BEGIN + ASSIGN (A); + END P; + + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 1"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + ------------------------------------------------------------------------ + + BEGIN + IF EQUAL (2, 2) THEN + DECLARE + GENERIC + PROCEDURE ADD1 (X : IN OUT INTEGER); + + PROCEDURE NEW_ADD1 IS NEW ADD1; + + PROCEDURE ADD1 (X : IN OUT INTEGER) IS + BEGIN + X := X + IDENT_INT (1); + END ADD1; + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 2"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------------ + + BEGIN + IF EQUAL (3, 3) THEN + DECLARE + GENERIC + FUNCTION INIT RETURN INTEGER; + + FUNCTION NEW_INIT IS NEW INIT; + + FUNCTION INIT RETURN INTEGER IS + BEGIN + RETURN (IDENT_INT (1)); + END INIT; + BEGIN + NULL; + END; + FAILED ("PROGRAM_ERROR WAS NOT RAISED - 3"); + END IF; + + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + ------------------------------------------------------------------------ + + RESULT; + END C39007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39007b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39007b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39007b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39007b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C39007B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO INSTANTIATE + -- A GENERIC UNIT WHOSE BODY IS NOT YET ELABORATED. USE A GENERIC + -- UNIT THAT IS DECLARED AND INSTANTIATED IN A PACKAGE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 08/01/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C39007B IS + + BEGIN + TEST ("C39007B", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " & + "ATTEMPT TO INSTANTIATE A GENERIC UNIT WHOSE " & + "BODY IS NOT YET ELABORATED. USE A GENERIC " & + "UNIT THAT IS DECLARED AND INSTANTIATED IN A " & + "PACKAGE SPECIFICATION"); + + DECLARE + BEGIN + DECLARE + PACKAGE P IS + GENERIC + FUNCTION F RETURN BOOLEAN; + + FUNCTION NEW_F IS NEW F; + END P; + + PACKAGE BODY P IS + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F; + END P; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + DECLARE + X : BOOLEAN := IDENT_BOOL(FALSE); + BEGIN + X := P.NEW_F; + IF X /= IDENT_BOOL(TRUE) THEN + COMMENT ("NOT RELEVANT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE"); + END; + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; + END C39007B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C39008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PROGRAM_ERROR IS RAISED BY AN ATTEMPT TO ACTIVATE + -- A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE CASE IN + -- WHICH A TASK VARIABLE IS DECLARED IN A PACKAGE SPECIFICATION AND + -- THE PACKAGE BODY OCCURS BEFORE THE TASK BODY. + + -- HISTORY: + -- BCB 01/21/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C39008A IS + + BEGIN + TEST ("C39008A", "CHECK THAT PROGRAM_ERROR IS RAISED BY AN " & + "ATTEMPT TO ACTIVATE A TASK BEFORE ITS BODY " & + "HAS BEEN ELABORATED. CHECK THE CASE IN WHICH " & + "A TASK VARIABLE IS DECLARED IN A PACKAGE " & + "SPECIFICATION AND THE PACKAGE BODY OCCURS " & + "BEFORE THE TASK BODY"); + + BEGIN + DECLARE + TASK TYPE T; + + PACKAGE P IS + X : T; + END P; + + PACKAGE BODY P IS + END P; -- PROGRAM_ERROR. + + TASK BODY T IS + BEGIN + COMMENT ("TASK MESSAGE"); + END T; + BEGIN + FAILED ("PROGRAM_ERROR WAS NOT RAISED"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR WAS RAISED"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " & + "RAISED"); + END; + + RESULT; + END C39008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C39008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE ACTIVATION OF A TASK IS ATTEMPTED BEFORE THE + -- ELABORATION OF THE CORRESPONDING BODY IS FINISHED, THE EXCEPTION + -- PROGRAM_ERROR IS RAISED, NOT TASKING_ERROR (SEE AI-00149). + + -- WEI 3/04/82 + -- JBG 2/17/84 + -- EG 11/02/84 + -- JBG 5/23/85 + -- JWC 6/28/85 RENAMED FROM C93007B-B.ADA + + WITH REPORT; + USE REPORT; + + PROCEDURE C39008B IS + + BEGIN + + TEST ("C39008B", "PROGRAM_ERROR AFTER ATTEMPT OF ACTIVATION " & + "BEFORE ELABORATION"); + BLOCK1: + BEGIN + BLOCK2: + DECLARE + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + + POINTER_TT1 : ATT1 := NEW TT1; -- ACCESSING TASK BODY + -- BEFORE ITS ELABORATION + + TASK BODY TT1 IS + BEGIN + FAILED ("TT1 ACTIVATED"); + END TT1; + + BEGIN + + FAILED ("TT1 ACTIVATED - 2"); + + END BLOCK2; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END BLOCK1; + + RESULT; + + END C39008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c39008c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c39008c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C39008C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PROGRAM_ERROR IS RAISED WHEN AN ATTEMPT IS MADE TO + -- ACTIVATE A TASK BEFORE ITS BODY HAS BEEN ELABORATED. CHECK THE + -- CASE IN WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND ONLY SOME + -- HAVE UNELABORATED BODIES; NO TASKS SHOULD BE ACTIVATED. + + -- HISTORY: + -- BCB 07/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C39008C IS + + BEGIN + TEST ("C39008C", "CHECK THAT PROGRAM_ERROR IS RAISED WHEN AN " & + "ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS " & + "BODY HAS BEEN ELABORATED. CHECK THE CASE IN " & + "WHICH SEVERAL TASKS ARE TO BE ACTIVATED, AND " & + "ONLY SOME HAVE UNELABORATED BODIES; NO TASKS " & + "SHOULD BE ACTIVATED"); + + BEGIN + DECLARE + TASK TYPE A; + + TASK TYPE B; + + TASK TYPE C; + + TASK TYPE D; + + PACKAGE P IS + W : A; + X : B; + Y : C; + Z : D; + END P; + + TASK BODY A IS + BEGIN + FAILED ("TASK A ACTIVATED"); + END A; + + TASK BODY D IS + BEGIN + FAILED ("TASK D ACTIVATED"); + END D; + + PACKAGE BODY P IS + END P; + + TASK BODY B IS + BEGIN + FAILED ("TASK B ACTIVATED"); + END B; + + TASK BODY C IS + BEGIN + FAILED ("TASK C ACTIVATED"); + END C; + BEGIN + FAILED ("PROGRAM_ERROR WAS NOT RAISED"); + END; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN PROGRAM_ERROR WAS " & + "RAISED"); + END; + + RESULT; + END C39008C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- C390A010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C390A011.AM. + -- + -- TEST DESCRIPTION: + -- See C390A011.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- => C390A010.A + -- C390A011.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with F390A00; -- Alert system abstraction. + package C390A010 is + + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; -- Record extension of + end record; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + + -- Declarations required for component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; -- Record extension of + end record; -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + end C390A010; + + + --==================================================================-- + + + package body C390A010 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's op (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + + end C390A010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a011.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a011.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a011.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a011.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,218 ---- + -- C390A011.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a nonprivate tagged type declared in a package specification + -- may be extended with a record extension in a different package + -- specification, and that this record extension may in turn be extended + -- by a record extension. + -- + -- Check that each derivative inherits the user-defined primitive + -- subprograms of its parent (including those that its parent inherited), + -- that it may override these inherited primitive subprograms, and that it + -- may also declare its own primitive subprograms. + -- + -- Check that predefined equality operators are defined for the tagged + -- type and its derivatives. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type and two associated primitive subprograms + -- in a package specification (foundation code). + -- + -- Extend the root type with a record extension in a different package + -- specification. Declare a new primitive subprogram for the extension, + -- and override one of the two inherited subprograms. Within the + -- overriding subprogram, utilize type conversion to call the parent's + -- implementation of the same subprogram. Also within the overriding + -- subprogram, call the new primitive subprogram and each inherited + -- subprogram. + -- + -- Extend the extension with a record extension in the same package + -- specification. Declare a new primitive subprogram for this second + -- extension, and override one of the three inherited subprograms. + -- Within the overriding subprogram, utilize type conversion to call the + -- parent's implementation of the same subprogram. Also within the + -- overriding subprogram, call the new primitive subprogram and each + -- inherited subprogram. + -- + -- In the main program, declare objects of the root tagged type + -- and the two type extensions. For each object, call the overriding + -- subprogram, and verify the correctness of the components by using + -- aggregates and equality operators, or by checking the components + -- directly. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- C390A010.A + -- => C390A011.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + with F390A00; -- Basic alert abstraction. + with C390A010; -- Extended alert abstraction. + + use F390A00; -- Primitive operations of Alert_Type directly visible. + + with Ada.Calendar; + + procedure C390A011 is + use type Ada.Calendar.Time; -- Equality/inequality ops directly visible. + begin + + Report.Test ("C390A01", "Primitive operation inheritance by type " & + "extensions: all extensions declared in same package, " & + "but a different package from that of root type"); + + + ALERT_SUBTEST: ------------------------------------------------------------- + + declare + Alarm : F390A00.Alert_Type; -- Root tagged type. + begin + + -- Check "/=" operator availability. Aggregate with positional + -- associations: + if Alarm /= (Default_Time, Null_Device) then + Report.Failed ("Wrong initial values for Alert_Type"); + end if; + + Handle (Alarm); + + -- Check "=" operator availability. Aggregate with named + -- associations: + if not (Alarm = (Arrival_Time => Alert_Time, + Display_On => Null_Device)) + then + Report.Failed ("Wrong values for Alert_Type after Handle"); + end if; + + end Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For (Null_Device) /= 1 or + F390A00.Display_Count_For (Teletype) /= 0 or + F390A00.Display_Count_For (Console) /= 0 or + F390A00.Display_Count_For (Big_Screen) /= 0 + then + Report.Failed ("Wrong display counts after Alert_Type"); + end if; + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A010.Low_Alert_Type; -- Extension of tagged type. + use C390A010; -- Primitive operations of extension directly visible. + begin + + -- Check "=" operator availability. Aggregate with positional + -- associations: + if not (Low_Alarm = (Default_Time, Null_Device, 0)) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + -- Check component availability: + if Low_Alarm.Arrival_Time /= Alert_Time or + Low_Alarm.Display_On /= Teletype or + Low_Alarm.Level /= 1 + then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A010.Medium_Alert_Type; -- Extension of extension. + use C390A010; -- Primitive operations of extension directly visible. + begin + + -- Check component availability: + if Medium_Alarm.Level /= 0 or + Medium_Alarm.Arrival_Time /= Default_Time or + Medium_Alarm.Action_Officer /= Nobody or + Medium_Alarm.Display_On /= Null_Device + then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + -- Check "/=" operator availability. Aggregate with named + -- associations: + if Medium_Alarm /= (Arrival_Time => Alert_Time, + Display_On => Console, + Level => 2, + Action_Officer => Duty_Officer) + then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 3, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + + end C390A011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a020.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C390A020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C390A022.AM. + -- + -- TEST DESCRIPTION: + -- See C390A022.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- => C390A020.A + -- C390A021.A + -- C390A022.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with F390A00; -- Alert system abstraction. + package C390A020 is + + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; -- Record extension of + end record; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + end C390A020; + + + --==================================================================-- + + + package body C390A020 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's oper. (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + + end C390A020; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a021.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C390A021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C390A022.AM. + -- + -- TEST DESCRIPTION: + -- See C390A022.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- C390A020.A + -- => C390A021.A + -- C390A022.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with C390A020; -- Extended alert abstraction. + package C390A021 is + + + -- Declarations used by component Action_Officer; + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new C390A020.Low_Alert_Type + with private; -- Private extension of + -- record extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; + + function Bad_Final_Values (MA : in Medium_Alert_Type) + return Boolean; + + + private + + type Medium_Alert_Type is new C390A020.Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + + end C390A021; + + + --==================================================================-- + + + with F390A00; -- Basic alert abstraction. + use F390A00; + package body C390A021 is + + use C390A020; -- Extended alert abstraction. + + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + return (MA = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device, -- availability. + Level => 0, -- Aggregate with + Action_Officer => Nobody)); -- named associations. + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + begin + return (MA /= (Alert_Time, Console, -- Check "/=" operator + 2 , Duty_Officer)); -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + + end C390A021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a022.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a022.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a022.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a022.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- C390A022.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a nonprivate tagged type declared in a package specification + -- may be extended with a record extension in a different package + -- specification, and that this record extension may in turn be extended + -- by a private extension in a third package. + -- + -- Check that each derivative inherits the user-defined primitive + -- subprograms of its parent (including those that its parent inherited), + -- that it may override these inherited primitive subprograms, and that it + -- may also declare its own primitive subprograms. + -- + -- Check that predefined equality operators are defined for the tagged + -- type and its derivatives. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type and two associated primitive subprograms + -- in a package specification (foundation code). + -- + -- Extend the root type with a record extension in a different package + -- specification. Declare a new primitive subprogram for the extension, + -- and override one of the two inherited subprograms. Within the + -- overriding subprogram, utilize type conversion to call the parent's + -- implementation of the same subprogram. Also within the overriding + -- subprogram, call the new primitive subprogram and each inherited + -- subprogram. + -- + -- Extend the extension with a private extension in a third package + -- specification. Declare a new primitive subprogram for this private + -- extension, and override one of the three inherited subprograms. + -- Within the overriding subprogram, utilize type conversion to call the + -- parent's implementation of the same subprogram. Also within the + -- overriding subprogram, call the new primitive subprogram and each + -- inherited subprogram. + -- + -- Also in the third package, declare two operations of the private + -- extension which utilize aggregates and equality operators to verify + -- the correctness of the components. + -- + -- In the main program, declare objects of the two extended types. + -- For each object, call the overriding subprogram, and verify the + -- correctness of the components by using aggregates and equality + -- operators, or by checking the components directly, or, for the private + -- extension, by calling the verification operations declared in the + -- third package. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- C390A020.A + -- C390A021.A + -- => C390A022.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + with F390A00; -- Basic alert abstraction. + with C390A020; -- Extended alert abstraction. + with C390A021; -- Further extended alert abstraction. + + use F390A00; -- Primitive operations of Alert_Type directly visible. + + with Ada.Calendar; + + procedure C390A022 is + use type Ada.Calendar.Time; -- Equality/inequality ops directly visible. + begin + + Report.Test ("C390A02", "Primitive operation inheritance by type " & + "extensions: all extensions declared in different " & + "packages; second extension is private"); + + + -- The case for type F390A00.Alert_Type is tested in C390A01. + -- That subtest is not repeated here. + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A020.Low_Alert_Type; -- Extension of tagged type. + use C390A020; -- Primitive operations of extension directly visible. + begin + + -- Check "=" operator availability. Aggregate with positional + -- associations: + if not (Low_Alarm = (Default_Time, Null_Device, 0)) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + -- Check component availability: + if Low_Alarm.Arrival_Time /= Alert_Time or + Low_Alarm.Display_On /= Teletype or + Low_Alarm.Level /= 1 + then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert_Type"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A021.Medium_Alert_Type; -- Priv. ext. of extension. + use C390A021; -- Primitive operations of extension directly visible. + begin + if not C390A021.Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if C390A021.Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + + end C390A022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a030.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a030.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a030.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a030.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- C390A030.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See C390A031.AM. + -- + -- TEST DESCRIPTION: + -- See C390A031.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- => C390A030.A + -- C390A031.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with F390A00; -- Alert system abstraction. + package C390A030 is + + + type Low_Alert_Type is new F390A00.Alert_Type -- Private extension of + with private; -- root tagged type. + + -- Inherits procedure Display from Alert_Type. + + procedure Handle (LA : in out Low_Alert_Type); -- Override parent's + -- primitive subprog. + + function Level_Of (LA : in Low_Alert_Type) -- To be inherited by + return Integer; -- all derivatives. + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (LA : in Low_Alert_Type) + return Boolean; + + function Bad_Final_Values (LA : in Low_Alert_Type) + return Boolean; + + + -- Declarations used by private extension component. + + type Person_Enum is (Nobody, Duty_Officer, + Watch_Commander, Commanding_Officer); + + + type Medium_Alert_Type is new Low_Alert_Type -- Private extension of + with private; -- private extension. + + -- Inherits (inherited) procedure Display from Low_Alert_Type. + -- Inherits function Level_Of from Low_Alert_Type. + + procedure Handle (MA : in out Medium_Alert_Type); -- Override parent's + -- primitive subprog. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum); + + + -- The following two functions are needed to verify the values of the + -- extension's private components. + + function Initial_Values_Okay (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- operation. + + function Bad_Final_Values (MA : in Medium_Alert_Type) + return Boolean; -- Override parent's + -- operation. + + private + + type Low_Alert_Type is new F390A00.Alert_Type with record + Level : Integer := 0; + end record; + + + type Medium_Alert_Type is new Low_Alert_Type with record + Action_Officer : Person_Enum := Nobody; + end record; + + end C390A030; + + + --==================================================================-- + + + package body C390A030 is + + use F390A00; -- Alert system abstraction. + + + function Level_Of (LA : in Low_Alert_Type) return Integer is + begin + return (LA.Level + 1); + end Level_Of; + + + procedure Handle (LA : in out Low_Alert_Type) is + begin + Handle (Alert_Type (LA)); -- Call parent's operation (type conversion). + LA.Level := Level_Of (LA); -- Call newly declared operation. + LA.Display_On := Teletype; + Display (LA); -- Call inherited operation. + end Handle; + + + function Initial_Values_Okay (LA : in Low_Alert_Type) return Boolean is + begin + return (LA = (Arrival_Time => Default_Time, -- Check "=" operator + Display_On => Null_Device, -- availability. + Level => 0)); -- Aggregate with + end Initial_Values_Okay; -- named associations. + + + function Bad_Final_Values (LA : in Low_Alert_Type) return Boolean is + begin + return (LA /= (Alert_Time, Teletype, 1)); -- Check "/=" operator + -- availability. + end Bad_Final_Values; -- Aggregate with + -- positional assoc. + + procedure Assign_Officer (MA : in out Medium_Alert_Type; + To : in Person_Enum) is + begin + MA.Action_Officer := To; + end Assign_Officer; + + + procedure Handle (MA : in out Medium_Alert_Type) is + begin + Handle (Low_Alert_Type (MA)); -- Call parent's op (type conversion). + MA.Level := Level_Of (MA); -- Call inherited operation. + Assign_Officer (MA, Duty_Officer); -- Call newly declared operation. + MA.Display_On := Console; + Display (MA); -- Call twice-inherited operation. + end Handle; + + + function Initial_Values_Okay (MA : in Medium_Alert_Type) return Boolean is + begin + -- Call parent's operation (type conversion). + return (Initial_Values_Okay (Low_Alert_Type (MA)) and + MA.Action_Officer = Nobody); + end Initial_Values_Okay; + + + function Bad_Final_Values (MA : in Medium_Alert_Type) return Boolean is + begin + return not (MA = (Arrival_Time => Alert_Time, -- Check "=" operator + Display_On => Console, -- availability. + Level => 2, -- Aggregate with + Action_Officer => Duty_Officer));-- named associations. + end Bad_Final_Values; + + + end C390A030; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a031.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a031.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c390a031.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c390a031.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- C390A031.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a nonprivate tagged type declared in a package specification + -- may be extended with a private extension in a different package + -- specification, and that this private extension may in turn be extended + -- by a private extension. + -- + -- Check that each derivative inherits the user-defined primitive + -- subprograms of its parent (including those that its parent inherited), + -- that it may override these inherited primitive subprograms, and that it + -- may also declare its own primitive subprograms. + -- + -- Check that predefined equality operators are defined for the tagged + -- type and its derivatives. + -- + -- Check that type conversion is defined from a type extension to its + -- parent, and that this parent itself may be a type extension. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type and two associated primitive subprograms + -- in a package specification (foundation code). + -- + -- Extend the root type with a private extension in a different package + -- specification. Declare a new primitive subprogram for the extension, + -- and override one of the two inherited subprograms. Within the + -- overriding subprogram, utilize type conversion to call the parent's + -- implementation of the same subprogram. Also within the overriding + -- subprogram, call the new primitive subprogram and each inherited + -- subprogram. Declare operations of the private extension which utilize + -- aggregates and equality operators to verify the correctness of the + -- components. + -- + -- Extend the extension with a private extension in the same package + -- specification. Declare a new primitive subprogram for this second + -- extension, and override one of the three inherited subprograms. + -- Within the overriding subprogram, utilize type conversion to call the + -- parent's implementation of the same subprogram. Also within the + -- overriding subprogram, call the new primitive subprogram and each + -- inherited subprogram. Declare operations of the private extension + -- which override the verification operations of its parent. Within + -- these overriding operations, utilize type conversion to call the + -- parent's implementations of the same operations. + -- + -- In the main program, declare objects of the two extended types. + -- For each object, call the overriding subprogram, and verify the + -- correctness of the components by calling the verification operations + -- declared in the second package. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- F390A00.A + -- C390A030.A + -- => C390A031.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jun 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + with F390A00; -- Basic alert abstraction. + with C390A030; -- Extended alert abstraction. + + use F390A00; -- Primitive operations of Alert_Type directly visible. + + procedure C390A031 is + begin + + Report.Test ("C390A03", "Primitive operation inheritance by type " & + "extensions: all extensions are private and declared " & + "in same package, but a different package from that " & + "of root type"); + + + -- The case for type F390A00.Alert_Type is tested in C390A01. + -- That subtest is not repeated here. + + + LOW_ALERT_SUBTEST: --------------------------------------------------------- + + declare + Low_Alarm : C390A030.Low_Alert_Type; -- Priv. ext. of tagged type. + use C390A030; -- Primitive operations of extension directly visible. + begin + if not C390A030.Initial_Values_Okay (Low_Alarm) then + Report.Failed ("Wrong initial values for Low_Alert_Type"); + end if; + + Handle (Low_Alarm); + + if C390A030.Bad_Final_Values (Low_Alarm) then + Report.Failed ("Wrong values for Low_Alert_Type after Handle"); + end if; + end Low_Alert_Subtest; + + + -- Check intermediate display counts: + + if F390A00.Display_Count_For /= (Null_Device => 1, + Teletype => 1, + Console => 0, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Low_Alert"); + end if; + + + MEDIUM_ALERT_SUBTEST: ------------------------------------------------------ + + declare + Medium_Alarm : C390A030.Medium_Alert_Type; -- Priv. ext. of extension. + use C390A030; -- Primitive operations of extension directly visible. + begin + if not C390A030.Initial_Values_Okay (Medium_Alarm) then + Report.Failed ("Wrong initial values for Medium_Alert_Type"); + end if; + + Handle (Medium_Alarm); + + if C390A030.Bad_Final_Values (Medium_Alarm) then + Report.Failed ("Wrong values for Medium_Alert_Type after Handle"); + end if; + end Medium_Alert_Subtest; + + + -- Check final display counts: + + if F390A00.Display_Count_For /= (Null_Device => 2, + Teletype => 2, + Console => 1, + Big_Screen => 0) + then + Report.Failed ("Wrong display counts after Medium_Alert_Type"); + end if; + + + Report.Result; + + end C390A031; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c391001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c391001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c391001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c391001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,329 ---- + -- C391001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that structures nesting discriminated records as + -- components in record extension are correctly supported. Check + -- for this using limited private structures. + -- Check that record extensions inherit all the visible components + -- of their ancestor types. + -- Check that discriminants are correctly inherited. + -- + -- TEST DESCRIPTION: + -- This test defines a textbook object, a serial number plaque. + -- This object is used in each of several other structures modeled + -- after those used in an existing antenna modeling software system. + -- Record types discriminated and undiscriminated are nested to + -- produce a layered design. Some parametrization is programmatic; + -- some parametrization is data-driven. + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 19 Apr 95 SAIC Added "limited" to full type def of "Object" + -- + --! + + package C391001_1 is + type Object is tagged limited private; + -- Constructor operation + procedure Create( The_Plaque : in out Object ); + -- Selector operations + function "="( Left_Plaque,Right_Plaque : Object ) return Boolean; + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean; + function Serial_Number( A_Plaque : Object ) return Natural; + Unserialized : exception; -- Serial_Number called before Create + Reserialized : exception; -- Create called twice + private + type Object is tagged limited record + Serial_Number : Natural := 0; + end record; + end C391001_1; + + package body C391001_1 is + Counter : Natural := 0; + procedure Create( The_Plaque : in out Object ) is + begin + if The_Plaque.Serial_Number = 0 then + Counter := Counter +1; + The_Plaque.Serial_Number := Counter; + else + raise Reserialized; + end if; + end Create; + + function "="( Left_Plaque,Right_Plaque : Object ) return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Plaque.Serial_Number) + and then -- two uninitialized plates are unequal + (Left_Plaque.Serial_Number /= 0); + end "="; + + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Natural); + end TC_Match; + + function Serial_Number( A_Plaque : Object ) return Natural is + begin + if A_Plaque.Serial_Number = 0 then + raise Unserialized; + end if; + return A_Plaque.Serial_Number; + end Serial_Number; + end C391001_1; + + with C391001_1; + package C391001_2 is -- package Boards is + + package Plaque renames C391001_1; + + type Modes is (Receiving, Transmitting, Standby); + type Link(Mode: Modes := Standby) is record + case Mode is + when Receiving => TC_R : Integer := 100; + when Transmitting => TC_T : Integer := 200; + when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA + end case; + end record; + + type Data_Formats is (S_Band, KU_Band, UHF); + + + type Transceiver(Band: Data_Formats) is tagged limited record + ID : Plaque.Object; + The_Link: Link; + case Band is + when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA + when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA + when UHF => TC_UHF_Data : Integer := 3; + end case; + end record; + end C391001_2; + + with C391001_1; + with C391001_2; + package C391001_3 is -- package Modules + package Plaque renames C391001_1; + package Boards renames C391001_2; + use type Boards.Modes; + use type Boards.Data_Formats; + + type Command_Formats is ( Set_Compression_Code, + Set_Data_Rate, + Set_Power_State ); + + type Electronics_Module(EBand : Boards.Data_Formats; + The_Command_Format: Command_Formats) + is new Boards.Transceiver(EBand) with record + case The_Command_Format is + when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA + when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA + when Set_Power_State => TC_SPS : Integer := 30; -- TSA + end case; + end record; + end C391001_3; + + with Report; + with C391001_1; + with C391001_2; + with C391001_3; + procedure C391001 is + package Plaque renames C391001_1; + package Boards renames C391001_2; + package Modules renames C391001_3; + use type Boards.Modes; + use type Boards.Data_Formats; + use type Modules.Command_Formats; + + type Azimuth is range 0..359; + + type Ground_Antenna(The_Band : Boards.Data_Formats; + The_Command_Format: Modules.Command_Formats) is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command_Format); + Pointing : Azimuth; + end record; + + type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; + The_Command : Modules.Command_Formats + := Modules.Set_Power_State) + is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + end record; + + The_Ground_Antenna : Ground_Antenna (Boards.S_Band, + Modules.Set_Data_Rate); + The_Space_Antenna : Space_Antenna; + Space_Station_Antenna : Space_Antenna (Boards.S_Band, + Modules.Set_Compression_Code); + + + procedure Validate( Condition : Boolean; Message: String ) is + begin + if not Condition then + Report.Failed("Failed " & Message ); + end if; + end Validate; + + begin + Report.Test("C391001", "Check nested tagged discriminated " + & "record structures"); + + Plaque.Create( The_Ground_Antenna.ID ); -- 1 + Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 + Plaque.Create( The_Space_Antenna.ID ); -- 3 + Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 + Plaque.Create( Space_Station_Antenna.ID ); -- 5 + Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 + + The_Ground_Antenna.Pointing := 180; + Validate( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA discr 1" ); + Validate( The_Ground_Antenna.The_Command_Format = Modules.Set_Data_Rate, + "TGA discr 2" ); + Validate( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 1" ); + Validate( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, + "TGA comp 2.discr 1" ); + Validate( The_Ground_Antenna.Electronics.The_Command_Format + = Modules.Set_Data_Rate, "TGA comp 2.discr 2" ); + Validate( The_Ground_Antenna.Electronics.TC_SDR = 20, + "TGA comp 2.1" ); + Validate( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), + "TGA comp 2.inher.1" ); + Validate( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "TGA comp 2.inher.2.discr" ); + Validate( The_Ground_Antenna.Electronics.The_Link.TC_S = 300, + "TGA comp 2.inher.2.1" ); + Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 1, + "TGA comp 2.inher.3" ); + Validate( The_Ground_Antenna.Pointing = 180, "TGA comp 3" ); + + Validate( The_Space_Antenna.The_Band = Boards.KU_Band, "TSA discr 1"); + Validate( The_Space_Antenna.The_Command = Modules.Set_Power_State, + "TSA discr 2"); + Validate( Plaque.TC_Match(The_Space_Antenna.ID,3), + "TSA comp 1"); + Validate( The_Space_Antenna.Electronics.EBand = Boards.KU_Band, + "TSA comp 2.discr 1"); + Validate( The_Space_Antenna.Electronics.The_Command_Format + = Modules.Set_Power_State, "TSA comp 2.discr 2"); + Validate( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), + "TSA comp 2.inher.1"); + Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "TSA comp 2.inher.2.discr"); + Validate( The_Space_Antenna.Electronics.The_Link.TC_S = 300, + "TSA comp 2.inher.2.1"); + Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2, + "TSA comp 2.inher.3"); + Validate( The_Space_Antenna.Electronics.TC_SPS = 30, + "TSA comp 2.1"); + + Validate( Space_Station_Antenna.The_Band = Boards.S_Band, "SSA discr 1"); + Validate( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, + "SSA discr 2"); + Validate( Plaque.TC_Match(Space_Station_Antenna.ID,5), + "SSA comp 1"); + Validate( Space_Station_Antenna.Electronics.EBand = Boards.S_Band, + "SSA comp 2.discr 1"); + Validate( Space_Station_Antenna.Electronics.The_Command_Format + = Modules.Set_Compression_Code, "SSA comp 2.discr 2"); + Validate( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), + "SSA comp 2.inher.1"); + Validate( Space_Station_Antenna.Electronics.The_Link.Mode = Boards.Standby, + "SSA comp 2.inher.2.discr"); + Validate( Space_Station_Antenna.Electronics.The_Link.TC_S = 300, + "SSA comp 2.inher.2.1"); + Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 1, + "SSA comp 2.inher.3"); + Validate( Space_Station_Antenna.Electronics.TC_SCC = 10, + "SSA comp 2.1"); + + The_Ground_Antenna.Electronics.TC_SDR := 1001; + The_Ground_Antenna.Electronics.The_Link := + (Boards.Transmitting,2001); + The_Ground_Antenna.Electronics.TC_S_Band_Data := 3001; + The_Ground_Antenna.Pointing := 41; + + The_Space_Antenna.Electronics.The_Link := (Boards.Receiving,1010); + The_Space_Antenna.Electronics.TC_KU_Band_Data := 2020; + The_Space_Antenna.Electronics.TC_SPS := 3030; + + Space_Station_Antenna.Electronics.The_Link + := The_Space_Antenna.Electronics.The_Link; + Space_Station_Antenna.Electronics.The_Link.TC_R := 111; + Space_Station_Antenna.Electronics.TC_S_Band_Data := 222; + Space_Station_Antenna.Electronics.TC_SCC := 333; + + ---------------------------------------------------------------------- + begin -- should fail discriminant check + The_Ground_Antenna.Electronics.TC_SCC := 909; + Report.Failed("Discriminant check, no exception"); + exception + when Constraint_Error => null; + when others => + Report.Failed("Discriminant check, wrong exception"); + end; + + Validate( The_Ground_Antenna.Electronics.TC_SDR = 1001, + "assigned value 1"); + Validate( The_Ground_Antenna.Electronics.The_Link.Mode + = Boards.Transmitting, + "assigned value 2.1"); + Validate( The_Ground_Antenna.Electronics.The_Link.TC_T = 2001, + "assigned value 2.2"); + Validate( The_Ground_Antenna.Electronics.TC_S_Band_Data = 3001, + "assigned value 3"); + Validate( The_Ground_Antenna.Pointing = 41, + "assigned value 4"); + + Validate( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Receiving, + "assigned value 5.1"); + Validate( The_Space_Antenna.Electronics.The_Link.TC_R = 1010, + "assigned value 5.2"); + Validate( The_Space_Antenna.Electronics.TC_KU_Band_Data = 2020, + "assigned value 6"); + Validate( The_Space_Antenna.Electronics.TC_SPS = 3030, + "assigned value 7"); + + Validate( Space_Station_Antenna.Electronics.The_Link.Mode + = Boards.Receiving, + "assigned value 8.1"); + Validate( Space_Station_Antenna.Electronics.The_Link.TC_R = 111, + "assigned value 8.2"); + Validate( Space_Station_Antenna.Electronics.TC_S_Band_Data = 222, + "assigned value 9"); + Validate( Space_Station_Antenna.Electronics.TC_SCC = 333, + "assigned value 10"); + + Report.Result; + + end C391001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c391002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c391002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c391002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c391002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,493 ---- + -- C391002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that structures nesting discriminated records as + -- components in record extension are correctly supported. + -- Check that record extensions inherit all the visible components + -- of their ancestor types. + -- Check that discriminants are correctly inherited. + -- + -- TEST DESCRIPTION: + -- This test defines a simple class hierarchy, where the final + -- derivations exercise the different possible "permissions" available + -- to a designer. Extension aggregates for discriminated types are used + -- to set values of these final types. The key difference between + -- this test and C391001 is that the types are visible, and allow the + -- creation of complex discriminated extension aggregates. Another + -- layer of derivation is present to more robustly check that the + -- inheritance is correctly supported. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Dec 94 SAIC Removed offending parenthesis in aggregate + -- extensions, corrected typo: TC_MC SB TC_PC, + -- corrected visibility errors for literals, + -- added qualification for aggregate expressions + -- used in extension aggregates, corrected parameter + -- order in call to Communications.Creator + -- 01 MAY 95 SAIC Removed "limited" from the definition of Mil_Comm + -- 14 OCT 95 SAIC Fixed some value bugs for ACVC 2.0.1 + -- 04 MAR 96 SAIC Altered 3 overambitious extension aggregates + -- 11 APR 96 SAIC Updated documentation for 2.1 + -- 27 FEB 97 PWB.CTA Deleted extra (illegal) component association + --! + + ----------------------------------------------------------------- C391002_1 + + package C391002_1 is + + type Object is tagged private; + + -- Constructor operation + procedure Create( The_Plaque : in out Object ); + + -- Selector operations + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean; + + function Serial_Number( A_Plaque : Object ) return Natural; + + Unserialized : exception; -- Serial_Number called before Create + Reserialized : exception; -- Create called twice + + private + type Object is tagged record + Serial_Number : Natural := 0; + end record; + end C391002_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C391002_1 is + + Counter : Natural := 0; + + procedure Create( The_Plaque : in out Object ) is + begin + if The_Plaque.Serial_Number = 0 then + Counter := Counter +1; + The_Plaque.Serial_Number := Counter; + else + raise Reserialized; + end if; + end Create; + + function TC_Match( Left_Plaque : Object; Right_Natural : Natural ) + return Boolean is + begin + return (Left_Plaque.Serial_Number = Right_Natural); + end TC_Match; + + function Serial_Number( A_Plaque : Object ) return Natural is + begin + if A_Plaque.Serial_Number = 0 then + raise Unserialized; + end if; + return A_Plaque.Serial_Number; + end Serial_Number; + end C391002_1; + + ----------------------------------------------------------------- C391002_2 + + with C391002_1; + package C391002_2 is -- package Boards is + + package Plaque renames C391002_1; + + type Modes is (Receiving, Transmitting, Standby); + type Link(Mode: Modes := Standby) is record + case Mode is + when Receiving => TC_R : Integer := 100; + when Transmitting => TC_T : Integer := 200; + when Standby => TC_S : Integer := 300; -- TGA, TSA, SSA + end case; + end record; + + type Data_Formats is (S_Band, KU_Band, UHF); + + type Transceiver(Band: Data_Formats) is tagged record + ID : Plaque.Object; + The_Link: Link; + case Band is + when S_Band => TC_S_Band_Data : Integer := 1; -- TGA, SSA, Milnet + when KU_Band => TC_KU_Band_Data : Integer := 2; -- TSA, Usenet + when UHF => TC_UHF_Data : Integer := 3; -- Gossip + end case; + end record; + end C391002_2; + + ----------------------------------------------------------------- C391002_3 + + with C391002_1; + with C391002_2; + package C391002_3 is -- package Modules + + package Plaque renames C391002_1; + package Boards renames C391002_2; + use type Boards.Modes; + use type Boards.Data_Formats; + + type Command_Formats is ( Set_Compression_Code, + Set_Data_Rate, + Set_Power_State ); + + type Electronics_Module(EBand : Boards.Data_Formats; + The_Command : Command_Formats) + is new Boards.Transceiver(EBand) with record + case The_Command is + when Set_Compression_Code => TC_SCC : Integer := 10; -- SSA, Gossip + when Set_Data_Rate => TC_SDR : Integer := 20; -- TGA, Usenet + when Set_Power_State => TC_SPS : Integer := 30; -- TSA, Milnet + end case; + end record; + end C391002_3; + + ----------------------------------------------------------------- C391002_4 + + with C391002_3; + package C391002_4 is -- Communications + package Modules renames C391002_3; + + type Public_Comm is new Modules.Electronics_Module with + record + TC_VC : Integer; + end record; + + type Private_Comm is new Modules.Electronics_Module with private; + + type Mil_Comm is new Modules.Electronics_Module with private; + + procedure Creator( Plugs : in Modules.Electronics_Module; + Gives : out Mil_Comm); + + function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) + return Private_Comm; + + procedure Setup( It : in out Public_Comm; Value : in Integer ); + procedure Setup( It : in out Private_Comm; Value : in Integer ); + procedure Setup( It : in out Mil_Comm; Value : in Integer ); + + function Selector( It : Public_Comm ) return Integer; + function Selector( It : Private_Comm ) return Integer; + function Selector( It : Mil_Comm ) return Integer; + + private + type Private_Comm is new Modules.Electronics_Module with + record + TC_PC : Integer; + end record; + + type Mil_Comm is new Modules.Electronics_Module with + record + TC_MC : Integer; + end record; + end C391002_4; -- Communications + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body C391002_4 is -- Communications + + procedure Creator( Plugs : in Modules.Electronics_Module; + Gives : out Mil_Comm) is + begin + Gives := ( Plugs with TC_MC => -1 ); + end Creator; + + function Creator( Key : Integer; Plugs : in Modules.Electronics_Module ) + return Private_Comm is + begin + return ( Plugs with TC_PC => Key ); + end Creator; + + procedure Setup( It : in out Public_Comm; Value : in Integer ) is + begin + It.TC_VC := Value; + TCTouch.Assert( Value = 1, "Public_Comm"); + end Setup; + + procedure Setup( It : in out Private_Comm; Value : in Integer ) is + begin + It.TC_PC := Value; + TCTouch.Assert( Value = 2, "Private_Comm"); + end Setup; + + procedure Setup( It : in out Mil_Comm; Value : in Integer ) is + begin + It.TC_MC := Value; + TCTouch.Assert( Value = 3, "Private_Comm"); + end Setup; + + function Selector( It : Public_Comm ) return Integer is + begin + return It.TC_VC; + end Selector; + + function Selector( It : Private_Comm ) return Integer is + begin + return It.TC_PC; + end Selector; + + function Selector( It : Mil_Comm ) return Integer is + begin + return It.TC_MC; + end Selector; + + end C391002_4; -- Communications + + ------------------------------------------------------------------- C391002 + + with Report; + with TCTouch; + with C391002_1; + with C391002_2; + with C391002_3; + with C391002_4; + procedure C391002 is + + package Plaque renames C391002_1; + package Boards renames C391002_2; + package Modules renames C391002_3; + package Communications renames C391002_4; + + procedure Assert( Condition: Boolean; Message: String ) + renames TCTouch.Assert; + + use type Boards.Modes; + use type Boards.Data_Formats; + use type Modules.Command_Formats; + + type Azimuth is range 0..359; + + type Ground_Antenna(The_Band : Boards.Data_Formats; + The_Command : Modules.Command_Formats) is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + Pointing : Azimuth; + end record; + + type Space_Antenna(The_Band : Boards.Data_Formats := Boards.KU_Band; + The_Command : Modules.Command_Formats + := Modules.Set_Power_State) + is + record + ID : Plaque.Object; + Electronics : Modules.Electronics_Module(The_Band,The_Command); + end record; + + The_Ground_Antenna : Ground_Antenna (Boards.S_Band, + Modules.Set_Data_Rate); + The_Space_Antenna : Space_Antenna; + Space_Station_Antenna : Space_Antenna (Boards.UHF, + Modules.Set_Compression_Code); + + Gossip : Communications.Public_Comm (Boards.UHF, + Modules.Set_Compression_Code); + Usenet : Communications.Private_Comm (Boards.KU_Band, + Modules.Set_Data_Rate); + Milnet : Communications.Mil_Comm (Boards.S_Band, + Modules.Set_Power_State); + + + begin + + Report.Test("C391002", "Check nested tagged discriminated" + & " record structures"); + + Plaque.Create( The_Ground_Antenna.ID ); -- 1 + Plaque.Create( The_Ground_Antenna.Electronics.ID ); -- 2 + Plaque.Create( The_Space_Antenna.ID ); -- 3 + Plaque.Create( The_Space_Antenna.Electronics.ID ); -- 4 + Plaque.Create( Space_Station_Antenna.ID ); -- 5 + Plaque.Create( Space_Station_Antenna.Electronics.ID );-- 6 + + The_Ground_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + ID => The_Ground_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Ground_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 222 ), + TC_S_Band_Data => 8 ) + with EBand => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + TC_SDR => 11 ), + Pointing => 270 ); + + The_Space_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + ID => The_Space_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 456 ), + TC_S_Band_Data => 88 ) + with + EBand => Boards.S_Band, + The_Command => Modules.Set_Data_Rate, + TC_SDR => 42 + ) ); + + Space_Station_Antenna := ( Boards.UHF, Modules.Set_Compression_Code, + Space_Station_Antenna.ID, + ( Boards.Transceiver'( + Boards.UHF, + Space_Station_Antenna.Electronics.ID, + ( Boards.Transmitting, 202 ), + 42 ) + with Boards.UHF, + Modules.Set_Compression_Code, + TC_SCC => 101 + ) ); + + Assert( The_Ground_Antenna.The_Band = Boards.S_Band, "TGA disc 1" ); + Assert( The_Ground_Antenna.The_Command = Modules.Set_Data_Rate, + "TGA disc 2" ); + Assert( Plaque.TC_Match(The_Ground_Antenna.ID,1), "TGA comp 3" ); + Assert( The_Ground_Antenna.Electronics.EBand = Boards.S_Band, + "TGA comp 2.disc 1" ); + Assert( The_Ground_Antenna.Electronics.The_Command + = Modules.Set_Data_Rate, + "TGA comp 2.disc 2" ); + Assert( The_Ground_Antenna.Electronics.TC_SDR = 11, + "TGA comp 2.1" ); + Assert( Plaque.TC_Match( The_Ground_Antenna.Electronics.ID, 2 ), + "TGA comp 2.inher.1" ); + Assert( The_Ground_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, + "TGA comp 2.inher.2.disc" ); + Assert( The_Ground_Antenna.Electronics.The_Link.TC_T = 222, + "TGA comp 2.inher.2.1" ); + Assert( The_Ground_Antenna.Electronics.TC_S_Band_Data = 8, + "TGA comp 2.inher.3" ); + Assert( The_Ground_Antenna.Pointing = 270, "TGA comp 3" ); + + Assert( The_Space_Antenna.The_Band = Boards.S_Band, "TSA disc 1"); + Assert( The_Space_Antenna.The_Command = Modules.Set_Data_Rate, + "TSA disc 2"); + Assert( Plaque.TC_Match(The_Space_Antenna.ID,3), + "TSA comp 1"); + Assert( The_Space_Antenna.Electronics.EBand = Boards.S_Band, + "TSA comp 2.disc 1"); + Assert( The_Space_Antenna.Electronics.The_Command = Modules.Set_Data_Rate, + "TSA comp 2.disc 2"); + Assert( The_Space_Antenna.Electronics.TC_SDR = 42, + "TSA comp 2.1"); + Assert( Plaque.TC_Match(The_Space_Antenna.Electronics.ID,4), + "TSA comp 2.inher.1"); + Assert( The_Space_Antenna.Electronics.The_Link.Mode = Boards.Transmitting, + "TSA comp 2.inher.2.disc"); + Assert( The_Space_Antenna.Electronics.The_Link.TC_T = 456, + "TSA comp 2.inher.2.1"); + Assert( The_Space_Antenna.Electronics.TC_S_Band_Data = 88, + "TSA comp 2.inher.3"); + + Assert( Space_Station_Antenna.The_Band = Boards.UHF, "SSA disc 1"); + Assert( Space_Station_Antenna.The_Command = Modules.Set_Compression_Code, + "SSA disc 2"); + Assert( Plaque.TC_Match(Space_Station_Antenna.ID,5), + "SSA comp 1"); + Assert( Space_Station_Antenna.Electronics.EBand = Boards.UHF, + "SSA comp 2.disc 1"); + Assert( Space_Station_Antenna.Electronics.The_Command + = Modules.Set_Compression_Code, + "SSA comp 2.disc 2"); + Assert( Space_Station_Antenna.Electronics.TC_SCC = 101, + "SSA comp 2.1"); + Assert( Plaque.TC_Match(Space_Station_Antenna.Electronics.ID,6), + "SSA comp 2.inher.1"); + Assert( Space_Station_Antenna.Electronics.The_Link.Mode + = Boards.Transmitting, + "SSA comp 2.inher.2.disc"); + Assert( Space_Station_Antenna.Electronics.The_Link.TC_T = 202, + "SSA comp 2.inher.2.1"); + Assert( Space_Station_Antenna.Electronics.TC_UHF_Data = 42, + "SSA comp 2.inher.3"); + + + The_Space_Antenna := ( The_Band => Boards.S_Band, + The_Command => Modules.Set_Power_State, + ID => The_Space_Antenna.ID, + Electronics => + ( Boards.Transceiver'( + Band => Boards.S_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Mode => Boards.Transmitting, + TC_T => 1 ), + TC_S_Band_Data => 5 ) + with + EBand => Boards.S_Band, + The_Command => Modules.Set_Power_State, + TC_SPS => 101 + ) ); + + Communications.Creator( The_Space_Antenna.Electronics, Milnet ); + Assert( Communications.Selector( Milnet ) = -1, "Milnet creator" ); + + Usenet := Communications.Creator( -2, + ( Boards.Transceiver'( + Band => Boards.KU_Band, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Boards.Transmitting, TC_T => 101 ), + TC_KU_Band_Data => 395 ) + with Boards.KU_Band, Modules.Set_Data_Rate, 66 ) ); + + Assert( Communications.Selector( Usenet ) = -2, "Usenet creator" ); + + Gossip := ( + Modules.Electronics_Module'( + Boards.Transceiver'( + Band => Boards.UHF, + ID => The_Space_Antenna.Electronics.ID, + The_Link => ( Boards.Transmitting, TC_T => 101 ), + TC_UHF_Data => 395 ) + with + Boards.UHF, Modules.Set_Compression_Code, 66 ) + with + TC_VC => -3 ); + + Assert( Gossip.TC_VC = -3, "Gossip Aggregate" ); + + Communications.Setup( Gossip, 1 ); -- (Boards.UHF, + -- Modules.Set_Compression_Code) + Communications.Setup( Usenet, 2 ); -- (Boards.KU_Band, + -- Modules.Set_Data_Rate) + Communications.Setup( Milnet, 3 ); -- (Boards.S_Band, + -- Modules.Set_Power_State) + + Assert( Communications.Selector( Gossip ) = 1, "Gossip Setup" ); + Assert( Communications.Selector( Usenet ) = 2, "Usenet Setup" ); + Assert( Communications.Selector( Milnet ) = 3, "Milnet Setup" ); + + Report.Result; + + end C391002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,349 ---- + -- C392002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the use of a class-wide formal parameter allows for the + -- proper dispatching of objects to the appropriate implementation of + -- a primitive operation. Check this in the case where the root tagged + -- type is defined in a generic package, and the type derived from it is + -- defined in that same generic package. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type, and some associated primitive operations. + -- Extend the root type, and override one or more primitive operations, + -- inheriting the other primitive operations from the root type. + -- Derive from the extended type, again overriding some primitive + -- operations and inheriting others (including some that the parent + -- inherited). + -- Define a subprogram with a class-wide parameter, inside of which is a + -- call on a dispatching primitive operation. These primitive operations + -- modify global variables (the class-wide parameter has mode IN). + -- + -- The following hierarchy of tagged types and primitive operations is + -- utilized in this test: + -- + -- + -- type Vehicle (root) + -- | + -- type Motorcycle + -- | + -- | Operations + -- | Engine_Size + -- | Catalytic_Converter + -- | Emissions_Produced + -- | + -- type Automobile (extended from Motorcycle) + -- | + -- | Operations + -- | (Engine_Size) (inherited) + -- | Catalytic_Converter (overridden) + -- | Emissions_Produced (overridden) + -- | + -- type Truck (extended from Automobile) + -- | + -- | Operations + -- | (Engine_Size) (inherited twice - Motorcycle) + -- | (Catalytic_Converter) (inherited - Automobile) + -- | Emissions_Produced (overridden) + -- + -- + -- In this test, we are concerned with the following selection of dispatching + -- calls, accomplished with the use of a Vehicle'Class IN procedure + -- parameter : + -- + -- \ Type + -- Prim. Op \ Motorcycle Automobile Truck + -- \------------------------------------------------ + -- Engine_Size | X X X + -- Catalytic_Converter | X X X + -- Emissions_Produced | X X X + -- + -- + -- + -- The location of the declaration and derivation of the root and extended + -- types will be varied over a series of tests. Locations of declaration + -- and derivation for a particular test are marked with an asterisk (*). + -- + -- Root type: + -- + -- Declared in package. + -- * Declared in generic package. + -- + -- Extended types: + -- + -- * Derived in parent location. + -- Derived in a nested package. + -- Derived in a nested subprogram. + -- Derived in a nested generic package. + -- Derived in a separate package. + -- Derived in a separate visible child package. + -- Derived in a separate private child package. + -- + -- Primitive Operations: + -- + -- * Procedures with same parameter profile. + -- Procedures with different parameter profile. + -- * Functions with same parameter profile. + -- Functions with different parameter profile. + -- * Mixture of Procedures and Functions. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 09 May 96 SAIC Made single-file for 2.1 + -- + --! + + ------------------------------------------------------------------- C392002_0 + + -- Declare the root and extended types, along with their primitive + -- operations in a generic package. + + generic + + type Cubic_Inches is range <>; + type Emission_Measure is digits <>; + Emissions_per_Engine_Cubic_Inch : Emission_Measure; + + package C392002_0 is -- package Vehicle_Simulation + + -- + -- Equipment types and their primitive operations. + -- + + -- Root type. + + type Vehicle is abstract tagged + record + Weight : Integer; + Wheels : Positive; + end record; + + -- Abstract operations of type Vehicle. + function Engine_Size (V : in Vehicle) return Cubic_Inches + is abstract; + function Catalytic_Converter (V : in Vehicle) return Boolean + is abstract; + function Emissions_Produced (V : in Vehicle) return Emission_Measure + is abstract; + + -- + + type Motorcycle is new Vehicle with + record + Size_Of_Engine : Cubic_Inches; + end record; + + -- Primitive operations of type Motorcycle. + function Engine_Size (V : in Motorcycle) return Cubic_Inches; + function Catalytic_Converter (V : in Motorcycle) return Boolean; + function Emissions_Produced (V : in Motorcycle) return Emission_Measure; + + -- + + type Automobile is new Motorcycle with + record + Passenger_Capacity : Integer; + end record; + + -- Function Engine_Size inherited from parent (Motorcycle). + -- Primitive operations (Overridden). + function Catalytic_Converter (V : in Automobile) return Boolean; + function Emissions_Produced (V : in Automobile) return Emission_Measure; + + -- + + type Truck is new Automobile with + record + Hauling_Capacity : Natural; + end record; + + -- Function Engine_Size inherited twice. + -- Function Catalytic_Converter inherited from parent (Automobile). + -- Primitive operation (Overridden). + function Emissions_Produced (V : in Truck) return Emission_Measure; + + end C392002_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body c392002_0 is + + -- + -- Primitive operations for Motorcycle. + -- + + function Engine_Size (V : in Motorcycle) return Cubic_Inches is + begin + return (V.Size_Of_Engine); + end Engine_Size; + + + function Catalytic_Converter (V : in Motorcycle) return Boolean is + begin + return (False); + end Catalytic_Converter; + + + function Emissions_Produced (V : in Motorcycle) return Emission_Measure is + begin + return 100.00; + end Emissions_Produced; + + -- + -- Overridden operations for Automobile type. + -- + + function Catalytic_Converter (V : in Automobile) return Boolean is + begin + return (True); + end Catalytic_Converter; + + + function Emissions_Produced (V : in Automobile) return Emission_Measure is + begin + return 200.00; + end Emissions_Produced; + + -- + -- Overridden operation for Truck type. + -- + + function Emissions_Produced (V : in Truck) return Emission_Measure is + begin + return 300.00; + end Emissions_Produced; + + end C392002_0; + + --------------------------------------------------------------------- C392002 + + with C392002_0; -- with Vehicle_Simulation; + with Report; + + procedure C392002 is + + type Decade is (c1970, c1980, c1990); + type Vehicle_Emissions is digits 6; + type Engine_Emissions_by_Decade is array (Decade) of Vehicle_Emissions; + subtype Engine_Size is Integer range 100 .. 1000; + + Five_Tons : constant Natural := 10000; + Catalytic_Converter_Offset : constant Vehicle_Emissions := 0.8; + Truck_Adjustment_Factor : constant Vehicle_Emissions := 1.2; + + + Engine_Emission_Factor : Engine_Emissions_by_Decade := (c1970 => 10.00, + c1980 => 8.00, + c1990 => 5.00); + + -- Instantiate generic package for 1970 simulation. + + package Sim_1970 is new C392002_0 + (Cubic_Inches => Engine_Size, + Emission_Measure => Vehicle_Emissions, + Emissions_Per_Engine_Cubic_Inch => Engine_Emission_Factor (c1970)); + + + -- Declare and initialize vehicle objects. + + Cycle_1970 : Sim_1970.Motorcycle := (Weight => 400, + Wheels => 2, + Size_Of_Engine => 100); + + Auto_1970 : Sim_1970.Automobile := (2000, 4, 500, 5); + + Truck_1970 : Sim_1970.Truck := (Weight => 5000, + Wheels => 18, + Size_Of_Engine => 1000, + Passenger_Capacity => 2, + Hauling_Capacity => Five_Tons); + + -- Function Get_Engine_Size performs a dispatching call on a + -- primitive operation that has been defined for an ancestor type and + -- inherited by each type derived from the ancestor. + + function Get_Engine_Size (V : in Sim_1970.Vehicle'Class) + return Engine_Size is + begin + return (Sim_1970.Engine_Size (V)); -- Dispatch according to tag. + end Get_Engine_Size; + + + -- Function Catalytic_Converter_Present performs a dispatching call on + -- a primitive operation that has been defined for an ancestor type, + -- overridden in the parent extended type, and inherited by the subsequent + -- extended type. + + function Catalytic_Converter_Present (V : in Sim_1970.Vehicle'Class) + return Boolean is + begin + return (Sim_1970.Catalytic_Converter (V)); -- Dispatch according to tag. + end Catalytic_Converter_Present; + + + -- Function Air_Quality_Measure performs a dispatching call on + -- a primitive operation that has been defined for an ancestor type, and + -- overridden in each subsequent extended type. + + function Air_Quality_Measure (V : in Sim_1970.Vehicle'Class) + return Vehicle_Emissions is + begin + return (Sim_1970.Emissions_Produced (V)); -- Dispatch according to tag. + end Air_Quality_Measure; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("C392002", "Check that the use of a class-wide parameter " + & "allows for proper dispatching where root type " + & "and extended types are declared in the same " + & "generic package" ); + + if (Get_Engine_Size (Cycle_1970) /= 100) or + (Get_Engine_Size (Auto_1970) /= 500) or + (Get_Engine_Size (Truck_1970) /= 1000) + then + Report.Failed ("Failed dispatch to Get_Engine_Size"); + end if; + + if Catalytic_Converter_Present (Cycle_1970) or + not Catalytic_Converter_Present (Auto_1970) or + not Catalytic_Converter_Present (Truck_1970) + then + Report.Failed ("Failed dispatch to Catalytic_Converter_Present"); + end if; + + if ((Air_Quality_Measure (Cycle_1970) /= 100.00) or + (Air_Quality_Measure (Auto_1970) /= 200.00) or + (Air_Quality_Measure (Truck_1970) /= 300.00)) + then + Report.Failed ("Failed dispatch to Air_Quality_Measure"); + end if; + + Report.Result; + + end C392002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,453 ---- + -- C392003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the use of a class-wide formal parameter allows for the + -- proper dispatching of objects to the appropriate implementation of + -- a primitive operation. Check this where the root tagged type is + -- defined in a package, and the extended type is defined in a nested + -- package. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type, and some associated primitive operations. + -- Extend the root type, and override one or more primitive operations, + -- inheriting the other primitive operations from the root type. + -- Derive from the extended type, again overriding some primitive + -- operations and inheriting others (including some that the parent + -- inherited). + -- Define a subprogram with a class-wide parameter, inside of which is a + -- call on a dispatching primitive operation. These primitive operations + -- modify global variables (the class-wide parameter has mode IN). + -- + -- + -- + -- The following hierarchy of tagged types and primitive operations is + -- utilized in this test: + -- + -- type Bank_Account (root) + -- | + -- | Operations + -- | Increment_Bank_Reserve + -- | Assign_Representative + -- | Increment_Counters + -- | Open + -- | + -- type Savings_Account (extended from Bank_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited) + -- | Assign_Representative (overridden) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- | + -- type Preferred_Account (extended from Savings_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) + -- | (Assign_Representative) (inherited - Savings_Acct.) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- + -- + -- In this test, we are concerned with the following selection of dispatching + -- calls, accomplished with the use of a Bank_Account'Class IN procedure + -- parameter : + -- + -- \ Type + -- Prim. Op \ Bank_Account Savings_Account Preferred_Account + -- \------------------------------------------------ + -- Increment_Bank_Reserve| X X + -- Assign_Representative | X + -- Increment_Counters | X X X + -- + -- + -- + -- The location of the declaration and derivation of the root and extended + -- types will be varied over a series of tests. Locations of declaration + -- and derivation for a particular test are marked with an asterisk (*). + -- + -- Root type: + -- + -- * Declared in package. + -- Declared in generic package. + -- + -- Extended types: + -- + -- Derived in parent location. + -- * Derived in a nested package. + -- Derived in a nested subprogram. + -- Derived in a nested generic package. + -- Derived in a separate package. + -- Derived in a separate visible child package. + -- Derived in a separate private child package. + -- + -- Primitive Operations: + -- + -- * Procedures with same parameter profile. + -- Procedures with different parameter profile. + -- * Functions with same parameter profile. + -- Functions with different parameter profile. + -- * Mixture of Procedures and Functions. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + + procedure C392003 is + + -- + -- Types and subtypes. + -- + + type Dollar_Amount is new float; + type Interest_Rate is delta 0.001 range 0.000 .. 1.000; + type Account_Types is (Bank, Savings, Preferred, Total); + type Account_Counter is array (Account_Types) of integer; + type Account_Rep is (President, Manager, New_Account_Manager, Teller); + + -- + -- Constants. + -- + + Opening_Balance : constant Dollar_Amount := 100.00; + Current_Rate : constant Interest_Rate := 0.030; + Preferred_Minimum_Balance : constant Dollar_Amount := 1000.00; + + -- + -- Global Variables + -- + + Bank_Reserve : Dollar_Amount := 0.00; + Daily_Representative : Account_Rep := New_Account_Manager; + Number_Of_Accounts : Account_Counter := (Bank => 0, + Savings => 0, + Preferred => 0, + Total => 0); + + -- Root tagged type and primitive operations declared in internal + -- package (Accounts). + -- Extended types (and primitive operations) derived in nested packages. + + --=================================================================-- + + package Accounts is + + -- + -- Root account type and primitive operations. + -- + + -- Root type. + + type Bank_Account is tagged + record + Balance : Dollar_Amount; + end record; + + -- Primitive operations of Bank_Account. + + function Increment_Bank_Reserve (Acct : in Bank_Account) + return Dollar_Amount; + function Assign_Representative (Acct : in Bank_Account) + return Account_Rep; + procedure Increment_Counters (Acct : in Bank_Account); + procedure Open (Acct : in out Bank_Account); + + --=================================================================-- + + package S_And_L is + + -- Declare extended type in a nested package. + + type Savings_Account is new Bank_Account with + record + Rate : Interest_Rate; + end record; + + -- Function Increment_Bank_Reserve inherited from + -- parent (Bank_Account). + + -- Primitive operations (Overridden). + function Assign_Representative (Acct : in Savings_Account) + return Account_Rep; + procedure Increment_Counters (Acct : in Savings_Account); + procedure Open (Acct : in out Savings_Account); + + + --=================================================================-- + + package Premium is + + -- Declare further extended type in a nested package. + + type Preferred_Account is new Savings_Account with + record + Minimum_Balance : Dollar_Amount; + end record; + + -- Function Increment_Bank_Reserve inherited twice. + -- Function Assign_Representative inherited from parent + -- (Savings_Account). + + -- Primitive operation (Overridden). + procedure Increment_Counters (Acct : in Preferred_Account); + procedure Open (Acct : in out Preferred_Account); + + -- Function used to verify Open operation for Preferred_Account + -- objects. + function Verify_Open (Acct : in Preferred_Account) return Boolean; + + end Premium; + + end S_And_L; + + end Accounts; + + --=================================================================-- + + package body Accounts is + + -- + -- Primitive operations for Bank_Account. + -- + + function Increment_Bank_Reserve (Acct : in Bank_Account) + return Dollar_Amount is + begin + return (Bank_Reserve + Acct.Balance); + end Increment_Bank_Reserve; + + function Assign_Representative (Acct : in Bank_Account) + return Account_Rep is + begin + return Account_Rep'(Teller); + end Assign_Representative; + + procedure Increment_Counters (Acct : in Bank_Account) is + begin + Number_Of_Accounts (Bank) := Number_Of_Accounts (Bank) + 1; + Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Bank_Account) is + begin + Acct.Balance := Opening_Balance; + end Open; + + --=================================================================-- + + package body S_And_L is + + -- + -- Overridden operations for Savings_Account type. + -- + + function Assign_Representative (Acct : in Savings_Account) + return Account_Rep is + begin + return (Manager); + end Assign_Representative; + + procedure Increment_Counters (Acct : in Savings_Account) is + begin + Number_Of_Accounts (Savings) := Number_Of_Accounts (Savings) + 1; + Number_Of_Accounts (Total) := Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Savings_Account) is + begin + Open (Bank_Account(Acct)); + Acct.Rate := Current_Rate; + Acct.Balance := 2.0 * Opening_Balance; + end Open; + + --=================================================================-- + + package body Premium is + + -- + -- Overridden operations for Preferred_Account type. + -- + + procedure Increment_Counters (Acct : in Preferred_Account) is + begin + Number_Of_Accounts (Preferred) := + Number_Of_Accounts (Preferred) + 1; + Number_Of_Accounts (Total) := + Number_Of_Accounts (Total) + 1; + end Increment_Counters; + + procedure Open (Acct : in out Preferred_Account) is + begin + Open (Savings_Account(Acct)); + Acct.Minimum_Balance := Preferred_Minimum_Balance; + Acct.Balance := Acct.Minimum_Balance; + end Open; + + -- + -- Function used to verify Open operation for Preferred_Account + -- objects. + -- + + function Verify_Open (Acct : in Preferred_Account) + return Boolean is + begin + return (Acct.Balance = Preferred_Minimum_Balance and + Acct.Rate = Current_Rate and + Acct.Minimum_Balance = Preferred_Minimum_Balance); + end Verify_Open; + + end Premium; + + end S_And_L; + + end Accounts; + + --=================================================================-- + + -- Declare account objects. + + B_Account : Accounts.Bank_Account; + S_Account : Accounts.S_And_L.Savings_Account; + P_Account : Accounts.S_And_L.Premium.Preferred_Account; + + -- Procedures to operate on accounts. + -- Each uses a class-wide IN parameter, as well as a call to a + -- dispatching operation. + + -- Function Tabulate_Account performs a dispatching call on a primitive + -- operation that has been overridden for each of the extended types. + + procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Counters (Acct); -- Dispatch according to tag. + end Tabulate_Account; + + -- Function Accumulate_Reserve performs a dispatching call on a + -- primitive operation that has been defined for the root type and + -- inherited by each derived type. + + function Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) + return Dollar_Amount is + begin + -- Dispatch according to tag. + return (Accounts.Increment_Bank_Reserve (Acct)); + end Accumulate_Reserve; + + -- Procedure Resolve_Dispute performs a dispatching call on a primitive + -- operation that has been defined in the root type, overridden in the + -- first derived extended type, and inherited by the subsequent extended + -- type. + + procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is + begin + -- Dispatch according to tag. + Daily_Representative := Accounts.Assign_Representative (Acct); + end Resolve_Dispute; + + --=================================================================-- + + begin -- Main test procedure. + + Report.Test ("C392003", "Check that the use of a class-wide parameter " & + "allows for proper dispatching where root type " & + "is declared in a nested package, and " & + "subsequent extended types are derived in " & + "further nested packages" ); + + Bank_Account_Subtest: + begin + Accounts.Open (B_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been defined for this specific type. + Bank_Reserve := Accumulate_Reserve (Acct => B_Account); + Tabulate_Account (B_Account); + + if (Bank_Reserve /= Opening_Balance) or + (Number_Of_Accounts (Bank) /= 1) or + (Number_Of_Accounts (Total) /= 1) + then + Report.Failed ("Failed in Bank_Account_Subtest"); + end if; + + end Bank_Account_Subtest; + + + Savings_Account_Subtest: + begin + Accounts.S_And_L.Open (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type. + Resolve_Dispute (Acct => S_Account); + Tabulate_Account (S_Account); + + if (Daily_Representative /= Manager) or + (Number_Of_Accounts (Savings) /= 1) or + (Number_Of_Accounts (Total) /= 2) + then + Report.Failed ("Failed in Savings_Account_Subtest"); + end if; + + end Savings_Account_Subtest; + + + + Preferred_Account_Subtest: + begin + Accounts.S_And_L.Premium.Open (P_Account); + + -- Verify that the correct implementation of Open (overridden) was + -- used for the Preferred_Account object. + if not Accounts.S_And_L.Premium.Verify_Open (P_Account) then + Report.Failed ("Incorrect values for init. Preferred Acct object"); + end if; + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been twice inherited by this extended type. + Bank_Reserve := Accumulate_Reserve (Acct => P_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type (the + -- operation was overridden by its parent type as well). + Tabulate_Account (P_Account); + + if Bank_Reserve /= 1100.00 or + Number_Of_Accounts (Preferred) /= 1 or + Number_Of_Accounts (Total) /= 3 + then + Report.Failed ("Failed in Preferred_Account_Subtest"); + end if; + + end Preferred_Account_Subtest; + + Report.Result; + + end C392003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392004.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C392004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprograms inherited from tagged derivations, which are + -- subsequently redefined for the derived type, are available to the + -- package defining the new class via view conversion. Check + -- that operations performed on objects using view conversion do not + -- affect the extended fields. Check that visible operations not masked + -- by the deriving package remain available to the client, and do not + -- affect the extended fields. + -- + -- TEST DESCRIPTION: + -- This test declares a tagged type, with a constructor operation, + -- derives a type from that tagged type, and declares a constructor + -- operation which masks the inherited operation. It then tests + -- that the correct constructor is called, and that the extended + -- part of the derived type remains untouched as appropriate. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 04 Jan 94 SAIC Fixed objective typo, removed dead code. + -- + --! + + with Report; + + package C392004_1 is + + type Vehicle is tagged private; + + procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ); + procedure Start ( The_Vehicle : in out Vehicle ); + + private + + type Vehicle is tagged record + Engine_On : Boolean; + end record; + + end C392004_1; + + package body C392004_1 is + procedure Create ( The_Vehicle : out Vehicle; TC_Flag : Natural ) is + begin + case TC_Flag is + when 1 => null; -- expected flag for this subprogram + when others => + Report.Failed ("Called Vehicle Create"); + end case; + The_Vehicle := (Engine_On => False); + end Create; + + procedure Start ( The_Vehicle : in out Vehicle ) is + begin + The_Vehicle.Engine_On := True; + end Start; + + end C392004_1; + + ---------------------------------------------------------------------------- + + with C392004_1; + package C392004_2 is + + type Car is new C392004_1.Vehicle with record + Convertible : Boolean; + end record; + + -- masking definition + procedure Create( The_Car : out Car; TC_Flag : Natural ); + + type Limo is new Car with null record; + + procedure Create( The_Limo : out Limo; TC_Flag : Natural ); + + end C392004_2; + + ---------------------------------------------------------------------------- + + with Report; + package body C392004_2 is + + procedure Create( The_Car : out Car; TC_Flag : Natural ) is + begin + case TC_Flag is + when 2 => null; -- expected flag for this subprogram + when others => Report.Failed ("Called Car Create"); + end case; + C392004_1.Create( C392004_1.Vehicle(The_Car), 1); + The_Car.Convertible := False; + end Create; + + procedure Create( The_Limo : out Limo; TC_Flag : Natural ) is + begin + case TC_Flag is + when 3 => null; -- expected flag for this subprogram + when others => Report.Failed ("Called Limo Create"); + end case; + C392004_1.Create( C392004_1.Vehicle(The_Limo), 1); + The_Limo.Convertible := True; + end Create; + + end C392004_2; + + ---------------------------------------------------------------------------- + + with Report; + with C392004_1; use C392004_1; + with C392004_2; use C392004_2; + procedure C392004 is + + My_Car : Car; + Your_Car : Limo; + + procedure TC_Assert( Is_True : Boolean; Message : String ) is + begin + if not Is_True then + Report.Failed (Message); + end if; + end TC_Assert; + + begin -- Main test procedure. + + Report.Test ("C392004", "Check subprogram inheritance & visibility " & + "for derived tagged types" ); + + My_Car.Convertible := False; + Create( Vehicle( My_Car ), 1 ); + TC_Assert( not My_Car.Convertible, "Altered descendent component 1"); + + Create( Your_Car, 3 ); + TC_Assert( Your_Car.Convertible, "Did not set inherited component 2"); + + My_Car.Convertible := True; + Create( Vehicle( My_Car ), 1 ); + TC_Assert( My_Car.Convertible, "Altered descendent component 3"); + + Create( My_Car, 2 ); + TC_Assert( not My_Car.Convertible, "Did not set extending component 4"); + + My_Car.Convertible := False; + Start( Vehicle( My_Car ) ); + TC_Assert( not My_Car.Convertible , "Altered descendent component 5"); + + Start( My_Car ); + TC_Assert( not My_Car.Convertible, "Altered unreferenced component 6"); + + Your_Car.Convertible := False; + Start( Vehicle( Your_Car ) ); + TC_Assert( not Your_Car.Convertible , "Altered descendent component 7"); + + Start( Your_Car ); + TC_Assert( not Your_Car.Convertible, "Altered unreferenced component 8"); + + My_Car.Convertible := True; + Start( Vehicle( My_Car ) ); + TC_Assert( My_Car.Convertible, "Altered descendent component 9"); + + Start( My_Car ); + TC_Assert( My_Car.Convertible, "Altered unreferenced component 10"); + + Report.Result; + + end C392004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392005.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,367 ---- + -- C392005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for an implicitly declared dispatching operation that is + -- overridden, the body executed is the body for the overriding + -- subprogram, even if the overriding occurs in a private part. + -- + -- Check for the case where the overriding operations are declared in a + -- public child unit of the package declaring the parent type, and the + -- descendant type is a private extension. + -- + -- Check for both dispatching and nondispatching calls. + -- + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package Parent is + -- type Root is tagged ... + -- procedure Vis_Op (P: Root); + -- private + -- procedure Pri_Op (P: Root); + -- end Parent; + -- + -- package Parent.Child is + -- type Derived is new Root with private; + -- -- Implicit Vis_Op (P: Derived) declared here. + -- + -- procedure Pri_Op (P: Derived); -- (A) + -- ... + -- private + -- type Derived is new Root with record... + -- -- Implicit Pri_Op (P: Derived) declared here. + + -- procedure Vis_Op (P: Derived); -- (B) + -- ... + -- end Parent.Child; + -- + -- Type Derived inherits both Vis_Op and Pri_Op from the ancestor type + -- Root. Note, however, that Vis_Op is implicitly declared in the visible + -- part, whereas Pri_Op is implicitly declared in the private part + -- (inherited subprograms for a private extension are implicitly declared + -- after the private_extension_declaration if the corresponding + -- declaration from the ancestor is visible at that place; otherwise the + -- inherited subprogram is not declared for the private extension, + -- although it might be for the full type). + -- + -- Even though Root's version of Pri_Op hasn't been implicitly declared + -- for Derived at the time Derived's version of Pri_Op has been + -- explicitly declared, the explicit Pri_Op still overrides the implicit + -- version. + -- Also, even though the explicit Vis_Op for Derived is declared in the + -- private part it still overrides the implicit version declared in the + -- visible part. Calls with tag Derived will execute (A) and (B). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Nov 96 SAIC Improved for ACVC 2.1 + -- + --! + + package C392005_0 is + + type Remote_Camera is tagged private; + + type Depth_Of_Field is range 5 .. 100; + type Shutter_Speed is (One, Two_Fifty, Four_Hundred, Thousand); + type Aperture is (Eight, Sixteen, Thirty_Two); + + -- ...Other declarations. + + procedure Focus (Cam : in out Remote_Camera; + Depth : in Depth_Of_Field); + + procedure Self_Test (C: in out Remote_Camera'Class); + + -- ...Other operations. + + function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field; + function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed; + + private + + type Remote_Camera is tagged record + DOF : Depth_Of_Field := 10; + Shutter: Shutter_Speed := One; + FStop : Aperture := Eight; + end record; + + procedure Set_Shutter_Speed (C : in out Remote_Camera; + Speed : in Shutter_Speed); + + -- For the basic remote camera, shutter speed might be set as a function of + -- focus perhaps, thus it is declared as a private operation (usable + -- only internally within the abstraction). + + function Set_Aperture (C : Remote_Camera) return Aperture; + + end C392005_0; + + + --==================================================================-- + + + package body C392005_0 is + + procedure Focus (Cam : in out Remote_Camera; + Depth : in Depth_Of_Field) is + begin + -- Artificial for testing purposes. + Cam.DOF := 46; + end Focus; + + ----------------------------------------------------------- + procedure Set_Shutter_Speed (C : in out Remote_Camera; + Speed : in Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := Thousand; + end Set_Shutter_Speed; + + ----------------------------------------------------------- + function Set_Aperture (C : Remote_Camera) return Aperture is + begin + -- Artificial for testing purposes. + return Thirty_Two; + end Set_Aperture; + + ----------------------------------------------------------- + procedure Self_Test (C: in out Remote_Camera'Class) is + TC_Dummy_Depth : constant Depth_Of_Field := 23; + TC_Dummy_Speed : constant Shutter_Speed := Four_Hundred; + begin + + -- Test focus at various depths: + Focus(C, TC_Dummy_Depth); + -- ...Additional calls to Focus. + + -- Test various shutter speeds: + Set_Shutter_Speed(C, TC_Dummy_Speed); + -- ...Additional calls to Set_Shutter_Speed. + + end Self_Test; + + ----------------------------------------------------------- + function TC_Get_Depth (C: Remote_Camera) return Depth_Of_Field is + begin + return C.DOF; + end TC_Get_Depth; + + ----------------------------------------------------------- + function TC_Get_Speed (C: Remote_Camera) return Shutter_Speed is + begin + return C.Shutter; + end TC_Get_Speed; + + end C392005_0; + + --==================================================================-- + + + package C392005_0.C392005_1 is + + type Auto_Speed is new Remote_Camera with private; + + + -- procedure Focus (C : in out Auto_Speed; -- Implicitly declared + -- Depth : in Depth_Of_Field) -- here. + + -- For the improved remote camera, shutter speed can be set manually, + -- so it is declared as a public operation. + + -- The order of declarations for Set_Aperture and Set_Shutter_Speed are + -- reversed from the original declarations to trap potential compiler + -- problems related to subprogram ordering. + + function Set_Aperture (C : Auto_Speed) return Aperture; -- Overrides + -- inherited op. + + procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Overrides + Speed : in Shutter_Speed);-- inherited op. + + -- Set_Shutter_Speed and Set_Aperture override the operations inherited + -- from the parent, even though the inherited operations are not implicitly + -- declared until the private part below. + + type New_Camera is private; + + function TC_Get_Aper (C: New_Camera) return Aperture; + + -- ...Other operations. + + private + type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); + + type Auto_Speed is new Remote_Camera with record + ASA : Film_Speed; + end record; + + -- procedure Set_Shutter_Speed (C : in out Auto_Speed; -- Implicitly + -- Speed : in Shutter_Speed) -- declared + -- here. + + -- function Set_Aperture (C : Auto_Speed) return Aperture; -- Implicitly + -- declared. + + procedure Focus (C : in out Auto_Speed; -- Overrides + Depth : in Depth_Of_Field); -- inherited op. + + -- For the improved remote camera, perhaps the focusing algorithm is + -- different, so the original Focus operation is overridden here. + + Auto_Camera : Auto_Speed; + + type New_Camera is record + Aper : Aperture := Set_Aperture (Auto_Camera); -- Calls the overridden, + end record; -- not the inherited op. + + end C392005_0.C392005_1; + + + --==================================================================-- + + + package body C392005_0.C392005_1 is + + procedure Focus (C : in out Auto_Speed; + Depth : in Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 57; + end Focus; + + --------------------------------------------------------------- + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := Two_Fifty; + end Set_Shutter_Speed; + + ----------------------------------------------------------- + function Set_Aperture (C : Auto_Speed) return Aperture is + begin + -- Artificial for testing purposes. + return Sixteen; + end Set_Aperture; + + ----------------------------------------------------------- + function TC_Get_Aper (C: New_Camera) return Aperture is + begin + return C.Aper; + end TC_Get_Aper; + + end C392005_0.C392005_1; + + + --==================================================================-- + + + with C392005_0.C392005_1; + + with Report; + + procedure C392005 is + Basic_Camera : C392005_0.Remote_Camera; + Auto_Camera1 : C392005_0.C392005_1.Auto_Speed; + Auto_Camera2 : C392005_0.C392005_1.Auto_Speed; + Auto_Depth : C392005_0.Depth_Of_Field := 67; + New_Camera1 : C392005_0.C392005_1.New_Camera; + TC_Expected_Basic_Depth : constant C392005_0.Depth_Of_Field := 46; + TC_Expected_Auto_Depth : constant C392005_0.Depth_Of_Field := 57; + TC_Expected_Basic_Speed : constant C392005_0.Shutter_Speed + := C392005_0.Thousand; + TC_Expected_Auto_Speed : constant C392005_0.Shutter_Speed + := C392005_0.Two_Fifty; + TC_Expected_New_Aper : constant C392005_0.Aperture + := C392005_0.Sixteen; + + use type C392005_0.Depth_Of_Field; + use type C392005_0.Shutter_Speed; + use type C392005_0.Aperture; + + begin + Report.Test ("C392005", "Dispatching for overridden primitive " & + "subprograms: private extension declared in child unit, " & + "parent is tagged private whose full view is tagged record"); + + -- Call the class-wide operation for Remote_Camera'Class, which itself makes + -- dispatching calls to Focus and Set_Shutter_Speed: + + + -- For an object of type Remote_Camera, the dispatching calls should + -- dispatch to the bodies declared for the root type: + + C392005_0.Self_Test(Basic_Camera); + + if C392005_0.TC_Get_Depth (Basic_Camera) /= TC_Expected_Basic_Depth + or else C392005_0.TC_Get_Speed (Basic_Camera) /= TC_Expected_Basic_Speed + then + Report.Failed ("Calls dispatched incorrectly for root type"); + end if; + + + -- For an object of type Auto_Speed, the dispatching calls should + -- dispatch to the bodies declared for the derived type: + + C392005_0.Self_Test(Auto_Camera1); + + if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera1) /= TC_Expected_Auto_Depth + + or + C392005_0.C392005_1.TC_Get_Speed(Auto_Camera1) /= TC_Expected_Auto_Speed + then + Report.Failed ("Calls dispatched incorrectly for derived type"); + end if; + + -- For an object of type Auto_Speed, a non-dispatching call to Focus should + + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + C392005_0.C392005_1.Focus (Auto_Camera2, Auto_Depth); + + if C392005_0.C392005_1.TC_Get_Depth(Auto_Camera2) /= TC_Expected_Auto_Depth + + then + Report.Failed ("Non-dispatching call to privately overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of type New_Camera, the initialization using Set_Ap + -- should execute the overridden body, not the inherited one. + + if C392005_0.C392005_1.TC_Get_Aper (New_Camera1) /= TC_Expected_New_Aper + then + Report.Failed ("Non-dispatching call to visible overriding " & + "subprogram executed the wrong body"); + end if; + + Report.Result; + + end C392005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392008.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,401 ---- + -- C392008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the use of a class-wide formal parameter allows for the + -- proper dispatching of objects to the appropriate implementation of + -- a primitive operation. Check this for the case where the root tagged + -- type is defined in a package and the extended type is defined in a + -- dependent package. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type, and some associated primitive operations, + -- in a visible library package. + -- Extend the root type in another visible library package, and override + -- one or more primitive operations, inheriting the other primitive + -- operations from the root type. + -- Derive from the extended type in yet another visible library package, + -- again overriding some primitive operations and inheriting others + -- (including some that the parent inherited). + -- Define subprograms with class-wide parameters, inside of which is a + -- call on a dispatching primitive operation. These primitive + -- operations modify the objects of the specific class passed as actuals + -- to the class-wide formal parameter (class-wide formal parameter has + -- mode IN OUT). + -- + -- The following hierarchy of tagged types and primitive operations is + -- utilized in this test: + -- + -- package Bank + -- type Account (root) + -- | + -- | Operations + -- | proc Deposit + -- | proc Withdrawal + -- | func Balance + -- | proc Service_Charge + -- | proc Add_Interest + -- | proc Open + -- | + -- package Checking + -- type Account (extended from Bank.Account) + -- | + -- | Operations + -- | proc Deposit (inherited) + -- | proc Withdrawal (inherited) + -- | func Balance (inherited) + -- | proc Service_Charge (inherited) + -- | proc Add_Interest (inherited) + -- | proc Open (overridden) + -- | + -- package Interest_Checking + -- type Account (extended from Checking.Account) + -- | + -- | Operations + -- | proc Deposit (inherited twice - Bank.Acct.) + -- | proc Withdrawal (inherited twice - Bank.Acct.) + -- | func Balance (inherited twice - Bank.Acct.) + -- | proc Service_Charge (inherited twice - Bank.Acct.) + -- | proc Add_Interest (overridden) + -- | proc Open (overridden) + -- | + -- + -- In this test, we are concerned with the following selection of dispatching + -- calls, accomplished with the use of a Bank.Account'Class IN OUT formal + -- parameter : + -- + -- \ Type + -- Prim. Op \ Bank.Account Checking.Account Interest_Checking.Account + -- \--------------------------------------------------------- + + -- Service_Charge | X X X + -- Add_Interest | X X X + -- Open | X X X + -- + -- + -- + -- The location of the declaration of the root and derivation of extended + -- types will be varied over a series of tests. Locations of declaration + -- and derivation for a particular test are marked with an asterisk (*). + -- + -- Root type: + -- + -- * Declared in package. + -- Declared in generic package. + -- + -- Extended types: + -- + -- Derived in parent location. + -- Derived in a nested package. + -- Derived in a nested subprogram. + -- Derived in a nested generic package. + -- * Derived in a separate package. + -- Derived in a separate visible child package. + -- Derived in a separate private child package. + -- + -- Primitive Operations: + -- + -- * Procedures with same parameter profile. + -- Procedures with different parameter profile. + -- Functions with same parameter profile. + -- Functions with different parameter profile. + -- Mixture of Procedures and Functions. + -- + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- C392008_0.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 20 Nov 95 SAIC C392B04 became C392008 for ACVC 2.0.1 + -- + --! + + ----------------------------------------------------------------- C392008_0 + + package C392008_0 is -- package Bank + + type Dollar_Amount is range -30_000..30_000; + + type Account is tagged + record + Current_Balance: Dollar_Amount; + end record; + + -- Primitive operations. + + procedure Deposit (A : in out Account; + X : in Dollar_Amount); + procedure Withdrawal (A : in out Account; + X : in Dollar_Amount); + function Balance (A : in Account) return Dollar_Amount; + procedure Service_Charge (A : in out Account); + procedure Add_Interest (A : in out Account); + procedure Open (A : in out Account); + + end C392008_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C392008_0 is + + -- Primitive operations for type Account. + + procedure Deposit (A : in out Account; + X : in Dollar_Amount) is + begin + A.Current_Balance := A.Current_Balance + X; + end Deposit; + + procedure Withdrawal(A : in out Account; + X : in Dollar_Amount) is + begin + A.Current_Balance := A.Current_Balance - X; + end Withdrawal; + + function Balance (A : in Account) return Dollar_Amount is + begin + return (A.Current_Balance); + end Balance; + + procedure Service_Charge (A : in out Account) is + begin + A.Current_Balance := A.Current_Balance - 5_00; + end Service_Charge; + + procedure Add_Interest (A : in out Account) is + Interest_On_Account : Dollar_Amount := 0_00; + begin + A.Current_Balance := A.Current_Balance + Interest_On_Account; + end Add_Interest; + + procedure Open (A : in out Account) is + Initial_Deposit : Dollar_Amount := 10_00; + begin + A.Current_Balance := Initial_Deposit; + end Open; + + end C392008_0; + + ----------------------------------------------------------------- C392008_1 + + with C392008_0; -- package Bank + + package C392008_1 is -- package Checking + + package Bank renames C392008_0; + + type Account is new Bank.Account with + record + Overdraft_Fee : Bank.Dollar_Amount; + end record; + + -- Overridden primitive operation. + + procedure Open (A : in out Account); + + -- Inherited primitive operations. + -- procedure Deposit (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- procedure Withdrawal (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- function Balance (A : in Account) return Bank.Dollar_Amount; + -- procedure Service_Charge (A : in out Account); + -- procedure Add_Interest (A : in out Account); + + end C392008_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C392008_1 is + + -- Overridden primitive operation. + + procedure Open (A : in out Account) is + Check_Guarantee : Bank.Dollar_Amount := 10_00; + Initial_Deposit : Bank.Dollar_Amount := 20_00; + begin + A.Current_Balance := Initial_Deposit; + A.Overdraft_Fee := Check_Guarantee; + end Open; + + end C392008_1; + + ----------------------------------------------------------------- C392008_2 + + with C392008_0; -- with Bank; + with C392008_1; -- with Checking; + + package C392008_2 is -- package Interest_Checking + + package Bank renames C392008_0; + package Checking renames C392008_1; + + subtype Interest_Rate is Bank.Dollar_Amount range 0..100; -- was digits 4; + + Current_Rate : Interest_Rate := 0_02; + + type Account is new Checking.Account with + record + Rate : Interest_Rate; + end record; + + -- Overridden primitive operations. + + procedure Add_Interest (A : in out Account); + procedure Open (A : in out Account); + + -- "Twice" inherited primitive operations (from Bank.Account) + -- procedure Deposit (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- procedure Withdrawal (A : in out Account; + -- X : in Bank.Dollar_Amount); + -- function Balance (A : in Account) return Bank.Dollar_Amount; + -- procedure Service_Charge (A : in out Account); + + end C392008_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C392008_2 is + + -- Overridden primitive operations. + + procedure Add_Interest (A : in out Account) is + Interest_On_Account : Bank.Dollar_Amount + := Bank.Dollar_Amount( Bank."*"( A.Current_Balance, A.Rate )); + begin + A.Current_Balance := Bank."+"( A.Current_Balance, Interest_On_Account); + end Add_Interest; + + procedure Open (A : in out Account) is + Initial_Deposit : Bank.Dollar_Amount := 30_00; + begin + Checking.Open (Checking.Account (A)); + A.Current_Balance := Initial_Deposit; + A.Rate := Current_Rate; + end Open; + + end C392008_2; + + ------------------------------------------------------------------- C392008 + + with C392008_0; use C392008_0; -- package Bank + with C392008_1; use C392008_1; -- package Checking; + with C392008_2; use C392008_2; -- package Interest_Checking; + with Report; + + procedure C392008 is + + package Bank renames C392008_0; + package Checking renames C392008_1; + package Interest_Checking renames C392008_2; + + B_Acct : Bank.Account; + C_Acct : Checking.Account; + IC_Acct : Interest_Checking.Account; + + -- + -- Define procedures with class-wide formal parameters of mode IN OUT. + -- + + -- This procedure will perform a dispatching call on the + -- overridden primitive operation Open. + + procedure New_Account (Acct : in out Bank.Account'Class) is + begin + Open (Acct); -- Dispatch according to tag of class-wide parameter. + end New_Account; + + -- This procedure will perform a dispatching call on the inherited + -- primitive operation (for all types derived from the root Bank.Account) + -- Service_Charge. + + procedure Apply_Service_Charge (Acct: in out Bank.Account'Class) is + begin + Service_Charge (Acct); -- Dispatch according to tag of class-wide parm. + end Apply_Service_Charge; + + -- This procedure will perform a dispatching call on the + -- inherited/overridden primitive operation Add_Interest. + + procedure Annual_Interest (Acct: in out Bank.Account'Class) is + begin + Add_Interest (Acct); -- Dispatch according to tag of class-wide parm. + end Annual_Interest; + + begin + + Report.Test ("C392008", "Check that the use of a class-wide formal " & + "parameter allows for the proper dispatching " & + "of objects to the appropriate implementation " & + "of a primitive operation"); + + -- Check the dispatch to primitive operations overridden for each + -- extended type. + New_Account (B_Acct); + New_Account (C_Acct); + New_Account (IC_Acct); + + if (B_Acct.Current_Balance /= 10_00) or + (C_Acct.Current_Balance /= 20_00) or + (IC_Acct.Current_Balance /= 30_00) + then + Report.Failed ("Failed dispatch to multiply overridden prim. oper."); + end if; + + + Annual_Interest (B_Acct); + Annual_Interest (C_Acct); + Annual_Interest (IC_Acct); -- Check the dispatch to primitive operation + -- overridden from a parent type which inherited + -- the operation from the root type. + if (B_Acct.Current_Balance /= 10_00) or + (C_Acct.Current_Balance /= 20_00) or + (IC_Acct.Current_Balance /= 90_00) + then + Report.Failed ("Failed dispatch to overridden primitive operation"); + end if; + + + Apply_Service_Charge (Acct => B_Acct); + Apply_Service_Charge (Acct => C_Acct); + Apply_Service_Charge (Acct => IC_Acct); -- Check the dispatch to a + -- primitive operation twice + -- inherited from the root + -- tagged type. + if (B_Acct.Current_Balance /= 5_00) or + (C_Acct.Current_Balance /= 15_00) or + (IC_Acct.Current_Balance /= 85_00) + then + Report.Failed ("Failed dispatch to Apply_Service_Charge"); + end if; + + Report.Result; + + end C392008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,512 ---- + -- C392010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a subprogram dispatches correctly with a controlling + -- access parameter. Check that a subprogram dispatches correctly + -- when it has access parameters that are not controlling. + -- Check with and without default expressions. + -- + -- TEST DESCRIPTION: + -- The three packages define layers of tagged types. The root tagged + -- type contains a character value used to check that the right object + -- got passed to the right routine. Each subprogram has a unique + -- TCTouch tag, upper case values are used for subprograms, lower case + -- values are used for object values. + -- + -- Notes on style: the "tagged" comment lines --I and --A represent + -- commentary about what gets inherited and what becomes abstract, + -- respectively. The author felt these to be necessary with this test + -- to reduce some of the additional complexities. + -- + --3.9.2(16,17,18,20);6.0 + -- + -- CHANGE HISTORY: + -- 22 SEP 95 SAIC Initial version + -- 22 APR 96 SAIC Revised for 2.1 + -- 05 JAN 98 EDS Change return type of C392010_2.Func_W_Non to make + -- it override. + -- 21 JUN 00 RLB Changed expected result to reflect the appropriate + -- value of the default expression. + -- 20 JUL 00 RLB Removed entire call pending resolution by the ARG. + + --! + + ----------------------------------------------------------------- C392010_0 + + package C392010_0 is + + -- define a root tagged type + type Tagtype_Level_0 is tagged record + Ch_Item : Character; + end record; + + type Access_Procedure is access procedure( P: Tagtype_Level_0 ); + + procedure Proc_1( P: Tagtype_Level_0 ); + + procedure Proc_2( P: Tagtype_Level_0 ); + + function A_Default_Value return Tagtype_Level_0; + + procedure Proc_w_Ap_and_Cp( AP : Access_Procedure; + Cp : Tagtype_Level_0 ); + -- has both access procedure and controlling parameter + + procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; + Cp : Tagtype_Level_0 + := A_Default_Value ); ------------ z + -- has both access procedure and controlling parameter with defaults + + -- for the objective: + -- Check that access parameters may be controlling. + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ); + -- has access parameter that is controlling + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) + return Tagtype_Level_0; + -- has access parameter that is controlling, and controlling result + + Level_0_Global_Object : aliased Tagtype_Level_0 + := ( Ch_Item => 'a' ); ---------------------------- a + + end C392010_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C392010_0 is + + procedure Proc_1( P: Tagtype_Level_0 ) is + begin + TCTouch.Touch('A'); --------------------------------------------------- A + TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? + end Proc_1; + + procedure Proc_2( P: Tagtype_Level_0 ) is + begin + TCTouch.Touch('B'); --------------------------------------------------- B + TCTouch.Touch(P.Ch_Item); -- depends on the value passed -------------- ? + end Proc_2; + + function A_Default_Value return Tagtype_Level_0 is + begin + return (Ch_Item => 'z'); ---------------------------------------------- z + end A_Default_Value; + + procedure Proc_w_Ap_and_Cp( Ap : Access_Procedure; + Cp : Tagtype_Level_0 ) is + begin + TCTouch.Touch('C'); --------------------------------------------------- C + Ap.all( Cp ); + end Proc_w_Ap_and_Cp; + + procedure Proc_w_Ap_and_Cp_w_Def( AP : Access_Procedure := Proc_2'Access; + Cp : Tagtype_Level_0 + := A_Default_Value ) is + begin + TCTouch.Touch('D'); --------------------------------------------------- D + Ap.all( Cp ); + end Proc_w_Ap_and_Cp_w_Def; + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_0 ) is + begin + TCTouch.Touch('E'); --------------------------------------------------- E + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + end Proc_w_Cp_Ap; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_0 ) + return Tagtype_Level_0 is + begin + TCTouch.Touch('F'); --------------------------------------------------- F + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + return ( Ch_Item => 'b' ); -------------------------------------------- b + end Func_w_Cp_Ap_and_Cr; + + end C392010_0; + + ----------------------------------------------------------------- C392010_1 + + with C392010_0; + package C392010_1 is + + type Tagtype_Level_1 is new C392010_0.Tagtype_Level_0 with record + Int_Item : Integer; + end record; + + type Access_Tagtype_Level_1 is access all Tagtype_Level_1'Class; + + -- the following procedures are inherited by the above declaration: + --I procedure Proc_1( P: Tagtype_Level_1 ); + --I + --I procedure Proc_2( P: Tagtype_Level_1 ); + --I + --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + --I Cp : Tagtype_Level_1 ); + --I + --I procedure Proc_w_Ap_and_Cp_w_Def + --I ( AP : C392010_0.Access_Procedure := Proc_2'Access; + --I Cp : Tagtype_Level_1 := A_Default_Value ); + --I + --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); + --I + + -- the following functions become abstract due to the above declaration: + --A function A_Default_Value return Tagtype_Level_1; + --A + --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + --A return Tagtype_Level_1; + + -- so, in the interest of testing dispatching, we override them all: + -- except Proc_1 and Proc_2 + + procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + Cp : Tagtype_Level_1 ); + + function A_Default_Value return Tagtype_Level_1; + + procedure Proc_w_Ap_and_Cp_w_Def( + AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; + Cp : Tagtype_Level_1 := A_Default_Value ); + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ); + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + return Tagtype_Level_1; + + -- to test the objective: + -- Check that a subprogram dispatches correctly when it has + -- access parameters that are not controlling. + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) + return Access_Tagtype_Level_1; + + Level_1_Global_Object : aliased Tagtype_Level_1 + := ( Int_Item => 0, + Ch_Item => 'c' ); --------------------------- c + + end C392010_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C392010_1 is + + procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + Cp : Tagtype_Level_1 ) is + begin + TCTouch.Touch('G'); --------------------------------------------------- G + Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); + end Proc_w_Ap_and_Cp; + + procedure Proc_w_Ap_and_Cp_w_Def( + AP : C392010_0.Access_Procedure := C392010_0.Proc_2'Access; + Cp : Tagtype_Level_1 := A_Default_Value ) + is + begin + TCTouch.Touch('H'); --------------------------------------------------- H + Ap.All( C392010_0.Tagtype_Level_0( Cp ) ); + end Proc_w_Ap_and_Cp_w_Def; + + procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_1 ) is + begin + TCTouch.Touch('I'); --------------------------------------------------- I + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + end Proc_w_Cp_Ap; + + function A_Default_Value return Tagtype_Level_1 is + begin + return ( Int_Item => 0, Ch_Item => 'y' ); ---------------------------- y + end A_Default_Value; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_1 ) + return Tagtype_Level_1 is + begin + TCTouch.Touch('J'); --------------------------------------------------- J + TCTouch.Touch(Cp_Ap.Ch_Item); -- depends on the value passed ---------- ? + return ( Int_Item => 2, Ch_Item => 'd' ); ----------------------------- d + end Func_w_Cp_Ap_and_Cr; + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) is + begin + TCTouch.Touch('K'); --------------------------------------------------- K + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + end Proc_w_Non; + + Own_Item : aliased Tagtype_Level_1 := ( Int_Item => 3, Ch_Item => 'e' ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_1; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := C392010_0.Level_0_Global_Object'Access ) + return Access_Tagtype_Level_1 is + begin + TCTouch.Touch('L'); --------------------------------------------------- L + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + return Own_Item'Access; ----------------------------------------------- e + end Func_w_Non; + + end C392010_1; + + + + ----------------------------------------------------------------- C392010_2 + + with C392010_0; + with C392010_1; + package C392010_2 is + + Lev2_Level_0_Global_Object : aliased C392010_0.Tagtype_Level_0 + := ( Ch_Item => 'f' ); ---------------------------- f + + type Tagtype_Level_2 is new C392010_1.Tagtype_Level_1 with record + Another_Int_Item : Integer; + end record; + + type Access_Tagtype_Level_2 is access all Tagtype_Level_2; + + -- the following procedures are inherited by the above declaration: + --I procedure Proc_1( P: Tagtype_Level_2 ); + --I + --I procedure Proc_2( P: Tagtype_Level_2 ); + --I + --I procedure Proc_w_Ap_and_Cp( AP : C392010_0.Access_Procedure; + --I Cp : Tagtype_Level_2 ); + --I + --I procedure Proc_w_Ap_and_Cp_w_Def + --I (AP: C392010_0.Access_Procedure := C392010_0. Proc_2'Access; + --I CP: Tagtype_Level_2 := A_Default_Value ); + --I + --I procedure Proc_w_Cp_Ap( Cp_Ap : access Tagtype_Level_2 ); + --I + --I procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + --I NonCp_Ap : access C392010_0.Tagtype_Level_0 + --I := C392010_0.Level_0_Global_Object'Access ); + + -- the following functions become abstract due to the above declaration: + --A function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + --A return Tagtype_Level_2; + --A + --A function A_Default_Value + --A return Access_Tagtype_Level_2; + + -- so we override the interesting ones to check the objective: + -- Check that a subprogram with parameters of distinct tagged types may + -- be primitive for only one type (i.e. the other tagged types must be + -- declared in other packages). Check that the subprogram does not + -- dispatch for the other type(s). + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) + return C392010_1.Access_Tagtype_Level_1; + + -- and override the other abstract functions + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + return Tagtype_Level_2; + + function A_Default_Value return Tagtype_Level_2; + + end C392010_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + with Report; + package body C392010_2 is + + procedure Proc_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) is + begin + TCTouch.Touch('M'); --------------------------------------------------- M + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + end Proc_w_Non; + + function A_Default_Value return Tagtype_Level_2 is + begin + return ( Another_Int_Item | Int_Item => 0, Ch_Item => 'x' ); -------- x + end A_Default_Value; + + Own : aliased Tagtype_Level_2 + := ( Another_Int_Item | Int_Item => 4, Ch_Item => 'g' ); + + function Func_w_Non( Cp_Ap : access Tagtype_Level_2; + NonCp_Ap : access C392010_0.Tagtype_Level_0 + := Lev2_Level_0_Global_Object'Access ) + return C392010_1.Access_Tagtype_Level_1 is + begin + TCTouch.Touch('N'); --------------------------------------------------- N + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + TCTouch.Touch(NonCp_Ap.Ch_Item); -- depends on the value passed ------- ? + return Own'Access; ---------------------------------------------------- g + end Func_w_Non; + + function Func_w_Cp_Ap_and_Cr( Cp_Ap : access Tagtype_Level_2 ) + return Tagtype_Level_2 is + begin + TCTouch.Touch('P'); --------------------------------------------------- P + TCTouch.Touch(Cp_Ap.Ch_Item); ----- depends on the value passed ------- ? + return ( Another_Int_Item | Int_Item => 5, Ch_Item => 'h' ); ---------- h + end Func_w_Cp_Ap_and_Cr; + + end C392010_2; + + + + ------------------------------------------------------------------- C392010 + + with Report; + with TCTouch; + with C392010_0, C392010_1, C392010_2; + + procedure C392010 is + + type Access_Class_0 is access all C392010_0.Tagtype_Level_0'Class; + + -- define an array of class-wide pointers: + type Zero_Dispatch_List is array(Natural range <>) of Access_Class_0; + + Item_0 : aliased C392010_0.Tagtype_Level_0 := ( Ch_Item => 'k' ); ------ k + Item_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'm', ------ m + Int_Item => 1 ); + Item_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'n', ------ n + Int_Item => 1, + Another_Int_Item => 1 ); + + Z: Zero_Dispatch_List(1..3) := (Item_0'Access,Item_1'Access,Item_2'Access); + + procedure Subtest_1( Items: Zero_Dispatch_List ) is + -- there is little difference between the actions for _1 and _2 in + -- this subtest due to the nature of _2 inheriting most operations + -- + -- this subtest checks operations available to Level_0'Class + begin + for I in Items'Range loop + + C392010_0.Proc_w_Ap_and_Cp( C392010_0.Proc_1'Access, Items(I).all ); + -- CAk, GAm, GAn + -- actual is class-wide, operation should dispatch + + case I is -- use defaults + when 1 => C392010_0.Proc_w_Ap_and_Cp_w_Def; + -- DBz + when 2 => C392010_1.Proc_w_Ap_and_Cp_w_Def; + -- HBy + when 3 => null; -- Removed following pending resolution by ARG + -- (see AI-00239): + -- C392010_2.Proc_w_Ap_and_Cp_w_Def; + -- HBx + when others => Report.Failed("Unexpected loop value"); + end case; + + C392010_0.Proc_w_Ap_and_Cp_w_Def -- override defaults + ( C392010_0.Proc_1'Access, Items(I).all ); + -- DAk, HAm, HAn + + C392010_0.Proc_w_Cp_Ap( Items(I) ); + -- Ek, Im, In + + -- function return value is controlling for procedure call + C392010_0.Proc_w_Ap_and_Cp_w_Def( C392010_0.Proc_1'Access, + C392010_0.Func_w_Cp_Ap_and_Cr( Items(I) ) ); + -- FkDAb, JmHAd, PnHAh + -- note that the function evaluates first + + end loop; + end Subtest_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + type Access_Class_1 is access all C392010_1.Tagtype_Level_1'Class; + + type One_Dispatch_List is array(Natural range <>) of Access_Class_1; + + Object_1 : aliased C392010_1.Tagtype_Level_1 := ( Ch_Item => 'p', ----- p + Int_Item => 1 ); + Object_2 : aliased C392010_2.Tagtype_Level_2 := ( Ch_Item => 'q', ----- q + Int_Item => 1, + Another_Int_Item => 1 ); + + D: One_Dispatch_List(1..2) := (Object_1'Access, Object_2'Access); + + procedure Subtest_2( Items: One_Dispatch_List ) is + -- this subtest checks operations available to Level_1'Class, + -- specifically those operations that are not testable in subtest_1, + -- the operations with parameters of the two tagged type objects. + begin + for I in Items'Range loop + + C392010_1.Proc_w_Non( -- t_1, t_2 + C392010_1.Func_w_Non( Items(I), + C392010_0.Tagtype_Level_0(Z(I).all)'Access ), -- Lpk Nqm + C392010_0.Tagtype_Level_0(Z(I+1).all)'Access ); -- Kem Mgn + + end loop; + end Subtest_2; + + begin -- Main test procedure. + + Report.Test ("C392010", "Check that a subprogram dispatches correctly " & + "with a controlling access parameter. " & + "Check that a subprogram dispatches correctly " & + "when it has access parameters that are not " & + "controlling. Check with and without default " & + "expressions" ); + + Subtest_1( Z ); + + -- Original result: + --TCTouch.Validate( "CAkDBzDAkEkFkDAb" + -- & "GAmHByHAmImJmHAd" + -- & "GAnHBxHAnInPnHAh", "Subtest 1" ); + + -- Result pending resultion of AI-239: + TCTouch.Validate( "CAkDBzDAkEkFkDAb" + & "GAmHByHAmImJmHAd" + & "GAnHAnInPnHAh", "Subtest 1" ); + + Subtest_2( D ); + + TCTouch.Validate( "LpkKem" & "NqmMgn", "Subtest 2" ); + + Report.Result; + + end C392010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392011.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,299 ---- + -- C392011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a function call with a controlling result is itself + -- a controlling operand of an enclosing call on a dispatching operation, + -- then its controlling tag value is determined by the controlling tag + -- value of the enclosing call. + -- + -- TEST DESCRIPTION: + -- The test builds and traverses a "ragged" list; a linked list which + -- contains data elements of three different types (all rooted at + -- Level_0'Class). The traversal of this list checks the objective + -- by calling the dispatching operation "Check" using an item from the + -- list, and calling the function create; thus causing the controlling + -- result of the function to be determined by evaluating the value of + -- the other controlling parameter to the two-parameter Check. + -- + -- + -- CHANGE HISTORY: + -- 22 SEP 95 SAIC Initial version + -- 23 APR 96 SAIC Corrected commentary, differentiated integer. + -- + --! + + ----------------------------------------------------------------- C392011_0 + + package C392011_0 is + + type Level_0 is tagged record + Ch_Item : Character; + end record; + + function Create return Level_0; + -- primitive dispatching function + + procedure Check( Left, Right: in Level_0 ); + -- has controlling parameters + + end C392011_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body C392011_0 is + + The_Character : Character := 'A'; + + function Create return Level_0 is + Created_Item_0 : constant Level_0 := ( Ch_Item => The_Character ); + begin + The_Character := Character'Succ(The_Character); + TCTouch.Touch('A'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- A + return Created_Item_0; + end Create; + + procedure Check( Left, Right: in Level_0 ) is + begin + TCTouch.Touch('B'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- B + end Check; + + end C392011_0; + + ----------------------------------------------------------------- C392011_1 + + with C392011_0; + package C392011_1 is + + type Level_1 is new C392011_0.Level_0 with record + Int_Item : Integer; + end record; + + -- note that Create becomes abstract upon this derivation hence: + + function Create return Level_1; + + procedure Check( Left, Right: in Level_1 ); + + end C392011_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C392011_1 is + + Integer_1 : Integer := 0; + + function Create return Level_1 is + Created_Item_1 : constant Level_1 + := ( C392011_0.Create with Int_Item => Integer_1 ); + -- note call to ^--------------^ -- A + begin + Integer_1 := Integer'Succ(Integer_1); + TCTouch.Touch('C'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- C + return Created_Item_1; + end Create; + + procedure Check( Left, Right: in Level_1 ) is + begin + TCTouch.Touch('D'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- D + end Check; + + end C392011_1; + + ----------------------------------------------------------------- C392011_2 + + with C392011_1; + package C392011_2 is + + type Level_2 is new C392011_1.Level_1 with record + Another_Int_Item : Integer; + end record; + + -- note that Create becomes abstract upon this derivation hence: + + function Create return Level_2; + + procedure Check( Left, Right: in Level_2 ); + + end C392011_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C392011_2 is + + Integer_2 : Integer := 100; + + function Create return Level_2 is + Created_Item_2 : constant Level_2 + := ( C392011_1.Create with Another_Int_Item => Integer_2 ); + -- note call to ^--------------^ -- AC + begin + Integer_2 := Integer'Succ(Integer_2); + TCTouch.Touch('E'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- E + return Created_Item_2; + end Create; + + procedure Check( Left, Right: in Level_2 ) is + begin + TCTouch.Touch('F'); -- --- ---- ----- ---- --- -- --- ---- ----- ---- -- F + end Check; + + end C392011_2; + + ------------------------------------------------------- C392011_2.C392011_3 + + with C392011_0; + package C392011_2.C392011_3 is + + type Wide_Reference is access all C392011_0.Level_0'Class; + + type Ragged_Element; + + type List_Pointer is access Ragged_Element; + + type Ragged_Element is record + Data : Wide_Reference; + Next : List_Pointer; + end record; + + procedure Build_List; + + procedure Traverse_List; + + end C392011_2.C392011_3; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C392011_2.C392011_3 is + + The_List : List_Pointer; + + procedure Build_List is + begin + + -- build a list that looks like: + -- Level_2, Level_1, Level_2, Level_1, Level_0 + -- + -- the mechanism is to create each object, "pushing" the existing list + -- onto the end: cons( new_item, car, cdr ) + + The_List := + new Ragged_Element'( new C392011_0.Level_0'(C392011_0.Create), null ); + -- Level_0 >> A + + The_List := + new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); + -- Level_1 -> Level_0 >> AC + + The_List := + new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); + -- Level_2 -> Level_1 -> Level_0 >> ACE + + The_List := + new Ragged_Element'( new C392011_1.Level_1'(C392011_1.Create), The_List ); + -- Level_1 -> Level_2 -> Level_1 -> Level_0 >> AC + + The_List := + new Ragged_Element'( new C392011_2.Level_2'(C392011_2.Create), The_List ); + -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 >> ACE + + end Build_List; + + procedure Traverse_List is + + Next_Item : List_Pointer := The_List; + + -- Check that if a function call with a controlling result is itself + -- a controlling operand of an enclosing call on a dispatching operation, + -- then its controlling tag value is determined by the controlling tag + -- value of the enclosing call. + + -- Level_2 -> Level_1 -> Level_2 -> Level_1 -> Level_0 + + begin + + while Next_Item /= null loop -- here we go! + -- these calls better dispatch according to the value in the particular + -- list item; causing the call to create to dispatch accordingly. + -- why do it twice? To make sure order makes no difference + + C392011_0.Check(Next_Item.Data.all, C392011_0.Create); + -- Create will touch first, then Check touches + + C392011_0.Check(C392011_0.Create, Next_Item.Data.all); + + -- Here's what's s'pos'd to 'appen: + -- Check( Lev_2, Create ) >> ACEF + -- Check( Create, Lev_2 ) >> ACEF + -- Check( Lev_1, Create ) >> ACD + -- Check( Create, Lev_1 ) >> ACD + -- Check( Lev_2, Create ) >> ACEF + -- Check( Create, Lev_2 ) >> ACEF + -- Check( Lev_1, Create ) >> ACD + -- Check( Create, Lev_1 ) >> ACD + -- Check( Lev_0, Create ) >> AB + -- Check( Create, Lev_0 ) >> AB + + Next_Item := Next_Item.Next; + end loop; + end Traverse_List; + + end C392011_2.C392011_3; + + ------------------------------------------------------------------- C392011 + + with Report; + with TCTouch; + with C392011_2.C392011_3; + + procedure C392011 is + + begin -- Main test procedure. + + Report.Test ("C392011", "Check that if a function call with a " & + "controlling result is itself a controlling " & + "operand of an enclosing call on a dispatching " & + "operation, then its controlling tag value is " & + "determined by the controlling tag value of " & + "the enclosing call" ); + + C392011_2.C392011_3.Build_List; + TCTouch.Validate( "A" & "AC" & "ACE" & "AC" & "ACE", "Build List" ); + + C392011_2.C392011_3.Traverse_List; + TCTouch.Validate( "ACEFACEF" & + "ACDACD" & + "ACEFACEF" & + "ACDACD" & + "ABAB", + "Traverse List" ); + + Report.Result; + + end C392011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392013.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- C392013.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the "/=" implicitly declared with the declaration of "=" for + -- a tagged type is legal and can be used in a dispatching call. + -- (Defect Report 8652/0010, as reflected in Technical Corrigendum 1). + -- + -- CHANGE HISTORY: + -- 23 JAN 2001 PHL Initial version. + -- 16 MAR 2001 RLB Readied for release; added identity and negative + -- result cases. + -- 24 MAY 2001 RLB Corrected the result for the 9 vs. 9 case. + --! + with Report; + use Report; + procedure C392013 is + + package P1 is + type T is tagged + record + C1 : Integer; + end record; + function "=" (L, R : T) return Boolean; + end P1; + + package P2 is + type T is new P1.T with private; + function Make (Ancestor : P1.T; X : Float) return T; + private + type T is new P1.T with + record + C2 : Float; + end record; + function "=" (L, R : T) return Boolean; + end P2; + + package P3 is + type T is new P2.T with + record + C3 : Character; + end record; + private + function "=" (L, R : T) return Boolean; + function Make (Ancestor : P1.T; X : Float) return T; + end P3; + + + package body P1 is separate; + package body P2 is separate; + package body P3 is separate; + + + type Cwat is access P1.T'Class; + type Cwat_Array is array (Positive range <>) of Cwat; + + A : constant Cwat_Array := + (1 => new P1.T'(C1 => Ident_Int (3)), + 2 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 4.0)), + 3 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (-5)), X => 4.2)), + 4 => new P1.T'(C1 => Ident_Int (-3)), + 5 => new P2.T'(P2.Make (Ancestor => (C1 => Ident_Int (5)), X => 3.6)), + 6 => new P1.T'(C1 => Ident_Int (4)), + 7 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (4)), X => 1.2) with + Ident_Char ('a')), + 8 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (-4)), X => 1.3) with + Ident_Char ('A')), + 9 => new P3.T'(P2.Make + (Ancestor => (C1 => Ident_Int (4)), X => 1.0) with + Ident_Char ('B'))); + + type Truth is ('F', 'T'); + type Truth_Table is array (Positive range <>, Positive range <>) of Truth; + + Equality : constant Truth_Table (A'Range, A'Range) := ("TFFTFFFFF", + "FTTFTFFFF", + "FTTFFFFFF", + "TFFTFFFFF", + "FTFFTFFFF", + "FFFFFTFFF", + "FFFFFFTTF", + "FFFFFFTTF", + "FFFFFFFFT"); + + begin + Test ("C392013", "Check that the ""/="" implicitly declared " & + "with the declaration of ""="" for a tagged " & + "type is legal and can be used in a dispatching call"); + + for I in A'Range loop + for J in A'Range loop + -- Test identity: + if P1."=" (A (I).all, A (J).all) /= + (not P1."/=" (A (I).all, A (J).all)) then + Failed ("Incorrect identity comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J)); + end if; + -- Test the result of "/=": + if Equality (I, J) = 'T' then + if P1."/=" (A (I).all, A (J).all) then + Failed ("Incorrect result comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J) & " - T"); + end if; + else + if not P1."/=" (A (I).all, A (J).all) then + Failed ("Incorrect result comparing objects" & + Positive'Image (I) & " and" & Positive'Image (J) & " - F"); + end if; + end if; + end loop; + end loop; + + Result; + end C392013; + separate (C392013) + package body P1 is + + function "=" (L, R : T) return Boolean is + begin + return abs L.C1 = abs R.C1; + end "="; + + end P1; + separate (C392013) + package body P2 is + + function "=" (L, R : T) return Boolean is + begin + return P1."=" (P1.T (L), P1.T (R)) and then abs (L.C2 - R.C2) <= 0.5; + end "="; + + + function Make (Ancestor : P1.T; X : Float) return T is + begin + return (Ancestor with X); + end Make; + + end P2; + with Ada.Characters.Handling; + separate (C392013) + package body P3 is + + function "=" (L, R : T) return Boolean is + begin + return P2."=" (P2.T (L), P2.T (R)) and then + Ada.Characters.Handling.To_Upper (L.C3) = + Ada.Characters.Handling.To_Upper (R.C3); + end "="; + + function Make (Ancestor : P1.T; X : Float) return T is + begin + return (P2.Make (Ancestor, X) with ' '); + end Make; + + end P3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392014.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,225 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392a01.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,265 ---- + -- C392A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the use of a class-wide formal parameter allows for the + -- proper dispatching of objects to the appropriate implementation of + -- a primitive operation. Check this for the root tagged type defined + -- in a package, and the extended type is defined in that same package. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type, and some associated primitive operations. + -- Extend the root type, and override one or more primitive operations, + -- inheriting the other primitive operations from the root type. + -- Derive from the extended type, again overriding some primitive + -- operations and inheriting others (including some that the parent + -- inherited). + -- Define a subprogram with a class-wide parameter, inside of which is a + -- call on a dispatching primitive operation. These primitive operations + -- modify global variables (the class-wide parameter has mode IN). + -- + -- + -- + -- The following hierarchy of tagged types and primitive operations is + -- utilized in this test: + -- + -- type Bank_Account (root) + -- | + -- | Operations + -- | Increment_Bank_Reserve + -- | Assign_Representative + -- | Increment_Counters + -- | Open + -- | + -- type Savings_Account (extended from Bank_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited) + -- | Assign_Representative (overridden) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- | + -- type Preferred_Account (extended from Savings_Account) + -- | + -- | Operations + -- | (Increment_Bank_Reserve) (inherited twice - Bank_Acct.) + -- | (Assign_Representative) (inherited - Savings_Acct.) + -- | Increment_Counters (overridden) + -- | Open (overridden) + -- + -- + -- In this test, we are concerned with the following selection of dispatching + -- calls, accomplished with the use of a Bank_Account'Class IN procedure + -- parameter : + -- + -- \ Type + -- Prim. Op \ Bank_Account Savings_Account Preferred_Account + -- \------------------------------------------------ + -- Increment_Bank_Reserve| X X X + -- Assign_Representative | X + -- Increment_Counters | X X X + -- + -- + -- + -- The location of the declaration and derivation of the root and extended + -- types will be varied over a series of tests. Locations of declaration + -- and derivation for a particular test are marked with an asterisk (*). + -- + -- Root type: + -- + -- * Declared in package. + -- Declared in generic package. + -- + -- Extended types: + -- + -- * Derived in parent location. + -- Derived in a nested package. + -- Derived in a nested subprogram. + -- Derived in a nested generic package. + -- Derived in a separate package. + -- Derived in a separate visible child package. + -- Derived in a separate private child package. + -- + -- Primitive Operations: + -- + -- * Procedures with same parameter profile. + -- Procedures with different parameter profile. + -- Functions with same parameter profile. + -- Functions with different parameter profile. + -- Mixture of Procedures and Functions. + -- + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F392A00.A + -- + -- The following files comprise this test: + -- + -- => C392A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F392A00; -- package Accounts + with Report; + + procedure C392A01 is + + package Accounts renames F392A00; + + -- Declare account objects. + + B_Account : Accounts.Bank_Account; + S_Account : Accounts.Savings_Account; + P_Account : Accounts.Preferred_Account; + + -- Procedures to operate on accounts. + -- Each uses a class-wide IN parameter, as well as a call to a + -- dispatching operation. + + -- Procedure Tabulate_Account performs a dispatching call on a primitive + -- operation that has been overridden for each of the extended types. + + procedure Tabulate_Account (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Counters (Acct); -- Dispatch according to tag. + end Tabulate_Account; + + + -- Procedure Accumulate_Reserve performs a dispatching call on a + -- primitive operation that has been defined for the root type and + -- inherited by each derived type. + + procedure Accumulate_Reserve (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Increment_Bank_Reserve (Acct); -- Dispatch according to tag. + end Accumulate_Reserve; + + + -- Procedure Resolve_Dispute performs a dispatching call on a primitive + -- operation that has been defined in the root type, overridden in the + -- first derived extended type, and inherited by the subsequent extended + -- type. + + procedure Resolve_Dispute (Acct : in Accounts.Bank_Account'Class) is + begin + Accounts.Assign_Representative (Acct); -- Dispatch according to tag. + end Resolve_Dispute; + + + + begin -- Main test procedure. + + Report.Test ("C392A01", "Check that the use of a class-wide parameter " & + "allows for proper dispatching where root type " & + "and extended types are declared in the same " & + "package" ); + + Bank_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (B_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been defined for this specific type. + Accumulate_Reserve (Acct => B_Account); + Tabulate_Account (B_Account); + + if (Accounts.Bank_Reserve /= Accounts.Opening_Balance) or + (Accounts.Number_Of_Accounts (Bank) /= 1) or + (Accounts.Number_Of_Accounts (Total) /= 1) + then + Report.Failed ("Failed in Bank_Account_Subtest"); + end if; + + end Bank_Account_Subtest; + + + Savings_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been inherited by this extended type. + Accumulate_Reserve (Acct => S_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type. + Resolve_Dispute (Acct => S_Account); + Tabulate_Account (S_Account); + + if Accounts.Bank_Reserve /= (3.0 * Accounts.Opening_Balance) or + Accounts.Daily_Representative /= Accounts.Manager or + Accounts.Number_Of_Accounts (Savings) /= 1 or + Accounts.Number_Of_Accounts (Total) /= 2 + then + Report.Failed ("Failed in Savings_Account_Subtest"); + end if; + + end Savings_Account_Subtest; + + + Preferred_Account_Subtest: + declare + use Accounts; + begin + Accounts.Open (P_Account); + + -- Verify that the correct implementation of Open (overridden) was + -- used for the Preferred_Account object. + if not Accounts.Verify_Open (P_Account) then + Report.Failed ("Incorrect values for init. Preferred Acct object"); + end if; + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been twice inherited by this extended type. + Accumulate_Reserve (Acct => P_Account); + + -- Demonstrate class-wide parameter allowing dispatch by a primitive + -- operation that has been overridden for this extended type (the + -- operation was overridden by its parent type as well). + Tabulate_Account (P_Account); + + if Accounts.Bank_Reserve /= 1300.00 or + Accounts.Number_Of_Accounts (Preferred) /= 1 or + Accounts.Number_Of_Accounts (Total) /= 3 + then + Report.Failed ("Failed in Preferred_Account_Subtest"); + end if; + + end Preferred_Account_Subtest; + + + Report.Result; + + end C392A01; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392c05.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392c05.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392c05.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392c05.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C392C05.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a call to a dispatching subprogram the subprogram + -- body which is executed is determined by the controlling tag for + -- the case where the call has statically tagged controlling operands + -- of the type T. Check this for various operands of tagged types: + -- objects (declared or allocated), formal parameters, view conversions, + -- function calls (both primitive and non-primitive). + -- + -- TEST DESCRIPTION: + -- This test uses foundation F392C00 to test the usages of statically + -- tagged objects and values. The calls to Validate indicate the + -- expected sequence of procedure calls since the previous call to + -- Validate. Static tags can be determined at compile time, and + -- hence this is a test of correct overload resolution for tagged types. + -- A clever compiler which unrolls loops and does path analysis on + -- access values will be able to perform the same kind of determination + -- for all of the code in this test. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F392C00.A (foundation code) + -- C392C05.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 24 Oct 95 SAIC Updated for ACVC 2.0.1 + -- 13 Feb 97 PWB.CTA Corrected assumption that "or" operands are + -- evaluated in textual order. + --! + + with Report; + with TCTouch; + with F392C00_1; + procedure C392C05 is -- Hardware_Store + + package Switch renames F392C00_1; + + subtype Switch_Class is Switch.Toggle'Class; + + type Reference is access all Switch_Class; + + A_Switch : aliased Switch.Toggle; + A_Dimmer : aliased Switch.Dimmer; + An_Autodim : aliased Switch.Auto_Dimmer; + + type Light_Bank is array(Positive range <>) of Reference; + + Lamps : Light_Bank(1..3); + + begin -- Main test procedure. + + Report.Test ("C392C05", "Check that a dispatching subprogram call is " + & "determined by the controlling tag for statically " + & "tagged controlling operands" ); + + -- Check use of static tagged declared objects, + -- and static tagged formal parameters + -- Must call correct version of flip based on type of controlling op. + + -- Turn on the lights! + + Switch.Flip( A_Switch ); + TCTouch.Validate( "A", "Declared Toggle" ); + + Switch.Flip( A_Dimmer ); + TCTouch.Validate( "GBA", "Declared Dimmer" ); + + Switch.Flip( An_Autodim ); + TCTouch.Validate( "KGBA", "Declared Auto_Dimmer" ); + + Lamps(1) := new Switch.Toggle; + Lamps(2) := new Switch.Dimmer; + Lamps(3) := new Switch.Auto_Dimmer; + + -- Check use of static tagged allocated objects, + -- and static tagged formal parameters in a loop which may dynamically + -- dispatch. If an optimizer unrolls the loop, it may then be statically + -- determined, and no dispatching will occur. Either interpretation is + -- correct. + for Knob in Lamps'Range loop + Switch.Flip( Lamps(Knob).all ); + end loop; + TCTouch.Validate( "AGBAKGBA", "Allocated Objects" ); + + -- Check use of static tagged declared objects, + -- calling non-primitive functions. + if not Switch.TC_Non_Disp( A_Switch ) then + Report.Failed( "Bad Value 1" ); + end if; + TCTouch.Validate( "X", "Nonprimitive Function" ); + + if not Switch.TC_Non_Disp( A_Dimmer ) then + Report.Failed( "Bad Value 2" ); + end if; + TCTouch.Validate( "Y", "Nonprimitive Function" ); + + if not Switch.TC_Non_Disp( An_Autodim ) then + Report.Failed( "Bad Value 3" ); + end if; + TCTouch.Validate( "Z", "Nonprimitive Function" ); + + A_Switch := Switch.Create; + A_Dimmer := Switch.Create; + An_Autodim := Switch.Create; + TCTouch.Validate( "123", "Primitive Function" ); + + -- View conversions + Switch.Brighten( An_Autodim, 50 ); + + Switch.Flip( Switch.Toggle( A_Switch ) ); + Switch.Flip( Switch.Toggle( A_Dimmer ) ); + Switch.Flip( Switch.Dimmer( An_Autodim ) ); + TCTouch.Validate( "DAAGBA", "View Conversions" ); + + -- statically tagged controlling operands (specific types) provided to + -- class-wide functions + if Switch.On( A_Switch ) + or Switch.On( A_Dimmer ) + or Switch.On( An_Autodim ) then + Report.Failed( "Bad Value 4" ); + end if; + TCTouch.Validate( "BBB", "Class-wide" ); + + -- statically tagged controlling operands qualified expressions provided to + -- primitive functions, also using context to determine call to a + -- class-wide function. + if Switch.Off( Switch.Toggle'( Switch.Create ) ) + or else Switch.Off( Switch.Dimmer'( Switch.Create ) ) + or else Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then + Report.Failed( "Bad Value 5" ); + end if; + TCTouch.Validate( "1C2C3C", "Qualified Expression/Class-Wide" ); + + Report.Result; + + end C392C05; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392c07.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392c07.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392c07.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392c07.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,190 ---- + -- C392C07.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a call to a dispatching subprogram the subprogram + -- body which is executed is determined by the controlling tag for + -- the case where the call has dynamic tagged controlling operands + -- of the type T. Check for calls to these same subprograms where + -- the operands are of specific statically tagged types: + -- objects (declared or allocated), formal parameters, view + -- conversions, and function calls (both primitive and non-primitive). + -- + -- TEST DESCRIPTION: + -- This test uses foundation F392C00 to test the usages of statically + -- tagged objects and values. This test is derived in part from + -- C392C05. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 24 Oct 95 SAIC Updated for ACVC 2.0.1 + -- + --! + + with Report; + with TCTouch; + with F392C00_1; + procedure C392C07 is -- Hardware_Store + package Switch renames F392C00_1; + + subtype Switch_Class is Switch.Toggle'Class; + + type Reference is access all Switch_Class; + + A_Switch : aliased Switch.Toggle; + A_Dimmer : aliased Switch.Dimmer; + An_Autodim : aliased Switch.Auto_Dimmer; + + type Light_Bank is array(Positive range <>) of Reference; + + Lamps : Light_Bank(1..3); + + -- dynamically tagged controlling operands : class wide formal parameters + procedure Clamp( Device : in out Switch_Class; On : Boolean := False ) is + begin + if Switch.On( Device ) /= On then + Switch.Flip( Device ); + end if; + end Clamp; + function Class_Item(Bank_Pos: Positive) return Switch_Class is + begin + return Lamps(Bank_Pos).all; + end Class_Item; + + begin -- Main test procedure. + Report.Test ("C392C07", "Check that a dispatching subprogram call is " + & "determined by the controlling tag for " + & "dynamically tagged controlling operands" ); + + Lamps := ( A_Switch'Access, A_Dimmer'Access, An_Autodim'Access ); + + -- dynamically tagged operands referring to + -- statically tagged declared objects + for Knob in Lamps'Range loop + Clamp( Lamps(Knob).all, On => True ); + end loop; + TCTouch.Validate( "BABGBABKGBA", "Clamping On Lamps" ); + + Lamps(1) := new Switch.Toggle; + Lamps(2) := new Switch.Dimmer; + Lamps(3) := new Switch.Auto_Dimmer; + + -- turn the full bank of switches ON + -- dynamically tagged allocated objects + for Knob in Lamps'Range loop + Clamp( Lamps(Knob).all, On => True ); + end loop; + TCTouch.Validate( "BABGBABKGBA", "Dynamic Allocated"); + + -- Double check execution correctness + if Switch.Off( Lamps(1).all ) + or Switch.Off( Lamps(2).all ) + or Switch.Off( Lamps(3).all ) then + Report.Failed( "Bad Value" ); + end if; + TCTouch.Validate( "CCC", "Class-wide"); + + -- turn the full bank of switches OFF + for Knob in Lamps'Range loop + Switch.Flip( Lamps(Knob).all ); + end loop; + TCTouch.Validate( "AGBAKGBA", "Dynamic Allocated, Primitive Ops"); + + -- check switches for OFF + -- a few function calls as operands + for Knob in Lamps'Range loop + if not Switch.Off( Class_Item(Knob) ) then + Report.Failed("At function tests, Switch not OFF"); + end if; + end loop; + TCTouch.Validate( "CCC", + "Using function returning class-wide type"); + + -- Switches are all OFF now. + -- dynamically tagged view conversion + Clamp( Switch_Class( A_Switch ) ); + Clamp( Switch_Class( A_Dimmer ) ); + Clamp( Switch_Class( An_Autodim ) ); + TCTouch.Validate( "BABGBABKGBA", "View Conversions" ); + + -- dynamically tagged controlling operands : declared class wide objects + -- calling primitive functions + declare + Dine_O_Might : Switch_Class := Switch.TC_CW_TI( 't' ); + begin + Switch.Flip( Dine_O_Might ); + if Switch.On( Dine_O_Might ) then + Report.Failed( "Exploded at Dine_O_Might" ); + end if; + TCTouch.Validate( "WAB", "Dispatching function 1" ); + end; + + declare + Dyne_A_Mite : Switch_Class := Switch.TC_CW_TI( 'd' ); + begin + Switch.Flip( Dyne_A_Mite ); + if Switch.On( Dyne_A_Mite ) then + Report.Failed( "Exploded at Dyne_A_Mite" ); + end if; + TCTouch.Validate( "WGBAB", "Dispatching function 2" ); + end; + + declare + Din_Um_Out : Switch_Class := Switch.TC_CW_TI( 'a' ); + begin + Switch.Flip( Din_Um_Out ); + if Switch.Off( Din_Um_Out ) then + Report.Failed( "Exploded at Din_Um_Out" ); + end if; + TCTouch.Validate( "WKCC", "Dispatching function 3" ); + + -- Non-dispatching function calls. + if not Switch.TC_Non_Disp( Switch.Toggle( Din_Um_Out ) ) then + Report.Failed( "Non primitive, via view conversion" ); + end if; + TCTouch.Validate( "X", "View Conversion 1" ); + + if not Switch.TC_Non_Disp( Switch.Dimmer( Din_Um_Out ) ) then + Report.Failed( "Non primitive, via view conversion" ); + end if; + TCTouch.Validate( "Y", "View Conversion 2" ); + end; + + -- a few more function calls as operands (oops) + if not Switch.On( Switch.Toggle'( Switch.Create ) ) then + Report.Failed("Toggle did not create ""On"""); + end if; + + if Switch.Off( Switch.Dimmer'( Switch.Create ) ) then + Report.Failed("Dimmer created ""Off"""); + end if; + + if Switch.Off( Switch.Auto_Dimmer'( Switch.Create ) ) then + Report.Failed("Auto_Dimmer created ""Off"""); + end if; + + Report.Result; + end C392C07; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d01.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,324 ---- + -- C392D01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for an implicitly declared dispatching operation that is + -- overridden, the body executed is the body for the overriding + -- subprogram, even if the overriding occurs in a private part. + -- Check that, for an implicitly declared dispatching operation that is + -- NOT overridden, the body executed is the body of the corresponding + -- subprogram of the parent type. + -- + -- Check for the case where the overriding (and non-overriding) operations + -- are declared for a private extension (and its full type) in a public + -- child unit of the package declaring the ancestor type, and the ancestor + -- type is a tagged private type whose full view is itself a derived type. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package Parent is + -- type Root is tagged ... + -- procedure Vis_Op (P: Root); + -- private + -- procedure Pri_Op (P: Root); -- (A) + -- end Parent; + -- + -- package Intermediate is + -- type Mid is tagged private; + -- private + -- type Mid is new Parent.Root with record ... + -- -- Implicit Vis_Op (P: Mid) declared here. + -- + -- procedure Vis_Op (P: Mid); -- (B) + -- end Intermediate; + -- + -- package Intermediate.Child is + -- type Derived is new Mid with private; + -- + -- procedure Pri_Op (P: Derived); -- (C) + -- ... + -- + -- private + -- type Derived is new Mid with record... + -- -- Implicit Vis_Op (P: Derived) declared here. + -- ... + -- end Intermediate.Child; + -- + -- Type Derived inherits Vis_Op from the parent type Mid. Note, however, + -- that it is implicitly declared in the private part (inherited + -- subprograms for a derived_type_definition -- in this case, the full + -- type -- are implicitly declared at the earliest place within the + -- immediate scope of the type_declaration where the corresponding + -- declaration from the parent is visible). + -- + -- Because Parent.Pri_Op is never visible within the immediate scope + -- of Mid, it is not implicitly declared for Mid. Thus, it is also not + -- implicitly declared for Derived. As a result, the version of Pri_Op + -- declared at (C) above does not override an inherited version of + -- Parent.Pri_Op and is totally unrelated to it. + -- + -- Dispatching calls with tag Mid will execute (A) and (B). Dispatching + -- calls with tag Derived from Parent will execute the bodies of (B) + -- and (A). Dispatching calls with tag Derived from Parent.Child + -- will execute the bodies of (B) and (C). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F392D00.A + -- C392D01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F392D00; + package C392D01_0 is + + type Zoom_Camera is tagged private; + + procedure Self_Test (C : in out Zoom_Camera'Class); + + -- ...Additional operations. + + + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean; + + private + + type Magnification is (Low, Medium, High); + + type Zoom_Camera is new F392D00.Remote_Camera with record + Mag : Magnification; + end record; + + -- procedure Focus (C : in out Zoom_Camera; -- Implicitly + -- Depth : in Depth_Of_Field) -- declared + -- here. + + procedure Focus (C : in out Zoom_Camera; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- inherited op. + + -- For the remote zoom camera, perhaps the focusing algorithm is different + -- in some way, so the original Focus operation is overridden here. + + -- Since the partial view is not an extension, the overriding operation + -- must be declared after the full type. This version of Focus, although + -- not visible for type Zoom_Camera from outside the package, can still be + -- dispatched to. + + + -- Note: F392D00.Set_Shutter_Speed is inherited by Zoom_Camera from + -- F392D00.Remote_Camera, but since the operation never becomes visible + -- within the immediate scope of Zoom_Camera, it is never implicitly + -- declared. + + end C392D01_0; + + + --==================================================================-- + + + package body C392D01_0 is + + procedure Focus (C : in out Zoom_Camera; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 83; + end Focus; + + ----------------------------------------------------------- + -- Indirect call to F392D00.Self_Test since the main does not know + -- that Zoom_Camera is a private extension of F392D00.Basic_Camera. + procedure Self_Test (C : in out Zoom_Camera'Class) is + begin + F392D00.Self_Test (C); + -- ...Additional self-testing. + end Self_Test; + + ----------------------------------------------------------- + function TC_Correct_Result (C : Zoom_Camera; + D : F392D00.Depth_Of_Field; + S : F392D00.Shutter_Speed) return Boolean is + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + begin + return (C.DOF = D and C.Shutter = S); + end TC_Correct_Result; + + end C392D01_0; + + + --==================================================================-- + + + with F392D00; + package C392D01_0.C392D01_1 is + + type Film_Speed is private; + + type Auto_Speed is new Zoom_Camera with private; + + -- Implicit function TC_Correct_Result (Auto_Speed) declared here. + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from Zoom_Camera, because the inherited operation is never + -- visible (and thus, is never implicitly declared) within the immediate + -- scope of type Auto_Speed. + + procedure Self_Test (C : in out Auto_Speed'Class); + + -- ...Other operations. + + private + type Film_Speed is (One_Hundred, Two_Hundred, Four_Hundred); + + type Auto_Speed is new Zoom_Camera with record + ASA : Film_Speed; + end record; + + -- procedure Focus (C : in out Auto_Speed; -- Implicitly + -- Depth : in F392D00.Depth_Of_Field); -- declared + -- here. + + end C392D01_0.C392D01_1; + + + --==================================================================-- + + + package body C392D01_0.C392D01_1 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Two_Fifty; + end Set_Shutter_Speed; + + ------------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Artificial for testing purposes. + Set_Shutter_Speed (C, F392D00.Thousand); + Focus (C, 27); + end Self_Test; + + end C392D01_0.C392D01_1; + + + --==================================================================-- + + + with F392D00; + with C392D01_0.C392D01_1; + + with Report; + + procedure C392D01 is + Zooming_Camera : C392D01_0.Zoom_Camera; + Auto_Camera1 : C392D01_0.C392D01_1.Auto_Speed; + Auto_Camera2 : C392D01_0.C392D01_1.Auto_Speed; + + TC_Expected_Zoom_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 83; + TC_Expected_Zoom_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Auto_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Two_Fifty; + + use type F392D00.Depth_Of_Field; + use type F392D00.Shutter_Speed; + + begin + Report.Test ("C392D01", "Dispatching for overridden and non-overridden " & + "primitive subprograms: private extension declared in child " & + "unit, parent is tagged private whose full view is derived " & + "type"); + + + + -- Call the class-wide operation (Self_Test) for Zoom_Camera'Class, which + -- itself calls the class-wide operation for Remote_Camera'Class, which + -- in turn makes dispatching calls to Focus and Set_Shutter_Speed: + + + -- For an object of type Zoom_Camera, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- to Set_Shutter_Speed should dispatch to the body declared for + -- Remote_Camera: + + C392D01_0.Self_Test(Zooming_Camera); + + if not C392D01_0.TC_Correct_Result (Zooming_Camera, + TC_Expected_Zoom_Depth, + TC_Expected_Zoom_Speed) + then + Report.Failed ("Calls dispatched incorrectly for tagged private type"); + end if; + + -- For an object of type Auto_Speed, the dispatching call to Focus should + -- dispatch to the body explicitly declared for Zoom_Camera. The dispatching + -- call to Set_Shutter_Speed should dispatch to the body explicitly declared + -- for Remote_Camera: + + C392D01_0.Self_Test(Auto_Camera1); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera1, + TC_Expected_Auto_Depth, + TC_Expected_Auto_Speed) + then + Report.Failed ("Calls dispatched incorrectly for private extension"); + end if; + + -- Call to Self_Test from C392D01_0.C392D01_1 invokes the dispatching call + -- to Focus which should dispatch to the body explicitly declared for + -- Zoom_Camera. The dispatching call to Set_Shutter_Speed should dispatch + -- to the body explicitly declared for Auto_Speed: + + C392D01_0.C392D01_1.Self_Test(Auto_Camera2); + + if not C392D01_0.C392D01_1.TC_Correct_Result (Auto_Camera2, + TC_Expected_Depth, + TC_Expected_Speed) + then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + + end C392D01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d02.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + -- C392D02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a primitive procedure declared in a private part is not + -- overridden by a procedure explicitly declared at a place where the + -- primitive procedure in question is not visible. + -- + -- Check for the case where the non-overriding operation is declared in a + -- separate (non-child) package from that declaring the parent type, and + -- the descendant type is a record extension. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package P is + -- type Root is tagged ... + -- private + -- procedure Pri_Op (A: Root); + -- end P; + -- + -- with P; + -- package Q is + -- type Derived is new P.Root with record... + -- procedure Pri_Op (A: Derived); -- Does NOT override parent's Op. + -- ... + -- end Q; + -- + -- Type Derived inherits Pri_Op from the parent type Root. However, + -- because P.Pri_Op is never visible within the immediate scope of + -- Derived, it is not implicitly declared for Derived. As a result, + -- the explicit Q.Pri_Op does not override P.Pri_Op and is totally + -- unrelated to it. + -- + -- Dispatching calls to P.Pri_Op with operands of tag Derived will + -- not dispatch to Q.Pri_Op; the body executed will be that of P.Pri_Op. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F392D00.A + -- C392D02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F392D00; + package C392D02_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Speed is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed); + -- Does NOT override. + + -- This version of Set_Shutter_Speed does NOT override the operation + -- inherited from the parent, because the inherited operation is never + -- visible (and thus, is never implicitly declared) within the immediate + -- scope of type Auto_Speed. + + procedure Self_Test (C : in out Auto_Speed'Class); + + -- ...Other operations. + + end C392D02_0; + + + --==================================================================-- + + + package body C392D02_0 is + + procedure Set_Shutter_Speed (C : in out Auto_Speed; + Speed : in F392D00.Shutter_Speed) is + begin + -- Artificial for testing purposes. + C.Shutter := F392D00.Four_Hundred; + end Set_Shutter_Speed; + + ---------------------------------------------------- + procedure Self_Test (C : in out Auto_Speed'Class) is + begin + -- Should dispatch to the Set_Shutter_Speed explicitly declared + -- for Auto_Speed. + Set_Shutter_Speed (C, F392D00.Two_Fifty); + end Self_Test; + + end C392D02_0; + + + --==================================================================-- + + + with F392D00; + with C392D02_0; + + with Report; + + procedure C392D02 is + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D02_0.Auto_Speed; + Auto_Camera2 : C392D02_0.Auto_Speed; + + TC_Expected_Basic_Speed : constant F392D00.Shutter_Speed + := F392D00.Thousand; + TC_Expected_Speed : constant F392D00.Shutter_Speed + := F392D00.Four_Hundred; + + use type F392D00.Shutter_Speed; + + begin + Report.Test ("C392D02", "Dispatching for non-overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + + -- Call the class-wide operation for Remote_Camera'Class, which dispatches + -- to Set_Shutter_Speed: + + -- For an object of type Remote_Camera, the dispatching call should + -- dispatch to the body declared for the root type: + + F392D00.Self_Test(Basic_Camera); + + if Basic_Camera.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- C392D02_0.Set_Shutter_Speed should never be called by F392D00.Self_Test, + -- since C392D02_0.Set_Shutter_Speed does not override + -- F392D00.Set_Shutter_Speed. + + -- For an object of type Auto_Speed, the dispatching call should + -- also dispatch to the body declared for the root type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.Shutter /= TC_Expected_Basic_Speed then + Report.Failed ("Call dispatched incorrectly for derived type"); + end if; + + -- Call to Self_Test from C392D02_0 invokes the dispatching call to + -- Set_Shutter_Speed which should dispatch to the body explicitly declared + -- for Auto_Speed: + + C392D02_0.Self_Test(Auto_Camera2); + + if Auto_Camera2.Shutter /= TC_Expected_Speed then + Report.Failed ("Call to explicit subprogram executed the wrong body"); + end if; + + Report.Result; + + end C392D02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c392d03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c392d03.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,248 ---- + -- C392D03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for an inherited dispatching operation that is overridden, + -- the body executed is the body of the overriding subprogram, even if + -- the overriding occurs in a private part. + -- + -- Check for the case where the overriding operation is declared in a + -- separate (non-child) package from that declaring the parent type, and + -- the descendant type is a record extension. + -- + -- Check for both dispatching and nondispatching calls. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package P is + -- type Root is tagged ... + -- procedure Op (A: Root); + -- end P; + -- + -- with P; + -- package Q is + -- type Derived1 is new P.Root with record... + -- -- Implicit procedure Op (A: Derived1) declared here. + -- type Derived2 is new P.Root with private... + -- -- Implicit procedure Op (A: Derived2) declared here. + -- type New_Derived is new Derived1 with private... + -- -- Implicit procedure Op (A: New_Derived) declared here. + -- private + -- procedure Op (A: Derived1); -- Overrides parent's Op. + -- type Derived2 is new P.Root with record... + -- procedure Op (A: Derived2); -- Overrides parent's Op. + -- type New_Derived is new Derived1 with record... + -- ... + -- end Q; + -- + -- Both type Derived1 and Derived2 inherit Op from the parent type Root. + -- Type New_Derived inherits (inherited) Op from Derived1. The inherited + -- operation is implicitly declared immediately after the type extension. + -- The inherited operation is overridden by an explicit declaration in + -- the private part. Even though the overriding operation is private, + -- calls to Op with an operand of tag Derived1, Derived2, or New_Derived + -- will execute the body of the overriding operation. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F392D00.A + -- C392D03.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F392D00; + package C392D03_0 is + + type Aperture is (Eight, Sixteen); + + type Auto_Focus is new F392D00.Remote_Camera with record + -- ... + FStop : Aperture; + end record; + + -- Implicit procedure Focus (C : in out Auto_Focus; + -- Depth : in Depth_Of_Field) declared here. + + type Auto_Flashing is new F392D00.Remote_Camera with private; + + -- Implicit procedure Focus (C : in out Auto_Flashing; + -- Depth : in Depth_Of_Field) declared here. + + type Special_Focus is new Auto_Focus with private; + + -- Implicit procedure Focus (C : in out Special_Focus; + -- Depth : in Depth_Of_Field) declared here. + + -- ...Other operations. + + private + + procedure Focus (C : in out Auto_Focus; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + -- For the improved remote camera, focus is set automatically, so it is + -- declared as a private operation. + + type Auto_Flashing is new F392D00.Remote_Camera with null record; + + procedure Focus (C : in out Auto_Flashing; -- Overrides + Depth : in F392D00.Depth_Of_Field); -- parent's op. + + type Special_Focus is new Auto_Focus with null record; + + end C392D03_0; + + + --==================================================================-- + + + package body C392D03_0 is + + procedure Focus (C : in out Auto_Focus; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 52; + end Focus; + + ----------------------------------------------------------- + procedure Focus (C : in out Auto_Flashing; + Depth : in F392D00.Depth_Of_Field) is + begin + -- Artificial for testing purposes. + C.DOF := 91; + end Focus; + + end C392D03_0; + + + --==================================================================-- + + + with F392D00; + with C392D03_0; + + with Report; + + procedure C392D03 is + + type Focus_Ptr is access procedure + (P1 : in out C392D03_0.Auto_Focus; + P2 : in F392D00.Depth_Of_Field); + + Basic_Camera : F392D00.Remote_Camera; + Auto_Camera1 : C392D03_0.Auto_Focus; + Auto_Camera2 : C392D03_0.Auto_Focus; + Flash_Camera1 : C392D03_0.Auto_Flashing; + Flash_Camera2 : C392D03_0.Auto_Flashing; + Special_Camera : C392D03_0.Special_Focus; + Auto_Depth : F392D00.Depth_Of_Field := 78; + + TC_Expected_Basic_Depth : constant F392D00.Depth_Of_Field := 46; + TC_Expected_Auto_Depth : constant F392D00.Depth_Of_Field := 52; + TC_Expected_Depth : constant F392D00.Depth_Of_Field := 91; + + FP : Focus_Ptr := C392D03_0.Focus'Access; + + use type F392D00.Depth_Of_Field; + + begin + Report.Test ("C392D03", "Dispatching for overridden primitive " & + "subprograms: record extension declared in non-child " & + "package, parent is tagged record"); + + + -- Call the class-wide operation for Remote_Camera'Class, which itself makes + -- a dispatching call to Focus: + + -- For an object of type Remote_Camera, the dispatching call should + -- dispatch to the body declared for the root type: + + F392D00.Self_Test(Basic_Camera); + + if Basic_Camera.DOF /= TC_Expected_Basic_Depth then + Report.Failed ("Call dispatched incorrectly for root type"); + end if; + + + -- For an object of type Auto_Focus, the dispatching call should + -- dispatch to the body declared for the derived type: + + F392D00.Self_Test(Auto_Camera1); + + if Auto_Camera1.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Focus type"); + end if; + + + -- For an object of type Auto_Flash, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Flash_Camera1); + + if Flash_Camera1.DOF /= TC_Expected_Depth then + Report.Failed ("Call dispatched incorrectly for Auto_Flash type"); + end if; + + -- For an object of Auto_Flash type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + C392D03_0.Focus (Flash_Camera2, Auto_Depth); + + if Flash_Camera2.DOF /= TC_Expected_Depth then + Report.Failed ("Non-dispatching call to privately overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of Auto_Focus type, a non-dispatching call to Focus should + -- execute the body declared for the derived type (even through it is + -- declared in the private part). + + FP.all (Auto_Camera2, Auto_Depth); + + if Auto_Camera2.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Non-dispatching call by using access to overriding " & + "subprogram executed the wrong body"); + end if; + + -- For an object of type Special_Camera, the dispatching call should + -- also dispatch to the body declared for the derived type: + + F392D00.Self_Test(Special_Camera); + + if Special_Camera.DOF /= TC_Expected_Auto_Depth then + Report.Failed ("Call dispatched incorrectly for Special_Camera type"); + end if; + + Report.Result; + + end C392D03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,407 ---- + -- C393001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an abstract type can be declared, and in turn concrete + -- types can be derived from it. Check that the definition of + -- actual subprograms associated with the derived types dispatch + -- correctly. + -- + -- TEST DESCRIPTION: + -- This test declares an abstract type Breaker in a package, and + -- then derives from it. The type Basic_Breaker defines the least + -- possible in order to not be abstract. The type Ground_Fault is + -- defined to inherit as much as possible, whereas type Special_Breaker + -- overrides everything it can. The type Special_Breaker also includes + -- an embedded Basic_Breaker object. The main program then utilizes + -- each of the three types of breaker, and to ascertain that the + -- overloading and tagging resolution are correct, each "Create" + -- procedure is called with a unique value. The diagram below + -- illustrates the relationships. This test is derived from C3A2001. + -- + -- Abstract type: Breaker + -- | + -- Basic_Breaker (Short) + -- / \ + -- (Sharp) Ground_Fault Special_Breaker (Shock) + -- + -- Test structure is an array of class-wide objects, modeling a circuit + -- as a list of components. The test then creates some values, and + -- traverses the list to determine correct operation. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Nov 95 SAIC Revised for 2.0.1 + -- + --! + + ----------------------------------------------------------------- C393001_1 + + with Report; + package C393001_1 is + + type Breaker is abstract tagged private; + type Status is ( Power_Off, Power_On, Tripped, Failed ); + + procedure Flip ( The_Breaker : in out Breaker ) is abstract; + procedure Trip ( The_Breaker : in out Breaker ) is abstract; + procedure Reset( The_Breaker : in out Breaker ) is abstract; + procedure Fail ( The_Breaker : in out Breaker ); + + procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); + + function Status_Of( The_Breaker : Breaker ) return Status; + + private + type Breaker is abstract tagged record + State : Status := Power_Off; + end record; + end C393001_1; + + with TCTouch; + package body C393001_1 is + procedure Fail( The_Breaker : in out Breaker ) is ------------------- a + begin + TCTouch.Touch( 'a' ); + The_Breaker.State := Failed; + end Fail; + + procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is + begin + The_Breaker.State := To_State; + end Set; + + function Status_Of( The_Breaker : Breaker ) return Status is ------- b + begin + TCTouch.Touch( 'b' ); + return The_Breaker.State; + end Status_Of; + end C393001_1; + + ----------------------------------------------------------------- C393001_2 + + with C393001_1; + package C393001_2 is + + type Basic_Breaker is new C393001_1.Breaker with private; + + type Voltages is ( V12, V110, V220, V440 ); + type Amps is ( A1, A5, A10, A25, A100 ); + + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker; + + procedure Flip ( The_Breaker : in out Basic_Breaker ); + procedure Trip ( The_Breaker : in out Basic_Breaker ); + procedure Reset( The_Breaker : in out Basic_Breaker ); + private + type Basic_Breaker is new C393001_1.Breaker with record + Voltage_Level : Voltages := V110; + Amperage : Amps; + end record; + end C393001_2; + + with TCTouch; + package body C393001_2 is + function Construct( Voltage : Voltages; Amperage : Amps ) ----------- c + return Basic_Breaker is + It : Basic_Breaker; + begin + TCTouch.Touch( 'c' ); + It.Amperage := Amperage; + It.Voltage_Level := Voltage; + C393001_1.Set( It, C393001_1.Power_Off ); + return It; + end Construct; + + procedure Flip ( The_Breaker : in out Basic_Breaker ) is ------------ d + begin + TCTouch.Touch( 'd' ); + case Status_Of( The_Breaker ) is + when C393001_1.Power_Off => + C393001_1.Set( The_Breaker, C393001_1.Power_On ); + when C393001_1.Power_On => + C393001_1.Set( The_Breaker, C393001_1.Power_Off ); + when C393001_1.Tripped | C393001_1.Failed => null; + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Basic_Breaker ) is ------------ e + begin + TCTouch.Touch( 'e' ); + C393001_1.Set( The_Breaker, C393001_1.Tripped ); + end Trip; + + procedure Reset( The_Breaker : in out Basic_Breaker ) is ------------ f + begin + TCTouch.Touch( 'f' ); + case Status_Of( The_Breaker ) is + when C393001_1.Power_Off | C393001_1.Tripped => + C393001_1.Set( The_Breaker, C393001_1.Power_On ); + when C393001_1.Power_On | C393001_1.Failed => null; + end case; + end Reset; + + end C393001_2; + + with C393001_1,C393001_2; + package C393001_3 is + + type Ground_Fault is new C393001_2.Basic_Breaker with private; + + function Construct( Voltage : C393001_2.Voltages; Amperage : C393001_2.Amps + ) + return Ground_Fault; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ); + + private + type Ground_Fault is new C393001_2.Basic_Breaker with record + Capacitance : Integer; + end record; + end C393001_3; + + ----------------------------------------------------------------- C393001_3 + + with TCTouch; + package body C393001_3 is + + function Construct( Voltage : C393001_2.Voltages; ------------------ g + Amperage : C393001_2.Amps ) + return Ground_Fault is + + It : Ground_Fault; + + procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is + begin + It := C393001_2.Construct( Voltage, Amperage ); + end Set_Root; + + begin + TCTouch.Touch( 'g' ); + Set_Root( C393001_2.Basic_Breaker( It ) ); + It.Capacitance := 0; + return It; + end Construct; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; -------------- h + Capacitance : in Integer ) is + begin + TCTouch.Touch( 'h' ); + The_Breaker.Capacitance := Capacitance; + end Set_Trip; + + end C393001_3; + + ----------------------------------------------------------------- C393001_4 + + with C393001_1, C393001_2; + package C393001_4 is + + type Special_Breaker is new C393001_2.Basic_Breaker with private; + + function Construct( Voltage : C393001_2.Voltages; + Amperage : C393001_2.Amps ) + return Special_Breaker; + + procedure Flip ( The_Breaker : in out Special_Breaker ); + procedure Trip ( The_Breaker : in out Special_Breaker ); + procedure Reset( The_Breaker : in out Special_Breaker ); + procedure Fail ( The_Breaker : in out Special_Breaker ); + + function Status_Of( The_Breaker : Special_Breaker ) return C393001_1.Status; + function On_Backup( The_Breaker : Special_Breaker ) return Boolean; + + private + type Special_Breaker is new C393001_2.Basic_Breaker with record + Backup : C393001_2.Basic_Breaker; + end record; + end C393001_4; + + with TCTouch; + package body C393001_4 is + + function Construct( Voltage : C393001_2.Voltages; --------------- i + Amperage : C393001_2.Amps ) + return Special_Breaker is + It: Special_Breaker; + procedure Set_Root( It: in out C393001_2.Basic_Breaker ) is + begin + It := C393001_2.Construct( Voltage, Amperage ); + end Set_Root; + begin + TCTouch.Touch( 'i' ); + Set_Root( C393001_2.Basic_Breaker( It ) ); + Set_Root( It.Backup ); + return It; + end Construct; + + function Status_Of( It: C393001_1.Breaker ) return C393001_1.Status + renames C393001_1.Status_Of; + + procedure Flip ( The_Breaker : in out Special_Breaker ) is ---------- j + begin + TCTouch.Touch( 'j' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_Off | C393001_1.Power_On => + C393001_2.Flip( C393001_2.Basic_Breaker( The_Breaker ) ); + when others => + C393001_2.Flip( The_Breaker.Backup ); + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Special_Breaker ) is ---------- k + begin + TCTouch.Touch( 'k' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_Off => null; + when C393001_1.Power_On => + C393001_2.Reset( The_Breaker.Backup ); + C393001_2.Trip( C393001_2.Basic_Breaker( The_Breaker ) ); + when others => + C393001_2.Trip( The_Breaker.Backup ); + end case; + end Trip; + + procedure Reset( The_Breaker : in out Special_Breaker ) is ---------- l + begin + TCTouch.Touch( 'l' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Tripped => + C393001_2.Reset( C393001_2.Basic_Breaker( The_Breaker )); + when C393001_1.Failed => + C393001_2.Reset( The_Breaker.Backup ); + when C393001_1.Power_On | C393001_1.Power_Off => + null; + end case; + end Reset; + + procedure Fail ( The_Breaker : in out Special_Breaker ) is ---------- m + begin + TCTouch.Touch( 'm' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Failed => + C393001_2.Fail( The_Breaker.Backup ); + when others => + C393001_2.Fail( C393001_2.Basic_Breaker( The_Breaker )); + C393001_2.Reset( The_Breaker.Backup ); + end case; + end Fail; + + function Status_Of( The_Breaker : Special_Breaker ) ----------------- n + return C393001_1.Status is + begin + TCTouch.Touch( 'n' ); + case Status_Of( C393001_1.Breaker( The_Breaker )) is + when C393001_1.Power_On => return C393001_1.Power_On; + when C393001_1.Power_Off => return C393001_1.Power_Off; + when others => + return C393001_2.Status_Of( The_Breaker.Backup ); + end case; + end Status_Of; + + function On_Backup( The_Breaker : Special_Breaker ) return Boolean is + use C393001_2; + use type C393001_1.Status; + begin + return Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Tripped + or Status_Of(Basic_Breaker(The_Breaker)) = C393001_1.Failed; + end On_Backup; + + end C393001_4; + + ------------------------------------------------------------------- C393001 + + with Report, TCTouch; + with C393001_1, C393001_2, C393001_3, C393001_4; + procedure C393001 is + + procedure Flipper( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Flip( The_Circuit ); + end Flipper; + + procedure Tripper( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Trip( The_Circuit ); + end Tripper; + + procedure Restore( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Reset( The_Circuit ); + end Restore; + + procedure Failure( The_Circuit : in out C393001_1.Breaker'Class ) is + begin + C393001_1.Fail( The_Circuit ); + end Failure; + + Short : C393001_1.Breaker'Class -- Basic_Breaker + := C393001_2.Construct( C393001_2.V440, C393001_2.A5 ); + Sharp : C393001_1.Breaker'Class -- Ground_Fault + := C393001_3.Construct( C393001_2.V110, C393001_2.A1 ); + Shock : C393001_1.Breaker'Class -- Special_Breaker + := C393001_4.Construct( C393001_2.V12, C393001_2.A100 ); + + begin -- Main test procedure. + + Report.Test ("C393001", "Check that an abstract type can be declared " & + "and used. Check actual subprograms dispatch correctly" ); + + TCTouch.Validate( "cgcicc", "Declaration" ); + + Flipper( Short ); + TCTouch.Validate( "db", "Flipping Short" ); + Flipper( Sharp ); + TCTouch.Validate( "db", "Flipping Sharp" ); + Flipper( Shock ); + TCTouch.Validate( "jbdb", "Flipping Shock" ); + + Tripper( Short ); + TCTouch.Validate( "e", "Tripping Short" ); + Tripper( Sharp ); + TCTouch.Validate( "e", "Tripping Sharp" ); + Tripper( Shock ); + TCTouch.Validate( "kbfbe", "Tripping Shock" ); + + Restore( Short ); + TCTouch.Validate( "fb", "Restoring Short" ); + Restore( Sharp ); + TCTouch.Validate( "fb", "Restoring Sharp" ); + Restore( Shock ); + TCTouch.Validate( "lbfb", "Restoring Shock" ); + + Failure( Short ); + TCTouch.Validate( "a", "Shock Failing" ); + Failure( Sharp ); + TCTouch.Validate( "a", "Shock Failing" ); + Failure( Shock ); + TCTouch.Validate( "mbafb", "Shock Failing" ); + + Report.Result; + + end C393001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393007.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- C393007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived from an abstract type, + -- where the abstract type is defined in a package, and the type derived + -- from it is defined in a distinct library package. + -- + -- TEST DESCRIPTION: + -- Declare an private (abstract) type; declare two primitive operations + -- of the type that are explicitly abstract. + -- Derive an extended type from the (private) abstract type, overriding + -- both of the primitive operations. + -- This test also checks to see that name overloading between abstract + -- and non-abstract functions is resolved correctly. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C393007_0 is + -- Alert_System + + type DT_Type is new Integer; + + type Alert_Type is abstract tagged record + Time_Of_Arrival : DT_Type; + end record; + + type Log_File_Type is range 0 .. 100; + + Procedure Handle (A : in out Alert_type) is abstract; + + procedure Log (A : Alert_Type; + L : in out Log_File_Type) is abstract; + + procedure Set_Time (A : in out Alert_Type); + + function Correct_Time_Stamp (A : Alert_Type) return Boolean; + + Day_Time : DT_Type := 100; + + end C393007_0; + -- Alert_System; + + --=======================================================================-- + + package body C393007_0 is + -- Alert_System + + function Time_Stamp return DT_Type is + begin + Day_Time := Day_Time + 1; + return Day_Time; + end Time_Stamp; + + procedure Set_Time (A : in out Alert_Type) is + begin + A.Time_Of_Arrival := Time_Stamp; + end Set_time; + + function Correct_Time_Stamp ( A : Alert_Type) return Boolean is + begin + return (A.Time_Of_Arrival = Day_Time); + end Correct_Time_Stamp; + + end C393007_0; + -- Alert_System; + + --=======================================================================-- + + with Report; + with C393007_0; + -- Alert_system; + + package C393007_1 is + + type Normal_Alert_Type is + new C393007_0.Alert_Type + with null record; + + Log_File: C393007_0.Log_File_Type := C393007_0.Log_File_Type'First; + + procedure Handle (A : in out Normal_Alert_Type); -- Override is required + + procedure Log (A : Normal_Alert_Type; -- Override is required + L : in out C393007_0.Log_File_Type); + end C393007_1; + + package body C393007_1 is + use type C393007_0.Log_File_Type; + + procedure Handle (A : in out Normal_Alert_Type) is + begin + Set_Time (A); + Log (A, Log_File); + end Handle; + + procedure Log (A : Normal_Alert_Type; + L : in out C393007_0.Log_File_Type) is + begin + L := C393007_0."+"(L, 1); + end Log; + + end C393007_1; + + with Report; + with C393007_0; + with C393007_1; + -- Alert_system; + + procedure C393007 is + use C393007_0; + use C393007_1; + + Alert_One : C393007_1.Normal_Alert_Type; + + begin + Report.Test ("C393007", "Check that an extended type can be derived " & + "from an abstract type"); + + Handle (Alert_One); + if not Correct_Time_Stamp (Alert_One) then + Report.Failed ("Wrong results from procedure Handle"); + end if; + + if Log_File /=1 then + Report.Failed ("Wrong results"); + end if; + + Report.Result; + + end C393007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393008.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,204 ---- + -- C393008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived from an abstract type. + -- + -- TEST DESCRIPTION: + -- Declare a tagged record; declare an abstract + -- primitive operation and a non-abstract primitive operation of the + -- type. Derive an extended type from it, including a new component. + -- Use the derived type, the overriding operation and the inherited + -- operation to instantiate a generic package. The overriding operation + -- calls a new primitive operation and an inherited operation [so the + -- instantiation must get this sorted out correctly]. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with TCTouch; + procedure C393008 is + + package C393008_0 is + + type Status_Enum is (No_Status, Handled, Unhandled, Pending); + + type Alert_Type is abstract tagged record + Status : Status_Enum; + Reply : Boolean; + Urgent : Boolean; + end record; + + subtype Serial_Number is Integer range 0..Integer'last; + Serial_Num : Serial_Number := 0; + + procedure Handle (A : in out Alert_Type) is abstract; + -- abstract primitive operation + + -- the procedure Init would be _nice_ have this procedure be non_abstract + -- and create a "base" object with a "null" constraint. The language + -- will not allow this due to the restriction that an object of an + -- abstract type cannot be created. Hence Init must be abstract, + -- requiring any type derived directly from Alert_Type to declare + -- an Init. + -- + -- In light of this, I have changed init to a function to more closely + -- model the typical usage of OO features... + + function Init return Alert_Type is abstract; + + procedure No_Reply (A : in out Alert_Type); + + end C393008_0; + + --=======================================================================-- + + package body C393008_0 is + + procedure No_Reply (A : in out Alert_Type) is + begin -- primitive operation, not abstract + TCTouch.Touch('A'); ------------------------------------------------- A + if A.Status = Handled then + A.Reply := False; + end if; + end No_Reply; + + end C393008_0; + + --=======================================================================-- + + generic + -- pass in the Alert_Type object, including its + -- operations + type Data_Type is new C393008_0.Alert_Type with private; + -- note that Alert_Type is abstract, so it may not be + -- used as an actual parameter + with procedure Update (P : in out Data_Type) is <>; -- generic formal + with function Initialize return Data_Type is <>; -- generic formal + + package C393008_1 is + -- Utilities + + procedure Modify (Item : in out Data_Type); + + end C393008_1; + -- Utilities + + --=======================================================================-- + + package body C393008_1 is + -- Utilities + + procedure Modify (Item : in out Data_Type) is + begin + TCTouch.Touch('B'); --------------------------------------------- B + Item := Initialize; + Update (Item); + end Modify; + + end C393008_1; + + --=======================================================================-- + + package C393008_2 is + + type Low_Alert_Type is new C393008_0.Alert_Type with record + Serial : C393008_0.Serial_Number; + end record; + + procedure Serialize (LA : in out Low_Alert_Type); + + -- inherit No_Reply + + procedure Handle (LA : in out Low_Alert_Type); + + function Init return Low_Alert_Type; + end C393008_2; + + package body C393008_2 is + procedure Serialize (LA : in out Low_Alert_Type) is + begin -- new primitive operation + TCTouch.Touch('C'); ------------------------------------------------- C + C393008_0.Serial_Num := C393008_0.Serial_Num + 1; + LA.Serial := C393008_0.Serial_Num; + end Serialize; + + -- inherit No_Reply + + function Init return Low_Alert_Type is + TA: Low_Alert_Type; + begin + TCTouch.Touch('D'); ------------------------------------------------- D + Serialize( TA ); + TA.Status := C393008_0.No_Status; + return TA; + end Init; + + procedure Handle (LA : in out Low_Alert_Type) is + begin -- overrides abstract inherited Handle + TCTouch.Touch('E'); ------------------------------------------------- E + Serialize (LA); + LA.Reply := False; + LA.Status := C393008_0.Handled; + No_Reply (LA); + end Handle; + + end C393008_2; + + use C393008_2; + + package Alert_Utilities is new + C393008_1 (Data_Type => Low_Alert_Type, + Update => Handle, -- Low_Alert's Handle + Initialize => Init); -- inherited from Alert + + Item : Low_Alert_Type; + + use type C393008_0.Status_Enum; + + begin + + Report.Test ("C393008", "Check that an extended type can be derived "& + "from an abstract type"); + + Item := Init; + if (Item.Status /= C393008_0.No_Status) or (Item.Serial /=1) then + Report.Failed ("Wrong initialization"); + end if; + TCTouch.Validate("DC", "Initialization Call"); + + Alert_Utilities.Modify (Item); + if (Item.Status /= C393008_0.Handled) or (Item.Serial /= 3) then + Report.Failed ("Wrong results from Modify"); + end if; + TCTouch.Validate("BDCECA", "Generic Instance Call"); + + Report.Result; + + end C393008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393009.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C393009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived from an abstract type. + -- + -- TEST DESCRIPTION: + -- Declare an abstract type in the specification of a generic package. + -- Instantiate the package and derive an extended type from the abstract + -- (instantiated) type; override all abstract operations; use all + -- inherited operations; + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Oct 95 SAIC Fixed for ACVC 2.0.1 + -- + --! + + with Report; + procedure C393009 is + + package Display_Devices is + + type Display_Device_Enum is (None, TTY, Console, Big_Screen); + Display : Display_Device_Enum := None; + + end Display_Devices; + + --=======================================================================-- + + generic + + type Generic_Status is (<>); + + type Serial_Type is (<>); + + package Alert_System is + + type Alert_Type (Serial : Serial_Type) is abstract tagged record + Status : Generic_Status; + end record; + + Next_Serial_Number : Serial_Type := Serial_Type'First; + + procedure Handle (A : in out Alert_Type) is abstract; + -- abstract operation - must be overridden after instantiation + + procedure Display ( A : Alert_Type; + On : Display_Devices.Display_Device_Enum); + -- primitive operation of Alert_Type + -- not required to be overridden + + function Get_Serial_Number (A : Alert_Type) return Serial_Type; + -- primitive operation of Alert_Type + -- not required to be overridden + + end Alert_System; + + --=======================================================================-- + + package body Alert_System is + + procedure Display ( A : in Alert_Type; + On : Display_Devices.Display_Device_Enum) is + begin + Display_Devices.Display := On; + end Display; + + function Get_Serial_Number (A : Alert_Type) + return Serial_Type is + begin + return A.Serial; + end Get_Serial_Number; + + end Alert_System; + + --=======================================================================-- + + package NCC_1701 is + + type Status_Kind is (Green, Yellow, Red); + type Serial_Number_Type is new Integer range 1..Integer'Last; + + subtype Msg_Str is String (1..16); + Alert_Msg : Msg_Str := "C393009 passed."; + -- 123456789A123456 + + package Alert_Pkg is new Alert_System (Status_Kind, Serial_Number_Type); + + type New_Alert_Type(Serial : Serial_Number_Type) is + new Alert_Pkg.Alert_Type(Serial) with record + Message : Msg_Str; + end record; + + -- procedure Display is inherited by New_Alert_Type + + -- function Get_Serial_Number is inherited by New_Alert_Type + procedure Handle (NA : in out New_Alert_Type); -- must be overridden + procedure Init (NA : in out New_Alert_Type); -- new primitive + + NA : New_Alert_Type(Alert_Pkg.Next_Serial_Number); + -- New_Alert_Type is not abstract, so an object of that + -- type may be declared + + end NCC_1701; + + package body NCC_1701 is + + procedure Handle (NA : in out New_Alert_Type) is + begin + NA.Message := Alert_Msg; + Display (NA, On => Display_Devices.TTY); + end Handle; + + procedure Init (NA : in out New_Alert_Type) is -- new primitive operation + begin -- for New_Alert_Type + NA := (Serial=> NA.Serial, Status => Green, Message => (others => ' ')); + end Init; + + end NCC_1701; + + use NCC_1701; + use type Display_Devices.Display_Device_Enum; + + begin + + Report.Test ("C393009", "Check that an extended type can be derived " & + "from an abstract type"); + + Init (NA); + if (Get_Serial_Number (NA) /= 1) + or (NA.Status /= Green) + or (Display_Devices.Display /= Display_Devices.None) then + Report.Failed ("Wrong Initialization"); + end if; + + Handle (NA); + if (Get_Serial_Number (NA) /= 1) + or (NA.Status /= Green) + or (NA.Message /= Alert_Msg) + or (Display_Devices.Display /= Display_Devices.TTY) then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + + end C393009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,306 ---- + -- C393010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived from an abstract type and + -- that a call on an abstract operation is a dispatching operation. + -- Check that such a call can dispatch to an overriding operation + -- declared in the private part of a package. + -- + -- TEST DESCRIPTION: + -- Taking from a classroom example of a typical usage: declare a basic + -- abstract type containing data germane to the entire class structure, + -- derive from that a type with specific data, and derive from that + -- another type merely providing a "secret" override. The abstract type + -- provides a concrete procedure that itself "redispatches" to an + -- abstract procedure; the abstract procedure must be provided by one or + -- more of the concrete types derived from the abstract type, and hence + -- upon re-evaluating the actual type of the operand should dispatch + -- accordingly. + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Mar 96 SAIC ACVC 2.1 + -- + --! + + ----------------------------------------------------------------- C393010_0 + + package C393010_0 is + + type Ticket is abstract tagged record + Flight : Natural; + Serial_Number : Natural; + end record; + + function Issue return Ticket is abstract; + procedure Label( T: Ticket ) is abstract; + + procedure Print( T: Ticket ); + + end C393010_0; + + with TCTouch; + package body C393010_0 is + + procedure Print( T: Ticket ) is + begin + -- Check that a call on an abstract operation is a dispatching operation + Label( Ticket'Class( T ) ); + -- Appropriate_IO.Put( T.Flight & T.Serial_Number ); + TCTouch.Touch('P'); -------------------------------------------------- P + end Print; + + end C393010_0; + + ----------------------------------------------------------------- C393010_1 + + with C393010_0; + package C393010_1 is + + type Service_Classes is (First, Business, Coach); + + type Menu is (Steak, Lobster, Fowl, Vegan); + + -- Check that an extended type can be derived from an abstract type. + type Passenger_Ticket(Service : Service_Classes) is + new C393010_0.Ticket with record + Row_Seat : String(1..3); + case Service is + when First | Business => Meal : Menu; + when Coach => null; + end case; + end record; + + function Issue return Passenger_Ticket; + function Issue( Service : Service_Classes; + Flight : Natural; + Seat : String; + Meal : Menu := Fowl ) return Passenger_Ticket; + + procedure Label( T: Passenger_Ticket ); + + procedure Print( T: Passenger_Ticket ); + + end C393010_1; + + with TCTouch; + package body C393010_1 is + + procedure Label( T: Passenger_Ticket ) is + begin + -- Appropriate_IO.Put( T.Service ); + TCTouch.Touch('L'); -------------------------------------------------- L + end Label; + + procedure Print( T: Passenger_Ticket ) is + begin + -- call parent print: + C393010_0.Print( C393010_0.Ticket( T ) ); + case T.Service is + when First => -- Appropriate_IO.Put( Meal ); + TCTouch.Touch('F'); ---------------------------------------------- F + when Business => -- Appropriate_IO.Put( Meal ); + TCTouch.Touch('B'); ---------------------------------------------- B + when Coach => -- Appropriate_IO.Put( "BYO" & " peanuts" ); + TCTouch.Touch('C'); ---------------------------------------------- C + end case; + end Print; + + Num : Natural := 1000; + + function Issue( Service : Service_Classes; + Flight : Natural; + Seat : String; + Meal : Menu := Fowl ) return Passenger_Ticket is + begin + Num := Num +1; + case Service is + when First => + return Passenger_Ticket'(Service => First, Flight => Flight, + Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); + when Business => + return Passenger_Ticket'(Service => Business, Flight => Flight, + Row_Seat => Seat, Meal => Meal, Serial_Number => Num ); + when Coach => + return Passenger_Ticket'(Service => Coach, Flight => Flight, + Row_Seat => Seat, Serial_Number => Num ); + end case; + end Issue; + + function Issue return Passenger_Ticket is + begin + return Issue( Coach, 0, "non" ); + end Issue; + + end C393010_1; + + ----------------------------------------------------------------- C393010_1 + + with C393010_1; + package C393010_2 is + + type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) + with private; + + function Issue return Charter; + + -- procedure Print( T: Passenger_Ticket ); + + private + type Charter is new C393010_1.Passenger_Ticket( C393010_1.Coach ) + with null record; + + -- Check that the dispatching call to the abstract operation will dispatch + -- to a procedure defined in the private part of a package. + procedure Label( T: Charter ); + + -- an example of a required function the users shouldn't see: + function Issue( Service : C393010_1.Service_Classes; + Flight : Natural; + Seat : String; + Meal : C393010_1.Menu ) return Charter; + + end C393010_2; + + with TCTouch; + package body C393010_2 is + + procedure Label( T: Charter ) is + begin + -- Appropriate_IO.Put( "Excursion Fare" ); + TCTouch.Touch('X'); -------------------------------------------------- X + end Label; + + Num : Natural := 4000; + + function Issue return Charter is + begin + Num := Num +1; + return Charter'(Service => C393010_1.Coach, Flight => 1001, + Row_Seat => "OPN", Serial_Number => Num ); + end Issue; + + function Issue( Service : C393010_1.Service_Classes; + Flight : Natural; + Seat : String; + Meal : C393010_1.Menu ) return Charter is + begin + return Issue; + end Issue; + + end C393010_2; + + ----------------------------------------------------------------- C393010_1 + + with Report; + with TCTouch; + with C393010_0; + with C393010_1; + with C393010_2; -- Charter Tours + + procedure C393010 is + + type Agents_Handle is access all C393010_0.Ticket'Class; + + type Itinerary; + + type Next_Leg is access Itinerary; + + type Itinerary is record + Leg : Agents_Handle; + Next : Next_Leg; + end record; + + function Travel_Agent_1 return Next_Leg is + begin + -- ORL -> JFK -> LAX -> SAN -> DFW -> ORL + return new Itinerary'( + -- ORL -> JFK 01 12 2A First, Lobster + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 12, " 2A", C393010_1.Lobster )), + new Itinerary'( + -- JFK -> LAX 02 18 2B First, Steak + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 18, " 2B", C393010_1.Steak )), + new Itinerary'( + -- LAX -> SAN 03 5225 34H Coach + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.Coach, 5225, "34H")), + new Itinerary'( + -- SAN -> DFW 04 25 13A Business, Fowl + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.Business, 25, "13A")), + new Itinerary'( + -- DFW -> ORL 05 15 1D First, Lobster + new C393010_1.Passenger_Ticket'( + C393010_1.Issue(C393010_1.First, 15, " 1D", C393010_1.Lobster )), + null ))))); + end Travel_Agent_1; + + function Travel_Agent_2 return Next_Leg is + begin + -- LAX -> NRT -> SYD -> LAX + return new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + new Itinerary'( + new C393010_2.Charter'( C393010_2.Issue ), + null )))); + end Travel_Agent_2; + + procedure Traveler( Pax_Tix : in Next_Leg ) is + Fly_Me : Next_Leg := Pax_Tix; + begin + -- a particularly consumptive process... + while Fly_Me /= null loop + C393010_0.Print( Fly_Me.Leg.all ); -- herein lies the test. + Fly_Me := Fly_Me.Next; + end loop; + end Traveler; + + begin + + Report.Test ("C393010", "Check that an extended type can be derived from " + & "an abstract type and that a call on an abstract " + & "operation is a dispatching operation. Check " + & "that such a call can dispatch to an overriding " + & "operation declared in the private part of a " + & "package" ); + + Traveler( Travel_Agent_1 ); + TCTouch.Validate("LPFLPFLPCLPBLPF","First Trip"); + + Traveler( Travel_Agent_2 ); + TCTouch.Validate("XPCXPCXPCXPC","Second Trip"); + + Report.Result; + + end C393010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393011.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,220 ---- + -- C393011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an abstract extended type can be derived from an abstract + -- type, and that a a non-abstract type may then be derived from the + -- second abstract type. + -- + -- TEST DESCRIPTION: + -- Define an abstract type with three primitive operations, two of them + -- abstract. Derive an extended type from it, inheriting the non- + -- abstract operation, overriding one of the abstract operations with + -- a non-abstract operation, and overriding the other abstract operation + -- with an abstract operation. The extended type is therefore abstract; + -- derive an extended type from it. Override the abstract operation with + -- a non-abstract operation; inherit one operation from the original + -- abstract type, and inherit one operation from the intermediate + -- abstract type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + Package C393011_0 is + -- Definitions + + type Status_Enum is (None, Unhandled, Pending, Handled); + type Serial_Type is new Integer range 0 .. Integer'Last; + subtype Priority_Type is Integer range 0..10; + + type Display_Enum is (Bit_Bucket, TTY, Console, Big_Screen); + + Next : Serial_Type := 1; + Display_Device : Display_Enum := Bit_Bucket; + + end C393011_0; + -- Definitions; + + --=======================================================================-- + + with C393011_0; + -- Definitions + + Package C393011_1 is + -- Alert + + package Definitions renames C393011_0; + + type Alert_Type is abstract tagged record + Status : Definitions.Status_Enum := Definitions.None; + Serial_Num : Definitions.Serial_Type := 0; + Priority : Definitions.Priority_Type; + end record; + -- Alert_Type is an abstract type with + -- two operations to be overridden + + procedure Set_Status ( A : in out Alert_Type; -- not abstract + To : Definitions.Status_Enum); + + procedure Set_Serial ( A : in out Alert_Type) is abstract; + procedure Display ( A : Alert_Type) is abstract; + + end C393011_1; + -- Alert + + --=======================================================================-- + + with C393011_0; + package body C393011_1 is + -- Alert + procedure Set_Status ( A : in out Alert_Type; + To : Definitions.Status_Enum) is + begin + A.Status := To; + end Set_Status; + + end C393011_1; + -- Alert; + + --=======================================================================-- + + with C393011_0, + -- Definitions, + C393011_1, + -- Alert, + Calendar; + + Package C393011_3 is + -- New_Alert + + type New_Alert_Type is abstract new C393011_1.Alert_Type with record + Display_Dev : C393011_0.Display_Enum := C393011_0.TTY; + end record; + + -- procedure Set_Status is inherited + + procedure Set_Serial ( A : in out New_Alert_Type); -- override/see body + + procedure Display ( A : New_Alert_Type) is abstract; + -- override is abstract + -- still can't declare objects of New_Alert_Type + + end C393011_3; + -- New_Alert + + --=======================================================================-- + + with C393011_0; + Package Body C393011_3 is + -- New_Alert + + package Definitions renames C393011_0; + + procedure Set_Serial (A : in out New_Alert_Type) is + use type Definitions.Serial_Type; + begin + A.Serial_Num := Definitions.Next; + Definitions.Next := Definitions."+"( Definitions.Next, 1); + end Set_Serial; + + End C393011_3; + -- New_Alert; + + --=======================================================================-- + + with C393011_0, + -- Definitions + C393011_3; + -- New_Alert -- package Alert is not visible + package C393011_4 is + + package New_Alert renames C393011_3; + package Definitions renames C393011_0; + + type Final_Alert_Type is new New_Alert.New_Alert_Type with null record; + -- inherits Set_Status including body + -- inherits Set_Serial including body + -- must override Display since inherited Display is abstract + procedure Display(FA : in Final_Alert_Type); + procedure Handle (FA : in out Final_Alert_Type); + + end C393011_4; + + package body C393011_4 is + + procedure Display (FA : in Final_Alert_Type) is + begin + Definitions.Display_Device := FA.Display_Dev; + end Display; + + procedure Handle (FA : in out Final_Alert_Type) is + begin + Set_Status (FA, Definitions.Handled); + Set_Serial (FA); + Display (FA); + end Handle; + end C393011_4; + + with C393011_0, + -- Definitions + C393011_3; + -- New_Alert -- package Alert is not visible + with C393011_4; + with Report; + procedure C393011 is + use C393011_4; + use Definitions; + + FA : Final_Alert_Type; + + begin + + Report.Test ("C393011", "Check that an extended type can be derived " & + "from an abstract type"); + + if (Definitions.Display_Device /= Definitions.Bit_Bucket) + or (Definitions.Next /= 1) + or (FA.Status /= Definitions.None) + or (FA.Serial_Num /= 0) + or (FA.Display_Dev /= TTY) then + Report.Failed ("Incorrect initial conditions"); + end if; + + Handle (FA); + if (Definitions.Display_Device /= Definitions.TTY) + or (Definitions.Next /= 2) + or (FA.Status /= Definitions.Handled) + or (FA.Serial_Num /= 1) + or (FA.Display_Dev /= TTY) then + Report.Failed ("Incorrect results from Handle"); + end if; + + Report.Result; + + end C393011; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393012.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,221 ---- + -- C393012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a non-abstract subprogram of an abstract type can be + -- called with a controlling operand that is a type conversion to + -- the abstract type. + -- + -- Check that converting to the class-wide type of an abstract type + -- inside an operation of that type causes a "redispatch" of the + -- called operation. + -- + -- TEST DESCRIPTION: + -- This test defines an abstract type, and further derives types from it. + -- The key feature of this test is in the "Display" procedures where + -- the bodies of these procedures convert an object to the class-wide + -- type of the root abstract type, causing a "redispatch". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Dec 94 SAIC Add allocation to the object initializations + -- + --! + + package C393012_0 is + + subtype Row_Number is Positive range 1..120; + subtype Seat_Letter is Character range 'A'..'M'; + + type Ticket is abstract tagged + record + Flight : Natural; + Row : Row_Number; + Seat : Seat_Letter; + end record; + + function Display( T: Ticket ) return String; + function Service( T: Ticket ) return String is abstract; + + end C393012_0; + + with TCTouch; + package body C393012_0 is + function Display( T: Ticket ) return String is + begin + TCTouch.Touch('T'); --------------------------------------------------- T + return "Fl:" & Natural'Image(T.Flight) + & Service( Ticket'Class( T ) ) + & " Seat:" & Row_Number'Image(T.Row) & T.Seat; + end Display; + end C393012_0; + + with C393012_0; + package C393012_1 is + type Economy is new C393012_0.Ticket with null record; + function Display( T: Economy ) return String; + function Service( T: Economy ) return String; + + type Meal_Designator is ( B, L, D, V, SN ); + + type First is new C393012_0.Ticket with + record + Meal : Meal_Designator; + end record; + function Display( T: First ) return String; + function Service( T: First ) return String; + procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ); + + end C393012_1; + + with TCTouch; + package body C393012_1 is + function Display( T: Economy ) return String is + begin + TCTouch.Touch('E'); --------------------------------------------------- E + return C393012_0.Display( C393012_0.Ticket( T ) ); + end Display; -- conversion to abstract type + + function Service( T: Economy ) return String is + begin + TCTouch.Touch('e'); --------------------------------------------------- e + return " K"; + end Service; + + function Display( T: First ) return String is + begin + TCTouch.Touch('F'); --------------------------------------------------- F + return C393012_0.Display( C393012_0.Ticket( T ) ); + end Display; -- conversion to abstract type + + function Service( T: First ) return String is + begin + TCTouch.Touch('f'); --------------------------------------------------- f + return " F" & Meal_Designator'Image(T.Meal); + end Service; + + procedure Set_Meal( T: in out First; To_Meal : Meal_Designator ) is + begin + T.Meal := To_Meal; + end Set_Meal; + + end C393012_1; + + with Report; + with TCTouch; + with C393012_0; + with C393012_1; + procedure C393012 is + + package Rt renames C393012_0; + package Tx renames C393012_1; + + type Tix is access Rt.Ticket'Class; + type Itinerary is array(Positive range 1..3) of Tix; + + -- Outbound and Inbound itineraries provide different orderings of mixtures + -- of Economy and First_Class. Not that that should make any difference... + + Outbound : Itinerary := ( 1 => new Tx.Economy'( 5335, 5, 'B' ), + 2 => new Tx.First' ( 67, 1, 'J', Tx.L ), + 3 => new Tx.Economy'( 345, 37, 'C' ) ); + + Inbound : Itinerary := ( 1 => new Tx.First' ( 456, 4, 'F', Tx.SN ), + 2 => new Tx.Economy'( 68, 12, 'D' ), + 3 => new Tx.Economy'( 5336, 6, 'A' ) ); + + -- Each call to Display uses a parameter that is a type conversion + -- to the abstract type Ticket. + + procedure TC_Convert( I: Itinerary; Leg1,Leg2,Leg3: String ) is + begin + if Rt.Display( Rt.Ticket( I(1).all ) ) /= Leg1 then + Report.Failed( Rt.Display( Rt.Ticket( I(1).all ) ) & " /= " & Leg1 ); + end if; + if Rt.Display( Rt.Ticket( I(2).all ) ) /= Leg2 then + Report.Failed( Rt.Display( Rt.Ticket( I(2).all ) ) & " /= " & Leg2 ); + end if; + if Rt.Display( Rt.Ticket( I(3).all ) ) /= Leg3 then + Report.Failed( Rt.Display( Rt.Ticket( I(3).all ) ) & " /= " & Leg3 ); + end if; + end TC_Convert; + + -- Each call to Display uses a parameter that is not a type conversion + + procedure TC_Match( I: Itinerary; Leg1,Leg2,Leg3: String ) is + begin + if Rt.Display( I(1).all ) /= Leg1 then + Report.Failed( Rt.Display( I(1).all ) & " /= " & Leg1 ); + end if; + if Rt.Display( I(2).all ) /= Leg2 then + Report.Failed( Rt.Display( I(2).all ) & " /= " & Leg2 ); + end if; + if Rt.Display( I(3).all ) /= Leg3 then + Report.Failed( Rt.Display( I(3).all ) & " /= " & Leg3 ); + end if; + end TC_Match; + + begin -- Main test procedure. + + Report.Test ("C393012", "Check that a non-abstract subprogram of an " + & "abstract type can be called with a " + & "controlling operand that is a type " + & "conversion to the abstract type. " + & "Check that converting to the class-wide type " + & "of an abstract type inside an operation of " + & "that type causes a redispatch" ); + + -- Test conversions to abstract type + + TC_Convert( Outbound, "Fl: 5335 K Seat: 5B", + "Fl: 67 FL Seat: 1J", + "Fl: 345 K Seat: 37C" ); + + TCTouch.Validate( "TeTfTe", "Outbound flight (converted)" ); + + TC_Convert( Inbound, "Fl: 456 FSN Seat: 4F", + "Fl: 68 K Seat: 12D", + "Fl: 5336 K Seat: 6A" ); + + TCTouch.Validate( "TfTeTe", "Inbound flight (converted)" ); + + -- Test without conversions to abstract type + + TC_Match( Outbound, "Fl: 5335 K Seat: 5B", + "Fl: 67 FL Seat: 1J", + "Fl: 345 K Seat: 37C" ); + + TCTouch.Validate( "ETeFTfETe", "Outbound flight" ); + + TC_Match( Inbound, "Fl: 456 FSN Seat: 4F", + "Fl: 68 K Seat: 12D", + "Fl: 5336 K Seat: 6A" ); + + TCTouch.Validate( "FTfETeETe", "Inbound flight" ); + + Report.Result; + + end C393012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a02.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- C393A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a dispatching call to an abstract subprogram invokes + -- the correct subprogram body of a descendant type according to + -- the controlling tag. + -- Check that a subprogram can be declared with formal parameters + -- and result that are of an abstract type's associated class-wide + -- type and that such subprograms can be called. 3.4.1(4) + -- + -- TEST DESCRIPTION: + -- This test declares several objects of types derived from the + -- abstract type as defined in the foundation F393A00. It then calls + -- various dispatching and class-wide subprograms using those objects. + -- The packages in F393A00 are instrumented to trace the flow of + -- execution. + -- The test checks for the correct order of execution, as expected + -- by the various calls. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F393A00.A (foundation code) + -- C393A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 05 APR 96 SAIC Update RM references for 2.1 + -- + --! + + with Report; + with F393A00_0; + with F393A00_1; + with F393A00_2; + with F393A00_3; + with F393A00_4; + procedure C393A02 is + + A_Windmill : F393A00_2.Windmill; + A_Pump : F393A00_3.Pump; + A_Mill : F393A00_4.Mill; + + A_Windmill_2 : F393A00_2.Windmill; + A_Pump_2 : F393A00_3.Pump; + A_Mill_2 : F393A00_4.Mill; + + B_Windmill : F393A00_2.Windmill; + B_Pump : F393A00_3.Pump; + B_Mill : F393A00_4.Mill; + + procedure Swapem( A,B: in out F393A00_2.Windmill'Class ) is + begin + F393A00_0.TC_Touch('x'); + F393A00_2.Swap( A,B ); + end Swapem; + + function Zephyr( A: F393A00_2.Windmill'Class ) + return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := A; + begin + F393A00_0.TC_Touch('y'); + if not F393A00_1.Initialized( Item ) then -- b + F393A00_2.Initialize( Item ); -- a + end if; + F393A00_2.Stop( Item ); -- f / mff + F393A00_2.Add_Spin( Item, 10 ); -- e + return Item; + end Zephyr; + + function Gale( It: F393A00_2.Windmill ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- f + F393A00_2.Add_Spin( Item, 40 ); -- e + return Item; + end Gale; + + function Gale( It: F393A00_3.Pump ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- f + F393A00_2.Add_Spin( Item, 50 ); -- e + return Item; + end Gale; + + function Gale( It: F393A00_4.Mill ) return F393A00_2.Windmill'Class is + Item : F393A00_2.Windmill'Class := It; + begin + F393A00_2.Stop( Item ); -- mff + F393A00_2.Add_Spin( Item, 60 ); -- e + return Item; + end Gale; + + begin -- Main test procedure. + + Report.Test ("C393A02", "Check that a dispatching call to an abstract " + & "subprogram invokes the correct subprogram body. " + & "Check that a subprogram declared with formal " + & "parameters/result of an abstract type's " + & "associated class-wide can be called" ); + + F393A00_0.TC_Validate( "hhh", "Mill declarations" ); + A_Windmill := F393A00_2.Create; + F393A00_0.TC_Validate( "d", "Create A_Windmill" ); + + A_Pump := F393A00_3.Create; + F393A00_0.TC_Validate( "h", "Create A_Pump" ); + + A_Mill := F393A00_4.Create; + F393A00_0.TC_Validate( "hl", "Create A_Mill" ); + + -------------- + + Swapem( A_Windmill, A_Windmill_2 ); + F393A00_0.TC_Validate( "xc", "Windmill Swap" ); + + Swapem( A_Pump, A_Pump_2 ); + F393A00_0.TC_Validate( "xc", "Pump Swap" ); + + Swapem( A_Mill, A_Mill_2 ); + F393A00_0.TC_Validate( "xk", "Pump Swap" ); + + F393A00_2.Initialize( A_Windmill_2 ); + F393A00_3.Initialize( A_Pump_2 ); + F393A00_4.Initialize( A_Mill_2 ); + B_Windmill := A_Windmill_2; + B_Pump := A_Pump_2; + B_Mill := A_Mill_2; + F393A00_2.Add_Spin( B_Windmill, 123 ); + F393A00_3.Set_Rate( B_Pump, 12.34 ); + F393A00_4.Add_Spin( B_Mill, 321 ); + F393A00_0.TC_Validate( "aaaeie", "Setting Values" ); + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Windmill ); -- ybfe + XX : F393A00_2.Windmill'Class := Gale( B_Windmill ); -- fe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) + then + Report.Failed( "Copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 40 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybfefebbgg", "Windmill Zephyr" ); + end; + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Pump ); -- ybfe + XX : F393A00_2.Windmill'Class := Gale( B_Pump ); -- fe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) + then + Report.Failed( "Bad copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 50 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybfefebbgg", "Pump Zephyr" ); + end; + + declare + It : F393A00_2.Windmill'Class := Zephyr( B_Mill ); -- ybmffe + XX : F393A00_2.Windmill'Class := Gale( B_Mill ); -- mffe + use type F393A00_2.Rotational_Measurement; + begin + if not F393A00_1.Initialized( It ) or not F393A00_1.Initialized( XX ) + then + Report.Failed( "Bad copy to class-wide variable" ); + end if; -- bb + if F393A00_2.Spin( It ) /= 10 -- g + or F393A00_2.Spin( XX ) /= 60 then -- g + Report.Failed( "Call to class-wide operation" ); + end if; + + F393A00_0.TC_Validate( "ybmffemffebbgg", "Mill Zephyr" ); + end; + + Report.Result; + + end C393A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a03.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- C393A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a non-abstract primitive subprogram of an abstract + -- type can be called as a dispatching operation and that the body + -- of this subprogram can make a dispatching call to an abstract + -- operation of the corresponding abstract type. + -- + -- TEST DESCRIPTION: + -- This test expands on the class family defined in foundation F393A00 + -- by deriving a new abstract type from the root abstract type "Object". + -- The subprograms defined for the new abstract type are then + -- appropriately overridden, and the test ultimately calls various + -- mixtures of these subprograms to check that the dispatching occurs + -- correctly. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F393A00.A (foundation code) + -- C393A03.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed ARM references from objective text. + -- 23 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + ------------------------------------------------------------------- C393A03_0 + + with F393A00_1; + package C393A03_0 is + + type Counting_Object is abstract new F393A00_1.Object with private; + -- inherits Initialize, Swap (abstract) and Create (abstract) + + procedure Bump ( A_Counter: in out Counting_Object ); + procedure Clear( A_Counter: in out Counting_Object ) is abstract; + procedure Zero ( A_Counter: in out Counting_Object ); + function Value( A_Counter: Counting_Object'Class ) return Natural; + + private + + type Counting_Object is abstract new F393A00_1.Object with + record + Tally : Natural :=0; + end record; + + end C393A03_0; + + ----------------------------------------------------------------------------- + + with F393A00_0; + package body C393A03_0 is + + procedure Bump ( A_Counter: in out Counting_Object ) is + begin + F393A00_0.TC_Touch('A'); + A_Counter.Tally := A_Counter.Tally +1; + end Bump; + + procedure Zero ( A_Counter: in out Counting_Object ) is + begin + F393A00_0.TC_Touch('B'); + + -- dispatching call to abstract operation of Counting_Object + Clear( Counting_Object'Class(A_Counter) ); + + A_Counter.Tally := 0; + + end Zero; + + function Value( A_Counter: Counting_Object'Class ) return Natural is + begin + F393A00_0.TC_Touch('C'); + return A_Counter.Tally; + end Value; + + end C393A03_0; + + ------------------------------------------------------------------- C393A03_1 + + with C393A03_0; + package C393A03_1 is + + type Modular_Object is new C393A03_0.Counting_Object with private; + -- inherits Initialize, Bump, Zero and Value, + -- inherits abstract Swap, Create and Clear + + procedure Swap( A,B: in out Modular_Object ); + procedure Clear( It: in out Modular_Object ); + procedure Set_Max( It : in out Modular_Object; Value : Natural ); + function Create return Modular_Object; + + private + + type Modular_Object is new C393A03_0.Counting_Object with + record + Max_Value : Natural; + end record; + + end C393A03_1; + + ----------------------------------------------------------------------------- + + with F393A00_0; + package body C393A03_1 is + + procedure Swap( A,B: in out Modular_Object ) is + T : constant Modular_Object := B; + begin + F393A00_0.TC_Touch('1'); + B := A; + A := T; + end Swap; + + procedure Clear( It: in out Modular_Object ) is + begin + F393A00_0.TC_Touch('2'); + null; + end Clear; + + procedure Set_Max( It : in out Modular_Object; Value : Natural ) is + begin + F393A00_0.TC_Touch('3'); + It.Max_Value := Value; + end Set_Max; + + function Create return Modular_Object is + AMO : Modular_Object; + begin + F393A00_0.TC_Touch('4'); + AMO.Max_Value := Natural'Last; + return AMO; + end Create; + + end C393A03_1; + + --------------------------------------------------------------------- C393A03 + + with Report; + with F393A00_0; + with F393A00_1; + with C393A03_0; + with C393A03_1; + procedure C393A03 is + + A_Thing : C393A03_1.Modular_Object; + Another_Thing : C393A03_1.Modular_Object; + + procedure Initialize( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Initialize( It ); -- dispatch to inherited procedure + end Initialize; + + procedure Bump( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Bump( It ); -- dispatch to non-abstract procedure + end Bump; + + procedure Set_Max( It : in out C393A03_1.Modular_Object'Class; + Val : Natural) is + begin + C393A03_1.Set_Max( It, Val ); -- dispatch to non-abstract procedure + end Set_Max; + + procedure Swap( A, B : in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Swap( A, B ); -- dispatch to inherited abstract procedure + end Swap; + + procedure Zero( It: in out C393A03_0.Counting_Object'Class ) is + begin + C393A03_0.Zero( It ); -- dispatch to non-abstract procedure + end Zero; + + begin -- Main test procedure. + + Report.Test ("C393A03", "Check that a non-abstract primitive subprogram " + & "of an abstract type can be called as a " + & "dispatching operation and that the body of this " + & "subprogram can make a dispatching call to an " + & "abstract operation of the corresponding " + & "abstract type" ); + + A_Thing := C393A03_1.Create; -- Max_Value = Natural'Last + F393A00_0.TC_Validate( "4", "Overridden primitive layer 2"); + + Initialize( A_Thing ); + Initialize( Another_Thing ); + F393A00_0.TC_Validate( "aa", "Non-abstract primitive layer 0"); + + Bump( A_Thing ); -- Tally = 1 + F393A00_0.TC_Validate( "A", "Non-abstract primitive layer 1"); + + Set_Max( A_Thing, 42 ); -- Max_Value = 42 + F393A00_0.TC_Validate( "3", "Non-abstract normal layer 2"); + + if not F393A00_1.Initialized( A_Thing ) then + Report.Failed("Initialize didn't"); + end if; + F393A00_0.TC_Validate( "b", "Class-wide layer 0"); + + Swap( A_Thing, Another_Thing ); + F393A00_0.TC_Validate( "1", "Overridden abstract layer 2"); + + Zero( A_Thing ); + F393A00_0.TC_Validate( "B2", "Non-abstract layer 0, calls dispatch"); + + if C393A03_0.Value( A_Thing ) /= 0 then + Report.Failed("Zero didn't"); + end if; + F393A00_0.TC_Validate( "C", "Class-wide normal layer 2"); + + Report.Result; + + end C393A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a05.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a05.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a05.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a05.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + -- C393A05.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a nonabstract private extension, any inherited + -- abstract subprograms can be overridden in the private part of + -- the immediately enclosing package and that calls can be made to + -- private dispatching operations. + -- + -- TEST DESCRIPTION: + -- This test builds an additional layer upon the foundation code to + -- provide the required "hidden" dispatching operation. The procedure + -- Swap, a private subprogram, should be called by dispatch. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F393A00.A (foundation code) + -- C393A05.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F393A00_4; + package C393A05_0 is + type Grinder is new F393A00_4.Mill with private; + type Coarseness is (Whole_Bean, Coarse, Medium, Fine, Espresso); + + procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ); + function Grind( It: Grinder ) return Coarseness; + + function Create return Grinder; + private + procedure Swap( A,B: in out Grinder ); + type Grinder is new F393A00_4.Mill with + record + Grind : Coarseness := Whole_Bean; + end record; + end C393A05_0; + + with F393A00_0; + package body C393A05_0 is + procedure Set_Grind( It: in out Grinder; The_Grind: Coarseness ) is + begin + F393A00_0.TC_Touch( 'A' ); + It.Grind := The_Grind; + end Set_Grind; + + function Grind( It: Grinder ) return Coarseness is + begin + F393A00_0.TC_Touch( 'B' ); + return It.Grind; + end Grind; + + procedure Swap( A,B: in out Grinder ) is + T : constant Grinder := A; + begin + F393A00_0.TC_Touch( 'C' ); + A := B; + B := T; + end Swap; + + function Create return Grinder is + One: Grinder; + begin + F393A00_0.TC_Touch( 'D' ); + F393A00_4.Initialize( F393A00_4.Mill( One ) ); + One.Grind := Fine; + return One; + end Create; + end C393A05_0; + + with Report; + with F393A00_0; + with C393A05_0; + procedure C393A05 is + + package Tracer renames F393A00_0; + package Coffee renames C393A05_0; + use type Coffee.Coarseness; + + Morning : Coffee.Grinder; + Afternoon : Coffee.Grinder; + + Gritty : Coffee.Coarseness; + + procedure Class_Swap( A, B: in out Coffee.Grinder'Class ) is + begin + Coffee.Swap( A, B ); -- dispatch + end Class_Swap; + + begin -- Main test procedure. + + Report.Test ("C393A05", "Check that nonabstract private extensions, " + & "inherited abstract subprograms overridden " + & "in the private part can be dispatched from " + & "outside the package" ); + + Tracer.TC_Validate( "hh", "Declarations" ); + + Morning := Coffee.Create; + Tracer.TC_Validate( "hDa", "Creating Morning Coffee" ); + Gritty := Coffee.Grind( Morning ); + Tracer.TC_Validate( "B", "Finding Morning Grind" ); + + Afternoon := Coffee.Create; + Tracer.TC_Validate( "hDa", "Creating Afternoon Coffee" ); + Coffee.Set_Grind( Afternoon, Coffee.Medium ); + Tracer.TC_Validate( "A", "Setting Afternoon Grind" ); + + Coffee.Swap( Morning, Afternoon ); + Tracer.TC_Validate( "C", "Dispatching Swapping Coffees" ); + + if Gritty /= Coffee.Grind( Afternoon ) + or Coffee.Grind ( Afternoon ) /= Coffee.Fine then + Report.Failed ("Result of Swap"); + end if; + Tracer.TC_Validate( "BB", "Finding Afternoon Grind" ); + + Sunset: declare + Evening : Coffee.Grinder'Class := Coffee.Create; + begin + Tracer.TC_Validate( "hDa", "Creating Evening Coffee" ); + + Coffee.Set_Grind( Evening, Coffee.Espresso ); + Tracer.TC_Validate( "A", "Setting Evening Grind" ); + + Morning := Coffee.Grinder( Evening ); + Class_Swap( Morning, Evening ); + Tracer.TC_Validate( "C", "Swapping Coffees" ); + if Coffee.Grind( Morning ) /= Coffee.Espresso then + Report.Failed ("Result of Assignment"); + end if; + end Sunset; + + Report.Result; + + end C393A05; + + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a06.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a06.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393a06.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393a06.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,201 ---- + -- C393A06.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a type that inherits abstract operations but + -- overrides each of these operations is not required to be + -- abstract, and that objects of the type and its class-wide type + -- may be declared and passed in calls to the overriding + -- subprograms. + -- + -- TEST DESCRIPTION: + -- This test derives a type from the root abstract type available + -- in foundation F393A00. It declares subprograms as required by + -- the language to override the abstract subprograms, allowing the + -- derived type itself to be not abstract. It also declares + -- operations on the new type, as well as on the associated class- + -- wide type. The main program then uses two objects of the type + -- and two objects of the class-wide type as parameters for each of + -- the subprograms. Correct execution is determined by path + -- analysis and value checking. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F393A00.A (foundation code) + -- C393A06.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- + --! + + with F393A00_1; + package C393A06_0 is + type Organism is new F393A00_1.Object with private; + type Kingdoms is ( Animal, Vegetable, Unspecified ); + + procedure Swap( A,B: in out Organism ); + function Create return Organism; + + procedure Initialize( The_Entity : in out Organism; + In_The_Kingdom : Kingdoms ); + function Kingdom( Of_The_Entity : Organism ) return Kingdoms; + + procedure TC_Check( An_Entity : Organism'Class; + In_Kingdom : Kingdoms; + Initialized : Boolean ); + + Incompatible : exception; + + private + type Organism is new F393A00_1.Object with + record + In_Kingdom : Kingdoms; + end record; + end C393A06_0; + + with F393A00_0; + package body C393A06_0 is + + procedure Swap( A,B: in out Organism ) is + begin + F393A00_0.TC_Touch( 'A' ); ------------------------------------------- A + if A.In_Kingdom /= B.In_Kingdom then + F393A00_0.TC_Touch( 'X' ); + raise Incompatible; + else + declare + T: constant Organism := A; + begin + A := B; + B := T; + end; + end if; + end Swap; + + function Create return Organism is + Widget : Organism; + begin + F393A00_0.TC_Touch( 'B' ); ------------------------------------------- B + Initialize( Widget ); + Widget.In_Kingdom := Unspecified; + return Widget; + end Create; + + procedure Initialize( The_Entity : in out Organism; + In_The_Kingdom : Kingdoms ) is + begin + F393A00_0.TC_Touch( 'C' ); ------------------------------------------- C + F393A00_1.Initialize( F393A00_1.Object( The_Entity ) ); + The_Entity.In_Kingdom := In_The_Kingdom; + end Initialize; + + function Kingdom( Of_The_Entity : Organism ) return Kingdoms is + begin + F393A00_0.TC_Touch( 'D' ); ------------------------------------------- D + return Of_The_Entity.In_Kingdom; + end Kingdom; + + procedure TC_Check( An_Entity : Organism'Class; + In_Kingdom : Kingdoms; + Initialized : Boolean ) is + begin + if F393A00_1.Initialized( An_Entity ) /= Initialized then + F393A00_0.TC_Touch( '-' ); ------------------------------------------- - + elsif An_Entity.In_Kingdom /= In_Kingdom then + F393A00_0.TC_Touch( '!' ); ------------------------------------------- ! + else + F393A00_0.TC_Touch( '+' ); ------------------------------------------- + + end if; + end TC_Check; + + end C393A06_0; + + with Report; + + with C393A06_0; + with F393A00_0; + with F393A00_1; + procedure C393A06 is + + package Darwin renames C393A06_0; + package Tagger renames F393A00_0; + package Objects renames F393A00_1; + + Lion : Darwin.Organism; + Tigerlily : Darwin.Organism; + Bear : Darwin.Organism'Class := Darwin.Create; + Sunflower : Darwin.Organism'Class := Darwin.Create; + + use type Darwin.Kingdoms; + + begin -- Main test procedure. + + Report.Test ("C393A06", "Check that a type that inherits abstract " + & "operations but overrides each of these " + & "operations is not required to be abstract. " + & "Check that objects of the type and its " + & "class-wide type may be declared and passed " + & "in calls to the overriding subprograms" ); + + Tagger.TC_Validate( "BaBa", "Declaration Initializations" ); + + Darwin.Initialize( Lion, Darwin.Animal ); + Darwin.Initialize( Tigerlily, Darwin.Vegetable ); + Darwin.Initialize( Bear, Darwin.Animal ); + Darwin.Initialize( Sunflower, Darwin.Vegetable ); + + Tagger.TC_Validate( "CaCaCaCa", "Initialization sequence" ); + + Oh_My: begin + Darwin.Swap( Lion, Darwin.Organism( Bear ) ); + Darwin.Swap( Lion, Tigerlily ); + Report.Failed("Exception not raised"); + exception + when Darwin.Incompatible => null; + end Oh_My; + + Tagger.TC_Validate( "AAX", "Swap sequence" ); + + if Darwin.Kingdom( Darwin.Create ) = Darwin.Unspecified then + Darwin.Swap( Sunflower, Darwin.Organism'Class( Tigerlily ) ); + end if; + + Tagger.TC_Validate( "BaDA", "Vegetable swap sequence" ); + + Darwin.TC_Check( Lion, Darwin.Animal, True ); + Darwin.TC_Check( Tigerlily, Darwin.Vegetable, True ); + Darwin.TC_Check( Bear, Darwin.Animal, True ); + Darwin.TC_Check( Sunflower, Darwin.Vegetable, True ); + + Tagger.TC_Validate( "b+b+b+b+", "Final sequence" ); + + Report.Result; + + end C393A06; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b12.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b12.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b12.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b12.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- C393B12.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived in the specification of a + -- generic package when the parent is an abstract type in a library + -- package. + -- + -- TEST DESCRIPTION: + -- Extend an abstract type in the visible part of a generic package. + -- Make all of the procedures which override abstract procedures + -- available as part of the generic interface. Instantiate the generic. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F393B00.A Package Alert_Foundation + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Oct 95 SAIC Update and repair for ACVC 2.0.1 + -- 27 Feb 97 PWB.CTA Add pragma Elaborate for C393B12_0. + --! + + ----------------------------------------------------------------- C393B12_0 + + with F393B00; + -- Alert_Foundation + generic + type Generic_Status_Enum is (<>); + + package C393B12_0 is + -- Alert_Functions + + type Generic_Alert_Type is new F393B00.Alert with record + Status : Generic_Status_Enum := Generic_Status_Enum'First; + end record; + -- extension of an abstract type + + procedure Handle (GA : in out Generic_Alert_Type); + -- override of abstract procedure + + function Query_Status (GA : Generic_Alert_Type) + return Generic_Status_Enum; -- new primitive operation for + -- Generic_Alert_Type + end C393B12_0; + -- Alert_Functions + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C393B12_0 is + -- Alert_Functions + + procedure Handle (GA : in out Generic_Alert_Type) is + begin + GA.Status := Generic_Status_Enum'Last; + end Handle; + + function Query_Status (GA : Generic_Alert_Type) + return Generic_Status_Enum is + begin + return GA.Status; + end Query_Status; + + end C393B12_0; + + ----------------------------------------------------------------- C393B12_1 + + package C393B12_1 is + type Status is (Low, Medium, High); + end C393B12_1; + + ------------------------------------------------------- C393B12_1.C393B12_2 + + with C393B12_0; + pragma Elaborate (C393B12_0); + package C393B12_1.C393B12_2 is new C393B12_0 + -- Alert_Functions + (Generic_Status_Enum => Status); + + ------------------------------------------------------------------- C393B12 + + with C393B12_1.C393B12_2; + with Report; + procedure C393B12 is + + use type C393B12_1.Status; + + package Alt_Alert renames C393B12_1.C393B12_2; + + GA : Alt_Alert.Generic_Alert_Type; + + begin + Report.Test ("C393B12", "Check that an extended type can be derived " & + "from an abstract type"); + + if Alt_Alert.Query_Status (GA) /= C393B12_1.Low then + Report.Failed ("Wrong initialization"); + end if; + + Alt_Alert.Handle (GA); + if Alt_Alert.Query_Status (GA) /= C393B12_1.High then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + + end C393B12; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b13.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b13.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b13.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b13.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C393B13.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived from an abstract type + -- when that derivation is declared in a child package. + -- + -- TEST DESCRIPTION: + -- Add a visible child to Alert_Foundation. Using the abstract type + -- Alert as parent, declare an extended type with discriminant and new + -- record components. Override the Handle procedure. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F393B00.A Package Alert_Foundation + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + package F393B00.C393B13_0 is + -- Alert_Foundation.Public_Child + + subtype Msg_Length_Range is integer range 0 .. 240; + Max_Msg_Length : constant Msg_Length_Range := 80; + Message : String := "Test Passed"; + + type Child_Alert (Length : Msg_Length_Range) + is new Alert with record -- abstract type is in parent package + Times_Handled : Natural := 0; + Msg : String (1..Length); + end record; + + procedure Handle (CA : in out Child_Alert); -- required override + + end F393B00.C393B13_0; + -- Alert_Foundation.Public_Child; + + --=======================================================================-- + + package body F393B00.C393B13_0 is + -- Alert_Foundation.Public_Child + + procedure Handle (CA : in out Child_Alert) is + begin + CA.Msg(1..Message'Length) := Message; + CA.Times_Handled := CA.Times_Handled + 1; + end; + + end F393B00.C393B13_0; + -- Alert_Foundation.Public_Child + + --=======================================================================-- + + with Report; + with F393B00.C393B13_0; + -- Alert_foundation.Public_Child; + procedure C393B13 is + package Child renames F393B00.C393B13_0; + CA : Child.Child_Alert(Child.Message'Length); + + begin + + Report.Test ("C393B13", "Check that an extended type can be derived " & + "from an abstract type"); + + if CA.Times_Handled /= 0 then + Report.Failed ("Wrong initialization"); + end if; + + Child.Handle (CA); + if (CA.Times_Handled /= 1) + or (CA.Msg /= Child.Message) then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + + end C393B13; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b14.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b14.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c393b14.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c393b14.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C393B14.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an extended type can be derived in a private child package + -- from an abstract type defined in a library package. + -- + -- TEST DESCRIPTION: + -- Add a private child package to Alert_Foundation. Using Private_Alert + -- as parent type, declare an extended type adding a new record component. + -- Override procedure Handle. Declare an object of the new type in the + -- child specification. Use type definitions from the private part of the + -- parent in the body of the child. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F393B00.A Package Alert_Foundation + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + private package F393B00.C393B14_0 is + -- Alert_Foundation.Private_Child + + type Implementation_Specific_Alert_Type is new Private_Alert with record + New_Private_Field : Implementation_Detail + := Implementation_Detail'Last; + end record; + + procedure Handle (PA : in out Implementation_Specific_Alert_Type); + -- overrides abstract Handle, as required + PA : Implementation_Specific_Alert_Type; + + end F393B00.C393B14_0; + -- Alert_Foundation.Private_Child + + --=======================================================================-- + + package body F393B00.C393B14_0 is + -- Alert_Foundation.Private_Child + + procedure Handle (PA : in out Implementation_Specific_Alert_Type) is + begin + PA.Private_Field := 1; + PA.New_Private_Field := PA.Private_Field + 1; + end; + + end F393B00.C393B14_0; + -- Alert_Foundation.Private_Child + + --=======================================================================-- + + package F393B00.C393B14_1 is + -- Alert_Foundation.Public_Child + + type Timing is (Before, After); + procedure Init; + procedure Modify; + function Check_Before return Boolean; + function Check_After return Boolean; + + end F393B00.C393B14_1; + -- Alert_Foundation.Public_Child + + --=======================================================================-- + + with F393B00.C393B14_0; -- private sibling is visible in the + -- Alert_Foundation.Private_Child -- body of a public sibling + package body F393B00.C393B14_1 is + -- Alert_Foundation.Public_Child + package Priv renames F393B00.C393B14_0; + + procedure Init is + begin + Priv.PA.Private_Field := 5; + Priv.PA.New_Private_Field := 10; + end Init; + + procedure Modify is + begin + Priv.Handle (Priv.PA); + end Modify; + + function Check_Before return Boolean is + begin + return ((Priv.PA.Private_Field = 5) + and (Priv.PA.New_Private_Field =10)); + end Check_Before; + + function Check_After return Boolean is + begin + return ((Priv.PA.Private_Field = 1) + and (Priv.PA.New_Private_Field = 2)); + end Check_After; + + end F393B00.C393B14_1; + -- Alert_Foundation.Public_Child + + --=======================================================================-- + + with Report; + with F393B00.C393B14_1; + procedure C393B14 is + -- Alert_Foundation.Public_Child; + + begin + Report.Test ("C393B14", "Check that an extended type can be derived " & + "from an abstract type"); + + F393B00.C393B14_1.Init; + if not F393B00.C393B14_1.Check_Before then + Report.Failed ("Wrong initialization"); + end if; + + F393B00.C393B14_1.Modify; + if not F393B00.C393B14_1.Check_After then + Report.Failed ("Wrong results from Handle"); + end if; + + Report.Result; + end C393B14; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C3A0001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that access to subprogram type can be used to select and + -- invoke functions with appropriate arguments dynamically. + -- + -- TEST DESCRIPTION: + -- Declare an access to function type in a package specification. + -- Declare three different sine functions that can be referred to by + -- the access to function type. + -- + -- In the main program, call each function indirectly by dereferencing + -- the access value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A0001_0 is + + TC_Call_Tag : Natural := 0; + + -- Type accesses to any sine function + type Sine_Function_Ptr is access function + (Angle : in Float) return Float; + + -- Three 'Sine' functions that model an application situation in which + -- one function might be chosen when speed is important, another (using + -- a different algorithm) might be chosen when accuracy is important, + -- and so on. + + function Sine_Calc_Fast (Angle : in Float) return Float; + + function Sine_Calc_Acc (Angle : in Float) return Float; + + function Sine_Calc_Table (Angle : in Float) return Float; + + end C3A0001_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0001_0 is + + function Sine_Calc_Fast (Angle : in Float) return Float is + begin + TC_Call_Tag := 1; + return 1.0; + end Sine_Calc_Fast; + + + function Sine_Calc_Acc (Angle : in Float) return Float is + begin + TC_Call_Tag := 2; + return 0.0; + end Sine_Calc_Acc; + + + function Sine_Calc_Table (Angle : in Float) return Float is + begin + TC_Call_Tag := 3; + return -1.0; + end Sine_Calc_Table; + + end C3A0001_0; + + ----------------------------------------------------------------------------- + + with Report; + with C3A0001_0; + + procedure C3A0001 is + + Sine_Access : C3A0001_0.Sine_Function_Ptr; + X, Theta : Float := 0.0; + + begin + + Report.Test ("C3A0001", "Check that access to subprogram can be " & + "used to select and invoke an operation with " & + "appropriate arguments dynamically"); + + Sine_Access := C3A0001_0.Sine_Calc_Fast'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 1 then + Report.Failed ("Incorrect Sine_Calc_Fast result"); + end if; + + Sine_Access := C3A0001_0.Sine_Calc_Acc'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 2 then + Report.Failed ("Incorrect Sine_Calc_Acc result"); + end if; + + Sine_Access := C3A0001_0.Sine_Calc_Table'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access(Theta); + + If C3A0001_0.TC_Call_Tag /= 3 then + Report.Failed ("Incorrect Sine_Calc_Table result"); + end if; + + Report.Result; + + end C3A0001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C3A0002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that access to subprogram type can be used to select and + -- invoke procedures with appropriate arguments dynamically. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare three different log procedures that can be referred to by + -- the access to procedure type. + -- + -- In the main program, call each procedure indirectly by dereferencing + -- the access value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 05 APR 96 SAIC RM reference change for 2.1 + -- + -- + --! + + + package C3A0002_0 is + + TC_Call_Tag : Natural := 0; + + Return_Num : Float := 0.0; + + -- Type accesses to any log procedure + type Log_Procedure_Ptr is access procedure + (Angle : in Float); + + procedure Log_Calc_Fast (Angle : in Float); + + procedure Log_Calc_Acc (Angle : in Float); + + procedure Log_Calc_Table (Angle : in Float); + + end C3A0002_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0002_0 is + + procedure Log_Calc_Fast (Angle : in Float) is + begin + TC_Call_Tag := 1; + Return_Num := Angle; + end Log_Calc_Fast; + + + procedure Log_Calc_Acc (Angle : in Float) is + begin + TC_Call_Tag := 2; + Return_Num := Angle; + end Log_Calc_Acc; + + + procedure Log_Calc_Table (Angle : in Float) is + begin + TC_Call_Tag := 3; + Return_Num := Angle; + end Log_Calc_Table; + + end C3A0002_0; + + ----------------------------------------------------------------------------- + + with Report; + with C3A0002_0; + + procedure C3A0002 is + + Log_Access : C3A0002_0.Log_Procedure_Ptr; + Theta : Float := 0.0; + + begin + + Report.Test ("C3A0002", "Check that access to subprogram type can be " + & "used to select and invoke procedures with " + & "appropriate arguments dynamically" ); + + Log_Access := C3A0002_0.Log_Calc_Fast'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 1 or C3A0002_0.Return_Num /= 0.0 then + Report.Failed ("Incorrect Log_Calc_Fast result"); + end if; + + Theta := 1.0; + + Log_Access := C3A0002_0.Log_Calc_Acc'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 2 or C3A0002_0.Return_Num /= 1.0 then + Report.Failed ("Incorrect Log_Calc_Acc result"); + end if; + + Theta := -1.0; + + Log_Access := C3A0002_0.Log_Calc_Table'Access; + + -- Invoking Log procedure designated by access value + Log_Access (Theta); + + If C3A0002_0.TC_Call_Tag /= 3 or C3A0002_0.Return_Num /= -1.0 then + Report.Failed ("Incorrect Log_Calc_Table result"); + end if; + + Report.Result; + + end C3A0002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C3A0003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a function in a generic instance can be called using + -- an access-to-subprogram value. + -- + -- TEST DESCRIPTION: + -- Declare a numeric type in the visible part of a generic package. + -- Declare an access to function type. Declare three different sine + -- functions that can be referred to by the access to function type. + -- + -- In the main program, instantiate the generic. Call each function + -- indirectly by dereferencing the access value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic + type Real_Num is digits <>; + + package C3A0003_0 is + + TC_Call_Tag : Natural := 0; + + -- Type accesses to any sine function + type Sine_Function_Ptr is access function + (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num; + + function Sine_Calc_Table (Angle : in Real_Num) return Real_Num; + + end C3A0003_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0003_0 is + + function Sine_Calc_Fast (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := 1.0; + begin + TC_Call_Tag := 1; + return Sine_Num; + end Sine_Calc_Fast; + + + function Sine_Calc_Acc (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := 0.0; + begin + TC_Call_Tag := 2; + return Sine_Num; + end Sine_Calc_Acc; + + + function Sine_Calc_Table (Angle : in Real_Num) return Real_Num is + Sine_Num : Real_Num := -1.0; + begin + TC_Call_Tag := 3; + return Sine_Num; + end Sine_Calc_Table; + + end C3A0003_0; + + ----------------------------------------------------------------------------- + + with Report; + with C3A0003_0; + + procedure C3A0003 is + + type Real is digits 5; + + Subtype Trig_Float is Real range -1.0 .. 1.0; + + package Trig is new C3A0003_0 (Real_Num => Trig_Float); + + Sine_Access : Trig.Sine_Function_Ptr; + X, Theta : Trig_Float := 0.0; + + begin + + Report.Test ("C3A0003", "Check that a function in a generic instance can " + & "be called using an access-to-subprogram value"); + + Sine_Access := Trig.Sine_Calc_Fast'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 1 then + Report.Failed ("Incorrect Sine_Calc_Fast result"); + end if; + + Sine_Access := Trig.Sine_Calc_Acc'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 2 then + Report.Failed ("Incorrect Sine_Calc_Acc result"); + end if; + + Sine_Access := Trig.Sine_Calc_Table'Access; + + -- Invoking Sine function designated by access value + X := Sine_Access.all(Theta); + + If Trig.TC_Call_Tag /= 3 then + Report.Failed ("Incorrect Sine_Calc_Table result"); + end if; + + Report.Result; + + end C3A0003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0004.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C3A0004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that access to subprogram may be stored within array + -- objects, and that the access to subprogram can subsequently + -- be called. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare an array of the access type. Declare three different + -- procedures that can be referred to by the access to procedure type. + -- + -- In the main program, build the array by dereferencing the access + -- value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + + procedure C3A0004 is + + Left_Turn : Integer := 1; + + Right_Turn : Integer := 1; + + Center_Turn : Integer := 1; + + -- Type accesses to any procedure + type Action_Ptr is access procedure; + + -- Array of access to procedure + type Action_Array is array (Integer range <>) of Action_Ptr; + + + procedure Rotate_Left is + begin + Left_Turn := 2; + end Rotate_Left; + + + procedure Rotate_Right is + begin + Right_Turn := 3; + end Rotate_Right; + + + procedure Center is + begin + Center_Turn := 0; + end Center; + + + begin + + Report.Test ("C3A0004", "Check that access to subprogram may be " + & "stored within data structures, and that the " + & "access to subprogram can subsequently be called"); + + ------------------------------------------------------------------------ + + declare + Total_Actions : constant := 3; + Action_Sequence : Action_Array (1 .. Total_Actions); + + begin + + -- Build the action sequence + Action_Sequence := (Rotate_Left'Access, Center'Access, + Rotate_Right'Access); + + -- Assign actions by invoking subprogram designated by access value + for I in Action_Sequence'Range loop + Action_Sequence(I).all; + end loop; + + If Left_Turn /= 2 or Right_Turn /= 3 + or Center_Turn /= 0 then + Report.Failed ("Incorrect Action sequence result"); + end if; + + end; + + ------------------------------------------------------------------------ + + Report.Result; + + end C3A0004; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0005.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C3A0005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that access to subprogram may be stored within record + -- objects, and that the access to subprogram can subsequently + -- be called. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare two different procedures that can be referred to by the + -- access to procedure type. Declare a record with the access to + -- procedure type as a component. Use the access to procedure type to + -- initialize the component of a record. + -- + -- In the main program, declare an operation. An access value + -- designating this operation is passed as a parameter to be + -- stored in the record. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A0005_0 is + + Default_Call : Boolean := False; + + type Button; + + + -- Type accesses to procedures Push and Default_Response + type Button_Response_Ptr is access procedure + (B : access Button); + + procedure Push (B : access Button); + + procedure Set_Response (B : access Button; + R : in Button_Response_Ptr); + + procedure Default_Response (B : access Button); + + Emergency_Call : Boolean := False; + + procedure Emergency (B : access C3A0005_0.Button); + + type Button is + record + Response : Button_Response_Ptr + := Default_Response'Access; + end record; + + end C3A0005_0; + + + ----------------------------------------------------------------------------- + + with TCTouch; + package body C3A0005_0 is + + procedure Push (B : access Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Response (B); + end Push; + + + procedure Set_Response (B : access Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Response := R; + end Set_Response; + + + procedure Default_Response (B : access Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + Default_Call := True; + end Default_Response; + + + procedure Emergency (B : access C3A0005_0.Button) is + begin + TCTouch.Touch( 'E' ); --------------------------------------------- E + Emergency_Call := True; + end Emergency; + + end C3A0005_0; + + + ----------------------------------------------------------------------------- + + with TCTouch; + with Report; + + with C3A0005_0; + + procedure C3A0005 is + + Big_Red_Button : aliased C3A0005_0.Button; + + begin + + Report.Test ("C3A0005", "Check that access to subprogram may be " + & "stored within data structures, and that the " + & "access to subprogram can subsequently be called"); + + C3A0005_0.Push (Big_Red_Button'Access); + TCTouch.Validate("PD", "Using default value"); + TCTouch.Assert( C3A0005_0.Default_Call, "Default Call" ); + + -- set Emergency value in Button.Response + C3A0005_0.Set_Response(Big_Red_Button'Access, C3A0005_0.Emergency'Access); + + C3A0005_0.Push (Big_Red_Button'Access); + TCTouch.Validate("SPE", "After set to Emergency value"); + TCTouch.Assert( C3A0005_0.Emergency_Call, "Emergency Call"); + + Report.Result; + + end C3A0005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0006.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C3A0006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that access to subprogram may be stored within data + -- structures, and that the access to subprogram can subsequently + -- be called. + -- + -- TEST DESCRIPTION: + -- Declare an access to function type in a package specification. + -- Declare an array of the access type. Declare three different + -- functions that can be referred to by the access to function type. + -- + -- In the main program, declare a key function that builds the array + -- by calling each function indirectly through the access value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package C3A0006_0 is + + TC_Sine_Call : Integer := 0; + TC_Cos_Call : Integer := 0; + TC_Tan_Call : Integer := 0; + + Sine_Value : Float := 4.0; + Cos_Value : Float := 8.0; + Tan_Value : Float := 10.0; + + -- Type accesses to any function + type Trig_Function_Ptr is access function + (Angle : in Float) return Float; + + function Sine (Angle : in Float) return Float; + + function Cos (Angle : in Float) return Float; + + function Tan (Angle : in Float) return Float; + + end C3A0006_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0006_0 is + + function Sine (Angle : in Float) return Float is + begin + TC_Sine_Call := TC_Sine_Call + 1; + Sine_Value := Sine_Value + Angle; + return Sine_Value; + end Sine; + + + function Cos (Angle: in Float) return Float is + begin + TC_Cos_Call := TC_Cos_Call + 1; + Cos_Value := Cos_Value - Angle; + return Cos_Value; + end Cos; + + + function Tan (Angle : in Float) return Float is + begin + TC_Tan_Call := TC_Tan_Call + 1; + Tan_Value := (Tan_Value + (Tan_Value * Angle)); + return Tan_Value; + end Tan; + + + end C3A0006_0; + + ----------------------------------------------------------------------------- + + + with Report; + + with C3A0006_0; + + procedure C3A0006 is + + Trig_Value, Theta : Float := 0.0; + + Total_Routines : constant := 3; + + Sine_Total : constant := 7.0; + Cos_Total : constant := 5.0; + Tan_Total : constant := 75.0; + + Trig_Table : array (1 .. Total_Routines) of C3A0006_0.Trig_Function_Ptr; + + + -- Key function to build the table + function Call_Trig_Func (Func : C3A0006_0.Trig_Function_Ptr; + Operand : Float) return Float is + begin + return (Func(Operand)); + end Call_Trig_Func; + + + begin + + Report.Test ("C3A0006", "Check that access to subprogram may be " & + "stored within data structures, and that the access " & + "to subprogram can subsequently be called"); + + Trig_Table := (C3A0006_0.Sine'Access, C3A0006_0.Cos'Access, + C3A0006_0.Tan'Access); + + -- increase the value of Theta to build the table + for I in 1 .. Total_Routines loop + Theta := Theta + 0.5; + for J in 1 .. Total_Routines loop + Trig_Value := Call_Trig_Func (Trig_Table(J), Theta); + end loop; + end loop; + + if C3A0006_0.TC_Sine_Call /= Total_Routines + or C3A0006_0.TC_Cos_Call /= Total_Routines + or C3A0006_0.TC_Tan_Call /= Total_Routines then + Report.Failed ("Incorrect subprograms result"); + end if; + + if C3A0006_0.Sine_Value /= Sine_Total + or C3A0006_0.Cos_Value /= Cos_Total + or C3A0006_0.Tan_Value /= Tan_Total then + Report.Failed ("Incorrect values returned from subprograms"); + end if; + + if Trig_Value /= Tan_Total then + Report.Failed ("Incorrect call order."); + end if; + + Report.Result; + + end C3A0006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0007.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C3A0007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a call to a subprogram via an access-to-subprogram value + -- stored in a data structure will correctly dispatch according to the + -- tag of the class-wide parameter passed via that call. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare a root tagged type with the access to procedure type as a + -- component. Declare three primitive procedures for the type that + -- can be referred to by the access to procedure type. Use the access + -- to procedure type to initialize the component of a record. + -- + -- Extend the root type with a record extension in another package + -- specification. Declare a new primitive procedure for the extension + -- (in addition to its three inherited subprograms). + -- + -- In the main program, declare an operation for the root tagged type + -- which can be passed as an access value to change the initial value + -- of the component. Call the inherited operation indirectly by + -- dereferencing the access value to check on the initial value of the + -- extension. Call inherited operations indirectly by dereferencing + -- the access value to replace the initial value. Call the primitive + -- procedure indirectly by dereferencing the access value to modify the + -- extension. + -- + -- type Button + -- procedure Push(Button) + -- procedure Set_Response(Button,Button_Response_Ptr) + -- procedure Default_Response(Button) + -- + -- type Priority_Button (new Button) + -- procedures Push, Set_Response inherited + -- procedure Default_Response + -- procedure Set_Priority + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A0007_0 is + + Default_Call : Boolean := False; + + type Button is tagged private; + + type Button_Response_Ptr is access procedure + (B : in out Button'Class); + + procedure Push (B : in out Button); -- to be inherited + + procedure Set_Response (B : in out Button; -- to be inherited + R : in Button_Response_Ptr); + + procedure Response (B : in out Button); -- to be inherited + + private + procedure Default_Response(B: in out Button'Class); + type Button is tagged -- root tagged type + record + Action : Button_Response_Ptr + := Default_Response'Access; + end record; + end C3A0007_0; + + with C3A0007_0; + package C3A0007_1 is + + type Priority_Button is new C3A0007_0.Button + with record + Priority : Integer := 0; + end record; + + -- Inherits procedure Push from Button + -- Inherits procedure Set_Response from Button + + -- Override procedure Response from Button + procedure Response (B : in out Priority_Button); + + -- Primitive operation of the extension + procedure Set_Priority (B : in out Priority_Button); + + end C3A0007_1; + + with C3A0007_0; + package C3A0007_2 is + + Emergency_Call : Boolean := False; + + procedure Emergency (B : in out C3A0007_0.Button'Class); + end C3A0007_2; + + ----------------------------------------------------------------------------- + + with TCTouch; + package body C3A0007_0 is + + procedure Push (B : in out Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Action (B); + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Action := R; + end Set_Response; + + + procedure Response (B : in out Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + Default_Call := True; + end Response; + + procedure Default_Response (B : in out Button'Class) is + begin + TCTouch.Touch( 'C' ); --------------------------------------------- C + Response(B); + end Default_Response; + + end C3A0007_0; + + with TCTouch; + package body C3A0007_1 is + + procedure Set_Priority (B : in out Priority_Button) is + begin + TCTouch.Touch( 's' ); --------------------------------------------- s + B.Priority := 1; + end Set_Priority; + + procedure Response (B : in out Priority_Button) is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + end Response; + + end C3A0007_1; + + with TCTouch; + package body C3A0007_2 is + procedure Emergency (B : in out C3A0007_0.Button'Class) is + begin + TCTouch.Touch( 'E' ); ------------------------------------------- E + Emergency_Call := True; + end Emergency; + end C3A0007_2; + + ----------------------------------------------------------------------------- + + with Report; + with TCTouch; + + with C3A0007_0; + with C3A0007_1; + with C3A0007_2; + procedure C3A0007 is + + Pink_Button : C3A0007_0.Button; + Green_Button : C3A0007_1.Priority_Button; + + begin + + Report.Test ("C3A0007", "Check that a call to a subprogram via an " + & "access-to-subprogram value stored in a data " + & "structure will correctly dispatch according to " + & "the tag of the class-wide parameter passed " + & "via that call" ); + + -- Call inherited operation Push to set Default_Response value + -- in the extension. + + C3A0007_1.Push (Green_Button); + TCTouch.Validate("PCd", "First Green Button Push"); + + TCTouch.Assert_Not(C3A0007_0.Default_Call, + "Incorrect Green Default_Response"); + + C3A0007_0.Push (Pink_Button); + TCTouch.Validate("PCD", "First Pink Button Push"); + + -- Call inherited operations Set_Response and Push to set + -- Emergency value in the extension. + C3A0007_1.Set_Response (Green_Button, C3A0007_2.Emergency'Access); + C3A0007_1.Push (Green_Button); + TCTouch.Validate("SPE", "Second Green Button Push"); + + TCTouch.Assert(C3A0007_2.Emergency_Call, "Incorrect Green Emergency"); + + C3A0007_0.Set_Response (Pink_Button, C3A0007_2.Emergency'Access); + C3A0007_0.Push (Pink_Button); + TCTouch.Validate("SPE", "Second Pink Button Push"); + + -- Call primitive operation to set priority value + -- in the extension. + C3A0007_1.Set_Priority (Green_Button); + TCTouch.Validate("s", "Green Button Priority"); + + TCTouch.Assert(Green_Button.Priority = 1, "Incorrect Set_Priority"); + + Report.Result; + + end C3A0007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0008.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C3A0008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprogram references may be passed as parameters using + -- access-to-subprogram types. Check that the passed subprograms may + -- be invoked from within the called subprogram. + -- + -- TEST DESCRIPTION: + -- Declare an access to function type in a package specification. + -- Declare three different trig functions that can be referred to by + -- the access to function type. + -- + -- In the main program, call each function indirectly by passing the + -- access to subprogram value as parameter. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package Integrate_Lookup is + + TC_Log_Call : Boolean := False; + + TC_Cos_Call : Boolean := False; + + TC_Sine_Call : Boolean := False; + + -- Type accesses to functions Log, Sine, or Cos + type Integrand_Ptr is access function + (Angle : Float) return Float; + + function Log (Angle : in Float) return Float; + + function Sine (Angle : in Float) return Float; + + function Cos (Angle : in Float) return Float; + + function Integrate (Func : Integrand_Ptr; From, To: Float) + return Float; + + end Integrate_Lookup; + + + ----------------------------------------------------------------------------- + + + package body Integrate_Lookup is + + + function Log (Angle : in Float) return Float is + begin + TC_Log_Call := True; + return 0.1; + end Log; + + + function Sine (Angle : in Float) return Float is + begin + TC_Sine_Call := True; + return 0.0; + end Sine; + + + function Cos (Angle : in Float) return Float is + begin + TC_Cos_Call := True; + return 1.0; + end Cos; + + + function Integrate (Func : Integrand_Ptr; From, To: Float) + return Float is + Theta : Float; + begin + -- calls the actual subprogram passed as parameter + Theta := Func (From) + Func (To); + return Theta; + end Integrate; + + end Integrate_Lookup; + + + ----------------------------------------------------------------------------- + + + with Report; + + with Integrate_Lookup; + + procedure C3A0008 is + + Area : Float := 0.0; + + begin + + Report.Test ("C3A0008", "Check that subprogram references may be passed " + & "as parameters using access-to-subprogram types. " + & "Check that the passed subprograms may be invoked " + & "from within the called subprogram"); + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Log'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Log_Call or Area /= 0.2 then + Report.Failed ("Incorrect Log result"); + end if; + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Sine'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Sine_Call or Area /= 0.0 then + Report.Failed ("Incorrect Sine result"); + end if; + + Area := Integrate_Lookup.Integrate + (Integrate_Lookup.Cos'Access, 1.0, 2.0); + + If not Integrate_Lookup.TC_Cos_Call or Area /= 2.0 then + Report.Failed ("Incorrect Cos result"); + end if; + + Report.Result; + + end C3A0008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0009.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,219 ---- + -- C3A0009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprogram references may be passed as parameters using + -- access-to-subprogram types. Check that the passed subprograms may + -- be invoked from within the called subprogram. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a package specification. + -- Declare a root tagged type with the access to procedure type as a + -- component. Declare three primitive procedures for the type that + -- can be referred to by the access to procedure type. Use the access + -- to procedure type to initialize the component of a record. + -- + -- Extend the root type with a private extension in the same package + -- specification. Declare two new primitive subprograms for the extension + -- (in addition to its three inherited subprograms). + -- + -- In the main program, declare an operation for the root tagged type + -- which can be passed as an access value to change the initial value + -- of the component. Call the inherited operations indirectly by + -- de-referencing the access value to set value in the extension. + -- Call the primitive function to modify the extension by passing + -- the access value designating the primitive procedure as a parameter. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A0009_0 is -- Push_Buttons + + type Button is tagged private; + + -- Type accesses to procedures Push and Default_Response + type Button_Response_Ptr is access procedure + (B : in out Button); + + procedure Push (B : in out Button); -- to be inherited + + procedure Set_Response (B : in out Button; -- to be inherited + R : in Button_Response_Ptr); + + procedure Default_Response (B : in out Button); -- to be inherited + + type Alert_Button is new Button with private; -- private extension of + -- root tagged type + -- Inherits procedure Push from Button + -- Inherits procedure Set_Response from Button + -- Inherits procedure Default_Response from Button + + procedure Replace_Action( B: in out Alert_Button ); + + -- type accesses to procedure Default_Action + type Button_Action_Ptr is access procedure; + + -- The following function is needed to set value in the + -- extension's private component. + function Alert (B : in Alert_Button) return Button_Action_Ptr; + + private + + type Button is tagged -- root tagged type + record + Response : Button_Response_Ptr + := Default_Response'Access; + end record; + + procedure Default_Action; + + type Alert_Button is new Button with record + Action : Button_Action_Ptr + := Default_Action'Access; + end record; + + end C3A0009_0; + + + ----------------------------------------------------------------------------- + + + with TCTouch; + package body C3A0009_0 is + + procedure Push (B : in out Button) is + begin + TCTouch.Touch( 'P' ); --------------------------------------------- P + -- Invoking subprogram designated by access value + B.Response (B); + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + TCTouch.Touch( 'S' ); --------------------------------------------- S + -- Set procedure value in record + B.Response := R; + end Set_Response; + + + procedure Default_Response (B : in out Button) is + begin + TCTouch.Touch( 'D' ); --------------------------------------------- D + end Default_Response; + + + procedure Default_Action is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + end Default_Action; + + procedure Replacement_Action is + begin + TCTouch.Touch( 'r' ); --------------------------------------------- r + end Replacement_Action; + + procedure Replace_Action( B: in out Alert_Button ) is + begin + TCTouch.Touch( 'R' ); --------------------------------------------- R + B.Action := Replacement_Action'Access; + end Replace_Action; + + function Alert (B : in Alert_Button) return Button_Action_Ptr is + begin + TCTouch.Touch( 'A' ); --------------------------------------------- A + return (B.Action); + end Alert; + + end C3A0009_0; + + ----------------------------------------------------------------------------- + + with C3A0009_0; + package C3A0009_1 is -- Emergency_Items + package Push_Buttons renames C3A0009_0; + + procedure Emergency (B : in out Push_Buttons.Button); + end C3A0009_1; + + with TCTouch; + package body C3A0009_1 is -- Emergency_Items + procedure Emergency (B : in out Push_Buttons.Button) is + begin + TCTouch.Touch( 'E' ); ------------------------------------------- E + end Emergency; + end C3A0009_1; + ----------------------------------------------------------------------------- + + with Report; + + with C3A0009_0, C3A0009_1; + with TCTouch; + procedure C3A0009 is + + package Push_Buttons renames C3A0009_0; + package Emergency_Items renames C3A0009_1; + + Black_Button : Push_Buttons.Alert_Button; + Alert_Ptr : Push_Buttons.Button_Action_Ptr; + + begin + + Report.Test ("C3A0009", "Check that subprogram references may be passed " + & "as parameters using access-to-subprogram types. " + & "Check that the passed subprograms may be " + & "invoked from within the called subprogram"); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "PDAd", "Default operation set" ); + + -- Call inherited operations Set_Response and Push to set + -- Emergency value in the extension. + Push_Buttons.Set_Response (Black_Button, Emergency_Items.Emergency'Access); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "SPEAd", "Altered Response set" ); + + -- Call primitive operation to set action value in the extension. + Push_Buttons.Replace_Action( Black_Button ); + + + Push_Buttons.Push( Black_Button ); + Push_Buttons.Alert( Black_Button ).all; + + TCTouch.Validate( "RPEAr", "Altered Action set" ); + + Report.Result; + end C3A0009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0010.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C3A0010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an access-to-subprogram type in a generic instance may be + -- used to declare access-to-subprogram objects which invoke subprograms + -- in the instance. + -- + -- TEST DESCRIPTION: + -- Declare a numeric type in the visible part of a generic package. + -- Declare two different math procedures that can be referred to by + -- the access to procedure type. + -- + -- In the main program, instantiate the generic. Declare an access + -- to procedure type. Call each procedure indirectly by dereferencing + -- the access value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 05 APR 96 SAIC Header correction for 2.1 + -- + --! + + generic + type Real_Num is digits <>; + + package C3A0010_0 is + + -- Type accesses to any math procedure + type Math_Procedure_Ptr is access procedure + (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + + procedure Add (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + + procedure Subtract (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num); + + end C3A0010_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0010_0 is + + procedure Add (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num) is + begin + Result_Num := First_Num + Second_Num; + end Add; + + + procedure Subtract (First_Num, Second_Num : in Real_Num; + Result_Num : out Real_Num) is + begin + Result_Num := First_Num - Second_Num; + end Subtract; + + end C3A0010_0; + + ----------------------------------------------------------------------------- + + with Report; + with C3A0010_0; + + procedure C3A0010 is + + type Real is digits 2; + + subtype Math_Float is Real range -10.0 .. 10.0; + + package Math_Pk is new C3A0010_0 (Real_Num => Math_Float); + + Math_Access : Math_Pk.Math_Procedure_Ptr; + + Total_Num : Math_Float := 0.0; + First_Num : Math_Float := 1.0; + Second_Num : Math_Float := 2.0; + + procedure Max( A_Num, B_Num: in Math_Float; Result : out Math_Float ) is + begin + if A_Num > B_Num then + Result := A_Num; + else + Result := B_Num; + end if; + end Max; + + procedure Due_Process( Process: Math_Pk.Math_Procedure_Ptr ) is + begin + Process(First_Num, Second_Num, Total_Num); + end Due_Process; + + begin + + Report.Test ("C3A0010", "Check that an access-to-subprogram type in a " + & "generic instance may be used to declare " + & "access-to-subprogram objects which invoke " + & "subprograms in the instance"); + + -- Check for correct defaulting + if Math_Pk."/="( Math_Access, null) then + Report.Failed("subprogram access type object not initialized to null"); + end if; + + Math_Access := Math_Pk.Add'Access; + + -- Invoking Add procedure designated by access value + Due_Process( Math_Access ); + + If Total_Num /= 3.0 then + Report.Failed ("Incorrect Add result"); + end if; + + Math_Access := Math_Pk.Subtract'Access; + + Due_Process( Math_Access ); + + If Total_Num /= -1.0 then + Report.Failed ("Incorrect Subtract result"); + end if; + + Math_Access := Max'Access; + + Due_Process( Math_Access ); + + If Total_Num /= 2.0 then + Report.Failed ("Incorrect Max result"); + end if; + + Report.Result; + + end C3A0010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0011.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- C3A0011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an access-to-subprogram object whose type is declared in a + -- parent package, may be used to invoke subprograms in a child package. + -- Check that such access objects may be stored in a data structure and + -- that subprograms may be called by walking the data structure. + -- + -- TEST DESCRIPTION: + -- In the package, declare an access to procedure type. Declare an + -- array of the access type. Declare three different procedures that + -- can be referred to by the access to procedure type. + -- + -- In the visible child package, declare two procedures that can be + -- referred to by the access to procedure type of the parent. Build + -- the array by calling each procedure indirectly through the access + -- value. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Dec 94 SAIC Improved visibility of "/=" in main body + -- + --! + + package C3A0011_0 is -- Interpreter + + type Compass_Point is mod 360; + + function Heading return Compass_Point; + + -- Type accesses to any procedure + type Action_Ptr is access procedure; + + -- Array of access to procedure + type Action_Array is array (Natural range <>) of Action_Ptr; + + procedure Rotate_Left; + + procedure Rotate_Right; + + procedure Center; + + private + The_Heading : Compass_Point := Compass_Point'First; + + end C3A0011_0; + + + ----------------------------------------------------------------------------- + + + package body C3A0011_0 is + + function Heading return Compass_Point is + begin + return The_Heading; + end Heading; + + procedure Rotate_Left is + begin + The_Heading := The_Heading - 90; + end Rotate_Left; + + + procedure Rotate_Right is + begin + The_Heading := The_Heading + 90; + end Rotate_Right; + + + procedure Center is + begin + The_Heading := 0; + end Center; + + end C3A0011_0; + + + ----------------------------------------------------------------------------- + + + package C3A0011_0.Action is + + procedure Rotate_Front; + + procedure Rotate_Back; + + end C3A0011_0.Action; + + + ----------------------------------------------------------------------------- + + + package body C3A0011_0.Action is + + procedure Rotate_Front is + begin + The_Heading := The_Heading + 5; + end Rotate_Front; + + + procedure Rotate_Back is + begin + The_Heading := The_Heading - 5; + end Rotate_Back; + + end C3A0011_0.Action; + + + ----------------------------------------------------------------------------- + + + with C3A0011_0.Action; + + with Report; + + procedure C3A0011 is + + Total_Actions : constant := 6; + + Action_Sequence : C3A0011_0.Action_Array (1 .. Total_Actions); + + type Result_Array is array (Natural range <>) of C3A0011_0.Compass_Point; + + Action_Results : Result_Array(1 .. Total_Actions); + + package IA renames C3A0011_0.Action; + + begin + + Report.Test ("C3A0011", "Check that an access-to-subprogram object whose " + & "type is declared in a parent package, may be " + & "used to invoke subprograms in a child package. " + & "Check that such access objects may be stored in " + & "a data structure and that subprograms may be " + & "called by walking the data structure"); + + -- Build the action sequence + Action_Sequence := (C3A0011_0.Rotate_Left'Access, + C3A0011_0.Center'Access, + C3A0011_0.Rotate_Right'Access, + IA.Rotate_Front'Access, + C3A0011_0.Center'Access, + IA.Rotate_Back'Access); + + -- Build the expected result + Action_Results := ( 270, 0, 90, 95, 0, 355 ); + + -- Assign actions by invoking subprogram designated by access value + for I in Action_Sequence'Range loop + Action_Sequence(I).all; + if C3A0011_0."/="( C3A0011_0.Heading, Action_Results(I) ) then + Report.Failed ("Expecting " + & C3A0011_0.Compass_Point'Image(Action_Results(I)) + & " Got" + & C3A0011_0.Compass_Point'Image(C3A0011_0.Heading)); + end if; + end loop; + + Report.Result; + + end C3A0011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00120.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00120.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00120.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00120.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C3A00120.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See file C3A00122.AM + -- + -- TEST DESCRIPTION: + -- See file C3A00122.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- => C3A00120.A + -- C3A00121.A + -- C3A00122.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A0012_0 is + + type Call_Kind is (No_Call_Made, Fast_Call, Accurate_Call, + Table_Lookup_Call); + + Log_Result : Float := 0.0; + + -- Type accesses to any log procedure + type Log_Procedure_Ptr is access procedure + (Angle : in Float; Log_Call : out Call_Kind); + + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind); + + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind); + + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind); + + end C3A0012_0; + + + --=======================================================================-- + + + package body C3A0012_0 is + + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind) is separate; + + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind) is separate; + + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind) is separate; + + end C3A0012_0; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00121.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00121.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00121.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00121.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- C3A00121.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See file C3A00122.AM + -- + -- TEST DESCRIPTION: + -- See file C3A00122.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- C3A00120.A + -- => C3A00121.A + -- C3A00122.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + Separate (C3A0012_0) + procedure Log_Calc_Fast (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Fast_Call; + end Log_Calc_Fast; + + + --=======================================================================-- + + + Separate (C3A0012_0) + procedure Log_Calc_Acc (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Accurate_Call; + end Log_Calc_Acc; + + + --=======================================================================-- + + + Separate (C3A0012_0) + procedure Log_Calc_Table (Angle : in Float; + Method : out Call_Kind) is + begin + C3A0012_0.Log_Result := Angle; + Method := Table_Lookup_Call; + end Log_Calc_Table; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00122.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00122.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a00122.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a00122.am 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C3A00122.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an access-to-subprogram object can be used to invoke a + -- subprogram when the subprogram body had been declared and implemented + -- as a subunit. + -- + -- TEST DESCRIPTION: + -- Declare an access to procedure type in a main program. Declare + -- three different log subprogram body stubs that can be referred to by + -- the access to procedure type. + -- + -- Complete bodies of the log procedures. + -- + -- In the main program, each procedure will be called indirectly by + -- dereferencing the access value. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- C3A00120.A + -- C3A00121.A + -- => C3A00122.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + + with C3A0012_0; + + procedure C3A00122 is + + function "="( A,B: C3A0012_0.Call_Kind ) return Boolean + renames C3A0012_0."="; + + Log_Access : C3A0012_0.Log_Procedure_Ptr; + Theta : Float := 0.0; + Method : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made; + + + + function Due_Process( LA: C3A0012_0.Log_Procedure_Ptr ) + return C3A0012_0.Call_Kind is + Result : C3A0012_0.Call_Kind := C3A0012_0.No_Call_Made; + begin + LA( Theta, Result ); + return Result; + end Due_Process; + + begin + + Report.Test ("C3A0012", "Check that an access to a subprogram object " & + "can be used to select and invoke an operation with " & + "appropriate arguments"); + + Log_Access := C3A0012_0.Log_Calc_Fast'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Fast_Call then + Report.Failed ("Incorrect Log_Calc_Fast result"); + end if; + + Log_Access := C3A0012_0.Log_Calc_Acc'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Accurate_Call then + Report.Failed ("Incorrect Log_Calc_Acc result"); + end if; + + Log_Access := C3A0012_0.Log_Calc_Table'Access; + + -- Invoking Log procedure designated by access value + Method := Due_Process( Log_Access ); + + If Method /= C3A0012_0.Table_Lookup_Call then + Report.Failed ("Incorrect Log_Calc_Table result"); + end if; + + Report.Result; + + end C3A00122; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0013.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,347 ---- + -- C3A0013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a general access type object may reference allocated + -- pool objects as well as aliased objects. (3,4) + -- Check that formal parameters of tagged types are implicitly + -- defined as aliased; check that the 'Access of these formal + -- parameters designates the correct object with the correct + -- tag. (5) + -- Check that the current instance of a limited type is defined as + -- aliased. (5) + -- + -- TEST DESCRIPTION: + -- This test takes from the hierarchy defined in C390003; making + -- the root type Vehicle limited private. It also shifts the + -- abstraction to include the notion of a transmission, an object + -- which is contained within any vehicle. Using an access + -- discriminant, any subprogram which operates on a transmission + -- may also reference the vehicle in which it is installed. + -- + -- Class Hierarchy: + -- Vehicle Transmission + -- / \ + -- Truck Car + -- + -- Contains: + -- Vehicle( Transmission ) + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Dec 94 SAIC Fixed accessibility problems + -- + --! + + package C3A0013_1 is + type Vehicle is tagged limited private; + type Vehicle_ID is access all Vehicle'Class; + + -- Constructors + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ); + -- Modifiers + procedure Accelerate ( It : in out Vehicle ); + procedure Decelerate ( It : in out Vehicle ); + procedure Up_Shift ( It : in out Vehicle ); + procedure Stop ( It : in out Vehicle ); + + -- Selectors + function Speed ( It : Vehicle ) return Natural; + function Wheels ( It : Vehicle ) return Natural; + function Gear_Factor( It : Vehicle ) return Natural; + + -- TC_Ops + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ); + + -- dispatching procedure used to check tag correctness + procedure TC_Validate( It : Vehicle; + TC_ID : Character); + + private + + type Transmission(Within: access Vehicle'Class) is limited record + Engaged : Boolean := False; + Gear : Integer range -1..5 := 0; + end record; + + -- Current instance of a limited type is defined as aliased + + type Vehicle is tagged limited record + Wheels: Natural; + Speed : Natural; + Power_Train: Transmission( Vehicle'Access ); + end record; + end C3A0013_1; + + with C3A0013_1; + package C3A0013_2 is + type Car is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Car; + TC_ID : Character); + function Gear_Factor( It : Car ) return Natural; + private + type Car is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; + end C3A0013_2; + + with C3A0013_1; + package C3A0013_3 is + type Truck is new C3A0013_1.Vehicle with private; + procedure TC_Validate( It : Truck; + TC_ID : Character); + function Gear_Factor( It : Truck ) return Natural; + private + type Truck is new C3A0013_1.Vehicle with record + Displacement : Natural; + end record; + end C3A0013_3; + + with Report; + package body C3A0013_1 is + + procedure Create ( It : in out Vehicle; + Wheels : Natural := 4 ) is + begin + It.Wheels := Wheels; + It.Speed := 0; + end Create; + + procedure Accelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed + Gear_Factor( It.Power_Train.Within.all ); + end Accelerate; + + procedure Decelerate( It : in out Vehicle ) is + begin + It.Speed := It.Speed - Gear_Factor( It.Power_Train.Within.all ); + end Decelerate; + + procedure Stop ( It : in out Vehicle ) is + begin + It.Speed := 0; + It.Power_Train.Engaged := False; + end Stop; + + function Gear_Factor( It : Vehicle ) return Natural is + begin + return It.Power_Train.Gear; + end Gear_Factor; + + function Speed ( It : Vehicle ) return Natural is + begin + return It.Speed; + end Speed; + + function Wheels ( It : Vehicle ) return Natural is + begin + return It.Wheels; + end Wheels; + + -- formal tagged parameters are implicitly aliased + + procedure TC_Validate( It : in out Vehicle; Speed_Trap : Natural ) is + License: Vehicle_ID := It'Unchecked_Access; + begin + if Speed( License.all ) /= Speed_Trap then + Report.Failed("Speed Trap: expected: " & Natural'Image(Speed_Trap)); + end if; + end TC_Validate; + + procedure TC_Validate( It : Vehicle; + TC_ID : Character) is + begin + if TC_ID /= 'V' then + Report.Failed("Dispatched to Vehicle"); + end if; + if Wheels( It ) /= 1 then + Report.Failed("Not a Vehicle"); + end if; + end TC_Validate; + + procedure Up_Shift( It: in out Vehicle ) is + begin + It.Power_Train.Gear := It.Power_Train.Gear +1; + It.Power_Train.Engaged := True; + Accelerate( It ); + end Up_Shift; + end C3A0013_1; + + with Report; + package body C3A0013_2 is + + procedure TC_Validate( It : Car; + TC_ID : Character ) is + begin + if TC_ID /= 'C' then + Report.Failed("Dispatched to Car"); + end if; + if Wheels( It ) /= 4 then + Report.Failed("Not a Car"); + end if; + end TC_Validate; + + function Gear_Factor( It : Car ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*2; + end Gear_Factor; + + end C3A0013_2; + + with Report; + package body C3A0013_3 is + + procedure TC_Validate( It : Truck; + TC_ID : Character) is + begin + if TC_ID /= 'T' then + Report.Failed("Dispatched to Truck"); + end if; + if Wheels( It ) /= 3 then + Report.Failed("Not a Truck"); + end if; + end TC_Validate; + + function Gear_Factor( It : Truck ) return Natural is + begin + return C3A0013_1.Gear_Factor( C3A0013_1.Vehicle( It ) )*3; + end Gear_Factor; + + end C3A0013_3; + + package C3A0013_4 is + procedure Perform_Tests; + end C3A0013_4; + + with Report; + with C3A0013_1; + with C3A0013_2; + with C3A0013_3; + package body C3A0013_4 is + package Root renames C3A0013_1; + package Cars renames C3A0013_2; + package Trucks renames C3A0013_3; + + type Car_Pool is array(1..4) of aliased Cars.Car; + Commuters : Car_Pool; + + My_Car : aliased Cars.Car; + Company_Car : Root.Vehicle_ID; + Repair_Shop : Root.Vehicle_ID; + + The_Vehicle : Root.Vehicle; + The_Car : Cars.Car; + The_Truck : Trucks.Truck; + + procedure TC_Dispatch( Ptr : Root.Vehicle_ID; + Char : Character ) is + begin + Root.TC_Validate( Ptr.all, Char ); + end TC_Dispatch; + + procedure TC_Check_Formal_Access( Item: in out Root.Vehicle'Class; + Char: Character) is + begin + TC_Dispatch( Item'Unchecked_Access, Char ); + end TC_Check_Formal_Access; + + procedure Perform_Tests is + begin -- Main test procedure. + + for Lane in Commuters'Range loop + Cars.Create( Commuters(Lane) ); + for Excitement in 1..Lane loop + Cars.Up_Shift( Commuters(Lane) ); + end loop; + end loop; + + Cars.Create( My_Car ); + Cars.Up_Shift( My_Car ); + Cars.TC_Validate( My_Car, 2 ); + + Root.Create( The_Vehicle, 1 ); + Cars.Create( The_Car , 4 ); + Trucks.Create( The_Truck, 3 ); + + TC_Check_Formal_Access( The_Vehicle, 'V' ); + TC_Check_Formal_Access( The_Car, 'C' ); + TC_Check_Formal_Access( The_Truck, 'T' ); + + Root.Up_Shift( The_Vehicle ); + Cars.Up_Shift( The_Car ); + Trucks.Up_Shift( The_Truck ); + + Root.TC_Validate( The_Vehicle, 1 ); + Cars.TC_Validate( The_Car, 2 ); + Trucks.TC_Validate( The_Truck, 3 ); + + -- general access type may reference allocated objects + + Company_Car := new Cars.Car; + Root.Create( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.Up_Shift( Company_Car.all ); + Root.TC_Validate( Company_Car.all, 6 ); + + -- general access type may reference aliased objects + + Repair_Shop := My_Car'Access; + Root.TC_Validate( Repair_Shop.all, 2 ); + + -- general access type may reference aliased objects + + Construction: declare + type Speed_List is array(Commuters'Range) of Natural; + Accelerations : constant Speed_List := (2, 6, 12, 20); + begin + for Rotation in Commuters'Range loop + Repair_Shop := Commuters(Rotation)'Access; + Root.TC_Validate( Repair_Shop.all, Accelerations(Rotation) ); + end loop; + end Construction; + + end Perform_Tests; + + end C3A0013_4; + + with C3A0013_4; + with Report; + procedure C3A0013 is + begin + + Report.Test ("C3A0013", "Check general access types. Check aliased " + & "nature of formal tagged type parameters. " + & "Check aliased nature of the current " + & "instance of a limited type. Check the " + & "constraining of actual subtypes for " + & "discriminated objects" ); + + C3A0013_4.Perform_Tests; + + Report.Result; + end C3A0013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0014.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,453 ---- + -- C3A0014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the view defined by an object declaration is aliased, + -- and the type of the object has discriminants, then the object is + -- constrained by its initial value even if its nominal subtype is + -- unconstrained. + -- + -- Check that the attribute A'Constrained returns True if A is a formal + -- out or in out parameter, or dereference thereof, and A denotes an + -- aliased view of an object. + -- + -- TEST DESCRIPTION: + -- These rules apply to objects of a record type with defaulted + -- discriminants, which may be unconstrained variables. If such a + -- variable is declared to be aliased, then it is constrained by its + -- initial value, and the value of the discriminant cannot be changed + -- for the life of the variable. + -- + -- The rules do not apply to aliased component types because if such + -- types are discriminated they must be constrained. + -- + -- A'Constrained returns True if A denotes a constant, value, or + -- constrained variable. Since aliased objects are constrained, it must + -- return True if the actual parameter corresponding to a formal + -- parameter A is an aliased object. The objective only mentions formal + -- parameters of mode out and in out, since parameters of mode in are + -- by definition constant, and would result in True anyway. + -- + -- This test declares aliased objects of a nominally unconstrained + -- record subtype, both with and without initialization expressions. + -- It also declares access values which point to such objects. It then + -- checks that Constraint_Error is raised if an attempt is made to + -- change the discriminant value of an aliased object, either directly + -- or via a dereference of an access value. For aliased objects, this + -- check is also performed for subprogram parameters of mode out. + -- + -- The test also passes aliased objects and access values which point + -- to such objects as actuals to subprograms and verifies, for parameter + -- modes out and in out, that P'Constrained returns true if P is the + -- corresponding formal parameter or a dereference thereof. + -- + -- Additionally, the test declares a generic package which declares a + -- an aliased object of a formal derived unconstrained type, which is + -- is initialized with the value of a formal object of that type. + -- procedure declared within the generic assigns a value to the object + -- which has the same discriminant value as the formal derived type's + -- ancestor type. The generic is instantiated with various actuals + -- for the formal object, and the procedure is called. The test verifies + -- that Constraint_Error is raised if the discriminant values of the + -- actual corresponding to the formal object and the value assigned + -- by the procedure are not equal. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected numerous errors. + -- + --! + + package C3A0014_0 is + + subtype Reasonable is Integer range 1..10; + -- Unconstrained (sub)type. + type UC (D: Reasonable := 2) is record -- Discriminant default. + S: String (1 .. D) := "Hi"; -- Default value. + end record; + + type AUC is access all UC; + + -- Nominal subtype is unconstrained for the following: + + Obj0 : UC; -- An unconstrained object. + + Obj1 : UC := (5, "Hello"); -- Non-aliased with initialization, + -- an unconstrained object. + + Obj2 : aliased UC := (5, "Hello"); -- Aliased with initialization, + -- a constrained object. + + Obj3 : UC renames Obj2; -- Aliased (renaming of aliased view), + -- a constrained object. + Obj4 : aliased UC; -- Aliased without initialization, Obj4 + -- constrained here to initial value + -- taken from default for type. + + Ptr1 : AUC := new UC'(Obj1); + Ptr2 : AUC := new UC; + Ptr3 : AUC := Obj3'Access; + Ptr4 : AUC := Obj4'Access; + + + procedure NP_Proc (A: out UC); + procedure NP_Cons (A: in out UC; B: out Boolean); + procedure P_Cons (A: out AUC; B: out Boolean); + + + generic + type FT is new UC; + FObj : in out FT; + package Gen is + F : aliased FT := FObj; -- Constrained if FT has discriminants. + procedure Proc; + end Gen; + + + procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ); + + + end C3A0014_0; + + + --=======================================================================-- + + with Report; + + package body C3A0014_0 is + + procedure NP_Proc (A: out UC) is + begin + A := (3, "Bye"); + end NP_Proc; + + procedure NP_Cons (A: in out UC; B: out Boolean) is + begin + B := A'Constrained; + end NP_Cons; + + procedure P_Cons (A: out AUC; B: out Boolean) is + begin + B := A.all'Constrained; + end P_Cons; + + + package body Gen is + + procedure Proc is + begin + F := (2, "Fi"); + end Proc; + + end Gen; + + + procedure Avoid_Optimization_and_Fail ( P : UC; Msg : String ) is + Default : UC := (1, "!"); -- Unique value. + begin + if P = Default then -- Both If branches can't do the same thing. + Report.Failed (Msg & ": Constraint_Error not raised"); + else -- Subtests should always select this path. + Report.Failed ("Constraint_Error not raised " & Msg); + end if; + end Avoid_Optimization_and_Fail; + + + end C3A0014_0; + + + --=======================================================================-- + + + with C3A0014_0; use C3A0014_0; + with Report; + + procedure C3A0014 is + begin + + Report.Test("C3A0014", "Check that if the view defined by an object " & + "declaration is aliased, and the type of the " & + "object has discriminants, then the object is " & + "constrained by its initial value even if its " & + "nominal subtype is unconstrained. Check that " & + "the attribute A'Constrained returns True if A " & + "is a formal out or in out parameter, or " & + "dereference thereof, and A denotes an aliased " & + "view of an object"); + + Non_Pointer_Block: + begin + + begin + Obj0 := (3, "Bye"); -- OK: Obj0 not constrained. + if Obj0 /= (3, "Bye") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 1"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 1"); + end; + + + begin + Obj1 := (3, "Bye"); -- OK: Obj1 not constrained. + if Obj1 /= (3, "Bye") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 2"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 2"); + end; + + + begin + Obj2 := (3, "Bye"); -- C_E: Obj2 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj2, "Subtest 3"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Obj3 := (3, "Bye"); -- C_E: Obj3 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj3, "Subtest 4"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Obj4 := (3, "Bye"); -- C_E: Obj4 is constrained (D=>2). + Avoid_Optimization_and_Fail (Obj4, "Subtest 5"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + exception + when others => Report.Failed("Unexpected exception: Non_Pointer_Block"); + end Non_Pointer_Block; + + + Pointer_Block: + begin + + begin + Ptr1.all := (3, "Bye"); -- C_E: Ptr1.all is constrained (D=>5). + Avoid_Optimization_and_Fail (Ptr1.all, "Subtest 6"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr2.all := (3, "Bye"); -- C_E: Ptr2.all is constrained (D=>2). + Avoid_Optimization_and_Fail (Ptr2.all, "Subtest 7"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr3.all := (3, "Bye"); -- C_E: Ptr3.all is constrained (D=>5). + Avoid_Optimization_and_Fail (Ptr3.all, "Subtest 8"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Ptr4.all := (3, "Bye"); -- C_E: Ptr4.all is constrained (D=>2). + Avoid_Optimization_and_Fail (Ptr4.all, "Subtest 9"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + exception + when others => Report.Failed("Unexpected exception: Pointer_Block"); + end Pointer_Block; + + + Subprogram_Block: + declare + Is_Constrained : Boolean; + begin + + begin + NP_Proc (Obj0); -- OK: Obj0 not constrained, can + if Obj0 /= (3, "Bye") then -- change discriminant value. + Report.Failed + ("Wrong value after aggregate assignment - Subtest 10"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 10"); + end; + + + begin + NP_Proc (Obj2); -- C_E: Obj2 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj2, "Subtest 11"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + NP_Proc (Obj3); -- C_E: Obj3 is constrained (D=>5). + Avoid_Optimization_and_Fail (Obj3, "Subtest 12"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + NP_Proc (Obj4); -- C_E: Obj4 is constrained (D=>2). + Avoid_Optimization_and_Fail (Obj4, "Subtest 13"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + + begin + Is_Constrained := True; + NP_Cons (Obj1, Is_Constrained); -- Should return False, since Obj1 + if Is_Constrained then -- is not constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 14"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 14"); + end; + + + begin + Is_Constrained := False; + NP_Cons (Obj2, Is_Constrained); -- Should return True, Obj2 is + if not Is_Constrained then -- constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 15"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 15"); + end; + + + + + begin + Is_Constrained := False; + P_Cons (Ptr2, Is_Constrained); -- Should return True, Ptr2.all + if not Is_Constrained then -- is constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 16"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 16"); + end; + + + begin + Is_Constrained := False; + P_Cons (Ptr3, Is_Constrained); -- Should return True, Ptr3.all + if not Is_Constrained then -- is constrained. + Report.Failed ("Wrong result from 'Constrained - Subtest 17"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 17"); + end; + + + exception + when others => Report.Failed("Exception raised in Subprogram_Block"); + end Subprogram_Block; + + + Generic_Block: + declare + + type NUC is new UC; + + Obj : NUC; + + + package Instance_A is new Gen (NUC, Obj); + package Instance_B is new Gen (UC, Obj2); + package Instance_C is new Gen (UC, Obj3); + package Instance_D is new Gen (UC, Obj4); + + begin + + begin + Instance_A.Proc; -- OK: Obj.D = 2. + if Instance_A.F /= (2, "Fi") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 18"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 18"); + end; + + + begin + Instance_B.Proc; -- C_E: Obj2.D = 5. + Avoid_Optimization_and_Fail (Obj2, "Subtest 19"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Instance_C.Proc; -- C_E: Obj3.D = 5. + Avoid_Optimization_and_Fail (Obj3, "Subtest 20"); + exception + when Constraint_Error => null; -- Exception is expected. + end; + + + begin + Instance_D.Proc; -- OK: Obj4.D = 2. + if Instance_D.F /= (2, "Fi") then + Report.Failed + ("Wrong value after aggregate assignment - Subtest 21"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Subtest 21"); + end; + + exception + when others => Report.Failed("Exception raised in Generic_Block"); + end Generic_Block; + + + Report.Result; + + end C3A0014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a0015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a0015.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C3A0015.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a derived access type has the same storage pool as its + -- parent. (Defect Report 8652/0012, Technical Corrigendum 3.10(7/1)). + -- + -- CHANGE HISTORY: + -- 24 JAN 2001 PHL Initial version. + -- 29 JUN 2001 RLB Reformatted for ACATS. + -- + --! + with System.Storage_Elements; + use System.Storage_Elements; + with System.Storage_Pools; + use System.Storage_Pools; + package C3A0015_0 is + + type Pool (Storage_Size : Storage_Count) is new Root_Storage_Pool with + record + First_Free : Storage_Count := 1; + Contents : Storage_Array (1 .. Storage_Size); + end record; + + procedure Allocate (Pool : in out C3A0015_0.Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count); + + procedure Deallocate (Pool : in out C3A0015_0.Pool; + Storage_Address : in System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count); + + function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count; + + end C3A0015_0; + + package body C3A0015_0 is + + use System; + + procedure Allocate (Pool : in out C3A0015_0.Pool; + Storage_Address : out System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count) is + Unaligned_Address : constant System.Address := + Pool.Contents (Pool.First_Free)'Address; + Unalignment : Storage_Count; + begin + Unalignment := Unaligned_Address mod Alignment; + if Unalignment = 0 then + Storage_Address := Unaligned_Address; + Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements; + else + Storage_Address := + Pool.Contents (Pool.First_Free + Alignment - Unalignment)' + Address; + Pool.First_Free := Pool.First_Free + Size_In_Storage_Elements + + Alignment - Unalignment; + end if; + end Allocate; + + procedure Deallocate (Pool : in out C3A0015_0.Pool; + Storage_Address : in System.Address; + Size_In_Storage_Elements : in Storage_Count; + Alignment : in Storage_Count) is + begin + if Storage_Address + Size_In_Storage_Elements = + Pool.Contents (Pool.First_Free)'Address then + -- Only deallocate if the block is at the end. + Pool.First_Free := Pool.First_Free - Size_In_Storage_Elements; + end if; + end Deallocate; + + function Storage_Size (Pool : in C3A0015_0.Pool) return Storage_Count is + begin + return Pool.Storage_Size; + end Storage_Size; + + end C3A0015_0; + + with Ada.Exceptions; + use Ada.Exceptions; + with Ada.Unchecked_Deallocation; + with Report; + use Report; + with System.Storage_Elements; + use System.Storage_Elements; + with C3A0015_0; + procedure C3A0015 is + + type Standard_Pool is access Float; + type Derived_Standard_Pool is new Standard_Pool; + type Derived_Derived_Standard_Pool is new Derived_Standard_Pool; + + type User_Defined_Pool is access Integer; + type Derived_User_Defined_Pool is new User_Defined_Pool; + type Derived_Derived_User_Defined_Pool is new Derived_User_Defined_Pool; + + My_Pool : C3A0015_0.Pool (1024); + for User_Defined_Pool'Storage_Pool use My_Pool; + + generic + type Designated is private; + Value : Designated; + type Acc is access Designated; + type Derived_Acc is new Acc; + procedure Check (Subtest : String; User_Defined_Pool : Boolean); + + procedure Check (Subtest : String; User_Defined_Pool : Boolean) is + + procedure Deallocate is + new Ada.Unchecked_Deallocation (Object => Designated, + Name => Acc); + procedure Deallocate is + new Ada.Unchecked_Deallocation (Object => Designated, + Name => Derived_Acc); + + First_Free : Storage_Count; + X : Acc; + Y : Derived_Acc; + begin + if User_Defined_Pool then + First_Free := My_Pool.First_Free; + end if; + X := new Designated'(Value); + if User_Defined_Pool and then First_Free >= My_Pool.First_Free then + Failed (Subtest & + " - Allocation didn't consume storage in the pool - 1"); + else + First_Free := My_Pool.First_Free; + end if; + + Y := Derived_Acc (X); + if User_Defined_Pool and then First_Free /= My_Pool.First_Free then + Failed (Subtest & + " - Conversion did consume storage in the pool - 1"); + end if; + if Y.all /= Value then + Failed (Subtest & + " - Incorrect allocation/conversion of access values - 1"); + end if; + + Deallocate (Y); + if User_Defined_Pool and then First_Free <= My_Pool.First_Free then + Failed (Subtest & + " - Deallocation didn't release storage from the pool - 1"); + else + First_Free := My_Pool.First_Free; + end if; + + Y := new Designated'(Value); + if User_Defined_Pool and then First_Free >= My_Pool.First_Free then + Failed (Subtest & + " - Allocation didn't consume storage in the pool - 2"); + else + First_Free := My_Pool.First_Free; + end if; + + X := Acc (Y); + if User_Defined_Pool and then First_Free /= My_Pool.First_Free then + Failed (Subtest & + " - Conversion did consume storage in the pool - 2"); + end if; + if X.all /= Value then + Failed (Subtest & + " - Incorrect allocation/conversion of access values - 2"); + end if; + + Deallocate (X); + if User_Defined_Pool and then First_Free <= My_Pool.First_Free then + Failed (Subtest & + " - Deallocation didn't release storage from the pool - 2"); + end if; + exception + when E: others => + Failed (Subtest & " - Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E)); + end Check; + + + begin + Test ("C3A0015", "Check that a dervied access type has the same " & + "storage pool as its parent"); + + Comment ("Access types using the standard storage pool"); + + Std: + declare + procedure Check1 is + new Check (Designated => Float, + Value => 3.0, + Acc => Standard_Pool, + Derived_Acc => Derived_Standard_Pool); + procedure Check2 is + new Check (Designated => Float, + Value => 4.0, + Acc => Standard_Pool, + Derived_Acc => Derived_Derived_Standard_Pool); + procedure Check3 is + new Check (Designated => Float, + Value => 5.0, + Acc => Derived_Standard_Pool, + Derived_Acc => Derived_Derived_Standard_Pool); + begin + Check1 ("Standard_Pool/Derived_Standard_Pool", + User_Defined_Pool => False); + Check2 ("Standard_Pool/Derived_Derived_Standard_Pool", + User_Defined_Pool => False); + Check3 ("Derived_Standard_Pool/Derived_Derived_Standard_Pool", + User_Defined_Pool => False); + end Std; + + Comment ("Access types using a user-defined storage pool"); + + User: + declare + procedure Check1 is + new Check (Designated => Integer, + Value => 17, + Acc => User_Defined_Pool, + Derived_Acc => Derived_User_Defined_Pool); + procedure Check2 is + new Check (Designated => Integer, + Value => 18, + Acc => User_Defined_Pool, + Derived_Acc => Derived_Derived_User_Defined_Pool); + procedure Check3 is + new Check (Designated => Integer, + Value => 19, + Acc => Derived_User_Defined_Pool, + Derived_Acc => Derived_Derived_User_Defined_Pool); + begin + Check1 ("User_Defined_Pool/Derived_User_Defined_Pool", + User_Defined_Pool => True); + Check2 ("User_Defined_Pool/Derived_Derived_User_Defined_Pool", + User_Defined_Pool => True); + Check3 + ("Derived_User_Defined_Pool/Derived_Derived_User_Defined_Pool", + User_Defined_Pool => True); + end User; + + Result; + end C3A0015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a1001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a1001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a1001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a1001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,315 ---- + -- C3A1001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the full type completing a type with no discriminant part + -- or an unknown discriminant part may have explicitly declared or + -- inherited discriminants. + -- Check for cases where the types are records and protected types. + -- + -- TEST DESCRIPTION: + -- Declare two groups of incomplete types: one group with no discriminant + -- part and one group with unknown discriminant part. Both groups of + -- incomplete types are completed with both explicit and inherited + -- discriminants. Discriminants for record and protected types are + -- declared with default and non default values. + -- In the main program, verify that objects of both groups of incomplete + -- types can be created by default values or by assignments. + -- + -- + -- CHANGE HISTORY: + -- 11 Oct 95 SAIC Initial prerelease version. + -- 11 Nov 96 SAIC Revised for version 2.1. + -- + --! + + package C3A1001_0 is + + type Incomplete1 (<>); -- unknown discriminant + + type Incomplete2; -- no discriminant + + type Incomplete3 (<>); -- unknown discriminant + + type Incomplete4; -- no discriminant + + type Incomplete5 (<>); -- unknown discriminant + + type Incomplete6; -- no discriminant + + type Incomplete8; -- no discriminant + + subtype Small_Int is Integer range 1 .. 10; + + type Enu_Type is (M, F); + + type Incomplete1 (Disc : Enu_Type) is -- unknown discriminant/ + record -- explicit discriminant + case Disc is + when M => MInteger : Small_Int := 3; + when F => FInteger : Small_Int := 8; + end case; + end record; + + type Incomplete2 (Disc : Small_Int := 8) is -- no discriminant/ + record -- explicit discriminant + ID : String (1 .. Disc) := "Plymouth"; + end record; + + type Incomplete3 is new Incomplete2; -- unknown discriminant/ + -- inherited discriminant + + type Incomplete4 is new Incomplete2; -- no discriminant/ + -- inherited discriminant + + protected type Incomplete5 -- unknown discriminant/ + (Disc : Enu_Type) is -- explicit discriminant + function Get_Priv_Val return Enu_Type; + private + Enu_Obj : Enu_Type := Disc; + end Incomplete5; + + protected type Incomplete6 -- no discriminant/ + (Disc : Small_Int := 1) is -- explicit discriminant + function Get_Priv_Val return Small_Int; -- with default + private + Num : Small_Int := Disc; + end Incomplete6; + + type Incomplete8 (Disc : Small_Int) is -- no discriminant/ + record -- explicit discriminant + Str : String (1 .. Disc); -- no default + end record; + + type Incomplete9 is new Incomplete8; + + function Return_String (S : String) return String; + + end C3A1001_0; + + --==================================================================-- + + with Report; + + package body C3A1001_0 is + + protected body Incomplete5 is + + function Get_Priv_Val return Enu_Type is + begin + return Enu_Obj; + end Get_Priv_Val; + + end Incomplete5; + + ---------------------------------------------------------------------- + protected body Incomplete6 is + + function Get_Priv_Val return Small_Int is + begin + return Num; + end Get_Priv_Val; + + end Incomplete6; + + ---------------------------------------------------------------------- + function Return_String (S : String) return String is + begin + if Report.Ident_Bool(True) = True then + return S; + end if; + + return S; + end Return_String; + + end C3A1001_0; + + --==================================================================-- + + with Report; + + with C3A1001_0; + use C3A1001_0; + + procedure C3A1001 is + + -- Discriminant value comes from default. + + Incomplete2_Obj_1 : Incomplete2; + + Incomplete4_Obj_1 : Incomplete4; + + Incomplete6_Obj_1 : Incomplete6; + + -- Discriminant value comes from explicit constraint. + + Incomplete1_Obj_1 : Incomplete1 (F); + + Incomplete5_Obj_1 : Incomplete5 (M); + + Incomplete6_Obj_2 : Incomplete6 (2); + + -- Discriminant value comes from assignment. + + Incomplete3_Obj_1 : Incomplete3 := (Disc => 6, ID => "Sentra"); + + Incomplete1_Obj_2 : Incomplete1 := (Disc => M, MInteger => 9); + + Incomplete2_Obj_2 : Incomplete2 := (Disc => 5, ID => "Buick"); + + begin + + Report.Test ("C3A1001", "Check that the full type completing a type " & + "with no discriminant part or an unknown discriminant " & + "part may have explicitly declared or inherited " & + "discriminants. Check for cases where the types are " & + "records and protected types"); + + -- Check the initial values. + + if (Incomplete2_Obj_1.Disc /= 8) or + (Incomplete2_Obj_1.ID /= "Plymouth") then + Report.Failed ("Wrong initial values for Incomplete2_Obj_1"); + end if; + + if (Incomplete4_Obj_1.Disc /= 8) or + (Incomplete4_Obj_1.ID /= "Plymouth") then + Report.Failed ("Wrong initial values for Incomplete4_Obj_1"); + end if; + + if (Incomplete6_Obj_1.Disc /= 1) or + (Incomplete6_Obj_1.Get_Priv_Val /= 1) then + Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); + end if; + + -- Check the explicit values. + + if (Incomplete1_Obj_1.Disc /= F) or + (Incomplete1_Obj_1.FInteger /= 8) then + Report.Failed ("Wrong values for Incomplete1_Obj_1"); + end if; + + if (Incomplete5_Obj_1.Disc /= M) or + (Incomplete5_Obj_1.Get_Priv_Val /= M) then + Report.Failed ("Wrong value for Incomplete5_Obj_1"); + end if; + + if (Incomplete6_Obj_2.Disc /= 2) or + (Incomplete6_Obj_2.Get_Priv_Val /= 2) then + Report.Failed ("Wrong value for Incomplete6_Obj_2"); + end if; + + -- Check the assigned values. + + if (Incomplete3_Obj_1.Disc /= 6) or + (Incomplete3_Obj_1.ID /= "Sentra") then + Report.Failed ("Wrong values for Incomplete3_Obj_1"); + end if; + + if (Incomplete1_Obj_2.Disc /= M) or + (Incomplete1_Obj_2.MInteger /= 9) then + Report.Failed ("Wrong values for Incomplete1_Obj_2"); + end if; + + if (Incomplete2_Obj_2.Disc /= 5) or + (Incomplete2_Obj_2.ID /= "Buick") then + Report.Failed ("Wrong values for Incomplete2_Obj_2"); + end if; + + -- Make sure that assignments work without problems. + + Incomplete1_Obj_1.FInteger := 1; + + -- Avoid optimization (dead variable removal of FInteger): + + if Incomplete1_Obj_1.FInteger /= Report.Ident_Int(1) + then + Report.Failed ("Wrong value stored in Incomplete1_Obj_1.FInteger"); + end if; + + Incomplete2_Obj_1.ID := Return_String ("12345678"); + + -- Avoid optimization (dead variable removal of ID) + + if Incomplete2_Obj_1.ID /= Return_String ("12345678") + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.ID"); + end if; + + Incomplete4_Obj_1.ID := Return_String ("87654321"); + + -- Avoid optimization (dead variable removal of ID) + + if Incomplete4_Obj_1.ID /= Return_String ("87654321") + then + Report.Failed ("Wrong values for Incomplete4_Obj_1.ID"); + end if; + + + Test1: + declare + + Incomplete8_Obj_1 : Incomplete8 (10); + + begin + Incomplete8_Obj_1.Str := "Merry Xmas"; + + -- Avoid optimization (dead variable removal of Str): + + if Return_String (Incomplete8_Obj_1.Str) /= "Merry Xmas" + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Incomplete8_Obj_1"); + + end Test1; + + Test2: + declare + + Incomplete8_Obj_2 : Incomplete8 (5); + + begin + Incomplete8_Obj_2.Str := "Happy"; + + -- Avoid optimization (dead variable removal of Str): + + if Return_String (Incomplete8_Obj_2.Str) /= "Happy" + then + Report.Failed ("Wrong values for Incomplete8_Obj_1.Str"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Incomplete8_Obj_2"); + + end Test2; + + Report.Result; + + end C3A1001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a1002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a1002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a1002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a1002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,251 ---- + -- C3A1002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the full type completing a type with no discriminant part + -- or an unknown discriminant part may have explicitly declared or + -- inherited discriminants. + -- Check for cases where the types are tagged records and task types. + -- + -- TEST DESCRIPTION: + -- Declare two groups of incomplete types: one group with no discriminant + -- part and one group with unknown discriminant part. Both groups of + -- incomplete types are completed with both explicit and inherited + -- discriminants. Discriminants for task types are declared with both + -- default and non default values. Discriminants for tagged types are + -- only declared without default values. + -- In the main program, verify that objects of both groups of incomplete + -- types can be created by default values or by assignments. + -- + -- + -- CHANGE HISTORY: + -- 23 Oct 95 SAIC Initial prerelease version. + -- 19 Oct 96 SAIC ACVC 2.1: modified test description. Initialized + -- Int_Val. + -- + --! + + package C3A1002_0 is + + subtype Small_Int is Integer range 1 .. 15; + + type Enu_Type is (M, F); + + type Tag_Type is tagged + record + I : Small_Int := 1; + end record; + + type NTag_Type (D : Small_Int) is new Tag_Type with + record + S : String (1 .. D) := "Aloha"; + end record; + + type Incomplete1; -- no discriminant + + type Incomplete2 (<>); -- unknown discriminant + + type Incomplete3; -- no discriminant + + type Incomplete4 (<>); -- unknown discriminant + + type Incomplete5; -- no discriminant + + type Incomplete6 (<>); -- unknown discriminant + + type Incomplete1 (D1 : Enu_Type) is tagged -- no discriminant/ + record -- explicit discriminant + case D1 is + when M => MInteger : Small_Int := 9; + when F => FInteger : Small_Int := 8; + end case; + end record; + + type Incomplete2 (D2 : Small_Int) is new -- unknown discriminant/ + Incomplete1 (D1 => F) with record -- explicit discriminant + ID : String (1 .. D2) := "ACVC95"; + end record; + + type Incomplete3 is new -- no discriminant/ + NTag_Type with record -- inherited discriminant + E : Enu_Type := M; + end record; + + type Incomplete4 is new -- unknown discriminant/ + NTag_Type (D => 3) with record -- inherited discriminant + E : Enu_Type := F; + end record; + + task type Incomplete5 (D5 : Enu_Type) is -- no discriminant/ + entry Read_Disc (P : out Enu_Type); -- explicit discriminant + end Incomplete5; + + task type Incomplete6 + (D6 : Small_Int := 4) is -- unknown discriminant/ + entry Read_Int (P : out Small_Int); -- explicit discriminant + end Incomplete6; + + end C3A1002_0; + + --==================================================================-- + + package body C3A1002_0 is + + task body Incomplete5 is + begin + select + accept Read_Disc (P : out Enu_Type) do + P := D5; + end Read_Disc; + or + terminate; + end select; + + end Incomplete5; + + ---------------------------------------------------------------------- + task body Incomplete6 is + begin + select + accept Read_Int (P : out Small_Int) do + P := D6; + end Read_Int; + or + terminate; + end select; + + end Incomplete6; + + end C3A1002_0; + + --==================================================================-- + + with Report; + + with C3A1002_0; + use C3A1002_0; + + procedure C3A1002 is + + Enum_Val : Enu_Type := M; + + Int_Val : Small_Int := 15; + + -- Discriminant value comes from default. + + Incomplete6_Obj_1 : Incomplete6; + + -- Discriminant value comes from explicit constraint. + + Incomplete1_Obj_1 : Incomplete1 (M); + + Incomplete2_Obj_1 : Incomplete2 (6); + + Incomplete5_Obj_1 : Incomplete5 (F); + + Incomplete6_Obj_2 : Incomplete6 (7); + + -- Discriminant value comes from assignment. + + Incomplete1_Obj_2 : Incomplete1 + := (F, 12); + + Incomplete3_Obj_1 : Incomplete3 + := (D => 2, S => "Hi", I => 10, E => F); + + Incomplete4_Obj_1 : Incomplete4 + := (E => M, D => 3, S => "Bye", I => 14); + + begin + + Report.Test ("C3A1002", "Check that the full type completing a type " & + "with no discriminant part or an unknown discriminant " & + "part may have explicitly declared or inherited " & + "discriminants. Check for cases where the types are " & + "tagged records and task types"); + + -- Check the initial values. + + if (Incomplete6_Obj_1.D6 /= 4) then + Report.Failed ("Wrong initial value for Incomplete6_Obj_1"); + end if; + + -- Check the explicit values. + + if (Incomplete1_Obj_1.D1 /= M) or + (Incomplete1_Obj_1.MInteger /= 9) then + Report.Failed ("Wrong values for Incomplete1_Obj_1"); + end if; + + if (Incomplete2_Obj_1.D2 /= 6) or + (Incomplete2_Obj_1.FInteger /= 8) or + (Incomplete2_Obj_1.ID /= "ACVC95") then + Report.Failed ("Wrong values for Incomplete2_Obj_1"); + end if; + + if (Incomplete5_Obj_1.D5 /= F) then + Report.Failed ("Wrong value for Incomplete5_Obj_1"); + end if; + + Incomplete5_Obj_1.Read_Disc (Enum_Val); + + if (Enum_Val /= F) then + Report.Failed ("Wrong value for Enum_Val"); + end if; + + if (Incomplete6_Obj_2.D6 /= 7) then + Report.Failed ("Wrong value for Incomplete6_Obj_2"); + end if; + + Incomplete6_Obj_1.Read_Int (Int_Val); + + if (Int_Val /= 4) then + Report.Failed ("Wrong value for Int_Val"); + end if; + + -- Check the assigned values. + + if (Incomplete1_Obj_2.D1 /= F) or + (Incomplete1_Obj_2.FInteger /= 12) then + Report.Failed ("Wrong values for Incomplete1_Obj_2"); + end if; + + if (Incomplete3_Obj_1.D /= 2 ) or + (Incomplete3_Obj_1.I /= 10) or + (Incomplete3_Obj_1.E /= F ) or + (Incomplete3_Obj_1.S /= "Hi") then + Report.Failed ("Wrong values for Incomplete3_Obj_1"); + end if; + + if (Incomplete4_Obj_1.E /= M ) or + (Incomplete4_Obj_1.D /= 3) or + (Incomplete4_Obj_1.S /= "Bye") or + (Incomplete4_Obj_1.I /= 14) then + Report.Failed ("Wrong values for Incomplete4_Obj_1"); + end if; + + Report.Result; + + end C3A1002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,460 ---- + -- C3A2001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an access type may be defined to designate the + -- class-wide type of an abstract type. Check that the access type + -- may then be used subsequently with types derived from the abstract + -- type. Check that dispatching operations dispatch correctly, when + -- called using values designated by objects of the access type. + -- + -- TEST DESCRIPTION: + -- This test declares an abstract type Breaker in a package, and + -- then derives from it. The type Basic_Breaker defines the least + -- possible in order to not be abstract. The type Ground_Fault is + -- defined to inherit as much as possible, whereas type Special_Breaker + -- overrides everything it can. The type Special_Breaker also includes + -- an embedded Basic_Breaker object. The main program then utilizes + -- each of the three types of breaker, and to ascertain that the + -- overloading and tagging resolution are correct, each "Create" + -- procedure is called with a unique value. The diagram below + -- illustrates the relationships. + -- + -- Abstract type: Breaker(1) + -- | + -- Basic_Breaker(2) + -- / \ + -- Ground_Fault(3) Special_Breaker(4) + -- + -- Test structure is a polymorphic linked list, modeling a circuit + -- as a list of components. The type component is the access type + -- defined to designate Breaker'Class values. The test then creates + -- some values, and traverses the list to determine correct operation. + -- This test is instrumented with a the trace facility found in + -- foundation F392C00 to simplify the verification process. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Nov 95 SAIC Checked compilation for ACVC 2.0.1 + -- 23 APR 96 SAIC Added pragma Elaborate_All + -- 26 NOV 96 SAIC Elaborate_Body changed to Elaborate_All + -- + --! + + with Report; + with TCTouch; + package C3A2001_1 is + + type Breaker is abstract tagged private; + type Status is ( Power_Off, Power_On, Tripped, Failed ); + + procedure Flip ( The_Breaker : in out Breaker ) is abstract; + procedure Trip ( The_Breaker : in out Breaker ) is abstract; + procedure Reset( The_Breaker : in out Breaker ) is abstract; + procedure Fail ( The_Breaker : in out Breaker ); + + procedure Set ( The_Breaker : in out Breaker'Class; To_State : Status ); + + function Status_Of( The_Breaker : Breaker ) return Status; + + private + type Breaker is abstract tagged record + State : Status := Power_Off; + end record; + end C3A2001_1; + + ---------------------------------------------------------------------------- + + with TCTouch; + package body C3A2001_1 is + procedure Fail( The_Breaker : in out Breaker ) is + begin + TCTouch.Touch( 'a' ); --------------------------------------------- a + The_Breaker.State := Failed; + end Fail; + + procedure Set( The_Breaker : in out Breaker'Class; To_State : Status ) is + begin + The_Breaker.State := To_State; + end Set; + + function Status_Of( The_Breaker : Breaker ) return Status is + begin + TCTouch.Touch( 'b' ); --------------------------------------------- b + return The_Breaker.State; + end Status_Of; + end C3A2001_1; + + ---------------------------------------------------------------------------- + + with C3A2001_1; + package C3A2001_2 is + + type Basic_Breaker is new C3A2001_1.Breaker with private; + + type Voltages is ( V12, V110, V220, V440 ); + type Amps is ( A1, A5, A10, A25, A100 ); + + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker; + + procedure Flip ( The_Breaker : in out Basic_Breaker ); + procedure Trip ( The_Breaker : in out Basic_Breaker ); + procedure Reset( The_Breaker : in out Basic_Breaker ); + private + type Basic_Breaker is new C3A2001_1.Breaker with record + Voltage_Level : Voltages := V110; + Amperage : Amps; + end record; + end C3A2001_2; + + ---------------------------------------------------------------------------- + + with TCTouch; + package body C3A2001_2 is + function Construct( Voltage : Voltages; Amperage : Amps ) + return Basic_Breaker is + It : Basic_Breaker; + begin + TCTouch.Touch( 'c' ); --------------------------------------------- c + It.Amperage := Amperage; + It.Voltage_Level := Voltage; + C3A2001_1.Set( It, C3A2001_1.Power_Off ); + return It; + end Construct; + + procedure Flip ( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'd' ); --------------------------------------------- d + case Status_Of( The_Breaker ) is + when C3A2001_1.Power_Off => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); + when C3A2001_1.Power_On => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_Off ); + when C3A2001_1.Tripped | C3A2001_1.Failed => null; + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'e' ); --------------------------------------------- e + C3A2001_1.Set( The_Breaker, C3A2001_1.Tripped ); + end Trip; + + procedure Reset( The_Breaker : in out Basic_Breaker ) is + begin + TCTouch.Touch( 'f' ); --------------------------------------------- f + case Status_Of( The_Breaker ) is + when C3A2001_1.Power_Off | C3A2001_1.Tripped => + C3A2001_1.Set( The_Breaker, C3A2001_1.Power_On ); + when C3A2001_1.Power_On | C3A2001_1.Failed => null; + end case; + end Reset; + + end C3A2001_2; + + ---------------------------------------------------------------------------- + + with C3A2001_1,C3A2001_2; + package C3A2001_3 is + use type C3A2001_1.Status; + + type Ground_Fault is new C3A2001_2.Basic_Breaker with private; + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Ground_Fault; + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ); + + private + type Ground_Fault is new C3A2001_2.Basic_Breaker with record + Capacitance : Integer; + end record; + end C3A2001_3; + + ---------------------------------------------------------------------------- + + with TCTouch; + package body C3A2001_3 is + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Ground_Fault is + begin + TCTouch.Touch( 'g' ); --------------------------------------------- g + return ( C3A2001_2.Construct( Voltage, Amperage ) + with Capacitance => 0 ); + end Construct; + + + procedure Set_Trip( The_Breaker : in out Ground_Fault; + Capacitance : in Integer ) is + begin + TCTouch.Touch( 'h' ); --------------------------------------------- h + The_Breaker.Capacitance := Capacitance; + end Set_Trip; + + end C3A2001_3; + + ---------------------------------------------------------------------------- + + with C3A2001_1, C3A2001_2; + package C3A2001_4 is + + type Special_Breaker is new C3A2001_2.Basic_Breaker with private; + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Special_Breaker; + + procedure Flip ( The_Breaker : in out Special_Breaker ); + procedure Trip ( The_Breaker : in out Special_Breaker ); + procedure Reset( The_Breaker : in out Special_Breaker ); + procedure Fail ( The_Breaker : in out Special_Breaker ); + + function Status_Of( The_Breaker : Special_Breaker ) return C3A2001_1.Status; + function On_Backup( The_Breaker : Special_Breaker ) return Boolean; + + private + type Special_Breaker is new C3A2001_2.Basic_Breaker with record + Backup : C3A2001_2.Basic_Breaker; + end record; + end C3A2001_4; + + ---------------------------------------------------------------------------- + + with TCTouch; + package body C3A2001_4 is + + function Construct( Voltage : C3A2001_2.Voltages; + Amperage : C3A2001_2.Amps ) + return Special_Breaker is + It: Special_Breaker; + procedure Set_Root( It: in out C3A2001_2.Basic_Breaker ) is + begin + It := C3A2001_2.Construct( Voltage, Amperage ); + end Set_Root; + begin + TCTouch.Touch( 'i' ); --------------------------------------------- i + Set_Root( C3A2001_2.Basic_Breaker( It ) ); + Set_Root( It.Backup ); + return It; + end Construct; + + function Status_Of( It: C3A2001_1.Breaker ) return C3A2001_1.Status + renames C3A2001_1.Status_Of; + + procedure Flip ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'j' ); --------------------------------------------- j + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_Off | C3A2001_1.Power_On => + C3A2001_2.Flip( C3A2001_2.Basic_Breaker( The_Breaker ) ); + when others => + C3A2001_2.Flip( The_Breaker.Backup ); + end case; + end Flip; + + procedure Trip ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'k' ); --------------------------------------------- k + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_Off => null; + when C3A2001_1.Power_On => + C3A2001_2.Reset( The_Breaker.Backup ); + C3A2001_2.Trip( C3A2001_2.Basic_Breaker( The_Breaker ) ); + when others => + C3A2001_2.Trip( The_Breaker.Backup ); + end case; + end Trip; + + procedure Reset( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'l' ); --------------------------------------------- l + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Tripped => + C3A2001_2.Reset( C3A2001_2.Basic_Breaker( The_Breaker )); + when C3A2001_1.Failed => + C3A2001_2.Reset( The_Breaker.Backup ); + when C3A2001_1.Power_On | C3A2001_1.Power_Off => + null; + end case; + end Reset; + + procedure Fail ( The_Breaker : in out Special_Breaker ) is + begin + TCTouch.Touch( 'm' ); --------------------------------------------- m + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Failed => + C3A2001_2.Fail( The_Breaker.Backup ); + when others => + C3A2001_2.Fail( C3A2001_2.Basic_Breaker( The_Breaker )); + C3A2001_2.Reset( The_Breaker.Backup ); + end case; + end Fail; + + function Status_Of( The_Breaker : Special_Breaker ) + return C3A2001_1.Status is + begin + TCTouch.Touch( 'n' ); --------------------------------------------- n + case Status_Of( C3A2001_1.Breaker( The_Breaker )) is + when C3A2001_1.Power_On => return C3A2001_1.Power_On; + when C3A2001_1.Power_Off => return C3A2001_1.Power_Off; + when others => + return C3A2001_2.Status_Of( The_Breaker.Backup ); + end case; + end Status_Of; + + function On_Backup( The_Breaker : Special_Breaker ) return Boolean is + use C3A2001_2; + use type C3A2001_1.Status; + begin + return Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Tripped + or Status_Of(Basic_Breaker(The_Breaker)) = C3A2001_1.Failed; + end On_Backup; + + end C3A2001_4; + + ---------------------------------------------------------------------------- + + with C3A2001_1; + package C3A2001_5 is + + type Component is access C3A2001_1.Breaker'Class; + + type Circuit; + type Connection is access Circuit; + + type Circuit is record + The_Gadget : Component; + Next : Connection; + end record; + + procedure Flipper( The_Circuit : Connection ); + procedure Tripper( The_Circuit : Connection ); + procedure Restore( The_Circuit : Connection ); + procedure Failure( The_Circuit : Connection ); + + Short : Connection := null; + + end C3A2001_5; + + ---------------------------------------------------------------------------- + with Report; + with TCTouch; + with C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4; + + pragma Elaborate_All( Report, TCTouch, + C3A2001_1, C3A2001_2, C3A2001_3, C3A2001_4 ); + + package body C3A2001_5 is + + function Neww( Breaker: in C3A2001_1.Breaker'Class ) + return Component is + begin + return new C3A2001_1.Breaker'Class'( Breaker ); + end Neww; + + procedure Add( Gadget : in Component; + To_Circuit : in out Connection) is + begin + To_Circuit := new Circuit'(Gadget,To_Circuit); + end Add; + + procedure Flipper( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Flip( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Flipper; + + procedure Tripper( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Trip( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Tripper; + + procedure Restore( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Reset( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Restore; + + procedure Failure( The_Circuit : Connection ) is + Probe : Connection := The_Circuit; + begin + while Probe /= null loop + C3A2001_1.Fail( Probe.The_Gadget.all ); + Probe := Probe.Next; + end loop; + end Failure; + + begin + Add( Neww( C3A2001_2.Construct( C3A2001_2.V440, C3A2001_2.A5 )), Short ); + Add( Neww( C3A2001_3.Construct( C3A2001_2.V110, C3A2001_2.A1 )), Short ); + Add( Neww( C3A2001_4.Construct( C3A2001_2.V12, C3A2001_2.A100 )), Short ); + end C3A2001_5; + + ---------------------------------------------------------------------------- + + with Report; + with TCTouch; + with C3A2001_5; + procedure C3A2001 is + + begin -- Main test procedure. + + Report.Test ("C3A2001", "Check that an abstract type can be declared " & + "and used. Check actual subprograms dispatch correctly" ); + + -- This Validate call must be _after_ the call to Report.Test + TCTouch.Validate( "cgcicc", "Adding" ); + + C3A2001_5.Flipper( C3A2001_5.Short ); + TCTouch.Validate( "jbdbdbdb", "Flipping" ); + + C3A2001_5.Tripper( C3A2001_5.Short ); + TCTouch.Validate( "kbfbeee", "Tripping" ); + + C3A2001_5.Restore( C3A2001_5.Short ); + TCTouch.Validate( "lbfbfbfb", "Restoring" ); + + C3A2001_5.Failure( C3A2001_5.Short ); + TCTouch.Validate( "mbafbaa", "Circuits Failing" ); + + Report.Result; + + end C3A2001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,295 ---- + -- C3A2002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for X'Access of a general access type A, Program_Error is + -- raised if the accessibility level of X is deeper than that of A. + -- Check for the case where X denotes a view that is a dereference of an + -- access parameter, or a rename thereof. + -- + -- Check for cases where the actual corresponding to X is: + -- (a) An allocator. + -- (b) An expression of a named access type. + -- (c) Obj'Access. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the designated + -- object X must be at the same or a less deep nesting level than the + -- general access type A -- X must "live" as long as A. Nesting + -- levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares subprograms with access parameters, within which + -- 'Access is attempted on a dereference of the access parameter, and + -- assigned to an access object whose type A is declared at some nesting + -- level. The test verifies that Program_Error is raised if the actual + -- corresponding to the access parameter is: + -- + -- (1) an allocator, and the accessibility level of the execution + -- of the called subprogram is deeper than that of the access + -- type A. + -- + -- (2) an expression of a named access type, and the accessibility + -- level of the named access type is deeper than that of the + -- access type A. + -- + -- (3) a reference to the Access attribute (e.g., X'Access), and + -- the accessibility level of X is deeper than that of the + -- access type A. + -- + -- Note that the static nesting level of the actual corresponding to the + -- access parameter can be deeper than that of the type A -- it is + -- the run-time nesting that matters for accessibility rules. Consider + -- the case where the access type A is declared within the called + -- subprogram. The accessibility check will never fail, even if the + -- actual happens to have a deeper static nesting level: + -- + -- procedure P (X: access T) is + -- type A is access all T; -- Static level = 2, e.g. + -- Acc : A := X.all'Access; -- Check should never fail. + -- begin null; end; + -- . . . + -- declare + -- Actual : aliased T; -- Static level = 3, e.g. + -- begin + -- P (Actual'Access); + -- end; + -- + -- For the execution of P, the accessibility level of type A will + -- always be deeper than that of Actual, so there is no danger of a + -- dangling reference arising from the assignment to Acc. Thus, + -- X.all'Access is safe, even though the static nesting level of + -- Actual is deeper than that of A. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C3A2002_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig; -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure A_Is_Level_0 (X: access Desig; R : out Result_Kind); + procedure Never_Fails (X: access Desig; R : out Result_Kind); + + end C3A2002_0; + + + --==================================================================-- + + package body C3A2002_0 is + + procedure A_Is_Level_0 (X : access Desig; + R : out Result_Kind) is + begin + -- The accessibility level of the type of A0 is 0. + A0 := X.all'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end A_Is_Level_0; + + ----------------------------------------------- + procedure Never_Fails (X: access Desig; + R : out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- X.all'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of the + -- type of AL will always be deeper than or the same as that of the + -- actual corresponding to Y. + AL := X.all'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Never_Fails; + + end C3A2002_0; + + + --==================================================================-- + + + with C3A2002_0; + with Report; + + procedure C3A2002 is + + X1 : aliased C3A2002_0.Desig; -- Level = 1. + + type Acc_L1 is access all C3A2002_0.Desig; -- Level = 1. + A1 : Acc_L1; + + Expr_L0 : C3A2002_0.Acc_L0 := C3A2002_0.X0'Access; + Expr_L1 : Acc_L1 := X1'Access; + + Res : C3A2002_0.Result_Kind; + + use type C3A2002_0.Result_Kind; + + ----------------------------------------------- + procedure A_Is_Level_1 (X : access C3A2002_0.Desig; + R : out C3A2002_0.Result_Kind) is + -- Dereference of an access_to_object value is aliased. + Ren : C3A2002_0.Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- The accessibility level of the type of A1 is 1. + A1 := Ren'Access; + R := C3A2002_0.OK; + exception + when Program_Error => + R := C3A2002_0.P_E; + when others => + R := C3A2002_0.O_E; + end A_Is_Level_1; + + ----------------------------------------------- + procedure Display_Results (Result : in C3A2002_0.Result_Kind; + Expected: in C3A2002_0.Result_Kind; + Message : in String) is + begin + if Result /= Expected then + case Result is + when C3A2002_0.OK => Report.Failed ("No exception raised: " & + Message); + when C3A2002_0.P_E => Report.Failed ("Program_Error raised: " & + Message); + when C3A2002_0.O_E => Report.Failed ("Unexpected exception " & + "raised: " & Message); + end case; + end if; + end Display_Results; + + begin -- C3A2002 + + Report.Test ("C3A2002", "Check that, for X'Access of general access " & + "type A, Program_Error is raised if the accessibility " & + "level of X is deeper than that of A: X is an access " & + "parameter; corresponding actual is an allocator, " & + "expression of a named access type, Obj'Access, or a " & + "rename thereof"); + + + -- Actual is X'Access: + + C3A2002_0.Never_Fails (C3A2002_0.X0'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X0'Access, local access type"); + + C3A2002_0.A_Is_Level_0 (C3A2002_0.X0'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X0'Access, level 0 access type"); + + C3A2002_0.A_Is_Level_0 (X1'Access, Res); + Display_Results (Res, C3A2002_0.P_E, "X1'Access, level 0 access type"); + + A_Is_Level_1 (X1'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X1'Access, level 1 access type"); + + + -- Actual is expression of a named access type: + + C3A2002_0.Never_Fails (Expr_L1, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L1, local access type"); + + C3A2002_0.A_Is_Level_0 (Expr_L1, Res); + Display_Results (Res, C3A2002_0.P_E, "Expr_L1, level 0 access type"); + + A_Is_Level_1 (Expr_L0, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L0, level 1 access type"); + + A_Is_Level_1 (Expr_L1, Res); + Display_Results (Res, C3A2002_0.OK, "Expr_L1, level 1 access type"); + + -- Actual is allocator (level of execution = 2): + + C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.OK, "Allocator level 2, " & + "local access type"); + + -- Since actual is an allocator, its accessibility level is that of + -- the execution of the called subprogram, i.e., level 2. + + C3A2002_0.A_Is_Level_0 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & + "level 0 access type"); + + A_Is_Level_1 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 2, " & + "level 1 access type"); + + + Block_L2: + declare + X2 : aliased C3A2002_0.Desig; -- Level = 2. + type Acc_L2 is access all C3A2002_0.Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X1'Access; + begin + + -- Actual is X'Access: + + C3A2002_0.Never_Fails (X2'Access, Res); + Display_Results (Res, C3A2002_0.OK, "X2'Access, local access type"); + + C3A2002_0.A_Is_Level_0 (X2'Access, Res); + Display_Results (Res, C3A2002_0.P_E, "X2'Access, level 0 access type"); + + + -- Actual is expression of a named access type: + + A_Is_Level_1 (Expr_L2, Res); + Display_Results (Res, C3A2002_0.P_E, "Expr_L2, level 1 access type"); + + + -- Actual is allocator (level of execution = 3): + + C3A2002_0.Never_Fails (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.OK, "Allocator level 3, " & + "local access type"); + + A_Is_Level_1 (new C3A2002_0.Desig, Res); + Display_Results (Res, C3A2002_0.P_E, "Allocator level 3, " & + "level 1 access type"); + + end Block_L2; + + Report.Result; + + end C3A2002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,329 ---- + -- C3A2003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for X'Access of a general access type A, Program_Error is + -- raised if the accessibility level of X is deeper than that of A. + -- Check for the case where X denotes a view that is a dereference of an + -- access parameter, or a rename thereof. Check for the case where X is + -- an access parameter and the corresponding actual is another access + -- parameter. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the designated + -- object X must be at the same or a less deep nesting level than the + -- general access type A -- X must "live" as long as A. Nesting + -- levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares subprograms with access parameters, within which + -- 'Access is attempted on a dereference of an access parameter, and + -- assigned to an access object whose type A is declared at some nesting + -- level. The test verifies that Program_Error is raised if the actual + -- corresponding to the access parameter is another access parameter, + -- and the actual corresponding to this second access parameter is: + -- + -- (1) an expression of a named access type, and the accessibility + -- level of the named access type is deeper than that of the + -- access type A. + -- + -- (2) a reference to the Access attribute (e.g., X'Access), and + -- the accessibility level of X is deeper than that of the + -- access type A. + -- + -- Note that the static nesting level of the actual corresponding to the + -- access parameter can be deeper than that of the type A -- it is + -- the run-time nesting that matters for accessibility rules. Consider + -- the case where the access type A is declared within the called + -- subprogram. The accessibility check will never fail, even if the + -- actual happens to have a deeper static nesting level: + -- + -- procedure P (X: access T) is + -- type A is access all T; -- Static level = 2, e.g. + -- Acc : A := X.all'Access; -- Check should never fail. + -- begin null; end; + -- . . . + -- procedure Q (Y: access T) is + -- begin + -- P(Y); + -- end; + -- . . . + -- declare + -- Actual : aliased T; -- Static level = 3, e.g. + -- begin + -- Q (Actual'Access); + -- end; + -- + -- For the execution of Q (and hence P), the accessibility level of + -- type A will always be deeper than that of Actual, so there is no + -- danger of a dangling reference arising from the assignment to + -- Acc. Thus, X.all'Access is safe, even though the static nesting + -- level of Actual is deeper than that of A. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Jul 98 EDS Avoid optimization. + -- 28 Jun 02 RLB Added pragma Elaborate_All (Report);. + --! + + with report; use report; pragma Elaborate_All (report); + package C3A2003_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig := (Desig'Range => Ident_Int(3)); -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); + + end C3A2003_0; + + + --==================================================================-- + + + package body C3A2003_0 is + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is + + + -- This procedure utilizes 'Access on a dereference of an access + -- parameter, and assigned to an access object whose type A is + -- declared at some nesting level. Program_Error is raised if + -- the accessibility level of the operand type is deeper than that + -- of the target type. + + procedure Nested (X: access Desig; R: out Result_Kind) is + -- Dereference of an access_to_object value is aliased. + Ren : Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- The accessibility level of type A0 is 0. + A0 := Ren'Access; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Nested; + + begin -- Target_Is_Level_0_Nest + Nested (Y, S); + end Target_Is_Level_0_Nest; + + ------------------------------------------------------------------ + + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is + + type Acc_Deeper is access all Desig; + AD : Acc_Deeper; + + function Nested (X: access Desig) return Result_Kind is + begin + -- X.all'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of the + -- type of AD will always be deeper than or the same as that of the + -- actual corresponding to Y. + AD := X.all'Access; + if Ident_Int (AD(4)) /= 3 then --Avoid Optimization of AD + FAILED ("Initial Values not correct."); + end if; + return OK; + exception + when Program_Error => + return P_E; + when others => + return O_E; + end Nested; + + begin -- Never_Fails_Nest + S := Nested (Y); + end Never_Fails_Nest; + + ------------------------------------------------------------------ + + procedure Called_By_Never_Fails_Same + (X: access Desig; R: out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + + -- Dereference of an access_to_object value is aliased. + Ren : Desig renames X.all; -- Renaming of a dereference + begin -- of an access parameter. + -- Ren'Access below will always be safe, since the accessibility + -- level (although not necessarily the static nesting depth) of + -- type of AL will always be deeper than or the same as that of the + -- actual corresponding to Y. + AL := Ren'Access; + if Ident_Int (AL(4)) /= 3 then --Avoid Optimization of AL + FAILED ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Never_Fails_Same; + + ------------------------------------------------------------------ + + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is + begin + Called_By_Never_Fails_Same (Y, S); + end Never_Fails_Same; + + end C3A2003_0; + + + --==================================================================-- + + + with C3A2003_0; + use C3A2003_0; + + with Report; use report; + + procedure C3A2003 is + + type Acc_L1 is access all Desig; -- Level = 1. + A1 : Acc_L1; + X1 : aliased Desig := (Desig'Range => Ident_Int(3)); + Res : Result_Kind; + + + procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is + begin + -- The accessibility level of the type of A1 is 1. + A1 := X.all'Access; + if IDENT_INT (A1(4)) /= 3 then --Avoid optimization of A1 + FAILED ("Initial values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Target_L1; + + ------------------------------------------------------------------ + + function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is + S : Result_Kind; + begin + Called_By_Target_L1 (Y, S); + return S; + end Target_Is_Level_1_Same; + + ------------------------------------------------------------------ + + procedure Display_Results (Result : in Result_Kind; + Expected: in Result_Kind; + Msg : in String) is + begin + if Result /= Expected then + case Result is + when OK => Report.Failed ("No exception raised: " & Msg); + when P_E => Report.Failed ("Program_Error raised: " & Msg); + when O_E => Report.Failed ("Unexpected exception raised: " & Msg); + end case; + end if; + end Display_Results; + + begin -- C3A2003 + + Report.Test ("C3A2003", "Check that, for X'Access of general access " & + "type A, Program_Error is raised if the accessibility " & + "level of X is deeper than that of A: X is an access " & + "parameter; corresponding actual is another access " & + "parameter"); + + + -- Accessibility level of actual is 0 (actual is X'Access): + + Never_Fails_Same (X0'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); + + Never_Fails_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); + + Target_Is_Level_0_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); + + Res := Target_Is_Level_1_Same (X0'Access); + Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); + + + -- Accessibility level of actual is 1 (actual is X'Access): + + Never_Fails_Same (X1'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); + + Never_Fails_Nest (X1'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); + + Target_Is_Level_0_Nest (X1'Access, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); + + Res := Target_Is_Level_1_Same (X1'Access); + Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); + + + Block_L2: + declare + X2 : aliased Desig := (Desig'Range => Ident_Int(3)); + type Acc_L2 is access all Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X2'Access; + begin + + -- Accessibility level of actual is 2 (actual is expression of named + -- access type): + + Never_Fails_Same (Expr_L2, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); + + Never_Fails_Nest (Expr_L2, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); + + Target_Is_Level_0_Nest (Expr_L2, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); + + Res := Target_Is_Level_1_Same (Expr_L2); + Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); + + end Block_L2; + + Report.Result; + + end C3A2003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2a01.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,367 ---- + -- C3A2A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for X'Access of a general access type A, Program_Error is + -- raised if the accessibility level of X is deeper than that of A. + -- Check for cases where X'Access occurs in an instance body, and A + -- is passed as an actual during instantiation. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the designated + -- object X must be at the same or a less deep nesting level than the + -- general access type A -- X must "live" as long as A. Nesting + -- levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares three generic units, each of which has a formal + -- general access type: + -- + -- (1) A generic package, in which X is declared in the specification, + -- and X'Access occurs within the declarative part of the body. + -- + -- (2) A generic package, in which X is a formal in out object of a + -- tagged formal derived type, and X'Access occurs in the sequence + -- of statements of a nested subprogram. + -- + -- (3) A generic procedure, in which X is a dereference of an access + -- parameter, and X'Access occurs in the sequence of statements. + -- + -- The test verifies the following: + -- + -- For (1), Program_Error is raised upon instantiation if the generic + -- package is instantiated at a deeper level than that of the general + -- access type passed as an actual. The exception is propagated to the + -- innermost enclosing master. + -- + -- For (2), Program_Error is raised when the nested subprogram is + -- called if the object passed as an actual during instantiation of + -- the generic package has an accessibility level deeper than that of + -- the general access type passed as an actual. The exception is + -- handled within the nested subprogram. Also, check that + -- Program_Error is not raised if the level of the actual access type + -- is deeper than that of the actual object. + -- + -- For (3), Program_Error is raised when the instance subprogram is + -- called if the object pointed to by the actual corresponding to + -- the access parameter has an accessibility level deeper than that of + -- the general access type passed as an actual during instantiation. + -- The exception is handled within the instance subprogram. Also, + -- check that Program_Error is not raised if the level of the actual + -- access type is deeper than that of the actual corresponding to the + -- access parameter. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F3A2A00.A + -- -> C3A2A01.A + -- + -- + -- CHANGE HISTORY: + -- 12 May 95 SAIC Initial prerelease version. + -- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. + -- + --! + + with F3A2A00; + generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; + package C3A2A01_0 is + X : aliased FD; + + procedure Dummy; -- Needed to allow package body. + end C3A2A01_0; + + + --==================================================================-- + + + with Report; + package body C3A2A01_0 is + Ptr : FAF := X'Access; + Index : Integer := F3A2A00.Array_Type'First; + + procedure Dummy is + begin + null; + end Dummy; + begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_0 instance"); + end if; + end C3A2A01_0; + + + --==================================================================-- + + + with F3A2A00; + generic + type FD is new F3A2A00.Tagged_Type with private; + type FAF is access all FD; + FObj : in out FD; + package C3A2A01_1 is + procedure Handle (R: out F3A2A00.TC_Result_Kind); + end C3A2A01_1; + + + --==================================================================-- + + + with Report; + package body C3A2A01_1 is + + procedure Handle (R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + begin + Ptr := FObj'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in Handle"); + end if; + exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; + end Handle; + + end C3A2A01_1; + + + --==================================================================-- + + + with F3A2A00; + generic + type FD is new F3A2A00.Array_Type; + type FAF is access all FD; + procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind); + + + --==================================================================-- + + + with Report; + procedure C3A2A01_2 (P: access FD; R: out F3A2A00.TC_Result_Kind) is + Ptr : FAF; + Index : Integer := F3A2A00.Array_Type'First; + begin + Ptr := P.all'Access; + R := F3A2A00.OK; + + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr(Index).C, Ptr(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A01_2 instance"); + end if; + exception + when Program_Error => R := F3A2A00.P_E; + when others => R := F3A2A00.O_E; + end C3A2A01_2; + + + --==================================================================-- + + + with F3A2A00; + with C3A2A01_0; + with C3A2A01_1; + with C3A2A01_2; + + with Report; + procedure C3A2A01 is + begin -- C3A2A01. -- [ Level = 1 ] + + Report.Test ("C3A2A01", "Run-time accessibility checks: instance " & + "bodies. Type of X'Access is passed as actual to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F3A2A00.Array_Type; + begin + declare -- [ Level = 4 ] + -- The accessibility level of Pack.X is that of the instantiation + -- (4). The accessibility level of the actual access type used to + -- instantiate Pack is 3. Therefore, the X'Access in Pack + -- propagates Program_Error when the instance body is elaborated: + + package Pack is new C3A2A01_0 (F3A2A00.Array_Type, AccArr_L3); + begin + Result := F3A2A00.OK; + end; + exception + when Program_Error => Result := F3A2A00.P_E; -- Expected result. + when others => Result := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + type AccTag_L3 is access all F3A2A00.Tagged_Type; + + package Pack_OK is new C3A2A01_1 (F3A2A00.Tagged_Type, + AccTag_L3, + F3A2A00.X_L0); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_OK is 0. The accessibility level of the actual access type + -- used to instantiate Pack_OK is 3. Therefore, the FObj'Access in + -- Pack_OK.Handle does not raise an exception when the subprogram is + -- called. If an exception is (incorrectly) raised, however, it is + -- handled within the subprogram: + + Pack_OK.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.OK, "SUBTEST #2"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #2: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #2: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F3A2A00.TC_Result_Kind; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_1 should NOT result in any + -- exceptions. + + X_L3: F3A2A00.Tagged_Type; + + package Pack_PE is new C3A2A01_1 (F3A2A00.Tagged_Type, + F3A2A00.AccTag_L0, + X_L3); + begin + -- The accessibility level of the actual object used to instantiate + -- Pack_PE is 3. The accessibility level of the actual access type + -- used to instantiate Pack_PE is 0. Therefore, the FObj'Access in + -- Pack_OK.Handle raises Program_Error when the subprogram is + -- called. The exception is handled within the subprogram: + + Pack_PE.Handle (Result); + end; + + F3A2A00.TC_Display_Results (Result, F3A2A00.P_E, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A01_2 should NOT result in any + -- exceptions. + + X_L3: aliased F3A2A00.Array_Type; + type AccArr_L3 is access all F3A2A00.Array_Type; + + procedure Proc is new C3A2A01_2 (F3A2A00.Array_Type, AccArr_L3); + begin + -- The accessibility level of Proc.P.all is that of the corresponding + -- actual during the call (in this case 3). The accessibility level of + -- the access type used to instantiate Proc is also 3. Therefore, the + -- P.all'Access in Proc does not raise an exception when the + -- subprogram is called. If an exception is (incorrectly) raised, + -- however, it is handled within the subprogram: + + Proc (X_L3'Access, Result1); + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #4: same levels"); + + declare -- [ Level = 4 ] + X_L4: aliased F3A2A00.Array_Type; + begin + -- Within this block, the accessibility level of the actual + -- corresponding to Proc.P.all is 4. Therefore, the P.all'Access + -- in Proc raises Program_Error when the subprogram is called. The + -- exception is handled within the subprogram: + + Proc (X_L4'Access, Result2); + + F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, + "SUBTEST #4: object at deeper level"); + end; + + end; + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST4; + + + Report.Result; + + end C3A2A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c3/c3a2a02.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,396 ---- + -- C3A2A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for X'Access of a general access type A, Program_Error is + -- raised if the accessibility level of X is deeper than that of A. + -- Check for cases where X'Access occurs in an instance body, and A + -- is a type either declared inside the instance, or declared outside + -- the instance but not passed as an actual during instantiation. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the designated + -- object X must be at the same or a less deep nesting level than the + -- general access type A -- X must "live" as long as A. Nesting + -- levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares three generic packages: + -- + -- (1) One in which X is of a formal tagged derived type and declared + -- in the body, A is a type declared outside the instance, and + -- X'Access occurs in the declarative part of a nested subprogram. + -- + -- (2) One in which X is a formal object of a tagged type, A is a + -- type declared outside the instance, and X'Access occurs in the + -- declarative part of the body. + -- + -- (3) One in which there are two X's and two A's. In the first pair, + -- X is a formal in object of a tagged type, A is declared in the + -- specification, and X'Access occurs in the declarative part of + -- the body. In the second pair, X is of a formal derived type, + -- X and A are declared in the specification, and X'Access occurs + -- in the sequence of statements of the body. + -- + -- The test verifies the following: + -- + -- For (1), Program_Error is raised when the nested subprogram is + -- called, if the generic package is instantiated at a deeper level + -- than that of A. The exception is propagated to the innermost + -- enclosing master. Also, check that Program_Error is not raised + -- if the instantiation is at the same level as that of A. + -- + -- For (2), Program_Error is raised upon instantiation if the object + -- passed as an actual during instantiation has an accessibility level + -- deeper than that of A. The exception is propagated to the innermost + -- enclosing master. Also, check that Program_Error is not raised if + -- the level of the actual object is not deeper than that of A. + -- + -- For (3), Program_Error is not raised, for actual objects at + -- various accessibility levels (since A will have at least the same + -- accessibility level as X in all cases, no exception should ever + -- be raised). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F3A2A00.A + -- -> C3A2A02.A + -- + -- + -- CHANGE HISTORY: + -- 12 May 95 SAIC Initial prerelease version. + -- 10 Jul 95 SAIC Modified code to avoid dead variable optimization. + -- 26 Jun 98 EDS Added pragma Elaborate (C3A2A02_0) to package + -- package C3A2A02_3, in order to avoid possible + -- instantiation error. + --! + + with F3A2A00; + generic + type FD is new F3A2A00.Tagged_Type with private; + package C3A2A02_0 is + procedure Proc; + end C3A2A02_0; + + + --==================================================================-- + + + with Report; + package body C3A2A02_0 is + X : aliased FD; + + procedure Proc is + Ptr : F3A2A00.AccTagClass_L0 := X'Access; + begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in Proc"); + end if; + end Proc; + end C3A2A02_0; + + + --==================================================================-- + + + with F3A2A00; + generic + FObj : in out F3A2A00.Tagged_Type; + package C3A2A02_1 is + procedure Dummy; -- Needed to allow package body. + end C3A2A02_1; + + + --==================================================================-- + + + with Report; + package body C3A2A02_1 is + Ptr : F3A2A00.AccTag_L0 := FObj'Access; + + procedure Dummy is + begin + null; + end Dummy; + begin + -- Avoid optimization (dead variable removal of Ptr): + + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_1 instance"); + end if; + end C3A2A02_1; + + + --==================================================================-- + + + with F3A2A00; + generic + type FD is new F3A2A00.Array_Type; + FObj : in F3A2A00.Tagged_Type; + package C3A2A02_2 is + type GAF is access all FD; + type GAO is access constant F3A2A00.Tagged_Type; + XG : aliased FD; + PtrF : GAF; + Index : Integer := FD'First; + + procedure Dummy; -- Needed to allow package body. + end C3A2A02_2; + + + --==================================================================-- + + + with Report; + package body C3A2A02_2 is + PtrO : GAO := FObj'Access; + + procedure Dummy is + begin + null; + end Dummy; + begin + PtrF := XG'Access; + + -- Avoid optimization (dead variable removal of PtrO and/or PtrF): + + if not Report.Equal (PtrO.C, PtrO.C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrO"); + end if; + + if not Report.Equal (PtrF(Index).C, PtrF(Index).C) then -- Always false. + Report.Failed ("Unexpected error in C3A2A02_2 instance: PtrF"); + end if; + end C3A2A02_2; + + + --==================================================================-- + + + -- The instantiation of C3A2A02_0 should NOT result in any exceptions. + + with F3A2A00; + with C3A2A02_0; + pragma Elaborate (C3A2A02_0); + package C3A2A02_3 is new C3A2A02_0 (F3A2A00.Tagged_Type); + + + --==================================================================-- + + + with F3A2A00; + with C3A2A02_0; + with C3A2A02_1; + with C3A2A02_2; + with C3A2A02_3; + + with Report; + procedure C3A2A02 is + begin -- C3A2A02. -- [ Level = 1 ] + + Report.Test ("C3A2A02", "Run-time accessibility checks: instance " & + "bodies. Type of X'Access is local or global to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + package Pack_Same_Level renames C3A2A02_3; + begin + -- The accessibility level of Pack_Same_Level.X is that of the + -- instance (0), not that of the renaming declaration. The level of + -- the type of Pack_Same_Level.X'Access (F3A2A00.AccTagClass_L0) is + -- 0. Therefore, the X'Access in Pack_Same_Level.Proc does not raise + -- an exception when the subprogram is called. The level of execution + -- of the subprogram is irrelevant: + + Pack_Same_Level.Proc; + Result1 := F3A2A00.OK; -- Expected result. + exception + when Program_Error => Result1 := F3A2A00.P_E; + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #1 (same level)"); + + + declare -- [ Level = 3 ] + -- The instantiation of C3A2A02_0 should NOT result in any + -- exceptions. + + package Pack_Deeper_Level is new C3A2A02_0 (F3A2A00.Tagged_Type); + begin + -- The accessibility level of Pack_Deeper_Level.X is that of the + -- instance (3). The level of the type of Pack_Deeper_Level.X'Access + -- (F3A2A00.AccTagClass_L0) is 0. Therefore, the X'Access in + -- Pack_Deeper_Level.Proc propagates Program_Error when the + -- subprogram is called: + + Pack_Deeper_Level.Proc; + Result2 := F3A2A00.OK; + exception + when Program_Error => Result2 := F3A2A00.P_E; -- Expected result. + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.P_E, + "SUBTEST #1: deeper level"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #1: Program_Error incorrectly raised " & + "during instantiation of generic"); + when others => + Report.Failed ("SUBTEST #1: Unexpected exception raised " & + "during instantiation of generic"); + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + X_L3 : F3A2A00.Tagged_Type; + begin + declare -- [ Level = 4 ] + -- The accessibility level of the actual object corresponding to + -- FObj in Pack_PE is 3. The level of the type of FObj'Access + -- (F3A2A00.AccTag_L0) is 0. Therefore, the FObj'Access in Pack_PE + -- propagates Program_Error when the instance body is elaborated: + + package Pack_PE is new C3A2A02_1 (X_L3); + begin + Result1 := F3A2A00.OK; + end; + exception + when Program_Error => Result1 := F3A2A00.P_E; -- Expected result. + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.P_E, + "SUBTEST #2: deeper level"); + + + begin -- [ Level = 3 ] + declare -- [ Level = 4 ] + -- The accessibility level of the actual object corresponding to + -- FObj in Pack_OK is 0. The level of the type of FObj'Access + -- (F3A2A00.AccTag_L0) is also 0. Therefore, the FObj'Access in + -- Pack_OK does not raise an exception when the instance body is + -- elaborated: + + package Pack_OK is new C3A2A02_1 (F3A2A00.X_L0); + begin + Result2 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result2 := F3A2A00.P_E; + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, + "SUBTEST #2: same level"); + + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result1 : F3A2A00.TC_Result_Kind; + Result2 : F3A2A00.TC_Result_Kind; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + X_L3 : F3A2A00.Tagged_Type; + begin + declare -- [ Level = 4 ] + -- Since the accessibility level of the type of X'Access in + -- both cases within Pack_OK1 is that of the instance, and since + -- X is either passed as an actual (in which case its level will + -- not be deeper than that of the instance) or is declared within + -- the instance (in which case its level is the same as that of + -- the instance), no exception should be raised when the instance + -- body is elaborated: + + package Pack_OK1 is new C3A2A02_2 (F3A2A00.Array_Type, X_L3); + begin + Result1 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result1 := F3A2A00.P_E; + when others => Result1 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result1, F3A2A00.OK, + "SUBTEST #3: 1st okay case"); + + + declare -- [ Level = 3 ] + type My_Array is new F3A2A00.Array_Type; + begin + declare -- [ Level = 4 ] + -- Since the accessibility level of the type of X'Access in + -- both cases within Pack_OK2 is that of the instance, and since + -- X is either passed as an actual (in which case its level will + -- not be deeper than that of the instance) or is declared within + -- the instance (in which case its level is the same as that of + -- the instance), no exception should be raised when the instance + -- body is elaborated: + + package Pack_OK2 is new C3A2A02_2 (My_Array, F3A2A00.X_L0); + begin + Result2 := F3A2A00.OK; -- Expected result. + end; + exception + when Program_Error => Result2 := F3A2A00.P_E; + when others => Result2 := F3A2A00.O_E; + end; + + F3A2A00.TC_Display_Results (Result2, F3A2A00.OK, + "SUBTEST #3: 2nd okay case"); + + + end SUBTEST3; + + + + Report.Result; + + end C3A2A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c410001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c410001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c410001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c410001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,303 ---- + -- C410001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that evaluating an access to subprogram variable containing + -- the value null causes the exception Constraint_Error. + -- Check that the default value for objects of access to subprogram + -- types is null. + -- + -- TEST DESCRIPTION: + -- This test defines a few simple access_to_subprogram types, and + -- objects of those types. It checks that the default values for + -- these objects is null, and that an attempt to make a subprogram + -- call via one of this objects containing a null value causes the + -- predefined exception Constraint_Error. The check is performed + --- both with the default null value, and with an explicitly assigned + -- null value, after the object has been used to successfully designate + -- and call a subprogram. + -- + -- + -- CHANGE HISTORY: + -- 05 APR 96 SAIC Initial version + -- 04 NOV 96 SAIC Revised for 2.1 release + -- 26 FEB 97 PWB.CTA Initialized variable before passing to function + --! + + ----------------------------------------------------------------- C410001_0 + + package C410001_0 is + + -- used to "switch state" in the software + Expect_Exception : Boolean; + + -- define a minimal mixture of access_to_subprogram types + + type Proc_Ref is access procedure; + + type Func_Ref is access function(I:Integer) return Integer; + + type Proc_Para_Ref is access procedure(P:Proc_Ref); + + type Func_Para_Ref is access function(F:Func_Ref) return Integer; + + type Prot_Proc_Ref is access protected procedure; + + type Prot_Func_Ref is access protected function return Boolean; + + -- define some subprograms for them to reference + + procedure Proc; + + function Func(I:Integer) return Integer; + + procedure Proc_Para( Param : Proc_Ref ); + + function Func_Para( Param : Func_Ref ) return Integer; + + protected Prot_Obj is + procedure Prot_Proc; + function Prot_Func return Boolean; + end Prot_Obj; + + end C410001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C410001_0 is + + -- Note that some failing cases will cause duplicate failure messages; + -- rather than have the procedure/function bodies be null, the error + -- checking code makes for a reasonable anti-optimization feature. + + procedure Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc"); + end if; + end Proc; + + function Func(I:Integer) return Integer is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func"); + end if; + return Report.Ident_Int(I); + end Func; + + procedure Proc_Para( Param : Proc_Ref ) is + begin + + Param.all; -- call by explicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Proc_Para"); + end if; + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Proc_Para"); + end if; -- else null; expected the exception + when others => Report.Failed("Unexpected exception: Proc_Para"); + end Proc_Para; + + function Func_Para( Param : Func_Ref ) return Integer is + begin + + return Param(1); -- call by implicit dereference + + if Expect_Exception then + Report.Failed("Expected exception did not occur: Func_Para"); + end if; + return 1; -- really just to avoid warnings + + exception + when Constraint_Error => + if not Expect_Exception then + Report.Failed("Unexpected Constraint_Error: Func_Para"); + return 0; + else + return 1995; -- any value other than this is unexpected + end if; + when others => Report.Failed("Unexpected exception: Func_Para"); + return -42; + end Func_Para; + + protected body Prot_Obj is + + procedure Prot_Proc is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Proc"); + end if; + end Prot_Proc; + + function Prot_Func return Boolean is + begin + if Expect_Exception then + Report.Failed("Expected exception did not occur: Prot_Func"); + end if; + return Report.Ident_Bool( True ); + end Prot_Func; + + end Prot_Obj; + + end C410001_0; + + ------------------------------------------------------------------- C410001 + + with Report; + with TCTouch; + with C410001_0; + procedure C410001 is + + Proc_Ref_Var : C410001_0.Proc_Ref; + + Func_Ref_Var : C410001_0.Func_Ref; + + Proc_Para_Ref_Var : C410001_0.Proc_Para_Ref; + + Func_Para_Ref_Var : C410001_0.Func_Para_Ref; + + type Enclosure is record + Prot_Proc_Ref_Var : C410001_0.Prot_Proc_Ref; + Prot_Func_Ref_Var : C410001_0.Prot_Func_Ref; + end record; + + Enclosed : Enclosure; + + Valid_Proc : C410001_0.Proc_Ref := C410001_0.Proc'Access; + + Valid_Func : C410001_0.Func_Ref := C410001_0.Func'Access; + + procedure Make_Calls( Expecting_Exceptions : Boolean ) is + type Case_Numbers is range 1..6; + Some_Integer : Integer := 0; + begin + for Cases in Case_Numbers loop + Catch_Exception : begin + case Cases is + when 1 => Proc_Ref_Var.all; + when 2 => Some_Integer := Func_Ref_Var.all( Some_Integer ); + when 3 => Proc_Para_Ref_Var( Valid_Proc ); + when 4 => Some_Integer := Func_Para_Ref_Var( Valid_Func ); + when 5 => Enclosed.Prot_Proc_Ref_Var.all; + when 6 => TCTouch.Assert( Enclosed.Prot_Func_Ref_Var.all + /= Expecting_Exceptions, + "Case 6"); + end case; + if Expecting_Exceptions then + Report.Failed("Exception expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + exception + when Constraint_Error => + if not Expecting_Exceptions then + Report.Failed("Constraint_Error not expected: Case" + & Case_Numbers'Image(Cases) ); + end if; + when others => + Report.Failed("Wrong/Bad Exception: Case" + & Case_Numbers'Image(Cases) ); + end Catch_Exception; + end loop; + end Make_Calls; + + begin -- Main test procedure. + + Report.Test ("C410001", "Check that evaluating an access to subprogram " & + "variable containing the value null causes the " & + "exception Constraint_Error. Check that the " & + "default value for objects of access to " & + "subprogram types is null" ); + + -- check that the default values are null + declare + use C410001_0; -- make all "="'s visible for all types + begin + TCTouch.Assert( Proc_Ref_Var = null, "Proc_Ref_Var = null" ); + + TCTouch.Assert( Func_Ref_Var = null, "Func_Ref_Var = null" ); + + TCTouch.Assert( Proc_Para_Ref_Var = null, "Proc_Para_Ref_Var = null" ); + + TCTouch.Assert( Func_Para_Ref_Var = null, "Func_Para_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Proc_Ref_Var = null, + "Enclosed.Prot_Proc_Ref_Var = null" ); + + TCTouch.Assert( Enclosed.Prot_Func_Ref_Var = null, + "Enclosed.Prot_Func_Ref_Var = null" ); + end; + + -- check that calls via the default values cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + -- assign non-null values to the objects + + Proc_Ref_Var := C410001_0.Proc'Access; + Func_Ref_Var := C410001_0.Func'Access; + Proc_Para_Ref_Var := C410001_0.Proc_Para'Access; + Func_Para_Ref_Var := C410001_0.Func_Para'Access; + Enclosed := (C410001_0.Prot_Obj.Prot_Proc'Access, + C410001_0.Prot_Obj.Prot_Func'Access); + + -- check that the calls perform normally + + C410001_0.Expect_Exception := False; + + Make_Calls( Expecting_Exceptions => False ); + + -- check that a passed null value causes Constraint_Error + + C410001_0.Expect_Exception := True; + + Proc_Para_Ref_Var( null ); + + TCTouch.Assert( Func_Para_Ref_Var( null ) = 1995, + "Func_Para_Ref_Var( null )"); + + -- assign the null value to the objects + + Proc_Ref_Var := null; + Func_Ref_Var := null; + Proc_Para_Ref_Var := null; + Func_Para_Ref_Var := null; + Enclosed := (null,null); + + -- check that calls now again cause Constraint_Error + + C410001_0.Expect_Exception := True; + + Make_Calls( Expecting_Exceptions => True ); + + Report.Result; + + end C410001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41101d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41101d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41101d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41101d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C41101D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR INDEXED COMPONENTS OF THE FORM F(...), CHECK THAT + -- THE NUMBER OF INDEX VALUES, THE TYPE OF THE INDEX + -- VALUES, AND THE REQUIRED TYPE OF THE INDEXED COMPONENT + -- ARE USED TO RESOLVE AN OVERLOADING OF F. + + -- WKB 8/12/81 + -- JBG 10/12/81 + -- SPS 11/1/82 + + WITH REPORT; + PROCEDURE C41101D IS + + USE REPORT; + + TYPE T1 IS ARRAY (1..10) OF INTEGER; + TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER; + I : INTEGER; + + TYPE U1 IS (MON,TUE,WED,THU,FRI); + TYPE U2 IS ARRAY (U1 RANGE MON..THU) OF INTEGER; + + TYPE V1 IS ARRAY (1..10) OF BOOLEAN; + B : BOOLEAN; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN (1..10 => 1); + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN (1..10 => (1..10 => 2)); + END F; + + FUNCTION G RETURN U2 IS + BEGIN + RETURN (MON..THU => 3); + END G; + + FUNCTION G RETURN T1 IS + BEGIN + RETURN (1..10 => 4); + END G; + + FUNCTION H RETURN T1 IS + BEGIN + RETURN (1..10 => 5); + END H; + + FUNCTION H RETURN V1 IS + BEGIN + RETURN (1..10 => FALSE); + END H; + + BEGIN + + TEST ("C41101D", "WHEN INDEXING FUNCTION RESULTS, INDEX TYPE, " & + "NUMBER OF INDICES, AND COMPONENT TYPE ARE " & + "USED FOR OVERLOADING RESOLUTION"); + + I := F(7); -- NUMBER OF INDEX VALUES. + IF I /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE - 1"); + END IF; + + I := G(3); -- INDEX TYPE. + IF I /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE - 2"); + END IF; + + B := H(5); -- COMPONENT TYPE. + IF B /= IDENT_BOOL(FALSE) THEN + FAILED ("WRONG VALUE - 3"); + END IF; + + RESULT; + + END C41101D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41103a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- C41103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAME IN AN INDEXED_COMPONENT MAY BE: + -- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1; + -- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE + -- DESIGNATES AN ARRAY OBJECT - N2; + -- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING + -- A PREDEFINED FUNCTION - &, + -- A USER-DEFINED FUNCTION - F1; + -- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT + -- DESIGNATES AN ARRAY - F2; + -- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3; + -- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT + -- (ARRAY OF ARRAYS) - N4; + -- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT + -- ENCLOSING ITS DECLARATION - C41103A.N1; + -- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE + -- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. + -- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR + -- STATIC INDICES). + + -- WKB 7/27/81 + -- JRK 7/28/81 + -- SPS 10/26/82 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; + USE REPORT; + PROCEDURE C41103A IS + + TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER; + N1 : A1 := (1,2,3,4); + + BEGIN + TEST ("C41103A", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " & + "CERTAIN FORMS AND THAT THE APPROPRIATE " & + "COMPONENT IS ACCESSED (FOR STATIC INDICES)"); + + DECLARE + + TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN; + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4); + N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8), + 3 => (9,10,11,12), 4 => (13,14,15,16)); + N5 : R(4) := (LENGTH => 4, S => "ABCD"); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : IN STRING) IS + BEGIN + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 3 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 8; + Z := 9; + END P1; + + PROCEDURE P2 (X : CHARACTER) IS + BEGIN + IF X /= 'C' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'A' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= 'D' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P5; + + BEGIN + + IF N1(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(2) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4); + P1 (N1(2), N1(3), N1(1), "N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(3) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(3) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (2,1,4,3); + P1 (N2(1), N2(4), N2(2), "N2"); + IF N2.ALL /= (2,9,4,8) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(5) /= CHARACTER'('E') THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(3)); + + IF F1(3) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(3)); + + N2 := NEW A1' (1,2,3,4); + IF F2(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(3) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (1,2,3,4); + P1 (F2(2), F2(3), F2(1), "F2"); + IF N2.ALL /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..5)(5) /= 5 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..5)(2) := 8; + IF N3 /= (1,8,3,4,5,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,2,1,6,7); + P1 (N3(2..5)(4), N3(2..5)(2), N3(2..5)(5), "N3"); + IF N3 /= (5,8,4,2,9,6,7) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(3)(1) := 20; + IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12), + (13,14,15,16)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (0,6,4,2), 2 => (10,11,12,13), + 3 => (14,15,16,17), 4 => (7,5,3,1)); + P1 (N4(1)(4), N4(4)(3), N4(2)(1), "N4"); + IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17), + (7,5,8,1)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4); + IF C41103A.N1(2) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41103A.N1"); + END IF; + C41103A.N1(2) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103A.N1"); + END IF; + N1 := (1,2,3,4); + P1 (C41103A.N1(2), C41103A.N1(3), C41103A.N1(1), + "C41103A.N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41103A.N1"); + END IF; + + IF N5.S(3) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(4) := 'X'; + IF N5.S /= "ABCX" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCD"; + P5 (N5.S(1), N5.S(4), N5.S(2)); + IF N5.S /= "AZCY" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + END; + + RESULT; + END C41103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41103b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41103b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41103b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41103b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,366 ---- + -- C41103B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAME IN AN INDEXED_COMPONENT MAY BE: + -- AN IDENTIFIER DENOTING AN ARRAY OBJECT - N1; + -- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE + -- DESIGNATES AN ARRAY OBJECT - N2; + -- A FUNCTION CALL DELIVERING AN ARRAY OBJECT USING + -- PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS + -- A USER-DEFINED FUNCTION - F1; + -- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT + -- DESIGNATES AN ARRAY - F2; + -- A SLICE (CHECKING UPPER AND LOWER BOUND COMPONENTS) - N3; + -- AN INDEXED COMPONENT DENOTING AN ARRAY OBJECT + -- (ARRAY OF ARRAYS) - N4; + -- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT + -- ENCLOSING ITS DECLARATION - C41103B.N1; + -- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE + -- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. + -- CHECK THAT THE APPROPRIATE COMPONENT IS ACCESSED (FOR + -- DYNAMIC INDICES). + + -- HISTORY: + -- WKB 08/05/81 CREATED ORIGINAL TEST. + -- SPS 10/26/82 + -- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE + -- LOGICAL OPERATORS. + -- BCB 04/16/90 MODIFIED SLICE TEST TO INCLUDE A READING OF THE + -- COMPONENT DESIGNATED BY THE LOWER BOUND OF THE + -- SLICE. ADDED TEST FOR PREFIX OF INDEXED COMPONENT + -- HAVING A LIMITED TYPE. + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; + USE REPORT; + PROCEDURE C41103B IS + + TYPE A1 IS ARRAY (INTEGER RANGE 1..4) OF INTEGER; + N1 : A1 := (1,2,3,4); + + BEGIN + TEST ("C41103B", "CHECK THAT AN INDEXED_COMPONENT MAY BE OF " & + "CERTAIN FORMS AND THAT THE APPROPRIATE " & + "COMPONENT IS ACCESSED (FOR DYNAMIC INDICES)"); + + DECLARE + + TYPE A2 IS ARRAY (INTEGER RANGE 1..4) OF BOOLEAN; + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..4) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4); + N3 : ARRAY (1..7) OF INTEGER := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4), 2 => (5,6,7,8), + 3 => (9,10,11,12), 4 => (13,14,15,16)); + N5 : R(4) := (LENGTH => 4, S => "ABCD"); + + M2A : A2 := (TRUE,FALSE,TRUE,FALSE); + M2B : A2 := (TRUE,TRUE,FALSE,FALSE); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : IN STRING) IS + BEGIN + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 3 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 8; + Z := 9; + END P1; + + PROCEDURE P2 (X : CHARACTER) IS + BEGIN + IF X /= 'C' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'A' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= 'D' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P5; + + PROCEDURE P6 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - NOT"); + END IF; + END P6; + + PROCEDURE P7 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - AND"); + END IF; + END P7; + + PROCEDURE P8 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - OR"); + END IF; + END P8; + + PROCEDURE P9 (X : BOOLEAN) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - XOR"); + END IF; + END P9; + + BEGIN + + IF N1(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(IDENT_INT(2)) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4); + P1 (N1(IDENT_INT(2)), N1(IDENT_INT(3)), + N1(IDENT_INT(1)), "N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(IDENT_INT(3)) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(IDENT_INT(3)) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (2,1,4,3); + P1 (N2(IDENT_INT(1)), N2(IDENT_INT(4)), + N2(IDENT_INT(2)), "N2"); + IF N2.ALL /= (2,9,4,8) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(IDENT_INT(5)) + /= CHARACTER'('E') THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(IDENT_INT(3))); + + IF "NOT" (M2A)(IDENT_INT(4)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'"); + END IF; + P6 ("NOT" (M2A)(IDENT_INT(4))); + + IF "AND" (M2A,M2B)(IDENT_INT(3)) /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'"); + END IF; + P7 ("AND" (M2A,M2B)(IDENT_INT(1))); + + IF "OR" (M2A,M2B)(IDENT_INT(3)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'"); + END IF; + P8 ("OR" (M2A,M2B)(IDENT_INT(3))); + + IF "XOR" (M2A,M2B)(IDENT_INT(1)) /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'"); + END IF; + P9 ("XOR" (M2A,M2B)(IDENT_INT(3))); + + IF F1(IDENT_INT(3)) /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(IDENT_INT(3))); + + N2 := NEW A1'(1,2,3,4); + IF F2(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(IDENT_INT(3)) := 7; + IF N2.ALL /= (1,2,7,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (1,2,3,4); + P1 (F2(IDENT_INT(2)), F2(IDENT_INT(3)), + F2(IDENT_INT(1)), "F2"); + IF N2.ALL /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..5)(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION (LOWER BOUND) - N3"); + END IF; + IF N3(2..5)(IDENT_INT(5)) /= 5 THEN + FAILED ("WRONG VALUE FOR EXPRESSION (UPPER BOUND) - N3"); + END IF; + N3(2..5)(IDENT_INT(2)) := 8; + IF N3 /= (1,8,3,4,5,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,2,1,6,7); + P1 (N3(2..5)(IDENT_INT(4)), N3(2..5)(IDENT_INT(2)), + N3(2..5)(IDENT_INT(5)), "N3"); + IF N3 /= (5,8,4,2,9,6,7) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(3)(IDENT_INT(1)) := 20; + IF N4 /= ((1,2,3,4),(5,6,7,8),(20,10,11,12), + (13,14,15,16)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (0,6,4,2), 2 => (10,11,12,13), + 3 => (14,15,16,17), 4 => (7,5,3,1)); + P1 (N4(1)(IDENT_INT(4)), N4(4)(IDENT_INT(3)), + N4(2)(IDENT_INT(1)), "N4"); + IF N4 /= ((0,6,4,2),(9,11,12,13),(14,15,16,17), + (7,5,8,1)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4); + IF C41103B.N1(IDENT_INT(2)) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41103B.N1"); + END IF; + C41103B.N1(IDENT_INT(2)) := 7; + IF N1 /= (1,7,3,4) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41103B.N1"); + END IF; + N1 := (1,2,3,4); + P1 (C41103B.N1(IDENT_INT(2)), C41103B.N1(IDENT_INT(3)), + C41103B.N1(IDENT_INT(1)), "C41103B.N1"); + IF N1 /= (9,2,8,4) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41103B.N1"); + END IF; + + IF N5.S(IDENT_INT(3)) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(IDENT_INT(4)) := 'X'; + IF N5.S /= "ABCX" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCD"; + P5 (N5.S(IDENT_INT(1)), N5.S(IDENT_INT(4)), + N5.S(IDENT_INT(2))); + IF N5.S /= "AZCY" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + + DECLARE + PACKAGE P IS + TYPE LIM IS LIMITED PRIVATE; + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER); + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM); + FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN; + PRIVATE + TYPE LIM IS ARRAY(1..3) OF INTEGER; + END P; + + USE P; + + TYPE A IS ARRAY(1..3) OF LIM; + + H : A; + + N6 : LIM; + + PACKAGE BODY P IS + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS + BEGIN + V := (X,Y,Z); + END INIT; + + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS + BEGIN + ONE := TWO; + END ASSIGN; + + FUNCTION "=" (ONE,TWO : LIM) RETURN BOOLEAN IS + BEGIN + IF ONE(1) = TWO(1) AND ONE(2) = TWO(2) AND + ONE(3) = TWO(3) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END "="; + END P; + + FUNCTION FR RETURN A IS + BEGIN + RETURN H; + END FR; + + BEGIN + INIT (H(1),1,2,3); + INIT (H(2),4,5,6); + INIT (H(3),7,8,9); + INIT (N6,0,0,0); + + ASSIGN (N6,FR(2)); + + IF N6 /= FR(2) THEN + FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE"); + END IF; + + END; + END; + + RESULT; + END C41103B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41104a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,240 ---- + -- C41104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF AN EXPRESSION GIVES AN INDEX + -- VALUE OUTSIDE THE RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND ACCESS + -- TYPES. + + -- TBN 9/12/86 + -- EDS 8/03/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C41104A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + SUBTYPE BOOL IS BOOLEAN RANGE TRUE .. TRUE; + SUBTYPE CHAR IS CHARACTER RANGE 'W' .. 'Z'; + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY2 IS ARRAY (3 .. 1) OF INTEGER; + TYPE ARRAY3 IS ARRAY (BOOL RANGE <>) OF INTEGER; + TYPE ARRAY4 IS ARRAY (CHAR RANGE <>) OF INTEGER; + + TYPE REC (D : INT) IS + RECORD + A : ARRAY1 (1 .. D); + END RECORD; + + TYPE B_REC (D : BOOL) IS + RECORD + A : ARRAY3 (TRUE .. D); + END RECORD; + + TYPE NULL_REC (D : INT) IS + RECORD + A : ARRAY1 (D .. 1); + END RECORD; + + TYPE NULL_CREC (D : CHAR) IS + RECORD + A : ARRAY4 (D .. 'W'); + END RECORD; + + BEGIN + TEST ("C41104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF AN " & + "EXPRESSION GIVES AN INDEX VALUE OUTSIDE THE " & + "RANGE SPECIFIED FOR THE INDEX FOR ARRAYS AND " & + "ACCESS TYPES"); + + DECLARE + ARA1 : ARRAY1 (1 .. 5) := (1, 2, 3, 4, 5); + BEGIN + ARA1 (IDENT_INT(0)) := 1; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ARA1 (1))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + ------------------------------------------------------------------------ + DECLARE + TYPE ACC_ARRAY IS ACCESS ARRAY3 (TRUE .. TRUE); + ACC_ARA : ACC_ARRAY := NEW ARRAY3'(TRUE => 2); + BEGIN + ACC_ARA (IDENT_BOOL(FALSE)) := 2; + + BEGIN + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ACC_ARA (TRUE))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + ------------------------------------------------------------------------ + DECLARE + ARA2 : ARRAY4 ('Z' .. 'Y'); + BEGIN + ARA2 (IDENT_CHAR('Y')) := 3; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); + + BEGIN + COMMENT ("ARA2 (Y) IS " & INTEGER'IMAGE(ARA2 ('Y'))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + ------------------------------------------------------------------------ + DECLARE + TYPE ACC_ARRAY IS ACCESS ARRAY2; + ACC_ARA : ACC_ARRAY := NEW ARRAY2; + BEGIN + ACC_ARA (IDENT_INT(4)) := 4; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); + + BEGIN + COMMENT ("ACC_ARA (4) IS " & INTEGER'IMAGE(ACC_ARA (4))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; + ------------------------------------------------------------------------ + DECLARE + REC1 : B_REC (TRUE) := (TRUE, A => (TRUE => 5)); + BEGIN + REC1.A (IDENT_BOOL (FALSE)) := 1; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(REC1.A (TRUE))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 5"); + END; + ------------------------------------------------------------------------ + DECLARE + TYPE ACC_REC IS ACCESS REC (3); + ACC_REC1 : ACC_REC := NEW REC'(3, (4, 5, 6)); + BEGIN + ACC_REC1.A (IDENT_INT(4)) := 4; + + BEGIN + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - " & + INTEGER'IMAGE(ACC_REC1.A (3))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6"); + END; + ------------------------------------------------------------------------ + DECLARE + REC1 : NULL_REC (2); + BEGIN + REC1.A (IDENT_INT(2)) := 1; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); + + BEGIN + COMMENT ("REC1.A (2) IS " & INTEGER'IMAGE(REC1.A (2))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 7"); + END; + ------------------------------------------------------------------------ + DECLARE + TYPE ACC_REC IS ACCESS NULL_CREC ('Z'); + ACC_REC1 : ACC_REC := NEW NULL_CREC ('Z'); + BEGIN + ACC_REC1.A (IDENT_CHAR('A')) := 4; + + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); + BEGIN + COMMENT ("ACC_REC1.A (A) IS " & + INTEGER'IMAGE(ACC_REC1.A ('A'))); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION ON ATTEMPT TO USE OBJECT"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 8"); + END; + ------------------------------------------------------------------------ + + RESULT; + END C41104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41105a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41105a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41105a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41105a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C41105A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE NAME PART OF AN + -- INDEXED COMPONENT DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL, + -- AND ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL. + + -- HISTORY: + -- WKB 07/29/81 CREATED ORIGINAL TEST. + -- SPS 10/26/82 + -- JET 01/05/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT + -- OPTIMIZATION. + + WITH REPORT; + USE REPORT; + PROCEDURE C41105A IS + + BEGIN + TEST ("C41105A", "CONSTRAINT_ERROR FROM NAMES DENOTING A NULL " & + "ACCESS OBJECT AND A FUNCTION CALL DELIVERING " & + "NULL"); + + DECLARE + + TYPE T1 IS ARRAY (1..2) OF INTEGER; + TYPE A1 IS ACCESS T1; + B : A1 := NEW T1' (1,2); + I : INTEGER; + + BEGIN + + IF EQUAL (3,3) THEN + B := NULL; + END IF; + + I := B(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + + IF EQUAL (I,I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + + END; + + + DECLARE + + TYPE T2 IS ARRAY (1..2) OF INTEGER; + TYPE A2 IS ACCESS T2; + I : INTEGER; + + FUNCTION F RETURN A2 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN NULL; + END IF; + RETURN NEW T2' (1,2); + END F; + + BEGIN + + I := F(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + + IF EQUAL (I,I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + + END; + + RESULT; + END C41105A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41107a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C41107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR AN ARRAY HAVING BOTH POSITIVE AND NEGATIVE + -- INDEX VALUES, THE PROPER COMPONENT IS SELECTED - A. + -- CHECK THAT FOR AN ARRAY INDEXED WITH AN ENUMERATION TYPE, + -- APPROPRIATE COMPONENTS CAN BE SELECTED - B. + -- CHECK THAT SUBSCRIPT EXPRESSIONS CAN BE OF COMPLEXITY GREATER + -- THAN VARIABLE + - CONSTANT - C. + -- CHECK THAT MULTIPLY DIMENSIONED ARRAYS ARE PROPERLY INDEXED - D. + + -- WKB 7/29/81 + -- JBG 8/21/83 + + WITH REPORT; + USE REPORT; + PROCEDURE C41107A IS + + TYPE T1 IS ARRAY (INTEGER RANGE -2..2) OF INTEGER; + A : T1 := (1,2,3,4,5); + + TYPE COLOR IS (RED,ORANGE,YELLOW,GREEN,BLUE); + TYPE T2 IS ARRAY (COLOR RANGE RED..BLUE) OF INTEGER; + B : T2 := (5,4,3,2,1); + + C : STRING (1..7) := "ABCDEFG"; + + TYPE T4 IS ARRAY (1..4,1..3) OF INTEGER; + D : T4 := (1 => (1,2,3), 2 => (4,5,6), 3 => (7,8,9), + 4 => (0,-1,-2)); + + V1 : INTEGER := IDENT_INT (1); + V2 : INTEGER := IDENT_INT (2); + V3 : INTEGER := IDENT_INT (3); + + PROCEDURE P1 (X : IN INTEGER; Y : IN OUT INTEGER; + Z : OUT INTEGER; W : STRING) IS + BEGIN + IF X /= 1 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 4 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 11; + Z := 12; + END P1; + + PROCEDURE P2 (X : IN CHARACTER; Y : IN OUT CHARACTER; + Z : OUT CHARACTER) IS + BEGIN + IF X /= 'D' THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - C"); + END IF; + IF Y /= 'F' THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - C"); + END IF; + Y := 'Y'; + Z := 'Z'; + END P2; + + BEGIN + TEST ("C41107A", "CHECK THAT THE PROPER COMPONENT IS SELECTED " & + "FOR ARRAYS WITH POS AND NEG INDICES, " & + "ENUMERATION INDICES, COMPLEX SUBSCRIPT " & + "EXPRESSIONS, AND MULTIPLE DIMENSIONS"); + + IF A(IDENT_INT(1)) /= 4 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - A"); + END IF; + A(IDENT_INT(-2)) := 10; + IF A /= (10,2,3,4,5) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - A"); + END IF; + A := (2,1,0,3,4); + P1 (A(-1), A(2), A(-2), "A"); + IF A /= (12,1,0,3,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - A"); + END IF; + + IF B(GREEN) /= 2 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - B"); + END IF; + B(YELLOW) := 10; + IF B /= (5,4,10,2,1) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - B"); + END IF; + B := (1,4,2,3,5); + P1 (B(RED), B(ORANGE), B(BLUE), "B"); + IF B /= (1,11,2,3,12) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - B"); + END IF; + + IF C(3..6)(3**2 / 3 * (2-1) - 6 / 3 + 2) /= 'C' THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C"); + END IF; + C(3..6)(V3**2 / V1 * (V3-V2) + IDENT_INT(4) - V3 * V2 - V1) := 'W'; + IF C /= "ABCDEWG" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C"); + END IF; + C := "ABCDEFG"; + P2 (C(3..6)(V3+V1), C(3..6)(V3*V2), C(3..6)((V1+V2)*V1)); + IF C /= "ABZDEYG" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - C"); + END IF; + + IF D(IDENT_INT(1),IDENT_INT(3)) /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - D"); + END IF; + D(IDENT_INT(4),IDENT_INT(2)) := 10; + IF D /= ((1,2,3),(4,5,6),(7,8,9),(0,10,-2)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - D"); + END IF; + D := (1 => (0,2,3), 2 => (4,5,6), 3 => (7,8,9), 4 => (1,-1,-2)); + P1 (D(4,1), D(2,1), D(3,2), "D"); + IF D /= ((0,2,3),(11,5,6),(7,12,9),(1,-1,-2)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - D"); + END IF; + + RESULT; + END C41107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41201d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41201d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41201d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41201d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C41201D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR SLICED COMPONENTS OF THE FORM F(...), CHECK THAT + -- THE REQUIREMENT FOR A ONE-DIMENSIONAL ARRAY AND THE + -- TYPE OF THE INDEX ARE USED TO RESOLVE AN OVERLOADING OF F. + + -- WKB 8/11/81 + -- JBG 10/12/81 + -- SPS 11/1/82 + + WITH REPORT; + PROCEDURE C41201D IS + + USE REPORT; + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T(1..10); + TYPE T2 IS ARRAY (1..10, 1..10) OF INTEGER; + TT : T(1..3); + + SUBTYPE U1 IS T(1..10); + TYPE U2 IS (MON,TUE,WED,THU,FRI); + SUBTYPE SU2 IS U2 RANGE MON .. THU; + TYPE U3 IS ARRAY (SU2) OF INTEGER; + UU : T(1..3); + + TYPE V IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE V1 IS V(1..10); + SUBTYPE V2 IS T(1..10); + VV : V(2..5); + + FUNCTION F RETURN T1 IS + BEGIN + RETURN (1,1,1,1,5,6,7,8,9,10); + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN (1..10 => (1,2,3,4,5,6,7,8,9,10)); + END F; + + FUNCTION G RETURN U1 IS + BEGIN + RETURN (3,3,3,3,5,6,7,8,9,10); + END G; + + FUNCTION G RETURN U3 IS + BEGIN + RETURN (0,1,2,3); + END G; + + FUNCTION H RETURN V1 IS + BEGIN + RETURN (1|3..10 => FALSE, 2 => IDENT_BOOL(TRUE)); + END H; + + FUNCTION H RETURN V2 IS + BEGIN + RETURN (1..10 => 5); + END H; + + BEGIN + + TEST ("C41201D", "WHEN SLICING FUNCTION RESULTS, TYPE OF " & + "RESULT IS USED FOR OVERLOADING RESOLUTION"); + + IF F(1..3) /= + F(IDENT_INT(2)..IDENT_INT(4)) THEN -- NUMBER OF DIMENSIONS. + FAILED ("WRONG VALUE - 1"); + END IF; + + IF G(1..3) /= + G(IDENT_INT(2)..IDENT_INT(4)) THEN -- INDEX TYPE. + FAILED ("WRONG VALUE - 2"); + END IF; + + IF NOT IDENT_BOOL(H(2..3)(2)) THEN -- COMPONENT TYPE. + FAILED ("WRONG VALUE - 3"); + END IF; + + RESULT; + + END C41201D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41203a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,241 ---- + -- C41203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAME PART OF A SLICE MAY BE: + -- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1; + -- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE + -- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2; + -- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT USING + -- A PREDEFINED FUNCTION - &, + -- A USER-DEFINED FUNCTION - F1; + -- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT + -- DESIGNATES A ONE DIMENSIONAL ARRAY - F2; + -- A SLICE - N3; + -- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT + -- (ARRAY OF ARRAYS) - N4; + -- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT + -- ENCLOSING ITS DECLARATION - C41203A.N1; + -- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE + -- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. + -- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR + -- STATIC INDICES). + + -- WKB 8/5/81 + -- SPS 11/1/82 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; + USE REPORT; + PROCEDURE C41203A IS + + TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE A1 IS T1 (1..6); + N1 : A1 := (1,2,3,4,5,6); + + BEGIN + TEST ("C41203A", "CHECK THAT THE NAME PART OF A SLICE MAY BE " & + "OF CERTAIN FORMS AND THAT THE APPROPRIATE " & + "SLICE IS ACCESSED (FOR STATIC INDICES)"); + + DECLARE + + TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE A2 IS T2 (1..6); + TYPE A3 IS ACCESS A1; + SUBTYPE SI IS INTEGER RANGE 1 .. 3; + TYPE A4 IS ARRAY (SI) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1' (1,2,3,4,5,6); + N3 : T1 (1..7) := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12), + 3 => (13,14,15,16,17,18)); + N5 : R(6) := (LENGTH => 6, S => "ABCDEF"); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN T1; Y : IN OUT T1; + Z : OUT T1; W : IN STRING) IS + BEGIN + IF X /= (1,2) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= (3,4) THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := (10,11); + Z := (12,13); + END P1; + + PROCEDURE P2 (X : STRING) IS + BEGIN + IF X /= "BC" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING; + Z : OUT STRING) IS + BEGIN + IF X /= "EF" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= "CD" THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := "XY"; + Z := "WZ"; + END P5; + + BEGIN + + IF N1(1..2) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(1..2) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (N1(1..2), N1(3..4), N1(5..6), "N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(4..6) /= (4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(4..6) := (7,8,9); + IF N2.ALL /= (1,2,3,7,8,9) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (1,2,5,6,3,4); + P1 (N2(1..2), N2(5..6), N2(3..4), "N2"); + IF N2.ALL /= (1,2,12,13,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"), STRING'("CDEF"))(4..6) /= STRING'("DEF") THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB", "CD")(2..3)); + + IF F1(1..2) /= (FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(2..4)); + + N2 := NEW A1' (1,2,3,4,5,6); + IF F2(2..6) /= (2,3,4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(3..3) := (5 => 7); + IF N2.ALL /= (1,2,7,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (5,6,1,2,3,4); + P1 (F2(3..4), F2(5..6), F2(1..2), "F2"); + IF N2.ALL /= (12,13,1,2,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..7)(2..4) /= (2,3,4) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..7)(4..5) := (8,9); + IF N3 /= (1,2,3,8,9,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,1,2,6,7); + P1 (N3(2..7)(4..5), N3(2..7)(2..3), N3(2..7)(6..7), "N3"); + IF N3 /= (5,10,11,1,2,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(3..5) /= (3,4,5) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(2)(1..3) := (21,22,23); + IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12), + (13,14,15,16,17,18)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14), + 3 => (7,3,4,5,6,8)); + P1 (N4(2)(4..5), N4(3)(2..3), N4(1)(5..6), "N4"); + IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14), + (7,10,11,5,6,8)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4,5,6); + IF C41203A.N1(1..2) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41203A.N1"); + END IF; + C41203A.N1(1..2) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203A.N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (C41203A.N1(1..2), C41203A.N1(3..4), C41203A.N1(5..6), + "C41203A.N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41203A.N1"); + END IF; + + IF N5.S(1..5) /= "ABCDE" THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(4..6) := "PQR"; + IF N5.S /= "ABCPQR" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCDEF"; + P5 (N5.S(5..6), N5.S(3..4), N5.S(1..2)); + IF N5.S /= "WZXYEF" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + END; + + RESULT; + END C41203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41203b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41203b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41203b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41203b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,378 ---- + -- C41203B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAME PART OF A SLICE MAY BE: + -- AN IDENTIFIER DENOTING A ONE DIMENSIONAL ARRAY OBJECT - N1; + -- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE + -- DESIGNATES A ONE DIMENSIONAL ARRAY OBJECT - N2; + -- A FUNCTION CALL DELIVERING A ONE DIMENSIONAL ARRAY OBJECT + -- USING PREDEFINED FUNCTIONS - &, AND THE LOGICAL OPERATORS + -- A USER-DEFINED FUNCTION - F1; + -- A FUNCTION CALL DELIVERING AN ACCESS VALUE THAT + -- DESIGNATES A ONE DIMENSIONAL ARRAY - F2; + -- A SLICE - N3; + -- AN INDEXED COMPONENT DENOTING A ONE DIMENSIONAL ARRAY OBJECT + -- (ARRAY OF ARRAYS) - N4; + -- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT + -- ENCLOSING ITS DECLARATION - C41203B.N1; + -- A RECORD COMPONENT (OF A RECORD CONTAINING ONE OR MORE + -- ARRAYS WHOSE BOUNDS DEPEND ON A DISCRIMINANT) - N5. + -- CHECK THAT THE APPROPRIATE SLICE IS ACCESSED (FOR + -- DYNAMIC INDICES). + + -- HISTORY: + -- WKB 08/05/81 CREATED ORIGINAL TEST. + -- SPS 02/04/83 + -- BCB 08/02/88 MODIFIED HEADER FORMAT AND ADDED CALLS TO THE + -- LOGICAL OPERATORS. + -- BCB 04/16/90 ADDED TEST FOR PREFIX OF INDEXED COMPONENT HAVING + -- A LIMITED TYPE. + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; + USE REPORT; + PROCEDURE C41203B IS + + TYPE T1 IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE A1 IS T1 (1..6); + N1 : A1 := (1,2,3,4,5,6); + + BEGIN + TEST ("C41203B", "CHECK THAT THE NAME PART OF A SLICE MAY BE " & + "OF CERTAIN FORMS AND THAT THE APPROPRIATE " & + "SLICE IS ACCESSED (FOR DYNAMIC INDICES)"); + + DECLARE + + TYPE T2 IS ARRAY (INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE A2 IS T2 (1..6); + TYPE A3 IS ACCESS A1; + TYPE A4 IS ARRAY (INTEGER RANGE 1..3 ) OF A1; + TYPE R (LENGTH : INTEGER) IS + RECORD + S : STRING (1..LENGTH); + END RECORD; + + N2 : A3 := NEW A1'(1,2,3,4,5,6); + N3 : T1(1..7) := (1,2,3,4,5,6,7); + N4 : A4 := (1 => (1,2,3,4,5,6), 2 => (7,8,9,10,11,12), + 3 => (13,14,15,16,17,18)); + N5 : R(6) := (LENGTH => 6, S => "ABCDEF"); + + M2A : A2 := (TRUE,TRUE,TRUE,FALSE,FALSE,FALSE); + M2B : A2 := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + + FUNCTION F1 RETURN A2 IS + BEGIN + RETURN (FALSE,FALSE,TRUE,FALSE,TRUE,TRUE); + END F1; + + FUNCTION F2 RETURN A3 IS + BEGIN + RETURN N2; + END F2; + + PROCEDURE P1 (X : IN T1; Y : IN OUT T1; + Z : OUT T1; W : IN STRING) IS + BEGIN + IF X /= (1,2) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= (3,4) THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := (10,11); + Z := (12,13); + END P1; + + PROCEDURE P2 (X : STRING) IS + BEGIN + IF X /= "BC" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - '&'"); + END IF; + END P2; + + PROCEDURE P3 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P3; + + PROCEDURE P5 (X : IN STRING; Y : IN OUT STRING; + Z : OUT STRING) IS + BEGIN + IF X /= "EF" THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - N5"); + END IF; + IF Y /= "CD" THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - N5"); + END IF; + Y := "XY"; + Z := "WZ"; + END P5; + + PROCEDURE P6 (X : T2) IS + BEGIN + IF X /= (FALSE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - NOT"); + END IF; + END P6; + + PROCEDURE P7 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - AND"); + END IF; + END P7; + + PROCEDURE P8 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - OR"); + END IF; + END P8; + + PROCEDURE P9 (X : T2) IS + BEGIN + IF X /= (FALSE,TRUE,FALSE) THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - XOR"); + END IF; + END P9; + + BEGIN + + IF N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N1"); + END IF; + N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (N1(IDENT_INT(1)..IDENT_INT(2)), + N1(IDENT_INT(3)..IDENT_INT(4)), + N1(IDENT_INT(5)..IDENT_INT(6)), "N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N1"); + END IF; + + IF N2(IDENT_INT(4)..IDENT_INT(6)) /= (4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N2"); + END IF; + N2(IDENT_INT(4)..IDENT_INT(6)) := (7,8,9); + IF N2.ALL /= (1,2,3,7,8,9) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N2"); + END IF; + N2.ALL := (1,2,5,6,3,4); + P1 (N2(IDENT_INT(1)..IDENT_INT(2)), + N2(IDENT_INT(5)..IDENT_INT(6)), + N2(IDENT_INT(3)..IDENT_INT(4)), "N2"); + IF N2.ALL /= (1,2,12,13,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N2"); + END IF; + + IF "&" (STRING'("AB"),STRING'("CDEF"))(IDENT_INT(4)..IDENT_INT(6)) + /= STRING'("DEF") THEN + FAILED ("WRONG VALUE FOR EXPRESSION - '&'"); + END IF; + P2 ("&" ("AB","CD")(IDENT_INT(2)..IDENT_INT(3))); + + IF "NOT" (M2A)(IDENT_INT(3)..IDENT_INT(5)) /= + (FALSE,TRUE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'NOT'"); + END IF; + P6 ("NOT" (M2A)(IDENT_INT(2)..IDENT_INT(4))); + + IF "AND" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (TRUE,FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'AND'"); + END IF; + P7 ("AND" (M2A,M2B)(IDENT_INT(2)..IDENT_INT(4))); + + IF "OR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (TRUE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'OR'"); + END IF; + P8 ("OR" (M2A,M2B)(IDENT_INT(4)..IDENT_INT(6))); + + IF "XOR" (M2A,M2B)(IDENT_INT(3)..IDENT_INT(5)) /= + (FALSE,FALSE,TRUE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - 'XOR'"); + END IF; + P9 ("XOR" (M2A,M2B)(IDENT_INT(1)..IDENT_INT(3))); + + IF F1(IDENT_INT(1)..IDENT_INT(2)) /= (FALSE,FALSE) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P3 (F1(IDENT_INT(2)..IDENT_INT(4))); + + N2 := NEW A1'(1,2,3,4,5,6); + IF F2(IDENT_INT(2)..IDENT_INT(6)) /= (2,3,4,5,6) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2(IDENT_INT(3)..IDENT_INT(3)) := (5 => 7); + IF N2.ALL /= (1,2,7,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + N2.ALL := (5,6,1,2,3,4); + P1 (F2(IDENT_INT(3)..IDENT_INT(4)), + F2(IDENT_INT(5)..IDENT_INT(6)), + F2(IDENT_INT(1)..IDENT_INT(2)), "F2"); + IF N2.ALL /= (12,13,1,2,10,11) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF N3(2..7)(IDENT_INT(2)..IDENT_INT(4)) /= (2,3,4) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N3"); + END IF; + N3(2..7)(IDENT_INT(4)..IDENT_INT(5)) := (8,9); + IF N3 /= (1,2,3,8,9,6,7) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N3"); + END IF; + N3 := (5,3,4,1,2,6,7); + P1 (N3(2..7)(IDENT_INT(4)..IDENT_INT(5)), + N3(2..7)(IDENT_INT(2)..IDENT_INT(3)), + N3(2..7)(IDENT_INT(6)..IDENT_INT(7)), "N3"); + IF N3 /= (5,10,11,1,2,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N3"); + END IF; + + IF N4(1)(IDENT_INT(3)..IDENT_INT(5)) /= (3,4,5) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N4"); + END IF; + N4(2)(IDENT_INT(1)..IDENT_INT(3)) := (21,22,23); + IF N4 /= ((1,2,3,4,5,6),(21,22,23,10,11,12), + (13,14,15,16,17,18)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N4"); + END IF; + N4 := (1 => (18,19,20,21,22,23), 2 => (17,16,15,1,2,14), + 3 => (7,3,4,5,6,8)); + P1 (N4(2)(IDENT_INT(4)..IDENT_INT(5)), + N4(3)(IDENT_INT(2)..IDENT_INT(3)), + N4(1)(IDENT_INT(5)..IDENT_INT(6)), "N4"); + IF N4 /= ((18,19,20,21,12,13),(17,16,15,1,2,14), + (7,10,11,5,6,8)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N4"); + END IF; + + N1 := (1,2,3,4,5,6); + IF C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) /= (1,2) THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41203B.N1"); + END IF; + C41203B.N1(IDENT_INT(1)..IDENT_INT(2)) := (7,8); + IF N1 /= (7,8,3,4,5,6) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41203B.N1"); + END IF; + N1 := (1,2,3,4,5,6); + P1 (C41203B.N1(IDENT_INT(1)..IDENT_INT(2)), + C41203B.N1(IDENT_INT(3)..IDENT_INT(4)), + C41203B.N1(IDENT_INT(5)..IDENT_INT(6)), "C41203B.N1"); + IF N1 /= (1,2,10,11,12,13) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER " & + "- C41203B.N1"); + END IF; + + IF N5.S(IDENT_INT(1)..IDENT_INT(5)) /= "ABCDE" THEN + FAILED ("WRONG VALUE FOR EXPRESSION - N5"); + END IF; + N5.S(IDENT_INT(4)..IDENT_INT(6)) := "PQR"; + IF N5.S /= "ABCPQR" THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - N5"); + END IF; + N5.S := "ABCDEF"; + P5 (N5.S(IDENT_INT(5)..IDENT_INT(6)), + N5.S(IDENT_INT(3)..IDENT_INT(4)), + N5.S(IDENT_INT(1)..IDENT_INT(2))); + IF N5.S /= "WZXYEF" THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - N5"); + END IF; + + DECLARE + PACKAGE P IS + TYPE LIM IS LIMITED PRIVATE; + TYPE A IS ARRAY(INTEGER RANGE <>) OF LIM; + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER); + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM); + FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN; + PRIVATE + TYPE LIM IS ARRAY(1..3) OF INTEGER; + END P; + + USE P; + + H : A(1..5); + + N6 : A(1..3); + + PACKAGE BODY P IS + PROCEDURE INIT (V : OUT LIM; X,Y,Z : INTEGER) IS + BEGIN + V := (X,Y,Z); + END INIT; + + PROCEDURE ASSIGN (ONE : OUT LIM; TWO : LIM) IS + BEGIN + ONE := TWO; + END ASSIGN; + + FUNCTION "=" (ONE,TWO : A) RETURN BOOLEAN IS + BEGIN + IF ONE(1) = TWO(2) AND ONE(2) = TWO(3) AND + ONE(3) = TWO(4) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END "="; + END P; + + FUNCTION FR RETURN A IS + BEGIN + RETURN H; + END FR; + + BEGIN + INIT (H(1),1,2,3); + INIT (H(2),4,5,6); + INIT (H(3),7,8,9); + INIT (H(4),10,11,12); + INIT (H(5),13,14,15); + INIT (N6(1),0,0,0); + INIT (N6(2),0,0,0); + INIT (N6(3),0,0,0); + + ASSIGN (N6(1),H(2)); + ASSIGN (N6(2),H(3)); + ASSIGN (N6(3),H(4)); + + IF N6 /= FR(2..4) THEN + FAILED ("WRONG VALUE FROM LIMITED COMPONENT TYPE"); + END IF; + END; + END; + + RESULT; + END C41203B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41204a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C41204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A SLICE'S DISCRETE + -- RANGE IS NOT NULL, AND ITS LOWER OR UPPER BOUND IS NOT A + -- POSSIBLE INDEX FOR THE NAMED ARRAY. + + -- WKB 8/4/81 + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; + USE REPORT; + PROCEDURE C41204A IS + + BEGIN + TEST ("C41204A", "ILLEGAL UPPER OR LOWER BOUNDS FOR A " & + "SLICE RAISES CONSTRAINT_ERROR"); + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + A : T (10..15) := (10,11,12,13,14,15); + B : T (-20..30); + + BEGIN + + BEGIN + B (IDENT_INT(9)..12) := A (IDENT_INT(9)..12); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1" & + INTEGER'IMAGE(B(10))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + END; + + BEGIN + B (IDENT_INT(-12)..14) := A (IDENT_INT(-12)..14); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2" & + INTEGER'IMAGE(B(10))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + END; + + BEGIN + B (11..IDENT_INT(16)) := A (11..IDENT_INT(16)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3" & + INTEGER'IMAGE(B(15))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 3"); + END; + + BEGIN + B (17..20) := A (IDENT_INT(17)..IDENT_INT(20)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4" & + INTEGER'IMAGE(B(17))); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 4"); + END; + END; + + RESULT; + END C41204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41205a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41205a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41205a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41205a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C41205A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE NAME PART OF A + -- SLICE DENOTES AN ACCESS OBJECT WHOSE VALUE IS NULL, AND + -- ALSO IF THE NAME IS A FUNCTION CALL DELIVERING NULL. + + -- WKB 8/6/81 + -- SPS 10/26/82 + -- EDS 07/14/98 AVOID OPTIMIZATION + + WITH REPORT; + USE REPORT; + PROCEDURE C41205A IS + + BEGIN + TEST ("C41205A", "CONSTRAINT_ERROR WHEN THE NAME PART OF A " & + "SLICE DENOTES A NULL ACCESS OBJECT OR A " & + "FUNCTION CALL DELIVERING NULL"); + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T (1..5); + TYPE A1 IS ACCESS T1; + B : A1 := NEW T1' (1,2,3,4,5); + I : T (2..3); + + BEGIN + + IF EQUAL (3,3) THEN + B := NULL; + END IF; + + I := B(2..3); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & INTEGER'IMAGE(I(2))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 1"); + + END; + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <> ) OF INTEGER; + SUBTYPE T2 IS T (1..5); + TYPE A2 IS ACCESS T2; + I : T (2..5); + + FUNCTION F RETURN A2 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN NULL; + END IF; + RETURN NEW T2' (1,2,3,4,5); + END F; + + BEGIN + + I := F(2..5); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " & INTEGER'IMAGE(I(2))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + + END; + + RESULT; + END C41205A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41206a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C41206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RANGE L..R, WHERE L=SUCC(R) CAN BE USED TO FORM + -- A NULL SLICE FROM AN ARRAY WHEN: + -- BOTH L AND R SATISFY THE INDEX CONSTRAINT; + -- L SATISFIES THE INDEX CONSTRAINT, R DOES NOT (BUT IT + -- BELONGS TO THE BASE TYPE OF THE INDEX); + -- L SATISFIES THE CONSTRAINT IMPOSED BY THE TYPE MARK OF + -- THE INDEX, BUT NOT THE CONSTRAINT ASSOCIATED WITH + -- THE INDEX; + -- THE ARRAY IS NULL, AND L IS IN THE RANGE OF THE INDEX SUBTYPE. + + -- WKB 8/10/81 + + WITH REPORT; + USE REPORT; + PROCEDURE C41206A IS + + TYPE SMALL IS RANGE 1..100; + TYPE T IS ARRAY (SMALL RANGE <> ) OF INTEGER; + SUBTYPE T1 IS T(5..10); + A : T1 := (5,6,7,8,9,10); + B : T(8..7) := (8..7 => 1); + + BEGIN + TEST ("C41206A", "USING A RANGE L..R, WHERE L=SUCC(R), " & + "TO FORM A NULL SLICE FROM AN ARRAY"); + + BEGIN + IF A (7..6) /= B OR A (SMALL(IDENT_INT(7))..6) /= B THEN + FAILED ("SLICE NOT NULL - 1"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + IF A (5..4) /= B OR A (SMALL(IDENT_INT(5))..4) /= B THEN + FAILED ("SLICE NOT NULL - 2"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 2"); + END; + + BEGIN + IF A (50..49) /= B OR A (SMALL(IDENT_INT(50))..49) /= B THEN + FAILED ("SLICE NOT NULL - 3"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 3"); + END; + + BEGIN + IF B (50..49) /= B OR B (SMALL(IDENT_INT(50))..49) /= B THEN + FAILED ("SLICE NOT NULL - 4"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RAISED - 4"); + END; + + RESULT; + END C41206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41207a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41207a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41207a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41207a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C41207A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DISCRETE RANGE IN A SLICE CAN HAVE THE FORM + -- A'RANGE, WHERE A IS A CONSTRAINED ARRAY SUBTYPE OR AN ARRAY + -- OBJECT. + + -- HISTORY: + -- BCB 07/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C41207A IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + SUBTYPE A1 IS ARR(1..5); + + ARR_VAR : ARR(1..10) := (90,91,92,93,94,95,96,97,98,99); + + A2 : ARRAY(1..5) OF INTEGER := (80,81,82,83,84); + + BEGIN + TEST ("C41207A", "CHECK THAT THE DISCRETE RANGE IN A SLICE CAN " & + "HAVE THE FORM A'RANGE, WHERE A IS A " & + "CONSTRAINED ARRAY SUBTYPE OR AN ARRAY OBJECT"); + + ARR_VAR (A1'RANGE) := (1,2,3,4,5); + + IF NOT (EQUAL(ARR_VAR(1),1) AND EQUAL(ARR_VAR(2),2) AND + EQUAL(ARR_VAR(3),3) AND EQUAL(ARR_VAR(4),4) AND + EQUAL(ARR_VAR(5),5)) THEN + FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " & + "RANGE OF A CONSTRAINED ARRAY SUBTYPE"); + END IF; + + ARR_VAR (A2'RANGE) := (6,7,8,9,10); + + IF (NOT EQUAL(ARR_VAR(1),6) OR NOT EQUAL(ARR_VAR(2),7) OR + NOT EQUAL(ARR_VAR(3),8) OR NOT EQUAL(ARR_VAR(4),9) OR + NOT EQUAL(ARR_VAR(5),10)) THEN + FAILED ("IMPROPER RESULT FROM SLICE ASSIGNMENT USING THE " & + "RANGE OF AN ARRAY OBJECT"); + END IF; + + RESULT; + END C41207A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41301a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41301a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41301a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41301a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- C41301A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.R MAY BE USED TO DENOTE A RECORD COMPONENT, + -- WHERE R IS THE IDENTIFIER OF SUCH COMPONENT, AND L MAY BE ANY OF + -- THE FOLLOWING: + -- AN IDENTIFIER DENOTING A RECORD OBJECT - X2; + -- AN IDENTIFIER DENOTING AN ACCESS OBJECT WHOSE VALUE DESIGNATES + -- A RECORD OBJECT - X3; + -- A FUNCTION CALL DELIVERING A RECORD VALUE - F1; + -- A FUNCTION CALL DELIVERING AN ACCESS VALUE DESIGNATING A + -- RECORD OBJECT - F2; + -- AN INDEXED COMPONENT - X4; + -- AN IDENTIFIER PREFIXED BY THE NAME OF THE INNERMOST UNIT + -- ENCLOSING THE IDENTIFIER'S DECLARATION - C41301A.X1; + -- A SELECTED COMPONENT DENOTING A RECORD (WHICH IS A COMPONENT + -- OF ANOTHER RECORD) - X5. + + -- WKB 8/13/81 + -- JRK 8/17/81 + -- SPS 10/26/82 + + WITH REPORT; + USE REPORT; + PROCEDURE C41301A IS + + TYPE T1 IS + RECORD + A : INTEGER; + B : BOOLEAN; + C : BOOLEAN; + END RECORD; + X1 : T1 := (A=>1, B=>TRUE, C=>FALSE); + + BEGIN + TEST ("C41301A", "CHECK THAT THE NOTATION L.R MAY BE USED TO " & + "DENOTE A RECORD COMPONENT, WHERE R IS THE " & + "IDENTIFIER AND L MAY BE OF CERTAIN FORMS"); + + DECLARE + + TYPE T2 (DISC : INTEGER := 0) IS + RECORD + D : BOOLEAN; + E : INTEGER; + F : BOOLEAN; + CASE DISC IS + WHEN 1 => + G : BOOLEAN; + WHEN 2 => + H : INTEGER; + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + X2 : T2(2) := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1); + + TYPE T3 IS ACCESS T1; + X3 : T3 := NEW T1' (A=>1, B=>TRUE, C=>FALSE); + + TYPE T4 IS ARRAY (1..3) OF T1; + X4 : T4 := (1 => (1, TRUE, FALSE), + 2 => (2, FALSE, TRUE), + 3 => (3, TRUE, FALSE)); + + TYPE T5 IS + RECORD + I : INTEGER; + J : T1; + END RECORD; + X5 : T5 := (I => 5, J => (6, FALSE, TRUE)); + + FUNCTION F1 RETURN T2 IS + BEGIN + RETURN (DISC=>1, D=>FALSE, E=>3, F=>TRUE, G=>FALSE); + END F1; + + FUNCTION F2 RETURN T3 IS + BEGIN + RETURN X3; + END F2; + + PROCEDURE P1 (X : IN BOOLEAN; Y : IN OUT INTEGER; + Z : OUT BOOLEAN; W : STRING) IS + BEGIN + IF X /= TRUE THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - " & W); + END IF; + IF Y /= 1 THEN + FAILED ("WRONG VALUE FOR IN OUT PARAMETER - " & W); + END IF; + Y := 10; + Z := TRUE; + END P1; + + PROCEDURE P2 (X : IN INTEGER) IS + BEGIN + IF X /= 1 THEN + FAILED ("WRONG VALUE FOR IN PARAMETER - F1"); + END IF; + END P2; + + BEGIN + + IF X2.E /= 3 THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X2"); + END IF; + X2.E := 5; + IF X2 /= (2, TRUE, 5, FALSE, 1) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X2"); + END IF; + X2 := (DISC=>2, D=>TRUE, E=>3, F=>FALSE, H=>1); + P1 (X2.D, X2.H, X2.F, "X2"); + IF X2 /= (2, TRUE, 3, TRUE, 10) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X2"); + END IF; + + IF X3.C /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X3"); + END IF; + X3.A := 5; + IF X3.ALL /= (5, TRUE, FALSE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X3"); + END IF; + X3 := NEW T1 '(A=>1, B=>TRUE, C=>FALSE); + P1 (X3.B, X3.A, X3.C, "X3"); + IF X3.ALL /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X3"); + END IF; + + IF F1.G /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F1"); + END IF; + P2 (F1.DISC); + + X3 := NEW T1' (A=>3, B=>FALSE, C=>TRUE); + IF F2.B /= FALSE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - F2"); + END IF; + F2.A := 4; + IF X3.ALL /= (4, FALSE, TRUE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - F2"); + END IF; + X3 := NEW T1' (A=>1, B=>FALSE, C=>TRUE); + P1 (F2.C, F2.A, F2.B, "F2"); + IF X3.ALL /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - F2"); + END IF; + + IF X4(2).C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X4"); + END IF; + X4(3).A := 4; + IF X4 /= ((1,TRUE,FALSE), (2,FALSE,TRUE), (4,TRUE,FALSE)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X4"); + END IF; + X4 := (1 => (2,TRUE,FALSE), 2 => (1,FALSE,TRUE), + 3 => (3,TRUE,FALSE)); + P1 (X4(3).B, X4(2).A, X4(1).C, "X4"); + IF X4 /= ((2,TRUE,TRUE), (10,FALSE,TRUE), (3,TRUE,FALSE)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X4"); + END IF; + + X1 := (A=>1, B=>FALSE, C=>TRUE); + IF C41301A.X1.C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - C41301A.X1"); + END IF; + C41301A.X1.B := TRUE; + IF X1 /= (1, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - C41301A.X1"); + END IF; + X1 := (A=>1, B=>FALSE, C=>TRUE); + P1 (C41301A.X1.C, C41301A.X1.A, C41301A.X1.B, "C41301A.X1"); + IF X1 /= (10, TRUE, TRUE) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - " & + "C41301A.X1"); + END IF; + + IF X5.J.C /= TRUE THEN + FAILED ("WRONG VALUE FOR EXPRESSION - X5"); + END IF; + X5.J.C := FALSE; + IF X5 /= (5, (6, FALSE, FALSE)) THEN + FAILED ("WRONG TARGET FOR ASSIGNMENT - X5"); + END IF; + X5 := (I => 5, J => (A=>1, B=>TRUE, C=>FALSE)); + P1 (X5.J.B, X5.J.A, X5.J.C, "X5"); + IF X5 /= (5, (10, TRUE, TRUE)) THEN + FAILED ("WRONG TARGET FOR (IN) OUT PARAMETER - X5"); + END IF; + + END; + + RESULT; + END C41301A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C41303A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303A IS + + + BEGIN + + TEST ( "C41303A" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO RECORD --------------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + + TYPE ACC_REC IS ACCESS REC ; + + ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 ); + + BEGIN + + REC_VAR := ACC_REC_VAR.ALL ; + + IF REC_VAR /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_REC_VAR.ALL := REC_CONST ; + + IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C41303B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303B IS + + + BEGIN + + TEST ( "C41303B" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO ARRAY ---------------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + + TYPE ACC_ARR IS ACCESS ARR ; + + ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE ); + + BEGIN + + ARR_VAR := ACC_ARR_VAR.ALL ; + + IF ARR_VAR /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ARR_VAR.ALL := ARR_CONST ; + + IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + + ------------------------------------------------------------------- + + RESULT; + + + END C41303B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C41303C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || XXXXXXXXX | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303C IS + + + BEGIN + + TEST ( "C41303C" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING A RECORD, AN ARRAY, OR A SCALAR"); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO SCALAR --------------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := 813 ; + NEWINT_VAR : NEWINT := NEWINT_CONST ; + + TYPE ACC_NEWINT IS ACCESS NEWINT ; + + ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 ); + + BEGIN + + NEWINT_VAR := ACC_NEWINT_VAR.ALL ; + + IF NEWINT_VAR /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_NEWINT_VAR.ALL := NEWINT_CONST ; + + IF ACC_NEWINT_VAR.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C41303E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303E IS + + + BEGIN + + TEST ( "C41303E" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + TYPE ACCREC IS ACCESS REC ; + + ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 ); + ACCREC_VAR : ACCREC := ACCREC_CONST ; + ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 ); + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + + BEGIN + + ACCREC_VAR := ACC_ACCREC_VAR.ALL ; + + IF ACCREC_VAR /= ACCREC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_ACCREC_VAR.ALL := ACCREC_CONST ; + + IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303f.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C41303F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303F IS + + BEGIN + + TEST ( "C41303F" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + TYPE ACCARR IS ACCESS ARR ; + + ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE ); + ACCARR_VAR : ACCARR := ACCARR_CONST ; + ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE ); + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + + BEGIN + + ACCARR_VAR := ACC_ACCARR_VAR.ALL ; + + IF ACCARR_VAR /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCARR_VAR.ALL := ACCARR_CONST ; + + IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303g.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- C41303G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || XXXXXXXXX | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303G IS + + + BEGIN + + TEST ( "C41303G" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 ); + ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 ); + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + BEGIN + + ACCNEWINT_VAR := ACC_ACCNEWINT_VAR.ALL ; + + IF ACCNEWINT_VAR /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE OF ASSIGN.,WRONG VAL."); + END IF; + + + ACC_ACCNEWINT_VAR.ALL := ACCNEWINT_CONST ; + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE OF ASSIGN.,WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303i.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- C41303I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303I IS + + + BEGIN + + TEST ( "C41303I" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_CONST2 : REC := ( 17 , 18 , 19 ); + + TYPE ACCREC IS ACCESS REC ; + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + BEGIN + + REC_VAR := ACC_ACCREC_VAR.ALL.ALL ; + + IF REC_VAR /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD,RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCREC_VAR.ALL.ALL := REC_CONST ; + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303j.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C41303J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || XXXXXXXXX | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303J IS + + + BEGIN + + TEST ( "C41303J" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_CONST2 : ARR := ( FALSE , TRUE ); + + TYPE ACCARR IS ACCESS ARR ; + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + BEGIN + + ARR_VAR := ACC_ACCARR_VAR.ALL.ALL ; + + IF ARR_VAR /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCARR_VAR.ALL.ALL := ARR_CONST ; + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303k.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C41303K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || XXXXXXXXX | + -- ============================================================ + + + -- RM 1/20/82 + -- RM 1/25/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303K IS + + + BEGIN + + TEST ( "C41303K" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := ( 813 ); + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_CONST2 : NEWINT := ( 707 ); + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + BEGIN + + NEWINT_VAR := ACC_ACCNEWINT_VAR.ALL.ALL ; + + IF NEWINT_VAR /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT,RIGHT SIDE OF ASSIGN., WRONG VAL."); + END IF; + + + ACC_ACCNEWINT_VAR.ALL.ALL := NEWINT_CONST ; + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL + THEN + FAILED( "ACC2 NEWINT,LEFT SIDE OF ASSIGN., WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303m.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C41303M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/22/82 + -- RM 1/26/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303M IS + + + BEGIN + + TEST ( "C41303M" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO RECORD --------------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_VAR0 : REC := REC_CONST ; + + TYPE ACC_REC IS ACCESS REC ; + + ACC_REC_VAR : ACC_REC := NEW REC'( 17 , 18 , 19 ); + ACC_REC_VAR0 : ACC_REC := NEW REC'( 17 , 18 , 19 ); + + + PROCEDURE R_ASSIGN( R_IN : IN REC ; + R_INOUT : IN OUT REC ) IS + BEGIN + REC_VAR := R_IN ; + REC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT REC ; + L_INOUT : IN OUT REC ) IS + BEGIN + L_OUT := REC_CONST ; + L_INOUT := REC_CONST ; + END ; + + BEGIN + + R_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL ); + + IF REC_VAR /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL."); + END IF; + + IF REC_VAR0 /= ( 17 , 18 , 19 ) + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL."); + END IF; + + + L_ASSIGN( ACC_REC_VAR.ALL , ACC_REC_VAR0.ALL ); + + IF ACC_REC_VAR.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + + IF ACC_REC_VAR0.ALL /= ( 7 , 8 , 9 ) + THEN + FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303n.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C41303N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/22/82 + -- RM 1/26/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303N IS + + + BEGIN + + TEST ( "C41303N" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO ARRAY ---------------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_VAR0 : ARR := ARR_CONST ; + + TYPE ACC_ARR IS ACCESS ARR ; + + ACC_ARR_VAR : ACC_ARR := NEW ARR'( FALSE , TRUE ); + ACC_ARR_VAR0 : ACC_ARR := NEW ARR'( FALSE , TRUE ); + + + PROCEDURE R_ASSIGN( R_IN : IN ARR ; + R_INOUT : IN OUT ARR ) IS + BEGIN + ARR_VAR := R_IN ; + ARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ARR ; + L_INOUT : IN OUT ARR ) IS + BEGIN + L_OUT := ARR_CONST ; + L_INOUT := ARR_CONST ; + END ; + + BEGIN + + + R_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL ); + + IF ARR_VAR /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ARR_VAR0 /= ( FALSE , TRUE ) + THEN + FAILED( "ACC. ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ARR_VAR.ALL , ACC_ARR_VAR0.ALL ); + + IF ACC_ARR_VAR.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + + IF ACC_ARR_VAR0.ALL /= ( TRUE , FALSE ) + THEN + FAILED( "ACC. ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303o.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C41303O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | XXXXXXXXX + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/27/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303O IS + + + BEGIN + + TEST ( "C41303O" , "CHECK THAT L.ALL , WHERE L IS THE NAME OF" + & " AN ACCESS OBJECT DESIGNATING A RECORD, AN" + & " ARRAY, OR A SCALAR, IS ALLOWED AS" + & " ACTUAL PARAMETER OF ANY MODE" ); + + + ------------------------------------------------------------------- + -------------------- ACCESS TO SCALAR --------------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := 813 ; + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_VAR0 : NEWINT := NEWINT_CONST ; + + TYPE ACC_NEWINT IS ACCESS NEWINT ; + + ACC_NEWINT_VAR : ACC_NEWINT := NEW NEWINT'( 707 ); + ACC_NEWINT_VAR0 : ACC_NEWINT := NEW NEWINT'( 707 ); + + + PROCEDURE R_ASSIGN( R_IN : IN NEWINT ; + R_INOUT : IN OUT NEWINT ) IS + BEGIN + NEWINT_VAR := R_IN ; + NEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ; + L_INOUT : IN OUT NEWINT ) IS + BEGIN + L_OUT := NEWINT_CONST ; + L_INOUT := NEWINT_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL ); + + IF NEWINT_VAR /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_VAR0 /= ( 707 ) + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_NEWINT_VAR.ALL , ACC_NEWINT_VAR0.ALL ); + + IF ACC_NEWINT_VAR.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACC_NEWINT_VAR0.ALL /= 813 + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303q.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C41303Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/28/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303Q IS + + + BEGIN + + TEST ( "C41303Q" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + TYPE ACCREC IS ACCESS REC ; + + ACCREC_CONST : ACCREC := NEW REC'( 7 , 8 , 9 ); + ACCREC_VAR : ACCREC := ACCREC_CONST ; + ACCREC_VAR0 : ACCREC := ACCREC_CONST ; + ACCREC_CONST2 : ACCREC := NEW REC'( 17 , 18 , 19 ); + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'(ACCREC_CONST2); + + PROCEDURE R_ASSIGN( R_IN : IN ACCREC ; + R_INOUT : IN OUT ACCREC ) IS + BEGIN + ACCREC_VAR := R_IN ; + ACCREC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCREC ; + L_INOUT : IN OUT ACCREC ) IS + BEGIN + L_OUT := ACCREC_CONST ; + L_INOUT := ACCREC_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL ); + + IF ACCREC_VAR /= ACCREC_CONST2 + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (1), WRONG VAL."); + END IF; + + IF ACCREC_VAR0 /= ACCREC_CONST2 + THEN + FAILED( "ACC. RECORD, RIGHT SIDE (2), WRONG VAL."); + END IF; + + + L_ASSIGN( ACC_ACCREC_VAR.ALL , ACC_ACCREC_VAR0.ALL ); + + IF ACCREC_CONST /= ACC_ACCREC_VAR.ALL + THEN + FAILED( "ACC. RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCREC_CONST /= ACC_ACCREC_VAR0.ALL + THEN + FAILED( "ACC. RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303r.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C41303R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/28/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303R IS + + BEGIN + + TEST ( "C41303R" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + TYPE ACCARR IS ACCESS ARR ; + + ACCARR_CONST : ACCARR := NEW ARR'( TRUE , FALSE ); + ACCARR_VAR : ACCARR := ACCARR_CONST ; + ACCARR_VAR0 : ACCARR := ACCARR_CONST ; + ACCARR_CONST2 : ACCARR := NEW ARR'( FALSE , TRUE ); + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'(ACCARR_CONST2); + + + PROCEDURE R_ASSIGN( R_IN : IN ACCARR ; + R_INOUT : IN OUT ACCARR ) IS + BEGIN + ACCARR_VAR := R_IN ; + ACCARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCARR ; + L_INOUT : IN OUT ACCARR ) IS + BEGIN + L_OUT := ACCARR_CONST ; + L_INOUT := ACCARR_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCARR_VAR.ALL, ACC_ACCARR_VAR0.ALL ); + + IF ACCARR_VAR /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCARR_VAR0 /= ACCARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCARR_VAR.ALL , ACC_ACCARR_VAR0.ALL ); + + IF ACCARR_CONST /= ACC_ACCARR_VAR.ALL + THEN + FAILED( "ACC2. ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCARR_CONST /= ACC_ACCARR_VAR0.ALL + THEN + FAILED( "ACC2. ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303s.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C41303S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | XXXXXXXXX + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/28/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303S IS + + + BEGIN + + TEST ( "C41303S" , "CHECK THAT THE NOTATION L.ALL IS ALLOWED IF" + & " L IS THE NAME OF AN ACCESS OBJECT" + & " DESIGNATING ANOTHER ACCESS OBJECT" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + ACCNEWINT_CONST : ACCNEWINT := NEW NEWINT'( 813 ); + ACCNEWINT_VAR : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_VAR0 : ACCNEWINT := ACCNEWINT_CONST ; + ACCNEWINT_CONST2 : ACCNEWINT := NEW NEWINT'( 707 ); + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'( + ACCNEWINT_CONST2 + ); + + PROCEDURE R_ASSIGN( R_IN : IN ACCNEWINT ; + R_INOUT : IN OUT ACCNEWINT ) IS + BEGIN + ACCNEWINT_VAR := R_IN ; + ACCNEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ACCNEWINT ; + L_INOUT : IN OUT ACCNEWINT ) IS + BEGIN + L_OUT := ACCNEWINT_CONST ; + L_INOUT := ACCNEWINT_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL ); + + IF ACCNEWINT_VAR /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCNEWINT_VAR0 /= ACCNEWINT_CONST2 + THEN + FAILED( "ACC. NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCNEWINT_VAR.ALL , ACC_ACCNEWINT_VAR0.ALL ); + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ACCNEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL + THEN + FAILED( "ACC. NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303u.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303u.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303u.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303u.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C41303U.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/29/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303U IS + + + BEGIN + + TEST ( "C41303U" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO RECORD ---------------------- + + DECLARE + + TYPE REC IS + + RECORD + A , B , C : INTEGER ; + END RECORD ; + + + REC_CONST : REC := ( 7 , 8 , 9 ); + REC_VAR : REC := REC_CONST ; + REC_VAR0 : REC := REC_CONST ; + REC_CONST2 : REC := ( 17 , 18 , 19 ); + + TYPE ACCREC IS ACCESS REC ; + + TYPE ACC_ACCREC IS ACCESS ACCREC ; + + ACC_ACCREC_VAR : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + ACC_ACCREC_VAR0 : ACC_ACCREC := NEW ACCREC'( + NEW REC'( REC_CONST2 ) + ); + + + PROCEDURE R_ASSIGN( R_IN : IN REC ; + R_INOUT : IN OUT REC ) IS + BEGIN + REC_VAR := R_IN ; + REC_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT REC ; + L_INOUT : IN OUT REC ) IS + BEGIN + L_OUT := REC_CONST ; + L_INOUT := REC_CONST ; + END ; + + + BEGIN + + R_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL ); + + IF REC_VAR /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF REC_VAR0 /= REC_CONST2 + THEN + FAILED( "ACC2 RECORD, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCREC_VAR.ALL.ALL , ACC_ACCREC_VAR0.ALL.ALL ); + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ( 7 , 8 , 9 ) /= ACC_ACCREC_VAR0.ALL.ALL + THEN + FAILED( "ACC2 RECORD, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303v.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- C41303V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | XXXXXXXXX + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ============================================================ + + + -- RM 1/29/82 + -- SPS 12/2/82 + + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303V IS + + + BEGIN + + TEST ( "C41303V" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO ARRAY ----------------------- + + DECLARE + + TYPE ARR IS ARRAY(1..2) OF BOOLEAN ; + + ARR_CONST : ARR := ( TRUE , FALSE ); + ARR_VAR : ARR := ARR_CONST ; + ARR_VAR0 : ARR := ARR_CONST ; + ARR_CONST2 : ARR := ( FALSE , TRUE ); + + TYPE ACCARR IS ACCESS ARR ; + + TYPE ACC_ACCARR IS ACCESS ACCARR ; + + ACC_ACCARR_VAR : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + ACC_ACCARR_VAR0 : ACC_ACCARR := NEW ACCARR'( + NEW ARR'( ARR_CONST2 ) + ); + + + PROCEDURE R_ASSIGN( R_IN : IN ARR ; + R_INOUT : IN OUT ARR ) IS + BEGIN + ARR_VAR := R_IN ; + ARR_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT ARR ; + L_INOUT : IN OUT ARR ) IS + BEGIN + L_OUT := ARR_CONST ; + L_INOUT := ARR_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL ); + + IF ARR_VAR /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF ARR_VAR0 /= ARR_CONST2 + THEN + FAILED( "ACC2 ARRAY, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCARR_VAR.ALL.ALL , ACC_ACCARR_VAR0.ALL.ALL ); + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF ( TRUE , FALSE ) /= ACC_ACCARR_VAR0.ALL.ALL + THEN + FAILED( "ACC2 ARRAY, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303w.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303w.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41303w.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41303w.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- C41303W.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NOTATION L.ALL IS ALLOWED IF L IS THE NAME OF AN + -- ACCESS OBJECT DESIGNATING A RECORD, AN ARRAY, A SCALAR, OR + -- ANOTHER ACCESS OBJECT. + -- CHECK THAT IF A IS AN IDENTIFIER DENOTING AN ACCESS OBJECT WHICH + -- IN TURN DESIGNATES AN ACCESS OBJECT, THE FORM A.ALL.ALL IS + -- ACCEPTED. + + + -- THIS OBJECTIVE IS COVERED IN SEVERAL TESTS. IN THE FOLLOWING DIAGRAM, + -- THE PORTION COVERED BY THE CURRENT TEST IS MARKED BY 'X' . + + + -- || ASSIGNMT | PROC. PARAMETERS + -- || ():= :=() | IN OUT IN OUT + -- ========================||=============|==================== + -- ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 1 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | + -- ========================||=============|==================== + -- ACC ACC REC || | + -- --------------||-------------|-------------------- + -- 2 '.ALL' ACC ACC ARR || | + -- --------------||-------------|-------------------- + -- ACC ACC SCLR || | XXXXXXXXX + -- ============================================================ + + + -- RM 1/29/82 + -- SPS 12/2/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C41303W IS + + + BEGIN + + TEST ( "C41303W" , "CHECK THAT IF A IS AN IDENTIFIER DENOTING" & + " AN ACCESS OBJECT WHICH IN TURN DESIGNATES" & + " AN ACCESS OBJECT, THE FORM A.ALL.ALL IS" & + " ACCEPTED" ); + + + ------------------------------------------------------------------- + --------------- ACCESS TO ACCESS TO SCALAR ---------------------- + + DECLARE + + TYPE NEWINT IS NEW INTEGER ; + + NEWINT_CONST : NEWINT := ( 813 ); + NEWINT_VAR : NEWINT := NEWINT_CONST ; + NEWINT_VAR0 : NEWINT := NEWINT_CONST ; + NEWINT_CONST2 : NEWINT := ( 707 ); + + TYPE ACCNEWINT IS ACCESS NEWINT ; + + TYPE ACC_ACCNEWINT IS ACCESS ACCNEWINT ; + + ACC_ACCNEWINT_VAR : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + ACC_ACCNEWINT_VAR0 : ACC_ACCNEWINT := NEW ACCNEWINT'( + NEW NEWINT' ( + NEWINT_CONST2 + ) + ); + + PROCEDURE R_ASSIGN( R_IN : IN NEWINT ; + R_INOUT : IN OUT NEWINT ) IS + BEGIN + NEWINT_VAR := R_IN ; + NEWINT_VAR0 := R_INOUT ; + END ; + + + PROCEDURE L_ASSIGN( L_OUT : OUT NEWINT ; + L_INOUT : IN OUT NEWINT ) IS + BEGIN + L_OUT := NEWINT_CONST ; + L_INOUT := NEWINT_CONST ; + END ; + + + BEGIN + + + R_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL , + ACC_ACCNEWINT_VAR0.ALL.ALL ); + + IF NEWINT_VAR /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_VAR0 /= NEWINT_CONST2 + THEN + FAILED( "ACC2 NEWINT, RIGHT SIDE (2), WRONG VAL." ); + END IF; + + + L_ASSIGN( ACC_ACCNEWINT_VAR.ALL.ALL , + ACC_ACCNEWINT_VAR0.ALL.ALL ); + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR.ALL.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE (1), WRONG VAL." ); + END IF; + + IF NEWINT_CONST /= ACC_ACCNEWINT_VAR0.ALL.ALL + THEN + FAILED( "ACC2 NEWINT, LEFT SIDE (2), WRONG VAL." ); + END IF; + + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41303W; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41304a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- C41304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN: + -- L DENOTES AN ACCESS OBJECT HAVING THE VALUE NULL. + -- L IS A FUNCTION CALL DELIVERING THE ACCESS VALUE NULL. + + -- HISTORY: + -- WKB 08/14/81 + -- JRK 08/17/81 + -- SPS 10/26/82 + -- TBN 03/26/86 PUT THE NON-EXISTENT COMPONENT CASES INTO C41304B. + -- JET 01/05/88 MODIFIED HEADER FORMAT AND ADDED CODE TO PREVENT + -- OPTIMIZATION. + + WITH REPORT; USE REPORT; + PROCEDURE C41304A IS + + TYPE R IS + RECORD + I : INTEGER; + END RECORD; + + TYPE T IS ACCESS R; + + BEGIN + TEST ("C41304A", "CONSTRAINT_ERROR WHEN L IN L.R DENOTES A NULL " & + "ACCESS OBJECT OR A FUNCTION CALL DELIVERING " & + "NULL"); + + -------------------------------------------------- + + DECLARE + + A : T := NEW R' (I => 1); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + A := NULL; + END IF; + + J := A.I; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A NULL ACCESS " & + "OBJECT"); + + IF EQUAL (J,J) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A NULL ACCESS " & + "OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN T IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN NULL; + END IF; + RETURN NEW R' (I => 2); + END F; + + BEGIN + + J := F.I; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING A NULL ACCESS VALUE"); + + IF EQUAL (J,J) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING A NULL ACCESS VALUE"); + + END; + + RESULT; + END C41304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41304b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41304b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41304b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41304b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- C41304B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN: + -- L DENOTES A RECORD OBJECT SUCH THAT, FOR THE EXISTING + -- DISCRIMINANT VALUES, THE COMPONENT DENOTED BY R DOES + -- NOT EXIST. + -- L IS A FUNCTION CALL DELIVERING A RECORD VALUE SUCH THAT, + -- FOR THE EXISTING DISCRIMINANT VALUES, THE COMPONENT + -- DENOTED BY R DOES NOT EXIST. + -- L IS AN ACCESS OBJECT AND THE OBJECT DESIGNATED BY THE ACCESS + -- VALUE IS SUCH THAT COMPONENT R DOES NOT EXIST FOR THE + -- OBJECT'S CURRENT DISCRIMINANT VALUES. + -- L IS A FUNCTION CALL RETURNING AN ACCESS VALUE AND THE OBJECT + -- DESIGNATED BY THE ACCESS VALUE IS SUCH THAT COMPONENT R + -- DOES NOT EXIST FOR THE OBJECT'S CURRENT DISCRIMINANT + -- VALUES. + + -- HISTORY: + -- TBN 05/23/86 CREATED ORIGINAL TEST. + -- JET 01/08/88 MODIFIED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + + WITH REPORT; USE REPORT; + PROCEDURE C41304B IS + + TYPE V (DISC : INTEGER := 0) IS + RECORD + CASE DISC IS + WHEN 1 => + X : INTEGER; + WHEN OTHERS => + Y : INTEGER; + END CASE; + END RECORD; + + TYPE T IS ACCESS V; + + BEGIN + TEST ("C41304B", "CHECK THAT L.R RAISES CONSTRAINT_ERROR WHEN " & + "THE COMPONENT DENOTED BY R DOES NOT EXIST"); + + DECLARE + + VR : V := (DISC => 0, Y => 4); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + VR := (DISC => 1, X => 3); + END IF; + + J := VR.Y; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A RECORD OBJECT"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A RECORD OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN V IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN (DISC => 2, Y => 3); + END IF; + RETURN (DISC => 1, X => 4); + END F; + + BEGIN + + J := F.X; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING A RECORD VALUE"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING A RECORD VALUE"); + + END; + + -------------------------------------------------- + + DECLARE + + A : T := NEW V' (DISC => 0, Y => 4); + J : INTEGER; + + BEGIN + + IF EQUAL (4, 4) THEN + A := NEW V' (DISC => 1, X => 3); + END IF; + + J := A.Y; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR AN ACCESS OBJECT"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR AN ACCESS OBJECT"); + + END; + + -------------------------------------------------- + + DECLARE + + J : INTEGER; + + FUNCTION F RETURN T IS + BEGIN + IF EQUAL (4, 4) THEN + RETURN NEW V' (DISC => 2, Y => 3); + END IF; + RETURN NEW V' (DISC => 1, X => 4); + END F; + + BEGIN + + J := F.X; + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR A FUNCTION CALL " & + "DELIVERING AN ACCESS VALUE"); + + -- IF STATEMENT PREVENTS OPTIMIZING OF VARIABLE J. + + IF EQUAL (J,3) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR A FUNCTION CALL " & + "DELIVERING AN ACCESS VALUE"); + + END; + + RESULT; + END C41304B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C41306A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF F IS A FUNCTION RETURNING A TASK OF A TYPE HAVING + -- AN ENTRY E , AN ENTRY CALL OF THE FORM + -- + -- F.E + -- + -- IS PERMITTED. + + + -- RM 2/2/82 + -- ABW 7/16/82 + + WITH REPORT; + USE REPORT; + PROCEDURE C41306A IS + + + BEGIN + + TEST ( "C41306A" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.E IS PERMITTED"); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + T1 : T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + ACCEPT E DO + X := IDENT_INT(16) ; + END E ; + END T ; + + FUNCTION F1 RETURN T IS + BEGIN + RETURN T1 ; + END F1 ; + + FUNCTION F2 (A,B : BOOLEAN) RETURN T IS + BEGIN + IF A AND B THEN NULL; END IF; + RETURN T1; + END F2; + + BEGIN + + F1.E ; -- X SET TO 17. + + IF X /= 17 THEN + FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 1"); + END IF; + + X := 0; + F2(TRUE,TRUE).E; -- X SET TO 16. + -- X TO BE SET TO 16. + + IF X /= 16 THEN + FAILED("WRONG VALUE FOR GLOBAL VARIABLE - 2"); + END IF; + + END ; + + ------------------------------------------------------------------- + + RESULT; + + + END C41306A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,217 ---- + -- C41306B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING + -- A TASK OF A TYPE HAVING + -- AN ENTRY E , AN ENTRY CALL OF THE FORM + -- + -- F.ALL.E + -- + -- IS PERMITTED. + + -- RM 02/02/82 + -- ABW 07/16/82 + -- EG 05/28/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C41306B IS + + BEGIN + + TEST ( "C41306B" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " AN ACCESS VALUE DESIGNATING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.ALL.E IS" & + " PERMITTED" ); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F1 RETURN A_T IS + A_T_VAR1 : A_T := NEW T ; + BEGIN + RETURN A_T_VAR1 ; + END F1 ; + + FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS + A_T_VAR2 : A_T := NEW T; + BEGIN + IF A AND B THEN + NULL; + END IF; + RETURN A_T_VAR2; + END F2; + + BEGIN + + F1.ALL.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" ); + END IF; + + X := 0; + F2(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F2 (BODY) + -- ACTIVATES THE TASK, WHICH + -- PROCEEDS TO WAIT FOR THE + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE + -- SET TO 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F3 RETURN A_T IS + BEGIN + RETURN NEW T ; + END F3; + + FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS + BEGIN + IF C AND D THEN + NULL; + END IF; + RETURN NEW T; + END F4; + + BEGIN + + F3.ALL.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" ); + END IF; + + X := 0; + F4(TRUE, TRUE).ALL.E; -- THE ELABORATION OF F4 (BODY) + -- ACTIVATES THE TASK, WHICH + -- PROCEEDS TO WAIT FOR THE + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE + -- SET TO 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + BEGIN + + DECLARE + + F3 : A_T := NEW T; + + BEGIN + + F3.ALL.E; + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" ); + END IF; + + END; + + END ; + + ------------------------------------------------------------------- + + + RESULT; + + + END C41306B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41306c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41306c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- C41306C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF F IS A FUNCTION RETURNING AN ACCESS VALUE DESIGNATING + -- A TASK OF A TYPE HAVING + -- AN ENTRY E , AN ENTRY CALL OF THE FORM + -- + -- F.E + -- + -- IS PERMITTED. + + + -- RM 02/02/82 + -- ABW 07/16/82 + -- EG 05/28/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C41306C IS + + BEGIN + + TEST ( "C41306C" , "CHECK THAT IF F IS A FUNCTION RETURNING" & + " AN ACCESS VALUE DESIGNATING" & + " A TASK OF A TYPE HAVING AN ENTRY E , AN" & + " ENTRY CALL OF THE FORM F.E IS PERMITTED" ); + + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F1 RETURN A_T IS + A_T_VAR1 : A_T := NEW T ; + BEGIN + RETURN A_T_VAR1 ; + END F1 ; + + FUNCTION F2 (A, B : BOOLEAN) RETURN A_T IS + A_T_VAR2 : A_T := NEW T; + BEGIN + IF A AND B THEN + NULL; + END IF; + RETURN A_T_VAR2; + END F2; + + BEGIN + + F1.E ; -- THE ELABOR. OF F1 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (1)" ); + END IF; + + X := 0; + F2(TRUE, TRUE).E; -- THE ELABORATION OF F2 (BODY) ACTIVATES + -- THE TASK, WHICH PROCEEDS TO WAIT FOR + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO + -- 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (2)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + FUNCTION F3 RETURN A_T IS + BEGIN + RETURN NEW T ; + END F3; + + FUNCTION F4 (C, D : BOOLEAN) RETURN A_T IS + BEGIN + IF C AND D THEN + NULL; + END IF; + RETURN NEW T; + END F4; + + BEGIN + + F3.E ; -- THE ELABOR. OF F3 (BODY) ACTIVATES THE TASK, + -- WHICH PROCEEDS TO WAIT FOR ENTRY E TO + -- BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 + THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (3)" ); + END IF; + + X := 0; + F4(TRUE, TRUE).E; -- THE ELABORATION OF F4 (BODY) ACTIVATES + -- THE TASK WHICH PROCEEDS TO WAIT FOR + -- ENTRY E TO BE CALLED. + + -- THE CALLED ENTRY CAUSES X TO BE SET TO + -- 17. + + IF X /= 17 THEN + FAILED ("WRONG VALUE FOR GLOBAL VARIABLE (4)"); + END IF; + + END ; + + ------------------------------------------------------------------- + + DECLARE + + X : INTEGER := 0 ; + + TASK TYPE T IS + ENTRY E ; + END T ; + + TYPE A_T IS ACCESS T ; + + TASK BODY T IS + BEGIN + ACCEPT E DO + X := IDENT_INT(17) ; + END E ; + END T ; + + BEGIN + + DECLARE + + F3 : A_T := NEW T; + + BEGIN + + F3.E; + + -- THE CALLED ENTRY CAUSES X TO BE SET TO 17 . + + IF X /= 17 THEN + FAILED( "WRONG VALUE FOR GLOBAL VARIABLE (5)" ); + END IF; + + END; + + END ; + + ------------------------------------------------------------------- + + + RESULT; + + + END C41306C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41307d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41307d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41307d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41307d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,255 ---- + -- C41307D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT L.R IS ALLOWED INSIDE A PACKAGE, GENERIC PACKAGE, + -- SUBPROGRAM, GENERIC SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT + -- STATEMENT NAMED L, IF R IS DECLARED INSIDE THE UNIT. + + -- TBN 12/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41307D IS + + BEGIN + TEST ("C41307D", "CHECK THAT L.R IS ALLOWED INSIDE A PACKAGE, " & + "GENERIC PACKAGE, SUBPROGRAM, GENERIC " & + "SUBPROGRAM, TASK, BLOCK, LOOP, OR AN ACCEPT " & + "STATEMENT NAMED L, IF R IS DECLARED INSIDE " & + "THE UNIT"); + DECLARE + PACKAGE L IS + R : INTEGER := 5; + A : INTEGER := L.R; + END L; + + PACKAGE BODY L IS + B : INTEGER := L.R + 1; + BEGIN + IF IDENT_INT(A) /= 5 OR IDENT_INT(B) /= 6 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + END L; + + GENERIC + S : INTEGER; + PACKAGE M IS + X : INTEGER := M.S; + END M; + + PACKAGE BODY M IS + Y : INTEGER := M.S + 1; + BEGIN + IF IDENT_INT(X) /= 2 OR + IDENT_INT(Y) /= 3 OR + IDENT_INT(M.X) /= 2 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + END M; + + PACKAGE Q IS NEW M(2); + BEGIN + IF IDENT_INT(Q.X) /= 2 THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + END; + ------------------------------------------------------------------- + + DECLARE + CH : CHARACTER := '6'; + + PROCEDURE L (R : IN OUT CHARACTER) IS + A : CHARACTER := L.R; + BEGIN + IF IDENT_CHAR(L.A) /= '6' THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + L.R := IDENT_CHAR('7'); + END L; + + GENERIC + S : CHARACTER; + PROCEDURE M; + + PROCEDURE M IS + T : CHARACTER := M.S; + BEGIN + IF IDENT_CHAR(T) /= '3' OR IDENT_CHAR(M.S) /= '3' THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + END M; + + PROCEDURE P1 IS NEW M('3'); + + BEGIN + L (CH); + IF CH /= IDENT_CHAR('7') THEN + FAILED ("INCORRECT RESULTS RETURNED FROM PROCEDURE - 6"); + END IF; + P1; + END; + ------------------------------------------------------------------- + + DECLARE + INT : INTEGER := 3; + + FUNCTION L (R : INTEGER) RETURN INTEGER IS + A : INTEGER := L.R; + BEGIN + IF IDENT_INT(L.A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + RETURN IDENT_INT(4); + END L; + + GENERIC + S : INTEGER; + FUNCTION M RETURN INTEGER; + + FUNCTION M RETURN INTEGER IS + T : INTEGER := M.S; + BEGIN + IF IDENT_INT(M.T) /= 4 OR M.S /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + RETURN IDENT_INT(1); + END M; + + FUNCTION F1 IS NEW M(4); + + BEGIN + IF L(INT) /= 4 OR F1 /= 1 THEN + FAILED ("INCORRECT RESULTS RETURNED FROM FUNCTION - 9"); + END IF; + END; + ------------------------------------------------------------------- + + DECLARE + TASK L IS + ENTRY E (A : INTEGER); + END L; + + TASK TYPE M IS + ENTRY E1 (A : INTEGER); + END M; + + T1 : M; + + TASK BODY L IS + X : INTEGER := IDENT_INT(1); + R : INTEGER RENAMES X; + Y : INTEGER := L.R; + BEGIN + X := X + L.R; + IF X /= IDENT_INT(2) OR Y /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " & + "10"); + END IF; + END L; + + TASK BODY M IS + X : INTEGER := IDENT_INT(2); + R : INTEGER RENAMES X; + Y : INTEGER := M.R; + BEGIN + ACCEPT E1 (A : INTEGER) DO + X := X + M.R; + IF X /= IDENT_INT(4) OR Y /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 11"); + END IF; + IF E1.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 12"); + END IF; + END E1; + END M; + BEGIN + T1.E1 (3); + END; + ------------------------------------------------------------------- + + DECLARE + TASK T IS + ENTRY G (1..2) (A : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT G (1) (A : INTEGER) DO + IF G.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 13"); + END IF; + BLK: + DECLARE + B : INTEGER := 7; + BEGIN + IF T.BLK.B /= IDENT_INT(7) THEN + FAILED ("INCORRECT RESULTS FROM " & + "EXPANDED NAME - 14"); + END IF; + END BLK; + END G; + ACCEPT G (2) (A : INTEGER) DO + IF G.A /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED " & + "NAME - 15"); + END IF; + END G; + END T; + BEGIN + T.G (1) (2); + T.G (2) (1); + END; + ------------------------------------------------------------------- + + SWAP: + DECLARE + VAR : CHARACTER := '*'; + RENAME_VAR : CHARACTER RENAMES VAR; + NEW_VAR : CHARACTER; + BEGIN + IF EQUAL (3, 3) THEN + NEW_VAR := SWAP.RENAME_VAR; + END IF; + IF NEW_VAR /= IDENT_CHAR('*') THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - " & + "16"); + END IF; + LP: FOR I IN 1..2 LOOP + IF SWAP.LP.I = IDENT_INT(2) OR + LP.I = IDENT_INT(1) THEN + GOTO SWAP.LAB1; + END IF; + NEW_VAR := IDENT_CHAR('+'); + <> + NEW_VAR := IDENT_CHAR('-'); + END LOOP LP; + IF NEW_VAR /= IDENT_CHAR('-') THEN + FAILED ("INCORRECT RESULTS FROM FOR LOOP - 17"); + END IF; + END SWAP; + + RESULT; + END C41307D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41309a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41309a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41309a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41309a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C41309A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXPANDED NAME IS ALLOWED EVEN IF A USE CLAUSE MAKES THE + -- EXPANDED NAME UNNECESSARY. + + -- TBN 12/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41309A IS + + BEGIN + TEST ("C41309A", "CHECK THAT AN EXPANDED NAME IS ALLOWED EVEN " & + "IF A USE CLAUSE MAKES THE EXPANDED NAME " & + "UNNECESSARY"); + DECLARE + PACKAGE P IS + PACKAGE Q IS + PACKAGE R IS + TYPE REC IS + RECORD + A : INTEGER := 5; + B : BOOLEAN := TRUE; + END RECORD; + REC1 : REC; + END R; + + USE R; + + REC2 : R.REC := R.REC1; + END Q; + + USE Q; USE R; + + REC3 : Q.R.REC := Q.REC2; + END P; + + USE P; USE Q; USE R; + + REC4 : P.Q.R.REC := P.REC3; + BEGIN + IF REC4 /= (IDENT_INT(5), IDENT_BOOL(TRUE)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME"); + END IF; + END; + + RESULT; + END C41309A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41320a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41320a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41320a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41320a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C41320A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IMPLICITLY DECLARED ENUMERATION LITERALS, CHARACTER + -- LITERALS, AND THE RELATIONAL OPERATORS CAN BE SELECTED FROM + -- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR ENUMERATION TYPES. + + -- HISTORY: + -- TBN 07/15/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 ADDED TEST FOR OVERLOADED VARIABLES. + + WITH REPORT; USE REPORT; + PROCEDURE C41320A IS + + PACKAGE P IS + TYPE FLAG IS (RED, WHITE, BLUE); + TYPE ROMAN_DIGITS IS ('I', 'V', 'X', 'C', 'M'); + TYPE TRAFFIC_LIGHT IS (RED, YELLOW, GREEN); + TYPE HEX IS ('A', 'B', 'C', 'D', 'E', 'F'); + FLAG_COLOR_1 : FLAG := RED; + FLAG_COLOR_2 : FLAG := WHITE; + TRAFFIC_LIGHT_COLOR_1 : FLAG := RED; + HEX_3 : HEX := 'C'; + ROMAN_1 : ROMAN_DIGITS := 'I'; + END P; + + USA_FLAG_1 : P.FLAG := P.RED; + USA_FLAG_3 : P.FLAG := P.BLUE; + HEX_CHAR_3 : P.HEX := P.'C'; + ROMAN_DIGITS_4 : P.ROMAN_DIGITS := P.'C'; + TRAFFIC_LIGHT_1 : P.TRAFFIC_LIGHT := P.RED; + + BEGIN + TEST ("C41320A", "CHECK THAT IMPLICITLY DECLARED ENUMERATION " & + "LITERALS, CHARACTER LITERALS, AND THE " & + "RELATIONAL OPERATORS CAN BE SELECTED FROM " & + "OUTSIDE THE PACKAGE USING AN EXPANDED NAME " & + "FOR ENUMERATION TYPES"); + + IF P."/=" (USA_FLAG_1, P.FLAG_COLOR_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."=" (USA_FLAG_3, P.FLAG_COLOR_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (HEX_CHAR_3, P.HEX_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (P.ROMAN_1, ROMAN_DIGITS_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P.">=" (TRAFFIC_LIGHT_1, P.TRAFFIC_LIGHT'PRED (P.GREEN)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + FOR J IN P.FLAG'(P.WHITE) .. P.FLAG'(P.WHITE) LOOP + IF P."<=" (P.FLAG'SUCC (P.WHITE), J) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + END LOOP; + + IF P.">=" (P.RED, P.GREEN) THEN + FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 1"); + END IF; + + IF P."<=" (P.BLUE, P.RED) THEN + FAILED ("INCORRECT RESULT FROM OVERLOADED VARIABLE NAME - 2"); + END IF; + + RESULT; + END C41320A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41321a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41321a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41321a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41321a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C41321A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS, LOGICAL + -- OPERATORS, AND THE "NOT" OPERATOR MAY BE SELECTED FROM OUTSIDE + -- THE PACKAGE USING AN EXPANDED NAME, FOR A DERIVED BOOLEAN TYPE. + + -- TBN 7/16/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41321A IS + + PACKAGE P IS + TYPE DERIVED_BOOLEAN IS NEW BOOLEAN RANGE FALSE .. TRUE; + DERIVED_FALSE : DERIVED_BOOLEAN := FALSE; + DERIVED_TRUE : DERIVED_BOOLEAN := TRUE; + END P; + + DBOOL_FALSE : P.DERIVED_BOOLEAN := P.FALSE; + DBOOL_TRUE : P.DERIVED_BOOLEAN := P.TRUE; + + BEGIN + TEST ("C41321A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS, LOGICAL OPERATORS, AND THE 'NOT' " & + "OPERATOR MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " & + "BOOLEAN TYPE"); + + IF P."=" (DBOOL_FALSE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (P.DERIVED_TRUE, P.DERIVED_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (P.DERIVED_TRUE, DBOOL_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.DERIVED_TRUE, DBOOL_TRUE) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + FOR J IN P.DERIVED_BOOLEAN'(P.TRUE) .. P.DERIVED_BOOLEAN'(P.TRUE) + LOOP + IF P.">=" (DBOOL_FALSE, J) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + END LOOP; + + IF P."AND" (DBOOL_FALSE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + IF P."OR" (DBOOL_FALSE, P.DERIVED_FALSE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + IF P."XOR" (DBOOL_TRUE, P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + IF P."NOT" (P.DERIVED_TRUE) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + RESULT; + END C41321A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41322a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41322a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41322a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41322a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C41322A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC + -- OPERATORS (+, -, *, /, **, ABS, MOD, REM) MAY BE SELECTED FROM + -- OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN INTEGER TYPE. + + -- TBN 7/16/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41322A IS + + PACKAGE P IS + TYPE INT IS RANGE -10 .. 10; + OBJ_INT_1 : INT := -10; + OBJ_INT_2 : INT := 1; + OBJ_INT_3 : INT := 10; + END P; + + INT_VAR : P.INT; + INT_VAR_1 : P.INT := P."-"(P.INT'(10)); + INT_VAR_2 : P.INT := P.INT'(1); + INT_VAR_3 : P.INT := P.INT'(10); + + BEGIN + TEST ("C41322A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, **, ABS, MOD, REM) MAY BE SELECTED FROM " & + "OUTSIDE THE PACKAGE USING AN EXPANDED NAME, " & + "FOR AN INTEGER TYPE"); + + IF P."=" (INT_VAR_1, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (INT_VAR_1, P.OBJ_INT_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (INT_VAR_2, 0) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (INT_VAR_2, P.OBJ_INT_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (INT_VAR_3, P.INT'(9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + FOR J IN P.INT'(4) .. P.INT'(4) LOOP + IF P.">=" (J, INT_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + END LOOP; + + INT_VAR := P."+" (INT_VAR_1, P.INT'(2)); + IF P."/=" (INT_VAR, P."-"(P.INT'(8))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + INT_VAR := P."+" (P.INT'(2)); + IF P."/=" (INT_VAR, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + INT_VAR := P."-" (INT_VAR_2, P.INT'(0)); + IF P."/=" (INT_VAR, P.OBJ_INT_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + INT_VAR := P."*" (INT_VAR_2, P.INT'(5)); + IF P."/=" (INT_VAR, P.INT'(5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + INT_VAR := P."/" (INT_VAR_3, P.INT'(2)); + IF P."/=" (INT_VAR, P.INT'(5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + INT_VAR := P."**" (P.INT'(2), 3); + IF P."/=" (INT_VAR, P.INT'(8)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + INT_VAR := P."ABS" (INT_VAR_1); + IF P."/=" (INT_VAR, P.OBJ_INT_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + INT_VAR := P."MOD" (INT_VAR_1, P.INT'(3)); + IF P."/=" (INT_VAR, P.INT'(2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + INT_VAR := P."REM" (INT_VAR_1, P.INT'(3)); + IF P."/=" (INT_VAR, P."-" (INT_VAR_2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + RESULT; + END C41322A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41323a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41323a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41323a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41323a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C41323A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC + -- OPERATORS (+, -, *, /, **, ABS) MAY BE SELECTED FROM OUTSIDE THE + -- PACKAGE USING AN EXPANDED NAME, FOR A FLOATING POINT TYPE. + + -- TBN 7/16/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41323A IS + + PACKAGE P IS + TYPE FLOAT IS DIGITS 5 RANGE -1.0E1 .. 1.0E1; + OBJ_FLO_1 : FLOAT := -5.5; + OBJ_FLO_2 : FLOAT := 1.5; + OBJ_FLO_3 : FLOAT := 10.0; + END P; + + FLO_VAR : P.FLOAT; + FLO_VAR_1 : P.FLOAT := P."-"(P.FLOAT'(5.5)); + FLO_VAR_2 : P.FLOAT := P.FLOAT'(1.5); + FLO_VAR_3 : P.FLOAT := P.FLOAT'(1.0E1); + + BEGIN + TEST ("C41323A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, **, ABS) MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A " & + "FLOATING POINT TYPE"); + + IF P."=" (FLO_VAR_1, P."-"(P.FLOAT'(5.55))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (FLO_VAR_1, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (FLO_VAR_2, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (FLO_VAR_2, P.OBJ_FLO_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (FLO_VAR_3, P.FLOAT'(9.9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (FLO_VAR_3, P.FLOAT'(10.0)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.OBJ_FLO_2, FLO_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P.">=" (P.OBJ_FLO_3, FLO_VAR_3) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + FLO_VAR := P."+" (FLO_VAR_1, P.OBJ_FLO_2); + IF P."/=" (FLO_VAR, P."-"(P.FLOAT'(4.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + FLO_VAR := P."+" (FLO_VAR_1); + IF P."/=" (FLO_VAR, P.OBJ_FLO_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + FLO_VAR := P."-" (FLO_VAR_2, P.OBJ_FLO_1); + IF P."/=" (FLO_VAR, P.FLOAT'(7.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + FLO_VAR := P."*" (FLO_VAR_2, P.FLOAT'(2.0)); + IF P."/=" (FLO_VAR, P.FLOAT'(3.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + FLO_VAR := P."/" (FLO_VAR_3, P.FLOAT'(2.0)); + IF P."/=" (FLO_VAR, P.FLOAT'(5.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + FLO_VAR := P."**" (P.FLOAT'(2.0), 3); + IF P."/=" (FLO_VAR, P.FLOAT'(8.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + FLO_VAR := P."ABS" (FLO_VAR_1); + IF P."/=" (FLO_VAR, P.FLOAT'(5.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + RESULT; + END C41323A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41324a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41324a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41324a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41324a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C41324A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED RELATIONAL OPERATORS AND ARITHMETIC + -- OPERATORS (+, -, *, /, ABS) MAY BE SELECTED FROM OUTSIDE THE + -- PACKAGE USING AN EXPANDED NAME, FOR A FIXED POINT TYPE. + + -- TBN 7/16/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41324A IS + + PACKAGE P IS + TYPE FIXED IS DELTA 0.125 RANGE -1.0E1 .. 1.0E1; + OBJ_FIX_1 : FIXED := -5.5; + OBJ_FIX_2 : FIXED := 1.5; + OBJ_FIX_3 : FIXED := 10.0; + END P; + + FIX_VAR : P.FIXED; + FIX_VAR_1 : P.FIXED := P."-"(P.FIXED'(5.5)); + FIX_VAR_2 : P.FIXED := P.FIXED'(1.5); + FIX_VAR_3 : P.FIXED := P.FIXED'(1.0E1); + + BEGIN + TEST ("C41324A", "CHECK THAT IMPLICITLY DECLARED RELATIONAL " & + "OPERATORS AND ARITHMETIC OPERATORS (+, -, *, " & + "/, ABS) MAY BE SELECTED FROM OUTSIDE THE " & + "PACKAGE USING AN EXPANDED NAME, FOR A FIXED " & + "POINT TYPE"); + + IF P."=" (FIX_VAR_1, P."-"(P.FIXED'(6.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (FIX_VAR_1, P.OBJ_FIX_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."<" (FIX_VAR_2, P.OBJ_FIX_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P.">" (FIX_VAR_2, P.OBJ_FIX_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."<=" (FIX_VAR_3, P.FIXED'(9.9)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."<=" (FIX_VAR_3, P.FIXED'(10.0)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + IF P.">=" (P.OBJ_FIX_2, FIX_VAR_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P.">=" (P.OBJ_FIX_2, FIX_VAR_2) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + FIX_VAR := P."+" (FIX_VAR_1, P.OBJ_FIX_2); + IF P."/=" (FIX_VAR, P."-"(P.FIXED'(4.0))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + FIX_VAR := P."-" (FIX_VAR_2, P.OBJ_FIX_1); + IF P."/=" (FIX_VAR, P.FIXED'(7.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + FIX_VAR := P."*" (FIX_VAR_2, 2); + IF P."/=" (FIX_VAR, P.FIXED'(3.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + FIX_VAR := P."*" (3, FIX_VAR_2); + IF P."/=" (FIX_VAR, P.FIXED'(4.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + FIX_VAR := P."/" (FIX_VAR_3, 2); + IF P."/=" (FIX_VAR, P.FIXED'(5.0)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + FIX_VAR := P."ABS" (FIX_VAR_1); + IF P."/=" (FIX_VAR, P.FIXED'(5.5)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + RESULT; + END C41324A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41325a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41325a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41325a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41325a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- C41325A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FOLLOWING IMPLICITLY DECLARED ENTITIES CAN BE SELECTED + -- FROM OUTSIDE THE PACKAGE USING AN EXPANDED NAME, FOR AN ARRAY TYPE. + -- CASE 1: CHECK EQUALITY AND INEQUALITY WHEN COMPONENT TYPE IS + -- NON-LIMITED, FOR MULTIDIMENSIONAL ARRAYS. + -- CASE 2: FOR ONE DIMENSIONAL ARRAYS: + -- A) CHECK CATENATION, EQUALITY, AND INEQUALITY WHEN + -- COMPONENT TYPE IS NON-LIMITED. + -- B) CHECK RELATIONAL OPERATORS WHEN COMPONENT TYPE IS + -- DISCRETE. + -- C) CHECK THE "NOT" OPERATOR AND THE LOGICAL OPERATORS + -- WHEN COMPONENT TYPE IS BOOLEAN. + + -- TBN 7/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41325A IS + + PACKAGE P IS + TYPE CATARRAY IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE ARRAY_1 IS ARRAY (1..10) OF INTEGER; + TYPE ARRAY_2 IS ARRAY (1..4, 1..4) OF INTEGER; + TYPE ARRAY_3 IS ARRAY (1..2, 1..3, 1..4) OF INTEGER; + TYPE ARRAY_4 IS ARRAY (1..10) OF BOOLEAN; + TYPE ARRAY_5 IS ARRAY (1..4, 1..4) OF BOOLEAN; + TYPE ARRAY_6 IS ARRAY (1..2, 1..3, 1..4) OF BOOLEAN; + + OBJ_ARA_1 : ARRAY_1 := (1..10 => IDENT_INT(0)); + OBJ_ARA_2 : ARRAY_2 := (1..4 => (1..4 => IDENT_INT(0))); + OBJ_ARA_3 : ARRAY_3 := (1..2 => (1..3 => + (1..4 => IDENT_INT(0)))); + OBJ_ARA_4 : ARRAY_4 := (1..10 => IDENT_BOOL(FALSE)); + OBJ_ARA_5 : ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(FALSE))); + OBJ_ARA_6 : ARRAY_6 := (1..2 => (1..3 => + (1..4 => IDENT_BOOL(FALSE)))); + OBJ_ARA_7 : CATARRAY (1..10) := (1..10 => IDENT_INT(0)); + OBJ_ARA_20 : CATARRAY (1..20) := (1..10 => 1, + 11..20 => IDENT_INT(0)); + END P; + + VAR_ARA_1 : P.ARRAY_1 := (1..10 => IDENT_INT(1)); + VAR_ARA_2 : P.ARRAY_2 := (1..4 => (1..4 => IDENT_INT(1))); + VAR_ARA_3 : P.ARRAY_3 := (1..2 => (1..3 => + (1..4 => IDENT_INT(1)))); + VAR_ARA_4 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE)); + VAR_ARA_5 : P.ARRAY_5 := (1..4 => (1..4 => IDENT_BOOL(TRUE))); + VAR_ARA_6 : P.ARRAY_6 := (1..2 => (1..3 => + (1..4 => IDENT_BOOL(TRUE)))); + VAR_ARA_7 : P.CATARRAY (1..10) := (1..10 => IDENT_INT(1)); + VAR_ARA_8 : P.ARRAY_4 := (1..10 => IDENT_BOOL(TRUE)); + VAR_ARA_20 : P.CATARRAY (1..20) := (1..20 => IDENT_INT(0)); + + BEGIN + TEST ("C41325A", "CHECK THAT IMPLICITLY DECLARED ENTITIES CAN " & + "BE SELECTED FROM OUTSIDE THE PACKAGE USING AN " & + "EXPANDED NAME, FOR AN ARRAY TYPE"); + + -- CASE 1: MULTIDIMENSIONAL ARRAYS. + + IF P."=" (VAR_ARA_2, P.OBJ_ARA_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."=" (VAR_ARA_5, P.OBJ_ARA_5) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."/=" (VAR_ARA_2, P.ARRAY_2'(1..4 => (1..4 => 1))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + IF P."/=" (VAR_ARA_5, P.ARRAY_5'(1..4 => (1..4 => TRUE))) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + IF P."=" (VAR_ARA_3, P.OBJ_ARA_3) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 5"); + END IF; + + IF P."/=" (VAR_ARA_6, P.ARRAY_6'(1..2 =>(1..3 =>(1..4 => TRUE)))) + THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 6"); + END IF; + + -- CASE 2: ONE DIMENSIONAL ARRAYS. + + IF P."=" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 7"); + END IF; + + IF P."/=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 8"); + END IF; + + VAR_ARA_20 := P."&" (VAR_ARA_7, P.OBJ_ARA_7); + IF P."/=" (VAR_ARA_20, P.OBJ_ARA_20) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 9"); + END IF; + + IF P."<" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 10"); + END IF; + + IF P.">" (P.OBJ_ARA_1, VAR_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 11"); + END IF; + + IF P."<=" (VAR_ARA_1, P.OBJ_ARA_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 12"); + END IF; + + IF P."<=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 13"); + END IF; + + IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 14"); + END IF; + + IF P.">=" (VAR_ARA_1, P.ARRAY_1'(1..10 => 1)) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 15"); + END IF; + + VAR_ARA_8 := P."NOT" (VAR_ARA_4); + IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 16"); + END IF; + + VAR_ARA_8 := P."OR" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 17"); + END IF; + + VAR_ARA_8 := P."AND" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."/=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 18"); + END IF; + + VAR_ARA_8 := P."XOR" (VAR_ARA_4, P.OBJ_ARA_4); + IF P."=" (VAR_ARA_8, P.OBJ_ARA_4) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 19"); + END IF; + + RESULT; + END C41325A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41326a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41326a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41326a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41326a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C41326A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS + -- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR + -- AN ACCESS TYPE. + + -- TBN 7/18/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41326A IS + + PACKAGE P IS + TYPE CELL IS + RECORD + VALUE : INTEGER; + END RECORD; + TYPE LINK IS ACCESS CELL; + + OBJ_LINK_1 : LINK := NEW CELL'(VALUE => 1); + OBJ_LINK_2 : LINK := OBJ_LINK_1; + END P; + + VAR_LINK_1 : P.LINK := NEW P.CELL'(VALUE => 1); + VAR_LINK_2 : P.LINK := NEW P.CELL'(VALUE => 2); + + BEGIN + TEST ("C41326A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " & + "INEQUALITY OPERATORS MAY BE SELECTED FROM " & + "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " & + "FOR AN ACCESS TYPE"); + + IF P."=" (VAR_LINK_1, P.OBJ_LINK_1) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (P.OBJ_LINK_1, P.OBJ_LINK_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + IF P."=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 3"); + END IF; + + VAR_LINK_2.VALUE := 1; + IF P."/=" (VAR_LINK_2.ALL, P.OBJ_LINK_1.ALL) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 4"); + END IF; + + RESULT; + END C41326A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41327a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41327a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41327a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41327a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C41327A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED EQUALITY AND INEQUALITY OPERATORS + -- MAY BE SELECTED FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR + -- A PRIVATE TYPE. + + -- TBN 7/18/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41327A IS + + PACKAGE P IS + TYPE KEY IS PRIVATE; + TYPE CHAR IS PRIVATE; + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY; + FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR; + PRIVATE + TYPE KEY IS NEW NATURAL; + TYPE CHAR IS NEW CHARACTER; + END P; + + VAR_KEY_1 : P.KEY; + VAR_KEY_2 : P.KEY; + VAR_CHAR_1 : P.CHAR; + VAR_CHAR_2 : P.CHAR; + + PACKAGE BODY P IS + + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS + BEGIN + RETURN (KEY (X)); + END INIT_KEY; + + FUNCTION INIT_CHAR (X : CHARACTER) RETURN CHAR IS + BEGIN + RETURN (CHAR (X)); + END INIT_CHAR; + + BEGIN + NULL; + END P; + + BEGIN + TEST ("C41327A", "CHECK THAT IMPLICITLY DECLARED EQUALITY AND " & + "INEQUALITY OPERATORS MAY BE SELECTED FROM " & + "OUTSIDE A PACKAGE USING AN EXPANDED NAME, " & + "FOR A PRIVATE TYPE"); + + VAR_KEY_1 := P.INIT_KEY (1); + VAR_KEY_2 := P.INIT_KEY (2); + VAR_CHAR_1 := P.INIT_CHAR ('A'); + VAR_CHAR_2 := P.INIT_CHAR ('A'); + IF P."=" (VAR_KEY_1, VAR_KEY_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 1"); + END IF; + + IF P."/=" (VAR_CHAR_1, VAR_CHAR_2) THEN + FAILED ("INCORRECT RESULTS FROM EXPANDED NAME - 2"); + END IF; + + RESULT; + END C41327A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41328a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41328a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41328a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41328a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C41328A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS CAN BE SELECTED + -- FROM OUTSIDE A PACKAGE USING AN EXPANDED NAME, FOR A DERIVED TYPE. + + -- TBN 7/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE C41328A IS + + PACKAGE P IS + PACKAGE Q IS + TYPE PAIR IS ARRAY (1..2) OF INTEGER; + FUNCTION INIT (INT : INTEGER) RETURN PAIR; + PROCEDURE SWAP (TWO : IN OUT PAIR); + END Q; + TYPE COUPLE IS NEW Q.PAIR; + END P; + + VAR_1 : P.COUPLE; + VAR_2 : P.COUPLE; + + PACKAGE BODY P IS + + PACKAGE BODY Q IS + + FUNCTION INIT (INT : INTEGER) RETURN PAIR IS + A : PAIR; + BEGIN + A (1) := INT; + A (2) := INT + 1; + RETURN (A); + END INIT; + + PROCEDURE SWAP (TWO : IN OUT PAIR) IS + TEMP : INTEGER; + BEGIN + TEMP := TWO (1); + TWO (1) := TWO (2); + TWO (2) := TEMP; + END SWAP; + + BEGIN + NULL; + END Q; + + BEGIN + NULL; + END P; + + BEGIN + TEST ("C41328A", "CHECK THAT IMPLICITLY DECLARED DERIVED " & + "SUBPROGRAMS CAN BE SELECTED FROM OUTSIDE A " & + "PACKAGE USING AN EXPANDED NAME, FOR A DERIVED " & + "TYPE"); + + VAR_1 := P.INIT (IDENT_INT(1)); + IF P."/=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 1"); + END IF; + + VAR_2 := P.INIT (IDENT_INT(2)); + IF P."=" (VAR_2, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 2"); + END IF; + + P.SWAP (VAR_1); + IF P."=" (VAR_1, P.COUPLE'(1 => 1, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 3"); + END IF; + + P.SWAP (VAR_2); + IF P."/=" (VAR_2, P.COUPLE'(1 => 3, 2 => 2)) THEN + FAILED ("INCORRECT RESULTS FROM DERIVED SUBPROGRAM - 4"); + END IF; + + RESULT; + END C41328A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41401a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41401a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41401a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41401a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- C41401A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE PREFIX OF THE FOLLOWING + -- ATTRIBUTES HAS THE VALUE NULL: + -- A) 'CALLABLE AND 'TERMINATED FOR A TASK TYPE. + -- B) 'FIRST, 'FIRST(N), 'LAST, 'LAST(N), 'LENGTH, 'LENGTH(N), + -- 'RANGE, AND 'RANGE(N) FOR AN ARRAY TYPE. + + -- TBN 10/2/86 + -- EDS 07/14/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C41401A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE ACC_TT IS ACCESS TT; + + TYPE NULL_ARR1 IS ARRAY (2 .. 1) OF INTEGER; + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE NULL_ARR2 IS ARRAY (3 .. 1, 2 .. 1) OF INTEGER; + TYPE ARRAY2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ACC_NULL1 IS ACCESS NULL_ARR1; + TYPE ACC_ARR1 IS ACCESS ARRAY1; + TYPE ACC_NULL2 IS ACCESS NULL_ARR2; + TYPE ACC_ARR2 IS ACCESS ARRAY2; + + PTR_TT : ACC_TT; + PTR_ARA1: ACC_NULL1; + PTR_ARA2 : ACC_ARR1 (1 .. 4); + PTR_ARA3 : ACC_NULL2; + PTR_ARA4 : ACC_ARR2 (1 .. 2, 2 .. 4); + BOOL_VAR : BOOLEAN := FALSE; + INT_VAR : INTEGER := 1; + + TASK BODY TT IS + BEGIN + ACCEPT E; + END TT; + + BEGIN + TEST ("C41401A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " & + "PREFIX HAS A VALUE OF NULL FOR THE FOLLOWING " & + "ATTRIBUTES: 'CALLABLE, 'TERMINATED, 'FIRST, " & + "'LAST, 'LENGTH, AND 'RANGE"); + + BEGIN + IF EQUAL (3, 2) THEN + PTR_TT := NEW TT; + END IF; + BOOL_VAR := IDENT_BOOL(PTR_TT'CALLABLE); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & BOOLEAN'IMAGE(BOOL_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + IF EQUAL (1, 3) THEN + PTR_TT := NEW TT; + END IF; + BOOL_VAR := IDENT_BOOL(PTR_TT'TERMINATED); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & BOOLEAN'IMAGE(BOOL_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA1'FIRST); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 5 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA2'LAST); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 7 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 8"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA1'LENGTH); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 9 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 10"); + END; + + BEGIN + DECLARE + A : ARRAY1 (PTR_ARA2'RANGE); + BEGIN + A (1) := IDENT_INT(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 " & + INTEGER'IMAGE(A(1))); + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - 11 "); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 12"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'FIRST(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 13 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 14"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA4'LAST(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 15 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 16"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 17 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 18"); + END; + + BEGIN + DECLARE + A : ARRAY1 (PTR_ARA4'RANGE(2)); + BEGIN + A (1) := IDENT_INT(1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 " & + INTEGER'IMAGE(A(1))); + EXCEPTION + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - 19 "); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 20"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA4'LAST(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 21 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 22"); + END; + + BEGIN + INT_VAR := IDENT_INT(PTR_ARA3'LENGTH(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 23 " & INTEGER'IMAGE(INT_VAR)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 24"); + END; + + RESULT; + END C41401A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41402a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C41402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE PREFIX OF + -- 'ADDRESS, 'SIZE, 'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE + -- VALUE NULL. + + -- HISTORY: + -- TBN 10/02/86 CREATED ORIGINAL TEST. + -- CJJ 07/01/87 REMOVED TEST FOR 'STORAGE_SIZE, WHICH IS NO LONGER + -- PART OF THE OBJECTIVE. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C41402A IS + + TYPE ARRAY1 IS ARRAY (1 .. 2) OF INTEGER; + TYPE ACC_ARA IS ACCESS ARRAY1; + + PTR_ARA : ACC_ARA; + VAR1 : INTEGER; + + TYPE REC1 IS + RECORD + A : INTEGER; + END RECORD; + + TYPE ACC_REC1 IS ACCESS REC1; + + TYPE REC2 IS + RECORD + P_AR : ACC_ARA; + P_REC : ACC_REC1; + END RECORD; + + OBJ_REC : REC2; + + + PROCEDURE PROC (A : ADDRESS) IS + BEGIN + NULL; + END; + + BEGIN + TEST ("C41402A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "THE PREFIX OF 'ADDRESS, 'SIZE, " & + "'FIRST_BIT, 'LAST_BIT, AND 'POSITION HAS THE " & + "VALUE NULL"); + + BEGIN + PROC (PTR_ARA'ADDRESS); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'ADDRESS"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'ADDRESS"); + END; + + BEGIN + VAR1 := PTR_ARA'SIZE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'SIZE"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'SIZE"); + END; + + BEGIN + VAR1 := OBJ_REC.P_AR'FIRST_BIT; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'FIRST_BIT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'FIRST_BIT"); + END; + + BEGIN + VAR1 := OBJ_REC.P_AR'LAST_BIT; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'LAST_BIT"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'LAST_BIT"); + END; + + BEGIN + VAR1 := OBJ_REC.P_REC'POSITION; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR 'POSITION"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED 'POSITION"); + END; + + RESULT; + END C41402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41404a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41404a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c41404a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c41404a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C41404A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE PREFIX OF THE ARRAY ATTRIBUTES CAN BE THE VALUE OF AN + -- IMAGE ATTRIBUTE. + + -- JBG 6/1/85 + -- PWB 2/3/86 CORRECTED COMPARISON VALUES FOR 'LAST AND 'LENGTH. + + WITH REPORT; USE REPORT; + PROCEDURE C41404A IS + + TYPE ENUM IS (ONE, FOUR, 'C'); + + BEGIN + + TEST ("C41404A", "CHECK WHEN PREFIX OF AN ATTRIBUTE IS 'IMAGE"); + + IF ENUM'IMAGE(FOUR)'LENGTH /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE FOR LENGTH - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(56))'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - INTEGER: 56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LENGTH /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LENGTH - CHAR: 'B'"); + END IF; + + IF ENUM'IMAGE(FOUR)'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'FIRST(1) /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(56))'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - INTEGER: 56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'FIRST /= IDENT_INT(1) THEN + FAILED ("WRONG VALUE FOR FIRST - CHAR: 'B'"); + END IF; + + IF ENUM'IMAGE(FOUR)'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG VALUE FOR LAST - ENUM"); + END IF; + + IF ENUM'IMAGE('C')'LAST(1) /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - ENUM: 'C'"); + END IF; + + IF INTEGER'IMAGE(IDENT_INT(-56))'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - INTEGER: -56"); + END IF; + + IF CHARACTER'IMAGE(IDENT_CHAR('B'))'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG VALUE FOR LAST - CHAR: 'B'"); + END IF; + + DECLARE + + FOUR_VAR : STRING(ENUM'IMAGE(FOUR)'RANGE); + C_VAR : STRING(ENUM'IMAGE('C')'RANGE); + VAR_101 : STRING(INTEGER'IMAGE(IDENT_INT(101))'RANGE); + CHAR_VAR : STRING(CHARACTER'IMAGE(IDENT_CHAR('B'))'RANGE); + + BEGIN + + IF FOUR_VAR'FIRST /= 1 OR + FOUR_VAR'LAST /= 4 OR + FOUR_VAR'LENGTH /= 4 THEN + FAILED ("FOUR_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(FOUR_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(FOUR_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(FOUR_VAR'LENGTH)); + END IF; + + IF C_VAR'FIRST /= 1 OR + C_VAR'LAST /= 3 OR + C_VAR'LENGTH /= 3 THEN + FAILED ("C_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(C_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(C_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(C_VAR'LENGTH)); + END IF; + + IF VAR_101'FIRST /= 1 OR + VAR_101'LAST /= 4 OR + VAR_101'LENGTH /= 4 THEN + FAILED ("VAR_101 ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(VAR_101'FIRST) & ". LAST IS" & + INTEGER'IMAGE(VAR_101'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(VAR_101'LENGTH)); + END IF; + + IF CHAR_VAR'FIRST /= 1 OR + CHAR_VAR'LAST /= 3 OR + CHAR_VAR'LENGTH /= 3 THEN + FAILED ("CHAR_VAR ATTRIBUTES INCORRECT. FIRST IS" & + INTEGER'IMAGE(CHAR_VAR'FIRST) & ". LAST IS" & + INTEGER'IMAGE(CHAR_VAR'LAST) & ". LENGTH IS" & + INTEGER'IMAGE(CHAR_VAR'LENGTH)); + END IF; + + END; + + RESULT; + END C41404A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c420001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c420001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c420001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c420001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C420001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check that if the index subtype of a string type is a modular subtype + -- whose lower bound is zero, then the evaluation of a null string_literal + -- raises Constraint_Error. This was confirmed by AI95-00138. + -- + -- TEST DESCRIPTION + -- In this test, we have a generic formal modular type, and we have + -- several null string literals of that type. Because the type is + -- generic formal, the string literals are not static, and therefore + -- the Constraint_Error should be detected at run time. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 23 SEP 1999 RLB Improved comments and messages, renamed, issued. + -- + --! + with Report; use Report; pragma Elaborate_All(Report); + with System; + procedure C420001 is + generic + type Modular is mod <>; + package Mod_Test is + type Str is array(Modular range <>) of Character; + procedure Test_String_Literal; + end Mod_Test; + + package body Mod_Test is + procedure Test_String_Literal is + begin + begin + declare + Null_String: Str := ""; -- Should raise C_E. + begin + Comment(String(Null_String)); -- Avoid 11.6 issues. + end; + Failed("Null string didn't raise Constraint_Error"); + exception + when Exc: Constraint_Error => + null; -- Comment("Constraint_Error -- OK"); + when Exc2: others => + Failed("Null string raised wrong exception"); + end; + begin + Failed(String(Str'(""))); -- Should raise C_E, not do Failed. + Failed("Null string didn't raise Constraint_Error"); + exception + when Exc: Constraint_Error => + null; -- Comment("Constraint_Error -- OK"); + when Exc2: others => + Failed("Null string raised wrong exception"); + end; + end Test_String_Literal; + begin + Test_String_Literal; + end Mod_Test; + begin + Test("C420001", "Check that if the index subtype of a string type is a " & + "modular subtype whose lower bound is zero, then the " & + "evaluation of a null string_literal raises " & + "Constraint_Error. "); + declare + type M1 is mod 1; + package Test_M1 is new Mod_Test(M1); + type M2 is mod 2; + package Test_M2 is new Mod_Test(M2); + type M3 is mod 3; + package Test_M3 is new Mod_Test(M3); + type M4 is mod 4; + package Test_M4 is new Mod_Test(M4); + type M5 is mod 5; + package Test_M5 is new Mod_Test(M5); + type M6 is mod 6; + package Test_M6 is new Mod_Test(M6); + type M7 is mod 7; + package Test_M7 is new Mod_Test(M7); + type M8 is mod 8; + package Test_M8 is new Mod_Test(M8); + type M_Max_Binary_Modulus is mod System.Max_Binary_Modulus; + package Test_M_Max_Binary_Modulus is new Mod_Test(M_Max_Binary_Modulus); + type M_Max_Nonbinary_Modulus is mod System.Max_Nonbinary_Modulus; + package Test_M_Max_Nonbinary_Modulus is new Mod_Test(M_Max_Nonbinary_Modulus); + begin + null; + end; + Result; + end C420001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c42006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c42006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c42006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c42006a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C42006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A STRING LITERAL OF AN + -- ARRAY TYPE CONTAINS A CHARACTER THAT DOES NOT BELONG TO THE COMPONENT + -- SUBTYPE. + + -- SPS 2/22/84 + -- EDS 12/02/97 MODIFIED THE COMPONENT SUBTYPES SO THAT THEY ARE NON-STATIC. + -- EDS 7/14/98 AVOID OPTIMIZATION + + WITH REPORT; + USE REPORT; + PROCEDURE C42006A IS + BEGIN + + TEST ("C42006A", "CHECK THAT THE VALUES OF STRING LITERALS MUST" & + " BELONG TO THE COMPONENT SUBTYPE."); + + DECLARE + + TYPE CHAR_COMP IS ('A', 'B', 'C', 'D', 'E', 'F'); + + ASCIINUL : CHARACTER := ASCII.NUL; + SUBTYPE NON_GRAPHIC_CHAR IS CHARACTER + RANGE ASCIINUL .. ASCII.BEL; + + BEE : CHAR_COMP := 'B'; + TYPE CHAR_STRING IS ARRAY (POSITIVE RANGE <>) + OF CHAR_COMP RANGE BEE..'C'; + TYPE NON_GRAPHIC_CHAR_STRING IS ARRAY (POSITIVE RANGE <>) + OF NON_GRAPHIC_CHAR; + + C_STR : CHAR_STRING (1 .. 1); + C_STR_5 : CHAR_STRING (1 .. 5) := "BBBBB"; + N_G_STR : NON_GRAPHIC_CHAR_STRING (1 .. 1) := + (OTHERS => NON_GRAPHIC_CHAR'FIRST); + + BEGIN + + BEGIN + C_STR_5 := "BABCC"; -- 'A' NOT IN COMPONENT SUBTYPE. + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1 " & + CHAR_COMP'IMAGE(C_STR_5(1))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 1"); + END; + + BEGIN + C_STR_5 := "BCBCD"; -- 'D' NOT IN COMPONENT SUBTYPE. + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2 " & + CHAR_COMP'IMAGE(C_STR_5(1))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + END; + + BEGIN + N_G_STR := "Z"; + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3 " & + INTEGER'IMAGE(CHARACTER'POS(N_G_STR(1)))); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + END; + + END; + + RESULT; + + END C42006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c42007e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c42007e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c42007e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c42007e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C42007E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A STRING LITERAL ARE DETERMINED CORRECTLY. + -- IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY 'FIRST OF THE + -- INDEX SUBTYPE WHEN THE STRING LITERAL IS USED AS: + + -- E) THE LEFT OR RIGHT OPERAND OF "&". + + -- TBN 7/28/86 + + WITH REPORT; USE REPORT; + PROCEDURE C42007E IS + + BEGIN + + TEST("C42007E", "CHECK THE BOUNDS OF A STRING LITERAL WHEN USED " & + "AS THE LEFT OR RIGHT OPERAND OF THE CATENATION " & + "OPERATOR"); + + BEGIN + + CASE_E : DECLARE + + SUBTYPE STR_RANGE IS INTEGER RANGE 2 .. 10; + TYPE STR IS ARRAY (STR_RANGE RANGE <>) OF CHARACTER; + + FUNCTION CONCAT1 RETURN STR IS + BEGIN + RETURN ("ABC" & (7 .. 8 => 'D')); + END CONCAT1; + + FUNCTION CONCAT2 RETURN STR IS + BEGIN + RETURN ((IDENT_INT(4) .. 3 => 'A') & "BC"); + END CONCAT2; + + FUNCTION CONCAT3 RETURN STRING IS + BEGIN + RETURN ("TEST" & (7 .. 8 => 'X')); + END CONCAT3; + + FUNCTION CONCAT4 RETURN STRING IS + BEGIN + RETURN ((8 .. 5 => 'A') & "DE"); + END CONCAT4; + + BEGIN + + IF CONCAT1'FIRST /= IDENT_INT(2) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 1"); + END IF; + IF CONCAT1'LAST /= 6 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 1"); + END IF; + IF CONCAT1 /= "ABCDD" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 1"); + END IF; + + IF CONCAT2'FIRST /= IDENT_INT(2) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 2"); + END IF; + IF CONCAT2'LAST /= 3 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 2"); + END IF; + IF CONCAT2 /= "BC" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 2"); + END IF; + + IF CONCAT3'FIRST /= IDENT_INT(1) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 3"); + END IF; + IF CONCAT3'LAST /= 6 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 3"); + END IF; + IF CONCAT3 /= "TESTXX" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 3"); + END IF; + + IF CONCAT4'FIRST /= IDENT_INT(1) THEN + FAILED ("LOWER BOUND INCORRECTLY DETERMINED - 4"); + END IF; + IF CONCAT4'LAST /= 2 THEN + FAILED ("UPPER BOUND INCORRECTLY DETERMINED - 4"); + END IF; + IF CONCAT4 /= "DE" THEN + FAILED ("STRING INCORRECTLY DETERMINED - 4"); + END IF; + + END CASE_E; + + END; + + RESULT; + + END C42007E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43003a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C43003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN INITIALIZING AN ARRAY OF ACCESS OBJECTS, WITH + -- AN AGGREGATE CONTAINING A SINGLE ALLOCATOR, ALL ELEMENTS + -- ARE INITIALIZED TO THE SAME INITIAL VALUE. + -- THAT IS, CHECK THAT ALL COMPONENTS OF THE ARRAY DESIGNATE + -- DISTINCT OBJECTS. + + -- DAT 3/18/81 + -- SPS 10/26/82 + -- JBG 12/27/82 + -- R. WILLIAMS 11/11/86 RENAMED FROM C38007A-B.ADA. + + WITH REPORT; USE REPORT; + + PROCEDURE C43003A IS + + TYPE AI IS ACCESS INTEGER; + + TYPE AAI IS ARRAY (1..5) OF AI; + + A : AAI := AAI'(OTHERS => NEW INTEGER '(2)); + + BEGIN + TEST ("C43003A", "CHECK THAT ALLOCATORS IN INITIALIZATIONS" + & " FOR ARRAYS OF ACCESS VALUES ARE EVALUATED ONCE" & + " FOR EACH COMPONENT"); + + FOR I IN 1..5 + LOOP + FOR J IN I+1..5 + LOOP + IF A(I) = A(J) THEN + FAILED ("DID NOT EVALUATE ALLOCATOR FOR EACH " & + "COMPONENT"); + EXIT; + END IF; + END LOOP; + END LOOP; + + RESULT; + END C43003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43004a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- C43004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A VALUE FOR A + -- NON-DISCRIMINANT SCALAR COMPONENT OF AN AGGREGATE IS NOT + -- WITHIN THE RANGE OF THE COMPONENT'S SUBTYPE. + + -- HISTORY: + -- BCB 01/22/88 CREATED ORIGINAL TEST. + -- RJW 06/27/90 CORRECTED CONSTRAINTS OF TYPE DFIX. + -- LDC 09/25/90 ADDED A BLOCK IN THE EXCEPTION HANDLER SO IT CAN + -- NOT OPTIMIZE IT AWAY, ALSO INITIALIZED EACH + -- OBJECT TO VALID DATA BEFORE DOING THE INVALID, + -- MADE 'IDENT_XXX' FUNCTIONS SO THE COMPILER CAN + -- NOT JUST EVALUATE THE ASSIGNMENT AND PUT IN CODE + -- FOR A CONSTRAINT ERROR IN IS PLACE. + -- JRL 06/07/96 Changed value in aggregate in subtest 4 to value + -- guaranteed to be in the base range of the type FIX. + -- Corrected typo. + + WITH REPORT; USE REPORT; + + PROCEDURE C43004A IS + + TYPE INT IS RANGE 1 .. 8; + SUBTYPE SINT IS INT RANGE 2 .. 7; + + TYPE ENUM IS (VINCE, JOHN, TOM, PHIL, ROSA, JODIE, BRIAN, DAVE); + SUBTYPE SENUM IS ENUM RANGE JOHN .. BRIAN; + + TYPE FL IS DIGITS 5 RANGE 0.0 .. 10.0; + SUBTYPE SFL IS FL RANGE 1.0 .. 9.0; + + TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 8.0; + SUBTYPE SFIX IS FIX RANGE 1.0 .. 7.0; + + TYPE DINT IS NEW INTEGER RANGE 1 .. 8; + SUBTYPE SDINT IS DINT RANGE 2 .. 7; + + TYPE DENUM IS NEW ENUM RANGE VINCE .. DAVE; + SUBTYPE SDENUM IS DENUM RANGE JOHN .. BRIAN; + + TYPE DFL IS NEW FLOAT RANGE 0.0 .. 10.0; + SUBTYPE SDFL IS DFL RANGE 1.0 .. 9.0; + + TYPE DFIX IS NEW FIX RANGE 0.5 .. 7.5; + SUBTYPE SDFIX IS DFIX RANGE 1.0 .. 7.0; + + TYPE REC1 IS RECORD + E1, E2, E3, E4, E5 : SENUM; + END RECORD; + + TYPE REC2 IS RECORD + E1, E2, E3, E4, E5 : SFIX; + END RECORD; + + TYPE REC3 IS RECORD + E1, E2, E3, E4, E5 : SDENUM; + END RECORD; + + TYPE REC4 IS RECORD + E1, E2, E3, E4, E5 : SDFIX; + END RECORD; + + ARRAY_OBJ : ARRAY(1..2) OF INTEGER; + + A : ARRAY(1..5) OF SINT; + B : REC1; + C : ARRAY(1..5) OF SFL; + D : REC2; + E : ARRAY(1..5) OF SDINT; + F : REC3; + G : ARRAY(1..5) OF SDFL; + H : REC4; + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN; + + FUNCTION GENEQUAL(ONE, TWO : GENERAL_PURPOSE) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END GENEQUAL; + + FUNCTION EQUAL IS NEW GENEQUAL(SENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SFL); + FUNCTION EQUAL IS NEW GENEQUAL(SFIX); + FUNCTION EQUAL IS NEW GENEQUAL(SDENUM); + FUNCTION EQUAL IS NEW GENEQUAL(SDFL); + FUNCTION EQUAL IS NEW GENEQUAL(SDFIX); + + GENERIC + TYPE GENERAL_PURPOSE IS PRIVATE; + WITH FUNCTION EQUAL_GENERAL(ONE, TWO : GENERAL_PURPOSE) + RETURN BOOLEAN; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; + FUNCTION GEN_IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS + BEGIN + IF EQUAL_GENERAL (X, X) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + -- NEVER EXECUTED. + RETURN X; + END GEN_IDENT; + + FUNCTION IDENT_FL IS NEW GEN_IDENT(FL, EQUAL); + FUNCTION IDENT_FIX IS NEW GEN_IDENT(FIX, EQUAL); + FUNCTION IDENT_DFL IS NEW GEN_IDENT(DFL, EQUAL); + FUNCTION IDENT_DFIX IS NEW GEN_IDENT(DFIX, EQUAL); + + BEGIN + TEST ("C43004A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & + "VALUE FOR A NON-DISCRIMINANT SCALAR COMPONENT " & + "OF AN AGGREGATE IS NOT WITHIN THE RANGE OF " & + "THE COMPONENT'S SUBTYPE"); + + ARRAY_OBJ := (1, 2); + + BEGIN + A := (2,3,4,5,6); -- OK + + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + + A := (SINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 1"); + IF EQUAL (INTEGER (A(IDENT_INT(1))), + INTEGER (A(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE A"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 1"); + END; + + BEGIN + B := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + + IF EQUAL (B.E1, B.E2) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + + B := (ENUM'VAL(IDENT_INT(ENUM'POS(DAVE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF AN + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 2"); + IF NOT EQUAL (B.E1, B.E1) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 2"); + END; + BEGIN + C := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (C(IDENT_INT(1)), C(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + + C := (IDENT_FL(1.0),2.0,3.0,4.0,IDENT_FL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FLOATING POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 3"); + IF NOT EQUAL (C(IDENT_INT(1)), C(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE C"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 3"); + END; + + BEGIN + D := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (D.E1, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + + D := (IDENT_FIX(1.0),2.1,3.3,4.4,IDENT_FIX(7.75)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH FIXED POINT COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 4"); + IF NOT EQUAL (D.E5, D.E5) THEN + COMMENT ("DON'T OPTIMIZE D"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 4"); + END; + + BEGIN + E := (2,3,4,5,6); -- OK + IF EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(2)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + + E := (SDINT(IDENT_INT(1)),2,3,4,7); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED INTEGER COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 5"); + IF NOT EQUAL (INTEGER (E(IDENT_INT(1))), + INTEGER (E(IDENT_INT(1)))) THEN + COMMENT ("DON'T OPTIMIZE E"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 5"); + END; + + BEGIN + F := (JOHN,TOM,PHIL,ROSA,JOHN); -- OK + IF EQUAL (F.E1, F.E2) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + + F := (DENUM'VAL(IDENT_INT(DENUM'POS(VINCE))), TOM, PHIL, + ROSA, JODIE); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH COMPONENTS OF A DERIVED + -- ENUMERATION TYPE. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 6"); + IF NOT EQUAL (F.E1, F.E1) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 6"); + END; + + BEGIN + G := (2.0,3.0,4.0,5.0,6.0); -- OK + IF EQUAL (G(IDENT_INT(1)), G(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + + G := (IDENT_DFL(1.0),2.0,3.0,4.0,IDENT_DFL(10.0)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FLOATING POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 7"); + IF NOT EQUAL (G(IDENT_INT(1)), G(IDENT_INT(1))) THEN + COMMENT ("DON'T OPTIMIZE G"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 7"); + END; + + BEGIN + H := (2.2,3.3,4.4,5.5,6.6); -- OK + IF EQUAL (H.E1, H.E2) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + + H := (IDENT_DFIX(2.0),2.5,3.5,4.3,IDENT_DFIX(7.4)); + -- CONSTRAINT_ERROR BY AGGREGATE + -- WITH DERIVED FIXED POINT + -- COMPONENTS. + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED - 8"); + IF EQUAL (H.E1, H.E5) THEN + COMMENT ("DON'T OPTIMIZE H"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF EQUAL (ARRAY_OBJ(IDENT_INT(1)), + ARRAY_OBJ(IDENT_INT(2))) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION HANDLER"); + END IF; + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED - 8"); + END; + + + RESULT; + END C43004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43004c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- C43004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE VALUE OF A + -- DISCRIMINANT OF A CONSTRAINED COMPONENT OF AN AGGREGATE DOES + -- NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR THE + -- COMPONENT'S SUBTYPE. + + -- HISTORY: + -- BCB 07/19/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C43004C IS + + ZERO : INTEGER := 0; + + TYPE REC (D : INTEGER := 0) IS RECORD + COMP1 : INTEGER; + END RECORD; + + TYPE DREC (DD : INTEGER := ZERO) IS RECORD + DCOMP1 : INTEGER; + END RECORD; + + TYPE REC1 IS RECORD + A : REC(0); + END RECORD; + + TYPE REC2 IS RECORD + B : DREC(ZERO); + END RECORD; + + TYPE REC3 (D3 : INTEGER := 0) IS RECORD + C : REC(D3); + END RECORD; + + V : REC1; + W : REC2; + X : REC3; + + PACKAGE P IS + TYPE PRIV1 (D : INTEGER := 0) IS PRIVATE; + TYPE PRIV2 (DD : INTEGER := ZERO) IS PRIVATE; + FUNCTION INIT (I : INTEGER) RETURN PRIV1; + PRIVATE + TYPE PRIV1 (D : INTEGER := 0) IS RECORD + NULL; + END RECORD; + + TYPE PRIV2 (DD : INTEGER := ZERO) IS RECORD + NULL; + END RECORD; + END P; + + TYPE REC7 IS RECORD + H : P.PRIV1 (0); + END RECORD; + + Y : REC7; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN; + + FUNCTION GEN_EQUAL (X, Y : GP) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END GEN_EQUAL; + + PACKAGE BODY P IS + TYPE REC4 IS RECORD + E : PRIV1(0); + END RECORD; + + TYPE REC5 IS RECORD + F : PRIV2(ZERO); + END RECORD; + + TYPE REC6 (D6 : INTEGER := 0) IS RECORD + G : PRIV1(D6); + END RECORD; + + VV : REC4; + WW : REC5; + XX : REC6; + + FUNCTION REC4_EQUAL IS NEW GEN_EQUAL (REC4); + FUNCTION REC5_EQUAL IS NEW GEN_EQUAL (REC5); + FUNCTION REC6_EQUAL IS NEW GEN_EQUAL (REC6); + + FUNCTION INIT (I : INTEGER) RETURN PRIV1 IS + VAR : PRIV1; + BEGIN + VAR := (D => I); + RETURN VAR; + END INIT; + BEGIN + TEST ("C43004C", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "IF THE VALUE OF A DISCRIMINANT OF A " & + "CONSTRAINED COMPONENT OF AN AGGREGATE " & + "DOES NOT EQUAL THE CORRESPONDING " & + "DISCRIMINANT VALUE FOR THECOMPONENT'S " & + "SUBTYPE"); + + BEGIN + VV := (E => (D => 1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 1"); + IF REC4_EQUAL (VV,VV) THEN + COMMENT ("DON'T OPTIMIZE VV"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + WW := (F => (DD => 1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 2"); + IF REC5_EQUAL (WW,WW) THEN + COMMENT ("DON'T OPTIMIZE WW"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + BEGIN + XX := (D6 => 1, G => (D => 5)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 3"); + IF REC6_EQUAL (XX,XX) THEN + COMMENT ("DON'T OPTIMIZE XX"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 3"); + END; + END P; + + USE P; + + FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1); + FUNCTION REC2_EQUAL IS NEW GEN_EQUAL (REC2); + FUNCTION REC3_EQUAL IS NEW GEN_EQUAL (REC3); + FUNCTION REC7_EQUAL IS NEW GEN_EQUAL (REC7); + + BEGIN + + BEGIN + V := (A => (D => 1, COMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 4"); + IF REC1_EQUAL (V,V) THEN + COMMENT ("DON'T OPTIMIZE V"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + END; + + BEGIN + W := (B => (DD => 1, DCOMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 5"); + IF REC2_EQUAL (W,W) THEN + COMMENT ("DON'T OPTIMIZE W"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 5"); + END; + + BEGIN + X := (D3 => 1, C => (D => 5, COMP1 => 2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 6"); + IF REC3_EQUAL (X,X) THEN + COMMENT ("DON'T OPTIMIZE X"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 6"); + END; + + BEGIN + Y := (H => INIT (1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - 7"); + IF REC7_EQUAL (Y,Y) THEN + COMMENT ("DON'T OPTIMIZE Y"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 7"); + END; + + RESULT; + END C43004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c431001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c431001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c431001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c431001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,464 ---- + -- C431001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a record aggregate can be given for a nonprivate, + -- nonlimited record extension and that the tag of the aggregate + -- values are initialized to the tag of the record extension. + -- + -- TEST DESCRIPTION: + -- From an initial parent tagged type, several type extensions + -- are declared. Each type extension adds components onto + -- the existing record structure. + -- + -- In the main procedure, aggregates are declared in two ways. + -- In the declarative part, aggregates are used to supply + -- initial values for objects of specific types. In the executable + -- part, aggregates are used directly as actual parameters to + -- a class-wide formal parameter. + -- + -- The abstraction is for a catalog of recordings. A recording + -- can be a CD or a record (vinyl). Additionally, a CD may also + -- be a CD-ROM, containing both music and data. This type is declared + -- as an extension to a type extension, to test that the inclusion + -- of record components is transitive across multiple extensions. + -- + -- That the aggregate has the correct tag is verify by feeding + -- it to a dispatching operation and confirming that the + -- expected subprogram is called as a result. To accomplish this, + -- an enumeration type is declared with an enumeration literal + -- representing each of the declared types in the hierarchy. A value + -- of this type is passed as a parameter to the dispatching + -- operation which passes it along to the dispatched subprogram. + -- Each dispatched subprogram verifies that it received the + -- expected enumeration literal. + -- + -- Not quite fitting the above abstraction are several test cases + -- for null records. These tests verify that the new syntax for + -- null record aggregates, (null record), is supported. A type is + -- declared which extends a null tagged type and adds components. + -- Aggregates of this type should include associations for the + -- components of the type extension only. Finally, a type is + -- declared that adds a null type extension onto a non-null tagged + -- type. The aggregate associations should remain the same. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- + --! + -- + package C431001_0 is + + -- Values of TC_Type_ID are passed through to dispatched subprogram + -- calls so that it can be verified that the dispatching resulted in + -- the expected call. + type TC_Type_ID is (TC_Recording, TC_CD, TC_Vinyl, TC_CD_ROM); + + type Genre is (Classical, Country, Jazz, Rap, Rock, World); + + type Recording is tagged record + Artist : String (1..20); + Category : Genre; + Length : Duration; + Selections : Positive; + end record; + + function Summary (R : in Recording; + TC_Type : in TC_Type_ID) return String; + + type Recording_Method is (Audio, Digital); + type CD is new Recording with record + Recorded : Recording_Method; + Mastered : Recording_Method; + end record; + + function Summary (Disc : in CD; + TC_Type : in TC_Type_ID) return String; + + type Playing_Speed is (LP_33, Single_45, Old_78); + type Vinyl is new Recording with record + Speed : Playing_Speed; + end record; + + function Summary (Album : in Vinyl; + TC_Type : in TC_Type_ID) return String; + + + type CD_ROM is new CD with record + Storage : Positive; + end record; + + function Summary (Disk : in CD_ROM; + TC_Type : in TC_Type_ID) return String; + + function Catalog_Entry (R : in Recording'Class; + TC_Type : in TC_Type_ID) return String; + + procedure Print (S : in String); -- provides somewhere for the + -- results of Catalog_Entry to + -- "go", so they don't get + -- optimized away. + + -- The types and procedures declared below are not a continuation + -- of the Recording abstraction. These types are intended to test + -- support for null tagged types and type extensions. TC_Check mirrors + -- the operation of function Summary, above. Similarly, TC_Dispatch + -- mirrors the operation of Catalog_Entry. + + type TC_N_Type_ID is + (TC_Null_Tagged, TC_Null_Extension, + TC_Extension_Of_Null, TC_Null_Extension_Of_Nonnull); + + type Null_Tagged is tagged null record; + procedure TC_Check (N : in Null_Tagged; + TC_Type : in TC_N_Type_ID); + + type Null_Extension is new Null_Tagged with null record; + procedure TC_Check (N : in Null_Extension; + TC_Type : in TC_N_Type_ID); + + type Extension_Of_Null is new Null_Tagged with record + New_Component1 : Boolean; + New_Component2 : Natural; + end record; + procedure TC_Check (N : in Extension_Of_Null; + TC_Type : in TC_N_Type_ID); + + type Null_Extension_Of_Nonnull is new Extension_Of_Null + with null record; + procedure TC_Check (N : in Null_Extension_Of_Nonnull; + TC_Type : in TC_N_Type_ID); + + procedure TC_Dispatch (N : in Null_Tagged'Class; + TC_Type : in TC_N_Type_ID); + + end C431001_0; + + with Report; + package body C431001_0 is + + function Summary (R : in Recording; + TC_Type : in TC_Type_ID) return String is + begin + + if TC_Type /= TC_Recording then + Report.Failed ("Did not dispatch on tag for tagged parent " & + "type Recording"); + end if; + + return R.Artist (1..10) + & ' ' & Genre'Image (R.Category) (1..2) + & ' ' & Duration'Image (R.Length) + & ' ' & Integer'Image (R.Selections); + + end Summary; + + function Summary (Disc : in CD; + TC_Type : in TC_Type_ID) return String is + begin + + if TC_Type /= TC_CD then + Report.Failed ("Did not dispatch on tag for type extension " & + "CD"); + end if; + + return Summary (Recording (Disc), TC_Type => TC_Recording) + & ' ' & Recording_Method'Image(Disc.Recorded)(1) + & Recording_Method'Image(Disc.Mastered)(1); + + end Summary; + + function Summary (Album : in Vinyl; + TC_Type : in TC_Type_ID) return String is + begin + if TC_Type /= TC_Vinyl then + Report.Failed ("Did not dispatch on tag for type extension " & + "Vinyl"); + end if; + + case Album.Speed is + when LP_33 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 33"; + when Single_45 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 45"; + when Old_78 => + return Summary (Recording (Album), TC_Type => TC_Recording) + & " 78"; + end case; + + end Summary; + + function Summary (Disk : in CD_ROM; + TC_Type : in TC_Type_ID) return String is + begin + if TC_Type /= TC_CD_ROM then + Report.Failed ("Did not dispatch on tag for type extension " & + "CD_ROM. This is an extension of the type " & + "extension CD"); + end if; + + return Summary (Recording(Disk), TC_Type => TC_Recording) + & ' ' & Integer'Image (Disk.Storage) & 'K'; + + end Summary; + + function Catalog_Entry (R : in Recording'Class; + TC_Type : in TC_Type_ID) return String is + begin + return Summary (R, TC_Type); -- dispatched call + end Catalog_Entry; + + procedure Print (S : in String) is + T : String (1..S'Length) := Report.Ident_Str (S); + begin + -- Ada.Text_IO.Put_Line (S); + null; + end Print; + + -- Bodies for null type checks + procedure TC_Check (N : in Null_Tagged; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Tagged then + Report.Failed ("Did not dispatch on tag for null tagged " & + "type Null_Tagged"); + end if; + end TC_Check; + + procedure TC_Check (N : in Null_Extension; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Extension then + Report.Failed ("Did not dispatch on tag for null tagged " & + "type extension Null_Extension"); + end if; + end TC_Check; + + procedure TC_Check (N : in Extension_Of_Null; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Extension_Of_Null then + Report.Failed + ("Did not dispatch on tag for extension of null parent" & + "type"); + end if; + end TC_Check; + + procedure TC_Check (N : in Null_Extension_Of_Nonnull; + TC_Type : in TC_N_Type_ID) is + begin + if TC_Type /= TC_Null_Extension_Of_Nonnull then + Report.Failed + ("Did not dispatch on tag for null extension of nonnull " & + "parent type"); + end if; + end TC_Check; + + procedure TC_Dispatch (N : in Null_Tagged'Class; + TC_Type : in TC_N_Type_ID) is + begin + TC_Check (N, TC_Type); -- dispatched call + end TC_Dispatch; + + end C431001_0; + + + with C431001_0; + with Report; + procedure C431001 is + + -- Tagged type + -- Named component associations + DAT : C431001_0.Recording := + (Artist => "Aerosmith ", + Category => C431001_0.Rock, + Length => 48.5, + Selections => 10); + + -- Type extensions + -- Named component associations + Disc1 : C431001_0.CD := + (Artist => "London Symphony ", + Category => C431001_0.Classical, + Length => 55.0, + Selections => 4, + Recorded => C431001_0.Digital, + Mastered => C431001_0.Digital); + + -- Named component associations with others + Disc2 : C431001_0.CD := + (Artist => "Pink Floyd ", + Category => C431001_0.Rock, + Length => 51.8, + Selections => 5, + others => C431001_0.Audio); -- Recorded + -- Mastered + + -- Positional component associations + Album1 : C431001_0.Vinyl := + ("Hammer ", -- Artist + C431001_0.Rap, -- Category + 46.2, -- Length + 9, -- Selections + C431001_0.LP_33); -- Speed + + -- Mixed positional and named component associations + -- Named component associations out of order + Album2 : C431001_0.Vinyl := + ("Balinese Gamelan ", -- Artist + C431001_0.World, -- Category + 42.6, -- Length + 14, -- Selections + C431001_0.LP_33); -- Speed + + -- Type extension, parent is also type extension + -- Named notation, components out of order + Data : C431001_0.CD_ROM := + (Storage => 140, + Mastered => C431001_0.Digital, + Category => C431001_0.Rock, + Selections => 10, + Recorded => C431001_0.Digital, + Artist => "Black, Clint ", + Length => 48.5); + + -- Null tagged type + Null_Rec : C431001_0.Null_Tagged := (null record); + + -- Null type extension + Null_Ext : C431001_0.Null_Extension := (null record); + + -- Nonnull extension of null parent + Ext_Of_Null : C431001_0.Extension_Of_Null := (True, 0); + + -- Null extension of nonnull parent + Null_Ext_Of_Nonnull : C431001_0.Null_Extension_Of_Nonnull + := (False, 1); + + begin + + Report.Test ("C431001", "Aggregate values for type extensions"); + + C431001_0.Print (C431001_0.Catalog_Entry (DAT, C431001_0.TC_Recording)); + C431001_0.Print (C431001_0.Catalog_Entry (Disc1, C431001_0.TC_CD)); + C431001_0.Print (C431001_0.Catalog_Entry (Disc2, C431001_0.TC_CD)); + C431001_0.Print (C431001_0.Catalog_Entry (Album1, C431001_0.TC_Vinyl)); + C431001_0.Print (C431001_0.Catalog_Entry (Album2, C431001_0.TC_Vinyl)); + C431001_0.Print (C431001_0.Catalog_Entry (Data, C431001_0.TC_CD_ROM)); + + C431001_0.TC_Dispatch (Null_Rec, C431001_0.TC_Null_Tagged); + C431001_0.TC_Dispatch (Null_Ext, C431001_0.TC_Null_Extension); + C431001_0.TC_Dispatch (Ext_Of_Null, C431001_0.TC_Extension_Of_Null); + C431001_0.TC_Dispatch + (Null_Ext_Of_Nonnull, C431001_0.TC_Null_Extension_Of_Nonnull); + + -- Tagged type + -- Named component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Recording, + R => C431001_0.Recording'(Artist => "Zappa, Frank ", + Category => C431001_0.Rock, + Length => 70.0, + Selections => 38))); + + -- Type extensions + -- Named component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD, + R => C431001_0.CD'(Artist => "Dog, Snoop Doggy ", + Category => C431001_0.Rap, + Length => 37.3, + Selections => 8, + Recorded => C431001_0.Audio, + Mastered => C431001_0.Digital))); + + -- Named component associations with others + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD, + R => C431001_0.CD'(Artist => "Judd, Winona ", + Category => C431001_0.Country, + Length => 51.2, + Selections => 11, + others => C431001_0.Digital))); -- Recorded + -- Mastered + + -- Positional component associations + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Vinyl, + R => C431001_0.Vinyl'("Davis, Miles ", -- Artist + C431001_0.Jazz, -- Category + 50.4, -- Length + 10, -- Selections + C431001_0.LP_33))); -- Speed + + -- Mixed positional and named component associations + -- Named component associations out of order + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_Vinyl, + R => C431001_0.Vinyl'("Zamfir ", -- Artist + C431001_0.World, -- Category + Speed => C431001_0.LP_33, + Selections => 14, + Length => 56.5))); + + -- Type extension, parent is also type extension + -- Named notation, components out of order + C431001_0.Print (C431001_0.Catalog_Entry + (TC_Type => C431001_0.TC_CD_ROM, + R => C431001_0.CD_ROM'(Storage => 720, + Category => C431001_0.Classical, + Recorded => C431001_0.Digital, + Artist => "Baltimore Symphony ", + Length => 68.9, + Mastered => C431001_0.Digital, + Selections => 5))); + + -- Null tagged type + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Null_Tagged, + N => C431001_0.Null_Tagged'(null record)); + + -- Null type extension + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Null_Extension, + N => C431001_0.Null_Extension'(null record)); + + -- Nonnull extension of null parent + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Extension_Of_Null, + N => C431001_0.Extension_Of_Null'(True, 3)); + + -- Null extension of nonnull parent + C431001_0.TC_Dispatch + (TC_Type => C431001_0.TC_Extension_Of_Null, + N => C431001_0.Extension_Of_Null'(False, 4)); + + Report.Result; + + end C431001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43103a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- C43103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN A VARIANT PART, + -- ITS VALUE CAN BE GIVEN BY A NON-STATIC EXPRESSION. + + -- EG 02/13/84 + + WITH REPORT; + + PROCEDURE C43103A IS + + USE REPORT; + + BEGIN + + TEST("C43103A","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " & + "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " & + "NON-STATIC EXPRESSION"); + + BEGIN + + COMMENT ("CASE A : DISCRIMINANT THAT IS NOT USED INSIDE " & + "THE RECORD"); + + CASE_A : DECLARE + + TYPE R1 (A : INTEGER) IS + RECORD + B : STRING(1 .. 2); + C : INTEGER; + END RECORD; + + A1 : R1(IDENT_INT(5)) := (IDENT_INT(5), "AB", -2); + + BEGIN + + IF A1.A /= IDENT_INT(5) OR A1.B /= "AB" OR + A1.C /= -2 THEN + FAILED ("CASE A : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_A; + + COMMENT ("CASE B : DISCRIMINANT THAT IS USED AS AN ARRAY " & + "INDEX BOUND"); + + CASE_B : DECLARE + + SUBTYPE STB IS INTEGER RANGE 1 .. 10; + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + TYPE R2 (A : STB) IS + RECORD + B : TB(1 .. A); + C : BOOLEAN; + END RECORD; + + B1 : R2(IDENT_INT(2)) := (IDENT_INT(2), (-1, -2), FALSE); + + BEGIN + + IF B1.B'LAST /= IDENT_INT(2) THEN + FAILED ("CASE B : INCORRECT UPPER BOUND"); + ELSIF B1.A /= IDENT_INT(2) OR B1.B /= (-1, -2) OR + B1.C /= FALSE THEN + FAILED ("CASE B : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_B; + + COMMENT ("CASE C : DISCRIMINANT THAT IS USED IN A " & + "DISCRIMINANT CONSTRAINT"); + + CASE_C : DECLARE + + SUBTYPE STC IS INTEGER RANGE 1 .. 10; + TYPE TC IS ARRAY(STC RANGE <>) OF INTEGER; + TYPE R3 (A : STC) IS + RECORD + B : TC(1 .. A); + C : INTEGER := -4; + END RECORD; + TYPE R4 (A : INTEGER) IS + RECORD + B : R3(A); + C : INTEGER; + END RECORD; + + C1 : R4(IDENT_INT(3)) := (IDENT_INT(3), + (IDENT_INT(3), (1, 2, 3), 4), + 5); + + BEGIN + + IF C1.B.B /= (1, 2, 3) OR C1.B.C /= 4 OR + C1.C /= 5 THEN + FAILED ("CASE C : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_C; + + END; + + RESULT; + + END C43103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43103b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43103b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43103b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43103b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- C43103B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN A VARIANT PART, ITS + -- VALUE CAN BE GIVEN BY A NONSTATIC EXPRESSION. + -- ADDITIONAL CASES OF USE OF A DISCRIMINANT THAT IS USED AS AN + -- ARRAY INDEX BOUND. + + -- PK 02/21/84 + -- EG 05/30/84 + -- EG 11/02/84 + -- DN 12/01/95 REMOVED CONFORMANCE CHECKS WHERE RULES RELAXED. + -- PWN 10/25/96 RESTORED CHECK WITH ADA 95 EXPECTED RESULTS INCLUDED. + + WITH REPORT; + USE REPORT; + + PROCEDURE C43103B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER; + + SUBTYPE DINT IS INTEGER RANGE 0 .. 10; + + TYPE REC(D, E : DINT := IDENT_INT(1)) IS RECORD + U : A2(1 .. D, E .. 3) := (1 .. D => + (E .. 3 => IDENT_INT(1))); + END RECORD; + + BEGIN + + TEST("C43103B","CHECK THAT IF A DISCRIMINANT DOES NOT GOVERN " & + "A VARIANT PART, ITS VALUE CAN BE GIVEN BY A " & + "NONSTATIC EXPRESSION"); + + -- SIMPLE DECLARATIONS + + BEGIN + + DECLARE + + L : REC(IDENT_INT(2), IDENT_INT(2)); + K : REC(IDENT_INT(0), IDENT_INT(1)); + M : REC(IDENT_INT(3), IDENT_INT(4)); + + BEGIN + IF L.U'FIRST(1) /= IDENT_INT(1) OR + L.U'LAST(1) /= IDENT_INT(2) OR + L.U'FIRST(2) /= IDENT_INT(2) OR + L.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.1 - INCORRECT BOUNDS"); + END IF; + IF K.U'FIRST(1) /= IDENT_INT(1) OR + K.U'LAST(1) /= IDENT_INT(0) OR + K.U'FIRST(2) /= IDENT_INT(1) OR + K.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.2 - INCORRECT BOUNDS"); + END IF; + IF M.U'FIRST(1) /= IDENT_INT(1) OR + M.U'LAST(1) /= IDENT_INT(3) OR + M.U'FIRST(2) /= IDENT_INT(4) OR + M.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("1.3 - INCORRECT BOUNDS"); + END IF; + IF M.U'LENGTH(1) /= 3 OR M.U'LENGTH(2) /= 0 THEN + FAILED("1.4 - INCORRECT ARRAY LENGTH"); + END IF; + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("1.5 - EXCEPTION RAISED"); + + END; + + -- EXPLICIT INITIAL VALUE - OK + + BEGIN + + DECLARE + O : CONSTANT REC := (IDENT_INT(2), IDENT_INT(2), + ((1, IDENT_INT(2)), (IDENT_INT(2), 3))); + BEGIN + IF O.U'FIRST(1) /= IDENT_INT(1) OR + O.U'LAST(1) /= IDENT_INT(2) OR + O.U'FIRST(2) /= IDENT_INT(2) OR + O.U'LAST(2) /= IDENT_INT(3) THEN + FAILED("2.1 - INCORRECT BOUNDS"); + END IF; + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("2.2 - EXCEPTION RAISED"); + END; + + -- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(3) .. IDENT_INT(0) => + (IDENT_INT(2), 3))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("3.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("3.2 - WRONG EXCEPTION RAISED"); + END; + + -- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(3) .. IDENT_INT(0) => + (OTHERS => IDENT_INT(2)))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("4.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("4.2 - WRONG EXCEPTION RAISED"); + + END; + + -- EXPLICIT INITIAL VALUE: NULL ARRAY WITH WRONG BOUNDS 2ND DIM. + + BEGIN + + DECLARE + P : CONSTANT REC := (IDENT_INT(0), IDENT_INT(2), + (IDENT_INT(1) .. IDENT_INT(0) => + (IDENT_INT(1) .. IDENT_INT(2) => + 1))); + BEGIN + NULL; + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("5.1 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("5.2 - WRONG EXCEPTION RAISED"); + + END; + + RESULT; + + END C43103B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43104a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C43104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WITH THE TYPE OF THE AGGREGATE RESOLVED, THE + -- DISCRIMINANT MAY BE USED TO DECIDE TO WHICH OF THE VARIANT'S + -- SUBTYPES THE AGGREGATE BELONGS. + + -- HISTORY: + -- DHH 08/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43104A IS + + TYPE INT IS RANGE 0 .. 10; + + TYPE VAR_REC(BOOL : BOOLEAN := TRUE) IS + RECORD + CASE BOOL IS + WHEN TRUE => + X : INTEGER; + WHEN FALSE => + Y : INT; + END CASE; + END RECORD; + + SUBTYPE S_TRUE IS VAR_REC(TRUE); + SUBTYPE S_FALSE IS VAR_REC(FALSE); + + PROCEDURE CHECK(P : IN S_TRUE) IS + BEGIN + IF P.BOOL = FALSE THEN + FAILED("WRONG PROCEDURE ENTERED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + + END CHECK; + + BEGIN + TEST("C43104A", "CHECK THAT WITH THE TYPE OF THE AGGREGATE " & + "RESOLVED, THE DISCRIMINANT MAY BE USED TO " & + "DECIDE TO WHICH OF THE VARIANT'S SUBTYPES " & + "THE AGGREGATE BELONGS"); + + CHECK((TRUE, 1)); + + BEGIN + + CHECK((FALSE, 2)); + FAILED("PROCEDURE CALL USING '(FALSE, 2)' DID NOT RAISE " & + "EXCEPTION"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("INCORRECT EXCEPTION RAISED ON PROCEDURE CALL " & + "USING '(FALSE,2)'"); + END; + + RESULT; + END C43104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43105a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43105a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43105a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43105a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C43105A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IN A RECORD AGGREGATE, (X => E, Y => E), WHERE E IS AN OVERLOADED + -- ENUMERATION LITERAL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR + -- THE DIFFERENT OCCURRENCES OF E. + + -- HISTORY: + -- DHH 08/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43105A IS + + BEGIN + TEST("C43105A", "IN A RECORD AGGREGATE, (X => E, Y => E), WHERE " & + "E IS AN OVERLOADED ENUMERATION LITERAL, " & + "OVERLOADING RESOLUTION OCCURS SEPARATELY FOR " & + "THE DIFFERENT OCCURRENCES OF E"); + + DECLARE + TYPE COLOR IS (RED, YELLOW, GREEN); + TYPE PALETTE IS (GREEN, YELLOW, RED); + + TYPE REC IS + RECORD + X : COLOR; + Y : PALETTE; + END RECORD; + + TYPE RECD IS + RECORD + X : PALETTE; + Y : COLOR; + END RECORD; + + REC1 : REC; + REC2 : RECD; + + FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN C; + ELSE + RETURN GREEN; + END IF; + END IDENT_C; + + FUNCTION IDENT_P(P : PALETTE) RETURN PALETTE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN P; + ELSE + RETURN RED; + END IF; + END IDENT_P; + + + BEGIN + REC1 := (X => YELLOW, Y => YELLOW); + REC2 := (X => YELLOW, Y => YELLOW); + + IF REC1.X /= IDENT_C(REC2.Y) THEN + FAILED("COLOR RESOLUTION FAILED"); + END IF; + + IF REC1.Y /= IDENT_P(REC2.X) THEN + FAILED("PALETTE RESOLUTION FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED"); + END; + + RESULT; + END C43105A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43105b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43105b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43105b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43105b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C43105B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IN A RECORD AGGREGATE (X => E, Y => E), WHERE E IS AN OVERLOADED + -- FUNCTION CALL, OVERLOADING RESOLUTION OCCURS SEPARATELY FOR THE + -- DIFFERENT OCCURRENCES OF E. + + -- HISTORY: + -- DHH 09/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43105B IS + BEGIN + TEST ("C43105B", "IN A RECORD AGGREGATE (X => E, Y => E), WHERE " & + "E IS AN OVERLOADED FUNCTION CALL, OVERLOADING " & + "RESOLUTION OCCURS SEPARATELY FOR THE " & + "DIFFERENT OCCURRENCES OF E"); + + DECLARE + TYPE COLOR IS (RED, YELLOW, GREEN); + TYPE PALETTE IS (GREEN, YELLOW, RED); + + TYPE REC IS + RECORD + X : COLOR; + Y : PALETTE; + END RECORD; + + TYPE RECD IS + RECORD + X : PALETTE; + Y : COLOR; + END RECORD; + + REC1 : REC; + REC2 : RECD; + + FUNCTION IDENT_C(C : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN C; + ELSE + RETURN GREEN; + END IF; + END IDENT_C; + + FUNCTION IDENT_C(P : PALETTE) RETURN PALETTE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN P; + ELSE + RETURN RED; + END IF; + END IDENT_C; + + BEGIN + REC1 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW)); + REC2 := (X => IDENT_C(YELLOW), Y => IDENT_C(YELLOW)); + + IF REC1.X /= REC2.Y THEN + FAILED("COLOR FUNCTION RESOLUTION FAILED"); + END IF; + + IF REC1.Y /= REC2.X THEN + FAILED("PALETTE FUNCTION RESOLUTION FAILED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED"); + END; + RESULT; + END C43105B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43106a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C43106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT BOTH NAMED AND POSITIONAL NOTATIONS ARE PERMITTED + -- WITHIN THE SAME RECORD AGGREGATE, (PROVIDED THAT ALL POSITIONAL + -- ASSOCIATIONS APPEAR BEFORE ANY NAMED ASSOCIATION). + + -- HISTORY: + -- DHH 08/10/88 CREATED ORIGIANL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43106A IS + + TYPE REC IS + RECORD + A : INTEGER; + B : CHARACTER; + C : BOOLEAN; + D, E, F, G : INTEGER; + H, I, J, K : CHARACTER; + L, M, N, O : BOOLEAN; + P, Q, R, S : STRING(1 .. 3); + T, U, V, W, X, Y, Z : BOOLEAN; + END RECORD; + AGG : REC := (12, 'A', TRUE, 1, 2, 3, 4, 'B', 'C', 'D', 'E', + P|R => "ABC", S|Q => "DEF", L|X|O|U => TRUE, + OTHERS => FALSE); + + FUNCTION IDENT_CHAR(X : CHARACTER) RETURN CHARACTER IS + BEGIN + IF EQUAL(3, 3) THEN + RETURN X; + ELSE + RETURN 'Z'; + END IF; + END IDENT_CHAR; + + BEGIN + TEST("C43106A", "CHECK THAT BOTH NAMED AND POSITIONAL NOTATIONS " & + "ARE PERMITTED WITHIN THE SAME RECORD " & + "AGGREGATE, (PROVIDED THAT ALL POSITIONAL " & + "ASSOCIATIONS APPEAR BEFORE ANY NAMED " & + "ASSOCIATION)"); + + IF NOT IDENT_BOOL(AGG.C) OR NOT IDENT_BOOL(AGG.L) OR + NOT IDENT_BOOL(AGG.X) OR NOT IDENT_BOOL(AGG.O) OR + NOT IDENT_BOOL(AGG.U) OR IDENT_BOOL(AGG.M) OR + IDENT_BOOL(AGG.N) OR IDENT_BOOL(AGG.T) OR + IDENT_BOOL(AGG.V) OR IDENT_BOOL(AGG.W) OR + IDENT_BOOL(AGG.Y) OR IDENT_BOOL(AGG.Z) THEN + FAILED("BOOLEANS NOT INITIALIZED TO AGGREGATE VALUES"); + END IF; + + IF IDENT_STR(AGG.P) /= IDENT_STR(AGG.R) OR + IDENT_STR(AGG.Q) /= IDENT_STR(AGG.S) THEN + FAILED("STRINGS NOT INITIALIZED CORRECTLY"); + END IF; + + IF IDENT_CHAR(AGG.B) /= IDENT_CHAR('A') OR + IDENT_CHAR(AGG.H) /= IDENT_CHAR('B') OR + IDENT_CHAR(AGG.I) /= IDENT_CHAR('C') OR + IDENT_CHAR(AGG.J) /= IDENT_CHAR('D') OR + IDENT_CHAR(AGG.K) /= IDENT_CHAR('E') THEN + FAILED("CHARACTERS NOT INITIALIZED CORRECTLY"); + END IF; + + RESULT; + END C43106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43107a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C43107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXPRESSION ASSOCIATED WITH MORE THAN ONE RECORD + -- COMPONENT IS EVALUATED ONCE FOR EACH ASSOCIATED COMPONENT. + + -- EG 02/14/84 + + WITH REPORT; + + PROCEDURE C43107A IS + + USE REPORT; + + BEGIN + + TEST("C43107A","CHECK THAT AN EXPRESSION WITH MORE THAN ONE " & + "RECORD COMPONENT IS EVALUATED ONCE FOR EACH " & + "ASSOCIATED COMPONENT"); + + BEGIN + + CASE_A : DECLARE + + TYPE T1 IS ARRAY(1 .. 2) OF INTEGER; + TYPE R1 IS + RECORD + A : T1; + B : INTEGER; + C : T1; + D : INTEGER; + E : INTEGER; + END RECORD; + + A1 : R1; + CNTR : INTEGER := 0; + + FUNCTION FUN1 (A : T1) RETURN T1 IS + BEGIN + CNTR := IDENT_INT(CNTR+1); + RETURN A; + END FUN1; + + FUNCTION FUN2 (A : INTEGER) RETURN INTEGER IS + BEGIN + CNTR := CNTR+1; + RETURN IDENT_INT(A); + END FUN2; + + BEGIN + + A1 := (A | C => FUN1((-1, -2)), OTHERS => FUN2(-3)+1); + IF CNTR /= 5 THEN + FAILED ("CASE A : INCORRECT NUMBER OF EVALUATIONS" & + " OF RECORD ASSOCIATED COMPONENTS"); + END IF; + IF A1.A /= (-1, -2) OR A1.C /= (-1, -2) OR + A1.B /= -2 OR A1.D /= -2 OR A1.E /= -2 THEN + FAILED ("CASE A : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_A; + + CASE_B : DECLARE + + TYPE T2 IS ACCESS INTEGER; + TYPE R2 IS + RECORD + A : T2; + B : INTEGER; + C : T2; + D : INTEGER; + E : INTEGER; + END RECORD; + + B1 : R2; + CNTR : INTEGER := 0; + + FUNCTION FUN3 RETURN INTEGER IS + BEGIN + CNTR := CNTR+1; + RETURN IDENT_INT(2); + END FUN3; + + BEGIN + + B1 := (A | C => NEW INTEGER'(-1), + B | D | E => FUN3); + IF B1.A = B1.C OR CNTR /= 3 THEN + FAILED ("CASE B : INCORRECT NUMBER OF EVALUATION" & + " OF RECORD ASSOCIATED COMPONENTS"); + END IF; + IF B1.B /= 2 OR B1.D /= 2 OR B1.E /= 2 OR + B1.A = NULL OR B1.C = NULL OR B1.A = B1.C THEN + FAILED ("CASE B : INCORRECT VALUES IN RECORD"); + END IF; + + END CASE_B; + + END; + + RESULT; + + END C43107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43108a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C43108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IN A RECORD AGGREGATE THE VALUE OF A DISCRIMINANT IS + -- USED TO RESOLVE THE TYPE OF A COMPONENT THAT DEPENDS ON THE + -- DISCRIMINANT. + + -- HISTORY: + -- DHH 09/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43108A IS + + BEGIN + TEST ("C43108A", "CHECK THAT IN A RECORD AGGREGATE THE VALUE OF " & + "A DISCRIMINANT IS USED TO RESOLVE THE TYPE OF " & + "A COMPONENT THAT DEPENDS ON THE DISCRIMINANT"); + + DECLARE + A : INTEGER; + + TYPE DIS(A : BOOLEAN) IS + RECORD + CASE A IS + WHEN TRUE => + B : BOOLEAN; + C : INTEGER; + WHEN FALSE => + D : INTEGER; + END CASE; + END RECORD; + + FUNCTION DIFF(PARAM : DIS) RETURN INTEGER IS + BEGIN + IF PARAM.B THEN + RETURN PARAM.C; + ELSE + RETURN PARAM.D; + END IF; + END DIFF; + + BEGIN + A := DIFF((C => 3, OTHERS => TRUE)); + + IF A /= IDENT_INT(3) THEN + FAILED("STATIC OTHERS NOT DECIDED CORRECTLY"); + END IF; + END; + + DECLARE + GLOBAL : INTEGER := 0; + TYPE INT IS NEW INTEGER; + + TYPE DIS(A : BOOLEAN) IS + RECORD + CASE A IS + WHEN TRUE => + I1 : INT; + WHEN FALSE => + I2 : INTEGER; + END CASE; + END RECORD; + FUNCTION F RETURN INT; + FUNCTION F RETURN INTEGER; + + A : DIS(TRUE); + + FUNCTION F RETURN INT IS + BEGIN + GLOBAL := 1; + RETURN 5; + END F; + + FUNCTION F RETURN INTEGER IS + BEGIN + GLOBAL := 2; + RETURN 5; + END F; + + BEGIN + A := (TRUE, OTHERS => F); + + IF GLOBAL /= 1 THEN + FAILED("NON_STATIC OTHERS NOT DECIDED CORRECTLY"); + END IF; + END; + + RESULT; + END C43108A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432001.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,512 ---- + -- C432001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- + -- Check that extension aggregates may be used to specify values + -- for types that are record extensions. Check that the + -- type of the ancestor expression may be any nonlimited type that + -- is a record extension, including private types and private + -- extensions. Check that the type for the aggregate is + -- derived from the type of the ancestor expression. + -- + -- TEST DESCRIPTION: + -- + -- Two progenitor nonlimited record types are declared, one + -- nonprivate and one private. Using these as parent types, + -- all possible combinations of record extensions are declared + -- (Nonprivate record extension of nonprivate type, private + -- extension of nonprivate type, nonprivate record extension of + -- private type, and private extension of private type). Finally, + -- each of these types is extended using nonprivate record + -- extensions. + -- + -- Extension of private types is done in packages other than + -- the ones containing the parent declaration. This is done + -- to eliminate errors with extension of the partial view of + -- a type, which is not an objective of this test. + -- + -- All components of private types and private extensions are given + -- default values. This eliminates the need for separate subprograms + -- whose sole purpose is to place a value into a private record type. + -- + -- Types that have been extended are checked using an object of their + -- parent type as the ancestor expression. For those types that + -- have been extended twice, using only nonprivate record extensions, + -- a check is made using an object of their grandparent type as + -- the ancestor expression. + -- + -- For each type, a subprogram is defined which checks the contents + -- of the parameter, which is a value of the record extension. + -- Components of nonprivate record extensions are checked against + -- passed-in parameters of the component type. Components of private + -- extensions are checked to ensure that they maintain their initial + -- values. + -- + -- To check that the aggregate's type is derived from its ancestor, + -- each Check subprogram in turn calls the Check subprogram for + -- its parent type. Explicit conversion is used to convert the + -- record extension to the parent type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + package C432001_0 is + + type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); + + type N is tagged record + How_Long_Ago : Natural := Report.Ident_Int(1); + Era : Eras := Cenozoic; + end record; + + function Check (Rec : in N; + N : in Natural; + E : in Eras) return Boolean; + + type P is tagged private; + + function Check (Rec : in P) return Boolean; + + private + + type P is tagged record + How_Long_Ago : Natural := Report.Ident_Int(150); + Era : Eras := Mesozoic; + end record; + + end C432001_0; + + package body C432001_0 is + + function Check (Rec : in P) return Boolean is + begin + return Rec.How_Long_Ago = 150 and Rec.Era = Mesozoic; + end Check; + + function Check (Rec : in N; + N : in Natural; + E : in Eras) return Boolean is + begin + return Rec.How_Long_Ago = N and Rec.Era = E; + end Check; + + end C432001_0; + + with C432001_0; + package C432001_1 is + + type Periods is + (Aphebian, Helikian, Hadrynian, + Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, + Triassic, Jurassic, Cretaceous, + Tertiary, Quaternary); + + type N_N is new C432001_0.N with record + Period : Periods := C432001_1.Quaternary; + end record; + + function Check (Rec : in N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in Periods) return Boolean; + + type N_P is new C432001_0.N with private; + + function Check (Rec : in N_P) return Boolean; + + type P_N is new C432001_0.P with record + Period : Periods := C432001_1.Jurassic; + end record; + + function Check (Rec : in P_N; + P : in Periods) return Boolean; + + type P_P is new C432001_0.P with private; + + function Check (Rec : in P_P) return Boolean; + + type P_P_Null is new C432001_0.P with null record; + + private + + type N_P is new C432001_0.N with record + Period : Periods := C432001_1.Quaternary; + end record; + + type P_P is new C432001_0.P with record + Period : Periods := C432001_1.Jurassic; + end record; + + end C432001_1; + + with Report; + package body C432001_1 is + + function Check (Rec : in N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in Periods) return Boolean is + begin + if not C432001_0.Check (C432001_0.N (Rec), N, E) then + Report.Failed ("Conversion to parent type of " & + "nonprivate portion of " & + "nonprivate extension failed"); + end if; + return Rec.Period = P; + end Check; + + + function Check (Rec : in N_P) return Boolean is + begin + if not C432001_0.Check (C432001_0.N (Rec), 1, C432001_0.Cenozoic) then + Report.Failed ("Conversion to parent type of " & + "nonprivate portion of " & + "private extension failed"); + end if; + return Rec.Period = C432001_1.Quaternary; + end Check; + + function Check (Rec : in P_N; + P : in Periods) return Boolean is + begin + if not C432001_0.Check (C432001_0.P (Rec)) then + Report.Failed ("Conversion to parent type of " & + "private portion of " & + "nonprivate extension failed"); + end if; + return Rec.Period = P; + end Check; + + function Check (Rec : in P_P) return Boolean is + begin + if not C432001_0.Check (C432001_0.P (Rec)) then + Report.Failed ("Conversion to parent type of " & + "private portion of " & + "private extension failed"); + end if; + return Rec.Period = C432001_1.Jurassic; + end Check; + + end C432001_1; + + with C432001_0; + with C432001_1; + package C432001_2 is + + -- All types herein are nonprivate extensions, since aggregates + -- cannot be given for private extensions + + type N_N_N is new C432001_1.N_N with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in N_N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in C432001_1.Periods; + B : in Boolean) return Boolean; + + type N_P_N is new C432001_1.N_P with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in N_P_N; + B : Boolean) return Boolean; + + type P_N_N is new C432001_1.P_N with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in P_N_N; + P : in C432001_1.Periods; + B : Boolean) return Boolean; + + type P_P_N is new C432001_1.P_P with record + Sample_On_Loan : Boolean; + end record; + + function Check (Rec : in P_P_N; + B : Boolean) return Boolean; + + end C432001_2; + + with Report; + package body C432001_2 is + + -- direct access to operator + use type C432001_1.Periods; + + + function Check (Rec : in N_N_N; + N : in Natural; + E : in C432001_0.Eras; + P : in C432001_1.Periods; + B : in Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.N_N (Rec), N, E, P) then + Report.Failed ("Conversion to parent " & + "nonprivate type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + + function Check (Rec : in N_P_N; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.N_P (Rec)) then + Report.Failed ("Conversion to parent " & + "private type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + function Check (Rec : in P_N_N; + P : in C432001_1.Periods; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.P_N (Rec), P) then + Report.Failed ("Conversion to parent " & + "nonprivate type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + function Check (Rec : in P_P_N; + B : Boolean) return Boolean is + begin + if not C432001_1.Check (C432001_1.P_P (Rec)) then + Report.Failed ("Conversion to parent " & + "private type extension " & + "failed"); + end if; + return Rec.Sample_On_Loan = B; + end Check; + + end C432001_2; + + + with C432001_0; + with C432001_1; + with C432001_2; + with Report; + procedure C432001 is + + N_Object : C432001_0.N := (How_Long_Ago => Report.Ident_Int(375), + Era => C432001_0.Paleozoic); + + P_Object : C432001_0.P; -- default value is (150, + -- C432001_0.Mesozoic) + + N_N_Object : C432001_1.N_N := + (N_Object with Period => C432001_1.Devonian); + + P_N_Object : C432001_1.P_N := + (P_Object with Period => C432001_1.Jurassic); + + N_P_Object : C432001_1.N_P; -- default is (1, + -- C432001_0.Cenozoic, + -- C432001_1.Quaternary) + + P_P_Object : C432001_1.P_P; -- default is (150, + -- C432001_0.Mesozoic, + -- C432001_1.Jurassic) + + P_P_Null_Ob:C432001_1.P_P_Null := (P_Object with null record); + + N_N_N_Object : C432001_2.N_N_N := + (N_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); + + N_P_N_Object : C432001_2.N_P_N := + (N_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); + + P_N_N_Object : C432001_2.P_N_N := + (P_N_Object with Sample_On_Loan => Report.Ident_Bool(True)); + + P_P_N_Object : C432001_2.P_P_N := + (P_P_Object with Sample_On_Loan => Report.Ident_Bool(False)); + + P_N_Object_2 : C432001_1.P_N := (C432001_0.P(P_N_N_Object) + with C432001_1.Carboniferous); + + N_N_Object_2 : C432001_1.N_N := (C432001_0.N'(42,C432001_0.Precambrian) + with C432001_1.Carboniferous); + + begin + + Report.Test ("C432001", "Extension aggregates"); + + -- check ultimate ancestor types + + if not C432001_0.Check (N_Object, + 375, + C432001_0.Paleozoic) then + Report.Failed ("Object of " & + "nonprivate type " & + "failed content check"); + end if; + + if not C432001_0.Check (P_Object) then + Report.Failed ("Object of " & + "private type " & + "failed content check"); + end if; + + -- check direct type extensions + + if not C432001_1.Check (N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate type " & + "failed content check"); + end if; + + if not C432001_1.Check (N_P_Object) then + Report.Failed ("Object of " & + "private extension of nonprivate type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_N_Object, + C432001_1.Jurassic) then + Report.Failed ("Object of " & + "nonprivate extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_P_Object) then + Report.Failed ("Object of " & + "private extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (P_P_Null_Ob) then + Report.Failed ("Object of " & + "private type " & + "failed content check"); + end if; + + + -- check direct extensions of extensions + + if not C432001_2.Check (N_N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian, + True) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate extension " & + "(of nonprivate parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (N_P_N_Object, False) then + Report.Failed ("Object of " & + "nonprivate extension of private extension " & + "(of nonprivate parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (P_N_N_Object, + C432001_1.Jurassic, + True) then + Report.Failed ("Object of " & + "nonprivate extension of nonprivate extension " & + "(of private parent) " & + "failed content check"); + end if; + + if not C432001_2.Check (P_P_N_Object, False) then + Report.Failed ("Object of " & + "nonprivate extension of private extension " & + "(of private parent) " & + "failed content check"); + end if; + + -- check that the extension aggregate may specify an expression of + -- a "grandparent" ancestor type + + -- types tested are derived through nonprivate extensions only + -- (extension aggregates are not allowed if the path from the + -- ancestor type wanders through a private extension) + + N_N_N_Object := + (N_Object with Period => C432001_1.Devonian, + Sample_On_Loan => Report.Ident_Bool(True)); + + if not C432001_2.Check (N_N_N_Object, + 375, + C432001_0.Paleozoic, + C432001_1.Devonian, + True) then + Report.Failed ("Object of " & + "nonprivate extension " & + "of nonprivate ancestor " & + "failed content check"); + end if; + + P_N_N_Object := + (P_Object with Period => C432001_1.Jurassic, + Sample_On_Loan => Report.Ident_Bool(True)); + + if not C432001_2.Check (P_N_N_Object, + C432001_1.Jurassic, + True) then + Report.Failed ("Object of " & + "nonprivate extension " & + "of private ancestor " & + "failed content check"); + end if; + + -- Check additional cases + if not C432001_1.Check (P_N_Object_2, + C432001_1.Carboniferous) then + Report.Failed ("Additional Object of " & + "nonprivate extension of private type " & + "failed content check"); + end if; + + if not C432001_1.Check (N_N_Object_2, + 42, + C432001_0.Precambrian, + C432001_1.Carboniferous) then + Report.Failed ("Additional Object of " & + "nonprivate extension of nonprivate type " & + "failed content check"); + end if; + + Report.Result; + + end C432001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432002.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,764 ---- + -- C432002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if an extension aggregate specifies a value for a record + -- extension and the ancestor expression has discriminants that are + -- inherited by the record extension, then a check is made that each + -- discriminant has the value specified. + -- + -- Check that if an extension aggregate specifies a value for a record + -- extension and the ancestor expression has discriminants that are not + -- inherited by the record extension, then a check is made that each + -- such discriminant has the value specified for the corresponding + -- discriminant. + -- + -- Check that the corresponding discriminant value may be specified + -- in the record component association list or in the derived type + -- definition for an ancestor. + -- + -- Check the case of ancestors that are several generations removed. + -- Check the case where the value of the discriminant(s) in question + -- is supplied several generations removed. + -- + -- Check the case of multiple discriminants. + -- + -- Check that Constraint_Error is raised if the check fails. + -- + -- TEST DESCRIPTION: + -- A hierarchy of tagged types is declared from a discriminated + -- root type. Each level declares two kinds of types: (1) a type + -- extension which constrains the discriminant of its parent to + -- the value of an expression and (2) a type extension that + -- constrains the discriminant of its parent to equal a new discriminant + -- of the type extension (These are the two categories of noninherited + -- discriminants). + -- + -- Values for each type are declared within nested blocks. This is + -- done so that the instances that produce Constraint_Error may + -- be dealt with cleanly without forcing the program to exit. + -- + -- Success and failure cases (which should raise Constraint_Error) + -- are set up for each kind of type. Additionally, for the first + -- level of the hierarchy, separate tests are done for ancestor + -- expressions specified by aggregates and those specified by + -- variables. Later tests are performed using variables only. + -- + -- Additionally, the cases tested consist of the following kinds of + -- types: + -- + -- Extensions of extensions, using both the parent and grandparent + -- types for the ancestor expression, + -- + -- Ancestor expressions which are several generations removed + -- from the type of the aggregate, + -- + -- Extensions of types with multiple discriminants, where the + -- extension declares a new discriminant which corresponds to + -- more than one discriminant of the ancestor types. + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 20 Dec 94 SAIC Repair confusion WRT overridden discriminants + -- + --! + + package C432002_0 is + + subtype Length is Natural range 0..256; + type Discriminant (L : Length) is tagged + record + S1 : String (1..L); + end record; + + procedure Do_Something (Rec : in out Discriminant); + -- inherited by all type extensions + + -- Aggregates of Discriminant are of the form + -- (L, S1) where L= S1'Length + + -- Discriminant of parent constrained to value of an expression + type Constrained_Discriminant_Extension is + new Discriminant (L => 10) + with record + S2 : String (1..20); + end record; + + -- Aggregates of Constrained_Discriminant_Extension are of the form + -- (L, S1, S2), where L = S1'Length = 10, S2'Length = 20 + + type Once_Removed is new Constrained_Discriminant_Extension + with record + S3 : String (1..3); + end record; + + type Twice_Removed is new Once_Removed + with record + S4 : String (1..8); + end record; + + -- Aggregates of Twice_Removed are of the form + -- (L, S1, S2, S3, S4), where L = S1'Length = 10, + -- S2'Length = 20, + -- S3'Length = 3, + -- S4'Length = 8 + + -- Discriminant of parent constrained to equal new discriminant + type New_Discriminant_Extension (N : Length) is + new Discriminant (L => N) with + record + S2 : String (1..N); + end record; + + -- Aggregates of New_Discriminant_Extension are of the form + -- (N, S1, S2), where N = S1'Length = S2'Length + + -- Discriminant of parent extension constrained to the value of + -- an expression + type Constrained_Extension_Extension is + new New_Discriminant_Extension (N => 20) + with record + S3 : String (1..5); + end record; + + -- Aggregates of Constrained_Extension_Extension are of the form + -- (N, S1, S2, S3), where N = S1'Length = S2'Length = 20, + -- S3'Length = 5 + + -- Discriminant of parent extension constrained to equal a new + -- discriminant + type New_Extension_Extension (I : Length) is + new New_Discriminant_Extension (N => I) + with record + S3 : String (1..I); + end record; + + -- Aggregates of New_Extension_Extension are of the form + -- (I, S1, 2, S3), where + -- I = S1'Length = S2'Length = S3'Length + + type Multiple_Discriminants (A, B : Length) is tagged + record + S1 : String (1..A); + S2 : String (1..B); + end record; + + procedure Do_Something (Rec : in out Multiple_Discriminants); + -- inherited by type extension + + -- Aggregates of Multiple_Discriminants are of the form + -- (A, B, S1, S2), where A = S1'Length, B = S2'Length + + type Multiple_Discriminant_Extension (C : Length) is + new Multiple_Discriminants (A => C, B => C) + with record + S3 : String (1..C); + end record; + + -- Aggregates of Multiple_Discriminant_Extension are of the form + -- (A, B, S1, S2, C, S3), where + -- A = B = C = S1'Length = S2'Length = S3'Length + + end C432002_0; + + with Report; + package body C432002_0 is + + S : String (1..20) := "12345678901234567890"; + + procedure Do_Something (Rec : in out Discriminant) is + begin + Rec.S1 := Report.Ident_Str (S (1..Rec.L)); + end Do_Something; + + procedure Do_Something (Rec : in out Multiple_Discriminants) is + begin + Rec.S1 := Report.Ident_Str (S (1..Rec.A)); + end Do_Something; + + end C432002_0; + + + with C432002_0; + with Report; + procedure C432002 is + + -- Various different-sized strings for variety + String_3 : String (1..3) := Report.Ident_Str("123"); + String_5 : String (1..5) := Report.Ident_Str("12345"); + String_8 : String (1..8) := Report.Ident_Str("12345678"); + String_10 : String (1..10) := Report.Ident_Str("1234567890"); + String_11 : String (1..11) := Report.Ident_Str("12345678901"); + String_20 : String (1..20) := Report.Ident_Str("12345678901234567890"); + + begin + + Report.Test ("C432002", + "Extension aggregates for discriminated types"); + + -------------------------------------------------------------------- + -- Extension constrains parent's discriminant to value of expression + -------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + CD_Matched_Aggregate: + begin + declare + CD : C432002_0.Constrained_Discriminant_Extension := + (C432002_0.Discriminant'(L => 10, + S1 => String_10) + with S2 => String_20); + begin + C432002_0.Do_Something(CD); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CD_Matched_Aggregate; + + CD_Matched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 10) := + C432002_0.Discriminant'(L => 10, + S1 => String_10); + + CD : C432002_0.Constrained_Discriminant_Extension := + (D with S2 => String_20); + begin + C432002_0.Do_Something(CD); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CD_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + CD_Unmatched_Aggregate: + begin + declare + CD : C432002_0.Constrained_Discriminant_Extension := + (C432002_0.Discriminant'(L => 5, + S1 => String_5) + with S2 => String_20); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CD); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CD_Unmatched_Aggregate; + + CD_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + CD : C432002_0.Constrained_Discriminant_Extension := + (D with S2 => String_20); + begin + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CD); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CD_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Extension constrains parent's discriminant to equal new discriminant + ----------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + ND_Matched_Aggregate: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 8) := + (C432002_0.Discriminant'(L => 8, + S1 => String_8) + with N => 8, + S2 => String_8); + begin + C432002_0.Do_Something(ND); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end ND_Matched_Aggregate; + + ND_Matched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 3) := + C432002_0.Discriminant'(L => 3, + S1 => String_3); + + ND : C432002_0.New_Discriminant_Extension (N => 3) := + (D with N => 3, + S2 => String_3); + begin + C432002_0.Do_Something(ND); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end ND_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + ND_Unmatched_Aggregate: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 20) := + (C432002_0.Discriminant'(L => 11, + S1 => String_11) + with N => 20, + S2 => String_20); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(ND); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end ND_Unmatched_Aggregate; + + ND_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + ND : C432002_0.New_Discriminant_Extension (N => 20) := + (D with N => 20, + S2 => String_20); + begin + Report.Comment ("Ancestor expression is an variable"); + Report.Failed ("Aggregate of extension " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(ND); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end ND_Unmatched_Variable; + + -------------------------------------------------------------------- + -- Extension constrains parent's discriminant to value of expression + -- Parent is a discriminant extension + -------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + CE_Matched_Aggregate: + begin + declare + CE : C432002_0.Constrained_Extension_Extension := + (C432002_0.Discriminant'(L => 20, + S1 => String_20) + with N => 20, + S2 => String_20, + S3 => String_5); + begin + C432002_0.Do_Something(CE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CE_Matched_Aggregate; + + CE_Matched_Variable: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 20) := + C432002_0.New_Discriminant_Extension' + (N => 20, + S1 => String_20, + S2 => String_20); + + CE : C432002_0.Constrained_Extension_Extension := + (ND with S3 => String_5); + begin + C432002_0.Do_Something(CE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end CE_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + CE_Unmatched_Aggregate: + begin + declare + CE : C432002_0.Constrained_Extension_Extension := + (C432002_0.New_Discriminant_Extension' + (N => 11, + S1 => String_11, + S2 => String_11) + with S3 => String_5); + begin + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "Constraint_Error was not raised " & + "with discriminant constrained: " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CE_Unmatched_Aggregate; + + CE_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 8) := + C432002_0.Discriminant'(L => 8, + S1 => String_8); + + CE : C432002_0.Constrained_Extension_Extension := + (D with N => 8, + S2 => String_8, + S3 => String_5); + begin + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(CE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise of Constraint_Error is expected + end CE_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Extension constrains parent's discriminant to equal new discriminant + -- Parent is a discriminant extension + ----------------------------------------------------------------------- + + -- Successful cases - value matches corresponding discriminant value + + NE_Matched_Aggregate: + begin + declare + NE : C432002_0.New_Extension_Extension (I => 8) := + (C432002_0.Discriminant'(L => 8, + S1 => String_8) + with I => 8, + S2 => String_8, + S3 => String_8); + begin + C432002_0.Do_Something(NE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is an aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end NE_Matched_Aggregate; + + NE_Matched_Variable: + begin + declare + ND : C432002_0.New_Discriminant_Extension (N => 3) := + C432002_0.New_Discriminant_Extension' + (N => 3, + S1 => String_3, + S2 => String_3); + + NE : C432002_0.New_Extension_Extension (I => 3) := + (ND with I => 3, + S3 => String_3); + begin + C432002_0.Do_Something(NE); -- success + end; + exception + when Constraint_Error => + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end NE_Matched_Variable; + + + -- Unsuccessful cases - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + NE_Unmatched_Aggregate: + begin + declare + NE : C432002_0.New_Extension_Extension (I => 8) := + (C432002_0.New_Discriminant_Extension' + (C432002_0.Discriminant'(L => 11, + S1 => String_11) + with N => 11, + S2 => String_11) + with I => 8, + S3 => String_8); + begin + Report.Comment ("Ancestor expression is an extension aggregate"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(NE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end NE_Unmatched_Aggregate; + + NE_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant(L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + NE : C432002_0.New_Extension_Extension (I => 20) := + (D with I => 5, + S2 => String_5, + S3 => String_20); + begin + Report.Comment ("Ancestor expression is a variable"); + Report.Failed ("Aggregate of extension (of extension) " & + "with new discriminant: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(NE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end NE_Unmatched_Variable; + + ----------------------------------------------------------------------- + -- Corresponding discriminant is two levels deeper than aggregate + ----------------------------------------------------------------------- + + -- Successful case - value matches corresponding discriminant value + + TR_Matched_Variable: + begin + declare + D : C432002_0.Discriminant (L => 10) := + C432002_0.Discriminant'(L => 10, + S1 => String_10); + + TR : C432002_0.Twice_Removed := + C432002_0.Twice_Removed'(D with S2 => String_20, + S3 => String_3, + S4 => String_8); + -- N is constrained to a value in the derived_type_definition + -- of Constrained_Discriminant_Extension. Its omission from + -- the above record_component_association_list is allowed by + -- 4.3.2(6). + + begin + C432002_0.Do_Something(TR); -- success + end; + exception + when Constraint_Error => + Report.Failed ("Aggregate of far-removed extension " & + "with discriminant constrained: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end TR_Matched_Variable; + + + -- Unsuccessful case - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + TR_Unmatched_Variable: + begin + declare + D : C432002_0.Discriminant (L => 5) := + C432002_0.Discriminant'(L => 5, + S1 => String_5); + + TR : C432002_0.Twice_Removed := + C432002_0.Twice_Removed'(D with S2 => String_20, + S3 => String_3, + S4 => String_8); + + begin + Report.Failed ("Aggregate of far-removed extension " & + "with discriminant constrained: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(TR); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end TR_Unmatched_Variable; + + ------------------------------------------------------------------------ + -- Parent has multiple discriminants. + -- Discriminant in extension corresponds to both parental discriminants. + ------------------------------------------------------------------------ + + -- Successful case - value matches corresponding discriminant value + + MD_Matched_Variable: + begin + declare + MD : C432002_0.Multiple_Discriminants (A => 10, B => 10) := + C432002_0.Multiple_Discriminants'(A => 10, + B => 10, + S1 => String_10, + S2 => String_10); + MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := + (MD with C => 10, + S3 => String_10); + + begin + C432002_0.Do_Something(MDE); -- success + end; + exception + when Constraint_Error => + Report.Failed ("Aggregate of extension " & + "of multiply-discriminated parent: " & + "Constraint_Error was incorrectly raised " & + "for value that matches corresponding " & + "discriminant"); + end MD_Matched_Variable; + + + -- Unsuccessful case - value does not match value of corresponding + -- discriminant. Constraint_Error should be + -- raised. + + MD_Unmatched_Variable: + begin + declare + MD : C432002_0.Multiple_Discriminants (A => 10, B => 8) := + C432002_0.Multiple_Discriminants'(A => 10, + B => 8, + S1 => String_10, + S2 => String_8); + MDE : C432002_0.Multiple_Discriminant_Extension (C => 10) := + (MD with C => 10, + S3 => String_10); + + begin + Report.Failed ("Aggregate of extension " & + "of multiply-discriminated parent: " & + "Constraint_Error was not raised " & + "for discriminant value that does not match " & + "corresponding discriminant"); + C432002_0.Do_Something(MDE); -- disallow unused var optimization + end; + exception + when Constraint_Error => + null; -- raise is expected + end MD_Unmatched_Variable; + + Report.Result; + + end C432002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432003.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,594 ---- + -- C432003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the type of the ancestor part of an extension aggregate + -- has discriminants that are not inherited by the type of the aggregate, + -- and the ancestor part is a subtype mark that denotes a constrained + -- subtype, Constraint_Error is raised if: 1) any discriminant of the + -- ancestor has a different value than that specified for a corresponding + -- discriminant in the derived type definition for some ancestor of the + -- type of the aggregate, or 2) the value for the discriminant in the + -- record association list is not the value of the corresponding + -- discriminant. Check that the components of the value of the + -- aggregate not given by the record component association list are + -- initialized by default as for an object of the ancestor type. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- type T (D1: ...) is tagged ... + -- + -- type DT is new T with ... + -- subtype ST is DT (D1 => 3); -- Constrained subtype. + -- + -- type NT1 (D2: ...) is new DT (D1 => D2) with null record; + -- type NT2 (D2: ...) is new DT (D1 => 6) with null record; + -- type NT3 is new DT (D1 => 6) with null record; + -- + -- A: NT1 := (T with D2 => 6); -- OK: T is unconstrained. + -- B: NT1 := (DT with D2 => 6); -- OK: DT is unconstrained. + -- C: NT1 := (ST with D2 => 6); -- NO: ST.D1 /= D2. + -- + -- D: NT2 := (T with D2 => 4); -- OK: T is unconstrained. + -- E: NT2 := (DT with D2 => 4); -- OK: DT is unconstrained. + -- F: NT2 := (ST with . . . ); -- NO: ST.D1 /= DT.D1 as specified in NT2. + -- + -- G: NT3 := (T with D1 => 6); -- OK: T is unconstrained. + -- H: NT3 := (DT with D1 => 6); -- OK: DT is unconstrained. + -- I: NT3 := (ST with D1 => 6); -- NO: ST.D1 /= DT.D1 as specified in NT3. + -- + -- In A, B, D, E, G, and H the ancestor part is the name of an + -- unconstrained subtype, so this rule does not apply. In C, F, and I + -- the ancestor part (ST) is the name of a constrained subtype of DT, + -- which is itself a derived type of a discriminated tagged type T. ST + -- constrains the discriminant of DT (D1) to the value 3; thus, the + -- type of any extension aggregate for which ST is the ancestor part + -- must have an ancestor which also constrained D1 to 3. F and I raise + -- Constraint_Error because NT2 and NT3, respectively, constrain D1 to + -- 6. C raises Constraint_Error because NT1 constrains D1 to the value + -- of D2, which is set to 6 in the record component association list of + -- the aggregate. + -- + -- This test verifies each of the three scenarios above: + -- + -- (1) Ancestor of type of aggregate constrains discriminant with + -- new discriminant. + -- (2) Ancestor of type of aggregate constrains discriminant with + -- value, and has a new discriminant part. + -- (3) Ancestor of type of aggregate constrains discriminant with + -- value, and has no discriminant part. + -- + -- Verification is made for cases where the type of the aggregate is + -- once- and twice-removed from the type of the ancestor part. + -- + -- Additionally, a case is included where a new discriminant corresponds + -- to multiple discriminants of the type of the ancestor part. + -- + -- To test the portion of the objective concerning "initialization by + -- default," the test verifies that, after a successful aggregate + -- assignment, components not assigned an explicit value by the aggregate + -- contain the default values for the corresponding components of the + -- ancestor type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Dec 94 SAIC Removed discriminant defaults from tagged types. + -- 17 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected subtype constraint + -- for component NT_C3.Str2. Added missing component + -- checks. Removed record component update from + -- Avoid_Optimization. Fixed incorrect component + -- checks. + -- 02 Dec 95 SAIC ACVC 2.0.1 fixes: Corrected Failed comment for + -- Q case. + -- + --! + + package C432003_0 is + + Default_String : constant String := "This is a default string"; -- len = 24 + Another_String : constant String := "Another default string"; -- len = 22 + + subtype Length is Natural range 0..255; + + type ROOT (D1 : Length) is tagged + record + S1 : String (1..D1) := Default_String(1..D1); + Acc : Natural := 356; + end record; + + procedure Avoid_Optimization (Rec : in out ROOT); -- Inherited by all type + -- extensions. + + type Unconstrained_Der is new ROOT with + record + Str1 : String(1..5) := "abcde"; + end record; + + subtype Constrained_Subtype is Unconstrained_Der (D1 => 10); + + type NT_A1 (D2 : Length) is new Unconstrained_Der (D1 => D2) with + record + S2 : String(1..D2); -- Inherited discrim. constrained by + end record; -- new discriminant. + + type NT_A2 (D3 : Length) is new NT_A1 (D2 => D3) with + record + S3 : String(1..D3); -- Inherited discrim. constrained by + end record; -- new discriminant. + + + type NT_B1 (D2 : Length) is new Unconstrained_Der (D1 => 5) with + record + S2 : String(1..D2); -- Inherited discrim. constrained by + end record; -- explicit value. + + type NT_B2 (D3 : Length) is new NT_B1 (D2 => 10) with + record + S3 : String(1..D3); -- Inherited discrim. constrained by + end record; -- explicit value. + + type NT_B3 (D2 : Length) is new Unconstrained_Der (D1 => 10) with + record + S2 : String(1..D2); + end record; + + + type NT_C1 is new Unconstrained_Der (D1 => 5) with + record + Str2 : String(1..5); -- Inherited discrim. constrained + end record; -- No new value. + + type NT_C2 (D2 : Length) is new NT_C1 with + record + S2 : String(1..D2); -- Inherited discrim. not further + end record; -- constrained, new discriminant. + + type NT_C3 is new Unconstrained_Der(D1 => 10) with + record + Str2 : String(1..5); + end record; + + + type MULTI_ROOT (D1 : Length; D2 : Length) is tagged + record + S1 : String (1..D1) := Default_String(1..D1); + S2 : String (1..D2) := Another_String(1..D2); + end record; + + procedure Avoid_Optimization (Rec : in out MULTI_ROOT); -- Inherited by all + -- type extensions. + + type Mult_Unconstr_Der is new MULTI_ROOT with + record + Str1 : String(1..8) := "AbCdEfGh"; -- Derived, no constraints. + end record; + + -- Subtypes with constrained discriminants. + subtype Mult_Constr_Sub1 is Mult_Unconstr_Der(D1 => 15, -- Disc. have + D2 => 20); -- diff values + + subtype Mult_Constr_Sub2 is Mult_Unconstr_Der(D1 => 15, -- Disc. have + D2 => 15); -- same value + + type Mult_NT_A1 (D3 : Length) is + new Mult_Unconstr_Der (D1 => D3, D2 => D3) with + record + S3 : String(1..D3); -- Both inherited discriminants constrained + end record; -- by new discriminant. + + end C432003_0; + + + --=====================================================================-- + + + with Report; + package body C432003_0 is + + procedure Avoid_Optimization (Rec : in out ROOT) is + begin + Rec.S1 := Report.Ident_Str(Rec.S1); + end Avoid_Optimization; + + procedure Avoid_Optimization (Rec : in out MULTI_ROOT) is + begin + Rec.S1 := Report.Ident_Str(Rec.S1); + end Avoid_Optimization; + + end C432003_0; + + + --=====================================================================-- + + + with C432003_0; + with Report; + procedure C432003 is + begin + + Report.Test("C432003", "Extension aggregates where ancestor part " & + "is a subtype mark that denotes a constrained " & + "subtype causing Constraint_Error if any " & + "discriminant of the ancestor has a different " & + "value than that specified for a corresponding " & + "discriminant in the derived type definition " & + "for some ancestor of the type of the aggregate"); + + Test_Block: + declare + + -- Variety of string object declarations. + String2 : String(1..2) := Report.Ident_Str("12"); + String5 : String(1..5) := Report.Ident_Str("12345"); + String8 : String(1..8) := Report.Ident_Str("AbCdEfGh"); + String10 : String(1..10) := Report.Ident_Str("1234567890"); + String15 : String(1..15) := Report.Ident_Str("123456789012345"); + String20 : String(1..20) := Report.Ident_Str("12345678901234567890"); + + begin + + + begin + declare + A : C432003_0.NT_A1 := -- OK + (C432003_0.ROOT with D2 => 5, + Str1 => "cdefg", + S2 => String5); + begin + C432003_0.Avoid_Optimization(A); + if A.Acc /= 356 or + A.Str1 /= "cdefg" or + A.S2 /= String5 or + A.D2 /= 5 or + A.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object A"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object A"); + end; + + + begin + declare + C: C432003_0.NT_A1 := -- OK + (C432003_0.Constrained_Subtype with D2 => 10, + S2 => String10); + begin + C432003_0.Avoid_Optimization(C); + if C.D2 /= 10 or C.Acc /= 356 or + C.Str1 /= "abcde" or C.S2 /= String10 or + C.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object C"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object C"); + end; + + + begin + declare + D: C432003_0.NT_A1 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(5), + S2 => String5); + begin + C432003_0.Avoid_Optimization(D); + Report.Failed("Constraint_Error not raised for Object D"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + E: C432003_0.NT_A2 := -- OK + (C432003_0.Constrained_Subtype with D3 => 10, + S2 => String10, + S3 => String10); + begin + C432003_0.Avoid_Optimization(E); + if E.D3 /= 10 or E.Acc /= 356 or + E.Str1 /= "abcde" or E.S2 /= String10 or + E.S3 /= String10 or + E.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object E"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object E"); + end; + + + begin + declare + F: C432003_0.NT_A2 := -- C_E + (C432003_0.Constrained_Subtype with + D3 => Report.Ident_Int(5), + S2 => String5, + S3 => String5); + begin + C432003_0.Avoid_Optimization(F); + Report.Failed("Constraint_Error not raised for Object F"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + G: C432003_0.NT_B2 := -- OK + (C432003_0.ROOT with D3 => 5, + Str1 => "cdefg", + S2 => String10, + S3 => String5); + begin + C432003_0.Avoid_Optimization(G); + if G.D3 /= 5 or G.Acc /= 356 or + G.Str1 /= "cdefg" or G.S2 /= String10 or + G.S3 /= String5 or + G.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object G"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object G"); + end; + + + begin + declare + H: C432003_0.NT_B3 := -- OK + (C432003_0.Unconstrained_Der with D2 => 5, + S2 => String5); + begin + C432003_0.Avoid_Optimization(H); + if H.D2 /= 5 or H.Acc /= 356 or + H.Str1 /= "abcde" or H.S2 /= String5 or + H.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object H"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object H"); + end; + + + begin + declare + I: C432003_0.NT_B1 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(10), + S2 => String10); + begin + C432003_0.Avoid_Optimization(I); + Report.Failed("Constraint_Error not raised for Object I"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + J: C432003_0.NT_B2 := -- C_E + (C432003_0.Constrained_Subtype with + D3 => Report.Ident_Int(10), + S2 => String10, + S3 => String10); + begin + C432003_0.Avoid_Optimization(J); + Report.Failed("Constraint_Error not raised by Object J"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + K: C432003_0.NT_B3 := -- OK + (C432003_0.Constrained_Subtype with D2 => 5, + S2 => String5); + begin + C432003_0.Avoid_Optimization(K); + if K.D2 /= 5 or K.Acc /= 356 or + K.Str1 /= "abcde" or K.S2 /= String5 or + K.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object K"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object K"); + end; + + + begin + declare + M: C432003_0.NT_C2 := -- OK + (C432003_0.ROOT with D2 => 10, + Str1 => "cdefg", + Str2 => String5, + S2 => String10); + begin + C432003_0.Avoid_Optimization(M); + if M.D2 /= 10 or M.Acc /= 356 or + M.Str1 /= "cdefg" or M.S2 /= String10 or + M.Str2 /= String5 or + M.S1 /= C432003_0.Default_String(1..5) + then + Report.Failed("Incorrect object values for Object M"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object M"); + end; + + + begin + declare + O: C432003_0.NT_C1 := -- C_E + (C432003_0.Constrained_Subtype with + Str2 => Report.Ident_Str(String5)); + begin + C432003_0.Avoid_Optimization(O); + Report.Failed("Constraint_Error not raised for Object O"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + P: C432003_0.NT_C2 := -- C_E + (C432003_0.Constrained_Subtype with + D2 => Report.Ident_Int(10), + Str2 => String5, + S2 => String10); + begin + C432003_0.Avoid_Optimization(P); + Report.Failed("Constraint_Error not raised by Object P"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + Q: C432003_0.NT_C3 := + (C432003_0.Constrained_Subtype with Str2 => String5); -- OK + begin + C432003_0.Avoid_Optimization(Q); + if Q.Str2 /= String5 or + Q.Acc /= 356 or + Q.Str1 /= "abcde" or + Q.D1 /= 10 or + Q.S1 /= C432003_0.Default_String(1..10) + then + Report.Failed("Incorrect object values for Object Q"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object Q"); + end; + + + -- The following cases test where a new discriminant corresponds + -- to multiple discriminants of the type of the ancestor part. + + begin + declare + S: C432003_0.Mult_NT_A1 := -- OK + (C432003_0.Mult_Unconstr_Der with D3 => 15, + S3 => String15); + begin + C432003_0.Avoid_Optimization(S); + if S.S1 /= C432003_0.Default_String(1..15) or + S.Str1 /= String8 or + S.S2 /= C432003_0.Another_String(1..15) or + S.S3 /= String15 or + S.D3 /= 15 + then + Report.Failed("Incorrect object values for Object S"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object S"); + end; + + + begin + declare + U: C432003_0.Mult_NT_A1 := -- C_E + (C432003_0.Mult_Constr_Sub1 with + D3 => Report.Ident_Int(15), + S3 => String15); + begin + C432003_0.Avoid_Optimization(U); + Report.Failed("Constraint_Error not raised for Object U"); + end; + exception + when Constraint_Error => + null; -- Raise of Constraint_Error is expected. + end; + + + begin + declare + V: C432003_0.Mult_NT_A1 := -- OK + (C432003_0.Mult_Constr_Sub2 with D3 => 15, + S3 => String15); + begin + C432003_0.Avoid_Optimization(V); + if V.D3 /= 15 or + V.Str1 /= String8 or + V.S3 /= String15 or + V.S1 /= C432003_0.Default_String(1..15) or + V.S2 /= C432003_0.Another_String(1..15) + then + Report.Failed("Incorrect object values for Object V"); + end if; + end; + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised for Object V"); + end; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end C432003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c432004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c432004.a 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,319 ---- + -- C432004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the type of an extension aggregate may be derived from the + -- type of the ancestor part through multiple record extensions. Check + -- for ancestor parts that are subtype marks. Check that the type of the + -- ancestor part may be abstract. + -- + -- TEST DESCRIPTION: + -- This test defines the following type hierarchies: + -- + -- (A) (F) + -- Abstract Abstract + -- Tagged record Tagged private + -- / \ / \ + -- / (C) (G) \ + -- (B) Abstract Abstract (H) + -- Record private record Private + -- extension extension extension extension + -- | | | | + -- (D) (E) (I) (J) + -- Record Record Record Record + -- extension extension extension extension + -- + -- Extension aggregates for B, D, E, I, and J are constructed using each + -- of its ancestor types as the ancestor part (except for E and J, for + -- which only the immediate ancestor is used, since using A and F, + -- respectively, as the ancestor part would be illegal). + -- + -- X1 : B := (A with ...); + -- X2 : D := (A with ...); X5 : I := (F with ...); + -- X3 : D := (B with ...); X6 : I := (G with ...); + -- X4 : E := (C with ...); X7 : J := (H with ...); + -- + -- For each assignment of an aggregate, the value of the target object is + -- checked to ensure that the proper values for each component were + -- assigned. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C432004_0 is + + type Drawers is record + Building : natural; + end record; + + type Location is access Drawers; + + type Eras is (Precambrian, Paleozoic, Mesozoic, Cenozoic); + + type SampleType_A is abstract tagged record + Era : Eras := Cenozoic; + Loc : Location; + end record; + + type SampleType_F is abstract tagged private; + + -- The following function is needed to verify the values of the + -- private components. + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean; + + private + type SampleType_F is abstract tagged record + Era : Eras := Mesozoic; + end record; + + end C432004_0; + + --==================================================================-- + + package body C432004_0 is + + function TC_Correct_Result (Rec : SampleType_F'Class; + E : Eras) return Boolean is + begin + return (Rec.Era = E); + end TC_Correct_Result; + + end C432004_0; + + --==================================================================-- + + with C432004_0; + package C432004_1 is + + type Periods is + (Aphebian, Helikian, Hadrynian, + Cambrian, Ordovician, Silurian, Devonian, Carboniferous, Permian, + Triassic, Jurassic, Cretaceous, + Tertiary, Quaternary); + + type SampleType_B is new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_C is abstract new C432004_0.SampleType_A with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean; + + type SampleType_G is abstract new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + Loc : C432004_0.Location; + end record; + + type SampleType_H is new C432004_0.SampleType_F with private; + + -- The following function is needed to verify the values of the + -- extension's private components. + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean; + + private + type SampleType_C is abstract new C432004_0.SampleType_A with record + Period : Periods := Quaternary; + end record; + + type SampleType_H is new C432004_0.SampleType_F with record + Period : Periods := Jurassic; + end record; + + end C432004_1; + + --==================================================================-- + + package body C432004_1 is + + function TC_Correct_Result (Rec : SampleType_C'Class; + P : Periods) return Boolean is + begin + return (Rec.Period = P); + end TC_Correct_Result; + + ------------------------------------------------------------- + function TC_Correct_Result (Rec : SampleType_H'Class; + P : Periods; + E : C432004_0.Eras) return Boolean is + begin + return (Rec.Period = P) and C432004_0.TC_Correct_Result (Rec, E); + end TC_Correct_Result; + + end C432004_1; + + --==================================================================-- + + with C432004_0; + with C432004_1; + package C432004_2 is + + -- All types herein are record extensions, since aggregates + -- cannot be given for private extensions + + type SampleType_D is new C432004_1.SampleType_B with record + Sample_On_Loan : Boolean := False; + end record; + + type SampleType_E is new C432004_1.SampleType_C + with null record; + + type SampleType_I is new C432004_1.SampleType_G with record + Sample_On_Loan : Boolean := True; + end record; + + type SampleType_J is new C432004_1.SampleType_H with record + Sample_On_Loan : Boolean := True; + end record; + + end C432004_2; + + + --==================================================================-- + + with Report; + with C432004_0; + with C432004_1; + with C432004_2; + use C432004_1; + use C432004_2; + + procedure C432004 is + + -- Variety of extension aggregates. + + -- Default values for the components of SampleType_A + -- (Era => Cenozoic, Loc => null). + Sample_B : SampleType_B + := (C432004_0.SampleType_A with Period => Devonian); + + -- Default values from SampleType_A (Era => Cenozoic, Loc => null). + Sample_D1 : SampleType_D + := (C432004_0.SampleType_A with Period => Cambrian, + Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_B + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_D2 : SampleType_D + := (SampleType_B with Sample_On_Loan => True); + + -- Default values from SampleType_A and SampleType_C + -- (Era => Cenozoic, Loc => null, Period => Quaternary). + Sample_E : SampleType_E + := (SampleType_C with null record); + + -- Default value from SampleType_F (Era => Mesozoic). + Sample_I1 : SampleType_I + := (C432004_0.SampleType_F with Period => Tertiary, + Loc => new C432004_0.Drawers'(Building => 9), + Sample_On_Loan => False); + + -- Default values from SampleType_F and SampleType_G + -- (Era => Mesozoic, Period => Jurassic, Loc => null). + Sample_I2 : SampleType_I + := (SampleType_G with Sample_On_Loan => False); + + -- Default values from SampleType_H (Era => Mesozoic, Period => Jurassic). + Sample_J : SampleType_J + := (SampleType_H with Sample_On_Loan => False); + + use type C432004_0.Eras; + use type C432004_0.Location; + + begin + + Report.Test ("C432004", "Check that the type of an extension aggregate " & + "may be derived from the type of the ancestor part through " & + "multiple record extensions"); + + if Sample_B /= (C432004_0.Cenozoic, null, Devonian) then + Report.Failed ("Object of record extension of abstract ancestor, " & + "SampleType_B, failed content check"); + end if; + + ------------------- + if Sample_D1 /= (Era => C432004_0.Cenozoic, Loc => null, + Period => Cambrian, Sample_On_Loan => True) then + Report.Failed ("Object 1 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + + ------------------- + if Sample_D2 /= (C432004_0.Cenozoic, null, Quaternary, True) then + Report.Failed ("Object 2 of record extension of record extension, " & + "of abstract ancestor, SampleType_D, failed content " & + "check"); + end if; + ------------------- + if Sample_E.Era /= C432004_0.Cenozoic or + Sample_E.Loc /= null or + not TC_Correct_Result (Sample_E, Quaternary) then + Report.Failed ("Object of record extension of abstract private " & + "extension of abstract ancestor, SampleType_E, " & + "failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I1, C432004_0.Mesozoic) or + Sample_I1.Period /= Tertiary or + Sample_I1.Loc.Building /= 9 or + Sample_I1.Sample_On_Loan /= False then + Report.Failed ("Object 1 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not C432004_0.TC_Correct_Result (Sample_I2, C432004_0.Mesozoic) or + Sample_I2.Period /= Jurassic or + Sample_I2.Loc /= null or + Sample_I2.Sample_On_Loan /= False then + Report.Failed ("Object 2 of record extension of abstract record " & + "extension of abstract private ancestor, " & + "SampleType_I, failed content check"); + end if; + + ------------------- + if not TC_Correct_Result (Sample_J, + Jurassic, + C432004_0.Mesozoic) or + Sample_J.Sample_On_Loan /= False then + Report.Failed ("Object of record extension of private extension " & + "of abstract private ancestor, SampleType_J, " & + "failed content check"); + end if; + + Report.Result; + + end C432004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C43204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR + -- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF + -- A SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS CONSTRAINED. + + -- HISTORY: + -- JET 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204A IS + + TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER; + TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER; + TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER; + + TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0), + IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1, + INTEGER RANGE -1..1) OF INTEGER; + TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1), + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY(INTEGER'(-1)..1, + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + + PROCEDURE PROC10 (A : ARR10) IS + BEGIN + IF A'LENGTH /= IDENT_INT(0) THEN + FAILED ("PROC10 ARRAY IS NOT NULL"); + END IF; + END PROC10; + + PROCEDURE PROC11 (A : ARR11; C : INTEGER) IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) OR + A'FIRST /= IDENT_INT(-3) OR + A'LAST /= IDENT_INT(3) THEN + FAILED ("INCORRECT LENGTH IN PROC11 CALL NUMBER" & + INTEGER'IMAGE(C)); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC11 CALL NUMBER" & + INTEGER'IMAGE(C)); + END IF; + END LOOP; + END PROC11; + + PROCEDURE PROC12 (A : ARR12) IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) THEN + FAILED ("INCORRECT LENGTH IN PROC12"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 3 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC12"); + END IF; + END LOOP; + END PROC12; + + PROCEDURE PROC20 (A : ARR20) IS + BEGIN + IF A'LENGTH(1) /= IDENT_INT(0) OR + A'LENGTH(2) /= IDENT_INT(0) THEN + FAILED ("PROC20 ARRAY IS NOT NULL"); + END IF; + END PROC20; + + PROCEDURE PROC21 (A : ARR21; C : INTEGER) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC21 CALL " & + "NUMBER" & INTEGER'IMAGE(C)); + END IF; + END LOOP; + END LOOP; + END PROC21; + + PROCEDURE PROC22 (A : ARR22) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 5 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC22"); + END IF; + END LOOP; + END LOOP; + END PROC22; + + PROCEDURE PROC23 (A : ARR23) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 7 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), PROC23"); + END IF; + END LOOP; + END LOOP; + END PROC23; + + BEGIN + TEST ("C43204A", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " & + "CORRECTLY) AS AN ACTUAL PARAMETER OF A " & + "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " & + "CONSTRAINED"); + + PROC11 ((1,1,1, OTHERS => 1), 1); + PROC11 ((2 => 2, 3 => 2, OTHERS => 2), 2); + PROC12 ((OTHERS => 3)); + PROC10 ((OTHERS => 4)); + + PROC21 (((1,1,1), OTHERS => (1,1,1)), 1); + PROC21 ((1 => (2,2,2), OTHERS => (2,2,2)), 2); + PROC21 (((3,OTHERS => 3), (3,OTHERS => 3), (3,3,OTHERS => 3)), 3); + PROC21 (((-1 => 4, OTHERS => 4), (0 => 4, OTHERS => 4), + (1 => 4, OTHERS => 4)), 4); + PROC22 ((OTHERS => (OTHERS => 5))); + PROC20 ((OTHERS => (OTHERS => 6))); + PROC23 ((OTHERS => (7,7,7))); + + RESULT; + END C43204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- C43204C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR + -- (AND BOUNDS ARE DETERMINED CORRECTLY) AS AN ACTUAL PARAMETER OF + -- A GENERIC INSTANTIATION WHEN THE GENERIC FORMAL PARAMETER IS + -- CONSTRAINED. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204C IS + + TYPE ARR10 IS ARRAY(IDENT_INT(1)..IDENT_INT(0)) OF INTEGER; + TYPE ARR11 IS ARRAY(INTEGER RANGE -3..3) OF INTEGER; + TYPE ARR12 IS ARRAY(IDENT_INT(-3)..IDENT_INT(3)) OF INTEGER; + + TYPE ARR20 IS ARRAY(IDENT_INT(1)..IDENT_INT(0), + IDENT_INT(0)..IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY(INTEGER RANGE -1..1, + INTEGER RANGE -1..1) OF INTEGER; + TYPE ARR22 IS ARRAY(IDENT_INT(-1)..IDENT_INT(1), + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY(INTEGER'(-1)..1, + IDENT_INT(-1)..IDENT_INT(1)) OF INTEGER; + + GENERIC + A : ARR10; + PROCEDURE GPROC10; + + GENERIC + A : ARR11; + PROCEDURE GPROC11; + + GENERIC + A : ARR12; + PROCEDURE GPROC12; + + GENERIC + A : ARR20; + PROCEDURE GPROC20; + + GENERIC + A : ARR21; + PROCEDURE GPROC21 (C : INTEGER); + + GENERIC + A : ARR22; + PROCEDURE GPROC22; + + GENERIC + A : ARR23; + PROCEDURE GPROC23; + + PROCEDURE GPROC10 IS + BEGIN + IF A'LENGTH /= IDENT_INT(0) THEN + FAILED ("PROC10 ARRAY IS NOT NULL"); + END IF; + END GPROC10; + + PROCEDURE GPROC11 IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) OR + A'FIRST /= IDENT_INT(-3) OR + A'LAST /= IDENT_INT(3) THEN + FAILED ("INCORRECT LENGTH IN PROC11"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 1 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC11"); + END IF; + END LOOP; + END GPROC11; + + PROCEDURE GPROC12 IS + BEGIN + IF A'LENGTH /= IDENT_INT(7) THEN + FAILED ("INCORRECT LENGTH IN PROC12"); + END IF; + + FOR I IN IDENT_INT(-3)..IDENT_INT(3) LOOP + IF IDENT_INT(A(I)) /= 2 THEN + FAILED ("INCORRECT VALUE OF COMPONENT " & + INTEGER'IMAGE(I) & ", PROC12"); + END IF; + END LOOP; + END GPROC12; + + PROCEDURE GPROC20 IS + BEGIN + IF A'LENGTH(1) /= IDENT_INT(0) OR + A'LENGTH(2) /= IDENT_INT(0) THEN + FAILED ("GPROC20 ARRAY IS NOT NULL"); + END IF; + END GPROC20; + + PROCEDURE GPROC21 (C : INTEGER) IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= C THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC21 CALL " & + "NUMBER" & INTEGER'IMAGE(C)); + END IF; + END LOOP; + END LOOP; + END GPROC21; + + PROCEDURE GPROC22 IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 3 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC22"); + END IF; + END LOOP; + END LOOP; + END GPROC22; + + PROCEDURE GPROC23 IS + BEGIN + FOR I IN INTEGER'(-1)..1 LOOP + FOR J IN INTEGER'(-1)..1 LOOP + IF IDENT_INT(A(I,J)) /= 4 THEN + FAILED ("INCORRECT VALUE OF COMPONENT (" & + INTEGER'IMAGE(I) & "," & + INTEGER'IMAGE(J) & "), GPROC23"); + END IF; + END LOOP; + END LOOP; + END GPROC23; + + PROCEDURE PROC11 IS NEW GPROC11((1,1,1, OTHERS => 1)); + PROCEDURE PROC12 IS NEW GPROC12((OTHERS => 2)); + PROCEDURE PROC10 IS NEW GPROC10((OTHERS => 3)); + + PROCEDURE PROC21 IS NEW GPROC21(((1,1,1), OTHERS => (1,1,1))); + PROCEDURE PROC22 IS NEW GPROC21(((2,OTHERS => 2), (2,OTHERS => 2), + (2,2,OTHERS => 2))); + PROCEDURE PROC23 IS NEW GPROC22((OTHERS => (OTHERS => 3))); + PROCEDURE PROC24 IS NEW GPROC23((OTHERS => (4,4,4))); + PROCEDURE PROC20 IS NEW GPROC20((OTHERS => (OTHERS => 5))); + + BEGIN + TEST ("C43204C", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR (AND BOUNDS ARE DETERMINED " & + "CORRECTLY) AS AN ACTUAL PARAMETER OF A " & + "SUBPROGRAM CALL WHEN THE FORMAL PARAMETER IS " & + "CONSTRAINED"); + + PROC11; + PROC12; + PROC10; + + PROC21(1); + PROC22(2); + PROC23; + PROC24; + PROC20; + + RESULT; + END C43204C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- C43204E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS CHOICE CAN APPEAR + -- AS THE INITIALIZATION EXPRESSION OF A CONSTRAINED CONSTANT, + -- VARIABLE OBJECT DECLARATION, OR RECORD COMPONENT DECLARATION, + -- AND THAT THE BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204E IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + CA11 : CONSTANT ARR11 := (1, OTHERS => IDENT_INT(2)); + CA12 : CONSTANT ARR12 := (OTHERS => IDENT_INT(2)); + CA13 : CONSTANT ARR13 := (OTHERS => IDENT_INT(2)); + CA21 : CONSTANT ARR21 := (OTHERS => (-1..1 => IDENT_INT(2))); + CA22 : CONSTANT ARR22 := (OTHERS => (-1..1 => IDENT_INT(2))); + CA23 : CONSTANT ARR23 := (-1..1 => (OTHERS => IDENT_INT(2))); + CA24 : CONSTANT ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + VA11 : ARR11 := (1,1, OTHERS => IDENT_INT(2)); + VA12 : ARR12 := (OTHERS => IDENT_INT(2)); + VA13 : ARR13 := (OTHERS => IDENT_INT(2)); + VA21 : ARR21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2))); + VA22 : ARR22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2))); + VA23 : ARR23 := (OTHERS => (OTHERS => IDENT_INT(2))); + VA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + TYPE REC IS RECORD + RA11 : ARR11 := (1,1,1, OTHERS => IDENT_INT(2)); + RA12 : ARR12 := (OTHERS => IDENT_INT(2)); + RA13 : ARR13 := (OTHERS => IDENT_INT(2)); + RA21 : ARR21 := ((1,1,1), (1,1,1), OTHERS => (IDENT_INT(2), + IDENT_INT(2), IDENT_INT(2))); + RA22 : ARR22 := (OTHERS => (OTHERS => IDENT_INT(2))); + RA23 : ARR23 := (-1 => (OTHERS => 1), + 0..1 => (OTHERS => IDENT_INT(2))); + RA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + END RECORD; + + R : REC; + + BEGIN + TEST ("C43204E", "CHECK THAT AN ARRAY AGGREGATE WITH AN OTHERS " & + "CHOICE CAN APPEAR AS THE INITIALIZATION " & + "EXPRESSION OF A CONSTRAINED CONSTANT, " & + "VARIABLE OBJECT DECLARATION, OR RECORD " & + "COMPONENT DECLARATION, AND THAT THE BOUNDS OF " & + "THE AGGREGATE ARE DETERMINED CORRECTLY"); + + IF CA11 /= (1, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF CA11"); + END IF; + + IF CA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF CA12"); + END IF; + + IF CA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF CA13"); + END IF; + + IF CA21 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA21"); + END IF; + + IF CA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA22"); + END IF; + + IF CA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF CA23"); + END IF; + + IF CA24'LENGTH /= 0 OR CA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF CA24"); + END IF; + + IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA11"); + END IF; + + IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA12"); + END IF; + + IF VA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF VA13"); + END IF; + + IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA21"); + END IF; + + IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA22"); + END IF; + + IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA23"); + END IF; + + IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF VA24"); + END IF; + + IF R.RA11 /= (1, 1, 1, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF RA11"); + END IF; + + IF R.RA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF RA12"); + END IF; + + IF R.RA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF RA13"); + END IF; + + IF R.RA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA21"); + END IF; + + IF R.RA22 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA22"); + END IF; + + IF R.RA23 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF RA23"); + END IF; + + IF R.RA24'LENGTH /= 0 OR R.RA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF RA24"); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; + END C43204E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204f.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C43204F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A + -- CONSTRAINED FORMAL PARAMETER OF A SUBPROGRAM AND THAT THE BOUNDS + -- OF THE AGGREGATE ARE DETERMINED CORRECTLY. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204F IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + PROCEDURE PROC (PA11 : ARR11 := (1,1,1,1,1,1, + OTHERS => IDENT_INT(2)); + PA12 : ARR12 := (OTHERS => IDENT_INT(2)); + PA13 : ARR13 := (OTHERS => IDENT_INT(2)); + PA21 : ARR21 := ((1,1,1), (1,1,1), + (1, OTHERS => IDENT_INT(2))); + PA22 : ARR22 := ((1,1,1), (1,1,1), + (OTHERS => IDENT_INT(2))); + PA23 : ARR23 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (OTHERS => + IDENT_INT(2))); + PA24 : ARR24 := (OTHERS => (OTHERS => + IDENT_INT(2)))) IS + BEGIN + IF PA11 /= (1, 1, 1, 1, 1, 1, 2) THEN + FAILED("INCORRECT VALUE OF PA11"); + END IF; + + IF PA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF PA12"); + END IF; + + IF PA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF PA13"); + END IF; + + IF PA21 /= ((1,1,1), (1,1,1), (1,2,2)) THEN + FAILED("INCORRECT VALUE OF PA21"); + END IF; + + IF PA22 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF PA22"); + END IF; + + IF PA23 /= ((1,1,1), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF PA23"); + END IF; + + IF PA24'LENGTH /= 0 OR PA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF PA24"); + END IF; + END PROC; + + BEGIN + TEST ("C43204F", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF A SUBPROGRAM AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + PROC; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; + END C43204F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204g.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C43204G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A + -- CONSTRAINED FORMAL PARAMETER OF AN ENTRY, AND THAT THE BOUNDS + -- OF THE AGGREGATE ARE DETERMINED CORRECTLY. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204G IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + TASK T IS + ENTRY E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2)); + EA12 : ARR12 := (OTHERS => IDENT_INT(2)); + EA13 : ARR13 := (OTHERS => IDENT_INT(2)); + EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (-1..1 => IDENT_INT(2))); + EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1), + (1,1,1)); + EA23 : ARR23 := (-1..0 => (OTHERS => 1), + 1 => (OTHERS => IDENT_INT(2))); + EA24: ARR24 := (OTHERS => (OTHERS => IDENT_INT(2)))); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (EA11 : ARR11 := (1,1,1,1, OTHERS => IDENT_INT(2)); + EA12 : ARR12 := (OTHERS => IDENT_INT(2)); + EA13 : ARR13 := (OTHERS => IDENT_INT(2)); + EA21 : ARR21 := ((1,1,1), (1,1,1), (1,1,1), + OTHERS => (-1..1 => IDENT_INT(2))); + EA22 : ARR22 := ((OTHERS => IDENT_INT(2)), (1,1,1), + (1,1,1)); + EA23 : ARR23 := (-1..0 => (OTHERS => 1), + 1 => (OTHERS => IDENT_INT(2))); + EA24 : ARR24 := (OTHERS => (OTHERS => + IDENT_INT(2)))) + DO + IF EA11 /= (1, 1, 1, 1, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF EA11"); + END IF; + + IF EA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF EA12"); + END IF; + + IF EA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF EA13"); + END IF; + + IF EA21 /= ((1,1,1), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF EA21"); + END IF; + + IF EA22 /= ((2,2,2), (1,1,1), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF EA22"); + END IF; + + IF EA23 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF EA23"); + END IF; + + IF EA24'LENGTH /= 0 OR EA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF EA24"); + END IF; + END E; + END T; + + BEGIN + TEST ("C43204G", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF AN ENTRY, AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + T.E; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + IF T'CALLABLE THEN + T.E; + END IF; + + RESULT; + END C43204G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204h.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C43204H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS A + -- CONSTRAINED FORMAL PARAMETER OF A GENERIC UNIT, AND THAT THE + -- BOUNDS OF THE AGGREGATE ARE DETERMINED CORRECTLY. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204H IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + GENERIC + GA11 : ARR11 := (1,1,1,1,1, OTHERS => IDENT_INT(2)); + GA12 : ARR12 := (OTHERS => IDENT_INT(2)); + GA13 : ARR13 := (OTHERS => IDENT_INT(2)); + GA21 : ARR21 := ((1,1,1), (1,1,1), (OTHERS => IDENT_INT(2))); + GA22 : ARR22 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1)); + GA23 : ARR23 := ((1,1,1), (OTHERS => IDENT_INT(2)), (1,1,1)); + GA24 : ARR24 := (OTHERS => (OTHERS => IDENT_INT(2))); + PROCEDURE GEN; + + PROCEDURE GEN IS + BEGIN + IF GA11 /= (1, 1, 1, 1, 1, 2, 2) THEN + FAILED("INCORRECT VALUE OF GA11"); + END IF; + + IF GA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF GA12"); + END IF; + + IF GA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF GA13"); + END IF; + + IF GA21 /= ((1,1,1), (1,1,1), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF GA21"); + END IF; + + IF GA22 /= ((1,1,1), (2,2,2), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF GA22"); + END IF; + + IF GA23 /= ((1,1,1), (2,2,2), (1,1,1)) THEN + FAILED("INCORRECT VALUE OF GA23"); + END IF; + + IF GA24'LENGTH /= 0 OR GA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF GA24"); + END IF; + END GEN; + + PROCEDURE PROCG IS NEW GEN; + + BEGIN + TEST ("C43204H", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS A CONSTRAINED FORMAL PARAMETER " & + "OF A GENERIC UNIT, AND THAT THE BOUNDS OF " & + "THE AGGREGATE ARE DETERMINED CORRECTLY"); + + PROCG; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; + END C43204H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43204i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43204i.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C43204I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE CAN APPEAR AS THE + -- EXPRESSION IN AN ASSIGNMENT STATEMENT, AND THAT THE BOUNDS OF + -- THE AGGREGATE ARE DETERMINED CORRECTLY. + + -- HISTORY: + -- JET 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43204I IS + + TYPE ARR11 IS ARRAY (INTEGER RANGE -3 .. 3) OF INTEGER; + TYPE ARR12 IS ARRAY (IDENT_INT(-3) .. IDENT_INT(3)) OF INTEGER; + TYPE ARR13 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1)) OF INTEGER; + TYPE ARR21 IS ARRAY (INTEGER RANGE -1 .. 1, + INTEGER RANGE -1 .. 1) OF INTEGER; + TYPE ARR22 IS ARRAY (IDENT_INT(-1) .. IDENT_INT(1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR23 IS ARRAY (INTEGER RANGE -1 .. 1, + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + TYPE ARR24 IS ARRAY (IDENT_INT(1) .. IDENT_INT(-1), + IDENT_INT(-1) .. IDENT_INT(1)) OF INTEGER; + + VA11 : ARR11; + VA12 : ARR12; + VA13 : ARR13; + VA21 : ARR21; + VA22 : ARR22; + VA23 : ARR23; + VA24 : ARR24; + + BEGIN + TEST ("C43204I", "CHECK THAT AN AGGREGATE WITH AN OTHERS CLAUSE " & + "CAN APPEAR AS THE EXPRESSION IN AN ASSIGNMENT " & + "STATEMENT, AND THAT THE BOUNDS OF THE " & + "AGGREGATE ARE DETERMINED CORRECTLY"); + + VA11 := (1,1, OTHERS => IDENT_INT(2)); + VA12 := (OTHERS => IDENT_INT(2)); + VA13 := (OTHERS => IDENT_INT(2)); + VA21 := ((1,1,1), OTHERS => (-1..1 => IDENT_INT(2))); + VA22 := (-1 => (1,1,1), 0..1 => (OTHERS => IDENT_INT(2))); + VA23 := (OTHERS => (OTHERS => IDENT_INT(2))); + VA24 := (OTHERS => (OTHERS => IDENT_INT(2))); + + IF VA11 /= (1, 1, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA11"); + END IF; + + IF VA12 /= (2, 2, 2, 2, 2, 2, 2) THEN + FAILED("INCORRECT VALUE OF VA12"); + END IF; + + IF VA13'LENGTH /= 0 THEN + FAILED("INCORRECT VALUE OF VA13"); + END IF; + + IF VA21 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA21"); + END IF; + + IF VA22 /= ((1,1,1), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA22"); + END IF; + + IF VA23 /= ((2,2,2), (2,2,2), (2,2,2)) THEN + FAILED("INCORRECT VALUE OF VA23"); + END IF; + + IF VA24'LENGTH /= 0 OR VA24'LENGTH(2) /= 3 THEN + FAILED("INCORRECT VALUE OF VA24"); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED CONSTRAINT_ERROR OR OTHER EXCEPTION " & + "RAISED"); + + RESULT; + END C43204I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C43205A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + + -- A) AN ACTUAL PARAMETER IN A SUBPROGRAM OR ENTRY CALL, AND THE + -- FORMAL PARAMETER IS UNCONSTRAINED. + + -- EG 01/26/84 + + WITH REPORT; + + PROCEDURE C43205A IS + + USE REPORT; + + BEGIN + + TEST("C43205A", "CASE A1 : SUBPROGRAM WITH UNCONSTRAINED " & + "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + BEGIN + + CASE_A : BEGIN + + CASE_A1 : DECLARE + + SUBTYPE STA IS INTEGER RANGE 11 .. 15; + TYPE TA IS ARRAY (STA RANGE <>) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST /= IDENT_INT(11) THEN + FAILED ("CASE A1 : LOWER BOUND " & + "INCORRECTLY GIVEN BY 'FIRST"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE A1 : UPPER BOUND " & + "INCORRECTLY GIVEN BY 'LAST"); + ELSIF A /= (6, 7, 8, 9, 10) THEN + FAILED ("CASE A1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ((6, 7, 8, 9, IDENT_INT(10))); + + END CASE_A1; + + COMMENT ("CASE A2 : SUBPROGRAM WITH UNCONSTRAINED " & + "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A2 : DECLARE + + SUBTYPE STA1 IS INTEGER RANGE 11 .. IDENT_INT(12); + SUBTYPE STA2 IS INTEGER RANGE 10 .. 11; + TYPE TA IS ARRAY (STA1 RANGE <>, STA2 RANGE <>) + OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE A2 : LOWER BOUND " & + "INCORRECTLY GIVEN BY 'FIRST"); + ELSIF A'LAST(1) /= 12 OR + A'LAST(2) /= IDENT_INT(11) THEN + FAILED ("CASE A2 : UPPER BOUND " & + "INCORRECTLY GIVEN BY 'LAST"); + ELSIF A /= ((1, 2), (3, 4)) THEN + FAILED ("CASE A2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (((1, 2), (IDENT_INT(3), 4))); + + END CASE_A2; + + END CASE_A; + + END; + + RESULT; + + END C43205A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C43205B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + + -- B) AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL + -- PARAMETER IS UNCONSTRAINED. + + -- EG 01/26/84 + + WITH REPORT; + + PROCEDURE C43205B IS + + USE REPORT; + + BEGIN + + TEST("C43205B", "CASE B : UNCONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + + CASE_B : DECLARE + + SUBTYPE STB IS INTEGER RANGE IDENT_INT(-8) .. -5; + TYPE TB IS ARRAY (STB RANGE <>) OF INTEGER; + + GENERIC + B1 : TB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= -8 THEN + FAILED ("CASE B : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF B1'LAST /= IDENT_INT(-5) THEN + FAILED ("CASE B : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF B1 /= (7, 6, 5, 4) THEN + FAILED ("CASE B : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ((7, 6, IDENT_INT(5), 4)); + + BEGIN + + PROC2; + + END CASE_B; + + END; + + RESULT; + + END C43205B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C43205C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + + -- C) THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS + -- UNCONSTRAINED. + + -- EG 01/26/84 + + WITH REPORT; + + PROCEDURE C43205C IS + + USE REPORT; + + BEGIN + + TEST("C43205C", "CASE C : UNCONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + + CASE_C : DECLARE + + SUBTYPE STC1 IS INTEGER RANGE -2 .. 3; + SUBTYPE STC2 IS INTEGER RANGE 7 .. 20; + TYPE TC IS ARRAY (STC1 RANGE <>, STC2 RANGE <>) + OF INTEGER; + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ((5, 4, 3), (2, IDENT_INT(1), 0)); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -2 THEN + FAILED ("CASE C : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("CASE C : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= -1 THEN + FAILED ("CASE C : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("CASE C : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST(2)"); + ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN + FAILED ("CASE C : FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_C; + + END; + + RESULT; + + END C43205C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C43205D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + + -- D) THE INITIALIZATION EXPRESSION OF A CONSTANT WHOSE TYPE MARK + -- DENOTES AN UNCONSTRAINED ARRAY. + + -- EG 01/26/84 + + WITH REPORT; + + PROCEDURE C43205D IS + + USE REPORT; + + BEGIN + + TEST("C43205D", "CASE D : INITIALIZATION OF UNCONSTRAINED " & + "ARRAY CONSTANT"); + + BEGIN + + CASE_D : DECLARE + + SUBTYPE STD IS INTEGER RANGE IDENT_INT(11) .. 13; + TYPE TD IS ARRAY (STD RANGE <>) OF INTEGER; + + D1 : CONSTANT TD := (-1, -2, -3); + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE D : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE D : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF D1 /= (-1, -2, -3) THEN + FAILED ("CASE D : ARRAY DOES NOT CONTAIN " & + "THE CORRECT VALUES"); + END IF; + + END CASE_D; + + END; + + RESULT; + + END C43205D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205e.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C43205E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- 'FIRST OF THE INDEX SUBTYPE WHEN THE POSITIONAL AGGREGATE IS USED AS: + + -- E) THE LEFT OR RIGHT OPERAND OF "&". + + -- EG 01/26/84 + + WITH REPORT; + + PROCEDURE C43205E IS + + USE REPORT; + + BEGIN + + TEST("C43205E", "CASE E : OPERAND OF &"); + + BEGIN + + CASE_E : DECLARE + + SUBTYPE STE IS INTEGER RANGE 2 .. 10; + + TYPE COLOR IS (RED, GREEN, BLUE); + TYPE TE IS ARRAY (STE RANGE <>) OF COLOR; + + FUNCTION CONCAT1 RETURN TE IS + BEGIN + RETURN (RED, GREEN, BLUE) & (7 .. 8 => RED); + END; + + FUNCTION CONCAT2 RETURN TE IS + BEGIN + RETURN (IDENT_INT(4) .. 3 => RED) & (GREEN, BLUE); + END; + + FUNCTION CONCAT3 RETURN STRING IS + BEGIN + RETURN "TEST" & (7 .. 8 => 'X'); + END; + + FUNCTION CONCAT4 RETURN STRING IS + BEGIN + RETURN (8 .. 5 => 'A') & "BC"; + END; + + BEGIN + + IF CONCAT1'FIRST /= IDENT_INT(2) THEN + FAILED ("CASE E1 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT1'LAST /= 6 THEN + FAILED ("CASE E1 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT1 /= (RED, GREEN, BLUE, RED, RED) THEN + FAILED ("CASE E1 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT2'FIRST /= IDENT_INT(2) THEN + FAILED ("CASE E2 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT2'LAST /= 3 THEN + FAILED ("CASE E2 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT2 /= (GREEN, BLUE) THEN + FAILED ("CASE E2 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT3'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE E3 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT3'LAST /= 6 THEN + FAILED ("CASE E3 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT3 /= "TESTXX" THEN + FAILED ("CASE E3 : INCORRECT VALUES PRODUCED"); + END IF; + IF CONCAT4'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE E4 : LOWER BOUND INCORRECTLY " & + "GIVEN BY 'FIRST"); + ELSIF CONCAT4'LAST /= 2 THEN + FAILED ("CASE E4 : UPPER BOUND INCORRECTLY " & + "GIVEN BY 'LAST"); + ELSIF CONCAT4 /= "BC" THEN + FAILED ("CASE E4 : INCORRECT VALUES PRODUCED"); + END IF; + + END CASE_E; + + END; + + RESULT; + + END C43205E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205g.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C43205G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE + -- POSITIONAL AGGREGATE IS USED AS: + + -- AN ACTUAL PARAMETER IN A SUBPROGRAM, AND THE + -- FORMAL PARAMETER IS CONSTRAINED. + + -- EG 01/27/84 + + WITH REPORT; + + PROCEDURE C43205G IS + + USE REPORT; + + BEGIN + + TEST("C43205G", "SUBPROGRAM WITH CONSTRAINED " & + "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + BEGIN + + CASE_G : BEGIN + + CASE_G1 : DECLARE + + TYPE TA IS ARRAY (IDENT_INT(11) .. 15) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST /= 11 THEN + FAILED ("CASE A1 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE A1 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= (6, 7, 8, 9, 10) THEN + FAILED ("CASE A1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ((6, 7, 8, IDENT_INT(9), 10)); + + END CASE_G1; + + CASE_G2 : DECLARE + + TYPE TA IS ARRAY (11 .. 12, + IDENT_INT(10) .. 11) OF INTEGER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE A2 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN + FAILED ("CASE A2 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= ((1, 2), (3, 4)) THEN + FAILED ("CASE A2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (((1, 2), (3, 4))); + + END CASE_G2; + + END CASE_G; + + END; + + RESULT; + + END C43205G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205h.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C43205H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE + -- POSITIONAL AGGREGATE IS USED AS: + + -- AN ACTUAL PARAMETER IN A GENERIC INSTANTIATION, AND THE FORMAL + -- PARAMETER IS CONSTRAINED. + + -- EG 01/27/84 + + WITH REPORT; + + PROCEDURE C43205H IS + + USE REPORT; + + BEGIN + + TEST("C43205H", "CONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + + CASE_H : DECLARE + + SUBTYPE STH IS INTEGER RANGE -10 .. 0; + TYPE BASE IS ARRAY(STH RANGE <>) OF INTEGER; + SUBTYPE TB IS BASE(IDENT_INT(-8) .. -5); + + GENERIC + B1 : TB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= -8 THEN + FAILED ("CASE B : LOWER BOUND INCORRECT"); + ELSIF B1'LAST /= -5 THEN + FAILED ("CASE B : UPPER BOUND INCORRECT"); + ELSIF B1 /= (7, 6, 5, 4) THEN + FAILED ("CASE B : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ((7, 6, 5, 4)); + + BEGIN + + PROC2; + + END CASE_H; + + END; + + RESULT; + + END C43205H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205i.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C43205I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE + -- POSITIONAL AGGREGATE IS USED AS: + + -- THE RETURN EXPRESSION IN A FUNCTION WHOSE RETURN TYPE IS + -- CONSTRAINED. + + -- EG 01/27/84 + + WITH REPORT; + + PROCEDURE C43205I IS + + USE REPORT; + + BEGIN + + TEST("C43205I", "CONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + + CASE_I : DECLARE + + SUBTYPE STC IS INTEGER RANGE -2 .. 10; + TYPE BASE IS ARRAY(STC RANGE <>, STC RANGE <>)OF INTEGER; + SUBTYPE TC IS BASE(IDENT_INT(-1) .. 0, 7 .. 9); + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ((5, 4, 3), (2, 1, 0)); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -1 THEN + FAILED ("CASE I : LOWER BOUND INCORRECT " & + "FOR 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("CASE I : LOWER BOUND INCORRECT " & + "FOR 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= 0 THEN + FAILED ("CASE I : UPPER BOUND INCORRECT " & + "FOR 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("CASE I : UPPER BOUND INCORRECT " & + "FOR 'LAST(2)"); + ELSIF FUN1(5) /= ((5, 4, 3), (2, 1, 0)) THEN + FAILED ("CASE I : FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_I; + + END; + + RESULT; + + END C43205I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205j.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C43205J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE + -- POSITIONAL AGGREGATE IS USED AS: + + -- J) THE INITIALIZATION EXPRESSION OF A CONSTANT, VARIABLE, OR FORMAL + -- PARAMETER (OF A SUBPROGRAM, ENTRY, OR GENERIC UNIT) WHEN THE + -- TYPE OF THE CONSTANT, VARIABLE, OR PARAMETER IS CONSTRAINED. + + -- EG 01/27/84 + + WITH REPORT; + + PROCEDURE C43205J IS + + USE REPORT; + + BEGIN + + TEST("C43205J", "CASE J : INITIALIZATION OF CONSTRAINED " & + "ARRAY"); + + BEGIN + + CASE_J : BEGIN + + CASE_J1 : DECLARE + + TYPE TD1 IS ARRAY (IDENT_INT(11) .. 13) OF INTEGER; + + D1 : CONSTANT TD1 := (-1, -2, -3); + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE J1 : LOWER BOUND INCORRECT"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE J1 : UPPER BOUND INCORRECT"); + ELSIF D1 /= (-1, -2, -3) THEN + FAILED ("CASE J1 : ARRAY DOES NOT " & + "CONTAINING THE CORRECT VALUES"); + END IF; + + END CASE_J1; + + CASE_J2 : DECLARE + + TYPE TD2 IS ARRAY(INTEGER RANGE -13 .. -11) + OF INTEGER; + D2 : TD2 := (3, 2, 1); + + BEGIN + + IF D2'FIRST /= -13 THEN + FAILED ("CASE J2 : LOWER BOUND INCORRECT"); + ELSIF D2'LAST /= -11 THEN + FAILED ("CASE J2 : UPPER BOUND INCORRECT"); + ELSIF D2 /= (3, 2, 1) THEN + FAILED ("CASE J2 : INCORRECT VALUES"); + END IF; + + END CASE_J2; + + CASE_J3 : DECLARE + + TYPE TD3 IS ARRAY(IDENT_INT(5) .. 7) OF INTEGER; + + PROCEDURE PROC1 (A : TD3 := (2, 3, 4)) IS + BEGIN + IF A'FIRST /= 5 THEN + FAILED ("CASE J3 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 7 THEN + FAILED ("CASE J3 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= (2, 3, 4) THEN + FAILED ("CASE J3 : INCORRECT VALUES"); + END IF; + END PROC1; + + BEGIN + + PROC1; + + END CASE_J3; + + CASE_J4 : DECLARE + + TYPE TD4 IS ARRAY(5 .. 8) OF INTEGER; + + GENERIC + D4 : TD4 := (1, -2, 3, -4); + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF D4'FIRST /= 5 THEN + FAILED ("CASE J4 : LOWER BOUND " & + "INCORRECT"); + ELSIF D4'LAST /= 8 THEN + FAILED ("CASE J4 : UPPER BOUND " & + "INCORRECT"); + ELSIF D4 /= (1, -2, 3, -4) THEN + FAILED ("CASE J4 : INCORRECT VALUES"); + END IF; + END PROC1; + + PROCEDURE PROC2 IS NEW PROC1; + + BEGIN + + PROC2; + + END CASE_J4; + + END CASE_J; + + END; + + RESULT; + + END C43205J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43205k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43205k.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C43205K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A POSITIONAL AGGREGATE ARE DETERMINED + -- CORRECTLY. IN PARTICULAR, CHECK THAT THE LOWER BOUND IS GIVEN BY + -- THE LOWER BOUND OF THE APPLICABLE INDEX CONSTRAINT WHEN THE + -- POSITIONAL AGGREGATE IS USED AS: + + -- THE EXPRESSION OF AN ENCLOSING RECORD OR ARRAY AGGREGATE, AND + -- THE EXPRESSION GIVES THE VALUE OF A RECORD OR ARRAY COMPONENT + -- (WHICH IS NECESSARILY CONSTRAINED). + + -- EG 01/27/84 + -- JBG 3/30/84 + + WITH REPORT; + + PROCEDURE C43205K IS + + USE REPORT; + + BEGIN + + TEST("C43205K", "THE EXPRESSION OF AN ENCLOSING RECORD " & + "OR ARRAY AGGREGATE, AND THE EXPRESSION GIVES " & + "THE VALUE OF A RECORD OR ARRAY COMPONENT"); + + BEGIN + + CASE_K : BEGIN + + CASE_K1 : DECLARE + + SUBTYPE SK1 IS INTEGER RANGE 2 .. 6; + TYPE BASE IS ARRAY(SK1 RANGE <>) OF INTEGER; + SUBTYPE TE1 IS BASE(IDENT_INT(3) .. 5); + TYPE TE2 IS ARRAY(1 .. 2) OF TE1; + + E1 : TE2; + + BEGIN + + E1 := (1 .. 2 => (3, 2, 1)); + IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE + (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR + E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN + FAILED ("CASE K1 : INCORRECT BOUNDS"); + ELSE + IF E1 /= (1 .. 2 => (3, 2, 1)) THEN + FAILED ("CASE K1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END IF; + + END CASE_K1; + + CASE_K2 : DECLARE + + TYPE SK2 IS RANGE 2 .. 6; + TYPE BASE IS ARRAY(SK2 RANGE <>) OF INTEGER; + SUBTYPE TE1 IS BASE(3 .. 5); + TYPE TER IS + RECORD + REC : TE1; + END RECORD; + + E2 : TER; + + BEGIN + + E2 := (REC => (3, 2, 1)); + IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN + FAILED ("CASE K2 : INCORRECT BOUNDS"); + ELSE + IF E2.REC /= (3, 2, 1) THEN + FAILED ("CASE K2 : ARRAY DOES NOT " & + "CONTAIN CORRECT VALUES"); + END IF; + END IF; + + END CASE_K2; + + END CASE_K; + + END; + + RESULT; + + END C43205K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43206a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- C43206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF A NULL ARRAY AGGREGATE ARE DETERMINED + -- BY THE BOUNDS SPECIFIED BY THE CHOICES. IN PARTICULAR, CHECK + -- THAT: + + -- A) THE UPPER BOUND IS NOT REQUIRED TO BE THE PREDECESSOR OF + -- THE LOWER BOUND. + + -- B) NEITHER THE UPPER NOR THE LOWER BOUND NEED BELONG TO THE + -- INDEX SUBTYPE FOR NULL RANGES. + + -- C) IF ONE CHOICE OF A MULTIDIMENSIONAL AGGREGATE IS NON-NULL + -- BUT THE AGGREGATE IS A NULL ARRAY, CONSTRAINT_ERROR IS + -- RAISED WHEN THE NON-NULL CHOICES DO NOT BELONG TO THE + -- INDEX SUBTYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- EG 02/02/84 + -- JBG 12/6/84 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; + + PROCEDURE C43206A IS + + USE REPORT; + + BEGIN + + TEST("C43206A", "CHECK THAT THE BOUNDS OF A NULL ARRAY ARE " & + "DETERMINED BY THE BOUNDS SPECIFIED BY THE " & + "CHOICES"); + + DECLARE + + SUBTYPE ST1 IS INTEGER RANGE 10 .. 15; + SUBTYPE ST2 IS INTEGER RANGE 1 .. 5; + + TYPE T1 IS ARRAY (ST1 RANGE <>) OF INTEGER; + TYPE T2 IS ARRAY (ST2 RANGE <>, ST1 RANGE <>) OF INTEGER; + + BEGIN + + CASE_A : BEGIN + + CASE_A1 : DECLARE + + PROCEDURE PROC1 (A : T1) IS + BEGIN + IF A'FIRST /= 12 OR A'LAST /= 10 THEN + FAILED ("CASE A1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1((12 .. 10 => -2)); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE A1 : EXCEPTION RAISED"); + + END CASE_A1; + + CASE_A2 : DECLARE + + PROCEDURE PROC1 (A : STRING) IS + BEGIN + IF A'FIRST /= 5 OR A'LAST /= 2 THEN + FAILED ("CASE A2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((5 .. 2 => 'E')); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE A2 : EXCEPTION RAISED"); + + END CASE_A2; + + END CASE_A; + + CASE_B : BEGIN + + CASE_B1 : DECLARE + + PROCEDURE PROC1 (A : T1; L, U : INTEGER) IS + BEGIN + IF A'FIRST /= L OR A'LAST /= U THEN + FAILED ("CASE B1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + BEGIN + + PROC1 ((5 .. INTEGER'FIRST => -2), + 5, INTEGER'FIRST); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CASE B1A : CONSTRAINT_ERROR " & + "RAISED FOR NULL RANGE"); + WHEN OTHERS => + FAILED ("CASE B1A : EXCEPTION RAISED"); + + END; + + BEGIN + + PROC1 ((IDENT_INT(6) .. 3 => -2),6,3); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE B1B : EXCEPTION RAISED"); + + END; + + END CASE_B1; + + CASE_B2 : DECLARE + + PROCEDURE PROC1 (A : STRING) IS + BEGIN + IF A'FIRST /= 1 OR + A'LAST /= INTEGER'FIRST THEN + FAILED ("CASE B2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((1 .. INTEGER'FIRST => ' ')); + + EXCEPTION + + WHEN OTHERS => + FAILED ("CASE B2 : EXCEPTION RAISED"); + + END CASE_B2; + + END CASE_B; + + CASE_C : BEGIN + + CASE_C1 : DECLARE + + PROCEDURE PROC1 (A : T2) IS + BEGIN + IF A'FIRST(1) /= 5 OR A'LAST(1) /= 3 OR + A'FIRST(2) /= INTEGER'LAST-1 OR + A'LAST(2) /= INTEGER'LAST THEN + FAILED ("CASE C1 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((5 .. 3 => + (IDENT_INT(INTEGER'LAST-1) .. + IDENT_INT(INTEGER'LAST) => -2))); + FAILED ("CASE C1 : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE C1 : EXCEPTION RAISED"); + + END CASE_C1; + + CASE_C2 : DECLARE + + PROCEDURE PROC1 (A : T2) IS + BEGIN + IF A'FIRST(1) /= INTEGER'FIRST OR + A'LAST(1) /= INTEGER'FIRST+1 OR + A'FIRST(2) /= 14 OR A'LAST(2) /= 11 THEN + FAILED ("CASE C2 : INCORRECT BOUNDS"); + END IF; + END PROC1; + + BEGIN + + PROC1 ((IDENT_INT(INTEGER'FIRST) .. + IDENT_INT(INTEGER'FIRST+1) => + (14 .. IDENT_INT(11) => -2))); + FAILED ("CASE C2 : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE C2 : EXCEPTION RAISED"); + + END CASE_C2; + + END CASE_C; + + END; + + RESULT; + + END C43206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43207b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43207b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43207b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43207b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C43207B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), + -- CHECK THAT: + + -- B) IF H..I IS A NULL RANGE, CONSTRAINT_ERROR IS RAISED IF + -- F..G IS NON-NULL AND F OR G DO NOT BELONG TO THE INDEX + -- SUBTYPE; + + -- EG 01/18/84 + -- BHS 7/13/84 + -- JBG 12/6/84 + + WITH REPORT; + + PROCEDURE C43207B IS + + USE REPORT; + + BEGIN + + TEST("C43207B", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + SUBTYPE SINT IS INTEGER RANGE 1 .. 8; + TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + + CASE_B : DECLARE + PROCEDURE CHECK (A : T0; M : STRING) IS + BEGIN + IF (A'FIRST(1) /= 1) OR (A'LAST(1) /= 9) OR + (A'FIRST(2) /= 6) OR (A'LAST(2) /= 5) THEN + FAILED("CASE B" & M & " : ARRAY NOT " & + "BOUNDED CORRECTLY"); + END IF; + END CHECK; + BEGIN + + CASE_B1 : BEGIN + CHECK ((1 .. 9 => (6 .. 5 => 2)),"1"); + FAILED ("CASE B1 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B1 : EXCEPTION RAISED"); + END CASE_B1; + + CASE_B2 : BEGIN + CHECK ((CALC(F,1) .. CALC(G,9) => (6 .. 5 => 2)), + "2"); + FAILED ("CASE B2 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B2 : EXCEPTION RAISED"); + END CASE_B2; + + CASE_B3 : BEGIN + CHECK ((1 .. 9 => (CALC(H,6) .. CALC(I,5) => 2)), + "3"); + FAILED ("CASE B3 : CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("CASE B3 : EXCEPTION RAISED"); + END CASE_B3; + + END CASE_B; + + IF CNTR(F) /= 1 THEN + FAILED ("CASE B2 : F WAS NOT EVALUATED " & + "ONCE. F WAS EVALUATED" & + INTEGER'IMAGE(CNTR(F)) & " TIMES"); + END IF; + IF CNTR(G) /= 1 THEN + FAILED ("CASE B2 : G WAS NOT EVALUATED " & + "ONCE. G WAS EVALUATED" & + INTEGER'IMAGE(CNTR(G)) & " TIMES"); + END IF; + + IF CNTR(H) /= 0 AND CNTR(I) /= 0 THEN + COMMENT ("CASE B3 : ALL CHOICES " & + "EVALUATED BEFORE CHECKING " & + "INDEX SUBTYPE"); + ELSIF CNTR(H) = 0 AND CNTR(I) = 0 THEN + COMMENT ("CASE B3 : SUBTYPE CHECKS "& + "MADE AS CHOICES ARE EVALUATED"); + END IF; + + IF CNTR(H) > 1 THEN + FAILED("CASE B3 : H WAS NOT EVALUATED " & + "AT MOST ONCE. H WAS EVALUATED" & + INTEGER'IMAGE(CNTR(H)) & " TIMES"); + END IF; + + IF CNTR(I) > 1 THEN + FAILED("CASE B3 : I WAS NOT EVALUATED " & + "AT MOST ONCE. I WAS EVALUATED" & + INTEGER'IMAGE(CNTR(I)) & " TIMES"); + END IF; + + END; + + RESULT; + + END C43207B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43207d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43207d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43207d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43207d.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- C43207D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), + -- CHECK THAT: + + -- D) J IS EVALUATED ONCE FOR EACH COMPONENT (ZERO TIMES IF THE + -- ARRAY IS NULL). + + -- EG 01/18/84 + + WITH REPORT; + + PROCEDURE C43207D IS + + USE REPORT; + + BEGIN + + TEST("C43207D", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + SUBTYPE SINT IS INTEGER RANGE 1 .. 8; + TYPE T0 IS ARRAY(SINT RANGE <>, SINT RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + + CASE_D : BEGIN + + CASE_D1 : DECLARE + D1 : T0(8 .. 4, 5 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D1 := (8 .. 4 => (5 .. 1 => CALC(J,2))); + IF CNTR(J) /= 0 THEN + FAILED("CASE D1 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D1 : EXCEPTION RAISED"); + END CASE_D1; + + CASE_D2 : DECLARE + D2 : T0(8 .. 4, 5 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D2 := (CALC(F,8) .. CALC(G,4) => + (CALC(H,5) .. CALC(I,1) => CALC(J,2))); + IF CNTR(J) /= 0 THEN + FAILED("CASE D2 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D2 : EXCEPTION RAISED"); + END CASE_D2; + + CASE_D3 : DECLARE + D3 : T0(3 .. 5, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D3 := (3 .. 5 => (1 .. 2 => CALC(J,2))); + IF CNTR(J) /= 6 THEN + FAILED("CASE D3 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D3 : EXCEPTION RAISED"); + END CASE_D3; + + CASE_D4 : DECLARE + D4 : T0(1 .. 2, 5 .. 7); + BEGIN + CNTR := (CHOICE_INDEX => 0); + D4 := (CALC(F,1) .. CALC(G,2) => + (CALC(H,5) .. CALC(I,7) => CALC(J,2))); + IF CNTR(J) /= 6 THEN + FAILED("CASE D4 : INCORRECT NUMBER " & + "OF EVALUATIONS. J EVALUATED" & + INTEGER'IMAGE(CNTR(J)) & " TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE D4 : EXCEPTION RAISED"); + END CASE_D4; + + END CASE_D; + + END; + + RESULT; + + END C43207D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43208a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43208a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43208a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43208a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,208 ---- + -- C43208A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A ONE-DIMENSIONAL AGGREGATE OF THE FORM (F..G => (H..I => J)), + -- CHECK THAT: + + -- A) IF F..G IS A NULL RANGE, H, I, AND J ARE NOT EVALUATED. + + -- B) IF F..G IS A NON-NULL RANGE, H AND I ARE EVALUATED G-F+1 + -- TIMES, AND J IS EVALUATED (I-H+1)*(G-F+1) TIMES IF H..I + -- IS NON-NULL. + + -- EG 01/19/84 + + WITH REPORT; + + PROCEDURE C43208A IS + + USE REPORT; + + BEGIN + + TEST("C43208A", "CHECK THAT THE EVALUATION OF A ONE-" & + "DIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => (H..I = J)) IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + TYPE T1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + + CASE_A : BEGIN + + CASE_A1 : DECLARE + A1 : ARRAY(4 .. 2) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A1 := (4 .. 2 => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 0 THEN + FAILED("CASE A1 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A1 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A1 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A1 : EXCEPTION RAISED"); + END CASE_A1; + + CASE_A2 : DECLARE + A2 : ARRAY(4 .. 2) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A2 := (CALC(F,4) .. CALC(G,2) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 0 THEN + FAILED("CASE A2 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A2 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A2 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A2 : EXCEPTION RAISED"); + END CASE_A2; + + END CASE_A; + + CASE_B : BEGIN + + CASE_B1 : DECLARE + B1 : ARRAY(2 .. 3) OF T1(1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B1 := (2 .. 3 => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B1 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B1 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 4 THEN + FAILED("CASE B1 : J NOT EVALUATED (I-H+1)*" & + "(G-F+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B1 : EXECEPTION RAISED"); + END CASE_B1; + + CASE_B2 : DECLARE + B2 : ARRAY(2 .. 3) OF T1(9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B2 := (CALC(F,2) .. CALC(G,3) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B2 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B2 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 4 THEN + FAILED("CASE B2 : J NOT EVALUATED (I-H+1)*" & + "(G-F+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B2 : EXECEPTION RAISED"); + END CASE_B2; + + CASE_B3 : DECLARE + B3 : ARRAY(2 .. 3) OF T1(2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B3 := (2 .. 3 => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B3 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B3 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B3 : EXECEPTION RAISED"); + END CASE_B3; + + CASE_B4 : DECLARE + B4 : ARRAY(2 .. 3) OF T1(2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B4 := (CALC(F,2) .. CALC(G,3) => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))); + IF CNTR(H) /= 2 THEN + FAILED("CASE B4 : H NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(I) /= 2 THEN + FAILED("CASE B4 : I NOT EVALUATED G-F+1 " & + "TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B4 : EXECEPTION RAISED"); + END CASE_B4; + + END CASE_B; + END; + + RESULT; + + END C43208A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43208b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43208b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43208b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43208b.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- C43208B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR AN AGGREGATE OF THE FORM: + -- (B..C => (D..E => (F..G => (H..I => J)))) + -- WHOSE TYPE IS A TWO-DIMENSIONAL ARRAY TYPE THAT HAS A TWO- + -- DIMENSIONAL ARRAY COMPONENT TYPE, CHECK THAT: + + -- A) IF B..C OR D..E IS A NULL RANGE, THEN F, G, H, I, AND J + -- ARE NOT EVALUATED. + + -- B) IF B..C AND D..E ARE NON-NULL RANGES, THEN F, G, H AND I + -- ARE EVALUATED (C-B+1)*(E-D+1) TIMES, AND J IS EVALUATED + -- (C-B+1)*(E-D+1)*(G-F+1)*(I-H+1) TIMES IF F..G AND H..I + -- ARE NON-NULL. + + -- EG 01/19/84 + + WITH REPORT; + + PROCEDURE C43208B IS + + USE REPORT; + + BEGIN + + TEST("C43208B", "CHECK THAT THE EVALUATION OF A MULTI" & + "DIMENSIONAL ARRAY TYPE THAT HAS AN " & + "ARRAY COMPONENT TYPE IS PERFORMED " & + "CORRECTLY"); + + DECLARE + + TYPE CHOICE_INDEX IS (B, C, D, E, F, G, H, I, J); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + TYPE T1 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + + CASE_A : BEGIN + + CASE_A1 : DECLARE + A1 : ARRAY(4 .. 3, 3 .. 4) OF T1(2 .. 3, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A1 := (4 .. 3 => (3 .. 4 => + (CALC(F,2) .. CALC(G,3) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 0 THEN + FAILED("CASE A1 : F WAS EVALUATED"); + END IF; + IF CNTR(G) /= 0 THEN + FAILED("CASE A1 : G WAS EVALUATED"); + END IF; + IF CNTR(H) /= 0 THEN + FAILED("CASE A1 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A1 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A1 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A1 : EXCEPTION RAISED"); + END CASE_A1; + + CASE_A2 : DECLARE + A2 : ARRAY(3 .. 4, 4 .. 3) OF T1(2 .. 3, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + A2 := (CALC(B,3) .. CALC(C,4) => + (CALC(D,4) .. CALC(E,3) => + (CALC(F,2) .. CALC(G,3) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 0 THEN + FAILED("CASE A2 : F WAS EVALUATED"); + END IF; + IF CNTR(G) /= 0 THEN + FAILED("CASE A2 : G WAS EVALUATED"); + END IF; + IF CNTR(H) /= 0 THEN + FAILED("CASE A2 : H WAS EVALUATED"); + END IF; + IF CNTR(I) /= 0 THEN + FAILED("CASE A2 : I WAS EVALUATED"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE A2 : J WAS EVALUATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE A2 : EXCEPTION RAISED"); + END CASE_A2; + + END CASE_A; + + CASE_B : BEGIN + + CASE_B1 : DECLARE + B1 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B1 := (2 .. 3 => (1 .. 2 => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B1 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B1 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B1 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B1 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 16 THEN + FAILED("CASE B1 : J NOT EVALUATED (C-B+1)*" & + "(E-D+1)*(G-F+1)*(I-H+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B1 : EXECEPTION RAISED"); + END CASE_B1; + + CASE_B2 : DECLARE + B2 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 9 .. 10); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B2 := (CALC(B,2) .. CALC(C,3) => + (CALC(D,1) .. CALC(E,2) => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,9) .. CALC(I,10) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B2 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B2 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B2 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B2 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 16 THEN + FAILED("CASE B2 : J NOT EVALUATED (C-B+1)*" & + "(E-D+1)*(G-F+1)*(I-H+1) TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B2 : EXECEPTION RAISED"); + END CASE_B2; + + CASE_B3 : DECLARE + B3 : ARRAY(2 .. 3, 1 .. 2) OF T1(1 .. 2, 2 .. 1); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B3 := (2 .. 3 => (1 .. 2 => + (CALC(F,1) .. CALC(G,2) => + (CALC(H,2) .. CALC(I,1) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B3 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B3 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B3 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B3 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B3 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B3 : EXECEPTION RAISED"); + END CASE_B3; + + CASE_B4 : DECLARE + B4 : ARRAY(2 .. 3, 1 .. 2) OF T1(2 .. 1, 1 .. 2); + BEGIN + CNTR := (CHOICE_INDEX => 0); + B4 := (CALC(B,2) .. CALC(C,3) => + (CALC(D,1) .. CALC(E,2) => + (CALC(F,2) .. CALC(G,1) => + (CALC(H,1) .. CALC(I,2) => CALC(J,2))))); + IF CNTR(F) /= 4 THEN + FAILED("CASE B4 : F NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(G) /= 4 THEN + FAILED("CASE B4 : G NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(H) /= 4 THEN + FAILED("CASE B4 : H NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(I) /= 4 THEN + FAILED("CASE B4 : I NOT EVALUATED (C-B+1)*" & + "(E-D+1) TIMES"); + END IF; + IF CNTR(J) /= 0 THEN + FAILED("CASE B4 : J NOT EVALUATED ZERO TIMES"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("CASE B4 : EXECEPTION RAISED"); + END CASE_B4; + + END CASE_B; + END; + + RESULT; + + END C43208B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43209a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43209a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43209a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43209a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- C43209A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A STRING LITERAL IS ALLOWED IN A MULTIDIMENSIONAL + -- ARRAY AGGREGATE AT THE PLACE OF A ONE DIMENSIONAL ARRAY OF + -- CHARACTER TYPE. + + -- HISTORY: + -- DHH 08/12/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43209A IS + + TYPE MULTI_ARRAY IS ARRAY(1 .. 2, 1 .. 3, 1 .. 6) OF CHARACTER; + + BEGIN + TEST("C43209A", "CHECK THAT A STRING LITERAL IS ALLOWED IN A " & + "MULTIDIMENSIONAL ARRAY AGGREGATE AT THE PLACE " & + "OF A ONE DIMENSIONAL ARRAY OF CHARACTER TYPE"); + + DECLARE + X : MULTI_ARRAY := ((('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L'), + ('M', 'N', 'O', 'P', 'Q', 'R')), + (('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'), + "WHOZAT")); + + Y : MULTI_ARRAY := (("WHOZAT", + ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'))); + + BEGIN + IF X(IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)) /= + Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(6)) THEN + FAILED("INITIALIZATION FAILURE"); + END IF; + END; + + DECLARE + PROCEDURE FIX_AGG(T : MULTI_ARRAY) IS + BEGIN + IF T(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /= + T(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN + FAILED("SUBPROGRAM FAILURE"); + END IF; + END; + BEGIN + FIX_AGG((("WHOZAT", ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D')))); + + END; + + DECLARE + + Y : CONSTANT MULTI_ARRAY := (("WHOZAT", + ('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L')), + (('M', 'N', 'O', 'P', 'Q', 'R'), + ('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'))); + + BEGIN + IF Y(IDENT_INT(2), IDENT_INT(2), IDENT_INT(5)) /= + Y(IDENT_INT(1), IDENT_INT(1), IDENT_INT(1)) THEN + FAILED("CONSTANT FAILURE"); + END IF; + END; + + DECLARE + BEGIN + IF MULTI_ARRAY'((1 =>(('A', 'B', 'C', 'D', 'E', 'F'), + ('G', 'H', 'I', 'J', 'K', 'L'), + ('M', 'N', 'O', 'P', 'Q', 'R')), + 2 => (('S', 'T', 'U', 'V', 'W', 'X'), + ('W', 'Z', 'A', 'B', 'C', 'D'), + "WHOZAT"))) = MULTI_ARRAY'((1 =>(1 =>"WHOZAT", + 2 =>('A', 'B', 'C', 'D', 'E', 'F'), + 3 =>('G', 'H', 'I', 'J', 'K', 'L')), + 2 => (1 =>('M', 'N', 'O', 'P', 'Q', 'R'), + 2 =>('S', 'T', 'U', 'V', 'W', 'X'), + 3 => ('W', 'Z', 'A', 'B', 'C', 'D')))) THEN + FAILED("EQUALITY OPERATOR FAILURE"); + END IF; + END; + + DECLARE + SUBTYPE SM IS INTEGER RANGE 1 .. 10; + TYPE UNCONSTR IS ARRAY(SM RANGE <>, SM RANGE<>) OF CHARACTER; + + FUNCTION FUNC(X : SM) RETURN UNCONSTR IS + BEGIN + IF EQUAL(X,X) THEN + RETURN (1 => "WHEN", 2 => "WHAT"); + ELSE + RETURN (" ", " "); + END IF; + END FUNC; + + BEGIN + IF FUNC(1) /= FUNC(2) THEN + FAILED("UNCONSTRAINED FUNCTION RETURN FAILURE"); + END IF; + END; + + RESULT; + END C43209A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43210a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43210a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43210a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43210a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C43210A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A NON-AGGREGATE EXPRESSION IN A NAMED COMPONENT + -- ASSOCIATION IS EVALUATED ONCE FOR EACH COMPONENT SPECIFIED + -- BY THE ASSOCIATION. + + -- EG 02/02/84 + + WITH REPORT; + + PROCEDURE C43210A IS + + USE REPORT; + + BEGIN + + TEST("C43210A", "CHECK THAT A NON-AGGREGATE IN A NAMED " & + "COMPONENT ASSOCIATION IS EVALUATED ONCE " & + "FOR EACH COMPONENT SPECIFIED BY THE " & + "ASSOCIATION"); + + DECLARE + + TYPE T1 IS ARRAY(1 .. 10) OF INTEGER; + TYPE T2 IS ARRAY(1 .. 8, 1 .. 2) OF INTEGER; + TYPE T3 IS ARRAY(1 .. 2, 1 .. 8) OF INTEGER; + TYPE T4 IS ARRAY(1 .. 8, 1 .. 8) OF INTEGER; + + A1 : T1; + A2 : T2; + A3 : T3; + A4 : T4; + CC : INTEGER; + + FUNCTION CALC (A : INTEGER) RETURN INTEGER IS + BEGIN + CC := CC + 1; + RETURN IDENT_INT(A); + END CALC; + + PROCEDURE CHECK (A : STRING; B : INTEGER) IS + BEGIN + IF CC /= B THEN + FAILED ("CASE " & A & " : INCORRECT NUMBER OF " & + "EVALUATIONS. NUMBER OF EVALUATIONS " & + "SHOULD BE " & INTEGER'IMAGE(B) & + ", BUT IS " & INTEGER'IMAGE(CC)); + END IF; + END CHECK; + + BEGIN + + CASE_A : BEGIN + + CC := 0; + A1 := T1'(4 .. 5 => CALC(2), 6 .. 8 => CALC(4), + OTHERS => 5); + CHECK ("A", 5); + + END CASE_A; + + CASE_B : BEGIN + + CC := 0; + A1 := T1'(1 | 4 .. 6 | 3 | 2 => CALC(-1), OTHERS => -2); + CHECK ("B", 6); + + END CASE_B; + + CASE_C : BEGIN + + CC := 0; + A1 := T1'(1 | 3 | 5 | 7 .. 9 => -1, OTHERS => CALC(-2)); + CHECK ("C", 4); + + END CASE_C; + + CASE_D : BEGIN + + CC := 0; + A2 := T2'(4 .. 6 | 8 | 2 .. 3 => (1 .. 2 => CALC(1)), + OTHERS => (1 .. 2 => -1)); + CHECK ("D", 12); + + END CASE_D; + + CASE_E : BEGIN + + CC := 0; + A3 := T3'(1 .. 2 => (2 | 4 | 6 .. 8 => CALC(-1), + OTHERS => -2)); + CHECK ("E", 10); + + END CASE_E; + + CASE_F : BEGIN + + CC := 0; + A4 := T4'(7 .. 8 | 3 .. 5 => + (1 | 2 | 4 | 6 .. 8 => CALC(1), OTHERS => -2), + OTHERS => (OTHERS => -2)); + CHECK ("F", 30); + + END CASE_F; + + CASE_G : BEGIN + + CC := 0; + A4 := T4'(5 .. 8 | 3 | 1 => (7 | 1 .. 5 | 8 => -1, + OTHERS => CALC(-2)), + OTHERS => (OTHERS => CALC(-2))); + CHECK ("G", 22); + + END CASE_G; + + END; + + RESULT; + + END C43210A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43211a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43211a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43211a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43211a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C43211A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF A BOUND IN A NON-NULL + -- RANGE OF A NON-NULL AGGREGATE DOES NOT BELONG TO THE INDEX SUBTYPE. + + -- EG 02/06/84 + -- EG 05/08/85 + -- EDS 07/15/98 AVOID OPTIMIZATION + + WITH REPORT; + + PROCEDURE C43211A IS + + USE REPORT; + + BEGIN + + TEST("C43211A","CHECK THAT CONSTRAINT_ERROR IS RAISED IF A " & + "BOUND IN A NON-NULL RANGE OF A NON-NULL " & + "AGGREGATE DOES NOT BELONG TO THE INDEX " & + "SUBTYPE"); + + DECLARE + + SUBTYPE ST IS INTEGER RANGE 4 .. 8; + TYPE BASE IS ARRAY(ST RANGE <>, ST RANGE <>) OF INTEGER; + SUBTYPE T IS BASE(5 .. 7, 5 .. 7); + + A : T; + + BEGIN + + CASE_A : BEGIN + + A := (6 .. 8 => (4 .. 6 => 0)); + IF A /= (6 .. 8 => (4 .. 6 => 0)) THEN + FAILED ("CASE A : INCORRECT VALUES"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE A"); + + END CASE_A; + + CASE_B : BEGIN + + A := (6 .. IDENT_INT(8) => + (IDENT_INT(4) .. 6 => 1)); + IF A /= (6 .. IDENT_INT(8) => + (IDENT_INT(4) .. 6 => 1)) THEN + FAILED ("CASE B : INCORRECT VALUES"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE B"); + + END CASE_B; + + CASE_C : BEGIN + + A := (7 .. 9 => (5 .. 7 => IDENT_INT(2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE C " & + INTEGER'IMAGE(A(IDENT_INT(7),7))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE C"); + + END CASE_C; + + CASE_D : BEGIN + + A := (5 .. 7 => (3 .. 5 => IDENT_INT(3))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE D " & + INTEGER'IMAGE(A(7,IDENT_INT(5)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE D"); + + END CASE_D; + + CASE_E : BEGIN + + A := (7 .. IDENT_INT(9) => (5 .. 7 => IDENT_INT(4))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE E " & + INTEGER'IMAGE(A(IDENT_INT(7),7))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE E : EXCEPTION RAISED"); + + END CASE_E; + + CASE_F : BEGIN + + A := (5 .. 7 => (IDENT_INT(3) .. 5 => IDENT_INT(5))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE F " & + INTEGER'IMAGE(A(7,IDENT_INT(5)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE F"); + + END CASE_F; + + CASE_G : BEGIN + + A := (7 .. 8 => (5 .. 7 => IDENT_INT(6)), + 9 => (5 .. 7 => IDENT_INT(6))); + FAILED ("CONSTRAINT_ERROR NOT RAISED: CASE G " & + INTEGER'IMAGE(A(7,IDENT_INT(7)))); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED: CASE G"); + + END CASE_G; + + END; + + RESULT; + + END C43211A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43212a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43212a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43212a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43212a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- C43212A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL SUBAGGREGATES FOR A + -- PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS. + + -- EG 02/06/1984 + -- JBG 3/30/84 + -- JRK 4/18/86 CORRECTED ERROR TO ALLOW CONSTRAINT_ERROR TO BE + -- RAISED EARLIER. + -- EDS 7/15/98 AVOID OPTIMIZATION. + + WITH REPORT; + + PROCEDURE C43212A IS + + USE REPORT; + + BEGIN + + TEST ("C43212A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " & + "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " & + "NOT HAVE THE SAME BOUNDS"); + + DECLARE + + TYPE CHOICE_INDEX IS (H, I); + TYPE CHOICE_CNTR IS ARRAY(CHOICE_INDEX) OF INTEGER; + + CNTR : CHOICE_CNTR := (CHOICE_INDEX => 0); + + FUNCTION CALC (A : CHOICE_INDEX; B : INTEGER) + RETURN INTEGER IS + BEGIN + CNTR(A) := CNTR(A) + 1; + RETURN IDENT_INT(B); + END CALC; + + BEGIN + + CASE_1 : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A1 : T(1 .. 3, 2 .. 5) := (OTHERS => (OTHERS => 0)); + + BEGIN + + CNTR := (CHOICE_INDEX => 0); + A1 := (1 => (CALC(H,2) .. CALC(I,5) => -4), + 2 => (CALC(H,3) .. CALC(I,6) => -5), + 3 => (CALC(H,2) .. CALC(I,5) => -3)); + FAILED ("CASE 1 : CONSTRAINT_ERROR NOT RAISED" & + INTEGER'IMAGE(A1(1,5)) ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF CNTR(H) < 2 AND CNTR(I) < 2 THEN + FAILED ("CASE 1 : BOUNDS OF SUBAGGREGATES " & + "NOT DETERMINED INDEPENDENTLY"); + END IF; + + WHEN OTHERS => + FAILED ("CASE 1 : WRONG EXCEPTION RAISED"); + + END CASE_1; + + CASE_1A : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A1 : T(1 .. 3, 2 .. 3) := (1 .. 3 => (2 .. 3 => 1)); + + BEGIN + + IF (1 .. 2 => (IDENT_INT(3) .. IDENT_INT(4) => 0), + 3 => (1, 2)) = A1 THEN + BEGIN + COMMENT(" IF SHOULD GENERATE CONSTRAINT_ERROR " & + INTEGER'IMAGE(A1(1,2)) ); + EXCEPTION + WHEN OTHERS => + FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED"); + END; + END IF; + FAILED ("CASE 1A : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE 1A : WRONG EXCEPTION RAISED"); + + END CASE_1A; + + CASE_2 : DECLARE + + TYPE T IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + A2 : T(1 .. 3, IDENT_INT(4) .. 2); + + BEGIN + + CNTR := (CHOICE_INDEX => 0); + A2 := (1 => (CALC(H,5) .. CALC(I,3) => -4), + 3 => (CALC(H,4) .. CALC(I,2) => -5), + 2 => (CALC(H,4) .. CALC(I,2) => -3)); + FAILED ("CASE 2 : CONSTRAINT_ERROR NOT RAISED " & + INTEGER'IMAGE(IDENT_INT(A2'FIRST(1)))); + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF CNTR(H) < 2 AND CNTR(I) < 2 THEN + FAILED ("CASE 2 : BOUNDS OF SUBAGGREGATES " & + "NOT DETERMINED INDEPENDENTLY"); + END IF; + + WHEN OTHERS => + FAILED ("CASE 2 : WRONG EXCEPTION RAISED"); + + END CASE_2; + + END; + + RESULT; + + END C43212A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43212c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43212c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43212c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43212c.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C43212C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL SUBAGGREGATES FOR + -- A PARTICULAR DIMENSION DO NOT HAVE THE SAME BOUNDS. + -- ADDITIONAL CASES FOR THE THIRD DIMENSION AND FOR THE NULL ARRAYS. + + -- PK 02/21/84 + -- EG 05/30/84 + + WITH REPORT; + USE REPORT; + + PROCEDURE C43212C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + BEGIN + + TEST("C43212C","CHECK THAT CONSTRAINT_ERROR IS RAISED IF ALL " & + "SUBAGGREGATES FOR A PARTICULAR DIMENSION DO " & + "NOT HAVE THE SAME BOUNDS"); + + DECLARE + TYPE A3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) + OF INTEGER; + BEGIN + IF A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)), + (1 .. IDENT_INT(2) => IDENT_INT(1))), + ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)), + (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)))) + = + A3'(((IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)), + (1 .. IDENT_INT(2) => IDENT_INT(1))), + ((IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)), + (IDENT_INT(2) .. IDENT_INT(3) => IDENT_INT(1)))) + THEN + FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS EQUAL"); + END IF; + FAILED ("A3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("A3 - WRONG EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE B3 IS ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) + OF INTEGER; + + BEGIN + + IF B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)), + (2 .. IDENT_INT(1) => IDENT_INT(1))), + ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)), + (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)))) + = + B3'(((IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1)), + (2 .. IDENT_INT(1) => IDENT_INT(1))), + ((IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)), + (IDENT_INT(3) .. IDENT_INT(1) => IDENT_INT(1)))) + THEN + FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS EQUAL"); + END IF; + FAILED ("B3 - EXCEPTION NOT RAISED, ARRAYS NOT EQUAL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("B3 - WRONG EXCEPTION RAISED"); + + END; + + RESULT; + + END C43212C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214a.ada 2003-10-27 11:28:51.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C43214A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM (F..G => ""), CHECK + -- THAT CONSTRAINT_ERROR IS RAISED IF F..G IS NON-NULL AND + -- F OR G DO NOT BELONG TO THE INDEX SUBTYPE. + + -- EG 02/10/1984 + -- JBG 12/6/84 + -- EDS 07/15/98 AVOID OPTIMIZATION + + WITH REPORT; + + PROCEDURE C43214A IS + + USE REPORT; + + BEGIN + + TEST("C43214A", "FOR A MULTIDIMENSIONAL AGGREGATE OF THE FORM " & + "(F..G => """"), CHECK THAT CONSTRAINT ERROR " & + "IS RAISED IF F..G IS NON-NULL AND NOT IN THE " & + "INDEX SUBTYPE"); + + DECLARE + + SUBTYPE STA IS INTEGER RANGE 4 .. 7; + TYPE TA IS ARRAY(STA RANGE 5 .. 6, + STA RANGE 6 .. IDENT_INT(4)) OF CHARACTER; + + A : TA := (5 .. 6 => ""); + + BEGIN + + CASE_A : BEGIN + + IF (6 .. IDENT_INT(8) => "") = A THEN + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED"); + END IF; + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED - 2"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : WRONG EXCEPTION RAISED"); + + END CASE_A; + + CASE_B : BEGIN + + A := (IDENT_INT(3) .. 4 => ""); + FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED"); + BEGIN + FAILED("ATTEMPT TO USE A " & + CHARACTER'VAL(IDENT_INT(CHARACTER'POS( + A(A'FIRST(1), A'FIRST(2)) ))) ); + EXCEPTION + WHEN OTHERS => + FAILED("CONSTRAINT_ERROR NOT RAISED AT PROPER PLACE"); + END; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : WRONG EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + + END C43214A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C43214B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY + -- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + + -- EG 02/10/84 + + WITH REPORT; + + PROCEDURE C43214B IS + + USE REPORT; + + BEGIN + + TEST("C43214B", "SUBPROGRAM WITH CONSTRAINED ARRAY FORMAL " & + "PARAMETER"); + + BEGIN + + CASE_A : BEGIN + + -- COMMENT ("CASE A1 : SUBPROGRAM WITH CONSTRAINED " & + -- "ONE-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A1 : DECLARE + + SUBTYPE STA1 IS STRING(IDENT_INT(11) .. 15); + + PROCEDURE PROC1 (A : STA1) IS + BEGIN + IF A'FIRST /= 11 THEN + FAILED ("CASE 1 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 15 THEN + FAILED ("CASE 1 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= "ABCDE" THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 ("ABCDE"); + + END CASE_A1; + + -- COMMENT ("CASE A2 : SUBPROGRAM WITH CONSTRAINED " & + -- "TWO-DIMENSIONAL ARRAY FORMAL PARAMETER"); + + CASE_A2 : DECLARE + + TYPE TA IS ARRAY (11 .. 12, 10 .. 11) OF CHARACTER; + + PROCEDURE PROC1 (A : TA) IS + BEGIN + IF A'FIRST(1) /= 11 OR A'FIRST(2) /= 10 THEN + FAILED ("CASE 2 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST(1) /= 12 OR A'LAST(2) /= 11 THEN + FAILED ("CASE 2 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= ("AB", "CD") THEN + FAILED ("CASE 2 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + BEGIN + + PROC1 (("AB", "CD")); + + END CASE_A2; + + END CASE_A; + + END; + + RESULT; + + END C43214B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C43214C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY + -- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + + -- EG 02/10/84 + + WITH REPORT; + + PROCEDURE C43214C IS + + USE REPORT; + + BEGIN + + TEST("C43214C", "CONSTRAINED ARRAY FORMAL GENERIC " & + "PARAMETER"); + + BEGIN + + CASE_B : DECLARE + + SUBTYPE STB IS STRING(5 .. 8); + + GENERIC + B1 : STB; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF B1'FIRST /= 5 THEN + FAILED ("LOWER BOUND INCORRECT"); + ELSIF B1'LAST /= 8 THEN + FAILED ("UPPER BOUND INCORRECT"); + ELSIF B1 /= "ABCD" THEN + FAILED ("ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + END; + + PROCEDURE PROC2 IS NEW PROC1 ("ABCD"); + + BEGIN + + PROC2; + + END CASE_B; + + END; + + RESULT; + + END C43214C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C43214D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY + -- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + + -- EG 02/10/84 + + WITH REPORT; + + PROCEDURE C43214D IS + + USE REPORT; + + BEGIN + + TEST("C43214D", "CONSTRAINED FUNCTION RESULT TYPE"); + + BEGIN + + CASE_C : DECLARE + + TYPE TC IS ARRAY (INTEGER RANGE -1 .. 0, + IDENT_INT(7) .. 9) OF CHARACTER; + + FUNCTION FUN1 (A : INTEGER) RETURN TC IS + BEGIN + RETURN ("ABC", "DEF"); + END; + + BEGIN + + IF FUN1(5)'FIRST(1) /= -1 THEN + FAILED ("LOWER BOUND INCORRECT " & + "FOR 'FIRST(1)"); + ELSIF FUN1(5)'FIRST(2) /= 7 THEN + FAILED ("LOWER BOUND INCORRECT " & + "FOR 'FIRST(2)"); + ELSIF FUN1(5)'LAST(1) /= 0 THEN + FAILED ("UPPER BOUND INCORRECT " & + "FOR 'LAST(1)"); + ELSIF FUN1(5)'LAST(2) /= 9 THEN + FAILED ("UPPER BOUND INCORRECT " & + "FOR 'LAST(2)"); + ELSIF FUN1(5) /= ("ABC", "DEF") THEN + FAILED ("FUNCTION DOES NOT " & + "RETURN THE CORRECT VALUES"); + END IF; + + END CASE_C; + + END; + + RESULT; + + END C43214D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C43214E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY + -- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + + -- EG 02/10/84 + + WITH REPORT; + + PROCEDURE C43214E IS + + USE REPORT; + + BEGIN + + TEST("C43214E", "INITIALIZATION OF CONSTRAINED ARRAY"); + + BEGIN + + CASE_D : BEGIN + + -- COMMENT ("CASE D1 : INITIALIZATION OF CONSTRAINED " & + -- "ARRAY CONSTANT"); + + CASE_D1 : DECLARE + + D1 : CONSTANT STRING(11 .. 13) := "ABC"; + + BEGIN + + IF D1'FIRST /= 11 THEN + FAILED ("CASE 1 : LOWER BOUND INCORRECT"); + ELSIF D1'LAST /= 13 THEN + FAILED ("CASE 1 : UPPER BOUND INCORRECT"); + ELSIF D1 /= "ABC" THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + + END CASE_D1; + + -- COMMENT ("CASE D2 : INITIALIZATION OF CONSTRAINED " & + -- "ARRAY VARIABLE"); + + CASE_D2 : DECLARE + + D2 : STRING(11 .. 13) := "ABC"; + + BEGIN + + IF D2'FIRST /= 11 THEN + FAILED ("CASE 2 : LOWER BOUND INCORRECT"); + ELSIF D2'LAST /= 13 THEN + FAILED ("CASE 2 : UPPER BOUND INCORRECT"); + ELSIF D2 /= "ABC" THEN + FAILED ("CASE 2 : INCORRECT VALUES"); + END IF; + + END CASE_D2; + + -- COMMENT ("CASE D3 : INITIALIZATION OF CONSTRAINED " & + -- "ARRAY FORMAL PARAMETER OF A SUBPROGRAM"); + + CASE_D3 : DECLARE + + SUBTYPE STD3 IS STRING(IDENT_INT(5) .. 7); + + PROCEDURE PROC1 (A : STD3 := "ABC") IS + BEGIN + IF A'FIRST /= 5 THEN + FAILED ("CASE 3 : LOWER BOUND " & + "INCORRECT"); + ELSIF A'LAST /= 7 THEN + FAILED ("CASE 3 : UPPER BOUND " & + "INCORRECT"); + ELSIF A /= "ABC" THEN + FAILED ("CASE 3 : INCORRECT VALUES"); + END IF; + END PROC1; + + BEGIN + + PROC1; + + END CASE_D3; + + -- COMMENT ("CASE D4 : INITIALIZATION OF CONSTRAINED " & + -- "ARRAY FORMAL PARAMETER OF A GENERIC UNIT"); + + CASE_D4 : DECLARE + + SUBTYPE STD4 IS STRING(5 .. 8); + + GENERIC + D4 : STD4 := "ABCD"; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN + IF D4'FIRST /= 5 THEN + FAILED ("CASE 4 : LOWER BOUND " & + "INCORRECT"); + ELSIF D4'LAST /= 8 THEN + FAILED ("CASE 4 : UPPER BOUND " & + "INCORRECT"); + ELSIF D4 /= "ABCD" THEN + FAILED ("CASE 4 : INCORRECT VALUES"); + END IF; + END PROC1; + + PROCEDURE PROC2 IS NEW PROC1; + + BEGIN + + PROC2; + + END CASE_D4; + + END CASE_D; + + END; + + RESULT; + + END C43214E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43214f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43214f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C43214F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOWER BOUND FOR THE STRING LITERAL IS DETERMINED BY + -- THE APPLICABLE INDEX CONSTRAINT, WHEN ONE EXISTS. + + -- EG 02/10/84 + -- JBG 3/30/84 + + WITH REPORT; + + PROCEDURE C43214F IS + + USE REPORT; + + BEGIN + + TEST("C43214F", "ARRAY COMPONENT EXPRESSION OF AN ENCLOSING " & + "AGGREGATE"); + + BEGIN + + CASE_E : BEGIN + + -- COMMENT ("CASE E1 : ARRAY COMPONENT EXPRESSION OF " & + -- "AN ENCLOSING ARRAY AGGREGATE"); + + CASE_E1 : DECLARE + + TYPE TE2 IS ARRAY(1 .. 2) OF + STRING(IDENT_INT(3) .. 5); + + E1 : TE2; + + BEGIN + + E1 := (1 .. 2 => "ABC"); + IF (E1'FIRST /= 1 OR E1'LAST /= 2) OR ELSE + (E1(1)'FIRST /= 3 OR E1(1)'LAST /= 5 OR + E1(2)'FIRST /= 3 OR E1(2)'LAST /= 5) THEN + FAILED ("CASE 1 : INCORRECT BOUNDS"); + ELSIF E1 /= (1 .. 2 => "ABC") THEN + FAILED ("CASE 1 : ARRAY DOES NOT " & + "CONTAIN THE CORRECT VALUES"); + END IF; + + END CASE_E1; + + -- COMMENT ("CASE E2 : ARRAY COMPONENT EXPRESSION OF " & + -- "AN ENCLOSING RECORD AGGREGATE"); + + CASE_E2 : DECLARE + + TYPE TER IS + RECORD + REC : STRING(3 .. 5); + END RECORD; + + E2 : TER; + + BEGIN + + E2 := (REC => "ABC"); + IF E2.REC'FIRST /= 3 OR E2.REC'LAST /= 5 THEN + FAILED ("CASE 2 : INCORRECT BOUNDS"); + ELSIF E2.REC /= "ABC" THEN + FAILED ("CASE 2 : ARRAY DOES NOT " & + "CONTAIN CORRECT VALUES"); + END IF; + + END CASE_E2; + + -- COMMENT ("CASE E3 : NULL LITERAL OF AN ENCLOSING " & + -- "ARRAY AGGREGATE"); + + CASE_E3 : DECLARE + + TYPE TE2 IS ARRAY(1 .. 2) OF + STRING(3 .. IDENT_INT(2)); + + E3 : TE2; + + BEGIN + + E3 := (1 .. 2 => ""); + IF (E3'FIRST /= 1 OR E3'LAST /= 2) OR ELSE + (E3(1)'FIRST /= 3 OR E3(1)'LAST /= 2 OR + E3(2)'FIRST /= 3 OR E3(2)'LAST /= 2) THEN + FAILED ("CASE 3 : INCORRECT BOUND"); + ELSIF E3 /= (1 .. 2 => "") THEN + FAILED ("CASE 3 : ARRAY DOES NOT CONTAIN " & + "THE CORRECT VALUES"); + END IF; + + END CASE_E3; + + -- COMMENT ("CASE E4 : ARRAY COMPONENT EXPRESSION OF " & + -- "AN ENCLOSING RECORD AGGREGATE THAT HAS A " & + -- "DISCRIMINANT AND THE DISCRIMINANT DETER" & + -- "MINES THE BOUNDS OF THE COMPONENT"); + + CASE_E4 : DECLARE + + SUBTYPE TEN IS INTEGER RANGE 1 .. 10; + TYPE TER (A : TEN) IS + RECORD + REC : STRING(3 .. A); + END RECORD; + + E4 : TER(5); + + BEGIN + + E4 := (REC => "ABC", A => 5); + IF E4.REC'FIRST /= 3 OR E4.REC'LAST /= 5 THEN + FAILED ("CASE 4 : INCORRECT BOUNDS"); + ELSIF E4.REC /= "ABC" THEN + FAILED ("CASE 4 : ARRAY DOES NOT CONTAIN " & + "CORRECT VALUES"); + END IF; + + END CASE_E4; + + END CASE_E; + + END; + + RESULT; + + END C43214F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43215a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43215a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43215a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43215a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C43215A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A POSITIONAL + -- ARRAY AGGREGATE WHOSE UPPER BOUND EXCEEDS THE UPPER BOUND + -- OF THE INDEX SUBTYPE BUT BELONGS TO THE INDEX BASE TYPE. + + -- EG 02/13/84 + + WITH REPORT; + WITH SYSTEM; + + PROCEDURE C43215A IS + + USE REPORT; + USE SYSTEM; + + BEGIN + + TEST("C43215A","CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR A POSITIONAL ARRAY AGGREGATE WHOSE " & + "UPPER BOUND EXCEEDS THE UPPER BOUND OF THE " & + "INDEX SUBTYPE BUT BELONGS TO THE INDEX " & + "BASE TYPE"); + + BEGIN + + CASE_A : DECLARE + + LOWER_BOUND : CONSTANT := MAX_INT-3; + UPPER_BOUND : CONSTANT := MAX_INT-1; + + TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND; + + TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER; + + A1 : TA(STA); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TA IS + BEGIN + RETURN (1, 2, 3, 4); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE A : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE A : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + A1 := FUN1; + FAILED ("CASE A : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : EXCEPTION RAISED"); + + END CASE_A; + + CASE_B : DECLARE + + TYPE ENUM IS (A, B, C, D); + + SUBTYPE STB IS ENUM RANGE A .. C; + + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + + B1 : TB(STB); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TB IS + BEGIN + RETURN (1, 2, 3, 4); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE B : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE B : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + B1 := FUN1; + FAILED ("CASE B : CONSTRAINT_ERROR NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + + END C43215A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43215b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43215b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43215b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43215b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C43215B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE UPPER BOUND + -- OF A POSITIONAL AGGREGATE DOES NOT BELONG TO THE INDEX BASE TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- EG 02/13/84 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; + WITH SYSTEM; + + PROCEDURE C43215B IS + + USE REPORT; + USE SYSTEM; + + BEGIN + + TEST("C43215B","CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE UPPER BOUND OF A POSITIONAL ARRAY " & + "AGGREGATE DOES NOT BELONG TO THE INDEX " & + "BASE TYPE"); + + BEGIN + + CASE_A : DECLARE + + LOWER_BOUND : CONSTANT := MAX_INT-3; + UPPER_BOUND : CONSTANT := MAX_INT-1; + + TYPE STA IS RANGE LOWER_BOUND .. UPPER_BOUND; + + TYPE TA IS ARRAY(STA RANGE <>) OF INTEGER; + + A1 : TA(STA); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TA IS + BEGIN + RETURN (1, 2, 3, 4, 5); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE A : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE A : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + A1 := FUN1; + FAILED ("CASE A : CONSTRAINT OR NUMERIC ERROR WAS " & + "NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE A : WRONG EXCEPTION RAISED"); + + END CASE_A; + + CASE_B : DECLARE + + TYPE ENUM IS (A, B, C, D); + + SUBTYPE STB IS ENUM RANGE A .. C; + + TYPE TB IS ARRAY(STB RANGE <>) OF INTEGER; + + B1 : TB(STB); + OK : EXCEPTION; + + FUNCTION FUN1 RETURN TB IS + BEGIN + RETURN (1, 2, 3, 4, 5); + EXCEPTION + WHEN CONSTRAINT_ERROR => + BEGIN + COMMENT ("CASE B : CONSTRAINT_ERROR RAISED"); + RAISE OK; + END; + WHEN OTHERS => + BEGIN + FAILED ("CASE B : EXCEPTION RAISED IN FUN1"); + RAISE OK; + END; + END FUN1; + + BEGIN + + B1 := FUN1; + FAILED ("CASE B : CONSTRAINT ERROR WAS NOT RAISED"); + + EXCEPTION + + WHEN OK => + NULL; + + WHEN OTHERS => + FAILED ("CASE B : WRONG EXCEPTION RAISED"); + + END CASE_B; + + END; + + RESULT; + + END C43215B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43222a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43222a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43222a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43222a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + -- C43222A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ARRAY AGGREGATE NEED NOT BE RESOLVABLE TO A + -- CONSTRAINED SUBTYPE. + + -- HISTORY: + -- DHH 08/12/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43222A IS + + BEGIN + TEST("C43222A", "CHECK THAT AN ARRAY AGGREGATE NEED NOT BE " & + "RESOLVABLE TO A CONSTRAINED SUBTYPE"); + + DECLARE + TYPE A IS ARRAY(INTEGER RANGE <>) OF INTEGER; + B : BOOLEAN := (1, 2, 3) = A'(1, 2, 3); + BEGIN + IF IDENT_BOOL(B) /= IDENT_BOOL(TRUE) THEN + FAILED("INITIALIZATION FAILURE"); + END IF; + END; + + RESULT; + END C43222A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43224a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43224a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c43224a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c43224a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C43224A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A NON-STATIC CHOICE OF AN ARRAY AGGREGATE CAN BE A + -- 'RANGE ATTRIBUTE. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C43224A IS + + M, O : INTEGER := IDENT_INT(2); + N : INTEGER := IDENT_INT(3); + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE D3_ARR IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>, + INTEGER RANGE <>) OF INTEGER; + + SUBTYPE ARR1 IS ARR(IDENT_INT(2) .. IDENT_INT(3)); + SUBTYPE ARR2 IS D3_ARR(1 .. M, 1 .. N, 1 ..O); + + SUB : ARR1; + SUB1 : ARR2; + + PROCEDURE PROC(ARRY : IN OUT ARR) IS + BEGIN + ARRY := (ARR1'RANGE => IDENT_INT(7)); + IF ARRY(IDENT_INT(ARRY'FIRST)) /= IDENT_INT(7) THEN + FAILED("RANGE NOT INITIALIZED - 1"); + END IF; + END PROC; + + PROCEDURE PROC1(ARRY : IN OUT D3_ARR) IS + BEGIN + ARRY := (ARR2'RANGE(1) => (ARRY'RANGE(2) => + (ARRY'RANGE(3) => IDENT_INT(7)))); + + IF ARRY(IDENT_INT(1), IDENT_INT(2), IDENT_INT(1)) /= + IDENT_INT(7) THEN + FAILED("RANGE NOT INITIALIZED - 2"); + END IF; + END PROC1; + + BEGIN + TEST("C43224A", "CHECK THAT A NON-STATIC CHOICE OF AN ARRAY " & + "AGGREGATE CAN BE A 'RANGE ATTRIBUTE"); + + PROC(SUB); + PROC1(SUB1); + + RESULT; + END C43224A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c433001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c433001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c433001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c433001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,302 ---- + -- C433001.A + + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check that an others choice is allowed in an array aggregate whose + -- applicable index constraint is dynamic. (This was an extension to + -- Ada 83). Check that index choices are within the applicable index + -- constraint for array aggregates with others choices. + -- + -- TEST DESCRIPTION + -- In this test, we declare several unconstrained array types, and + -- several dynamic subtypes. We then test a variety of cases of using + -- appropriate aggregates. Some cases expect to raise Constraint_Error. + -- + -- HISTORY: + -- 16 DEC 1999 RLB Initial Version. + + with Report; + procedure C433001 is + + type Color_Type is (Red, Orange, Yellow, Green, Blue, Indigo, Violet); + + type Array_1 is array (Positive range <>) of Integer; + + subtype Sub_1_1 is Array_1 (Report.Ident_Int(1) .. Report.Ident_Int(3)); + subtype Sub_1_2 is Array_1 (Report.Ident_Int(3) .. Report.Ident_Int(5)); + subtype Sub_1_3 is Array_1 (Report.Ident_Int(5) .. Report.Ident_Int(9)); + + type Array_2 is array (Color_Type range <>) of Integer; + + subtype Sub_2_1 is Array_2 (Color_Type'Val(Report.Ident_Int(0)) .. + Color_Type'Val(Report.Ident_Int(2))); + -- Red .. Yellow + subtype Sub_2_2 is Array_2 (Color_Type'Val(Report.Ident_Int(3)) .. + Color_Type'Val(Report.Ident_Int(6))); + -- Green .. Violet + type Array_3 is array (Color_Type range <>, Positive range <>) of Integer; + + subtype Sub_3_1 is Array_3 (Color_Type'Val(Report.Ident_Int(0)) .. + Color_Type'Val(Report.Ident_Int(2)), + Report.Ident_Int(3) .. Report.Ident_Int(5)); + -- Red .. Yellow, 3 .. 5 + subtype Sub_3_2 is Array_3 (Color_Type'Val(Report.Ident_Int(1)) .. + Color_Type'Val(Report.Ident_Int(3)), + Report.Ident_Int(6) .. Report.Ident_Int(8)); + -- Orange .. Green, 6 .. 8 + + procedure Check_1 (Obj : Array_1; Low, High : Integer; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + if Obj'First /= Low then + Report.Failed ("Low bound incorrect (" & Test_Case & ")"); + end if; + if Obj'Last /= High then + Report.Failed ("High bound incorrect (" & Test_Case & ")"); + end if; + if Obj(Low) /= First_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(Low+1) /= Second_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + end Check_1; + + procedure Check_2 (Obj : Array_2; Low, High : Color_Type; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + if Obj'First /= Low then + Report.Failed ("Low bound incorrect (" & Test_Case & ")"); + end if; + if Obj'Last /= High then + Report.Failed ("High bound incorrect (" & Test_Case & ")"); + end if; + if Obj(Low) /= First_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(Color_Type'Succ(Low)) /= Second_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + if Obj(High) /= Last_Component then + Report.Failed ("First Component incorrect (" & Test_Case & ")"); + end if; + end Check_2; + + procedure Check_3 (Test_Obj, Check_Obj : Array_3; + Low_1, High_1 : Color_Type; + Low_2, High_2 : Integer; + Test_Case : Character) is + begin + if Test_Obj'First(1) /= Low_1 then + Report.Failed ("Low bound for dimension 1 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'Last(1) /= High_1 then + Report.Failed ("High bound for dimension 1 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'First(2) /= Low_2 then + Report.Failed ("Low bound for dimension 2 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj'Last(2) /= High_2 then + Report.Failed ("High bound for dimension 2 incorrect (" & + Test_Case & ")"); + end if; + if Test_Obj /= Check_Obj then + Report.Failed ("Components incorrect (" & Test_Case & ")"); + end if; + end Check_3; + + procedure Subtest_Check_1 (Obj : Sub_1_3; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + Check_1 (Obj, 5, 9, First_Component, Second_Component, Last_Component, + Test_Case); + end Subtest_Check_1; + + procedure Subtest_Check_2 (Obj : Sub_2_2; + First_Component, Second_Component, + Last_Component : Integer; + Test_Case : Character) is + begin + Check_2 (Obj, Green, Violet, First_Component, Second_Component, + Last_Component, Test_Case); + end Subtest_Check_2; + + procedure Subtest_Check_3 (Obj : Sub_3_2; + Test_Case : Character) is + begin + Check_3 (Obj, Obj, Orange, Green, 6, 8, Test_Case); + end Subtest_Check_3; + + begin + + Report.Test ("C433001", + "Check that an others choice is allowed in an array " & + "aggregate whose applicable index constraint is dynamic. " & + "Also check index choices are within the applicable index " & + "constraint for array aggregates with others choices"); + + -- Check with a qualified expression: + Check_1 (Sub_1_1'(2, 3, others => 4), Low => 1, High => 3, + First_Component => 2, Second_Component => 3, Last_Component => 4, + Test_Case => 'A'); + + Check_2 (Sub_2_1'(1, others => Report.Ident_Int(6)), + Low => Red, High => Yellow, + First_Component => 1, Second_Component => 6, Last_Component => 6, + Test_Case => 'B'); + + Check_3 (Sub_3_1'((1, others => 3), others => (2, 4, others => 6)), + Check_Obj => ((1, 3, 3), (2, 4, 6), (2, 4, 6)), + Low_1 => Red, High_1 => Yellow, Low_2 => 3, High_2 => 5, + Test_Case => 'C'); + + -- Check that the others clause does not need to represent any components: + Check_1 (Sub_1_2'(5, 6, 8, others => 10), Low => 3, High => 5, + First_Component => 5, Second_Component => 6, Last_Component => 8, + Test_Case => 'D'); + + -- Check named choices are allowed: + Check_1 (Sub_1_1'(2 => Report.Ident_Int(-1), others => 8), + Low => 1, High => 3, + First_Component => 8, Second_Component => -1, Last_Component => 8, + Test_Case => 'E'); + + -- Check named choices and formal parameters: + Subtest_Check_1 ((6 => 4, 8 => 86, others => 1), + First_Component => 1, Second_Component => 4, Last_Component => 1, + Test_Case => 'F'); + + Subtest_Check_2 ((Green => Report.Ident_Int(88), Violet => 89, + Indigo => Report.Ident_Int(42), Blue => 0, others => -1), + First_Component => 88, Second_Component => 0, Last_Component => 89, + Test_Case => 'G'); + + Subtest_Check_3 ((Yellow => (7 => 0, others => 10), others => (1, 2, 3)), + Test_Case => 'H'); + + -- Check object declarations and assignment: + declare + Var : Sub_1_2 := (4, 36, others => 86); + begin + Check_1 (Var, Low => 3, High => 5, + First_Component => 4, Second_Component => 36, + Last_Component => 86, + Test_Case => 'I'); + Var := (5 => 415, others => Report.Ident_Int(1522)); + Check_1 (Var, Low => 3, High => 5, + First_Component => 1522, Second_Component => 1522, + Last_Component => 415, + Test_Case => 'J'); + end; + + -- Check positional aggregates that are too long: + begin + Subtest_Check_2 ((Report.Ident_Int(88), 89, 90, 91, 92, others => 93), + First_Component => 88, Second_Component => 89, + Last_Component => 91, + Test_Case => 'K'); + Report.Failed ("Constraint_Error not raised by positional " & + "aggregate with too many choices (K)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 (((0, others => 10), (2, 3, others => 4), + (5, 6, 8, others => 10), (1, 4, 7), others => (1, 2, 3)), + Test_Case => 'L'); + Report.Failed ("Constraint_Error not raised by positional " & + "aggregate with too many choices (L)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + -- Check named aggregates with choices in the index subtype but not in the + -- applicable index constraint: + + begin + Subtest_Check_1 ((5 => Report.Ident_Int(88), 8 => 89, + 10 => 66, -- 10 not in applicable index constraint + others => 93), + First_Component => 88, Second_Component => 93, + Last_Component => 93, + Test_Case => 'M'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (M)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_2 ( + (Yellow => 23, -- Yellow not in applicable index constraint. + Blue => 16, others => 77), + First_Component => 77, Second_Component => 16, + Last_Component => 77, + Test_Case => 'N'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (N)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 ((Orange => (0, others => 10), + Blue => (2, 3, others => 4), -- Blue not in applicable index cons. + others => (1, 2, 3)), + Test_Case => 'P'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (P)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + begin + Subtest_Check_3 ((Orange => (6 => 0, others => Report.Ident_Int(10)), + Green => (8 => 2, 4 => 3, others => 7), + -- 4 not in applicable index cons. + others => (1, 2, 3, others => Report.Ident_Int(10))), + Test_Case => 'Q'); + Report.Failed ("Constraint_Error not raised by aggregate choice " & + "index outside of applicable index constraint (Q)"); + exception + when Constraint_Error => null; -- Expected exception. + end; + + Report.Result; + + end C433001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- C44003D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK FOR CORRECT PRECEDENCE OF PREDEFINED AND OVERLOADED + -- OPERATIONS ON PREDEFINED TYPE FLOAT, USER-DEFINED TYPES, AND + -- ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT. + + -- HISTORY: + -- RJW 10/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C44003D IS + + BEGIN + TEST ("C44003D", "CHECK FOR CORRECT PRECEDENCE OF PREDEFINED " & + "AND OVERLOADED OPERATIONS ON PREDEFINED TYPE " & + "FLOAT, USER-DEFINED TYPES, AND ONE-DIMEN" & + "SIONAL ARRAYS WITH COMPONENTS OF TYPE FLOAT"); + + ----- PREDEFINED FLOAT: + + DECLARE + F1 : FLOAT := 1.0; + F2 : FLOAT := 2.0; + F5 : FLOAT := 5.0; + + FUNCTION "OR" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 4.5; + END "OR"; + + FUNCTION "<" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 5.5; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 6.5; + END "-"; + + FUNCTION "+" (RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 7.5; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 8.5; + END "*"; + + FUNCTION "NOT" (RIGHT : FLOAT) RETURN FLOAT IS + BEGIN + RETURN 9.5; + END "NOT"; + + BEGIN + IF NOT (-ABS F1 + F2 / F1 + F5 ** 2 = 26.0 AND + F1 > 0.0 AND + - F2 * F2 ** 3 = -8.5) THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + IF (F1 OR NOT F2 < F1 - F5 * F5 ** 3) /= 4.5 THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + END; + + ----- USER-DEFINED TYPE: + + DECLARE + TYPE USR IS DIGITS 5; + + F1 : USR := 1.0; + F2 : USR := 2.0; + F5 : USR := 5.0; + + FUNCTION "AND" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 4.5; + END "AND"; + + FUNCTION ">=" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 5.5; + END ">="; + + FUNCTION "+" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 6.5; + END "+"; + + FUNCTION "-" (RIGHT : USR) RETURN USR IS + BEGIN + RETURN 7.5; + END "-"; + + FUNCTION "/" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 8.5; + END "/"; + + FUNCTION "**" (LEFT, RIGHT : USR) RETURN USR IS + BEGIN + RETURN 9.5; + END "**"; + BEGIN + IF +F5 - F2 * F1 ** 2 /= 3.0 OR + ABS F1 <= 0.0 OR + - F2 * F2 ** 3.0 /= 7.5 THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + + IF (F1 AND F2 >= F1 + F5 / F5 ** 3) /= 4.5 THEN + FAILED ("INCORRECT RESULT - 4"); + END IF; + END; + + ----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF FLOAT; + + SUBTYPE SARR IS ARR (1 .. 3); + + F1 : SARR := (OTHERS => 1.0); + F2 : SARR := (OTHERS => 2.0); + F5 : SARR := (OTHERS => 5.0); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 4.5); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 5.5); + END "<="; + + FUNCTION "&" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 6.5); + END "&"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 8.5); + END "MOD"; + + FUNCTION "ABS" (RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => 9.5); + END "ABS"; + BEGIN + IF (ABS F1 <= F2 & F5 MOD F1 XOR F1) /= (1 .. 3 => 4.5) THEN + FAILED ("INCORRECT RESULT - 5"); + END IF; + + IF (ABS F1 & F2) /= (1 .. 3 => 6.5) OR + (F1 MOD F2 <= F5) /= (1 .. 3 => 5.5) THEN + FAILED ("INCORRECT RESULT - 6"); + END IF; + END; + + RESULT; + END C44003D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- C44003F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED + -- OPERATIONS ON ENUMERATION TYPES OTHER THAN BOOLEAN OR CHARACTER + -- AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF SUCH TYPES. + + -- HISTORY: + -- RJW 10/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C44003F IS + + TYPE ENUM IS (ZERO, ONE, TWO, THREE, FOUR, FIVE); + + BEGIN + TEST ("C44003F", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " & + "AND OVERLOADED OPERATIONS ON ENUMERATION " & + "TYPES OTHER THAN BOOLEAN OR CHARACTER AND " & + "ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " & + "SUCH TYPES"); + + + ----- ENUMERATION TYPE: + + DECLARE + E1 : ENUM := ONE; + E2 : ENUM := TWO; + E5 : ENUM := FIVE; + + FUNCTION "AND" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ZERO; + END "AND"; + + FUNCTION "<" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN THREE; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) - ENUM'POS (RIGHT)); + END "-"; + + FUNCTION "+" (RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN RIGHT; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) * ENUM'POS (RIGHT)); + END "*"; + + FUNCTION "**" (LEFT, RIGHT : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (ENUM'POS (LEFT) ** ENUM'POS (RIGHT)); + END "**"; + + BEGIN + IF NOT (+E1 < E2) OR NOT (E2 >= +E2) OR NOT (E5 = +FIVE) THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + IF (E5 ** E1 AND E2) /= (E5 - E1 * E5 ** E1) THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + + END; + + ----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF ENUM; + + SUBTYPE SARR IS ARR (1 .. 3); + + E1 : SARR := (OTHERS => ONE); + E2 : SARR := (OTHERS => TWO); + E5 : SARR := (OTHERS => FIVE); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => ZERO); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => THREE); + END "<="; + + FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => ZERO); + END "+"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => THREE); + END "MOD"; + + FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FOUR); + END "**"; + BEGIN + IF (E5 ** E1 <= E2 + E5 MOD E1 XOR E1) /= (1 .. 3 => ZERO) + THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + + IF (E5 ** E1 & E2) /= (FOUR, FOUR, FOUR, TWO, TWO, TWO) OR + (E1 MOD E2 <= E5) /= (1 .. 3 => THREE) THEN + FAILED ("INCORRECT RESULT - 4"); + END IF; + END; + + RESULT; + + END C44003F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c44003g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c44003g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C44003G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED AND OVERLOADED + -- OPERATIONS ON BOOLEAN TYPES AND ONE-DIMENSIONAL ARRAYS WITH + -- COMPONENTS OF TYPE BOOLEAN. + + -- HISTORY: + -- RJW 10/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C44003G IS + + BEGIN + TEST ("C44003G", "CHECK FOR CORRECT PRECEDENCE OF PRE-DEFINED " & + "AND OVERLOADED OPERATIONS ON BOOLEAN TYPES " & + "AND ONE-DIMENSIONAL ARRAYS WITH COMPONENTS OF " & + "TYPE BOOLEAN"); + + ----- PREDEFINED BOOLEAN: + + DECLARE + T : BOOLEAN := TRUE; + F : BOOLEAN := FALSE; + + FUNCTION "AND" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "AND"; + + FUNCTION "<" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "<"; + + FUNCTION "-" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "-"; + + FUNCTION "+" (RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT RIGHT; + END "+"; + + FUNCTION "*" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "*"; + + FUNCTION "**" (LEFT, RIGHT : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "**"; + + BEGIN + IF NOT (+T = F) OR T /= +F OR (TRUE AND FALSE ** TRUE) OR + NOT (+T < F) OR NOT (T - F * T) OR (NOT T - F XOR + F - F) + THEN + FAILED ("INCORRECT RESULT - 1"); + END IF; + + END; + + ----- ARRAYS: + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE SARR IS ARR (1 .. 3); + + T : SARR := (OTHERS => TRUE); + F : SARR := (OTHERS => FALSE); + + FUNCTION "XOR" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "XOR"; + + FUNCTION "<=" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => TRUE); + END "<="; + + FUNCTION "+" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "+"; + + FUNCTION "MOD" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => TRUE); + END "MOD"; + + FUNCTION "**" (LEFT, RIGHT : ARR) RETURN ARR IS + BEGIN + RETURN (1 .. 3 => FALSE); + END "**"; + BEGIN + IF (F ** T <= F + T MOD T XOR T) /= (1 .. 3 => FALSE) + THEN + FAILED ("INCORRECT RESULT - 2"); + END IF; + + IF F ** T & T /= NOT T & T OR + (T MOD F <= T) /= (1 .. 3 => TRUE) THEN + FAILED ("INCORRECT RESULT - 3"); + END IF; + END; + + RESULT; + END C44003G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c450001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c450001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c450001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c450001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,434 ---- + -- C450001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that operations on modular types perform correctly. + -- + -- Check that loops over the range of a modular type do not over or + -- under run the loop. + -- + -- TEST DESCRIPTION: + -- Check logical and arithmetic operations. + -- (Attributes are tested elsewhere) + -- Checks to make sure that: + -- for X in Mod_Type loop + -- doesn't do something silly like infinite loop. + -- + -- + -- CHANGE HISTORY: + -- 20 SEP 95 SAIC Initial version + -- 20 FEB 96 SAIC Added underrun cases for 2.1 + -- + --! + + ----------------------------------------------------------------- C450001_0 + + package C450001_0 is + + type Unsigned_8_Bit is mod 2**8; + + Shy_By_One : constant := 2**8-1; + + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + + type Unsigned_Over_8 is mod Heavy_By_Two; + + procedure Loop_Check; + + -- embed some calls to Report.Ident_Int: + + function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit; + function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8; + function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8; + + end C450001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C450001_0 is + + procedure Loop_Check is + Counter_Check : Natural := 0; + begin + for Ever in Unsigned_8_Bit loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > 2**8 then + Report.Failed("Unsigned_8_Bit loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < 2**8 then + Report.Failed("Unsigned_8_Bit loop underrun"); + end if; + + Counter_Check := 0; + + for Never in Unsigned_Edge_8 loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > Shy_By_One then + Report.Failed("Unsigned_Edge_8 loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < Shy_By_One then + Report.Failed("Unsigned_Edge_8 loop underrun"); + end if; + + Counter_Check := 0; + + for Getful in reverse Unsigned_Over_8 loop + Counter_Check := Report.Ident_Int(Counter_Check) + 1; + if Counter_Check > Heavy_By_Two then + Report.Failed("Unsigned_Over_8 loop overrun"); + exit; + end if; + end loop; + + if Counter_Check < Heavy_By_Two then + Report.Failed("Unsigned_Over_8 loop underrun"); + end if; + + end Loop_Check; + + function ID( U8B: Unsigned_8_Bit ) return Unsigned_8_Bit is + begin + return Unsigned_8_Bit(Report.Ident_Int(Integer(U8B))); + end ID; + + function ID( UEB: Unsigned_Edge_8 ) return Unsigned_Edge_8 is + begin + return Unsigned_Edge_8(Report.Ident_Int(Integer(UEB))); + end ID; + + function ID( UOB: Unsigned_Over_8 ) return Unsigned_Over_8 is + begin + return Unsigned_Over_8(Report.Ident_Int(Integer(UOB))); + end ID; + + end C450001_0; + + ------------------------------------------------------------------- C450001 + + with Report; + with C450001_0; + with TCTouch; + procedure C450001 is + use C450001_0; + + BR : constant String := " produced the wrong result"; + + procedure Is_T(B:Boolean;S:String) renames TCTouch.Assert; + procedure Is_F(B:Boolean;S:String) renames TCTouch.Assert_Not; + + Whole_8_A, Whole_8_B, Whole_8_C : C450001_0.Unsigned_8_Bit; + + Short_8_A, Short_8_B, Short_8_C : C450001_0.Unsigned_Edge_8; + + Over_8_A, Over_8_B, Over_8_C : C450001_0.Unsigned_Over_8; + + begin -- Main test procedure. C450001 + + Report.Test ("C450001", "Check that operations on modular types " & + "perform correctly." ); + + + -- the cases for the whole 8 bit type are pretty simple + + Whole_8_A := 2#00000000#; + Whole_8_B := 2#11111111#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00000000#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11111111#,"8 bit xor" & BR); + + Whole_8_A := 2#00001111#; + Whole_8_B := 2#11111111#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#00001111#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111111#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#11110000#,"8 bit xor" & BR); + + Whole_8_A := 2#10101010#; + Whole_8_B := 2#11110000#; + + Is_T((ID(Whole_8_A) and ID(Whole_8_B)) = 2#10100000#,"8 bit and" & BR); + Is_T((ID(Whole_8_A) or ID(Whole_8_B)) = 2#11111010#,"8 bit or" & BR); + Is_T((ID(Whole_8_A) xor ID(Whole_8_B)) = 2#01011010#,"8 bit xor" & BR); + + -- the cases for the partial 8 bit type involve subtracting the modulus + -- from results that exceed the modulus. + -- hence, any of the following operations that exceed 2#11111110# must + -- have 2#11111111# subtracted from the result; i.e. where you would + -- expect to see 2#11111111# as in the above operations, the correct + -- result will be 2#00000000#. Note that 2#11111111# is not a legal + -- value of type C450001_0.Unsigned_Edge_8. + + Short_8_A := 2#11100101#; + Short_8_B := 2#00011111#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000101#,"8 short and 1" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 1" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#11111010#,"8 short xor 1" & BR); + + Short_8_A := 2#11110000#; + Short_8_B := 2#11111110#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#11110000#,"8 short and 2" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 2" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00001110#,"8 short xor 2" & BR); + + Short_8_A := 2#10101010#; + Short_8_B := 2#01010101#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#00000000#,"8 short and 3" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#00000000#,"8 short or 3" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#00000000#,"8 short xor 3" & BR); + + Short_8_A := 2#10101010#; + Short_8_B := 2#11111110#; + + Is_T((ID(Short_8_A) and ID(Short_8_B)) = 2#10101010#,"8 short and 4" & BR); + Is_T((ID(Short_8_A) or ID(Short_8_B)) = 2#11111110#,"8 short or 4" & BR); + Is_T((ID(Short_8_A) xor ID(Short_8_B)) = 2#01010100#,"8 short xor 4" & BR); + + -- the cases for the over 8 bit type have similar issues to the short type + -- however the bit patterns are a little different. The rule is to subtract + -- the modulus (258) from any resulting value equal or greater than the + -- modulus -- note that 258 = 2#100000010# + + Over_8_A := 2#100000000#; + Over_8_B := 2#011111111#; + + Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000000#,"8 over and" & BR); + Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); + Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111101#,"8 over xor" & BR); + + Over_8_A := 2#100000001#; + Over_8_B := 2#011111111#; + + Is_T((ID(Over_8_A) and ID(Over_8_B)) = 2#000000001#,"8 over and" & BR); + Is_T((ID(Over_8_A) or ID(Over_8_B)) = 2#011111101#,"8 over or" & BR); + Is_T((ID(Over_8_A) xor ID(Over_8_B)) = 2#011111100#,"8 over xor" & BR); + + + + Whole_8_A := 128; + Whole_8_B := 255; + + Is_T(ID(Whole_8_A) /= ID(Whole_8_B), "8 /=" & BR); + Is_F(ID(Whole_8_A) = ID(Whole_8_B), "8 =" & BR); + + Is_T(ID(Whole_8_A) <= ID(Whole_8_B), "8 <=" & BR); + Is_T(ID(Whole_8_A) < ID(Whole_8_B), "8 < " & BR); + + Is_F(ID(Whole_8_A) >= ID(Whole_8_B), "8 >=" & BR); + Is_T(ID(Whole_8_A) > ID(Whole_8_B + 7), "8 > " & BR); + + Is_T(ID(Whole_8_A) in ID(100)..ID(200), "8 in" & BR); + Is_F(ID(Whole_8_A) not in ID(100)..ID(200), "8 not in" & BR); + + Is_F(ID(Whole_8_A) in ID(200)..ID(250), "8 in" & BR); + Is_T(ID(Whole_8_A) not in ID(200)..ID(250), "8 not in" & BR); + + Short_8_A := 127; + Short_8_B := 254; + + Is_T(ID(Short_8_A) /= ID(Short_8_B), "short 8 /=" & BR); + Is_F(ID(Short_8_A) = ID(Short_8_B), "short 8 =" & BR); + + Is_T(ID(Short_8_A) <= ID(Short_8_B), "short 8 <=" & BR); + Is_T(ID(Short_8_A) < ID(Short_8_B), "short 8 < " & BR); + + Is_F(ID(Short_8_A) >= ID(Short_8_B), "short 8 >=" & BR); + Is_F(ID(Short_8_A) > ID(Short_8_B), "short 8 > " & BR); + + Is_T(ID(Short_8_A) in ID(100)..ID(200), "8 in" & BR); + Is_F(ID(Short_8_A) not in ID(100)..ID(200), "8 not in" & BR); + + Is_F(ID(Short_8_A) in ID(200)..ID(250), "8 in" & BR); + Is_T(ID(Short_8_A) not in ID(200)..ID(250), "8 not in" & BR); + + + Whole_8_A := 1; + Whole_8_B := 254; + Short_8_A := 1; + Short_8_B := 2; + + Whole_8_C := ID(Whole_8_A) + ID(Whole_8_B); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 1" & BR); + + Whole_8_C := Whole_8_C + ID(Whole_8_A); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'First, "8 binary + 2" & BR); + + Whole_8_C := ID(Whole_8_A) - ID(Whole_8_A); + Is_T(Whole_8_C = 0, "8 binary -" & BR); + + Whole_8_C := Whole_8_C - ID(Whole_8_A); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 binary + 3" & BR); + + Short_8_C := ID(Short_8_A) + ID(C450001_0.Unsigned_Edge_8'Last); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'First, "Short binary + 1" & BR); + + Short_8_C := Short_8_A + ID(Short_8_A); + Is_T(Short_8_C = ID(Short_8_B), "Short binary + 2" & BR); + + Short_8_C := ID(Short_8_A) - ID(Short_8_A); + Is_T(Short_8_C = 0, "Short 8 binary -" & BR); + + Short_8_C := Short_8_C - ID(Short_8_A); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short binary + 3" & BR); + + + Whole_8_C := ( + ID(Whole_8_B) ); + Is_T(Whole_8_C = 254, "8 unary +" & BR); + + Whole_8_C := ( - ID(Whole_8_A) ); + Is_T(Whole_8_C = C450001_0.Unsigned_8_Bit'Last, "8 unary -" & BR); + + Whole_8_C := ( - ID(0) ); + Is_T(Whole_8_C = 0, "8 unary -0" & BR); + + Short_8_C := ( + ID(C450001_0.Unsigned_Edge_8'Last) ); + Is_T(Short_8_C = 254, "Short 8 unary +" & BR); + + Short_8_C := ( - ID(Short_8_A) ); + Is_T(Short_8_C = C450001_0.Unsigned_Edge_8'Last, "Short 8 unary -" & BR); + + + Whole_8_A := 20; + Whole_8_B := 255; + + Whole_8_C := ID(Whole_8_A) * ID(Whole_8_B); -- 5100 = 19*256 + 236 (256-20) + Is_T(Whole_8_C = 236, "8 *" & BR); + + Short_8_A := 9; + Short_8_B := 254; + + Short_8_C := ID(Short_8_A) * ID(Short_8_B); -- 2286 = 8*255 + 246 (255-9) + Is_T(Short_8_C = 246, "short 8 *" & BR); + + Over_8_A := 12; + Over_8_B := 86; + + Over_8_C := ID(Over_8_A) * ID(Over_8_B); -- 1032 = 4*258 + 0 + Is_T(Over_8_C = 0, "over 8 *" & BR); + + + Whole_8_A := 255; + Whole_8_B := 4; + + Whole_8_C := ID(Whole_8_A) / ID(Whole_8_B); + Is_T(Whole_8_C = 63, "8 /" & BR); + + Short_8_A := 253; + Short_8_B := 127; + + Short_8_C := ID(Short_8_A) / ID(Short_8_B); + Is_T(Short_8_C = 1, "short 8 / 1" & BR); + + Short_8_C := ID(Short_8_A) / ID(126); + Is_T(Short_8_C = 2, "short 8 / 2" & BR); + + + Whole_8_A := 255; + Whole_8_B := 254; + + Whole_8_C := ID(Whole_8_A) rem ID(Whole_8_B); + Is_T(Whole_8_C = 1, "8 rem" & BR); + + Short_8_A := 222; + Short_8_B := 111; + + Short_8_C := ID(Short_8_A) rem ID(Short_8_B); + Is_T(Short_8_C = 0, "short 8 rem" & BR); + + + Whole_8_A := 99; + Whole_8_B := 9; + + Whole_8_C := ID(Whole_8_A) mod ID(Whole_8_B); + Is_T(Whole_8_C = 0, "8 mod" & BR); + + Short_8_A := 254; + Short_8_B := 250; + + Short_8_C := ID(Short_8_A) mod ID(Short_8_B); + Is_T(Short_8_C = 4, "short 8 mod" & BR); + + + Whole_8_A := 99; + + Whole_8_C := abs Whole_8_A; + Is_T(Whole_8_C = ID(99), "8 abs" & BR); + + Short_8_A := 254; + + Short_8_C := ID( abs Short_8_A ); + Is_T(Short_8_C = 254, "short 8 abs" & BR); + + + Whole_8_B := 2#00001111#; + + Whole_8_C := not Whole_8_B; + Is_T(Whole_8_C = ID(2#11110000#), "8 not" & BR); + + Short_8_B := 2#00001111#; -- 15 + + Short_8_C := ID( not Short_8_B ); -- 254 - 15 + Is_T(Short_8_C = 2#11101111#, "short 8 not" & BR); -- 239 + + + Whole_8_A := 2; + + Whole_8_C := Whole_8_A ** 7; + Is_T(Whole_8_C = ID(128), "2 ** 7, whole 8" & BR); + + Whole_8_C := Whole_8_A ** 9; + Is_T(Whole_8_C = ID(0), "2 ** 9, whole 8" & BR); + + Short_8_A := 4; + + Short_8_C := ID( Short_8_A ) ** 4; + Is_T(Short_8_C = 1, "4 ** 4, short" & BR); + + Over_8_A := 4; + + Over_8_C := ID( Over_8_A ) ** 4; + Is_T(Over_8_C = 256, "4 ** 4, over" & BR); + + Over_8_C := ID( Over_8_A ) ** 5; -- 1024 = 3*258 + 250 + Is_T(Over_8_C = 250, "4 ** 5, over" & BR); + + + C450001_0.Loop_Check; + + Report.Result; + + end C450001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45112a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45112a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45112a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45112a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,233 ---- + -- C45112A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION + -- ARE THE BOUNDS OF THE LEFT OPERAND. + + -- RJW 2/3/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45112A IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN; + A1 : ARR(IDENT_INT(3) .. IDENT_INT(4)) := (TRUE, FALSE); + A2 : ARR(IDENT_INT(1) .. IDENT_INT(2)) := (TRUE, FALSE); + SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST)); + + PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS + BEGIN + IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN + FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 ); + END IF; + END CHECK; + + BEGIN + + TEST ( "C45112A", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " & + "ARRAY OPERATIONS" ); + + BEGIN + DECLARE + AAND : CONSTANT ARR := A1 AND A2; + AOR : CONSTANT ARR := A1 OR A2; + AXOR : CONSTANT ARR := A1 XOR A2; + BEGIN + CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ", + "'AND'" ); + + CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'OR'" ); + + CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'XOR'" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED DURING " & + "INTIALIZATIONS" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED DURING " & + "INITIALIZATIONS" ); + END; + + DECLARE + PROCEDURE PROC (A : ARR; STR : STRING) IS + BEGIN + CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY", + STR); + END PROC; + BEGIN + PROC ((A1 AND A2), "'AND'" ); + PROC ((A1 OR A2), "'OR'" ); + PROC ((A1 XOR A2), "'XOR'" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " & + "PARAMETERS" ); + END; + + DECLARE + FUNCTION FUNCAND RETURN ARR IS + BEGIN + RETURN A1 AND A2; + END FUNCAND; + + FUNCTION FUNCOR RETURN ARR IS + BEGIN + RETURN A1 OR A2; + END FUNCOR; + + FUNCTION FUNCXOR RETURN ARR IS + BEGIN + RETURN A1 XOR A2; + END FUNCXOR; + + BEGIN + CHECK (FUNCAND, "RETURN STATEMENT", "'AND'"); + CHECK (FUNCOR, "RETURN STATEMENT", "'OR'"); + CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'"); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " & + "FROM FUNCTION" ); + END; + + BEGIN + DECLARE + GENERIC + X : IN ARR; + PACKAGE PKG IS + FUNCTION G RETURN ARR; + END PKG; + + PACKAGE BODY PKG IS + FUNCTION G RETURN ARR IS + BEGIN + RETURN X; + END G; + END PKG; + + PACKAGE PAND IS NEW PKG(X => A1 AND A2); + PACKAGE POR IS NEW PKG(X => A1 OR A2); + PACKAGE PXOR IS NEW PKG(X => A1 XOR A2); + BEGIN + CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'"); + CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'"); + CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING GENERIC " & + "INSTANTIATION" ); + END; + + DECLARE + TYPE ACC IS ACCESS ARR; + AC : ACC; + + BEGIN + AC := NEW ARR'(A1 AND A2); + CHECK (AC.ALL, "ALLOCATION", "'AND'"); + AC := NEW ARR'(A1 OR A2); + CHECK (AC.ALL, "ALLOCATION", "'OR'"); + AC := NEW ARR'(A1 XOR A2); + CHECK (AC.ALL, "ALLOCATION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON ALLOCATION" ); + END; + + BEGIN + CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'"); + CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'"); + CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" ); + END; + + DECLARE + TYPE REC IS + RECORD + RCA : CARR; + END RECORD; + R1 : REC; + + BEGIN + R1 := (RCA => (A1 AND A2)); + CHECK (R1.RCA, "AGGREGATE", "'AND'"); + R1 := (RCA => (A1 OR A2)); + CHECK (R1.RCA, "AGGREGATE", "'OR'"); + R1 := (RCA => (A1 XOR A2)); + CHECK (R1.RCA, "AGGREGATE", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON AGGREGATE" ); + END; + + BEGIN + DECLARE + TYPE RECDEF IS + RECORD + RCDF1 : CARR := A1 AND A2; + RCDF2 : CARR := A1 OR A2; + RCDF3 : CARR := A1 XOR A2; + END RECORD; + RD : RECDEF; + BEGIN + CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'"); + CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'"); + CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " & + "DEFAULT RECORD" ); + END; + + DECLARE + PROCEDURE PDEF (X : CARR := A1 AND A2; + Y : CARR := A1 OR A2; + Z : CARR := A1 XOR A2 ) IS + BEGIN + CHECK (X, "DEFAULT PARAMETER", "'AND'"); + CHECK (Y, "DEFAULT PARAMETER", "'OR'"); + CHECK (Z, "DEFAULT PARAMETER", "'XOR'"); + END PDEF; + + BEGIN + PDEF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" ); + END; + + RESULT; + + END C45112A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45112b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45112b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45112b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45112b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C45112B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE BOUNDS OF THE RESULT OF A LOGICAL ARRAY OPERATION + -- ARE THE BOUNDS OF THE LEFT OPERAND WHEN THE OPERANDS ARE NULL + -- ARRAYS. + + -- RJW 2/3/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45112B IS + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF BOOLEAN; + A1 : ARR(IDENT_INT(4) .. IDENT_INT(3)); + A2 : ARR(IDENT_INT(2) .. IDENT_INT(1)); + SUBTYPE CARR IS ARR (IDENT_INT (A1'FIRST) .. IDENT_INT (A1'LAST)); + + PROCEDURE CHECK (X : ARR; N1, N2 : STRING) IS + BEGIN + IF X'FIRST /= A1'FIRST OR X'LAST /= A1'LAST THEN + FAILED ( "WRONG BOUNDS FOR " & N1 & " FOR " & N2 ); + END IF; + END CHECK; + + BEGIN + + TEST ( "C45112B", "CHECK THE BOUNDS OF THE RESULT OF LOGICAL " & + "ARRAY OPERATIONS ON NULL ARRAYS" ); + + BEGIN + DECLARE + AAND : CONSTANT ARR := A1 AND A2; + AOR : CONSTANT ARR := A1 OR A2; + AXOR : CONSTANT ARR := A1 XOR A2; + BEGIN + CHECK (AAND, "INITIALIZATION OF CONSTANT ARRAY ", + "'AND'" ); + + CHECK (AOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'OR'" ); + + CHECK (AXOR, "INITIALIZATION OF CONSTANT ARRAY ", + "'XOR'" ); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED DURING " & + "INTIALIZATIONS" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED DURING " & + "INITIALIZATIONS" ); + END; + + DECLARE + PROCEDURE PROC (A : ARR; STR : STRING) IS + BEGIN + CHECK (A, "FORMAL PARAMETER FOR CONSTRAINED ARRAY", + STR); + END PROC; + BEGIN + PROC ((A1 AND A2), "'AND'" ); + PROC ((A1 OR A2), "'OR'" ); + PROC ((A1 XOR A2), "'XOR'" ); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR FORMAL " & + "PARAMETERS" ); + END; + + DECLARE + FUNCTION FUNCAND RETURN ARR IS + BEGIN + RETURN A1 AND A2; + END FUNCAND; + + FUNCTION FUNCOR RETURN ARR IS + BEGIN + RETURN A1 OR A2; + END FUNCOR; + + FUNCTION FUNCXOR RETURN ARR IS + BEGIN + RETURN A1 XOR A2; + END FUNCXOR; + + BEGIN + CHECK (FUNCAND, "RETURN STATEMENT", "'AND'"); + CHECK (FUNCOR, "RETURN STATEMENT", "'OR'"); + CHECK (FUNCXOR, "RETURN STATEMENT", "'XOR'"); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING TEST FOR RETURN " & + "FROM FUNCTION" ); + END; + + BEGIN + DECLARE + GENERIC + X : IN ARR; + PACKAGE PKG IS + FUNCTION G RETURN ARR; + END PKG; + + PACKAGE BODY PKG IS + FUNCTION G RETURN ARR IS + BEGIN + RETURN X; + END G; + END PKG; + + PACKAGE PAND IS NEW PKG(X => A1 AND A2); + PACKAGE POR IS NEW PKG(X => A1 OR A2); + PACKAGE PXOR IS NEW PKG(X => A1 XOR A2); + BEGIN + CHECK (PAND.G, "GENERIC FORMAL PARAMETER", "'AND'"); + CHECK (POR.G, "GENERIC FORMAL PARAMETER", "'OR'"); + CHECK (PXOR.G, "GENERIC FORMAL PARAMMETER", "'XOR'"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING GENERIC " & + "INSTANTIATION" ); + END; + + DECLARE + TYPE ACC IS ACCESS ARR; + AC : ACC; + + BEGIN + AC := NEW ARR'(A1 AND A2); + CHECK (AC.ALL, "ALLOCATION", "'AND'"); + AC := NEW ARR'(A1 OR A2); + CHECK (AC.ALL, "ALLOCATION", "'OR'"); + AC := NEW ARR'(A1 XOR A2); + CHECK (AC.ALL, "ALLOCATION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON ALLOCATION" ); + END; + + BEGIN + CHECK (CARR' (A1 AND A2), "QUALIFIED EXPRESSION", "'AND'"); + CHECK (CARR' (A1 OR A2), "QUALIFIED EXPRESSION", "'OR'"); + CHECK (CARR' (A1 XOR A2), "QUALIFIED EXPRESSION", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON QUALIFIED EXPRESSION" ); + END; + + DECLARE + TYPE REC IS + RECORD + RCA : CARR; + END RECORD; + R1 : REC; + + BEGIN + R1 := (RCA => (A1 AND A2)); + CHECK (R1.RCA, "AGGREGATE", "'AND'"); + R1 := (RCA => (A1 OR A2)); + CHECK (R1.RCA, "AGGREGATE", "'OR'"); + R1 := (RCA => (A1 XOR A2)); + CHECK (R1.RCA, "AGGREGATE", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON AGGREGATE" ); + END; + + BEGIN + DECLARE + TYPE RECDEF IS + RECORD + RCDF1 : CARR := A1 AND A2; + RCDF2 : CARR := A1 OR A2; + RCDF3 : CARR := A1 XOR A2; + END RECORD; + RD : RECDEF; + BEGIN + CHECK (RD.RCDF1, "DEFAULT RECORD", "'AND'"); + CHECK (RD.RCDF2, "DEFAULT RECORD", "'OR'"); + CHECK (RD.RCDF3, "DEFAULT RECORD", "'XOR'"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT RECORD" ); + END; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING INITIALIZATION OF " & + "DEFAULT RECORD" ); + END; + + DECLARE + PROCEDURE PDEF (X : CARR := A1 AND A2; + Y : CARR := A1 OR A2; + Z : CARR := A1 XOR A2 ) IS + BEGIN + CHECK (X, "DEFAULT PARAMETER", "'AND'"); + CHECK (Y, "DEFAULT PARAMETER", "'OR'"); + CHECK (Z, "DEFAULT PARAMETER", "'XOR'"); + END PDEF; + + BEGIN + PDEF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED ON DEFAULT PARM" ); + END; + + RESULT; + + END C45112B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45113a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45113a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45113a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45113a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C45113A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE OPERANDS OF LOGICAL + -- OPERATORS HAVE DIFFERENT LENGTHS. + + -- RJW 1/15/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45113A IS + + BEGIN + + TEST( "C45113A" , "CHECK ON LOGICAL OPERATORS WITH " & + "OPERANDS OF DIFFERENT LENGTHS" ); + + DECLARE + + TYPE ARR IS ARRAY ( INTEGER RANGE <> ) OF BOOLEAN; + + A : ARR( IDENT_INT(1) .. IDENT_INT(2) ) := ( TRUE, FALSE ); + B : ARR( IDENT_INT(1) .. IDENT_INT(3) ) := ( TRUE, FALSE, + TRUE ); + + BEGIN + + BEGIN -- TEST FOR 'AND'. + IF (A AND B) = B THEN + FAILED ( "A AND B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'AND'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'AND'" ); + END; + + + BEGIN -- TEST FOR 'OR'. + IF (A OR B) = B THEN + FAILED ( "A OR B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'OR'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'OR'" ); + END; + + + BEGIN -- TEST FOR 'XOR'. + IF (A XOR B) = B THEN + FAILED ( "A XOR B = B" ); + END IF; + FAILED ( "NO EXCEPTION RAISED FOR 'XOR'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'XOR'" ); + END; + + END; + + RESULT; + + END C45113A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45114b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45114b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45114b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45114b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C45114B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOGICAL OPERATORS ARE DEFINED FOR PACKED BOOLEAN ARRAYS. + + -- RJW 1/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45114B IS + + BEGIN + + TEST( "C45114B" , "CHECK THAT LOGICAL OPERATORS ARE DEFINED " & + "FOR PACKED BOOLEAN ARRAYS" ); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 32) OF BOOLEAN; + + PRAGMA PACK (ARR); + + A : ARR := ( TRUE, TRUE, FALSE, FALSE, OTHERS => TRUE ); + B : ARR := ( TRUE, FALSE, TRUE, FALSE, OTHERS => FALSE ); + + A_AND_B : ARR := ( TRUE, OTHERS => FALSE ); + A_OR_B : ARR := ARR'( 4 => FALSE, OTHERS => TRUE ); + A_XOR_B : ARR := ARR'( 1|4 => FALSE, OTHERS => TRUE ); + NOT_A : ARR := ARR'( 3|4 => TRUE, OTHERS => FALSE ); + + BEGIN + + IF ( A AND B ) /= A_AND_B THEN + FAILED ( "'AND' NOT CORRECTLY DEFINED" ); + END IF; + + IF ( A OR B ) /= A_OR_B THEN + FAILED ( "'OR' NOT CORRECTLY DEFINED" ); + END IF; + + IF ( A XOR B ) /= A_XOR_B THEN + FAILED ( "'XOR' NOT CORRECTLY DEFINED" ); + END IF; + + IF NOT A /= NOT_A THEN + FAILED ( "'NOT' NOT CORRECTLY DEFINED" ); + END IF; + + END; + + RESULT; + + END C45114B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c452001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c452001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c452001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c452001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,707 ---- + -- C452001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- For a type extension, check that predefined equality is defined in + -- terms of the primitive equals operator of the parent type and any + -- tagged components of the extension part. + -- + -- For other composite types, check that the primitive equality operator + -- of any matching tagged components is used to determine equality of the + -- enclosing type. + -- + -- For private types, check that predefined equality is defined in + -- terms of the user-defined (primitive) operator of the full type if + -- the full type is tagged. The partial view of the type may be + -- tagged or untagged. Check that predefined equality for a private + -- type whose full view is untagged is defined in terms of the + -- predefined equality operator of its full type. + -- + -- TEST DESCRIPTION: + -- Tagged types are declared and used as components in several + -- differing composite type declarations, both tagged and untagged. + -- To differentiate between predefined and primitive equality + -- operations, user-defined equality operators are declared for + -- each component type that is to contribute to the equality + -- operator of the composite type that houses it. All user-defined + -- equality operations are designed to yield the opposite result + -- from the predefined operator, given the same component values. + -- + -- For cases where primitive equality is to be incorporated into + -- equality for the enclosing composite type, values are assigned + -- to the component type so that user-defined equality will return + -- True. If predefined equality is to be used instead, then the + -- same strategy results in the equality operator returning False. + -- + -- When equality for a type incorporates the user-defined equality + -- operator of one of its component types, the resulting operator + -- is considered to be the predefined operator of the composite type. + -- This case is confirmed by defining an tagged component of an + -- untagged composite type, then using the resulting untagged type + -- as a component of another composite type. The user-defined operator + -- for the lowest level should still be called. + -- + -- Three cases are set up to test private types: + -- + -- Case 1 Case 2 Case 3 + -- partial view: tagged untagged untagged + -- full view: tagged tagged untagged + -- + -- Types are declared for each of the above cases and user-defined + -- (primitive) operators are declared following the full type + -- declaration of each type (i.e., in the private part). + -- + -- Values are assigned into objects of these types using the same + -- strategy outlined above. Cases 1 and 2 should execute the + -- user-defined operator. Case 3 should ignore the user-defined + -- operator and user predefined equality for the type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Removed RM references from objective text. + -- 15 Nov 95 SAIC Fixed for 2.0.1 + -- 04 NOV 96 SAIC Typographical revision + -- + --! + + package c452001_0 is + + type Point is + record + X : Integer := 0; + Y : Integer := 0; + end record; + + type Circle is tagged + record + Center : Point; + Radius : Integer; + end record; + + function "=" (L, R : Circle) return Boolean; + + type Colors is (Red, Orange, Yellow, Green, Blue, Purple, Black, White); + + type Colored_Circle is new Circle + with record + Color : Colors := White; + end record; + + function "=" (L, R : Colored_Circle) return Boolean; + -- Override predefined equality for this tagged type. Predefined + -- equality should incorporate user-defined (primitive) equality + -- from type Circle. See C340001 for a test of that feature. + + -- Equality is overridden to ensure that predefined equality + -- incorporates this user-defined function for + -- any composite type with Colored_Circle as a component type. + -- (i.e., the type extension is recognized as a tagged type for + -- the purpose of defining predefined equality for the composite type). + + end C452001_0; + + package body c452001_0 is + + function "=" (L, R : Circle) return Boolean is + begin + return L.Radius = R.Radius; -- circles are same size + end "="; + + function "=" (L, R : Colored_Circle) return Boolean is + begin + return Circle(L) = Circle(R); + end "="; + + end C452001_0; + + with C452001_0; + package C452001_1 is + + type Planet is tagged record + Name : String (1..15); + Representation : C452001_0.Colored_Circle; + end record; + + -- Type Planet will be used to check that predefined equality + -- for a tagged type with a tagged component incorporates + -- user-defined equality for the component type. + + type TC_Planet is new Planet with null record; + + -- A "copy" of Planet. Used to create a type extension. An "=" + -- operator will be defined for this type that should be + -- incorporated by the type extension. + + function "=" (Arg1, Arg2 : in TC_Planet) return Boolean; + + type Craters is array (1..3) of C452001_0.Colored_Circle; + + -- An array type (untagged) with tagged components + + type Moon is new TC_Planet + with record + Crater : Craters; + end record; + + -- A tagged record type. Extended component type is untagged, + -- but its predefined equality operator should incorporate + -- the user-defined operator of its tagged component type. + + end C452001_1; + + package body C452001_1 is + + function "=" (Arg1, Arg2 : in TC_Planet) return Boolean is + begin + return Arg1.Name = Arg2.Name; + end "="; + + end C452001_1; + + package C452001_2 is + + -- Untagged record types + -- Equality should not be incorporated + + type Spacecraft_Design is (Mariner, Pioneer, Viking, Voyager); + type Spacecraft is record + Design : Spacecraft_Design; + Operational : Boolean; + end record; + + function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean; + + type Mission is record + Craft : Spacecraft; + Launch_Date : Natural; + end record; + + type Inventory is array (Positive range <>) of Spacecraft; + + end C452001_2; + + package body C452001_2 is + + function "=" (L : in Spacecraft; R : in Spacecraft) return Boolean is + begin + return L.Design = R.Design; + end "="; + + end C452001_2; + + package C452001_3 is + + type Tagged_Partial_Tagged_Full is tagged private; + procedure Change (Object : in out Tagged_Partial_Tagged_Full; + Value : in Boolean); + + type Untagged_Partial_Tagged_Full is private; + procedure Change (Object : in out Untagged_Partial_Tagged_Full; + Value : in Integer); + + type Untagged_Partial_Untagged_Full is private; + procedure Change (Object : in out Untagged_Partial_Untagged_Full; + Value : in Duration); + + private + + type Tagged_Partial_Tagged_Full is + tagged record + B : Boolean := True; + C : Character := ' '; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean; + -- primitive equality checks that records equate in component C only + + type Untagged_Partial_Tagged_Full is + tagged record + I : Integer := 0; + P : Positive := 1; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean; + -- primitive equality checks that records equate in component P only + + type Untagged_Partial_Untagged_Full is + record + D : Duration := 0.0; + S : String (1..12) := "Ada 9X rules"; + end record; + -- predefined equality checks that all components are equal + + function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean; + -- primitive equality checks that records equate in component S only + + end C452001_3; + + with Report; + package body C452001_3 is + + procedure Change (Object : in out Tagged_Partial_Tagged_Full; + Value : in Boolean) is + begin + Object := (Report.Ident_Bool(Value), Object.C); + end Change; + + procedure Change (Object : in out Untagged_Partial_Tagged_Full; + Value : in Integer) is + begin + Object := (Report.Ident_Int(Value), Object.P); + end Change; + + procedure Change (Object : in out Untagged_Partial_Untagged_Full; + Value : in Duration) is + begin + Object := (Value, Report.Ident_Str(Object.S)); + end Change; + + function "=" (L, R : in Tagged_Partial_Tagged_Full) return Boolean is + begin + return L.C = R.C; + end "="; + + function "=" (L, R : in Untagged_Partial_Tagged_Full) return Boolean is + begin + return L.P = R.P; + end "="; + + function "=" (L, R : in Untagged_Partial_Untagged_Full) return Boolean is + begin + return R.S = L.S; + end "="; + + end C452001_3; + + + with C452001_0; + with C452001_1; + with C452001_2; + with C452001_3; + with Report; + procedure C452001 is + + Mars_Aphelion : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(20), + Report.Ident_Int(0)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Red)); + + Mars_Perihelion : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(-20), + Report.Ident_Int(0)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Red)); + + -- Mars_Perihelion = Mars_Aphelion if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the tagged type Planet. User-defined + -- equality for Colored_Circle checks only that the Radii are equal. + + Blue_Mars : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(10)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Blue)); + + -- Blue_Mars should equal Mars_Perihelion, because Names and + -- Radii are equal (all other components are not). + + Green_Mars : C452001_1.Planet := + (Name => "Mars ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(10)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Green)); + + -- Blue_Mars should equal Green_Mars. They differ only in the + -- Color component. All user-defined equality operations return + -- True, but records are not equal by predefined equality. + + -- Blue_Mars should equal Mars_Perihelion, because Names and + -- Radii are equal (all other components are not). + + Moon_Craters : C452001_1.Craters := + ((Center => (Report.Ident_Int(9), Report.Ident_Int(11)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black), + (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black), + (Center => (Report.Ident_Int(11), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Black)); + + Alternate_Moon_Craters : C452001_1.Craters := + ((Center => (Report.Ident_Int(9), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Yellow), + (Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Purple), + (Center => (Report.Ident_Int(11), Report.Ident_Int(11)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Purple)); + + -- Moon_Craters = Alternate_Moon_Craters if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the untagged type Craters. User-defined + -- equality checks only that the Radii are equal. + + New_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Moon_Craters); + + Full_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Alternate_Moon_Craters); + + -- New_Moon = Full_Moon if user-defined equality from + -- the tagged type Colored_Circle was incorporated into + -- predefined equality for the untagged type Craters. This + -- equality test should call user-defined equality for type + -- TC_Planet (checks that Names are equal), then predefined + -- equality for Craters (ultimately calls user-defined equality + -- for type Circle, checking that Radii of craters are equal). + + Mars_Moon : C452001_1.Moon := + (Name => "Phobos ", + Representation => (Center => (Report.Ident_Int(10), + Report.Ident_Int(8)), + Radius => Report.Ident_Int(3), + Color => C452001_0.Black), + Crater => Alternate_Moon_Craters); + + -- Mars_Moon /= Full_Moon since the Names differ. + + Alternate_Moon_Craters_2 : C452001_1.Craters := + ((Center => (Report.Ident_Int(10), Report.Ident_Int(10)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red), + (Center => (Report.Ident_Int(9), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red), + (Center => (Report.Ident_Int(10), Report.Ident_Int(9)), + Radius => Report.Ident_Int(1), + Color => C452001_0.Red)); + + Harvest_Moon : C452001_1.Moon := + (Name => "Moon ", + Representation => (Center => (Report.Ident_Int(11), + Report.Ident_Int(7)), + Radius => Report.Ident_Int(4), + Color => C452001_0.Orange), + Crater => Alternate_Moon_Craters_2); + + -- Only the fields that are employed by the user-defined equality + -- operators are the same. Everything else differs. Equality should + -- still return True. + + Viking_1_Orbiter : C452001_2.Mission := + (Craft => (Design => C452001_2.Viking, + Operational => Report.Ident_Bool(False)), + Launch_Date => 1975); + + Viking_1_Lander : C452001_2.Mission := + (Craft => (Design => C452001_2.Viking, + Operational => Report.Ident_Bool(True)), + Launch_Date => 1975); + + -- Viking_1_Orbiter /= Viking_1_Lander if predefined equality + -- from the untagged type Spacecraft is used for equality + -- of matching components in type Mission. If user-defined + -- equality for type Spacecraft is incorporated, which it + -- should not be by 4.5.2(21), then Viking_1_Orbiter = Viking_1_Lander. + + Voyagers : C452001_2.Inventory (1..2):= + ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), + (C452001_2.Voyager, Operational => Report.Ident_Bool(False))); + + Jupiter_Craft : C452001_2.Inventory (1..2):= + ((C452001_2.Voyager, Operational => Report.Ident_Bool(True)), + (C452001_2.Voyager, Operational => Report.Ident_Bool(True))); + + -- Voyagers /= Jupiter_Craft if predefined equality + -- from the untagged type Spacecraft is used for equality + -- of matching components in type Inventory. If user-defined + -- equality for type Spacecraft is incorporated, which it + -- should not be by 4.5.2(21), then Voyagers = Jupiter_Craft. + + TPTF_1 : C452001_3.Tagged_Partial_Tagged_Full; + TPTF_2 : C452001_3.Tagged_Partial_Tagged_Full; + + -- With differing values for Boolean component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is tagged, primitive equality + -- should be used. + + UPTF_1 : C452001_3.Untagged_Partial_Tagged_Full; + UPTF_2 : C452001_3.Untagged_Partial_Tagged_Full; + + -- With differing values for Boolean component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is tagged, primitive equality + -- should be used. + + UPUF_1 : C452001_3.Untagged_Partial_Untagged_Full; + UPUF_2 : C452001_3.Untagged_Partial_Untagged_Full; + + -- With differing values for Duration component, user-defined + -- (primitive) equality returns True, predefined equality + -- returns False. Since full type is untagged, predefined equality + -- should be used. + + -- Use type clauses make "=" and "/=" operators directly visible + use type C452001_1.Planet; + use type C452001_1.Craters; + use type C452001_1.Moon; + use type C452001_2.Mission; + use type C452001_2.Inventory; + use type C452001_3.Tagged_Partial_Tagged_Full; + use type C452001_3.Untagged_Partial_Tagged_Full; + use type C452001_3.Untagged_Partial_Untagged_Full; + + begin + + Report.Test ("C452001", "Equality of private types and " & + "composite types with tagged components"); + + ------------------------------------------------------------------- + -- Tagged type with tagged component. + ------------------------------------------------------------------- + + if not (Mars_Aphelion = Mars_Perihelion) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for enclosing tagged record type"); + end if; + + if Mars_Aphelion /= Mars_Perihelion then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for enclosing tagged record type"); + end if; + + if not (Blue_Mars = Mars_Perihelion) then + Report.Failed ("Equality test for tagged record type " & + "incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Blue_Mars /= Mars_Perihelion then + Report.Failed ("Inequality test for tagged record type " & + "incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Blue_Mars /= Green_Mars then + Report.Failed ("Records are unequal even though they only differ " & + "in a component not used by user-defined equality"); + end if; + + if not (Blue_Mars = Green_Mars) then + Report.Failed ("Records are not equal even though they only differ " & + "in a component not used by user-defined equality"); + end if; + + ------------------------------------------------------------------- + -- Untagged (array) type with tagged component. + ------------------------------------------------------------------- + + if not (Moon_Craters = Alternate_Moon_Craters) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for enclosing array type"); + end if; + + if Moon_Craters /= Alternate_Moon_Craters then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for enclosing array type"); + end if; + + ------------------------------------------------------------------- + -- Tagged type with untagged composite component. Untagged + -- component itself has tagged components. + ------------------------------------------------------------------- + if not (New_Moon = Full_Moon) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for array component of tagged record type"); + end if; + + if New_Moon /= Full_Moon then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for array component of tagged record type"); + end if; + + if Mars_Moon = Full_Moon then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined equality " & + "for array component of tagged record type"); + end if; + + if not (Mars_Moon /= Full_Moon) then + Report.Failed ("User-defined equality for tagged component " & + "was not incorporated into predefined inequality " & + "for array component of tagged record type"); + end if; + + if not (Harvest_Moon = Full_Moon) then + Report.Failed ("Equality test for record with array of tagged " & + "components incorporates record components " & + "other than those used by user-defined equality"); + end if; + + if Harvest_Moon /= Full_Moon then + Report.Failed ("Inequality test for record with array of tagged " & + "components incorporates record components " & + "other than those used by user-defined equality"); + end if; + + ------------------------------------------------------------------- + -- Untagged types with no tagged components. + ------------------------------------------------------------------- + + -- Record type + + if Viking_1_Orbiter = Viking_1_Lander then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "equality for " & + "untagged record type"); + end if; + + if not (Viking_1_Orbiter /= Viking_1_Lander) then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "inequality for " & + "untagged record type"); + end if; + + -- Array type + + if Voyagers = Jupiter_Craft then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "equality for " & + "array type"); + end if; + + if not (Voyagers /= Jupiter_Craft) then + Report.Failed ("User-defined equality for untagged composite " & + "component was incorporated into predefined " & + "inequality for " & + "array type"); + end if; + + ------------------------------------------------------------------- + -- Private types tests. + ------------------------------------------------------------------- + + -- Make objects differ from one another + + C452001_3.Change (TPTF_1, False); + C452001_3.Change (UPTF_1, 999); + C452001_3.Change (UPUF_1, 40.0); + + ------------------------------------------------------------------- + -- Partial type and full type are tagged. (Full type must be tagged + -- if partial type is tagged) + ------------------------------------------------------------------- + + if not (TPTF_1 = TPTF_2) then + Report.Failed ("Predefined equality for full type " & + "was used to determine equality of " & + "tagged private type " & + "instead of user-defined (primitive) equality"); + end if; + + if TPTF_1 /= TPTF_2 then + Report.Failed ("Predefined equality for full type " & + "was used to determine inequality of " & + "tagged private type " & + "instead of user-defined (primitive) equality"); + end if; + + ------------------------------------------------------------------- + -- Partial type untagged, full type tagged. + ------------------------------------------------------------------- + + if not (UPTF_1 = UPTF_2) then + Report.Failed ("Predefined equality for full type " & + "was used to determine equality of " & + "private type (untagged partial view, " & + "tagged full view) " & + "instead of user-defined (primitive) equality"); + end if; + + if UPTF_1 /= UPTF_2 then + Report.Failed ("Predefined equality for full type " & + "was used to determine inequality of " & + "private type (untagged partial view, " & + "tagged full view) " & + "instead of user-defined (primitive) equality"); + end if; + + ------------------------------------------------------------------- + -- Partial type and full type are both untagged. + ------------------------------------------------------------------- + + if UPUF_1 = UPUF_2 then + Report.Failed ("User-defined (primitive) equality for full type " & + "was used to determine equality of " & + "private type (untagged partial view, " & + "untagged full view) " & + "instead of predefined equality"); + end if; + + if not (UPUF_1 /= UPUF_2) then + Report.Failed ("User-defined (primitive) equality for full type " & + "was used to determine inequality of " & + "private type (untagged partial view, " & + "untagged full view) " & + "instead of predefined equality"); + end if; + + ------------------------------------------------------------------- + Report.Result; + + end C452001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45201a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- C45201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON + -- ENUMERATION-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING + -- DIFFERENT SUBTYPES). + + -- THIS TEST'S FRAMEWORK IS FROM C45201B.ADA , C45210A.ADA . + + + -- RM 20 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45201A IS + + USE REPORT; + + TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E ); + + -- S-LIT , P-LIT , NUL , 'R' CORRESPOND + -- TO 'S' , 'P' , 'M' , 'R' IN C45210A. + + SUBTYPE T1 IS T RANGE A..B ; + SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1 + SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4 + SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2 + + MVAR : T3 := T'(NUL ) ; + PVAR : T2 := T'(PLIT) ; + RVAR : T4 := T'('R' ) ; + SVAR : T1 := T'(SLIT) ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION ITSELF( THE_ARGUMENT : T ) RETURN T IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN A ; + END IF; + END ; + + + BEGIN + + TEST( "C45201A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON ENUMERATION-TYPE LITERALS" ) ; + + -- 128 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 2 (4) OPERATORS (2, TWICE): '=' , '/=' , '=' , '/=' + -- (IN THE TABLE: A , B , C , D ) + -- (C45201B.ADA HAD < <= > >= ; REVERSED) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR BOTH OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) = T'(SVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(SVAR) /= T'(PLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(SLIT) = T'(MVAR) THEN BUMP ; END IF; + IF T'(SLIT) /= T'('R' ) THEN NULL; ELSE BUMP ; END IF; + + IF T'(PLIT) = T'(SLIT) THEN BUMP ; END IF; + IF T'(PLIT) /= T'(PVAR) THEN BUMP ; END IF; + IF T'(PVAR) = T'(NUL ) THEN BUMP ; END IF; + IF T'(PVAR) /= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) /= T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) = T'(PVAR) THEN BUMP ; END IF; + IF T'(NUL ) /= T'(NUL ) THEN BUMP ; END IF; + IF T'(NUL ) = T'(RVAR) THEN BUMP ; END IF; + + IF T'('R' ) /= T'(SVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'('R' ) = T'(PLIT) THEN BUMP ; END IF; + IF T'(RVAR) /= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) = T'('R' ) THEN NULL; ELSE BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' STILL MEANS 'BUMP THE ERROR COUNT' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF AVAR = BVAR THEN + IF AVAR /= BVAR THEN BUMP ; END IF; + END IF; + + IF AVAR /= BVAR THEN + IF AVAR = BVAR THEN BUMP ; END IF; + END IF; + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF ( AVAR /= BVAR ) /= ( T'POS(AVAR) /= T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR = BVAR ) /= ( T'POS(AVAR) = T'POS(BVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE3" ); + END IF; + + ERROR_COUNT := 0 ; + + FOR IVAR IN 0..8 LOOP -- 9 VALUES + + FOR JVAR IN 0..8 LOOP -- 9 VALUES + + IF ( IVAR /= JVAR ) /= ( T'VAL(IVAR) /= T'VAL(JVAR) )THEN + BUMP ; + END IF; + + IF ( IVAR = JVAR ) /= ( T'VAL(IVAR) = T'VAL(JVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES (THE DIAGONAL) + + IF AVAR = ITSELF(AVAR) THEN NULL; ELSE BUMP; END IF; + IF AVAR /= ITSELF(AVAR) THEN BUMP; END IF; + + END LOOP; + + IF ERROR_COUNT /= 0 THEN + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE5" ); + END IF; + + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF AVAR /= BVAR THEN BUMP ; END IF; -- COUNT +:= 72 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 72 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "EQUALITY OF ENUMERATION VALUES - FAILURE6" ); + END IF; + + + RESULT; + + END C45201A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45201b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45201b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45201b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45201b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,236 ---- + -- C45201B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ORDERING OF ENUMERATION LITERALS AS DEFINED BY THE + -- ORDERING OPERATORS IS THE SAME AS THE ORDER OF OCCURRENCE OF THE + -- LITERALS IN THE TYPE DEFINITION. + + -- THIS TEST IS DERIVED FROM C45210A.ADA . + + + -- RM 17 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45201B IS + + USE REPORT; + + TYPE T IS ( A , SLIT , B , PLIT , C , NUL , D , 'R' , E ); + + -- S-LIT , P-LIT , NUL , 'R' CORRESPOND + -- TO 'S' , 'P' , 'M' , 'R' IN C45210A. + + SUBTYPE T1 IS T RANGE A..B ; + SUBTYPE T2 IS T RANGE A..C ; -- INCLUDES T1 + SUBTYPE T3 IS T RANGE B..D ; -- INTERSECTS T2 , T4 + SUBTYPE T4 IS T RANGE C..E ; -- DISJOINT FROM T1 , T2 + + MVAR : T3 := T'(NUL ) ; + PVAR : T2 := T'(PLIT) ; + RVAR : T4 := T'('R' ) ; + SVAR : T1 := T'(SLIT) ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + + BEGIN + + TEST( "C45201B","CHECK THAT THE ORDERING OF ENUMERATION LITERALS "& + " AS DEFINED BY THE ORDERING OPERATORS" & + " IS THE SAME AS THE ORDER OF OCCURRENCE OF THE " & + " LITERALS IN THE TYPE DEFINITION" ) ; + + -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>=' + -- (IN THE TABLE: A , B , C , D ) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR ALL 4 OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF; + IF T'(SVAR) <= T'(PLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(SLIT) > T'(MVAR) THEN BUMP ; END IF; + IF T'(SLIT) >= T'('R' ) THEN BUMP ; END IF; + + IF T'(PLIT) > T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(PLIT) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) < T'(NUL ) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) >= T'(SLIT) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(NUL ) <= T'(NUL ) THEN NULL; ELSE BUMP ; END IF; + IF T'(NUL ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF; + IF T'('R' ) < T'(PLIT) THEN BUMP ; END IF; + IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 6 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 6 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 10 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=10 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE3" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 26 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=26 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + FOR BVAR IN T'FIRST..T'(PLIT) LOOP -- 4 VALUES + + IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 30 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /=30 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE5" ); + END IF; + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' (AGAIN) + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + FOR BVAR IN T'FIRST..T'LAST LOOP -- 9 VALUES + + IF ( AVAR < BVAR ) /= ( T'POS(AVAR) < T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR <= BVAR ) /= ( T'POS(AVAR) <= T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR > BVAR ) /= ( T'POS(AVAR) > T'POS(BVAR) )THEN + BUMP ; + END IF; + + IF ( AVAR >= BVAR ) /= ( T'POS(AVAR) >= T'POS(BVAR) )THEN + BUMP ; + END IF; + + END LOOP; + + END LOOP; + + + IF ERROR_COUNT /= 0 THEN -- REAL ERROR COUNT AGAIN + FAILED( "ORDERING OF ENUMERATION LITERALS - FAILURE6" ); + END IF; + + + RESULT; + + END C45201B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45202b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45202b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45202b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45202b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C45202B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK MEMBERSHIP OPERATIONS IN THE CASE IN WHICH A USER HAS + -- REDEFINED THE ORDERING OPERATORS. + + -- RJW 1/22/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45202B IS + + + BEGIN + + TEST( "C45202B" , "CHECK MEMBERSHIP OPERATIONS IN WHICH A USER " & + "HAS REDEFINED THE ORDERING OPERATORS" ) ; + + + DECLARE + + TYPE T IS ( AA, BB, CC, LIT, XX, YY, ZZ ); + SUBTYPE ST IS T RANGE AA .. LIT; + + VAR : T := LIT ; + CON : CONSTANT T := LIT ; + + FUNCTION ">" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) <= T'POS(R); + END; + + FUNCTION ">=" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) < T'POS(R); + END; + + FUNCTION "<" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) >= T'POS(R); + END; + + FUNCTION "<=" ( L, R : T ) RETURN BOOLEAN IS + BEGIN + RETURN T'POS(L) > T'POS(R); + END; + + + BEGIN + + IF LIT NOT IN ST OR + VAR NOT IN ST OR + CON NOT IN ST OR + NOT (VAR IN ST) OR + XX IN ST OR + NOT (XX NOT IN ST) + THEN + FAILED( "WRONG VALUES FOR 'IN ST'" ); + END IF; + + IF LIT IN AA ..CC OR + VAR NOT IN LIT..ZZ OR + CON IN ZZ ..AA OR + NOT (CC IN CC .. YY) OR + NOT (BB NOT IN CC .. YY) + THEN + FAILED( "WRONG VALUES FOR 'IN AA..CC'" ); + END IF; + + END; + + RESULT; + + END C45202B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45210a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45210a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45210a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45210a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C45210A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ENUMERATION IMPOSING AN "UNNATURAL" ORDER ON ALPHABETIC + -- CHARACTERS CORRECTLY EVALUATES THE ORDERING OPERATORS. + + + -- RM 15 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45210A IS + + USE REPORT; + + TYPE T IS ( 'S' , 'P' , 'M' , 'R' ); + + MVAR : T := T'('M') ; + PVAR : T := T'('P') ; + RVAR : T := T'('R') ; + SVAR : T := T'('S') ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT +1 ; + END BUMP ; + + + BEGIN + + TEST( "C45210A" , "CHECK THAT AN ENUMERATION IMPOSING" & + " AN ""UNNATURAL"" ORDER ON ALPHABETIC" & + " CHARACTERS CORRECTLY EVALUATES THE " & + " ORDERING OPERATORS" ) ; + + -- 256 CASES ( 4 * 4 ORDERED PAIRS OF OPERAND VALUES, + -- 4 ORDERING OPERATORS: '<' , '<=' , '>' , '>=' + -- (IN THE TABLE: A , B , C , D ) + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND, + -- (IN THE TABLE: VV = ALPHA , + -- VL = BETA , + -- LV = GAMMA , + -- LL = DELTA ) RANDOMIZED + -- INTO 16 (ONE FOR EACH PAIR OF VALUES) ACCORDING TO THE FOL- + -- LOWING GRAECO-LATIN SQUARE (WITH ADDITIONAL PROPERTIES): + + -- RIGHT OPERAND: 'S' 'P' 'M' 'R' + -- LEFT + -- OPERAND: + + -- 'S' A-ALPHA B-BETA C-GAMMA D-DELTA + -- 'P' C-DELTA D-GAMMA A-BETA B-ALPHA + -- 'M' D-BETA C-ALPHA B-DELTA A-GAMMA + -- 'R' B-GAMMA A-DELTA D-ALPHA C-BETA + + -- (BOTH THE LATIN DIAGONAL AND THE GREEK DIAGONAL CONTAIN 4 + -- DISTINCT LETTERS, NON-TRIVIALLY PERMUTED.) + + -- THE ABOVE DESCRIBES PART 1 OF THE TEST. PART 2 PERFORMS AN + -- EXHAUSTIVE VERIFICATION OF THE 'VARIABLE VS. VARIABLE' CASE + -- ( VV , ALPHA ) FOR ALL 4 OPERATORS. + + ----------------------------------------------------------------- + + -- PART 1 + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + IF T'(SVAR) < T'(SVAR) THEN BUMP ; END IF; + IF T'(SVAR) <= T'('P' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('S' ) > T'(MVAR) THEN BUMP ; END IF; + IF T'('S' ) >= T'('R' ) THEN BUMP ; END IF; + + IF T'('P' ) > T'('S' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('P' ) >= T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) < T'('M' ) THEN NULL; ELSE BUMP ; END IF; + IF T'(PVAR) <= T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'(MVAR) >= T'('S' ) THEN NULL; ELSE BUMP ; END IF; + IF T'(MVAR) > T'(PVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'('M' ) <= T'('M' ) THEN NULL; ELSE BUMP ; END IF; + IF T'('M' ) < T'(RVAR) THEN NULL; ELSE BUMP ; END IF; + + IF T'('R' ) <= T'(SVAR) THEN BUMP ; END IF; + IF T'('R' ) < T'('P' ) THEN BUMP ; END IF; + IF T'(RVAR) >= T'(MVAR) THEN NULL; ELSE BUMP ; END IF; + IF T'(RVAR) > T'('R' ) THEN BUMP ; END IF; + + + IF ERROR_COUNT /= 0 THEN + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE1" ); + END IF; + + ----------------------------------------------------------------- + + -- PART 2 + + -- 'BUMP' MEANS 'INCREASE THE COUNT FOR THE NUMBER OF S' + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR < BVAR THEN BUMP ; END IF; -- COUNT +:= 1 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 1 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE2" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR <= BVAR THEN BUMP ; END IF; -- COUNT +:= 3 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 3 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE3" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR > BVAR THEN BUMP ; END IF; -- COUNT +:= 5 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 5 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE4" ); + END IF; + + + ERROR_COUNT := 0 ; + + FOR AVAR IN T'FIRST..T'LAST LOOP -- 4 VALUES + FOR BVAR IN T'FIRST..T'('P') LOOP -- 2 VALUES + + IF AVAR >= BVAR THEN BUMP ; END IF; -- COUNT +:= 7 + + END LOOP; + END LOOP; + + IF ERROR_COUNT /= 7 THEN -- THIS IS A PLAIN COUNT, NOT AN + -- ERROR COUNT + FAILED( """UNNATURAL"" ORDER ON CHARACTER TYPES - FAILURE5" ); + END IF; + + + RESULT; + + END C45210A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45211a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45211a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45211a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45211a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- C45211A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK MEMBERSHIP TESTS FOR AN 'UNNATURAL' ORDERING OF CHARACTER + -- LITERALS. + + -- RJW 1/22/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45211A IS + + TYPE T IS ( 'S' , 'Q' , 'P' , 'M' , 'R' ); + SUBTYPE ST IS T RANGE 'P' .. 'R'; + + MVAR : T := T'('M') ; + QVAR : T := T'('Q') ; + MCON : CONSTANT T := T'('M'); + QCON : CONSTANT T := T'('Q'); + + BEGIN + + TEST( "C45211A" , "CHECK MEMBERSHIP TESTS FOR AN 'UNNATURAL' " & + "ORDERING OF CHARACTER LITERALS" ) ; + + IF QVAR IN T'('P') .. T'('R') OR + 'Q' IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 1" ); + END IF; + + IF MVAR NOT IN T'('P') .. T'('R') OR + 'M' NOT IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 2" ); + END IF; + + IF QCON IN T'('P') .. T'('R') OR + MCON NOT IN ST + THEN + FAILED ( "MEMBERSHIP TEST FOR 'UNNATURAL' ORDERING - 3" ); + END IF; + + RESULT; + + END C45211A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C45220A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON + -- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING + -- DIFFERENT SUBTYPES). + + -- THIS TEST IS DERIVED FROM C45201A.ADA . + + + -- RM 27 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45220A IS + + + USE REPORT; + + SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ; + SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ; + SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ; + SUBTYPE T4 IS T3 RANGE TRUE..TRUE ; + + FVAR1 : T1 := FALSE ; + TVAR1 : T2 := TRUE ; + FVAR2 : T3 := FALSE ; + TVAR2 : T4 := TRUE ; + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + + BEGIN + + + TEST( "C45220A" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON BOOLEAN-TYPE OPERANDS" ) ; + + -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 2 OPERATORS : '=' , '/=' , + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_BOOL( FALSE ) ; + TVAR1 := IDENT_BOOL( TRUE ) ; + FVAR2 := IDENT_BOOL( FALSE ) ; + TVAR2 := IDENT_BOOL( TRUE ) ; + + IF FALSE = FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 = FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE = FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE = TRUE THEN BUMP ; END IF; + IF FVAR1 = TRUE THEN BUMP ; END IF; + IF FALSE = TVAR2 THEN BUMP ; END IF; + IF FVAR2 = TVAR1 THEN BUMP ; END IF; + + IF TRUE = FALSE THEN BUMP ; END IF; + IF TRUE = FVAR1 THEN BUMP ; END IF; + IF TVAR2 = FALSE THEN BUMP ; END IF; + IF TVAR1 = FVAR2 THEN BUMP ; END IF; + + IF TRUE = TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 = TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE = TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + + IF FALSE /= FALSE THEN BUMP ; END IF; + IF FVAR1 /= FALSE THEN BUMP ; END IF; + IF FALSE /= FVAR2 THEN BUMP ; END IF; + IF FVAR2 /= FVAR1 THEN BUMP ; END IF; + + IF FALSE /= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 /= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE /= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE /= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE /= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 /= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE /= TRUE THEN BUMP ; END IF; + IF TVAR1 /= TRUE THEN BUMP ; END IF; + IF TRUE /= TVAR2 THEN BUMP ; END IF; + IF TVAR2 /= TVAR1 THEN BUMP ; END IF; + + + IF ERROR_COUNT /=0 THEN + FAILED( "(IN)EQUALITY OF BOOLEAN VALUES - FAILURE1" ); + END IF; + + + RESULT ; + + + END C45220A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C45220B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON + -- BOOLEAN-TYPE OPERANDS (IN PARTICULAR, FOR OPERANDS HAVING + -- DIFFERENT SUBTYPES). + + -- THIS TEST IS DERIVED FROM C45220A.ADA . + + + -- RM 28 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45220B IS + + + USE REPORT; + + SUBTYPE T1 IS BOOLEAN RANGE FALSE..FALSE ; + SUBTYPE T2 IS BOOLEAN RANGE TRUE..TRUE ; + SUBTYPE T3 IS BOOLEAN RANGE FALSE..TRUE ; + SUBTYPE T4 IS T3 RANGE TRUE..TRUE ; + + FVAR1 : T1 := FALSE ; + TVAR1 : T2 := TRUE ; + FVAR2 : T3 := FALSE ; + TVAR2 : T4 := TRUE ; + + ERROR_COUNT : INTEGER := 0 ; + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + + BEGIN + + + TEST( "C45220B" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" & + " CORRECT RESULTS ON BOOLEAN-TYPE OPERANDS" ) ; + + -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 4 OPERATORS : '<' , <=' , '>' , '>=' + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_BOOL( FALSE ) ; + TVAR1 := IDENT_BOOL( TRUE ) ; + FVAR2 := IDENT_BOOL( FALSE ) ; + TVAR2 := IDENT_BOOL( TRUE ) ; + + + ERROR_COUNT := 0 ; + + IF FALSE < FALSE THEN BUMP ; END IF; + IF FVAR1 < FALSE THEN BUMP ; END IF; + IF FALSE < FVAR2 THEN BUMP ; END IF; + IF FVAR2 < FVAR1 THEN BUMP ; END IF; + + IF FALSE < TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 < TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE < TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE < FALSE THEN BUMP ; END IF; + IF TRUE < FVAR1 THEN BUMP ; END IF; + IF TVAR2 < FALSE THEN BUMP ; END IF; + IF TVAR1 < FVAR2 THEN BUMP ; END IF; + + IF TRUE < TRUE THEN BUMP ; END IF; + IF TVAR1 < TRUE THEN BUMP ; END IF; + IF TRUE < TVAR2 THEN BUMP ; END IF; + IF TVAR2 < TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE <= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE <= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE <= FALSE THEN BUMP ; END IF; + IF TRUE <= FVAR1 THEN BUMP ; END IF; + IF TVAR2 <= FALSE THEN BUMP ; END IF; + IF TVAR1 <= FVAR2 THEN BUMP ; END IF; + + IF TRUE <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 <= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '<='" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE > FALSE THEN BUMP ; END IF; + IF FVAR1 > FALSE THEN BUMP ; END IF; + IF FALSE > FVAR2 THEN BUMP ; END IF; + IF FVAR2 > FVAR1 THEN BUMP ; END IF; + + IF FALSE > TRUE THEN BUMP ; END IF; + IF FVAR1 > TRUE THEN BUMP ; END IF; + IF FALSE > TVAR2 THEN BUMP ; END IF; + IF FVAR2 > TVAR1 THEN BUMP ; END IF; + + IF TRUE > FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE > FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 > FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE > TRUE THEN BUMP ; END IF; + IF TVAR1 > TRUE THEN BUMP ; END IF; + IF TRUE > TVAR2 THEN BUMP ; END IF; + IF TVAR2 > TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF FALSE >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF FALSE >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF FALSE >= TRUE THEN BUMP ; END IF; + IF FVAR1 >= TRUE THEN BUMP ; END IF; + IF FALSE >= TVAR2 THEN BUMP ; END IF; + IF FVAR2 >= TVAR1 THEN BUMP ; END IF; + + IF TRUE >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= FALSE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF TRUE >= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= TRUE THEN NULL ; ELSE BUMP ; END IF; + IF TRUE >= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF BOOLEAN VALUES - FAILURE '>='" ); + END IF; + + + RESULT ; + + + END C45220B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C45220C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT '=' AND '/=' PRODUCE CORRECT RESULTS ON + -- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN' + -- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES). + + -- THIS TEST IS DERIVED FROM C45220A.ADA . + + + -- RM 27 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + + WITH REPORT ; + PROCEDURE C45220C IS + + + USE REPORT; + + TYPE NB IS NEW BOOLEAN ; + + SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ; + SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE ); + SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE ); + SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE ); + + FVAR1 : T1 := NB'(FALSE) ; + TVAR1 : T2 := NB'(TRUE ); + FVAR2 : T3 := NB'(FALSE) ; + TVAR2 : T4 := NB'(TRUE ); + + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + + BEGIN + + + TEST( "C45220C" , "CHECK THAT '=' AND '/=' PRODUCE CORRECT" & + " RESULTS ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ; + + -- 32 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 2 OPERATORS : '=' , '/=' , + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ; + FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ; + + IF NB'(FALSE) = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 = NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) = FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 = FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) = NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 = NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) = TVAR2 THEN BUMP ; END IF; + IF FVAR2 = TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) = NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) = FVAR1 THEN BUMP ; END IF; + IF TVAR2 = NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 = FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 = NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) = TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 = TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + + IF NB'(FALSE) /= NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 /= NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) /= FVAR2 THEN BUMP ; END IF; + IF FVAR2 /= FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 /= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) /= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 /= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) /= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 /= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 /= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) /= NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 /= NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) /= TVAR2 THEN BUMP ; END IF; + IF TVAR2 /= TVAR1 THEN BUMP ; END IF; + + + IF ERROR_COUNT /=0 THEN + FAILED( "(IN)EQUALITY OF N_BOOLEAN VALUES - FAILURE1" ); + END IF; + + + RESULT ; + + + END C45220C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,200 ---- + -- C45220D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE CORRECT RESULTS ON + -- OPERANDS OF A TYPE DERIVED FROM THE TYPE 'BOOLEAN' + -- (IN PARTICULAR, FOR OPERANDS HAVING DIFFERENT SUBTYPES). + + -- THIS TEST IS DERIVED FROM C45220B.ADA , C45220C.ADA . + + + -- RM 28 OCTOBER 1980 + -- JWC 7/8/85 RENAMED TO -AB + + WITH REPORT ; + PROCEDURE C45220D IS + + + USE REPORT; + + TYPE NB IS NEW BOOLEAN ; + + SUBTYPE T1 IS NB RANGE NB'(FALSE)..NB'(FALSE) ; + SUBTYPE T2 IS NB RANGE NB'(TRUE )..NB'(TRUE ); + SUBTYPE T3 IS NB RANGE NB'(FALSE)..NB'(TRUE ); + SUBTYPE T4 IS T3 RANGE NB'(TRUE )..NB'(TRUE ); + + FVAR1 : T1 := NB'(FALSE) ; + TVAR1 : T2 := NB'(TRUE ); + FVAR2 : T3 := NB'(FALSE) ; + TVAR2 : T4 := NB'(TRUE ); + + ERROR_COUNT : INTEGER := 0 ; + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + + BEGIN + + + TEST( "C45220D" , "CHECK THAT '<' , '<=' , '>' , '>=' PRODUCE" & + " CORRECT RESULTS ON DERIVED-BOOLEAN-TYPE" & + " OPERANDS" ) ; + + -- 64 CASES ( 2 * 2 ORDERED PAIRS OF OPERAND VALUES, + -- 4 OPERATORS : '<' , <=' , '>' , '>=' + -- 4 VARIABLE/LITERAL FOR LEFT OPERAND, + -- VARIABLE/LITERAL FOR RIGHT OPERAND. + + + -- 'BUMP' MEANS 'BUMP THE ERROR COUNT' + + FVAR1 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR1 := IDENT_NEW_BOOL( NB'(TRUE )) ; + FVAR2 := IDENT_NEW_BOOL( NB'(FALSE) ) ; + TVAR2 := IDENT_NEW_BOOL( NB'(TRUE )) ; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) < NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 < NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) < FVAR2 THEN BUMP ; END IF; + IF FVAR2 < FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 < NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) < TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 < TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) < NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) < FVAR1 THEN BUMP ; END IF; + IF TVAR2 < NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 < FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) < NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 < NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) < TVAR2 THEN BUMP ; END IF; + IF TVAR2 < TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) <= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) <= NB'(FALSE) THEN BUMP ; END IF; + IF NB'(TRUE ) <= FVAR1 THEN BUMP ; END IF; + IF TVAR2 <= NB'(FALSE) THEN BUMP ; END IF; + IF TVAR1 <= FVAR2 THEN BUMP ; END IF; + + IF NB'(TRUE ) <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 <= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) <= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 <= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '<='" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) > NB'(FALSE) THEN BUMP ; END IF; + IF FVAR1 > NB'(FALSE) THEN BUMP ; END IF; + IF NB'(FALSE) > FVAR2 THEN BUMP ; END IF; + IF FVAR2 > FVAR1 THEN BUMP ; END IF; + + IF NB'(FALSE) > NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 > NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) > TVAR2 THEN BUMP ; END IF; + IF FVAR2 > TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) > FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 > NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 > FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) > NB'(TRUE ) THEN BUMP ; END IF; + IF TVAR1 > NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(TRUE ) > TVAR2 THEN BUMP ; END IF; + IF TVAR2 > TVAR1 THEN BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>'" ); + END IF; + + + ERROR_COUNT := 0 ; + + IF NB'(FALSE) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF FVAR1 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(FALSE) >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF FVAR2 >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(FALSE) >= NB'(TRUE ) THEN BUMP ; END IF; + IF FVAR1 >= NB'(TRUE ) THEN BUMP ; END IF; + IF NB'(FALSE) >= TVAR2 THEN BUMP ; END IF; + IF FVAR2 >= TVAR1 THEN BUMP ; END IF; + + IF NB'(TRUE ) >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) >= FVAR1 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= NB'(FALSE) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= FVAR2 THEN NULL ; ELSE BUMP ; END IF; + + IF NB'(TRUE ) >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF TVAR1 >= NB'(TRUE ) THEN NULL ; ELSE BUMP ; END IF; + IF NB'(TRUE ) >= TVAR2 THEN NULL ; ELSE BUMP ; END IF; + IF TVAR2 >= TVAR1 THEN NULL ; ELSE BUMP ; END IF; + + IF ERROR_COUNT > 0 THEN + FAILED( "ORDERING OF N_BOOLEAN VALUES - FAILURE '>='" ); + END IF; + + + RESULT ; + + + END C45220D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C45220E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE PROPER OPERATION OF THE MEMBERSHIP OPERATORS 'IN' AND + -- 'NOT IN' FOR BOOLEAN TYPES. + + + -- RM 03/20/81 + -- SPS 10/26/82 + + + WITH REPORT; + PROCEDURE C45220E IS + + USE REPORT ; + + BEGIN + + TEST( "C45220E" , "CHECK THE PROPER OPERATION OF THE MEMBERSHIP" & + " OPERATORS 'IN' AND 'NOT IN' FOR" & + " BOOLEAN TYPES" ); + + DECLARE + + SUBTYPE SUBBOOL IS BOOLEAN RANGE FALSE..TRUE ; + + VAR : BOOLEAN := FALSE ; + CON : CONSTANT BOOLEAN := FALSE ; + + BEGIN + + IF TRUE NOT IN SUBBOOL OR + VAR NOT IN SUBBOOL OR + CON NOT IN SUBBOOL + THEN + FAILED( "WRONG VALUES FOR 'IN SUBBOOL'" ); + END IF; + + IF FALSE IN TRUE..FALSE OR + VAR NOT IN FALSE..TRUE OR + CON IN TRUE..TRUE + THEN + FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" ); + END IF; + + + RESULT ; + + + END ; + + + END C45220E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45220f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45220f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C45220F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE MEMBERSHIP OPERATIONS WORK CORRECTLY FOR DERIVED + -- BOOLEAN TYPES. + + -- GLH 08/01/85 + + WITH REPORT; + PROCEDURE C45220F IS + + USE REPORT ; + + BEGIN + + TEST( "C45220F" , "CHECK MEMBERSHIP OPERATIONS FOR " & + "DERIVED BOOLEAN"); + + DECLARE + + TYPE NEWBOOL IS NEW BOOLEAN; + + VAR : NEWBOOL := FALSE ; + CON : CONSTANT NEWBOOL := FALSE ; + + BEGIN + + IF TRUE NOT IN NEWBOOL OR + VAR NOT IN NEWBOOL OR + CON NOT IN NEWBOOL + THEN + FAILED( "WRONG VALUES FOR 'IN NEWBOOL'" ); + END IF; + + IF NEWBOOL'(FALSE) IN TRUE..FALSE OR + VAR NOT IN FALSE..TRUE OR + CON IN TRUE..TRUE + THEN + FAILED( "WRONG VALUES FOR 'IN AAA..BBB'" ); + END IF; + + RESULT ; + + END ; + + END C45220F ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,252 ---- + -- C45231A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT + -- RESULTS FOR PREDEFINED TYPE INTEGER (INCLUDING THE CASE IN WHICH THE + -- RELATIONAL OPERATORS ARE REDEFINED). + + -- SUBTESTS ARE: + -- (A). TESTS FOR RELATIONAL OPERATORS. + -- (B). TESTS FOR MEMBERSHIP OPERATORS. + -- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE + -- RELATIONAL OPERATORS ARE REDEFINED. + + + -- RJW 2/4/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45231A IS + + + BEGIN + + TEST ( "C45231A", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : INTEGER := IDENT_INT (1); + I2 : INTEGER := IDENT_INT (2); + CI2 : CONSTANT INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS INTEGER RANGE -10 .. 10; + + I1 : INTEGER := IDENT_INT (1); + I5 : INTEGER := IDENT_INT (5); + + CI2 : CONSTANT INTEGER := 2; + CI10 : CONSTANT INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST) + THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS INTEGER RANGE -10 .. 10; + + I1 : INTEGER := IDENT_INT (1); + I5 : INTEGER := IDENT_INT (5); + + CI2 : CONSTANT INTEGER := 2; + CI10 : CONSTANT INTEGER := 10; + + + FUNCTION ">" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) <= INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) < INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) >= INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER'POS (L) > INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT_INT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT_INT (-11) IN ST) + THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + + END C45231A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,265 ---- + -- C45231B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD + -- CORRECT RESULTS FOR PREDEFINED TYPE SHORT_INTEGER (INCLUDING + -- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + + -- SUBTESTS ARE: + -- (A). TESTS FOR RELATIONAL OPERATORS. + -- (B). TESTS FOR MEMBERSHIP OPERATORS. + -- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE + -- RELATIONAL OPERATORS ARE REDEFINED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH + -- SUPPORT SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- RJW 02/04/86 CREATED ORIGINAL TEST. + -- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45231B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ( "C45231B", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE SHORT_INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : SHORT_INTEGER := IDENT (1); + I2 : SHORT_INTEGER := IDENT (2); + CI2 : CONSTANT SHORT_INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10; + + I1 : SHORT_INTEGER := IDENT (1); + I5 : SHORT_INTEGER := IDENT (5); + + CI2 : CONSTANT SHORT_INTEGER := 2; + CI10 : CONSTANT SHORT_INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS SHORT_INTEGER RANGE -10 .. 10; + + I1 : SHORT_INTEGER := IDENT (1); + I5 : SHORT_INTEGER := IDENT (5); + + CI2 : CONSTANT SHORT_INTEGER := 2; + CI10 : CONSTANT SHORT_INTEGER := 10; + + + FUNCTION ">" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) <= SHORT_INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) < SHORT_INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) >= SHORT_INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : SHORT_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN SHORT_INTEGER'POS (L) > SHORT_INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + + END C45231B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,265 ---- + -- C45231C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD + -- CORRECT RESULTS FOR PREDEFINED TYPE LONG_INTEGER (INCLUDING + -- THE CASE IN WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + + -- SUBTESTS ARE: + -- (A). TESTS FOR RELATIONAL OPERATORS. + -- (B). TESTS FOR MEMBERSHIP OPERATORS. + -- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE + -- RELATIONAL OPERATORS ARE REDEFINED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- HISTORY: + -- RJW 02/04/86 CREATED ORIGINAL TEST. + -- DHH 01/08/87 ENTERED APPLICABILITY CRITERIA AND FORMATTED HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45231C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ( "C45231C", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE LONG_INTEGER " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : LONG_INTEGER := IDENT (1); + I2 : LONG_INTEGER := IDENT (2); + CI2 : CONSTANT LONG_INTEGER := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10; + + I1 : LONG_INTEGER := IDENT (1); + I5 : LONG_INTEGER := IDENT (5); + + CI2 : CONSTANT LONG_INTEGER := 2; + CI10 : CONSTANT LONG_INTEGER := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS LONG_INTEGER RANGE -10 .. 10; + + I1 : LONG_INTEGER := IDENT (1); + I5 : LONG_INTEGER := IDENT (5); + + CI2 : CONSTANT LONG_INTEGER := 2; + CI10 : CONSTANT LONG_INTEGER := 10; + + + FUNCTION ">" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) <= LONG_INTEGER'POS (R); + END; + + FUNCTION ">=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) < LONG_INTEGER'POS (R); + END; + + FUNCTION "<" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) >= LONG_INTEGER'POS (R); + END; + + FUNCTION "<=" ( L, R : LONG_INTEGER ) RETURN BOOLEAN IS + BEGIN + RETURN LONG_INTEGER'POS (L) > LONG_INTEGER'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + + END C45231C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231d.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231d.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45231d.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45231d.tst 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,274 ---- + -- C45231D.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE RELATIONAL AND MEMBERSHIP OPERATIONS YIELD CORRECT + -- RESULTS FOR PREDEFINED TYPE $NAME (INCLUDING THE CASE IN + -- WHICH THE RELATIONAL OPERATORS ARE REDEFINED). + + -- SUBTESTS ARE: + -- (A). TESTS FOR RELATIONAL OPERATORS. + -- (B). TESTS FOR MEMBERSHIP OPERATORS. + -- (C). TESTS FOR MEMBERSHIP OPERATORS IN THE CASE IN WHICH THE + -- RELATIONAL OPERATORS ARE REDEFINED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT A + -- PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER, OR + -- LONG_INTEGER. + + -- IF NO SUCH PREDEFINED INTEGER TYPE IS SUPPORTED, THEN THE + -- SPECIFICATION OF THE FUNCTION IDENT MUST BE REJECTED. + + -- MACRO SUBSTITUTION: + -- $NAME IS A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, + -- SHORT_INTEGER, AND LONG_INTEGER. + + -- HISTORY: + -- RJW 02/04/86 + -- THS 04/16/90 ADDED OMITTED "-- N/A => ERROR." MESSAGE AND + -- MODIFIED HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45231D IS + + FUNCTION IDENT (X : $NAME) + RETURN $NAME IS -- N/A => ERROR. + BEGIN + RETURN $NAME (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ( "C45231D", "CHECK THAT THE RELATIONAL AND " & + "MEMBERSHIP OPERATIONS YIELD CORRECT " & + "RESULTS FOR PREDEFINED TYPE $NAME " & + "(INCLUDING THE CASE IN WHICH THE " & + "RELATIONAL OPERATORS ARE REDEFINED)" ); + + DECLARE -- (A) + + I1A, I1B : $NAME := IDENT (1); + I2 : $NAME := IDENT (2); + CI2 : CONSTANT $NAME := 2; + + + BEGIN -- (A) + + IF (I2 = CI2) AND (NOT (I2 /= CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 1" ); + END IF; + + IF (I2 /= 4) AND (NOT (I2 = 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 2" ); + END IF; + + IF (I1A = I1B) AND (NOT (I1A /= I1B)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 3" ); + END IF; + + IF (I2 >= CI2) AND (NOT (I2 < CI2)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 4"); + END IF; + + IF (I2 <= 4) AND (NOT (I2 > 4)) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 5" ); + END IF; + + IF (I1A >= I1B) AND (I1A <= I1B) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 6" ); + END IF; + + IF ">" (LEFT => CI2, RIGHT => I1A) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 7" ); + END IF; + + IF "<" (LEFT => I1A, RIGHT => I2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 8" ); + END IF; + + IF ">=" (LEFT => I1A, RIGHT => I1A ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 9 "); + END IF; + + IF "<=" (LEFT => I1A, RIGHT => CI2) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 10 "); + END IF; + + IF "=" (LEFT => I1A, RIGHT => I1B ) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 11 "); + END IF; + + IF "/=" (LEFT => CI2, RIGHT => 4) THEN + NULL; + ELSE + FAILED ( "RELATIONAL TEST - 12 "); + END IF; + + END; -- (A) + + ---------------------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE ST IS $NAME RANGE -10 .. 10; + + I1 : $NAME := IDENT (1); + I5 : $NAME := IDENT (5); + + CI2 : CONSTANT $NAME := 2; + CI10 : CONSTANT $NAME := 10; + + + BEGIN -- (B) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - B.5" ); + END IF; + + END; -- (B) + + ------------------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE ST IS $NAME RANGE -10 .. 10; + + I1 : $NAME := IDENT (1); + I5 : $NAME := IDENT (5); + + CI2 : CONSTANT $NAME := 2; + CI10 : CONSTANT $NAME := 10; + + + FUNCTION ">" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) <= + $NAME'POS (R); + END; + + FUNCTION ">=" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) < + $NAME'POS (R); + END; + + FUNCTION "<" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) >= + $NAME'POS (R); + END; + + FUNCTION "<=" ( L, R : $NAME ) RETURN BOOLEAN IS + BEGIN + RETURN $NAME'POS (L) > + $NAME'POS (R); + END; + + BEGIN -- (C) + + IF (I1 IN ST) AND (I1 NOT IN CI2 .. CI10) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.1" ); + END IF; + + IF (IDENT (11) NOT IN ST) AND (CI2 IN I1 .. I5) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.2" ); + END IF; + + IF NOT (I5 NOT IN CI2 .. 10) AND NOT (IDENT (-11) IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.3" ); + END IF; + + IF NOT (I1 IN CI2 .. CI10) AND NOT (I5 NOT IN ST) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.4" ); + END IF; + + IF (I1 NOT IN I5 .. I1) AND NOT (I5 IN I5 .. I1) THEN + NULL; + ELSE + FAILED ( "MEMBERSHIP TEST - C.5" ); + END IF; + + END; -- (C) + + RESULT; + + END C45231D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45232b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45232b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45232b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45232b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- C45232B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NO EXCEPTION IS RAISED WHEN AN INTEGER LITERAL IN + -- A COMPARISON BELONGS TO THE BASE TYPE BUT IS OUTSIDE THE + -- SUBTYPE OF THE OTHER OPERAND. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- P. BRASHEAR 08/21/86 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT, SYSTEM; USE REPORT; + PROCEDURE C45232B IS + + BEGIN + + TEST ("C45232B", "NO EXCEPTION IS RAISED WHEN AN INTEGER " & + "LITERAL IN A COMPARISON BELONGS TO THE BASE " & + "TYPE BUT IS OUTSIDE THE SUBTYPE OF THE " & + "OTHER OPERAND"); + + DECLARE + + TYPE INT10 IS RANGE -10 .. 5; + + BEGIN + + IF 7 > INT10'(-10) THEN + COMMENT ("NO EXCEPTION RAISED FOR '7 > " & + "INT10'(-10)'"); + ELSE + FAILED ("WRONG RESULT FOR '7 > INT10'(-10)'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " & + "> INT10'(-10)'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '7 > " & + "INT10'(-10)'"); + END; + + DECLARE + + TYPE INT10 IS RANGE -10 .. 5; + + BEGIN + + IF 7 NOT IN INT10 THEN + COMMENT ("NO EXCEPTION RAISED FOR '7 NOT IN " & + "INT'"); + ELSE + FAILED ("WRONG RESULT FOR '7 NOT IN INT'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '7 " & + "NOT IN INT'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '7 NOT IN " & + "INT'"); + END; + + DECLARE + + TYPE INT700 IS RANGE -700 .. 500; + + BEGIN + IF 600 > INT700'(5) THEN + COMMENT ("NO EXCEPTION RAISED FOR '600 > " & + "INT700'(5)'"); + ELSE + FAILED ("WRONG RESULT FOR '600 > INT700'(5)'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " & + "> INT700'(5)'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '600 > " & + "INT700'(5)'"); + END; + + DECLARE + + TYPE INT700 IS RANGE -700 .. 500; + + BEGIN + + IF 600 NOT IN INT700 THEN + COMMENT ("NO EXCEPTION RAISED FOR '600 NOT IN " & + "INT700'"); + ELSE + FAILED ("WRONG RESULT FOR '600 NOT IN INT700'"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR '600 " & + "NOT IN INT700'"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR '600 NOT IN " & + "INT700'"); + END; + + RESULT; + + END C45232B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45242b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45242b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45242b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45242b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- C45242B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO EXCEPTION IS RAISED WHEN A FLOATING POINT LITERAL + -- OPERAND IN A COMPARISON OR A FLOATING POINT LITERAL LEFT OPERAND + -- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE + -- THE RANGE OF THE SUBTYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- PWB 09/04/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT, SYSTEM; USE REPORT; + PROCEDURE C45242B IS + + BEGIN + + TEST ("C45242B", "NO EXCEPTION IS RAISED WHEN A FLOATING " & + "LITERAL USED IN A COMPARISON OR AS THE " & + "LEFT OPERAND IN A MEMBERSHIP TEST " & + "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " & + "THE RANGE OF THE SUBTYPE"); + + DECLARE + N : FLOAT := FLOAT (IDENT_INT (1)); + SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N; + NUM : FLOAT_1 := N; + BEGIN -- PRE-DEFINED FLOAT COMPARISON + + IF EQUAL(3,3) THEN + NUM := FLOAT_1'(0.5); + END IF; + + IF 2.0 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " & + "COMPARISON"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " & + "FLOAT COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " & + "FLOAT COMPARISON"); + END; -- PRE-DEFINED FLOAT COMPARISON + + DECLARE + N : FLOAT := FLOAT (IDENT_INT (1)); + SUBTYPE FLOAT_1 IS FLOAT RANGE -1.0 .. N; + BEGIN -- PRE-DEFINED FLOAT MEMBERSHIP + + IF 2.0 IN FLOAT_1 THEN + FAILED ("WRONG RESULT FROM PRE-DEFINED FLOAT " & + "MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR PRE-DEFINED FLOAT " & + "MEMBERSHIP"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PRE-DEFINED " & + "FLOAT MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PRE-DEFINED " & + "FLOAT MEMBERSHIP"); + END; -- PRE-DEFINED FLOAT MEMBERSHIP + + DECLARE -- PRECISE FLOAT COMPARISON + TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS; + N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1)); + SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N; + NUM : SUB_FINE := N; + BEGIN + IF EQUAL(3,3) THEN + NUM := 0.25; + END IF; + + IF 0.75 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FINE_FLOAT COMPARISON"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FLOAT COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FLOAT COMPARISON"); + END; -- FINE_FLOAT COMPARISON + + DECLARE -- PRECISE FLOAT MEMBERSHIP + TYPE FINE_FLOAT IS DIGITS SYSTEM.MAX_DIGITS; + N : FINE_FLOAT := 0.5 * FINE_FLOAT (IDENT_INT (1)); + SUBTYPE SUB_FINE IS FINE_FLOAT RANGE -0.5 .. N; + BEGIN + + IF 0.75 IN SUB_FINE THEN + FAILED ("WRONG RESULT FROM FINE_FLOAT MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FINE_FLOAT " & + "MEMBERSHIP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FLOAT MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FLOAT MEMBERSHIP"); + END; -- FINE_FLOAT MEMBERSHIP + + RESULT; + + END C45242B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45251a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45251a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45251a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45251a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + -- C45251A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR RELATIONAL OPERATIONS ON FIXED POINT TYPES THE + -- FOLLOWING HOLD: + -- (A) A /= B IS THE SAME AS NOT (A = B). + -- (B) A < B IS THE SAME AS NOT (A >= B). + -- (C) A > B IS THE SAME AS NOT (A <= B). + -- (D) ADJACENT MODEL NUMBERS GIVE CORRECT RESULTS. + -- (E) NON-MODEL NUMBERS WITH DISTINCT MODEL INTERVALS GIVE + -- CORRECT RESULTS. + -- (F) CASE WHERE MODEL INTERVALS INTERSECT IN A SINGLE MODEL + -- NUMBER GIVES CORRECT RESULT. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- WRG 8/26/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45251A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + + BEGIN + + TEST ("C45251A", "CHECK RELATIONAL OPERATIONS FOR FIXED POINT " & + "TYPES - BASIC TYPES"); + + ------------------------------------------------------------------- + + DECLARE + A, B : LIKE_DURATION_M23 := 0.0; + C, D : DECIMAL_M4 := 0.0; + BEGIN + IF EQUAL (3, 3) THEN + A := 2#0.0000_0011#; -- JUST BELOW LIKE_DURATION'SMALL. + B := 2#0.0000_0101#; -- JUST ABOVE LIKE_DURATION'SMALL. + END IF; + + -- (A) + IF A /= B XOR NOT (A = B) THEN + FAILED ("A /= B IS NOT THE SAME AS NOT (A = B)"); + END IF; + + -- (B) + IF A < B XOR NOT (A >= B) THEN + FAILED ("A < B IS NOT THE SAME AS NOT (A >= B)"); + END IF; + + -- (C) + IF A > B XOR NOT (A <= B) THEN + FAILED ("A > B IS NOT THE SAME AS NOT (A <= B)"); + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + A := -(16#1_5180.00#); -- (-86_400.0) + B := -(16#1_517F.FC#); -- (-86_400.0 + 1.0/64) + + C := 64.0; -- DECIMAL_M4'SMALL. + D := 128.0; -- 2 * DECIMAL_M4'SMALL. + END IF; + IF "=" (LEFT => A, RIGHT => B) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (A = B)"); + END IF; + IF NOT "/=" (LEFT => C, RIGHT => D) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (C /= D)"); + END IF; + IF "<" (LEFT => B, RIGHT => A) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (B < A)"); + END IF; + IF ">" (LEFT => C, RIGHT => D) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (C > D)"); + END IF; + IF ">=" (LEFT => A, RIGHT => B) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (A >= B)"); + END IF; + IF "<=" (LEFT => D, RIGHT => C) THEN + FAILED ("ADJACENT MODEL NUMBERS GIVE INCORRECT RESULT " & + "- (D <= C)"); + END IF; + + -- (E) + IF EQUAL (3, 3) THEN + A := 0.02; -- INTERVAL IS 1.0/64 .. 2.0/64. + B := -0.02; -- INTERVAL IS -2.0/64 .. -1.0/64. + + C := 800.0; -- INTERVAL IS 768.0 .. 832.0. + D := 900.0; -- INTERVAL IS 896.0 .. 960.0. + END IF; + IF A = B THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (A = B)"); + END IF; + IF NOT (C /= D) THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (C /= D)"); + END IF; + IF A < B THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (A < B)"); + END IF; + IF C > D THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (C > D)"); + END IF; + IF B >= A THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (B >= A)"); + END IF; + IF D <= C THEN + FAILED ("NON-MODEL NUMBERS WITH DISTINCT MODEL " & + "INTERVALS GIVE INCORRECT RESULT - (D <= C)"); + END IF; + + -- (F) + IF EQUAL (3, 3) THEN + B := 0.035; -- INTERVAL IS 2.0/64 .. 3.0/64. + + C := 850.0; -- INTERVAL IS 832.0 .. 896.0. + END IF; + IF NOT (A <= B) THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (A <= B)"); + END IF; + IF A > B THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (A > B)"); + END IF; + IF NOT (D >= C) THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (D >= C)"); + END IF; + IF D < C THEN + FAILED ("COMPARISON OF NON-MODEL NUMBERS WITH ONE " & + "COMMON MODEL INTERVAL END-POINT GIVES " & + "INCORRECT RESULT - (D < C)"); + END IF; + END; + + ------------------------------------------------------------------- + + RESULT; + + END C45251A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45252a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45252a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45252a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45252a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,200 ---- + -- C45252A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR FIXED POINT TYPES, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED WHEN A LITERAL USED IN A COMPARISON OR + -- MEMBERSHIP OPERATION (AS THE FIRST OPERAND) DOES NOT BELONG TO THE + -- BASE TYPE. + -- + -- CHECK THAT NO EXCEPTION IS RAISED FOR A FIXED POINT RELATIONAL OR + -- MEMBERSHIP OPERATION IF LITERAL VALUES BELONG TO THE BASE TYPE. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- WRG 9/10/86 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45252A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + TYPE MIDDLE_M3 IS DELTA 0.5 RANGE 0.0 .. 2.5; + TYPE LIKE_DURATION_M23 IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + + BEGIN + + TEST ("C45252A", "CHECK RAISING OF EXCEPTIONS BY RELATIONAL " & + "OPERATIONS FOR FIXED POINT TYPES - BASIC TYPES"); + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32. + IF 2.9E9 <= LIKE_DURATION_M23'LAST THEN + FAILED ("2.9E9 <= LIKE_DURATION_M23'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """2.9E9 <= LIKE_DURATION_M23'LAST"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " & + """2.9E9 <= LIKE_DURATION_M23'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64. + IF 1.0E19 IN LIKE_DURATION_M23 THEN + FAILED ("1.0E19 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """1.0E19 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " & + """1.0E19 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 63 < 1.0E19 < 2.0 ** 64. + IF 1.0E19 <= MIDDLE_M3'LAST THEN + FAILED ("1.0E19 <= MIDDLE_M3'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """1.0E19 <= MIDDLE_M3'LAST"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY COMPARISON " & + """1.0E19 <= MIDDLE_M3'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 2.0 ** 31 < 2.9E9 < 2.0 ** 32. + IF 2.9E9 IN MIDDLE_M3 THEN + FAILED ("2.9E9 IN MIDDLE_M3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """2.9E9 IN MIDDLE_M3"""); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MEMBERSHIP TEST " & + """2.9E9 IN MIDDLE_M3"""); + END; + + ------------------------------------------------------------------- + + BEGIN + -- 3.5 IS A MODEL NUMBER OF THE TYPE MIDDLE_M3. + IF 3.5 <= MIDDLE_M3'LAST THEN + FAILED ("3.5 <= MIDDLE_M3'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """3.5 <= MIDDLE_M3'LAST"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY COMPARISON " & + """3.5 <= MIDDLE_M3'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 3.0 IN MIDDLE_M3 THEN + FAILED ("3.0 IN MIDDLE_M3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """3.0 IN MIDDLE_M3"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """3.0 IN MIDDLE_M3"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 86_450.0 <= LIKE_DURATION_M23'LAST THEN + FAILED ("86_450.0 <= LIKE_DURATION_M23'LAST"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY COMPARISON " & + """86_450.0 <= LIKE_DURATION_M23'LAST"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY COMPARISON " & + """86_450.0 <= LIKE_DURATION_M23'LAST"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF 86_500.0 IN LIKE_DURATION_M23 THEN + FAILED ("86_500.0 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """86_500.0 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """86_500.0 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + BEGIN + IF -86_450.0 IN LIKE_DURATION_M23 THEN + FAILED ("-86_450.0 IN LIKE_DURATION_M23"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED BY MEMBERSHIP TEST " & + """-86_450.0 IN LIKE_DURATION_M23"""); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED BY MEMBERSHIP TEST " & + """-86_450.0 IN LIKE_DURATION_M23"""); + END; + + ------------------------------------------------------------------- + + RESULT; + + END C45252A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45252b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45252b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45252b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45252b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C45252B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NO EXCEPTION IS RAISED WHEN A FIXED POINT LITERAL + -- OPERAND IN A COMPARISON OR A FIXED POINT LITERAL LEFT OPERAND + -- IN A MEMBERSHIP TEST BELONGS TO THE BASE TYPE BUT IS OUTSIDE + -- THE RANGE OF THE SUBTYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- PWB 09/04/86 CREATED ORIGINAL TEST. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT, SYSTEM; USE REPORT; + PROCEDURE C45252B IS + + BEGIN + + TEST ("C45252B", "NO EXCEPTION IS RAISED WHEN A FIXED " & + "LITERAL USED IN A COMPARISON OR AS THE " & + "LEFT OPERAND IN A MEMBERSHIP TEST " & + "BELONGS TO THE BASE TYPE BUT IS OUTSIDE " & + "THE RANGE OF THE SUBTYPE"); + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0; + SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0; + NUM : FIXED_1 := 0.0; + BEGIN -- FIXED COMPARISON + + IF EQUAL(3,3) THEN + NUM := FIXED_1'(0.5); + END IF; + + IF 2.0 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FIXED " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FIXED " & + "COMPARISON"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FIXED COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FIXED COMPARISON"); + END; -- FIXED COMPARISON + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE -10.0 .. 10.0; + SUBTYPE FIXED_1 IS FIXED RANGE -1.0 .. 1.0; + BEGIN -- FIXED MEMBERSHIP + + IF 2.0 IN FIXED_1 THEN + FAILED ("WRONG RESULT FROM FIXED " & + "MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FIXED " & + "MEMBERSHIP"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FIXED MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FIXED MEMBERSHIP"); + END; -- FIXED MEMBERSHIP + + DECLARE -- PRECISE FIXED COMPARISON + TYPE FINE_FIXED IS DELTA SYSTEM.FINE_DELTA RANGE -1.0 .. 1.0; + SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5; + NUM : SUB_FINE := 0.0; + BEGIN + IF EQUAL(3,3) THEN + NUM := 0.25; + END IF; + + IF 0.75 > NUM THEN + COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " & + "COMPARISON"); + ELSE + FAILED ("WRONG RESULT FROM FINE_FIXED COMPARISON"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FIXED COMPARISON"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FIXED COMPARISON"); + END; -- FINE_FIXED COMPARISON + + DECLARE -- PRECISE FIXED MEMBERSHIP + TYPE FINE_FIXED IS DIGITS SYSTEM.MAX_DIGITS; + SUBTYPE SUB_FINE IS FINE_FIXED RANGE -0.5 .. 0.5; + BEGIN + + IF 0.75 IN SUB_FINE THEN + FAILED ("WRONG RESULT FROM FINE_FIXED MEMBERSHIP"); + ELSE + COMMENT ("NO EXCEPTION RAISED FOR FINE_FIXED " & + "MEMBERSHIP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR " & + "FINE_FIXED MEMBERSHIP"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "FINE_FIXED MEMBERSHIP"); + END; -- FINE_FIXED MEMBERSHIP + + RESULT; + + END C45252B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45253a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45253a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45253a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45253a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C45253A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES "A IN T" AND "A NOT IN T" GIVE + -- APPROPRIATE RESULTS, EVEN WHEN USER-DEFINED ORDERING OPERATORS EXIST + -- FOR T. + + -- WRG 8/27/86 + -- JRL 06/12/96 Added function The_Delta. Eliminated static expressions + -- outside the base range of type T. + + WITH REPORT; USE REPORT; + PROCEDURE C45253A IS + + TYPE FIXED IS DELTA 0.25 RANGE 0.0 .. 1000.0; + TYPE T IS NEW FIXED; + + FUNCTION "<" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) >= FIXED (RIGHT); + END "<"; + + FUNCTION "<=" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) > FIXED (RIGHT); + END "<="; + + FUNCTION ">" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) <= FIXED (RIGHT); + END ">"; + + FUNCTION ">=" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN FIXED (LEFT) < FIXED (RIGHT); + END ">="; + + function The_Delta return T is + begin + return T'Delta; + end The_Delta; + + BEGIN + + TEST ("C45253A", "CHECK THAT FOR FIXED POINT TYPES ""A IN T"" " & + "AND ""A NOT IN T"" GIVE APPROPRIATE RESULTS, " & + "EVEN WHEN USER-DEFINED ORDERING OPERATORS " & + "EXIST FOR T"); + + IF IDENT_INT (1) * 0.0 NOT IN T THEN + FAILED ("0.0 NOT IN T"); + END IF; + + -- 06/12/96 IF IDENT_INT (1) * 1000.0 NOT IN T THEN + if Ident_Int (2) * 500.0 not in T then + FAILED ("1000.0 NOT IN T"); + END IF; + + -- 06/12/96 IF IDENT_INT (1) * (-0.25) IN T THEN + if Ident_Int (1) * (-The_Delta) in T then + FAILED ("-0.25 IN T"); + END IF; + + -- 06/12/96 IF IDENT_INT (1) * 1000.25 IN T THEN + if Ident_Int (2) * 500.0 + The_Delta in T then + FAILED ("1000.25 IN T"); + END IF; + + -- 06/12/96 IF IDENT_INT (1) * (-1000.0) IN T THEN + if Ident_Int (2) * (-500.0) in T then + FAILED ("-1000.0 IN T"); + END IF; + + RESULT; + + END C45253A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- C45262A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR + -- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF + -- INTEGERS. + + -- JWC 8/19/85 + -- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + + WITH REPORT; USE REPORT; + + PROCEDURE C45262A IS + BEGIN + TEST ("C45262A", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - INTEGER COMPONENTS"); + + DECLARE + + TYPE ARR IS ARRAY( INTEGER RANGE <> ) OF INTEGER; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1); + ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => 0); + ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 0); + ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => 1); + + BEGIN + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF NOT (ARR1 <= ARR2) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <="); + END IF; + + IF ARR1 > ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (ARR1, ARR2) ) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >="); + END IF; + + IF ARR3 < ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1"); + END IF; + + IF NOT ( ">" (ARR3, ARR1) ) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " & + "ARR1"); + END IF; + + IF NOT (ARR3 >= ARR1) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " & + "NULL ARR1"); + END IF; + + IF ARR3 < ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (ARR3, ARR4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3 >= ARR4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR3, ARR5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR3 <= ARR5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR3 > ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (ARR6 < ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF ARR6 > ARR7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF ARR6 < ARR8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR6 >= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF ARR8 < ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF ARR8 <= ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (ARR8 > ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR8 >= ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (ARR8 < ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR8 <= ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR8 > ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR8 >= ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + + END C45262A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,219 ---- + -- C45262B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR + -- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS STRING TYPES. + + -- JWC 9/9/85 + -- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + + WITH REPORT; USE REPORT; + + PROCEDURE C45262B IS + BEGIN + TEST ("C45262B", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - TYPE STRING"); + + DECLARE + + STRING1 : STRING(2 .. IDENT_INT(1)); + STRING2 : STRING(3 .. IDENT_INT(1)); + STRING3 : STRING(2 .. IDENT_INT(2)) := (IDENT_INT(2) => 'A'); + STRING4 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'A'); + STRING5 : STRING(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 'B'); + STRING6 : STRING(2 .. IDENT_INT(6)) := + (2 .. IDENT_INT(6) => 'A'); + STRING7 : STRING(1 .. 5) := (1 .. 4 => 'A', 5 => 'B'); + STRING8 : STRING(1 .. IDENT_INT(5)) := + (1 .. IDENT_INT(5) => 'A'); + STRING9 : STRING(1 .. IDENT_INT(4)) := + (1 .. IDENT_INT(4) => 'A'); + STRINGA : STRING(1 .. IDENT_INT(4)) := + (1 .. IDENT_INT(4) => 'B'); + + BEGIN + IF STRING1 < STRING2 THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - <"); + END IF; + + IF NOT (STRING1 <= STRING2) THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " & + "<="); + END IF; + + IF STRING1 > STRING2 THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (STRING1, STRING2) ) THEN + FAILED ("NULL ARRAYS STRING1 AND STRING2 NOT EQUAL - " & + ">="); + END IF; + + IF STRING3 < STRING1 THEN + FAILED ("NON-NULL ARRAY STRING3 LESS THAN NULL STRING1"); + END IF; + + IF STRING3 <= STRING1 THEN + FAILED ("NON-NULL ARRAY STRING3 LESS THAN EQUAL NULL " & + "STRING1"); + END IF; + + IF NOT ( ">" (STRING3, STRING1) ) THEN + FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN NULL " & + "STRING1"); + END IF; + + IF NOT (STRING3 >= STRING1) THEN + FAILED ("NON-NULL ARRAY STRING3 NOT GREATER THAN " & + "EQUAL NULL STRING1"); + END IF; + + IF STRING3 < STRING4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (STRING3, STRING4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF STRING3 > STRING4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING3 >= STRING4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (STRING3, STRING5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING3 <= STRING5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF STRING3 > STRING5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF STRING3 >= STRING5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (STRING6 < STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING6 <= STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF STRING6 > STRING7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => STRING6, RIGHT => STRING7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF STRING6 < STRING8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (STRING6 <= STRING8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => STRING8, LEFT => STRING6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING6 >= STRING8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF STRING8 < STRING9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF STRING8 <= STRING9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (STRING8 > STRING9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (STRING8 >= STRING9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (STRING8 < STRINGA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (STRING8 <= STRINGA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF STRING8 > STRINGA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF STRING8 >= STRINGA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + + END C45262B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- C45262C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR + -- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST CHECKS ARRAYS OF + -- AN ENUMERATION TYPE. + + -- JWC 8/19/85 + -- JRK 6/24/86 FIXED SPELLING IN FAILURE MESSAGE. + + WITH REPORT; USE REPORT; + + PROCEDURE C45262C IS + BEGIN + TEST ("C45262C", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES - ENUMERATED COMPONENTS"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5; + TYPE ENUM IS (E0, E1); + TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF ENUM; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => E0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => E1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => E0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => E0, 4 => E1); + ARR8 : ARR(0 .. IDENT_INT(4)) := (0 .. IDENT_INT(4) => E0); + ARR9 : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E0); + ARRA : ARR(0 .. IDENT_INT(3)) := (0 .. IDENT_INT(3) => E1); + + BEGIN + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF NOT (ARR1 <= ARR2) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <="); + END IF; + + IF ARR1 > ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >"); + END IF; + + IF NOT ( ">=" (ARR1, ARR2) ) THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - >="); + END IF; + + IF ARR3 < ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN NULL ARR1"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL ARR1"); + END IF; + + IF NOT ( ">" (ARR3, ARR1) ) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN NULL " & + "ARR1"); + END IF; + + IF NOT (ARR3 >= ARR1) THEN + FAILED ("NON-NULL ARRAY ARR3 NOT GREATER THAN EQUAL " & + "NULL ARR1"); + END IF; + + IF ARR3 < ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF NOT ( "<=" (ARR3, ARR4) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3 >= ARR4) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR3, ARR5) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR3 <= ARR5) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR3 > ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT (ARR6 < ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + "<="); + END IF; + + IF ARR6 > ARR7 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - >"); + END IF; + + IF ">=" (LEFT => ARR6, RIGHT => ARR7) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - " & + ">="); + END IF; + + IF ARR6 < ARR8 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <"); + END IF; + + IF NOT (ARR6 <= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - <="); + END IF; + + IF ">" (RIGHT => ARR8, LEFT => ARR6) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR6 >= ARR8) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS EQUAL - >="); + END IF; + + IF ARR8 < ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <"); + END IF; + + IF ARR8 <= ARR9 THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - <="); + END IF; + + IF NOT (ARR8 > ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR8 >= ARR9) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >="); + END IF; + + IF NOT (ARR8 < ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <"); + END IF; + + IF NOT (ARR8 <= ARRA) THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - <="); + END IF; + + IF ARR8 > ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >"); + END IF; + + IF ARR8 >= ARRA THEN + FAILED ("DIFFERENT NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + END; + + RESULT; + + END C45262C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45262d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45262d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C45262D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ORDERING COMPARISONS YIELD CORRECT RESULTS FOR + -- ONE-DIMENSIONAL DISCRETE ARRAY TYPES. THIS TEST USES + -- USER-DEFINED ORDERING OPERATORS FOR THE DISCRETE COMPONENT TYPE. + + -- JWC 8/19/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45262D IS + + FUNCTION "<"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD.">="(LEFT, RIGHT); + END "<"; + + FUNCTION "<="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD.">"(LEFT, RIGHT); + END "<="; + + FUNCTION ">"(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD."<="(LEFT, RIGHT); + END ">"; + + FUNCTION ">="(LEFT, RIGHT : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN STANDARD."<"(LEFT, RIGHT); + END ">="; + + BEGIN + TEST ("C45262D", "ORDERING COMPARISONS OF ONE-DIMENSIONAL " & + "DISCRETE ARRAY TYPES"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 5; + TYPE ARR IS ARRAY( SUBINT RANGE <> ) OF INTEGER; + ARR1 : ARR(1 .. IDENT_INT(0)); + ARR2 : ARR(2 .. IDENT_INT(0)); + ARR3 : ARR(1 .. IDENT_INT(1)) := (IDENT_INT(1) => 0); + ARR4 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 0); + ARR5 : ARR(0 .. IDENT_INT(0)) := (IDENT_INT(0) => 1); + ARR6 : ARR(1 .. IDENT_INT(5)) := (1 .. IDENT_INT(5) => 0); + ARR7 : ARR(0 .. 4) := (0 .. 3 => 0, 4 => 1); + + BEGIN + + IF ARR1 < ARR2 THEN + FAILED ("NULL ARRAYS ARR1 AND ARR2 NOT EQUAL - <"); + END IF; + + IF ARR3 <= ARR1 THEN + FAILED ("NON-NULL ARRAY ARR3 LESS THAN EQUAL NULL " & + "ARR1"); + END IF; + + IF ARR3 > ARR4 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS EQUAL - >"); + END IF; + + IF NOT (ARR3(1) > ARR4(0)) THEN + FAILED ("REDEFINED COMPONENT COMPARISON - >"); + END IF; + + IF ARR3 >= ARR5 THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "COMPONENTS NOT EQUAL - >="); + END IF; + + IF NOT ( "<" (ARR6, ARR7) ) THEN + FAILED ("DIFFERENT BOUNDS, SAME NUMBER OF COMPONENTS, " & + "MULTIPLE COMPONENTS, COMPONENTS NOT EQUAL - <"); + END IF; + + END; + + RESULT; + + END C45262D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C45264A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE + -- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES. + -- CASE THAT CHECKS THAT TWO NULL ARRAYS OF THE SAME TYPE ARE + -- ALWAYS EQUAL. + + -- PK 02/21/84 + -- EG 05/30/84 + + WITH REPORT; + USE REPORT; + + PROCEDURE C45264A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + BEGIN + + TEST("C45264A","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + DECLARE + + TYPE A1 IS ARRAY(INT RANGE <>) OF INTEGER; + + BEGIN + + IF A1'(1 .. IDENT_INT(2) => IDENT_INT(1)) /= + A1'(IDENT_INT(2) .. 3 => IDENT_INT(1)) THEN + FAILED ("A1 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A1 - EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE A2 IS ARRAY(INT RANGE <>, INT RANGE <>) OF INTEGER; + + BEGIN + IF A2'(1 .. IDENT_INT(2) => + (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1))) /= + A2'(IDENT_INT(2) .. 3 => + (IDENT_INT(2) .. IDENT_INT(1) => IDENT_INT(1))) THEN + FAILED ("A2 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A2 - EXCEPTION RAISED"); + + END; + + DECLARE + + TYPE A3 IS + ARRAY(INT RANGE <>, INT RANGE <>, INT RANGE <>) OF + INTEGER; + + BEGIN + + IF A3'(1 .. IDENT_INT(2) => + (IDENT_INT(1) .. IDENT_INT(3) => + (IDENT_INT(3) .. IDENT_INT(2) => IDENT_INT(1)))) /= + A3'(IDENT_INT(1) .. 3 => + (IDENT_INT(2) .. IDENT_INT(1) => + (IDENT_INT(1) .. IDENT_INT(2) => IDENT_INT(1)))) THEN + FAILED ("A3 - ARRAYS NOT EQUAL"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("A3 - EXCEPTION RAISED"); + + END; + + RESULT; + + END C45264A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C45264B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY COMPARISONS YIELD CORRECT RESULTS FOR ONE + -- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES. + -- THIS TEST CHECKS THE CASE WHERE THE ARRAY HAS A BOUND THAT DEPENDS ON + -- A DISCRIMINANT WITH DEFAULTS. + + -- JWC 11/18/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45264B IS + + BEGIN + + TEST("C45264B","CHECK THAT EQUALITY COMPARISONS YIELD CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + DECLARE + + SUBTYPE SUBINT IS INTEGER RANGE 1 .. 5; + TYPE REC (DISC : SUBINT := 1) IS + RECORD + COMP : STRING(IDENT_INT(3) .. DISC); + END RECORD; + TYPE ARR IS ARRAY (1 .. 3) OF REC; + + A1, A2 : ARR; + + BEGIN + + IF A1 /= A2 THEN + FAILED ("NULL ARRAYS, RESULT NOT EQUAL"); + END IF; + + A1(2) := (5, "ABC"); + + IF A1 = A2 THEN + FAILED ("NON-NULL ARRAY AND NULL ARRAY, RESULT EQUAL"); + END IF; + + A2(2) := (5, "ABD"); + + IF A1 = A2 THEN + FAILED ("ARRAYS DIFFER BY LAST ELEMENT, RESULT EQUAL"); + END IF; + + A2(2) := (4, "AB"); + + IF A1 = A2 THEN + FAILED ("ARRAYS OF DIFFERENT LENGTH, RESULT EQUAL"); + END IF; + + A1(2) := (4, "AB"); + + IF A1 /= A2 THEN + FAILED ("DISCRIMINANTS AND COMPONENTS ARE THE SAME, " & + "RESULT NOT EQUAL"); + END IF; + + END; + + RESULT; + + END C45264B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45264c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45264c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45264C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT COMPARING ARRAYS OF DIFFERENT LENGTHS DOES NOT RAISE AN + -- EXCEPTION. + + -- TBN 7/21/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45264C IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>, + INT RANGE <>) OF INTEGER; + + ARRAY_1 : ARRAY_TYPE_1 (1..5) := (1..5 => 1); + ARRAY_2 : ARRAY_TYPE_1 (1..7) := (1..7 => 1); + ARRAY_3 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 1)); + ARRAY_4 : ARRAY_TYPE_2 (1..2, 1..3) := (1..2 => (1..3 => 1)); + ARRAY_5 : ARRAY_TYPE_3 (1..2, 1..3, 1..2) := (1..2 => (1..3 => + (1..2 => 2))); + ARRAY_6 : ARRAY_TYPE_3 (1..1, 1..2, 1..3) := (1..1 => (1..2 => + (1..3 => 2))); + ARRAY_7 : ARRAY_TYPE_2 (1..5, 1..4) := (1..5 => (1..4 => 3)); + ARRAY_8 : ARRAY_TYPE_2 (1..5, 1..3) := (1..5 => (1..3 => 3)); + ARRAY_9 : ARRAY_TYPE_2 (1..3, 1..2) := (1..3 => (1..2 => 4)); + ARRAY_10 : ARRAY_TYPE_2 (1..2, 1..2) := (1..2 => (1..2 => 4)); + + BEGIN + TEST ("C45264C", "CHECK THAT COMPARING ARRAYS OF DIFFERENT " & + "LENGTHS DOES NOT RAISE AN EXCEPTION"); + + BEGIN -- (A) + IF "=" (ARRAY_1 (1..INTEGER'FIRST), ARRAY_2) THEN + FAILED ("INCORRECT RESULTS FROM COMPARING ONE " & + "DIMENSIONAL ARRAYS - 1"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 1"); + END; -- (A) + + BEGIN -- (B) + IF ARRAY_1 /= ARRAY_2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING ONE " & + "DIMENSIONAL ARRAYS - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 2"); + END; -- (B) + + BEGIN -- (C) + IF ARRAY_3 = ARRAY_4 THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 3"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 3"); + END; -- (C) + + BEGIN -- (D) + IF "/=" (ARRAY_3, ARRAY_4) THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" & + "DIMENSIONAL ARRAYS - 4"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; -- (D) + + BEGIN -- (E) + IF "=" (ARRAY_5, ARRAY_6) THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 5"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 5"); + END; -- (E) + + BEGIN -- (F) + IF ARRAY_6 /= ARRAY_5 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULT-" & + "DIMENSIONAL ARRAYS - 6"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 6"); + END; -- (F) + + BEGIN -- (G) + IF ARRAY_7 = ARRAY_8 THEN + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 7"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 7"); + END; -- (G) + + BEGIN -- (H) + IF ARRAY_9 /= ARRAY_10 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FROM COMPARING MULTI-" & + "DIMENSIONAL ARRAYS - 8"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED EVALUATING - 8"); + END; -- (H) + + RESULT; + END C45264C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45265a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45265a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45265a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45265a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- C45265A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MEMBERSHIP TESTS YIELD THE CORRECT RESULTS FOR ONE + -- DIMENSIONAL AND MULTI-DIMENSIONAL ARRAY TYPES WHEN: + -- A) THE SUBTYPE INDICATION DENOTES AN UNCONSTRAINED ARRAY. + -- B) THE SUBTYPE INDICATION DENOTES A CONSTRAINED ARRAY. + + -- TBN 7/22/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45265A IS + + PACKAGE P IS + TYPE KEY IS LIMITED PRIVATE; + PRIVATE + TYPE KEY IS NEW NATURAL; + END P; + + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE ARRAY_TYPE_1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_2 IS ARRAY (INT RANGE <>, INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_3 IS ARRAY (INT RANGE <>, INT RANGE <>, + INT RANGE <>) OF INTEGER; + TYPE ARRAY_TYPE_4 IS ARRAY (INT RANGE <>) OF P.KEY; + TYPE ARRAY_TYPE_5 IS ARRAY (INT RANGE <>, INT RANGE <>) OF P.KEY; + + SUBTYPE ARRAY_SUB1 IS ARRAY_TYPE_1; + SUBTYPE ARRAY_SUB2 IS ARRAY_TYPE_2; + SUBTYPE ARRAY_SUB3 IS ARRAY_TYPE_3; + SUBTYPE ARRAY_SUB4 IS ARRAY_TYPE_4; + SUBTYPE ARRAY_SUB5 IS ARRAY_TYPE_5; + SUBTYPE CON_ARRAY1 IS ARRAY_TYPE_1 (1..5); + SUBTYPE CON_ARRAY2 IS ARRAY_TYPE_2 (1..2, 1..2); + SUBTYPE CON_ARRAY3 IS ARRAY_TYPE_3 (1..2, 1..3, 1..4); + SUBTYPE CON_ARRAY4 IS ARRAY_TYPE_4 (1..4); + SUBTYPE CON_ARRAY5 IS ARRAY_TYPE_5 (1..2, 1..3); + SUBTYPE NULL_ARRAY1 IS ARRAY_TYPE_1 (2 .. 1); + + ARRAY1 : ARRAY_TYPE_1 (1..10); + ARRAY2 : ARRAY_SUB1 (11..20); + ARRAY3 : ARRAY_TYPE_2 (1..4, 1..3); + ARRAY4 : ARRAY_SUB2 (5..7, 5..8); + ARRAY5 : ARRAY_TYPE_3 (1..2, 1..3, 1..4); + ARRAY6 : ARRAY_SUB3 (1..3, 1..2, 1..4); + NULL_ARRAY_1 : ARRAY_TYPE_1 (3..2); + NULL_ARRAY_2 : ARRAY_SUB1 (2..1); + ARRAY7 : ARRAY_TYPE_1 (1..10) := (1..10 => 7); + ARRAY8 : CON_ARRAY1 := (1..5 => 8); + ARRAY9 : ARRAY_TYPE_2 (1..10, 1..10) := (1..10 => (1..10 => 9)); + ARRAY10 : CON_ARRAY2 := (1..2 => (1..2 => 10)); + ARRAY11 : ARRAY_TYPE_3 (1..10, 1..10, 1..10) := (1..10 => + (1..10 => (1..10 => 11))); + ARRAY12 : CON_ARRAY3 := (1..2 => (1..3 => (1..4 => 12))); + ARRAY13 : ARRAY_TYPE_4 (1..2); + ARRAY14 : ARRAY_SUB4 (1..5); + ARRAY15 : ARRAY_TYPE_4 (1..6); + ARRAY16 : CON_ARRAY4; + ARRAY17 : ARRAY_TYPE_5 (1..3, 1..2); + ARRAY18 : ARRAY_SUB5 (1..2, 1..3); + ARRAY19 : ARRAY_TYPE_5 (1..4, 1..3); + ARRAY20 : CON_ARRAY5; + + BEGIN + TEST ("C45265A", "CHECK THAT MEMBERSHIP TESTS YIELD THE CORRECT " & + "RESULTS FOR ONE DIMENSIONAL AND MULTI-" & + "DIMENSIONAL ARRAY TYPES"); + + ARRAY1 := (ARRAY1'RANGE => 1); + ARRAY2 := (ARRAY2'RANGE => 2); + ARRAY3 := (ARRAY3'RANGE(1) => (ARRAY3'RANGE(2) => 3)); + ARRAY4 := (ARRAY4'RANGE(1) => (ARRAY4'RANGE(2) => 4)); + ARRAY5 := (ARRAY5'RANGE(1) => (ARRAY5'RANGE(2) => + (ARRAY5'RANGE(3) => 5))); + ARRAY6 := (ARRAY6'RANGE(1) => (ARRAY6'RANGE(2) => + (ARRAY6'RANGE(3) => 6))); + + IF ARRAY1 IN ARRAY_SUB1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 1"); + END IF; + IF ARRAY2 NOT IN ARRAY_SUB1 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 2"); + END IF; + + IF ARRAY3 IN ARRAY_SUB2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 3"); + END IF; + IF ARRAY4 NOT IN ARRAY_SUB2 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 4"); + END IF; + + IF ARRAY5 IN ARRAY_SUB3 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 5"); + END IF; + IF ARRAY6 NOT IN ARRAY_SUB3 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 6"); + END IF; + + IF NULL_ARRAY_1 IN ARRAY_SUB1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 7"); + END IF; + IF NULL_ARRAY_2 NOT IN ARRAY_SUB1 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 8"); + END IF; + + IF ARRAY7 IN CON_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 9"); + END IF; + IF ARRAY8 NOT IN CON_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 10"); + END IF; + + IF ARRAY9 IN CON_ARRAY2 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 11"); + END IF; + IF ARRAY10 NOT IN CON_ARRAY2 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 12"); + END IF; + + IF ARRAY11 IN CON_ARRAY3 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 13"); + END IF; + IF ARRAY12 NOT IN CON_ARRAY3 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 14"); + END IF; + + IF ARRAY13 IN ARRAY_SUB4 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 15"); + END IF; + IF ARRAY14 NOT IN ARRAY_SUB4 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 16"); + END IF; + + IF ARRAY15 IN CON_ARRAY4 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 17"); + END IF; + IF ARRAY16 NOT IN CON_ARRAY4 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 18"); + END IF; + + IF ARRAY17 IN ARRAY_SUB5 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 19"); + END IF; + IF ARRAY18 NOT IN ARRAY_SUB5 THEN + FAILED ("INCORRECT RESULTS FOR UNCONSTRAINED ARRAYS - 20"); + END IF; + + IF ARRAY19 IN CON_ARRAY5 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 21"); + END IF; + IF ARRAY20 NOT IN CON_ARRAY5 THEN + FAILED ("INCORRECT RESULTS FOR CONSTRAINED ARRAYS - 22"); + END IF; + + IF NULL_ARRAY_1 IN NULL_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 23"); + END IF; + IF NULL_ARRAY_2 NOT IN NULL_ARRAY1 THEN + FAILED ("INCORRECT RESULTS FOR NULL ARRAYS - 24"); + END IF; + + RESULT; + END C45265A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45271a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45271a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45271a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45271a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C45271A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR + -- RECORDS WHOSE COMPONENTS DO NOT HAVE CHANGEABLE DISCRIMINANTS. + + -- TBN 8/6/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45271A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE ARRAY_BOOL IS ARRAY (1 .. 5) OF BOOLEAN; + + TYPE REC_TYPE1 IS + RECORD + BOOL : ARRAY_BOOL; + A : INTEGER; + END RECORD; + + TYPE REC_TYPE2 (LEN : INT := 3) IS + RECORD + A : STRING (1 .. LEN); + END RECORD; + + TYPE REC_TYPE3 (NUM : INT := 1) IS + RECORD + A : REC_TYPE1; + END RECORD; + + REC1, REC2 : REC_TYPE1 := (A => 2, OTHERS => (OTHERS => TRUE)); + REC3, REC4 : REC_TYPE2 (5) := (5, "WHERE"); + REC5, REC6 : REC_TYPE2; + REC7, REC8 : REC_TYPE3; + REC9, REC10 : REC_TYPE3 (3) := (NUM => 3, A => + (A => 5, BOOL => (OTHERS => FALSE))); + + BEGIN + TEST ("C45271A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORDS WHOSE " & + "COMPONENTS DO NOT HAVE CHANGEABLE " & + "DISCRIMINANTS"); + + IF "/=" (LEFT => REC1, RIGHT => REC2) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + REC1.A := IDENT_INT(1); + IF "=" (LEFT => REC2, RIGHT => REC1) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + IF REC3 /= REC4 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + REC4.A := IDENT_STR("12345"); + IF REC3 = REC4 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + REC5.A := IDENT_STR("WHO"); + REC6.A := IDENT_STR("WHY"); + IF REC5 = REC6 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + REC5.A := "WHY"; + IF REC6 /= REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + + REC7.A.A := IDENT_INT(1); + REC7.A.BOOL := (OTHERS => IDENT_BOOL(TRUE)); + REC8.A.A := 1; + REC8.A.BOOL := (OTHERS => TRUE); + IF REC7 /= REC8 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + REC8.A.BOOL := (OTHERS => IDENT_BOOL(FALSE)); + IF REC8 = REC7 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 8"); + END IF; + + IF "/=" (LEFT => REC9, RIGHT => REC10) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 9"); + END IF; + REC9.A.A := IDENT_INT(1); + IF "=" (LEFT => REC9, RIGHT => REC10) THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 10"); + END IF; + + RESULT; + END C45271A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45272a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45272a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45272a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45272a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C45272A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR + -- RECORDS WHOSE COMPONENTS HAVE CHANGEABLE DISCRIMINANTS, INCLUDING + -- RECORDS DESIGNATED BY ACCESS VALUES. + + -- TBN 8/7/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45272A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 20; + TYPE VARSTR (LEN : INT := 0) IS + RECORD + VAL : STRING (1..LEN); + END RECORD; + TYPE VARREC IS + RECORD + A, B : VARSTR; + END RECORD; + + TYPE CELL2; + TYPE LINK IS ACCESS CELL2; + TYPE CELL1 (NAM_LEN : INT := 0) IS + RECORD + NAME : STRING (1..NAM_LEN); + END RECORD; + TYPE CELL2 IS + RECORD + ONE : CELL1; + TWO : CELL1; + NEW_LINK : LINK; + END RECORD; + + X, Y : VARREC; + FRONT : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL); + BACK : LINK := NEW CELL2'((5, "XXYZZ"), (5, "YYYZZ"), NULL); + + BEGIN + TEST ("C45272A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORDS WHOSE " & + "COMPONENTS HAVE CHANGEABLE DISCRIMINANTS"); + + X := ((5, "AAAXX"), (5, "BBBYY")); + Y := ((5, "AAAZZ"), (5, "BBBYY")); + IF X = Y THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + + X.A := (3, "HHH"); + Y.A := (IDENT_INT(3), IDENT_STR("HHH")); + IF X /= Y THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + + BACK.NEW_LINK := FRONT; + IF FRONT.ALL = BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + FRONT.NEW_LINK := FRONT; + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + + FRONT.ONE := (5, "XXXXX"); + BACK.ONE := (5, "ZZZZZ"); + IF FRONT.ALL = BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + + FRONT.ONE := (3, "XXX"); + BACK.ONE := (3, "XXX"); + IF FRONT.ALL /= BACK.ALL THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + + RESULT; + END C45272A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45273a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45273a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45273a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45273a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C45273A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR + -- RECORD OBJECTS HAVING DIFFERENT VALUES OF THE 'CONSTRAINED + -- ATTRIBUTE. + + -- HISTORY: + -- TBN 08/07/86 CREATED ORIGINAL TEST. + -- VCL 10/27/87 MODIFIED THIS HEADER; RELOCATED THE CALL TO + -- REPORT.TEST SO THAT IT COMES BEFORE ANY + -- DECLARATIONS; CHANGED THE 'ELSEIF' CONDITION IN + -- THE PROCEDURE 'PROC' SO THAT IT REFERS TO THE + -- FORMAL PARAMETERS. + + WITH REPORT; USE REPORT; + PROCEDURE C45273A IS + BEGIN + TEST ("C45273A", "EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR RECORD OBJECTS HAVING " & + "DIFFERENT VALUES OF THE 'CONSTRAINED' " & + " ATTRIBUTE"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 20; + TYPE REC_TYPE1 IS + RECORD + A : INTEGER; + END RECORD; + + TYPE REC_TYPE2 (LEN : INT := 3) IS + RECORD + A : STRING (1 .. LEN); + END RECORD; + + TYPE REC_TYPE3 (NUM : INT := 1) IS + RECORD + A : REC_TYPE1; + END RECORD; + + REC1 : REC_TYPE2 (3) := (3, "WHO"); + REC2 : REC_TYPE2; + REC3 : REC_TYPE2 (5) := (5, "WHERE"); + REC4 : REC_TYPE3; + REC5 : REC_TYPE3 (1) := (1, A => (A => 5)); + + PROCEDURE PROC (PREC1 : REC_TYPE2; + PREC2 : IN OUT REC_TYPE2) IS + BEGIN + IF NOT (PREC1'CONSTRAINED) OR PREC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 6"); + ELSIF PREC1 /= PREC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 6"); + END IF; + PREC2.A := "WHO"; + END PROC; + + BEGIN + REC2.A := "WHO"; + IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 1"); + ELSIF REC1 /= REC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 1"); + END IF; + + IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 2"); + ELSIF REC2 = REC3 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 2"); + END IF; + + REC2 := (5, "WHERE"); + IF REC2'CONSTRAINED OR NOT (REC3'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 3"); + ELSIF REC2 /= REC3 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 3"); + END IF; + + REC4.A.A := 5; + IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 4"); + ELSIF REC4 /= REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 4"); + END IF; + + REC5.A := (A => 6); + IF REC4'CONSTRAINED OR NOT (REC5'CONSTRAINED) THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 5"); + ELSIF REC4 = REC5 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 5"); + END IF; + + REC1.A := "WHY"; + REC2 := (3, "WHY"); + PROC (REC1, REC2); + IF NOT (REC1'CONSTRAINED) OR REC2'CONSTRAINED THEN + FAILED ("INCORRECT RESULTS FROM 'CONSTRAINED " & + "ATTRIBUTE - 7"); + ELSIF REC1 = REC2 THEN + FAILED ("INCORRECT RESULTS FOR RECORDS - 7"); + END IF; + END; + + RESULT; + END C45273A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,222 ---- + -- C45274A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS + -- YIELDS TRUE (RESP. FALSE ) FOR + -- + -->> * RECORD TYPES WITHOUT DISCRIMINANTS; + -->> * PRIVATE TYPES WITHOUT DISCRIMINANTS; + -->> * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS; + -- * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS; + -- * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS; + -- * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + + -- RM 3/01/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C45274A IS + + + BEGIN + + TEST ( "C45274A" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " FOR RECORD TYPES WITHOUT DISCRIMINANTS," & + " PRIVATE TYPES WITHOUT DISCRIMINANTS, AND" & + " LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS"); + + + ------------------------------------------------------------------- + ----------------- RECORD TYPES WITHOUT DISCRIMINANTS ------------ + + DECLARE + + TYPE REC IS + RECORD + A , B : INTEGER ; + END RECORD ; + + X : REC := ( 19 , 91 ); + + BEGIN + + IF X IN REC THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1" ); + END IF; + + IF X NOT IN REC THEN + FAILED( "WRONG VALUE: 'NOT IN', 1" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ----------------- PRIVATE TYPES WITHOUT DISCRIMINANTS ----------- + + DECLARE + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : PRIV ; + + PACKAGE BODY P IS + BEGIN + X := ( 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIV THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIV THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + --------- LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS ----------- + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PRIVATE + TYPE LP IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : LP ; + + PACKAGE BODY P IS + BEGIN + X := ( 19 , 91 ); + END P ; + + BEGIN + + IF X IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3" ); + END IF; + + IF X NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PRIVATE + TYPE LP IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + Y : LP ; + + -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE + BEGIN + + IF Y IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3BIS" ); + END IF; + + IF Y NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3BIS" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " & + "( 'NOT IN' ) RAISED AN EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + + END C45274A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- C45274B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) ALWAYS + -- YIELDS TRUE (RESP. FALSE ) FOR + -- + -- * RECORD TYPES WITHOUT DISCRIMINANTS; + -- * PRIVATE TYPES WITHOUT DISCRIMINANTS; + -- * LIMITED PRIVATE TYPES WITHOUT DISCRIMINANTS; + -->> * (UNCONSTRAINED) RECORD TYPES WITH DISCRIMINANTS; + -->> * (UNCONSTRAINED) PRIVATE TYPES WITH DISCRIMINANTS; + -->> * (UNCONSTRAINED) LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + + -- RM 3/03/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C45274B IS + + + BEGIN + + TEST ( "C45274B" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " FOR UNCONSTRAINED TYPES WITH DISCRIMINANTS" ); + + + ------------------------------------------------------------------- + -------- UNCONSTRAINED RECORD TYPES WITH DISCRIMINANTS ---------- + + DECLARE + + TYPE REC ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + X : REC(FALSE) := ( FALSE , 19 , 81 ); + + TYPE REC0 ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + Y : REC0 := ( TRUE , 19 , 81 ); + + BEGIN + + IF X IN REC THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1A" ); + END IF; + + IF Y NOT IN REC0 THEN + FAILED( "WRONG VALUE: 'NOT IN', 1B" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ------- UNCONSTRAINED PRIVATE TYPES WITH DISCRIMINANTS ---------- + + DECLARE + + PACKAGE P IS + TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE; + PRIVATE + TYPE PRIV ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : PRIV(FALSE) ; + + PACKAGE BODY P IS + BEGIN + X := ( FALSE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIV THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIV THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + --------- UNCONSTRAINED LIM. PRIV. TYPES WITH DISCRIM. ---------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + X : LP(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( TRUE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3" ); + END IF; + + IF X NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + Y : LP(TRUE) ; + + -- CHECK THAT NO EXCEPTION FOR UNINITIALIZED VARIABLE + BEGIN + + IF Y IN LP THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 3BIS" ); + END IF; + + IF Y NOT IN LP THEN + FAILED( "WRONG VALUE: 'NOT IN', 3BIS" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3BIS - UNINITIALIZED VARIABLE - 'IN' " & + "( 'NOT IN' ) RAISED AN EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + + END C45274B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45274c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45274c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- C45274C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE MEMBERSHIP OPERATOR IN ( NOT IN ) + -- YIELDS TRUE (RESP. FALSE ) IF THE DISCRIMINANTS OF THE LEFT + -- VALUE EQUAL THE DISCRIMINANTS OF THE SUBTYPE INDICATION. + -- + -- + -- * RECORD TYPES WITH DISCRIMINANTS; + -- * PRIVATE TYPES WITH DISCRIMINANTS; + -- * LIMITED PRIVATE TYPES WITH DISCRIMINANTS. + + + -- RM 3/01/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C45274C IS + + + BEGIN + + TEST ( "C45274C" , "CHECK THAT THE MEMBERSHIP OPERATOR IN " & + " ( NOT IN ) YIELDS TRUE (RESP. FALSE )" & + " IF THE DISCRIMINANTS OF THE LEFT VALUE" & + " EQUAL THE DISCRIMINANTS OF THE SUBTYPE" & + " INDICATION" ); + + + ------------------------------------------------------------------- + ----------------- RECORD TYPES WITH DISCRIMINANTS --------------- + + DECLARE + + TYPE REC ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + + SUBTYPE RECTRUE IS REC(TRUE) ; + + X : REC := ( TRUE , 19 , 91 ); + + BEGIN + + IF X IN RECTRUE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 1" ); + END IF; + + IF X NOT IN RECTRUE THEN + FAILED( "WRONG VALUE: 'NOT IN', 1" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "1 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + ----------------- PRIVATE TYPES WITH DISCRIMINANTS -------------- + + DECLARE + + PACKAGE P IS + TYPE PRIV ( DISCR : BOOLEAN ) IS PRIVATE; + PRIVATE + TYPE PRIV ( DISCR : BOOLEAN ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + SUBTYPE PRIVTRUE IS PRIV( IDENT_BOOL(TRUE) ); + + X : PRIV(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( TRUE , 19 , 91 ); + END P ; + + BEGIN + + IF X IN PRIVTRUE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'IN', 2" ); + END IF; + + IF X NOT IN PRIVTRUE THEN + FAILED( "WRONG VALUE: 'NOT IN', 2" ); + ELSE + NULL; + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "2 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + ------------------------------------------------------------------- + --------- LIMITED PRIVATE TYPES WITH DISCRIMINANTS -------------- + + DECLARE + + PACKAGE P IS + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS LIMITED PRIVATE; + PRIVATE + TYPE LP ( DISCR : BOOLEAN := FALSE ) IS + RECORD + A , B : INTEGER ; + END RECORD ; + END P ; + + USE P ; + + SUBTYPE LPFALSE IS LP(FALSE) ; + + X : LP(TRUE) ; + + PACKAGE BODY P IS + BEGIN + X := ( IDENT_BOOL(TRUE) , 19 , 91 ); + END P ; + + BEGIN + + IF X IN LPFALSE THEN + FAILED( "WRONG VALUE: 'IN', 3" ); + ELSE + NULL; + END IF; + + IF X NOT IN LPFALSE THEN + NULL; + ELSE + FAILED( "WRONG VALUE: 'NOT IN', 3" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "3 - 'IN' ( 'NOT IN' ) RAISED AN EXCEPTION"); + + END; + + + ------------------------------------------------------------------- + + + RESULT; + + + END C45274C ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45281a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45281a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45281a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45281a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C45281A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY AND INEQUALITY ARE EVALUATED CORRECTLY FOR ACCESS + -- TYPES. + + -- TBN 8/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45281A IS + + TYPE STR_NAME IS ACCESS STRING; + + TYPE GENDER IS (F, M); + TYPE PERSON (SEX : GENDER) IS + RECORD + NAME : STRING (1..6) := "NONAME"; + END RECORD; + + TYPE PERSON_NAME IS ACCESS PERSON; + SUBTYPE MALE IS PERSON_NAME (M); + SUBTYPE FEMALE IS PERSON_NAME (F); + + S : STR_NAME (1..10) := NEW STRING'("0123456789"); + T : STR_NAME (1..10) := S; + A : MALE; + B : FEMALE; + C : PERSON_NAME; + + BEGIN + TEST ("C45281A", "CHECK THAT EQUALITY AND INEQUALITY ARE " & + "EVALUATED CORRECTLY FOR ACCESS TYPES"); + + IF "/=" (LEFT => S, RIGHT => T) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 1"); + END IF; + T := NEW STRING'("0123456789"); + IF "=" (S, T) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 2"); + END IF; + + IF A /= B THEN + FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 3"); + END IF; + IF A /= C THEN + FAILED ("INCORRECT RESULTS FOR NULL ACCESS VALUES - 4"); + END IF; + + A := NEW PERSON'(M, "THOMAS"); + IF "=" (LEFT => A, RIGHT => B) THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 5"); + END IF; + C := A; + IF C /= A THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 6"); + END IF; + C := NEW PERSON'(M, "THOMAS"); + IF A = C THEN + FAILED ("INCORRECT RESULTS FOR ACCESS VALUES - 7"); + END IF; + + RESULT; + END C45281A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45282a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45282a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45282a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45282a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C45282A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN AND NOT IN ARE EVALUATED CORRECTLY FOR : + -- A) ACCESS TO SCALAR TYPES; + -- B) ACCESS TO ARRAY TYPES (CONSTRAINED AND UNCONSTRAINED); + -- C) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT + -- DISCRIMINANTS; + + -- TBN 8/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45282A IS + + PACKAGE P IS + TYPE KEY IS PRIVATE; + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY; + TYPE NEWKEY IS LIMITED PRIVATE; + TYPE ACC_NKEY IS ACCESS NEWKEY; + PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY); + PRIVATE + TYPE KEY IS NEW NATURAL; + TYPE NEWKEY IS NEW KEY; + END P; + + USE P; + SUBTYPE I IS INTEGER; + TYPE ACC_INT IS ACCESS I; + P_INT : ACC_INT; + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + TYPE ARRAY_TYPE1 IS ARRAY (INT RANGE <>) OF INTEGER; + TYPE ACC_ARA_1 IS ACCESS ARRAY_TYPE1; + SUBTYPE ACC_ARA_2 IS ACC_ARA_1 (1 .. 2); + SUBTYPE ACC_ARA_3 IS ACC_ARA_1 (1 .. 3); + ARA1 : ACC_ARA_1; + ARA2 : ACC_ARA_2; + ARA3 : ACC_ARA_3; + TYPE GREET IS + RECORD + NAME : STRING (1 .. 2); + END RECORD; + TYPE ACC_GREET IS ACCESS GREET; + INTRO : ACC_GREET; + TYPE ACC_KEY IS ACCESS KEY; + KEY1 : ACC_KEY; + KEY2 : ACC_NKEY; + + PACKAGE BODY P IS + FUNCTION INIT_KEY (X : NATURAL) RETURN KEY IS + BEGIN + RETURN (KEY(X)); + END INIT_KEY; + + PROCEDURE ASSIGN_NEWKEY (Y : IN OUT ACC_NKEY) IS + BEGIN + Y.ALL := NEWKEY (1); + END ASSIGN_NEWKEY; + END P; + + BEGIN + + TEST ("C45282A", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " & + "ACCESS TYPES TO SCALAR TYPES, ARRAY TYPES, " & + "RECORD TYPES, PRIVATE TYPES, AND LIMITED " & + "PRIVATE TYPES WITHOUT DISCRIMINANTS"); + + -- CASE A + IF P_INT NOT IN ACC_INT THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1"); + END IF; + P_INT := NEW INT'(5); + IF P_INT IN ACC_INT THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2"); + END IF; + + -- CASE B + IF ARA1 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3"); + END IF; + IF ARA1 NOT IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4"); + END IF; + IF ARA1 IN ACC_ARA_3 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5"); + END IF; + IF ARA2 IN ACC_ARA_1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6"); + END IF; + IF ARA3 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7"); + END IF; + ARA1 := NEW ARRAY_TYPE1'(1, 2, 3); + IF ARA1 IN ACC_ARA_1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8"); + END IF; + IF ARA1 IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9"); + END IF; + IF ARA1 NOT IN ACC_ARA_3 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10"); + END IF; + ARA2 := NEW ARRAY_TYPE1'(1, 2); + IF ARA2 NOT IN ACC_ARA_1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11"); + END IF; + IF ARA2 NOT IN ACC_ARA_2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12"); + END IF; + + -- CASE C + IF INTRO NOT IN ACC_GREET THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13"); + END IF; + INTRO := NEW GREET'(NAME => "HI"); + IF INTRO IN ACC_GREET THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14"); + END IF; + IF KEY1 NOT IN ACC_KEY THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15"); + END IF; + KEY1 := NEW KEY'(INIT_KEY (1)); + IF KEY1 IN ACC_KEY THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16"); + END IF; + IF KEY2 NOT IN ACC_NKEY THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17"); + END IF; + KEY2 := NEW NEWKEY; + ASSIGN_NEWKEY (KEY2); + IF KEY2 IN ACC_NKEY THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18"); + END IF; + + RESULT; + END C45282A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45282b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45282b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45282b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45282b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,347 ---- + -- C45282B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN AND NOT IN ARE EVALUATED CORRECTLY FOR : + -- D) ACCESS TO RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH + -- DISCRIMINANTS (WITH AND WITHOUT DEFAULT VALUES), WHERE THE + -- TYPE MARK DENOTES A CONSTRAINED AND UNCONSTRAINED TYPE; + -- E) ACCESS TO TASK TYPES. + + -- TBN 8/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45282B IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + + PACKAGE P IS + TYPE PRI_REC1 (D : INT) IS PRIVATE; + TYPE PRI_REC2 (D : INT := 2) IS PRIVATE; + FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1; + FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2; + TYPE LIM_REC1 (D : INT) IS LIMITED PRIVATE; + TYPE ACC_LIM1 IS ACCESS LIM_REC1; + SUBTYPE ACC_SUB_LIM1 IS ACC_LIM1 (2); + PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING); + TYPE LIM_REC2 (D : INT := 2) IS LIMITED PRIVATE; + TYPE ACC_LIM2 IS ACCESS LIM_REC2; + SUBTYPE ACC_SUB_LIM2 IS ACC_LIM2 (2); + PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING); + PRIVATE + TYPE PRI_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE PRI_REC2 (D : INT := 2) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE LIM_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE LIM_REC2 (D : INT := 2) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + END P; + + USE P; + + TYPE DIS_REC1 (D : INT) IS + RECORD + STR : STRING (1 .. D); + END RECORD; + TYPE DIS_REC2 (D : INT := 5) IS + RECORD + STR : STRING (D .. 8); + END RECORD; + + TYPE ACC1_REC1 IS ACCESS DIS_REC1; + SUBTYPE ACC2_REC1 IS ACC1_REC1 (2); + TYPE ACC1_REC2 IS ACCESS DIS_REC2; + SUBTYPE ACC2_REC2 IS ACC1_REC2 (2); + REC1 : ACC1_REC1; + REC2 : ACC2_REC1; + REC3 : ACC1_REC2; + REC4 : ACC2_REC2; + TYPE ACC_PREC1 IS ACCESS PRI_REC1; + SUBTYPE ACC_SREC1 IS ACC_PREC1 (2); + REC5 : ACC_PREC1; + REC6 : ACC_SREC1; + TYPE ACC_PREC2 IS ACCESS PRI_REC2; + SUBTYPE ACC_SREC2 IS ACC_PREC2 (2); + REC7 : ACC_PREC2; + REC8 : ACC_SREC2; + REC9 : ACC_LIM1; + REC10 : ACC_SUB_LIM1; + REC11 : ACC_LIM2; + REC12 : ACC_SUB_LIM2; + + TASK TYPE T IS + ENTRY E (X : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : INTEGER) DO + IF X /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE PASSED TO TASK"); + END IF; + END E; + END T; + + PACKAGE BODY P IS + FUNCTION INIT_PREC1 (A : INT; B : STRING) RETURN PRI_REC1 IS + REC : PRI_REC1 (A); + BEGIN + REC := (A, B); + RETURN (REC); + END INIT_PREC1; + + FUNCTION INIT_PREC2 (A : INT; B : STRING) RETURN PRI_REC2 IS + REC : PRI_REC2; + BEGIN + REC := (A, B); + RETURN (REC); + END INIT_PREC2; + + PROCEDURE ASSIGN_LIM1 (A : ACC_LIM1; B : INT; C : STRING) IS + BEGIN + A.ALL := (B, C); + END ASSIGN_LIM1; + + PROCEDURE ASSIGN_LIM2 (A : ACC_LIM2; B : INT; C : STRING) IS + BEGIN + A.ALL := (B, C); + END ASSIGN_LIM2; + END P; + + BEGIN + + TEST ("C45282B", "CHECK THAT IN AND NOT IN ARE EVALUATED FOR " & + "ACCESS TYPES TO RECORD TYPES, PRIVATE TYPES, " & + "LIMITED PRIVATE TYPES WITH DISCRIMINANTS, AND " & + "TASK TYPES"); + + -- CASE D + ------------------------------------------------------------------------ + IF REC1 NOT IN ACC1_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 1"); + END IF; + IF REC1 IN ACC2_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 2"); + END IF; + IF REC2 NOT IN ACC1_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 3"); + END IF; + REC1 := NEW DIS_REC1'(5, "12345"); + IF REC1 IN ACC1_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 4"); + END IF; + IF REC1 IN ACC2_REC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 5"); + END IF; + REC2 := NEW DIS_REC1'(2, "HI"); + IF REC2 IN ACC1_REC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 6"); + END IF; + + ------------------------------------------------------------------------ + + IF REC3 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 7"); + END IF; + IF REC3 NOT IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 8"); + END IF; + IF REC4 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 9"); + END IF; + REC3 := NEW DIS_REC2'(5, "5678"); + IF REC3 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 10"); + END IF; + IF REC3 IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 11"); + END IF; + REC4 := NEW DIS_REC2'(2, "2345678"); + IF REC4 IN ACC1_REC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 12"); + END IF; + IF REC4 NOT IN ACC2_REC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 13"); + END IF; + + ------------------------------------------------------------------------ + + IF REC5 NOT IN ACC_PREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 14"); + END IF; + IF REC5 NOT IN ACC_SREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 15"); + END IF; + IF REC6 NOT IN ACC_PREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 16"); + END IF; + REC5 := NEW PRI_REC1'(INIT_PREC1 (5, "12345")); + IF REC5 IN ACC_PREC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 17"); + END IF; + IF REC5 IN ACC_SREC1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 18"); + END IF; + REC6 := NEW PRI_REC1'(INIT_PREC1 (2, "HI")); + IF REC6 IN ACC_PREC1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 19"); + END IF; + + ------------------------------------------------------------------------ + + IF REC7 NOT IN ACC_PREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 20"); + END IF; + IF REC7 NOT IN ACC_SREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 21"); + END IF; + IF REC8 NOT IN ACC_PREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 22"); + END IF; + REC7 := NEW PRI_REC2'(INIT_PREC2 (5, "12345")); + IF REC7 IN ACC_PREC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 23"); + END IF; + IF REC7 IN ACC_SREC2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 24"); + END IF; + REC8 := NEW PRI_REC2'(INIT_PREC2 (2, "HI")); + IF REC8 IN ACC_PREC2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 25"); + END IF; + + ------------------------------------------------------------------------ + + IF REC9 NOT IN ACC_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 26"); + END IF; + IF REC9 NOT IN ACC_SUB_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 27"); + END IF; + IF REC10 NOT IN ACC_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 28"); + END IF; + REC9 := NEW LIM_REC1 (5); + ASSIGN_LIM1 (REC9, 5, "12345"); + IF REC9 IN ACC_LIM1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 29"); + END IF; + IF REC9 IN ACC_SUB_LIM1 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 30"); + END IF; + REC10 := NEW LIM_REC1 (2); + ASSIGN_LIM1 (REC10, 2, "12"); + IF REC10 IN ACC_LIM1 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 31"); + END IF; + + ------------------------------------------------------------------------ + + IF REC11 NOT IN ACC_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 32"); + END IF; + IF REC11 NOT IN ACC_SUB_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 33"); + END IF; + IF REC12 NOT IN ACC_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 34"); + END IF; + REC11 := NEW LIM_REC2; + IF REC11 NOT IN ACC_SUB_LIM2 THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 35"); + END IF; + ASSIGN_LIM2 (REC11, 2, "12"); + IF REC11 IN ACC_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 36"); + END IF; + IF REC11 IN ACC_SUB_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 37"); + END IF; + REC12 := NEW LIM_REC2; + ASSIGN_LIM2 (REC12, 2, "12"); + IF REC12 IN ACC_LIM2 THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38"); + END IF; + + -- CASE E + ------------------------------------------------------------------------ + DECLARE + TYPE ACC_TASK IS ACCESS T; + T1 : ACC_TASK; + BEGIN + IF T1 NOT IN ACC_TASK THEN + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 39"); + END IF; + T1 := NEW T; + IF T1 IN ACC_TASK THEN + NULL; + ELSE + FAILED ("INCORRECT RESULTS FOR ACCESS TYPES - 38"); + END IF; + T1.E (1); + END; + + RESULT; + END C45282B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45291a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45291a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45291a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45291a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C45291A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE MEMBERSHIP TESTS YIELD CORRECT RESULTS FOR TASK + -- TYPES, LIMITED PRIVATE TYPES, COMPOSITE LIMITED TYPES, AND + -- PRIVATE TYPES WITHOUT DISCRIMINANTS. + + -- HISTORY: + -- JET 08/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45291A IS + + TASK TYPE TASK1 IS + ENTRY E; + END TASK1; + + PACKAGE PACK IS + TYPE LIM_PRIV IS LIMITED PRIVATE; + TYPE LIM_COMP IS ARRAY (1..10) OF LIM_PRIV; + TYPE PRIV IS PRIVATE; + PROCEDURE INIT(LP : OUT LIM_PRIV; + LC : IN OUT LIM_COMP; + P : OUT PRIV); + PRIVATE + TYPE LIM_PRIV IS RANGE -100..100; + TYPE PRIV IS RECORD + I : INTEGER; + END RECORD; + END PACK; + + SUBTYPE SUB_TASK1 IS TASK1; + SUBTYPE SUB_LIM_PRIV IS PACK.LIM_PRIV; + SUBTYPE SUB_LIM_COMP IS PACK.LIM_COMP; + SUBTYPE SUB_PRIV IS PACK.PRIV; + + T1 : TASK1; + LP : PACK.LIM_PRIV; + LC : PACK.LIM_COMP; + P : PACK.PRIV; + + TASK BODY TASK1 IS + BEGIN + ACCEPT E DO + NULL; + END E; + END TASK1; + + PACKAGE BODY PACK IS + PROCEDURE INIT (LP : OUT LIM_PRIV; + LC : IN OUT LIM_COMP; + P : OUT PRIV) IS + BEGIN + LP := 0; + LC := (OTHERS => 0); + P := (I => 0); + END INIT; + END PACK; + + BEGIN + TEST ("C45291A", "CHECK THAT THE MEMBERSHIP TESTS YIELD CORRECT " & + "RESULTS FOR TASK TYPES, LIMITED PRIVATE TYPES," & + " COMPOSITE LIMITED TYPES, AND PRIVATE TYPES " & + "WITHOUT DISCRIMINANTS"); + + PACK.INIT(LP, LC, P); + + IF NOT IDENT_BOOL(T1 IN TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 IN TASK1'"); + END IF; + + IF IDENT_BOOL(T1 NOT IN TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 NOT IN TASK1'"); + END IF; + + IF NOT IDENT_BOOL(LP IN PACK.LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP IN LIM_PRIV'"); + END IF; + + IF IDENT_BOOL(LP NOT IN PACK.LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP NOT IN LIM_PRIV'"); + END IF; + + IF NOT IDENT_BOOL(LC IN PACK.LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC IN LIM_COMP'"); + END IF; + + IF IDENT_BOOL(LC NOT IN PACK.LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC NOT IN LIM_COMP'"); + END IF; + + IF NOT IDENT_BOOL(P IN PACK.PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P IN PRIV'"); + END IF; + + IF IDENT_BOOL(P NOT IN PACK.PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P NOT IN PRIV'"); + END IF; + + IF NOT IDENT_BOOL(T1 IN SUB_TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 IN SUB_TASK1'"); + END IF; + + IF IDENT_BOOL(T1 NOT IN SUB_TASK1) THEN + FAILED ("INCORRECT VALUE OF 'T1 NOT IN SUB_TASK1'"); + END IF; + + IF NOT IDENT_BOOL(LP IN SUB_LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP IN SUB_LIM_PRIV'"); + END IF; + + IF IDENT_BOOL(LP NOT IN SUB_LIM_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'LP NOT IN SUB_LIM_PRIV'"); + END IF; + + IF NOT IDENT_BOOL(LC IN SUB_LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC IN SUB_LIM_COMP'"); + END IF; + + IF IDENT_BOOL(LC NOT IN SUB_LIM_COMP) THEN + FAILED ("INCORRECT VALUE OF 'LC NOT IN SUB_LIM_COMP'"); + END IF; + + IF NOT IDENT_BOOL(P IN SUB_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P IN SUB_PRIV'"); + END IF; + + IF IDENT_BOOL(P NOT IN SUB_PRIV) THEN + FAILED ("INCORRECT VALUE OF 'P NOT IN SUB_PRIV'"); + END IF; + + T1.E; + + RESULT; + + END C45291A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45303a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45303a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45303a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45303a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C45303A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ADDITION AND SUBTRACTION YIELD RESULTS BELONGING TO THE + -- BASE TYPE. + + -- JBG 2/24/84 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + -- JRL 10/13/96 Fixed static expressions which contained values outside + -- the base range. + + WITH REPORT; USE REPORT; + PROCEDURE C45303A IS + + TYPE INT IS RANGE 1..10; + + X, Y : INT := INT(IDENT_INT(9)); + + BEGIN + + TEST ("C45303A", "CHECK SUBTYPE OF INTEGER ADDITION/SUBTRACTION"); + + BEGIN + + IF X + Y - 10 /= INT(IDENT_INT(8)) THEN + FAILED ("INCORRECT RESULT - ADDITION"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'POS(INT'BASE'LAST) >= 18 THEN + FAILED ("ADDITION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE LESS THAN 18 - ADD"); + END IF; + END; + + BEGIN + + IF 2 - X - INT(IDENT_INT(1)) /= INT'VAL(IDENT_INT(-8)) THEN + FAILED ("INCORRECT RESULT - SUBTRACTION"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'POS(INT'BASE'FIRST) <= -8 THEN + FAILED ("SUBTRACTION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE GREATER THAN -8 - SUB"); + END IF; + END; + + RESULT; + + END C45303A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C45304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY + -- "+" AND "-" FOR PREDEFINED INTEGER WHEN THE RESULT IS OUTSIDE + -- THE RANGE OF THE BASE TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- TBN 10/06/86 CREATED ORIGINAL TEST. + -- JET 12/29/87 FURTHER DEFEATED OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45304A IS + + BEGIN + TEST ("C45304A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "INTEGER WHEN THE RESULT IS OUTSIDE THE RANGE " & + "OF THE BASE TYPE"); + + DECLARE + B : INTEGER := INTEGER'LAST; + BEGIN + IF EQUAL (IDENT_INT(B)+1, 0) THEN + FAILED ("NO EXCEPTION FOR ADDITION -- ZERO RESULT"); + ELSE + FAILED ("NO EXCEPTION FOR ADDITION -- NONZERO RESULT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ADDITION"); + END; + + DECLARE + B : INTEGER := INTEGER'FIRST; + BEGIN + IF EQUAL (IDENT_INT(B)-1, 0) THEN + FAILED ("NO EXCEPTION FOR SUBTRACTION -- ZERO RESULT"); + ELSE + FAILED ("NO EXCEPTION FOR SUBTRACTION -- " & + "NONZERO RESULT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR SUBTRACTION"); + END; + + RESULT; + END C45304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C45304B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY + -- "+" AND "-" FOR PREDEFINED SHORT_INTEGER WHEN THE RESULT IS + -- OUTSIDE THE RANGE OF THE BASE TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A + -- PREDEFINED TYPE SHORT_INTEGER. + + -- IF SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "TEST_VAR" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- TBN 10/07/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45304B IS + + TEST_VAR : SHORT_INTEGER; -- N/A => ERROR. + + -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION. + + FUNCTION IDENT_SHORT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0); + END IF; + END IDENT_SHORT; + + FUNCTION SHORT_OK (X : SHORT_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL (INTEGER(X),INTEGER(X)); + END SHORT_OK; + + BEGIN + TEST ("C45304B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "SHORT_INTEGER WHEN THE RESULT IS OUTSIDE THE " & + "RANGE OF THE BASE TYPE"); + + DECLARE + B : SHORT_INTEGER := SHORT_INTEGER'LAST; + BEGIN + IF SHORT_OK (B + IDENT_SHORT(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "SHORT_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "SHORT_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + B : SHORT_INTEGER := SHORT_INTEGER'FIRST; + BEGIN + + IF SHORT_OK (B - IDENT_SHORT(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION- " & + "SHORT_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "SHORT_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + RESULT; + END C45304B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45304c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45304c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C45304C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY + -- "+" AND "-" FOR PREDEFINED LONG_INTEGER WHEN THE RESULT IS + -- OUTSIDE THE RANGE OF THE BASE TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE IF THE IMPLEMENTATION HAS A + -- PREDEFINED TYPE LONG_INTEGER. + + -- IF LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "TEST_VAR" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- TBN 10/07/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 ADDED CODE TO PREVENT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45304C IS + + TEST_VAR : LONG_INTEGER; -- N/A => ERROR. + + -- THESE FUNCTIONS ARE TO PREVENT OPTIMIZATION. + + FUNCTION IDENT_LONG (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + + FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_LONG(X); + END LONG_OK; + + BEGIN + TEST ("C45304C", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""+"" AND ""-"" FOR PREDEFINED " & + "LONG_INTEGER WHEN THE RESULT IS OUTSIDE THE " & + "RANGE OF THE BASE TYPE"); + + DECLARE + B : LONG_INTEGER := LONG_INTEGER'LAST; + BEGIN + IF LONG_OK (B + IDENT_LONG(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "LONG_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR ADDITION - " & + "LONG_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + DECLARE + B : LONG_INTEGER := LONG_INTEGER'FIRST; + BEGIN + IF LONG_OK (B - IDENT_LONG(1)) THEN + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "LONG_OK RETURNS TRUE"); + ELSE + FAILED ("NO EXCEPTION RAISED FOR SUBTRACTION - " & + "LONG_OK RETURNS FALSE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + RESULT; + END C45304C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45322a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45322a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45322a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45322a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- C45322A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF + -- MACHINE_OVERFLOWS IS TRUE AND THE RESULT OF THE ADDITION OR + -- SUBTRACTION LIES OUTSIDE OF THE RANGE OF THE BASE TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- NPL 09/01/90 CREATED ORIGINAL TEST. + -- LDC 10/09/90 CHANGED THE STYLE OF THE TEST TO THE STANDARD + -- ACVC FORMAT AND WRAPPED LINES WHICH WHERE LONGER + -- THAN 71 CHARACTERS. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C45322A IS + + TYPE FLOAT5 IS DIGITS 5; + F5 : FLOAT5; + + FUNCTION IDENT (F : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN F * FLOAT5(IDENT_INT(1)); + END IDENT; + + FUNCTION EQUAL (F,G : FLOAT5) RETURN BOOLEAN IS + BEGIN + RETURN F = G + FLOAT5(IDENT_INT(0)); + END EQUAL; + + BEGIN + TEST ("C45322A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " & + "THE RESULT OF THE ADDITION OR SUBTRACTION " & + "LIES OUTSIDE OF THE RANGE OF THE BASE TYPE"); + + IF NOT FLOAT5'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE("MACHINE_OVERFLOWS IS FALSE"); + ELSE + + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'LAST; + + FAILED("NO EXCEPTION RAISED BY LARGE '+'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '+'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'LAST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING LARGE '+'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING LARGE '+'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'FIRST; + + FAILED("NO EXCEPTION RAISED BY SMALL '+'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '+'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'FIRST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING SMALL '+'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING SMALL '+'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) - FLOAT5'BASE'FIRST; + + FAILED("NO EXCEPTION RAISED BY LARGE '-'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY LARGE '-'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'LAST) + FLOAT5'BASE'FIRST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING LARGE '-'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING LARGE '-'"); + END; + + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) - FLOAT5'BASE'LAST; + + FAILED("NO EXCEPTION RAISED BY SMALL '-'"); + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY SMALL '-'"); + END; + + -- AS ABOVE BUT INTERCHANGING '+' AND '-' + BEGIN + F5 := IDENT(FLOAT5'BASE'FIRST) + FLOAT5'BASE'LAST; + + IF NOT EQUAL(F5, F5) THEN + COMMENT("DON'T OPTIMIZE F5"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR " & + "RAISED BY INTERCHANGING SMALL '-'"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BY " & + "INTERCHANGING SMALL '-'"); + END; + + END IF; + + RESULT; + + END C45322A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45323a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45323a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45323a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45323a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C45323A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NONASSOCIATIVITY OF REAL ARITHMETIC IS PRESERVED + -- FOR FLOATING POINT PRECISION 5, EVEN WHEN OPTIMIZATION WOULD + -- BENEFIT IF FLOATING POINT ADDITION WERE ASSOCIATIVE. + + -- HISTORY: + -- JET 08/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45323A IS + + TYPE FLOAT5 IS DIGITS 5; + + A, B, C, D, E : FLOAT5; + + FUNCTION IDENT(F : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN F * FLOAT5(IDENT_INT(1)); + END IDENT; + + BEGIN + TEST ("C45323A", "CHECK THAT THE NONASSOCIATIVITY OF REAL " & + "ARITHMETIC IS PRESERVED FOR FLOATING POINT " & + "PRECISION 5, EVEN WHEN OPTIMIZATION WOULD " & + "BENEFIT IF FLOATING POINT ADDITION WERE " & + "ASSOCIATIVE"); + + B := 2#0.1010_1010_1010_1010_10#E3; + A := -B; + C := 2#0.1000_0000_0000_0000_00#E-18; + D := B + C; + E := A + B + C; + + IF IDENT(A) + IDENT(B) /= 0.0 THEN + FAILED("INCORRECT VALUE OF A + B"); + END IF; + + IF IDENT(E) /= IDENT(C) THEN + FAILED("C DOES NOT EQUAL E"); + END IF; + + RESULT; + END C45323A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45331a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45331a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45331a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45331a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,357 ---- + -- C45331A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES THE OPERATORS "+" AND "-" PRODUCE + -- CORRECT RESULTS WHEN: + -- (A) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS. + -- (B) A IS A MODEL NUMBER BUT B, A+B, AND A-B ARE NOT. + -- (C) A, B, A+B, AND A-B ARE ALL MODEL NUMBERS WITH DIFFERENT + -- SUBTYPES. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- WRG 8/27/86 + -- KAS 11/14/95 REDUCE EXPECTATION FOR T'SMALL + -- KAS 11/30/95 ONE MORE CHANGE... + -- PWN 02/28/96 CLEANED COMMENTS FOR RELEASE + -- KAS 03/18/96 ELIDED TWO 'SMALL CASES FOR 2.1 + + WITH REPORT; USE REPORT; + PROCEDURE C45331A IS + + TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + -- 'MANTISSA = 23. + SUBTYPE F IS LIKE_DURATION DELTA 0.25 RANGE -1000.0 .. 1000.0; + SUBTYPE ST_F1 IS LIKE_DURATION DELTA 0.5 RANGE -4.0 .. 3.0; + SUBTYPE ST_F2 IS LIKE_DURATION DELTA 1.0 / 16 + RANGE -13.0 / 16 .. 5.0 + 1.0 / 16; + + BEGIN + + TEST ("C45331A", "CHECK THAT FOR FIXED POINT TYPES THE " & + "OPERATORS ""+"" AND ""-"" PRODUCE CORRECT " & + "RESULTS - BASIC TYPES"); + + ------------------------------------------------------------------- + + A: DECLARE + SMALL, MAX, MIN, ZERO : F := 0.5; + X : F := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := F'SMALL; + MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND F'LAST + -- IS A MODEL NUMBER. + MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER. + ZERO := 0.0; + END IF; + + -- CHECK SMALL + OR - ZERO = SMALL: + IF "+"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR + 0.0 + SMALL /= SMALL THEN + FAILED ("F'SMALL + 0.0 /= F'SMALL"); + END IF; + IF "-"(LEFT => SMALL, RIGHT => ZERO) /= SMALL OR + SMALL - 0.0 /= SMALL THEN + FAILED ("F'SMALL - 0.0 /= F'SMALL"); + END IF; + + -- CHECK MAX + OR - ZERO = MAX: + IF MAX + ZERO /= MAX OR 0.0 + MAX /= MAX THEN + FAILED ("F'LAST + 0.0 /= F'LAST"); + END IF; + IF MAX - ZERO /= MAX OR MAX - 0.0 /= MAX THEN + FAILED ("F'LAST - 0.0 /= F'LAST"); + END IF; + + -- CHECK SMALL - SMALL = 0.0: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF SMALL - X /= 0.0 OR SMALL - SMALL /= 0.0 OR + F'SMALL - F'SMALL /= 0.0 THEN + FAILED ("F'SMALL - F'SMALL /= 0.0"); + END IF; + + -- CHECK MAX - MAX = 0.0: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF MAX - X /= 0.0 OR MAX - MAX /= 0.0 OR + F'LAST - F'LAST /= 0.0 THEN + FAILED ("F'LAST - F'LAST /= 0.0"); + END IF; + + -- CHECK ZERO - MAX = MIN, MIN - MIN = 0.0, + -- AND MIN + MAX = 0.0: + IF EQUAL (3, 3) THEN + X := ZERO - MAX; + END IF; + IF X /= MIN THEN + FAILED ("0.0 - 1000.0 /= -1000.0"); + END IF; + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF MIN - X /= 0.0 OR MIN - MIN /= 0.0 OR + F'FIRST - F'FIRST /= 0.0 THEN + FAILED ("F'FIRST - F'FIRST /= 0.0"); + END IF; + IF MIN + MAX /= 0.0 OR MAX + MIN /= 0.0 OR + F'FIRST + F'LAST /= 0.0 THEN + FAILED ("-1000.0 + 1000.0 /= 0.0"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE + -- NUMBERS: + IF EQUAL (3, 3) THEN + X := 100.75; + END IF; + IF (X + SMALL) /= (SMALL + X) OR + (X + SMALL) > (X + 0.25) THEN -- X + SMALL SB <= X + DELTA + FAILED("X + SMALL DELIVERED BAD RESULT"); + END IF; + + -- CHECK (MAX - SMALL) + SMALL = MAX: + IF EQUAL (3, 3) THEN + X := MAX - SMALL; + END IF; + IF X + SMALL /= MAX THEN + FAILED("(MAX - SMALL) + SMALL /= MAX"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A"); + END A; + + ------------------------------------------------------------------- + + B: DECLARE + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : F := 0.0; + + SMALL, MAX, MIN, ZERO : F := 0.5; + X : F := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := F'SMALL; + MAX := F'LAST; -- BECAUSE F'LAST < F'LARGE AND + -- F'LAST IS A MODEL NUMBER. + MIN := F'FIRST; -- F'FIRST IS A MODEL NUMBER. + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- CHECK VALUE OF NON_MODEL_VAR: + IF NON_MODEL_VAR NOT IN 0.5 .. 0.75 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE"); + END IF; + + -- CHECK NON-MODEL VALUE + OR - ZERO: + IF NON_MODEL_VAR + ZERO NOT IN 0.5 .. 0.75 OR + F'(0.0) + NON_MODEL_CONST NOT IN 0.5 .. 0.75 THEN + FAILED ("(2.0 / 3) + 0.0 NOT IN 0.5 .. 0.75"); + END IF; + IF NON_MODEL_VAR - ZERO NOT IN 0.5 .. 0.75 OR + NON_MODEL_CONST - F'(0.0) NOT IN 0.5 .. 0.75 THEN + FAILED ("(2.0 / 3) - 0.0 NOT IN 0.5 .. 0.75"); + END IF; + + -- CHECK ZERO - NON-MODEL: + IF F'(0.0) - NON_MODEL_CONST NOT IN -0.75 .. -0.5 THEN + FAILED ("0.0 - (2.0 / 3) NOT IN -0.75 .. -0.5"); + END IF; + + IF F'(1.0) - NON_MODEL_CONST NOT IN 0.25 .. 0.5 THEN + FAILED ("1.0 - (2.0 / 3) NOT IN 0.25 .. 0.5"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION OF NON-MODEL NEAR MIN AND + -- MAX: + IF MIN + NON_MODEL_VAR NOT IN -999.5 .. -999.25 OR + NON_MODEL_CONST + F'FIRST NOT IN -999.5 .. -999.25 THEN + FAILED ("-1000.0 + (2.0 / 3) NOT IN -999.5 .. -999.25"); + END IF; + IF MAX - NON_MODEL_VAR NOT IN 999.25 .. 999.5 OR + F'LAST - NON_MODEL_CONST NOT IN 999.25 .. 999.5 THEN + FAILED ("1000.0 - (2.0 / 3) NOT IN 999.25 .. 999.5"); + END IF; + + -- CHECK ADDITION AND SUBTRACTION FOR ARBITRARY MID-RANGE + -- MODEL NUMBER WITH NON-MODEL: + IF EQUAL (3, 3) THEN + X := -213.25; + END IF; + IF X + NON_MODEL_CONST NOT IN -212.75 .. -212.5 THEN + FAILED ("-213.25 + (2.0 / 3) NOT IN -212.75 .. -212.5"); + END IF; + IF NON_MODEL_VAR - X NOT IN 213.75 .. 214.0 THEN + FAILED ("(2.0 / 3) - (-213.25) NOT IN 213.75 .. 214.0"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B"); + END B; + + ------------------------------------------------------------------- + + C: DECLARE + A_SMALL, A_MAX, A_MIN : ST_F1 := 0.0; + B_SMALL, B_MAX, B_MIN : ST_F2 := 0.0; + X : F; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + A_SMALL := ST_F1'SMALL; + A_MAX := ST_F1'LAST; -- BECAUSE 'LAST < 'LARGE AND + -- 'LAST IS A MODEL NUMBER. + A_MIN := ST_F1'FIRST; -- 'FIRST IS A MODEL NUMBER. + + B_SMALL := ST_F2'SMALL; + B_MAX := ST_F2'LAST; -- BECAUSE 'LAST <= 'LARGE AND + -- 'LAST IS A MODEL NUMBER. + B_MIN := ST_F2'FIRST; -- 'FIRST IS A MODEL NUMBER. + END IF; + + IF A_MIN + B_MIN /= -4.8125 THEN + FAILED ("-4.0 + (-0.8125) /= -4.8125"); + END IF; + + IF A_MIN - B_MIN /= -3.1875 THEN + FAILED ("-4.0 - (-0.8125) /= -3.1875"); + END IF; + + IF (A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375 THEN + FAILED ("(A_MIN + B_SMALL) NOT IN A_MIN .. -3.9375"); + END IF; + + IF (A_MIN - B_SMALL) NOT IN -4.0625 .. -4.0 THEN + FAILED ("(A_MIN - B_SMALL) NOT IN -4.0 .. -4.0625"); + END IF; + + IF A_MIN + B_MAX /= 1.0625 THEN + FAILED ("-4.0 + 5.0625 /= 1.0625"); + END IF; + + IF A_MIN - B_MAX /= -9.0625 THEN + FAILED ("-4.0 - 5.0625 /= -9.0625"); + END IF; + + IF (A_SMALL + B_MIN) NOT IN B_MIN..-0.3125 THEN + FAILED ("(A_SMALL + B_MIN) NOT IN B_MIN..-0.3125"); + END IF; + + IF (A_SMALL - B_MIN) NOT IN +0.8125 .. 1.3125 THEN + FAILED ("(A_SMALL - B_MIN) NOT IN -0.8125 .. 1.3125"); + END IF; + + + + IF (A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625 THEN + FAILED ("(A_SMALL + B_MAX) NOT IN 5.0625 .. 5.5625"); + END IF; + + IF (A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625 THEN + FAILED ("(A_SMALL - B_MAX) NOT IN -5.0625 .. -4.5625"); + END IF; + + IF A_MAX + B_MIN /= 2.1875 THEN + FAILED ("3.0 + (-0.8125) /= 2.1875"); + END IF; + + IF A_MAX - B_MIN /= 3.8125 THEN + FAILED ("3.0 - (-0.8125) /= 3.8125"); + END IF; + + IF (A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625 THEN + FAILED ("(A_MAX + B_SMALL) NOT IN 3.0 .. 3.0625"); + END IF; + + IF (A_MAX - B_SMALL) NOT IN 2.9375..3.0 THEN + FAILED ("(A_MAX - B_SMALL) NOT IN 2.9375..3.0"); + END IF; + + IF A_MAX + B_MAX /= 8.0625 THEN + FAILED ("3.0 + 5.0625 /= 8.0625"); + END IF; + + IF A_MAX - B_MAX /= -2.0625 THEN + FAILED ("3.0 - 5.0625 /= -2.0625"); + END IF; + + X := B_MIN - A_MIN; + IF X NOT IN 3.0 .. 3.25 THEN + FAILED ("-0.8125 - (-4.0) NOT IN RANGE"); + END IF; + + X := B_MIN - A_SMALL; + IF X NOT IN -1.3125 .. -0.8125 THEN + FAILED ("B_MIN - A_SMALL NOT IN RANGE"); + END IF; + + X := B_MIN - A_MAX; + IF X NOT IN -4.0 .. -3.75 THEN + FAILED ("-0.8125 - 3.0 NOT IN RANGE"); + END IF; + + X := B_SMALL - A_MIN; + IF X NOT IN 4.0 .. 4.0625 THEN + FAILED ("B_SMALL - A_MIN NOT IN RANGE"); + END IF; + + + X := B_SMALL - A_MAX; + IF X NOT IN -3.0 .. -2.75 THEN + FAILED ("B_SMALL - A_MAX NOT IN RANGE"); + END IF; + + X := B_MAX - A_MIN; + IF X NOT IN 9.0 .. 9.25 THEN + FAILED ("5.0625 - (-4.0) NOT IN RANGE"); + END IF; + + X := B_MAX - A_SMALL; + IF X NOT IN 4.56 .. 5.0625 THEN + FAILED ("5.0625 - 0.5 NOT IN RANGE"); + END IF; + + X := B_MAX - A_MAX; + IF X NOT IN 2.0 .. 2.25 THEN + FAILED ("5.0625 - 3.0 NOT IN RANGE"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - C"); + END C; + + ------------------------------------------------------------------- + + RESULT; + + END C45331A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45342a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45342a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45342a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45342a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C45342A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION OF TWO OR MORE NON-NULL OPERANDS YIELDS THE + -- CORRECT RESULT, WITH THE CORRECT BOUNDS, WHETHER BOUNDS ARE STATIC OR + -- DYNAMIC. + + -- BHS 6/27/84 + + WITH REPORT; + PROCEDURE C45342A IS + + USE REPORT; + + SUBTYPE S IS INTEGER RANGE 1..100; + TYPE ARR IS ARRAY (S RANGE <>) OF INTEGER; + + A,B : ARR (2..9); + + FUNCTION F (AR_VAR1, AR_VAR2, AR_VAR3 : ARR) RETURN ARR IS + BEGIN + RETURN AR_VAR1 & AR_VAR2 & AR_VAR3; + END F; + + PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS + BEGIN + IF A'FIRST /= I1 OR A'LAST /= I2 THEN + FAILED ("INCORRECT CATENATION BOUNDS - " & NUM); + END IF; + END CAT; + + + BEGIN + + TEST ("C45342A", "CHECK THAT CATENATION OF NON-NULL OPERANDS " & + "YIELDS CORRECT RESULT WITH CORRECT BOUNDS"); + + BEGIN + A := (1,2,3,4,5,6,7,8); + B := A(2..4) & A(2..5) & A(2..2); + IF B /= (1,2,3,1,2,3,4,1) THEN + FAILED ("INCORRECT CATENATION RESULT - 1"); + END IF; + + A := (8,7,6,5,4,3,2,1); + IF F(A(2..3), A(2..4), A(2..4)) /= (8,7,8,7,6,8,7,6) THEN + FAILED ("INCORRECT CATENATION RESULT - 2"); + END IF; + + CAT ( A(3..5) & A(2..3), 3, 7, '3' ); + END; + + + DECLARE + DYN2 : INTEGER := IDENT_INT(2); + DYN3 : INTEGER := IDENT_INT(3); + DYN4 : INTEGER := IDENT_INT(4); + DYN6 : INTEGER := IDENT_INT(6); + + BEGIN + A := (1,2,3,4,5,6,7,8); + B := A(DYN2..DYN3) & A(DYN2..DYN4) & A(DYN2..DYN4); + IF B /= (1,2,1,2,3,1,2,3) THEN + FAILED ("INCORRECT CATENATION RESULT - 4"); + END IF; + + A := (8,7,6,5,4,3,2,1); + IF F ( A(DYN2..DYN6), A(DYN2..DYN3), A(DYN2..DYN2) ) + /= (8,7,6,5,4,8,7,8) THEN + FAILED ("INCORRECT CATENATION RESULT - 5"); + END IF; + + CAT ( A(DYN3..5) & A(2..3), 3, 7, '6'); + END; + + RESULT; + + END C45342A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45343a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45343a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45343a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45343a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C45343A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION OF NULL OPERANDS YIELDS THE CORRECT RESULT, + -- WITH THE CORRECT BOUNDS. + + -- BHS 6/29/84 + + WITH REPORT; + PROCEDURE C45343A IS + + USE REPORT; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE ARR_8 IS ARR (1..8); + A1, A2 : ARR_8; + + PROCEDURE CAT (A : ARR; I1,I2 : INTEGER; NUM : CHARACTER) IS + BEGIN + IF A'FIRST /= I1 OR A'LAST /= I2 THEN + FAILED ("INCORRECT CATENATION - " & NUM); + END IF; + END CAT; + + BEGIN + + TEST ("C45343A", "CATENATION OF NULL OPERANDS"); + + + A1 := (1,2,3,4,5,6,7,8); + A2 := A1(1..0) & A1(6..5) & A1(1..8); + IF A2 /= (1,2,3,4,5,6,7,8) THEN + FAILED ("INCORRECT CATENATION RESULT - 1"); + END IF; + + A1 := (1,2,3,4,5,6,7,8); + A2 := A1(2..8) & A1(1..0) & 9; + IF A2 /= (2,3,4,5,6,7,8,9) THEN + FAILED ("INCORRECT CATENATION RESULT - 2"); + END IF; + + + CAT ( A1(1..0) & A1(IDENT_INT(2)..0), 2, 0, '3' ); + CAT ( A1(IDENT_INT(1)..0) & A2(2..0), 2, 0, '4' ); + + CAT ( A1(1..0) & A1(6..5) & A1(2..8), 2, 8, '5' ); + CAT ( A1(2..8) & A1(1..0), 2, 8, '6' ); + + CAT ( A2(1..0) & A2(6..5) & A2(IDENT_INT(2)..8), 2, 8, '7' ); + CAT ( A2(IDENT_INT(2)..8) & A2(1..0), 2, 8, '8' ); + + RESULT; + + END C45343A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45344a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45344a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45344a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45344a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C45344A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CORRECT RESULT IS PRODUCED WHEN A FUNCTION RETURNS + -- THE RESULT OF A CATENATION WHOSE BOUNDS ARE NOT DEFINED STATICALLY. + + -- R.WILLIAMS 9/1/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45344A IS + + BEGIN + TEST ( "C45344A", "CHECK THAT THE CORRECT RESULT IS PRODUCED " & + "WHEN A FUNCTION RETURNS THE RESULT OF A " & + "CATENATION WHOSE BOUNDS ARE NOT DEFINED " & + "STATICALLY" ); + + DECLARE + SUBTYPE INT IS INTEGER RANGE IDENT_INT (1) .. IDENT_INT (30); + + TYPE ARR IS ARRAY (INT RANGE <>) OF INTEGER; + SUBTYPE CARR IS ARR (1 .. 9); + C : CARR; + + AR1 : ARR (IDENT_INT (2) .. IDENT_INT (4)) := + (IDENT_INT (2) .. IDENT_INT (4) => 1); + + AR2 : ARR (IDENT_INT (6) .. IDENT_INT (6)) := + (IDENT_INT (6) .. IDENT_INT (6) => 2); + + AR3 : ARR (IDENT_INT (4) .. IDENT_INT (2)); + + FUNCTION F (A, B : ARR; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN F (A & B, B, N - 1); + END IF; + END F; + + FUNCTION G (A : INTEGER; B : ARR; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN G (A, A & B, N - 1); + END IF; + END G; + + FUNCTION H (A : ARR; B : INTEGER; N : NATURAL) RETURN ARR IS + BEGIN + IF N = 0 THEN + RETURN A & B; + ELSE + RETURN H (A & B, B, N - 1); + END IF; + END H; + + PROCEDURE CHECK (X, Y : ARR; F, L : INTEGER; STR : STRING) IS + OK : BOOLEAN := TRUE; + BEGIN + IF X'FIRST /= F AND X'LAST /= L THEN + FAILED ( "INCORRECT RANGE FOR " & STR); + ELSE + FOR I IN F .. L LOOP + IF X (I) /= Y (I) THEN + OK := FALSE; + END IF; + END LOOP; + + IF NOT OK THEN + FAILED ( "INCORRECT VALUE FOR " & STR); + END IF; + END IF; + END CHECK; + + BEGIN + C := (1 .. 4 => 1, 5 .. 9 => 2); + CHECK (F (AR1, AR2, IDENT_INT (3)), C, 2, 8, "F - 1" ); + CHECK (F (AR3, AR2, IDENT_INT (3)), C, 6, 9, "F - 2" ); + CHECK (F (AR2, AR3, IDENT_INT (3)), C, 6, 6, "F - 3" ); + + C := (1 ..4 => 5, 5 .. 9 => 1); + CHECK (G (5, AR1, IDENT_INT (3)), C, 1, 7, "G - 1" ); + CHECK (G (5, AR3, IDENT_INT (3)), C, 1, 4, "G - 2" ); + + CHECK (H (AR3, 5, IDENT_INT (3)), C, 1, 4, "H - 1" ); + + C := (1 ..4 => 1, 5 .. 9 => 5); + CHECK (H (AR1, 5, IDENT_INT (3)), C, 2, 8, "H - 2" ); + END; + + RESULT; + END C45344A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45345b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45345b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45345b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45345b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C45345B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE RESULT OF + -- CATENATION HAS PRECISELY THE MAXIMUM LENGTH PERMITTED BY THE + -- INDEX SUBTYPE. + + + -- RM 2/26/82 + + + WITH REPORT; + USE REPORT; + PROCEDURE C45345B IS + + + BEGIN + + TEST ( "C45345B" , "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" & + " IF THE RESULT OF CATENATION HAS PRECISELY" & + " THE MAXIMUM LENGTH PERMITTED BY THE" & + " INDEX SUBTYPE" ); + + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_LIT & STRG_LIT --------------- + + DECLARE + + X : STRING(1..5) ; + + BEGIN + + X := "ABCD" & "E" ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_LIT & CHARACTER -------------- + + DECLARE + + X : STRING(1..5) ; + + BEGIN + + X := "ABCD" & 'E' ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + ------------------------------------------------------------------- + ----------------- STRG_VAR := STRG_VAR & STRG_VAR --------------- + + DECLARE + + X : STRING(1..5) ; + A : CONSTANT STRING := "A" ; + B : STRING(1..4) := IDENT_STR("BCDE") ; + + BEGIN + + X := A & B ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED( "'STRING & STRING' RAISED CONSTRAINT_ERROR " ); + + WHEN OTHERS => + FAILED( "'STRING & STRING' RAISED ANOTHER EXCEPTION" ); + + END; + + ------------------------------------------------------------------- + + + RESULT; + + + END C45345B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C45347A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION IS DEFINED FOR RECORD TYPES AS COMPONENT TYPES. + + -- JWC 11/15/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45347A IS + + BEGIN + + TEST ("C45347A", "CHECK THAT CATENATION IS DEFINED " & + "FOR RECORD TYPES AS COMPONENT TYPES"); + + DECLARE + + TYPE REC IS + RECORD + X : INTEGER; + END RECORD; + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE A IS ARRAY ( INT RANGE <>) OF REC; + + R1 : REC := (X => 4); + R2 : REC := (X => 1); + + A1 : A(1 .. 2) := ((X => 1), (X => 2)); + A2 : A(1 .. 2) := ((X => 3), (X => 4)); + A3 : A(1 .. 4) := ((X => 1), (X => 2), (X => 3), (X => 4)); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := ((X => 4), (X => 3), (X => 2), (X => 1)); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " & + "RECORDS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & R1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF RECORD, " & + "AND RECORDS"); + END IF; + + A4 := A5; + + A4 := R2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR RECORDS, " & + "AND ARRAY OF RECORDS"); + END IF; + + A4 := A5; + + A4 := R2 & A1(2) & (A2(1) & R1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR RECORDS"); + END IF; + + END; + + RESULT; + + END C45347A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C45347B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION IS DEFINED FOR ARRAY TYPES AS COMPONENT TYPES. + + -- JWC 11/15/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45347B IS + + BEGIN + + TEST ("C45347B", "CHECK THAT CATENATION IS DEFINED " & + "FOR ARRAY TYPES AS COMPONENT TYPES"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 2) OF INTEGER; + TYPE A IS ARRAY ( INTEGER RANGE <>) OF ARR; + + AR1 : ARR := (4,1); + AR2 : ARR := (1,1); + + A1 : A(1 .. 2) := ((1,1), (2,1)); + A2 : A(1 .. 2) := ((3,1), (4,1)); + A3 : A(1 .. 4) := ((1,1), (2,1), (3,1), (4,1)); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := ((4,1), (3,1), (2,1), (1,1)); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS OF ARRAYS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & AR1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF ARRAYS " & + "WITH ARRAYS"); + END IF; + + A4 := A5; + + A4 := AR2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS WITH ARRAYS " & + "OF ARRAYS"); + END IF; + + A4 := A5; + + A4 := A'(AR2 & A1(2)) & A'(A2(1) & AR1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAYS"); + END IF; + + END; + + RESULT; + + END C45347B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C45347C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION IS DEFINED FOR PRIVATE TYPES AS COMPONENT + -- TYPES. + + -- JWC 11/15/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45347C IS + + BEGIN + + TEST ("C45347C", "CHECK THAT CATENATION IS DEFINED " & + "FOR PRIVATE TYPES AS COMPONENT TYPES"); + + DECLARE + + PACKAGE PKG IS + TYPE PRIV IS PRIVATE; + ONE : CONSTANT PRIV; + TWO : CONSTANT PRIV; + THREE : CONSTANT PRIV; + FOUR : CONSTANT PRIV; + PRIVATE + TYPE PRIV IS NEW INTEGER; + ONE : CONSTANT PRIV := 1; + TWO : CONSTANT PRIV := 2; + THREE : CONSTANT PRIV := 3; + FOUR : CONSTANT PRIV := 4; + END PKG; + + USE PKG; + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE A IS ARRAY ( INT RANGE <>) OF PRIV; + + P1 : PRIV := FOUR; + P2 : PRIV := ONE; + + A1 : A(1 .. 2) := (ONE, TWO); + A2 : A(1 .. 2) := (THREE, FOUR); + A3 : A(1 .. 4) := (ONE, TWO, THREE, FOUR); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := (FOUR, THREE, TWO, ONE); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF " & + "PRIVATE"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & P1; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF PRIVATE, " & + "AND PRIVATE"); + END IF; + + A4 := A5; + + A4 := P2 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR PRIVATE, AND ARRAY " & + "OF PRIVATE"); + END IF; + + A4 := A5; + + A4 := P2 & A1(2) & (A2(1) & P1); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR PRIVATE"); + END IF; + + END; + + RESULT; + + END C45347C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45347d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45347d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C45347D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CATENATION IS DEFINED FOR ACCESS TYPES AS COMPONENT TYPES. + + -- JWC 11/15/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C45347D IS + + BEGIN + + TEST ("C45347D", "CHECK THAT CATENATION IS DEFINED " & + "FOR ACCESS TYPES AS COMPONENT TYPES"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1 .. 4; + TYPE ACC IS ACCESS INT; + TYPE A IS ARRAY ( INT RANGE <>) OF ACC; + + AC1 : ACC := NEW INT'(1); + AC2 : ACC := NEW INT'(2); + AC3 : ACC := NEW INT'(3); + AC4 : ACC := NEW INT'(4); + + A1 : A(1 .. 2) := (AC1, AC2); + A2 : A(1 .. 2) := (AC3, AC4); + A3 : A(1 .. 4) := (AC1, AC2, AC3, AC4); + A4 : A(1 .. 4); + A5 : A(1 .. 4) := (AC4, AC3, AC2, AC1); + + BEGIN + + A4 := A1 & A2; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR TWO ARRAYS OF ACCESS"); + END IF; + + A4 := A5; + + A4 := A1 & A2(1) & AC4; + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ARRAY OF ACCESS, " & + "AND ACCESS"); + END IF; + + A4 := A5; + + A4 := AC1 & (A1(2) & A2); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ACCESS, AND ARRAY " & + "OF ACCESS"); + END IF; + + A4 := A5; + + A4 := AC1 & A1(2) & (A2(1) & AC4); + + IF A3 /= A4 THEN + FAILED ("INCORRECT CATENATION FOR ACCESS"); + END IF; + + END; + + RESULT; + + END C45347D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C45411A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR + -- PREDEFINED INTEGER OPERANDS. + + -- HISTORY: + -- JET 01/25/88 CREATED ORIGINAL TEST. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + + WITH REPORT; USE REPORT; + + PROCEDURE C45411A IS + + TYPE DT IS NEW INTEGER RANGE -3..3; + I1 : INTEGER := 1; + D1 : DT := 1; + + BEGIN + TEST ("C45411A", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT_INT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT_INT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..INTEGER(1) LOOP + IF -I /= IDENT_INT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT_INT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT_INT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT_INT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT_INT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT_INT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT_INT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT_INT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT_INT(INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + IF INTEGER'LAST + INTEGER'FIRST = 0 THEN + IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST THEN + FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST"); + END IF; + ELSE + IF IDENT_INT(-INTEGER'LAST) /= INTEGER'FIRST+1 THEN + FAILED ("-INTEGER'LAST IS NOT EQUAL TO INTEGER'FIRST+1"); + END IF; + END IF; + + RESULT; + + END C45411A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C45411B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR + -- PREDEFINED SHORT_INTEGER OPERANDS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE PREDEFINED SHORT_INTEGER TYPE. + + -- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION + -- OF TYPE "DT" MUST BE REJECTED. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + -- KAS 01/12/95 DELETED INCOMPATIBLE SUBTEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C45411B IS + + TYPE DT IS NEW SHORT_INTEGER RANGE -3..3; -- N/A => ERROR. + I1 : SHORT_INTEGER := 1; + D1 : DT := 1; + + FUNCTION IDENT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN A * SHORT_INTEGER(IDENT_INT(1)); + END; + + BEGIN + TEST ("C45411B", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED SHORT_INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF -I /= IDENT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..SHORT_INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + SHORT_INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT(SHORT_INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + SHORT_INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + + RESULT; + + END C45411B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C45411C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR + -- PREDEFINED LONG_INTEGER OPERANDS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE PREDEFINED LONG_INTEGER TYPE. + + -- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE DECLARATION + -- OF TYPE "DT" MUST BE REJECTED. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + -- KAS 01/12/95 REMOVED INCOMPATIBLE SUBTEST + + WITH REPORT; USE REPORT; + + PROCEDURE C45411C IS + + TYPE DT IS NEW LONG_INTEGER RANGE -3..3; -- N/A => ERROR. + I1 : LONG_INTEGER := 1; + D1 : DT := 1; + + FUNCTION IDENT (A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN A * LONG_INTEGER(IDENT_INT(1)); + END; + + BEGIN + TEST ("C45411C", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR PREDEFINED LONG_INTEGER " & + "OPERANDS"); + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF "-"(RIGHT => I1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+2)); + END IF; + + IF +I1 /= IDENT(I1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+2)); + END IF; + I1 := I1 - 1; + END LOOP; + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF -I /= IDENT(0)-I THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+5)); + END IF; + + IF "+"(RIGHT => IDENT(I)) /= I THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+5)); + END IF; + END LOOP; + + IF -1 /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 7"); + END IF; + + IF "-"(RIGHT => 0) /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 8"); + END IF; + + IF "-"(RIGHT => "-"(RIGHT => 1)) /= IDENT(1) THEN + FAILED ("INCORRECT RESULT FOR ""-"" - 9"); + END IF; + + IF "+"(RIGHT => 1) /= IDENT(2)-1 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 7"); + END IF; + + IF +0 /= IDENT(0) THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 8"); + END IF; + + IF +(-1) /= IDENT(1)-2 THEN + FAILED ("INCORRECT RESULT FOR ""+"" - 9"); + END IF; + + FOR I IN (1-2)..LONG_INTEGER(1) LOOP + IF "-"(RIGHT => D1) /= DT(IDENT(I)) THEN + FAILED ("INCORRECT RESULT FOR ""-"" -" & + LONG_INTEGER'IMAGE(I+11)); + END IF; + + IF +D1 /= DT(IDENT(LONG_INTEGER(D1))) THEN + FAILED ("INCORRECT RESULT FOR ""+"" -" & + LONG_INTEGER'IMAGE(I+11)); + END IF; + D1 := D1 - 1; + END LOOP; + + + RESULT; + + END C45411C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45411d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45411d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C45411D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNARY "+" AND "-" YIELD CORRECT RESULTS FOR + -- OPERANDS OF DERIVED INTEGER TYPES. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + + WITH REPORT; USE REPORT; + + PROCEDURE C45411D IS + + TYPE INT IS RANGE -100..100; + + TYPE DT1 IS NEW INTEGER; + TYPE DT2 IS NEW INT; + + D1 : DT1 := 1; + D2 : DT2 := 1; + + FUNCTION IDENT (A : DT1) RETURN DT1 IS + BEGIN + RETURN A * DT1(IDENT_INT(1)); + END IDENT; + + FUNCTION IDENT (A : DT2) RETURN DT2 IS + BEGIN + RETURN A * DT2(IDENT_INT(1)); + END IDENT; + + BEGIN + TEST ("C45411D", "CHECK THAT UNARY ""+"" AND ""-"" YIELD " & + "CORRECT RESULTS FOR OPERANDS OF DERIVED " & + "INTEGER TYPES"); + + FOR I IN DT1'(1-2)..DT1'(1) LOOP + IF "-"(RIGHT => D1) /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" DT1 -" & + DT1'IMAGE(I+2)); + END IF; + + IF +D1 /= IDENT(D1) THEN + FAILED ("INCORRECT RESULT FOR ""+"" DT1 -" & + DT1'IMAGE(I+2)); + END IF; + D1 := D1 - 1; + END LOOP; + + IF DT1'LAST + DT1'FIRST = 0 THEN + IF IDENT(-DT1'LAST) /= DT1'FIRST THEN + FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST"); + END IF; + ELSE + IF IDENT(-DT1'LAST) /= DT1'FIRST+1 THEN + FAILED ("-DT1'LAST IS NOT EQUAL TO DT1'FIRST+1"); + END IF; + END IF; + + FOR I IN DT2'(1-2)..DT2'(1) LOOP + IF -D2 /= IDENT(I) THEN + FAILED ("INCORRECT RESULT FOR ""-"" DT2 -" & + DT2'IMAGE(I+2)); + END IF; + + IF "+"(RIGHT => D2) /= IDENT(D2) THEN + FAILED ("INCORRECT RESULT FOR ""+"" DT2 -" & + DT2'IMAGE(I+2)); + END IF; + D2 := D2 - 1; + END LOOP; + + RESULT; + + END C45411D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45413a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45413a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45413a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45413a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C45413A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNARY MINUS YIELDS AND ACCEPTS RESULTS BELONGING TO + -- THE BASE TYPE. + + -- JBG 2/24/84 + -- JRL 10/13/96 Removed static expressions which contained values outside + -- the base range. + + WITH REPORT; USE REPORT; + PROCEDURE C45413A IS + + TYPE INT IS RANGE 1..10; + + X : INT := INT(IDENT_INT(9)); + + BEGIN + + TEST ("C45413A", "CHECK SUBTYPE OF UNARY PLUS/MINUS"); + + BEGIN + + IF -X /= INT'VAL(-9) THEN + FAILED ("INCORRECT RESULT - UNARY MINUS"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("UNARY MINUS DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + + IF -(INT'VAL(-9)) /= 9 THEN + FAILED ("WRONG RESULT - UNARY MINUS"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("UNARY MINUS ARGUMENT NOT IN BASE TYPE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + RESULT; + + END C45413A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45431a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45431a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45431a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45431a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C45431A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR FIXED POINT TYPES +A = A AND THAT, FOR MODEL NUMBERS, + -- -(-A) = A. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF DURATION'BASE. + + -- WRG 8/28/86 + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE C45431A IS + + BEGIN + + TEST ("C45431A", "CHECK THAT FOR FIXED POINT TYPES +A = A AND " & + "THAT, FOR MODEL NUMBERS, -(-A) = A " & + "-- BASIC TYPES"); + + ------------------------------------------------------------------- + + A: DECLARE + TYPE LIKE_DURATION IS DELTA 0.020 RANGE -86_400.0 .. 86_400.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : LIKE_DURATION := 0.0; + + SMALL, MAX, MIN, ZERO : LIKE_DURATION := 0.5; + X : LIKE_DURATION := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + NON_MODEL_VAR := NON_MODEL_CONST; + SMALL := LIKE_DURATION'SMALL; + MAX := LIKE_DURATION'LAST; + MIN := LIKE_DURATION'FIRST; + ZERO := 0.0; + END IF; + + -- CHECK + OR - ZERO = ZERO: + IF "+"(RIGHT => ZERO) /= 0.0 OR + +LIKE_DURATION'(0.0) /= ZERO THEN + FAILED ("+0.0 /= 0.0"); + END IF; + IF "-"(RIGHT => ZERO) /= 0.0 OR + -LIKE_DURATION'(0.0) /= ZERO THEN + FAILED ("-0.0 /= 0.0"); + END IF; + IF -(-ZERO) /= 0.0 THEN + FAILED ("-(-0.0) /= 0.0"); + END IF; + + -- CHECK + AND - MAX: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF +X /= MAX OR +LIKE_DURATION'LAST /= MAX THEN + FAILED ("+LIKE_DURATION'LAST /= LIKE_DURATION'LAST"); + END IF; + IF -(-X) /= MAX OR -(-LIKE_DURATION'LAST) /= MAX THEN + FAILED ("-(-LIKE_DURATION'LAST) /= LIKE_DURATION'LAST"); + END IF; + + -- CHECK + AND - MIN: + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF +X /= MIN OR +LIKE_DURATION'FIRST /= MIN THEN + FAILED ("+LIKE_DURATION'FIRST /= LIKE_DURATION'FIRST"); + END IF; + IF -(-X) /= MIN OR -(-LIKE_DURATION'FIRST) /= MIN THEN + FAILED("-(-LIKE_DURATION'FIRST) /= LIKE_DURATION'FIRST"); + END IF; + + -- CHECK + AND - SMALL: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF +X /= SMALL OR +LIKE_DURATION'SMALL /= SMALL THEN + FAILED ("+LIKE_DURATION'SMALL /= LIKE_DURATION'SMALL"); + END IF; + IF -(-X) /= SMALL OR -(-LIKE_DURATION'SMALL) /= SMALL THEN + FAILED("-(-LIKE_DURATION'SMALL) /= LIKE_DURATION'SMALL"); + END IF; + + -- CHECK ARBITRARY MID-RANGE NUMBERS: + IF EQUAL (3, 3) THEN + X := 1000.984_375; + END IF; + IF +X /= 1000.984_375 OR +1000.984_375 /= X THEN + FAILED ("+1000.984_375 /= 1000.984_375"); + END IF; + IF -(-X) /= 1000.984_375 OR -(-1000.984_375) /= X THEN + FAILED ("-(-1000.984_375) /= 1000.984_375"); + END IF; + + -- CHECK "+" AND "-" FOR NON-MODEL NUMBER: + IF +LIKE_DURATION'(NON_MODEL_CONST) NOT IN 0.656_25 .. + 0.671_875 OR + +NON_MODEL_VAR NOT IN 0.656_25 .. 0.671_875 THEN + FAILED ("+LIKE_DURATION'(2.0 / 3) NOT IN 0.656_25 .. " & + "0.671_875"); + END IF; + IF -LIKE_DURATION'(NON_MODEL_CONST) NOT IN -0.671_875 .. + -0.656_25 OR + -NON_MODEL_VAR NOT IN -0.671_875 .. -0.656_25 THEN + FAILED ("-LIKE_DURATION'(2.0 / 3) NOT IN -0.671_875 " & + ".. -0.656_25"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -- A"); + END A; + + ------------------------------------------------------------------- + + B: DECLARE + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : DECIMAL_M4 := 0.0; + + SMALL, MAX, MIN, ZERO : DECIMAL_M4 := -128.0; + X : DECIMAL_M4 := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + NON_MODEL_VAR := NON_MODEL_CONST; + SMALL := DECIMAL_M4'SMALL; + ZERO := 0.0; + END IF; + + -- CHECK + OR - ZERO = ZERO: + IF +ZERO /= 0.0 OR +DECIMAL_M4'(0.0) /= ZERO THEN + FAILED ("+0.0 /= 0.0"); + END IF; + IF -ZERO /= 0.0 OR -DECIMAL_M4'(0.0) /= ZERO THEN + FAILED ("-0.0 /= 0.0"); + END IF; + IF -(-ZERO) /= 0.0 THEN + FAILED ("-(-0.0) /= 0.0"); + END IF; + + -- CHECK + AND - MAX: + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + -- CHECK + AND - SMALL: + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF +X /= SMALL OR +DECIMAL_M4'SMALL /= SMALL THEN + FAILED ("+DECIMAL_M4'SMALL /= DECIMAL_M4'SMALL"); + END IF; + IF -(-X) /= SMALL OR -(-DECIMAL_M4'SMALL) /= SMALL THEN + FAILED ("-(-DECIMAL_M4'SMALL) /= DECIMAL_M4'SMALL"); + END IF; + + -- CHECK ARBITRARY MID-RANGE NUMBERS: + IF EQUAL (3, 3) THEN + X := 256.0; + END IF; + IF +X /= 256.0 OR +256.0 /= X THEN + FAILED ("+256.0 /= 256.0"); + END IF; + IF -(-X) /= 256.0 OR -(-256.0) /= X THEN + FAILED ("-(-256.0) /= 256.0"); + END IF; + + -- CHECK "+" AND "-" FOR NON-MODEL NUMBER: + IF +DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 OR + +NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN + FAILED ("+DECIMAL_M4'(2.0 / 3) NOT IN 0.0 .. 64.0"); + END IF; + IF -DECIMAL_M4'(NON_MODEL_CONST) NOT IN -64.0 .. 0.0 OR + -NON_MODEL_VAR NOT IN -64.0 .. 0.0 THEN + FAILED ("-DECIMAL_M4'(2.0 / 3) NOT IN -64.0 .. 0.0"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -- B"); + END B; + + ------------------------------------------------------------------- + + RESULT; + + END C45431A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c455001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c455001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c455001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c455001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C455001.A + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that universal fixed multiplying operators can be used without + -- a conversion in contexts where the result type is determined. + -- + -- Note: This is intended to check the changes made to these operators + -- in Ada 95; legacy tests should cover cases from Ada 83. + -- + -- CHANGE HISTORY: + -- 18 MAR 99 RLB Initial version + -- + --! + + with Report; use Report; + + procedure C455001 is + + type F1 is delta 2.0**(-1) range 0.0 .. 8.0; + + type F2 is delta 2.0**(-2) range 0.0 .. 4.0; + + type F3 is delta 2.0**(-3) range 0.0 .. 2.0; + + A : F1; + B : F2; + C : F3; + + type Fixed_Record is record + D : F1; + E : F2; + end record; + + R : Fixed_Record; + + function Ident_Fix (X : F3) return F3 is + begin + if Equal(3,3) then + return X; + else + return 0.0; + end if; + end Ident_Fix; + + begin + Test ("C455001", "Check that universal fixed multiplying operators " & + "can be used without a conversion in contexts where " & + "the result type is determined."); + + A := 1.0; B := 1.0; + C := A * B; -- Assignment context. + + if C /= Ident_Fix(1.0) then + Failed ("Incorrect results for multiplication (1) - result is " & + F3'Image(C)); + end if; + + C := A / B; + + if C /= Ident_Fix(1.0) then + Failed ("Incorrect results for division (1) - result is " & + F3'Image(C)); + end if; + + A := 2.5; + C := A * 0.25; + + if C /= Ident_Fix(0.625) then + Failed ("Incorrect results for multiplication (2) - result is " & + F3'Image(C)); + end if; + + C := A / 4.0; + + if C /= Ident_Fix(0.625) then + Failed ("Incorrect results for division (2) - result is " & + F3'Image(C)); + end if; + + C := Ident_Fix(0.75); + C := C * 0.5; + + if C /= Ident_Fix(0.375) then + Failed ("Incorrect results for multiplication (3) - result is " & + F3'Image(C)); + end if; + + C := Ident_Fix(0.75); + C := C / 0.5; + + if C /= Ident_Fix(1.5) then + Failed ("Incorrect results for division (3) - result is " & + F3'Image(C)); + end if; + + A := 0.5; B := 0.3; -- Function parameter context. + if Ident_Fix(A * B) not in Ident_Fix(0.125) .. Ident_Fix(0.25) then + Failed ("Incorrect results for multiplication (4) - result is " & + F3'Image(A * B)); -- Exact = 0.15 + end if; + + B := 0.8; + if Ident_Fix(A / B) not in Ident_Fix(0.5) .. Ident_Fix(0.75) then + Failed ("Incorrect results for division (4) - result is " & + F3'Image(A / B)); + -- Exact = 0.625..., but B is only restricted to the range + -- 0.75 .. 1.0, so the result can be anywhere in the range + -- 0.5 .. 0.75. + end if; + + C := 0.875; B := 1.5; + R := (D => C * 4.0, E => B / 0.5); -- Aggregate context. + + if R.D /= 3.5 then + Failed ("Incorrect results for multiplication (5) - result is " & + F1'Image(R.D)); + end if; + + if R.E /= 3.0 then + Failed ("Incorrect results for division (5) - result is " & + F2'Image(R.E)); + end if; + + A := 0.5; + C := A * F1'(B * 2.0); -- Qualified expression context. + + if C /= Ident_Fix(1.5) then + Failed ("Incorrect results for multiplication (6) - result is " & + F3'Image(C)); + end if; + + A := 4.0; + C := F1'(B / 0.5) / A; + + if C /= Ident_Fix(0.75) then + Failed ("Incorrect results for division (6) - result is " & + F3'Image(C)); + end if; + + Result; + + end C455001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45502b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45502b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45502b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45502b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,291 ---- + -- C45502B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MULTIPLICATION AND DIVISION YIELD CORRECT RESULTS WHEN + -- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + PROCEDURE C45502B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S))); + END IDENT; + + BEGIN + TEST ( "C45502B", "CHECK THAT MULTIPLICATION AND DIVISION " & + "YIELD CORRECT RESULTS WHEN THE OPERANDS " & + "ARE OF PREDEFINED TYPE SHORT_INTEGER" ); + + DECLARE + I0 : SHORT_INTEGER := 0; + I1 : SHORT_INTEGER := 1; + I2 : SHORT_INTEGER := 2; + I3 : SHORT_INTEGER := 3; + I5 : SHORT_INTEGER := 5; + I10 : SHORT_INTEGER := 10; + I11 : SHORT_INTEGER := 11; + I12 : SHORT_INTEGER := 12; + I13 : SHORT_INTEGER := 13; + I14 : SHORT_INTEGER := 14; + N1 : SHORT_INTEGER := -1; + N2 : SHORT_INTEGER := -2; + N5 : SHORT_INTEGER := -5; + N10 : SHORT_INTEGER := -10; + N11 : SHORT_INTEGER := -11; + N12 : SHORT_INTEGER := -12; + N13 : SHORT_INTEGER := -13; + N14 : SHORT_INTEGER := -14; + N50 : SHORT_INTEGER := -50; + + BEGIN + IF I0 * SHORT_INTEGER'FIRST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "SHORT_INTEGER'FIRST" ); + END IF; + + IF I0 * SHORT_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "SHORT_INTEGER'LAST" ); + END IF; + + IF N1 * SHORT_INTEGER'LAST + SHORT_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR N1 * " & + "SHORT_INTEGER'LAST" ); + END IF; + + IF I3 * I1 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I3 * I1" ); + END IF; + + IF IDENT (I3) * IDENT (I1) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " & + "IDENT (I1)" ); + END IF; + + IF I2 * N1 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I2 * N1" ); + END IF; + + IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " & + "RIGHT => N1)" ); + END IF; + + IF IDENT (I2) * IDENT (N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " & + "IDENT (N1)" ); + END IF; + + IF I5 * I2 * N5 /= N50 THEN + FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" ); + END IF; + + IF IDENT (N1) * IDENT (N5) /= I5 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (N5)" ); + END IF; + + IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /= + I5 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " & + "IDENT (N1), RIGHT => IDENT (N5))" ); + END IF; + + IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10 + THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (I2) * IDENT (N5)" ); + END IF; + + IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " & + "IDENT (I10)" ); + END IF; + + IF I0 * I10 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 * I10" ); + END IF; + + IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " & + "RIGHT => I10)" ); + END IF; + + IF IDENT (I10) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) " & + "/ IDENT (I5)" ); + END IF; + + IF I11 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I11 / I5" ); + END IF; + + IF IDENT (I12) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (I12), RIGHT => IDENT (I5))" ); + END IF; + + IF I13 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I13 / I5" ); + END IF; + + IF IDENT (I14) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) " & + "/ IDENT (I5)" ); + END IF; + + IF I10 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I10 / N5" ); + END IF; + + IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I11) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) " & + "/ IDENT (N5)" ); + END IF; + + IF I12 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I12 / N5" ); + END IF; + + IF IDENT (I13) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) " & + "/ IDENT (N5)" ); + END IF; + + IF I14 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I14 / N5" ); + END IF; + + IF IDENT (N10) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /= + N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N10), RIGHT => IDENT (I5))" ); + END IF; + + IF N11 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N11 / I5" ); + END IF; + + IF IDENT (N12) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) " & + "/ IDENT (I5)" ); + END IF; + + IF N13 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N13 / I5" ); + END IF; + + IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N14) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) " & + "/ IDENT (I5)" ); + END IF; + + IF N10 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N10 / N5" ); + END IF; + + IF IDENT (N11) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) " & + "/ IDENT (N5)" ); + END IF; + + IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (N5))" ); + END IF; + + IF N12 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N12 / N5" ); + END IF; + + + IF IDENT (N13) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) " & + "/ IDENT (N5)" ); + END IF; + + IF N14 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N14 / N5" ); + END IF; + + IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " & + "RIGHT => N5)" ); + END IF; + + IF I0 / I5 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 / I5" ); + END IF; + + IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " & + "RIGHT => I5)" ); + END IF; + + IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " & + "IDENT (I5)" ); + END IF; + + END; + + RESULT; + END C45502B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45502c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45502c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45502c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45502c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,295 ---- + -- C45502C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MULTIPLICATION AND DIVISION YIELD CORRECT RESULTS WHEN + -- THE OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- HISTORY: + -- RJW 09/01/86 + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + PROCEDURE C45502C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN S; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN + TEST ( "C45502C", "CHECK THAT MULTIPLICATION AND DIVISION " & + "YIELD CORRECT RESULTS WHEN THE OPERANDS " & + "ARE OF PREDEFINED TYPE LONG_INTEGER" ); + + DECLARE + I0 : LONG_INTEGER := 0; + I1 : LONG_INTEGER := 1; + I2 : LONG_INTEGER := 2; + I3 : LONG_INTEGER := 3; + I5 : LONG_INTEGER := 5; + I10 : LONG_INTEGER := 10; + I11 : LONG_INTEGER := 11; + I12 : LONG_INTEGER := 12; + I13 : LONG_INTEGER := 13; + I14 : LONG_INTEGER := 14; + N1 : LONG_INTEGER := -1; + N2 : LONG_INTEGER := -2; + N5 : LONG_INTEGER := -5; + N10 : LONG_INTEGER := -10; + N11 : LONG_INTEGER := -11; + N12 : LONG_INTEGER := -12; + N13 : LONG_INTEGER := -13; + N14 : LONG_INTEGER := -14; + N50 : LONG_INTEGER := -50; + + BEGIN + IF I0 * LONG_INTEGER'FIRST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "LONG_INTEGER'FIRST" ); + END IF; + + IF I0 * LONG_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR I0 * " & + "LONG_INTEGER'LAST" ); + END IF; + + IF N1 * LONG_INTEGER'LAST + LONG_INTEGER'LAST /= 0 THEN + FAILED ( "INCORRECT RESULT FOR N1 * " & + "LONG_INTEGER'LAST" ); + END IF; + + IF I3 * I1 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I3 * I1" ); + END IF; + + IF IDENT (I3) * IDENT (I1) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I3) * " & + "IDENT (I1)" ); + END IF; + + IF I2 * N1 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I2 * N1" ); + END IF; + + IF "*" (LEFT => I2, RIGHT => N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I2, " & + "RIGHT => N1)" ); + END IF; + + IF IDENT (I2) * IDENT (N1) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I2) * " & + "IDENT (N1)" ); + END IF; + + IF I5 * I2 * N5 /= N50 THEN + FAILED ( "INCORRECT RESULT FOR I5 * I2 * N5" ); + END IF; + + IF IDENT (N1) * IDENT (N5) /= I5 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (N5)" ); + END IF; + + IF "*" (LEFT => IDENT (N1), RIGHT => IDENT (N5)) /= + I5 THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => " & + "IDENT (N1), RIGHT => IDENT (N5))" ); + END IF; + + IF IDENT (N1) * IDENT (I2) * IDENT (N5) /= I10 + THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N1) * " & + "IDENT (I2) * IDENT (N5)" ); + END IF; + + IF (-IDENT (I0)) * IDENT (I10) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) * " & + "IDENT (I10)" ); + END IF; + + IF I0 * I10 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 * I10" ); + END IF; + + IF "*" (LEFT => I0, RIGHT => I10) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""*"" (LEFT => I0, " & + "RIGHT => I10)" ); + END IF; + + IF IDENT (I10) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) " & + "/ IDENT (I5)" ); + END IF; + + IF I11 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I11 / I5" ); + END IF; + + IF IDENT (I12) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (I12), RIGHT => IDENT (I5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (I12), RIGHT => IDENT (I5))" ); + END IF; + + IF I13 / I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I13 / I5" ); + END IF; + + IF IDENT (I14) / IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) " & + "/ IDENT (I5)" ); + END IF; + + IF I10 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I10 / N5" ); + END IF; + + IF "/" (LEFT => I10, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I10, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I11) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) " & + "/ IDENT (N5)" ); + END IF; + + IF I12 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I12 / N5" ); + END IF; + + IF IDENT (I13) / IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) " & + "/ IDENT (N5)" ); + END IF; + + IF I14 / N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I14 / N5" ); + END IF; + + IF IDENT (N10) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) " & + "/ IDENT (I5)" ); + END IF; + + IF "/" (LEFT => IDENT (N10), RIGHT => IDENT (I5)) /= + N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N10), RIGHT => IDENT (I5))" ); + END IF; + + IF N11 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N11 / I5" ); + END IF; + + IF IDENT (N12) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) " & + "/ IDENT (I5)" ); + END IF; + + IF N13 / I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N13 / I5" ); + END IF; + + IF "/" (LEFT => N13, RIGHT => I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N13, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N14) / IDENT (I5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) " & + "/ IDENT (I5)" ); + END IF; + + IF N10 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N10 / N5" ); + END IF; + + IF IDENT (N11) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) " & + "/ IDENT (N5)" ); + END IF; + + IF "/" (LEFT => IDENT (N11), RIGHT => IDENT (N5)) /= + I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (N5))" ); + END IF; + + IF N12 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N12 / N5" ); + END IF; + + + IF IDENT (N13) / IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) " & + "/ IDENT (N5)" ); + END IF; + + IF N14 / N5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR N14 / N5" ); + END IF; + + IF "/" (LEFT => N14, RIGHT => N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => N14, " & + "RIGHT => N5)" ); + END IF; + + IF I0 / I5 /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR I0 / I5" ); + END IF; + + IF "/" (LEFT => I0, RIGHT => I5) /= (-I0) THEN + FAILED ( "INCORRECT RESULT FOR ""/"" (LEFT => I0, " & + "RIGHT => I5)" ); + END IF; + + IF (-IDENT (I0)) / IDENT (I5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR (-IDENT (I0)) / " & + "IDENT (I5)" ); + END IF; + + END; + + RESULT; + END C45502C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,310 ---- + -- C45503A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE OPERANDS + -- ARE OF PREDEFINED TYPE INTEGER. + + -- R.WILLIAMS 9/1/86 + + WITH REPORT; USE REPORT; + PROCEDURE C45503A IS + + BEGIN + TEST ( "C45503A", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE INTEGER" ); + + DECLARE + I0 : INTEGER := 0; + I1 : INTEGER := 1; + I2 : INTEGER := 2; + I3 : INTEGER := 3; + I4 : INTEGER := 4; + I5 : INTEGER := 5; + I10 : INTEGER := 10; + I11 : INTEGER := 11; + I12 : INTEGER := 12; + I13 : INTEGER := 13; + I14 : INTEGER := 14; + N1 : INTEGER := -1; + N2 : INTEGER := -2; + N3 : INTEGER := -3; + N4 : INTEGER := -4; + N5 : INTEGER := -5; + N10 : INTEGER := -10; + N11 : INTEGER := -11; + N12 : INTEGER := -12; + N13 : INTEGER := -13; + N14 : INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT_INT (I11) REM IDENT_INT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (I13) REM IDENT_INT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT_INT (I10) REM IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT_INT (I12) REM IDENT_INT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT_INT (I14) REM IDENT_INT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT_INT (N11) REM IDENT_INT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT_INT (N13) REM IDENT_INT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) REM " & + "IDENT_INT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (N10) REM IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT_INT (N12) REM IDENT_INT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT_INT (N14) REM IDENT_INT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) REM " & + "IDENT_INT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT_INT (I11) MOD IDENT_INT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I11) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (I13) MOD IDENT_INT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I13) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT_INT (I10) MOD IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I10) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (I10), RIGHT => IDENT_INT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (I10), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT_INT (I12) MOD IDENT_INT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I12) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT_INT (I14) MOD IDENT_INT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (I14) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT_INT (N11) MOD IDENT_INT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N11) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (N11), RIGHT => IDENT_INT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (N11), RIGHT => IDENT_INT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT_INT (N13) MOD IDENT_INT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N13) MOD " & + "IDENT_INT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT_INT (N10) MOD IDENT_INT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N10) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT_INT (N12) MOD IDENT_INT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N12) MOD " & + "IDENT_INT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT_INT (N12), RIGHT => IDENT_INT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT_INT (N12), RIGHT => IDENT_INT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT_INT (N14) MOD IDENT_INT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT_INT (N14) MOD " & + "IDENT_INT (N5)" ); + END IF; + END; + + RESULT; + END C45503A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,327 ---- + -- C45503B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE + -- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + PROCEDURE C45503B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (S : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (S))); + END IDENT; + + BEGIN + TEST ( "C45503B", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE SHORT_INTEGER" ); + + DECLARE + I0 : SHORT_INTEGER := 0; + I1 : SHORT_INTEGER := 1; + I2 : SHORT_INTEGER := 2; + I3 : SHORT_INTEGER := 3; + I4 : SHORT_INTEGER := 4; + I5 : SHORT_INTEGER := 5; + I10 : SHORT_INTEGER := 10; + I11 : SHORT_INTEGER := 11; + I12 : SHORT_INTEGER := 12; + I13 : SHORT_INTEGER := 13; + I14 : SHORT_INTEGER := 14; + N1 : SHORT_INTEGER := -1; + N2 : SHORT_INTEGER := -2; + N3 : SHORT_INTEGER := -3; + N4 : SHORT_INTEGER := -4; + N5 : SHORT_INTEGER := -5; + N10 : SHORT_INTEGER := -10; + N11 : SHORT_INTEGER := -11; + N12 : SHORT_INTEGER := -12; + N13 : SHORT_INTEGER := -13; + N14 : SHORT_INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT (I11) REM IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " & + "IDENT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) REM IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " & + "IDENT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT (I10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT (I12) REM IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " & + "IDENT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) REM IDENT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " & + "IDENT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT (N11) REM IDENT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " & + "IDENT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT (N13) REM IDENT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " & + "IDENT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " & + "IDENT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT (N12) REM IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT (N14) REM IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " & + "IDENT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT (I11) MOD IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " & + "IDENT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) MOD IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " & + "IDENT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT (I10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT (I12) MOD IDENT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " & + "IDENT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) MOD IDENT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " & + "IDENT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT (N11) MOD IDENT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " & + "IDENT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT (N13) MOD IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " & + "IDENT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " & + "IDENT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT (N12) MOD IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT (N14) MOD IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " & + "IDENT (N5)" ); + END IF; + END; + + RESULT; + END C45503B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45503c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45503c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,331 ---- + -- C45503C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'REM' AND 'MOD' YIELD CORRECT RESULTS WHEN THE + -- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + PROCEDURE C45503C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (L : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN L; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN + TEST ( "C45503C", "CHECK THAT 'REM' AND 'MOD' YIELD CORRECT " & + "RESULTS WHEN THE OPERANDS ARE OF PREDEFINED " & + "TYPE LONG_INTEGER" ); + + DECLARE + I0 : LONG_INTEGER := 0; + I1 : LONG_INTEGER := 1; + I2 : LONG_INTEGER := 2; + I3 : LONG_INTEGER := 3; + I4 : LONG_INTEGER := 4; + I5 : LONG_INTEGER := 5; + I10 : LONG_INTEGER := 10; + I11 : LONG_INTEGER := 11; + I12 : LONG_INTEGER := 12; + I13 : LONG_INTEGER := 13; + I14 : LONG_INTEGER := 14; + N1 : LONG_INTEGER := -1; + N2 : LONG_INTEGER := -2; + N3 : LONG_INTEGER := -3; + N4 : LONG_INTEGER := -4; + N5 : LONG_INTEGER := -5; + N10 : LONG_INTEGER := -10; + N11 : LONG_INTEGER := -11; + N12 : LONG_INTEGER := -12; + N13 : LONG_INTEGER := -13; + N14 : LONG_INTEGER := -14; + + BEGIN + IF I10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 REM I5" ); + END IF; + + IF IDENT (I11) REM IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) REM " & + "IDENT (I5)" ); + END IF; + + IF I12 REM I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 REM I5" ); + END IF; + + IF "REM" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) REM IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) REM " & + "IDENT (I5)" ); + END IF; + + IF I14 REM I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 REM I5" ); + END IF; + + IF IDENT (I10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 REM N5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR I11 REM N5" ); + END IF; + + IF IDENT (I12) REM IDENT (N5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) REM " & + "IDENT (N5)" ); + END IF; + + IF I13 REM N5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR I13 REM N5" ); + END IF; + + IF "REM" (LEFT => I13, RIGHT => N5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) REM IDENT (N5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) REM " & + "IDENT (N5)" ); + END IF; + + IF N10 REM I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 REM I5" ); + END IF; + + IF IDENT (N11) REM IDENT (I5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) REM " & + "IDENT (I5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= N1 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 REM I5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR N12 REM I5" ); + END IF; + + IF IDENT (N13) REM IDENT (I5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) REM " & + "IDENT (I5)" ); + END IF; + + IF N14 REM I5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR N14 REM I5" ); + END IF; + + IF "REM" (LEFT => N14, RIGHT => I5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => N14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) REM IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) REM " & + "IDENT (N5)" ); + END IF; + + IF N11 REM N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 REM N5" ); + END IF; + + IF IDENT (N12) REM IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) REM " & + "IDENT (N5)" ); + END IF; + + IF "REM" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""REM"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 REM N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 REM N5" ); + END IF; + + IF IDENT (N14) REM IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) REM " & + "IDENT (N5)" ); + END IF; + + IF I10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR I10 MOD I5" ); + END IF; + + IF IDENT (I11) MOD IDENT (I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I11) MOD " & + "IDENT (I5)" ); + END IF; + + IF I12 MOD I5 /= I2 THEN + FAILED ( "INCORRECT RESULT FOR I12 MOD I5" ); + END IF; + + IF "MOD" (LEFT => I12, RIGHT => I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I12, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (I13) MOD IDENT (I5) /= I3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I13) MOD " & + "IDENT (I5)" ); + END IF; + + IF I14 MOD I5 /= I4 THEN + FAILED ( "INCORRECT RESULT FOR I14 MOD I5" ); + END IF; + + IF IDENT (I10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I10) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (I10), RIGHT => IDENT (N5)) + /= I0 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (I10), RIGHT => IDENT (N5))" ); + END IF; + + IF I11 MOD N5 /= N4 THEN + FAILED ( "INCORRECT RESULT FOR I11 MOD N5" ); + END IF; + + IF IDENT (I12) MOD IDENT (N5) /= N3 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I12) MOD " & + "IDENT (N5)" ); + END IF; + + IF I13 MOD N5 /= N2 THEN + FAILED ( "INCORRECT RESULT FOR I13 MOD N5" ); + END IF; + + IF "MOD" (LEFT => I13, RIGHT => N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I13, " & + "RIGHT => N5)" ); + END IF; + + IF IDENT (I14) MOD IDENT (N5) /= N1 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (I14) MOD " & + "IDENT (N5)" ); + END IF; + + IF N10 MOD I5 /= I0 THEN + FAILED ( "INCORRECT RESULT FOR N10 MOD I5" ); + END IF; + + IF IDENT (N11) MOD IDENT (I5) /= I4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N11) MOD " & + "IDENT (I5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N11), RIGHT => IDENT (I5)) + /= I4 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N11), RIGHT => IDENT (I5))" ); + END IF; + + IF N12 MOD I5 /= I3 THEN + FAILED ( "INCORRECT RESULT FOR N12 MOD I5" ); + END IF; + + IF IDENT (N13) MOD IDENT (I5) /= I2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N13) MOD " & + "IDENT (I5)" ); + END IF; + + IF N14 MOD I5 /= I1 THEN + FAILED ( "INCORRECT RESULT FOR N14 MOD I5" ); + END IF; + + IF "MOD" (LEFT => N14, RIGHT => I5) /= I1 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => I14, " & + "RIGHT => I5)" ); + END IF; + + IF IDENT (N10) MOD IDENT (N5) /= I0 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N10) MOD " & + "IDENT (N5)" ); + END IF; + + IF N11 MOD N5 /= N1 THEN + FAILED ( "INCORRECT RESULT FOR N11 MOD N5" ); + END IF; + + IF IDENT (N12) MOD IDENT (N5) /= N2 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N12) MOD " & + "IDENT (N5)" ); + END IF; + + IF "MOD" (LEFT => IDENT (N12), RIGHT => IDENT (N5)) + /= N2 THEN + FAILED ( "INCORRECT RESULT FOR ""MOD"" (LEFT => " & + "IDENT (N12), RIGHT => IDENT (N5))" ); + END IF; + + IF N13 MOD N5 /= N3 THEN + FAILED ( "INCORRECT RESULT FOR N13 MOD N5" ); + END IF; + + IF IDENT (N14) MOD IDENT (N5) /= N4 THEN + FAILED ( "INCORRECT RESULT FOR IDENT (N14) MOD " & + "IDENT (N5)" ); + END IF; + END; + + RESULT; + END C45503C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C45504A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A + -- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE + -- OPERANDS ARE OF PREDEFINED TYPE INTEGER. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504A IS + + F : INTEGER := IDENT_INT (INTEGER'FIRST); + L : INTEGER := IDENT_INT (INTEGER'LAST); + + BEGIN + TEST ( "C45504A", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE INTEGER" ); + + BEGIN + IF EQUAL (F*L,-100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF EQUAL (F*F,100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF EQUAL (L*L,100) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; + END C45504A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C45504B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN + -- A PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF + -- THE OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE PREDEFINED TYPE "SHORT_INTEGER". + + -- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF + -- THE VARIABLE "F" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO + -- DEFEAT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504B IS + + F : SHORT_INTEGER; -- N/A => ERROR. + L : SHORT_INTEGER; + + FUNCTION IDENT_SHORT(A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_SHORT; + + FUNCTION SHORT_OK(X : SHORT_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_SHORT(X); + END SHORT_OK; + + BEGIN + TEST ( "C45504B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE SHORT_INTEGER" ); + + F := IDENT_SHORT(SHORT_INTEGER'FIRST); + L := IDENT_SHORT(SHORT_INTEGER'LAST); + + BEGIN + IF SHORT_OK (F*L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF SHORT_OK (F * F) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF SHORT_OK (L * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; + + END C45504B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- C45504C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A + -- PRODUCT LIES OUTSIDE THE RANGE OF THE BASE TYPE, IF THE + -- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE PREDEFINED TYPE "LONG_INTEGER". + + -- IF SUCH A TYPE IS NOT SUPPORTED THEN THE DECLARATION OF THE + -- VARIABLE "F" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT AND DEFEATED OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504C IS + + F : LONG_INTEGER; -- N/A => ERROR. + L : LONG_INTEGER; + + FUNCTION IDENT_LONG(A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + + FUNCTION LONG_OK (X : LONG_INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = IDENT_LONG(X); + END; + + BEGIN + TEST ( "C45504C", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN A PRODUCT LIES OUTSIDE THE " & + "RANGE OF THE BASE TYPE, IF THE OPERANDS ARE " & + "OF PREDEFINED TYPE LONG_INTEGER" ); + + F := IDENT_LONG(LONG_INTEGER'FIRST); + L := IDENT_LONG(LONG_INTEGER'LAST); + + BEGIN + IF LONG_OK (F * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * L' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * L'" ); + END; + + BEGIN + IF LONG_OK (F * F) THEN + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'F * F' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'F * F'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'F * F'" ); + END; + + BEGIN + IF LONG_OK (L * L) THEN + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'L * L' - 2" ); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'L * L'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'L * L'" ); + END; + + RESULT; + + END C45504C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- C45504D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE SECOND + -- OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE OPERANDS ARE OF + -- PREDEFINED TYPE INTEGER. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- R.WILLIAMS 9/1/86 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504D IS + + I0 : INTEGER := IDENT_INT (0); + I5 : INTEGER := IDENT_INT (5); + N5 : INTEGER := IDENT_INT (-5); + + BEGIN + TEST ( "C45504D", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE INTEGER" ); + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; + END C45504D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504e.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504e.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504e.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504e.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C45504E.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE + -- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE + -- OPERANDS ARE OF PREDEFINED TYPE SHORT_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504E IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + I0 : SHORT_INTEGER := 1; + I5 : SHORT_INTEGER := 2; + N5 : SHORT_INTEGER := 3; + + BEGIN + TEST ( "C45504E", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE " & + "SHORT_INTEGER" ); + + IF EQUAL (3, 3) THEN + I0 := 0; + I5 := 5; + N5 := -5; + END IF; + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; + END C45504E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504f.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504f.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45504f.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45504f.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C45504F.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE + -- SECOND OPERAND OF '/', 'MOD', OR 'REM' EQUALS ZERO, IF THE + -- OPERANDS ARE OF PREDEFINED TYPE LONG_INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- HISTORY: + -- RJW 09/01/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- JRL 03/11/93 INITIALIZED VARIABLES TO DEFEAT OPTIMIZATION. + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45504F IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + I0 : LONG_INTEGER := 1; + I5 : LONG_INTEGER := 2; + N5 : LONG_INTEGER := 3; + + BEGIN + TEST ( "C45504F", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED WHEN THE SECOND OPERAND OF '/', " & + "'MOD', OR 'REM' EQUALS ZERO, IF THE " & + "OPERANDS ARE OF PREDEFINED TYPE " & + "LONG_INTEGER" ); + + IF EQUAL (3, 3) THEN + I0 := 0; + I5 := 5; + N5 := -5; + END IF; + + BEGIN + IF I5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0'" ); + END; + + BEGIN + IF N5 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 / I0'" ); + END; + + BEGIN + IF I0 / I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 / I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 / I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 / I0'" ); + END; + + BEGIN + IF I5 / I0 * I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 / I0 * I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 / I0 * I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 / I0 * I0'" ); + END; + + BEGIN + IF I5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0'" ); + END; + + BEGIN + IF N5 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 MOD I0'" ); + END; + + BEGIN + IF I0 MOD I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 MOD I0'" ); + END; + + BEGIN + IF I5 MOD I0 = (I5 + I0) MOD I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 MOD I0 = " & + "(I5 + I0) MOD I0'" ); + END; + + BEGIN + IF I5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM I0'" ); + END; + + BEGIN + IF N5 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'N5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'N5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'N5 REM I0'" ); + END; + + BEGIN + IF I0 REM I0 = 0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I0 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I0 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I0 REM I0'" ); + END; + + BEGIN + IF I5 REM (-I0) = I5 REM I0 THEN + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED BY 'I5 REM (-I0) " & + "= I5 REM I0'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED BY 'I5 REM (-I0) = " & + "I5 REM I0'" ); + END; + + RESULT; + END C45504F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45505a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45505a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45505a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45505a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C45505A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MULTIPLICATION FOR INTEGER SUBTYPES YIELDS A RESULT + -- BELONGING TO THE BASE TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + + -- JBG 2/24/84 + -- JRL 03/30/93 REMOVED NUMERIC_ERROR FROM TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C45505A IS + + TYPE INT IS RANGE 1..10; + + X, Y : INT := INT(IDENT_INT(5)); + + BEGIN + + TEST ("C45505A", "CHECK SUBTYPE OF INTEGER MULTIPLICATION"); + + BEGIN + + IF X * Y / 5 /= INT(IDENT_INT(5)) THEN + FAILED ("INCORRECT RESULT"); + END IF; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + IF INT'BASE'LAST >= INT'VAL(25) THEN + FAILED ("MULTIPLICATION DOES NOT YIELD RESULT " & + "BELONGING TO THE BASE TYPE"); + ELSE + COMMENT ("BASE TYPE HAS RANGE LESS THAN 25"); + END IF; + END; + + RESULT; + + END C45505A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45523a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45523a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45523a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45523a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C45523A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR FLOATING POINT TYPES, IF MACHINE_OVERFLOWS IS TRUE AND + -- EITHER THE RESULT OF MULTIPLICATION LIES OUTSIDE THE RANGE OF THE + -- BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY ZERO, THEN + -- CONSTRAINT_ERROR IS RAISED. THIS TESTS + -- DIGITS 5. + + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- BCB 02/09/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + -- KAS 11/14/95 DELETED USAGE OF 'SAFE_LARGE + -- KAS 11/30/95 GOT IT RIGHT THIS TIME + + WITH REPORT; USE REPORT; + + PROCEDURE C45523A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION IDENT_FLT(X : FLT) RETURN FLT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION EQUAL_FLT(ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + + BEGIN + TEST ("C45523A", "FOR FLOATING POINT TYPES, IF MACHINE_" & + "OVERFLOWS IS TRUE AND EITHER THE RESULT OF " & + "MULTIPLICATION LIES OUTSIDE THE RANGE OF THE " & + "BASE TYPE, OR AN ATTEMPT IS MADE TO DIVIDE BY " & + "ZERO, THEN CONSTRAINT_ERROR IS RAISED." & + "THIS TESTS DIGITS 5"); + + + IF FLT'MACHINE_OVERFLOWS THEN + BEGIN + F := (FLT'BASE'LAST) * IDENT_FLT (2.0); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR MULTIPLICATION"); + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "MULTIPLICATION"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN " & + "CONSTRAINT_ERROR WAS RAISED FOR " & + "MULTIPLICATION"); + END; + BEGIN + F := (FLT'LAST) / IDENT_FLT (0.0); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR DIVISION BY ZERO"); + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "DIVISION BY ZERO"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED FOR DIVISION BY ZERO"); + END; + ELSE + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING FALSE"); + END IF; + + RESULT; + END C45523A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C45531A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531A IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531A", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45531B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531B IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531B", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C45531C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531C IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531C", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45531D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531D IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531D", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C45531E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531E IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531E", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45531F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531F IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531F", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C45531G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531G IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531G", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45531H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531H IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531H", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531i.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C45531I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531I IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531I", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531j.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C45531J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45531J IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531J", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531k.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C45531K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; + PROCEDURE C45531K IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531K", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531l.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- C45531L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; + PROCEDURE C45531L IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531L", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531m.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531m.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531m.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531m.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C45531M.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + + WITH REPORT; + PROCEDURE C45531M IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531M", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (0.375); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (0.125); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.75); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.125); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_2 (DEL4 * FORTH + DEL1 ); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_2 (DEL4 * FORTH + DEL1 ); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531n.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531n.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531n.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531n.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C45531N.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + + WITH REPORT; + PROCEDURE C45531N IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + DEL2 : CONSTANT := 2.0 * DEL1; + DEL4 : CONSTANT := 4.0 * DEL1; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45531N", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR RANGE <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (3 * DEL1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (15 * DEL1); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (DEL2 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A IS A MODEL NUMBER + A := FX_1 (DEL2 * (3 * FORTH + 1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_2 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (DEL4 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_2 (3 * (DEL4 * FORTH + DEL1) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531o.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531o.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531o.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531o.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C45531O.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 4 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + -- D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45531O IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531O", "MIXED FIXED POINT AND INTEGER ""*"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) INTEGER * FIXED WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : INTEGER := 0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (7.5); + BEGIN + IF EQUAL (3, 3) THEN + A := 3; + B := FX_0P5 (2.5); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED * INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (3 * FORTH); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (FULL_SCALE / 8); -- A MODEL NUMBER + B := 6; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) INTEGER * FIXED FOR NON-MODEL NUMBERS. + + C: DECLARE + A : INTEGER := 0; + B : FX_RNG1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- B NOT A MODEL NUMBER + A := 3; + B := FX_RNG1 (RNG1 * FORTH + 0.5); + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR INTEGER * FIXED FOR NON-MODEL NUMBERS"); + + END IF; + END C; + + -------------------------------------------------- + + -- CASE D) FIXED * INTEGER FOR NON-MODEL NUMBERS. + + D: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := (3 * (FORTH + 0) ); + HIGH_COUNT : CONSTANT := (3 * (FORTH + 1) ); + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT A MODEL NUMBER + A := FX_RNG1 (RNG1 * FORTH + 0.5); + B := 3; + END IF; + + RESULT_VALUE := A * B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED * INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END D; + + -------------------------------------------------- + + + RESULT; + + END C45531O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531p.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531p.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45531p.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45531p.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- C45531P.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR MIXED FIXED POINT AND INTEGER TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + -- B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER AND RESULT NOT. + -- C) FIXED / INTEGER FOR NON-MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- BCB 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45531P IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45531P", "MIXED FIXED POINT AND INTEGER ""/"" " + & "FOR DELTA <, =, > 1.0"); + + -------------------------------------------------- + + -- CASE A) FIXED / INTEGER WHEN ALL VALUES ARE MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (1.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (7.5); -- A MODEL NUMBER + B := 5; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER " + & "WHEN ALL VALUES ARE MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) FIXED / INTEGER WITH NUMERATOR MODEL NUMBER, RESULT NOT + + B: DECLARE + A : FX_1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (FORTH + 1); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (3 * FORTH + 1); -- A MODEL NUMBER + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER WITH NUMERATOR MODEL " + & "NUMBER, RESULT NOT"); + + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) FIXED / INTEGER FOR NON-MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : INTEGER := 0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * FORTH ); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * (FORTH + 1) ); + BEGIN + IF EQUAL (3, 3) THEN -- A NOT MODEL NUMBER + A := FX_RNG1 (3 * (RNG1 * FORTH + 0.5) ); + B := 3; + END IF; + + RESULT_VALUE := A / B; + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "FOR FIXED / INTEGER FOR NON-MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45531P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C45532A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532A IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532A", "FIXED POINT OPERATOR ""*"" " + & "FOR RANGE <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- C45532B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532B IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532B", "FIXED POINT OPERATOR ""/"" " + & "FOR RANGE <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C45532C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532C IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532C", "FIXED POINT OPERATOR ""*"" " + & "FOR DELTA <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C45532D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 12. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532D IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 12; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532D", "FIXED POINT OPERATOR ""/"" " + & "FOR DELTA <, =, AND > 1.0"); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C45532E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532E IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532E", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C45532F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532F IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532F", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- C45532G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532G IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532G", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C45532H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 16. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532H IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 16; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532H", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532i.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C45532I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; + PROCEDURE C45532I IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532I", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532j.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C45532J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; + PROCEDURE C45532J IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532J", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532k.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C45532K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; + PROCEDURE C45532K IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532K", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532l.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C45532L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 32. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + -- BCB 10/03/90 REMOVED APPLICABILITY CRITERIA AND N/A => ERROR + -- LINE. CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; + PROCEDURE C45532L IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 32; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532L", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532m.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532m.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532m.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532m.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- C45532M.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45532M IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. 0.5 - DEL1 * 1; + -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. 1.0 - DEL1 * 2; + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. 2.0 - DEL1 * 4; + + BEGIN TEST ("C45532M", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_2 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + HIGHEST_ACCEPTABLE_VALUE : FX_1 := FX_1 (0.125); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.25); -- A MODEL NUMBER + B := FX_2 (0.50); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 64; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_1 (DEL1 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 128 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 128 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_2 + := FX_2 (4 * DEL1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (DEL1 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (DEL1 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532n.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532n.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532n.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532n.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C45532N.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE LESS THAN 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 10/19/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45532N IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; -- MUST BE EVEN & >= 6 + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + A_THIRD : CONSTANT := FULL_SCALE / 3; + DEL1 : CONSTANT := 0.5 / FULL_SCALE; + TYPE FX_0P5 IS DELTA DEL1 * 1 RANGE -0.5 .. + 0.5 - DEL1 * 1; -- N/A => ERROR. + TYPE FX_1 IS DELTA DEL1 * 2 RANGE -1.0 .. + 1.0 - DEL1 * 2; -- N/A => ERROR. + TYPE FX_2 IS DELTA DEL1 * 4 RANGE -2.0 .. + 2.0 - DEL1 * 4; -- N/A => ERROR. + + BEGIN TEST ("C45532N", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_2 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + HIGHEST_ACCEPTABLE_VALUE : FX_2 := FX_2 (0.5); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.125); -- A MODEL NUMBER + B := FX_1 (0.25); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_2 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 (2 * DEL1 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (DEL1 * 1); -- A MODEL NUMBER + B := FX_0P5 (DEL1 * 3); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOW_COUNT : CONSTANT := 2 * A_THIRD; + -- := (2 * FULL_SCALE * (2 * FORTH + 0)) + -- / (6 * FORTH + 2); + HIGH_COUNT : CONSTANT := 2 * A_THIRD + 4; + -- := (2 * FULL_SCALE * (2 * FORTH + 2)) + -- / (6 * FORTH + 0); + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * LOW_COUNT ); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (DEL1 * HIGH_COUNT ); + BEGIN + IF EQUAL (3, 3) THEN -- A AND B NOT MODEL NUMBERS + A := FX_1 (DEL1 * (2 * FORTH + 1)); + B := FX_1 (DEL1 * (6 * FORTH + 1)); + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532o.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532o.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532o.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532o.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- C45532O.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATOR "*" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + -- B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + -- C) THE OPERATOR *, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45532O IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + FORTH : CONSTANT := FULL_SCALE / 4; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532O", "FIXED POINT OPERATOR ""*""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR *, A, B, AND A * B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_0P5 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOWEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + HIGHEST_ACCEPTABLE_VALUE + : FX_RNG1 := FX_RNG1 (RNG1 * RNG1 / 4); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + B := FX_1 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A * B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR *, A, B MODEL NUMBERS A * B NOT. + + B: DECLARE + A : FX_0P5 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 16; + HIGH_COUNT : CONSTANT := LOW_COUNT + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_0P5 (0.5 * (FORTH + 1) ); -- A MODEL NUMBER + B := FX_0P5 (0.5 * (FORTH * 2) ); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A * B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR *, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_RNG1 := 0.0; + LOW_COUNT : CONSTANT := FULL_SCALE / 32 - 1; + HIGH_COUNT : CONSTANT := FULL_SCALE / 32 + 1; + LOWEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * LOW_COUNT); + HIGHEST_ACCEPTABLE_VALUE : FX_RNG1 + := FX_RNG1 (RNG1 * HIGH_COUNT); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_1 (0.5 * (FORTH + 1) ); -- NOT MODEL NUMBER + B := FX_1 (0.5 * (FORTH - 1) ); -- NOT MODEL NUMBER + END IF; + + RESULT_VALUE := FX_RNG1 (A * B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""*"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532p.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532p.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45532p.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45532p.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- C45532P.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + --OBJECTIVE: + -- CHECK THAT THE OPERATOR "/" PRODUCES CORRECT RESULTS + -- FOR FIXED POINT TYPES USING 3 SUBTESTS. + -- THIS TEST REQUIRES MIN_WORD_LENGTH = 48. + -- THIS TEST USES VALUES OF DELTA WHICH ARE GREATER THAN OR + -- EQUAL TO 0.5. + -- + -- TEST CASES ARE: + -- A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + -- B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + -- C) THE OPERATOR /, USING NO MODEL NUMBERS. + -- + -- REPEAT FOR MINIMUM REQUIRED WORD LENGTHS OF 12, 16, 32 AND 48, + -- WITH RANGE <, =, AND > THAN 1.0 AND + -- WITH DELTA <, =, AND > THAN 1.0. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE FOR IMPLEMENTATIONS WHICH HAVE A + -- 'MAX_MANTISSA OF 47 OR GREATER. + + -- IF 'MAX_MANTISSA >= 47 IS NOT SUPPORTED THEN THE DECLARATION OF + -- 'TYPE FX_OP5' MUST BE REJECTED. + + -- HISTORY: + -- NTW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/05/86 REVISED COMMENTS. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- RDH 04/27/90 REVISED APPLICABILITY CRITERIA. + + WITH REPORT; + PROCEDURE C45532P IS + + USE REPORT; + + MIN_WORD_LENGTH : CONSTANT := 48; + FULL_SCALE : CONSTANT := 2 ** (MIN_WORD_LENGTH - 1); + A_THIRD : CONSTANT := FULL_SCALE / 3; + RNG1 : CONSTANT := FULL_SCALE * 0.5; + TYPE FX_0P5 IS DELTA 0.5 RANGE -RNG1 * 1 .. RNG1 * 1 - 0.5; + -- N/A => ERROR. + TYPE FX_1 IS DELTA 1.0 RANGE -RNG1 * 2 .. RNG1 * 2 - 1.0; + TYPE FX_RNG1 IS DELTA RNG1 + RANGE -RNG1 * FULL_SCALE .. RNG1 * (FULL_SCALE - 1); + + BEGIN TEST ("C45532P", "FIXED POINT OPERATOR ""/""" ); + + -------------------------------------------------- + + -- CASE A) THE OPERATOR /, A, B, AND A / B ALL MODEL NUMBERS. + + A: DECLARE + A : FX_RNG1 := 0.0; + B : FX_0P5 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 := FX_0P5 (RNG1 / 2); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 4); -- A MODEL NUMBER + B := FX_0P5 (RNG1 / 2); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B, AND A / B ARE ALL MODEL NUMBERS"); + END IF; + END A; + + -------------------------------------------------- + + -- CASE B) THE OPERATOR /, A, B MODEL NUMBERS A / B NOT. + + B: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_0P5 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * A_THIRD); + HIGHEST_ACCEPTABLE_VALUE : FX_0P5 + := FX_0P5 (0.5 * (A_THIRD + 1) ); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1); -- A MODEL NUMBER + B := FX_1 (3.0); -- A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_0P5 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN A, B MODEL NUMBERS A / B NOT"); + END IF; + END B; + + -------------------------------------------------- + + -- CASE C) THE OPERATOR /, USING NO MODEL NUMBERS + + C: DECLARE + A : FX_RNG1 := 0.0; + B : FX_1 := 0.0; + RESULT_VALUE : FX_1 := 0.0; + LOWEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 - 3.0); + HIGHEST_ACCEPTABLE_VALUE : FX_1 + := FX_1 ( RNG1 + 4.0); + BEGIN + IF EQUAL (3, 3) THEN + A := FX_RNG1 (RNG1 * RNG1 / 3); -- NOT A MODEL NUMBER + B := FX_1 (RNG1 / 3); -- NOT A MODEL NUMBER + END IF; + + RESULT_VALUE := FX_1 (A / B); + + IF (RESULT_VALUE < LOWEST_ACCEPTABLE_VALUE) + OR (RESULT_VALUE > HIGHEST_ACCEPTABLE_VALUE) THEN + FAILED ("RESULT OF ""/"" OUTSIDE RESULT MODEL INTERVAL " + & "WHEN USING NO MODEL NUMBERS"); + END IF; + END C; + + -------------------------------------------------- + + + RESULT; + + END C45532P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45534b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45534b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45534b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45534b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C45534B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN A + -- FIXED POINT VALUE IS DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR + -- A FIXED POINT ZERO). + + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- BCB 07/14/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X CONSISTENCY + + WITH REPORT; USE REPORT; + + PROCEDURE C45534B IS + + TYPE FIX IS DELTA 2.0**(-1) RANGE -2.0 .. 2.0; + TYPE FIX2 IS DELTA 2.0**(-1) RANGE -3.0 .. 3.0; + + A : FIX := 1.0; + B : FIX; + ZERO : FIX := 0.0; + ZERO2 : FIX2 := 0.0; + + FUNCTION IDENT_FLT (ONE, TWO : FIX) RETURN BOOLEAN IS + BEGIN + RETURN ONE = FIX (TWO * FIX (IDENT_INT(1))); + END IDENT_FLT; + + BEGIN + TEST ("C45534B", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "A FIXED POINT VALUE IS " & + "DIVIDED BY ZERO (EITHER AN INTEGER ZERO OR A " & + "FIXED POINT ZERO)"); + + BEGIN + B := A / IDENT_INT (0); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY INTEGER ZERO"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + BEGIN + B := FIX (A / ZERO); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " & + "ZERO - 1"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + BEGIN + B := FIX (A / ZERO2); + FAILED ("NO EXCEPTION RAISED FOR DIVISION BY FIXED POINT " & + "ZERO - 2"); + IF IDENT_FLT (B,B) THEN + COMMENT ("DON'T OPTIMIZE B"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + RESULT; + END C45534B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45536a.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45536a.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45536a.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45536a.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C45536A.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK FIXED POINT MULTIPLICATION AND DIVISION WHEN 'SMALL OF + -- THE OPERANDS ARE NOT BOTH POWERS OF THE SAME BASE VALUE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- REPRESENTATION CLAUSES FOR 'SMALL WHICH ARE NOT POWERS OF TWO. + + -- IF SUCH REPRESENTATION CLAUSES ARE NOT SUPPORTED, THEN THE + -- REPRESENTATION CLAUSE FOR CHECK_TYPE MUST BE REJECTED. + + -- HISTORY: + -- BCB 02/02/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C45536A IS + + TYPE CHECK_TYPE IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR CHECK_TYPE'SMALL USE 0.2; -- N/A => ERROR. + + TYPE F1 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F1'SMALL USE 0.5; + + TYPE F2 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F2'SMALL USE 0.2; + + TYPE F3 IS DELTA 2.0**(-1) RANGE 0.0 .. 8.0; + FOR F3'SMALL USE 0.1; + + A : F1; + B : F2; + C : F3; + + FUNCTION IDENT_FIX(X : F3) RETURN F3 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIX; + + BEGIN + TEST ("C45536A", "CHECK FIXED POINT MULTIPLICATION AND DIVISION " & + "WHEN 'SMALL OF THE OPERANDS ARE NOT BOTH " & + "POWERS OF THE SAME BASE VALUE"); + + A := 1.0; B := 1.0; C := F3(A * B); + + IF C /= IDENT_FIX(1.0) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 1"); + END IF; + + C := F3(A / B); + + IF C /= IDENT_FIX(1.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 1"); + END IF; + + A := 1.0; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 2"); + END IF; + + B := 0.25; C := F3(A / B); + + IF C NOT IN IDENT_FIX(2.5) .. IDENT_FIX(5.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 2"); + END IF; + + A := 0.5; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.2) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 3"); + END IF; + + C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 3"); + END IF; + + B := 0.3; C := 0.2; A := F1(B * C); + + IF A NOT IN F1(IDENT_FIX(0.0)) .. F1(IDENT_FIX(0.5)) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 4"); + END IF; + + A := 1.0; B := 1.6; C := F3(A / B); + + IF C NOT IN IDENT_FIX(0.6) .. IDENT_FIX(0.7) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 4"); + END IF; + + A := 0.75; B := 0.4; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 5"); + END IF; + + A := 0.8; C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 5"); + END IF; + + A := 0.8; B := 0.4; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.2) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 6"); + END IF; + + A := 0.75; C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(2.5) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 6"); + END IF; + + A := 0.7; B := 0.3; C := F3(A * B); + + IF C NOT IN IDENT_FIX(0.1) .. IDENT_FIX(0.4) THEN + FAILED ("IMPROPER RESULTS FOR MULTIPLICATION - 7"); + END IF; + + C := F3(A / B); + + IF C NOT IN IDENT_FIX(1.2) .. IDENT_FIX(5.0) THEN + FAILED ("IMPROPER RESULTS FOR DIVISION - 7"); + END IF; + + RESULT; + END C45536A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C45611A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXPONENTIATION OF AN INTEGER TO AN INTEGER VALUE IS + -- CORRECTLY EVALUATED. + + -- H. TILTON 9/23/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45611A IS + + I1,INT : INTEGER; + + BEGIN + + + TEST ("C45611A", "CHECK THAT EXPONENTIATION OF AN INTEGER " & + "VALUE IS CORRECTLY EVALUATED"); + + I1 := IDENT_INT(0) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT_INT(0),IDENT_INT(1)); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT_INT(6) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT_INT(156) ** IDENT_INT(1); + + IF IDENT_INT(INT) /= IDENT_INT(156) THEN + FAILED( "INCORRECT RESULT FOR '156**1'" ); + END IF; + + I1 := IDENT_INT(-3) ** IDENT_INT(0); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT_INT(-7),IDENT_INT(1)); + + IF IDENT_INT(INT) /= IDENT_INT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT_INT(-1),IDENT_INT(2)); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT_INT(-1) ** 3; + + IF IDENT_INT(INT) /= IDENT_INT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT_INT(0),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT_INT(0) ** IDENT_INT(10); + + IF IDENT_INT(INT) /= IDENT_INT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT_INT(6),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT_INT(2),IDENT_INT(2)); + + IF IDENT_INT(INT) /= IDENT_INT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT_INT(1),IDENT_INT(10)); + + IF IDENT_INT(I1) /= IDENT_INT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- C45611B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EXPONENTIATION OF A SHORT_INTEGER TO AN INTEGER VALUE + -- IS CORRECTLY EVALUATED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- HTG 09/23/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45611B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + I1,INT : SHORT_INTEGER; + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + + TEST ("C45611B", "CHECK THAT EXPONENTIATION OF A " & + "SHORT_INTEGER VALUE IS CORRECTLY " & + "EVALUATED"); + + I1 := IDENT(0) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT(6) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT(15) ** IDENT_INT(1); + + IF IDENT(INT) /= IDENT(15) THEN + FAILED( "INCORRECT RESULT FOR '15**1'" ); + END IF; + + I1 := IDENT(-3) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT(-7),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT(-1),IDENT_INT(2)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT(-1) ** IDENT_INT(3); + + IF IDENT(INT) /= IDENT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT(0) ** IDENT_INT(10); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT(6),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT(2),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT(1),IDENT_INT(10)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45611c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45611c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- C45611C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EXPONENTIATION OF A LONG_INTEGER TO AN INTEGER VALUE + -- IS CORRECTLY EVALUATED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- HISTORY: + -- HTG 09/23/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45611C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + I1,INT : LONG_INTEGER; + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + + TEST ("C45611C", "CHECK THAT EXPONENTIATION OF A " & + "LONG_INTEGER VALUE IS CORRECTLY " & + "EVALUATED"); + + I1 := IDENT(0) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '0**0'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**1'" ); + END IF; + + I1 := IDENT(6) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '6**0'" ); + END IF; + + INT := IDENT(156) ** IDENT_INT(1); + + IF IDENT(INT) /= IDENT(156) THEN + FAILED( "INCORRECT RESULT FOR '156**1'" ); + END IF; + + I1 := IDENT(-3) ** IDENT_INT(0); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-3)**0'" ); + END IF; + + INT := "**" (IDENT(-7),IDENT_INT(1)); + + IF IDENT(INT) /= IDENT(-7) THEN + FAILED( "INCORRECT RESULT FOR '(-7)**1'" ); + END IF; + + I1 := "**" (IDENT(-1),IDENT_INT(2)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**2'" ); + END IF; + + + INT := IDENT(-1) ** IDENT_INT(3); + + IF IDENT(INT) /= IDENT(-1) THEN + FAILED( "INCORRECT RESULT FOR '(-1)**3'" ); + END IF; + + INT := "**" (IDENT(0),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**2'" ); + END IF; + + INT := IDENT(0) ** IDENT_INT(10); + + IF IDENT(INT) /= IDENT(0) THEN + FAILED( "INCORRECT RESULT FOR '0**10'" ); + END IF; + + INT := "**" (IDENT(6),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(36) THEN + FAILED( "INCORRECT RESULT FOR '6**2'" ); + END IF; + + INT := "**" (IDENT(2),IDENT_INT(2)); + + IF IDENT(INT) /= IDENT(4) THEN + FAILED( "INCORRECT RESULT FOR '2**2'" ); + END IF; + + I1 := "**" (IDENT(1),IDENT_INT(10)); + + IF IDENT(I1) /= IDENT(1) THEN + FAILED( "INCORRECT RESULT FOR '1**10'" ); + END IF; + + RESULT; + + END C45611C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C45613A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED + -- BY "**" FOR INTEGERS WHEN THE RESULT EXCEEDS THE RANGE + -- OF THE BASE TYPE. + + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- H. TILTON 10/06/86 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C45613A IS + + BEGIN + TEST ("C45613A","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR INTEGERS WHEN THE " & + "RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : INTEGER; + BEGIN + INT := IDENT_INT(INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "INTEGER'LAST"); + END; + + DECLARE + INT : INTEGER; + BEGIN + INT := IDENT_INT(INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF INTEGER'FIRST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "INTEGER'FIRST"); + + END; + + RESULT; + + END C45613A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C45613B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED + -- BY "**" FOR SHORT_INTEGER WHEN THE RESULT EXCEEDS THE RANGE + -- OF THE BASE TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- HTG 10/06/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C45613B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + TEST ("C45613B","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR SHORT_INTEGER WHEN " & + "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : SHORT_INTEGER; + BEGIN + INT := IDENT(SHORT_INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF " & + "SHORT_INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "SHORT_INTEGER'LAST"); + END; + + DECLARE + INT : SHORT_INTEGER; + BEGIN + INT := IDENT(SHORT_INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF " & + "SHORT_INTEGER'FIRST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "SHORT_INTEGER'FIRST"); + + END; + + RESULT; + + END C45613B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45613c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45613c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C45613C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED + -- BY "**" FOR LONG_INTEGER WHEN THE RESULT EXCEEDS THE RANGE + -- OF THE BASE TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- HTG 10/06/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C45613C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + TEST ("C45613C","CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED BY ""**"" FOR LONG_INTEGER WHEN " & + "THE RESULT EXCEEDS THE RANGE OF THE BASE TYPE"); + + DECLARE + INT : LONG_INTEGER; + BEGIN + INT := IDENT(LONG_INTEGER'LAST ** IDENT_INT(2)); + FAILED ("NO EXCEPTION FOR SECOND POWER OF " & + "LONG_INTEGER'LAST"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "SECOND POWER OF " & + "LONG_INTEGER'LAST"); + END; + + DECLARE + INT : LONG_INTEGER; + BEGIN + INT := IDENT(LONG_INTEGER'FIRST ** IDENT_INT(3)); + FAILED ("NO EXCEPTION FOR THIRD POWER OF " & + "LONG_INTEGER'FIRST"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "THIRD POWER OF " & + "LONG_INTEGER'FIRST"); + + END; + + RESULT; + + END C45613C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C45614A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE EXPONENT VALUE IN + -- AN INTEGER EXPONENTIATION IS NEGATIVE. + -- CHECK BOTH STATIC AND NONSTATIC EXPONENT VALUES. + + -- AH 9/29/86 + -- EDS 7/15/98 AVOID OPTIMIZATION + + WITH REPORT; USE REPORT; + PROCEDURE C45614A IS + INT : INTEGER :=1; + RES : INTEGER :=0; + BEGIN + TEST ("C45614A", "CONSTRAINT_ERROR IS RAISED FOR INTEGERS " & + "HAVING A NEGATIVE EXPONENT"); + + DECLARE + E1 : CONSTANT INTEGER := -5; + BEGIN + RES := INT ** E1; + FAILED ("CONSTRAINT_ERROR NOT RAISED - E1A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E1B"); + END; + + DECLARE + E2 : INTEGER := 5; + BEGIN + RES := INT ** (-E2); + FAILED ("CONSTRAINT_ERROR NOT RAISED - E2A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E2B"); + END; + + DECLARE + E3 : INTEGER; + BEGIN + E3 := IDENT_INT(-5); + RES := INT ** E3; + FAILED ("CONSTRAINT_ERROR NOT RAISED - E3A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E3B"); + END; + + DECLARE + BEGIN + RES := INT ** IDENT_INT(-5); + FAILED ("CONSTRAINT_ERROR NOT RAISED - E4A " & + INTEGER'IMAGE(RES)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("CONSTRAINT_ERROR NOT RAISED - E4B"); + END; + + RES := IDENT_INT(2); + RES := IDENT_INT(RES); + RESULT; + END C45614A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C45614B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY PREDEFINED SHORT_INTEGER + -- "**" IF THE SECOND OPERAND HAS A NEGATIVE VALUE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- HTG 10/07/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + PROCEDURE C45614B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ("C45614B", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "PREDEFINED SHORT_INTEGER ""**"" IF THE " & + "SECOND OPERAND HAS A NEGATIVE VALUE"); + + DECLARE + A : INTEGER := -2; + B : SHORT_INTEGER := 3; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '3**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'"); + END; + + DECLARE + A : INTEGER := -3; + B : SHORT_INTEGER := -5; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '(-5)**(-3)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'"); + END; + + DECLARE + B : SHORT_INTEGER := 0; + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(-3)); + FAILED ("NO EXCEPTION FOR '0**(-3)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'"); + END; + + DECLARE + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(-10 ** IDENT_INT(-2)); + FAILED ("NO EXCEPTION FOR '(-10)**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'"); + END; + + DECLARE + INT : SHORT_INTEGER := 0; + BEGIN + INT := IDENT(6 ** IDENT_INT(-4)); + FAILED ("NO EXCEPTION FOR '6**(-4)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'"); + END; + + RESULT; + + END C45614B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45614c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45614c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C45614C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY PREDEFINED + -- LONG_INTEGER "**" IF THE SECOND OPERAND HAS A NEGATIVE + -- VALUE. + + -- APPLICABILITY CRITERIA: + -- IN ORDER FOR THIS TEST TO BE NOT-APPLICABLE THE COMPILER + -- MUST REJECT THE USE OF "LONG_INTEGER" AS AN UNDECLARED + -- IDENTIFIER. + + -- HISTORY: + -- HT 10/07/86 CREATED ORIGINAL TEST. + -- JET 08/06/87 REMOVED BUG FROM FUNCTION IDENT (X). + + WITH REPORT; USE REPORT; + PROCEDURE C45614C IS + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ("C45614C", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY " & + "PREDEFINED LONG_INTEGER ""**"" IF THE SECOND " & + "OPERAND HAS A NEGATIVE VALUE"); + + DECLARE + A : INTEGER := -2; + B : LONG_INTEGER := 3; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '3**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '3**(-2)'"); + END; + + DECLARE + A : INTEGER := -3; + B : LONG_INTEGER := -5; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(A)); + FAILED ("NO EXCEPTION FOR '(-5)**(-3)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-5)**(-3)'"); + END; + + DECLARE + B : LONG_INTEGER := 0; + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(B ** IDENT_INT(-3)); + FAILED ("NO EXCEPTION FOR '0**(-3)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '0**(-3)'"); + END; + + DECLARE + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(-10 ** IDENT_INT(-2)); + FAILED ("NO EXCEPTION FOR '(-10)**(-2)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '(-10)**(-2)'"); + END; + + DECLARE + INT : LONG_INTEGER := 0; + BEGIN + INT := IDENT(6 ** IDENT_INT(-4)); + FAILED ("NO EXCEPTION FOR '6**(-4)'"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR '6**(-4)'"); + END; + + RESULT; + + END C45614C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45622a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45622a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45622a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45622a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C45622A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR EXPONENTIATION OF FLOATING POINT TYPES, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED IF + -- MACHINE_OVERFLOWS IS TRUE AND THE RESULT IS OUTSIDE THE RANGE OF + -- THE BASE TYPE. THIS TESTS DIGITS 5. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- BCB 02/09/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45622A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + + BEGIN + TEST ("C45622A", "FOR EXPONENTIATION OF FLOATING POINT TYPES, " & + "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED IF MACHINE_OVERFLOWS IS TRUE AND " & + "THE RESULT IS OUTSIDE THE RANGE OF THE BASE " & + "TYPE. THIS TESTS DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + BEGIN + F := (FLT'BASE'LAST)**IDENT_INT (2); + FAILED ("CONSTRAINT_ERROR WAS NOT RAISED FOR " & + "EXPONENTIATION"); + + IF NOT EQUAL_FLT(F,F) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED FOR " & + "EXPONENTIATION"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED FOR EXPONENTIATION"); + END; + ELSE + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING FALSE"); + END IF; + + RESULT; + END C45622A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45624a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45624a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45624a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45624a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C45624A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR FLOATING POINT TYPES, CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF THE RESULT OF A FLOATING POINT + -- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND + -- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 5. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- BCB 02/09/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45624A IS + + TYPE FLT IS DIGITS 5; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END EQUAL_FLT; + + BEGIN + TEST ("C45624A", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 5"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'FIRST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + + IF EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; + END C45624A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45624b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45624b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45624b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45624b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C45624B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR FLOATING POINT TYPES, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED IF THE RESULT OF A FLOATING POINT + -- EXPONENTIATION IS OUTSIDE THE RANGE OF THE BASE TYPE AND + -- MACHINE_OVERFLOWS IS FALSE. THIS TESTS DIGITS 6. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- BCB 07/14/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45624B IS + + TYPE FLT IS DIGITS 6; + + F : FLT; + + FUNCTION EQUAL_FLT (ONE, TWO : FLT) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO * FLT (IDENT_INT(1)); + END EQUAL_FLT; + + BEGIN + TEST ("C45624B", "FOR FLOATING POINT TYPES, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED " & + "IF MACHINE_OVERFLOWS IS FALSE. THIS TESTS " & + "DIGITS 6"); + + IF FLT'MACHINE_OVERFLOWS THEN + NOT_APPLICABLE ("THIS TEST IS NOT APPLICABLE DUE TO " & + "MACHINE_OVERFLOWS BEING TRUE"); + ELSE + BEGIN + F := FLT'BASE'LAST**IDENT_INT (2); + COMMENT ("CONSTRAINT_ERROR WAS NOT RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + IF NOT EQUAL_FLT(F,F**IDENT_INT(1)) THEN + COMMENT ("DON'T OPTIMIZE F"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR WAS RAISED WHEN " & + "MACHINE_OVERFLOWS WAS FALSE"); + WHEN OTHERS => + FAILED ("AN EXCEPTION OTHER THAN CONSTRAINT_ERROR " & + "WAS RAISED"); + END; + END IF; + + RESULT; + END C45624B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C45631A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR TYPE INTEGER 'ABS A' EQUALS A IF A IS POSITIVE AND + -- EQUALS -A IF A IS NEGATIVE. + + -- RJW 2/10/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C45631A IS + + BEGIN + + TEST ( "C45631A", "CHECK THAT FOR TYPE INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : INTEGER := IDENT_INT (1); + N : INTEGER := IDENT_INT (-1); + Z : INTEGER := IDENT_INT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT_INT (-INTEGER'LAST)) = INTEGER'LAST THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -INTEGER'LAST" ); + END IF; + END; + + RESULT; + + END C45631A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C45631B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR TYPE SHORT_INTEGER 'ABS A' EQUALS A IF A IS + -- POSITIVE AND EQUALS -A IF A IS NEGATIVE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- SHORT_INTEGER. + + -- IF "SHORT_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_SHORT" MUST BE REJECTED. + + -- HISTORY: + -- RJW 02/26/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45631B IS + + CHECK_SHORT : SHORT_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + RETURN SHORT_INTEGER (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + + TEST ( "C45631B", "CHECK THAT FOR TYPE SHORT_INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : SHORT_INTEGER := IDENT (1); + N : SHORT_INTEGER := IDENT (-1); + Z : SHORT_INTEGER := IDENT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT (-SHORT_INTEGER'LAST)) = SHORT_INTEGER'LAST + THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -SHORT_INTEGER'LAST" ); + END IF; + END; + + RESULT; + + END C45631B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45631c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45631c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C45631C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR TYPE LONG_INTEGER 'ABS A' EQUALS A IF A IS + -- POSITIVE AND EQUALS -A IF A IS NEGATIVE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO THOSE IMPLEMENTATIONS WHICH SUPPORT + -- LONG_INTEGER. + + -- IF "LONG_INTEGER" IS NOT SUPPORTED, THEN THE DECLARATION OF + -- "CHECK_LONG" MUST BE REJECTED. + + -- HISTORY: + -- RJW 02/26/86 CREATED ORIGINAL TEST. + -- DHH 01/13/88 ADDED APPLICABILITY CRITERIA AND STANDARD HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE C45631C IS + + CHECK_LONG : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT (X : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF X >= LONG_INTEGER (INTEGER'FIRST) AND + X <= LONG_INTEGER (INTEGER'LAST) THEN + RETURN LONG_INTEGER (IDENT_INT (INTEGER (X))); + ELSIF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT; + + BEGIN + + TEST ( "C45631C", "CHECK THAT FOR TYPE LONG_INTEGER 'ABS A' " & + "EQUALS A IF A IS POSITIVE AND EQUALS -A IF " & + "A IS NEGATIVE" ); + + DECLARE + + P : LONG_INTEGER := IDENT (1); + N : LONG_INTEGER := IDENT (-1); + Z : LONG_INTEGER := IDENT (0); + BEGIN + + IF ABS P = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 1" ); + END IF; + + IF ABS N = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 1" ); + END IF; + + IF ABS Z = Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 1" ); + END IF; + + IF ABS (Z) = -Z THEN + NULL; + ELSE + FAILED ( "'ABS TEST FOR Z - 2"); + END IF; + + IF "ABS" (RIGHT => P) = P THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR P - 2" ); + END IF; + + IF "ABS" (N) = -N THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR N - 2 " ); + END IF; + + IF "ABS" (Z) = Z THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR Z - 3" ); + END IF; + + IF ABS (IDENT (-LONG_INTEGER'LAST)) = LONG_INTEGER'LAST + THEN + NULL; + ELSE + FAILED ( "'ABS' TEST FOR -LONG_INTEGER'LAST" ); + END IF; + END; + + RESULT; + + END C45631C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- C45632A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR PREDEFINED TYPE INTEGER, CONSTRAINT_ERROR + -- IS RAISED FOR ABS (INTEGER'FIRST) IF + -- -INTEGER'LAST > INTEGER'FIRST. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- RJW 02/10/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45632A IS + + I : INTEGER := IDENT_INT (INTEGER'FIRST); + + BEGIN + + TEST ( "C45632A", "CHECK THAT FOR PREDEFINED TYPE INTEGER " & + "CONSTRAINT_ERROR IS RAISED " & + "FOR ABS (INTEGER'FIRST) IF -INTEGER'LAST > " & + "INTEGER'FIRST" ); + + BEGIN + IF - INTEGER'LAST > INTEGER'FIRST THEN + BEGIN + IF EQUAL (ABS I, I) THEN + NULL; + ELSE + FAILED ( "WRONG RESULT FOR ABS" ); + END IF; + FAILED ( "EXCEPTION NOT RAISED" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-INTEGER'LAST <= INTEGER'FIRST" ); + END IF; + END; + + RESULT; + + END C45632A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C45632B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR PREDEFINED TYPE SHORT_INTEGER, + -- CONSTRAINT_ERROR IS RAISED FOR ABS (SHORT_INTEGER'FIRST) + -- IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE PREDEFINED TYPE "SHORT_INTEGER". + + -- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE + -- VARIABLE "TEST_VAR" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- RJW 02/20/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT + -- OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45632B IS + + TEST_VAR : SHORT_INTEGER; -- N/A => ERROR. + I : SHORT_INTEGER; + + FUNCTION IDENT_SHORT (A : SHORT_INTEGER) RETURN SHORT_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_SHORT; + + BEGIN + + TEST ( "C45632B", "CHECK THAT FOR PREDEFINED TYPE " & + "SHORT_INTEGER CONSTRAINT_ERROR IS RAISED FOR " & + "ABS (SHORT_INTEGER'FIRST) IF " & + "-SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST"); + + BEGIN + I := IDENT_SHORT (SHORT_INTEGER'FIRST); + + IF -SHORT_INTEGER'LAST > SHORT_INTEGER'FIRST THEN + BEGIN + IF IDENT_SHORT (ABS I) = IDENT_SHORT (I) THEN + FAILED ("NO EXCEPTION -- EQUALITY TRUE"); + ELSE + FAILED ("NO EXCEPTION -- EQUALITY FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-SHORT_INTEGER'LAST <= SHORT_INTEGER'FIRST"); + END IF; + END; + + RESULT; + + END C45632B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632c.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632c.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45632c.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45632c.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C45632C.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR PREDEFINED TYPE LONG_INTEGER, + -- CONSTRAINT_ERROR IS RAISED FOR ABS (LONG_INTEGER'FIRST) + -- IF -LONG_INTEGER'LAST > LONG_INTEGER'FIRST. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE USE OF "LONG_INTEGER" AS A PREDEFINED DATA TYPE. + + -- IF SUCH A TYPE IS NOT SUPPORTED, THEN THE DECLARATION OF THE + -- VARIABLE "TEST_VAR" MUST BE REJECTED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- RJW 02/20/86 CREATED ORIGINAL TEST. + -- JET 12/30/87 UPDATED HEADER FORMAT, ADDED CODE TO DEFEAT + -- OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C45632C IS + + TEST_VAR : LONG_INTEGER; -- N/A => ERROR. + + FUNCTION IDENT_LONG (A : LONG_INTEGER) RETURN LONG_INTEGER IS + BEGIN + IF EQUAL (3,3) THEN + RETURN A; + ELSE + RETURN 0; + END IF; + END IDENT_LONG; + + BEGIN + + TEST ( "C45632C", "CHECK THAT FOR PREDEFINED TYPE " & + "LONG_INTEGER CONSTRAINT_ERROR IS RAISED FOR " & + "ABS (LONG_INTEGER'FIRST) IF " & + "-LONG_INTEGER'LAST > LONG_INTEGER'FIRST" ); + + BEGIN + IF - LONG_INTEGER'LAST > LONG_INTEGER'FIRST THEN + DECLARE + I : LONG_INTEGER := IDENT_LONG(LONG_INTEGER'FIRST); + BEGIN + IF IDENT_LONG(ABS I) = IDENT_LONG(I) THEN + FAILED ("NO EXCEPTION -- EQUALITY TRUE"); + ELSE + FAILED ("NO EXCEPTION -- EQUALITY FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED" ); + END; + ELSE + COMMENT ( "-LONG_INTEGER'LAST <= " & + "LONG_INTEGER'FIRST" ); + END IF; + END; + + RESULT; + + END C45632C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45651a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45651a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45651a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45651a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,246 ---- + -- C45651A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR FIXED POINT TYPES, CHECK: + -- (A) FOR MODEL NUMBERS A >= 0.0, THAT ABS A = A. + -- (B) FOR MODEL NUMBERS A <= 0.0. THAT ABS A = -A. + -- (C) FOR NON-MODEL NUMBERS A > 0.0, THAT ABS A VALUES ARE + -- WITHIN THE APPROPRIATE MODEL INTERVAL. + -- (D) FOR NON-MODEL NUMBERS A < 0.0, THAT ABS A VALUES ARE + -- WITHIN THE APPROPRIATE MODEL INTERVAL. + + -- CASE A: BASIC TYPES THAT FIT THE CHARACTERISTICS OF + -- DURATION'BASE. + + -- HISTORY: + -- WRG 9/11/86 + -- PWB 3/31/88 CHANGED RANGE FOR MEMBERSHIP TEST INVOLVING + -- ABS (DECIMAL_M4'FIRST + DECIMAL_M4'SMALL / 2). + -- RJW 8/21/89 REMOVED CHECKS INVOLVING HARD-CODED FIXED-POINT + -- UPPER BOUNDS WHICH WERE INCORRECT FOR SOME + -- IMPLEMENTATIONS. REVISED HEADER. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + -- KAS 11/14/95 REMOVED CASES THAT DEPEND ON SPECIFIC VALUE FOR 'SMALL + -- TMB 11/19/94 REMOVED CASES RELATING TO 3.5.9(8) RULES - SMALL + -- MAY BE LESS THAN OR EQUAL TO DELTA FOR FIXED POINT. + + WITH REPORT; USE REPORT; + PROCEDURE C45651A IS + + -- THE NAME OF EACH TYPE OR SUBTYPE ENDS WITH THAT TYPE'S + -- 'MANTISSA VALUE. + + BEGIN + + TEST ("C45651A", "CHECK THAT, FOR FIXED POINT TYPES, THE ABS " & + "OPERATOR PRODUCES CORRECT RESULTS - BASIC " & + "TYPES"); + + ------------------------------------------------------------------- + + A: DECLARE + TYPE LIKE_DURATION_M23 IS DELTA 0.020 + RANGE -86_400.0 .. 86_400.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : LIKE_DURATION_M23 := 0.0; + + SMALL, MAX, MIN, ZERO : LIKE_DURATION_M23 := 0.5; + X : LIKE_DURATION_M23 := 1.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := LIKE_DURATION_M23'SMALL; + MAX := LIKE_DURATION_M23'LAST; + MIN := LIKE_DURATION_M23'FIRST; + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- (A) + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF ABS X /= SMALL OR X /= ABS LIKE_DURATION_M23'SMALL THEN + FAILED ("ABS (1.0 / 64) /= (1.0 / 64)"); + END IF; + IF EQUAL (3, 3) THEN + X := MAX; + END IF; + IF ABS X /= MAX OR X /= ABS LIKE_DURATION_M23'LAST THEN + FAILED ("ABS 86_400.0 /= 86_400.0"); + END IF; + + -- (B) + IF EQUAL (3, 3) THEN + X := -SMALL; + END IF; + IF ABS X /= SMALL OR + ABS (-LIKE_DURATION_M23'SMALL) /= SMALL THEN + FAILED ("ABS -(1.0 / 64) /= (1.0 / 64)"); + END IF; + IF EQUAL (3, 3) THEN + X := MIN; + END IF; + IF ABS X /= MAX OR ABS LIKE_DURATION_M23'FIRST /= MAX THEN + FAILED ("ABS -86_400.0 /= 86_400.0"); + END IF; + + -- (A) AND (B) + IF EQUAL (3, 3) THEN + X := 0.0; + END IF; + IF "ABS" (RIGHT => X) /= ZERO OR X /= ABS 0.0 THEN + FAILED ("ABS 0.0 /= 0.0 -- (LIKE_DURATION_M23)"); + END IF; + + -- CHECK THAT VALUE OF NON_MODEL_VAR IS IN THE RANGE + -- 42 * 'SMALL .. 43 * 'SMALL: + IF NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " & + "- A"); + END IF; + + -- (C) + IF ABS NON_MODEL_VAR NOT IN 0.65625 .. 0.671875 OR + ABS LIKE_DURATION_M23'(NON_MODEL_CONST) NOT IN + 0.65625 .. 0.671875 THEN + FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - A"); + END IF; + IF EQUAL (3, 3) THEN + X := 86_399.992_187_5; -- LIKE_DURATION_M23'LAST - + -- 1.0 / 128. + END IF; + IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR + ABS (LIKE_DURATION_M23'LAST - LIKE_DURATION_M23'SMALL / 2) + NOT IN 86_399.984_375 .. 86_400.0 THEN + FAILED ("ABS (LIKE_DURATION_M23'LAST - " & + "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " & + "RANGE"); + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + X := -NON_MODEL_CONST; + END IF; + IF ABS X NOT IN 0.65625 .. 0.671875 OR + ABS (-LIKE_DURATION_M23'(NON_MODEL_CONST)) NOT IN + 0.65625 .. 0.671875 THEN + FAILED ("ABS (-2.0 / 3) NOT IN CORRECT RANGE - A"); + END IF; + IF EQUAL (3, 3) THEN + X := -86_399.992_187_5; -- LIKE_DURATION_M23'FIRST + + -- 1.0 / 128. + END IF; + IF ABS X NOT IN 86_399.984_375 .. 86_400.0 OR + ABS (LIKE_DURATION_M23'FIRST + LIKE_DURATION_M23'SMALL / 2) + NOT IN 86_399.984_375 .. 86_400.0 THEN + FAILED ("ABS (LIKE_DURATION_M23'FIRST +" & + "LIKE_DURATION_M23'SMALL / 2) NOT IN CORRECT " & + "RANGE"); + END IF; + END A; + + ------------------------------------------------------------------- + + B: DECLARE + TYPE DECIMAL_M4 IS DELTA 100.0 RANGE -1000.0 .. 1000.0; + + NON_MODEL_CONST : CONSTANT := 2.0 / 3; + NON_MODEL_VAR : DECIMAL_M4 := 0.0; + + SMALL, MAX, MIN, ZERO : DECIMAL_M4 := 128.0; + X : DECIMAL_M4 := 0.0; + BEGIN + -- INITIALIZE "CONSTANTS": + IF EQUAL (3, 3) THEN + SMALL := DECIMAL_M4'SMALL; + ZERO := 0.0; + NON_MODEL_VAR := NON_MODEL_CONST; + END IF; + + -- (A) + IF EQUAL (3, 3) THEN + X := SMALL; + END IF; + IF ABS X /= SMALL OR X /= ABS DECIMAL_M4'SMALL THEN + FAILED ("ABS 64.0 /= 64.0"); + END IF; + + -- (B) + IF EQUAL (3, 3) THEN + X := -SMALL; + END IF; + IF ABS X /= SMALL OR ABS (-DECIMAL_M4'SMALL) /= SMALL THEN + FAILED ("ABS -64.0 /= 64.0"); + END IF; + + -- (A) AND (B) + IF EQUAL (3, 3) THEN + X := 0.0; + END IF; + IF ABS X /= ZERO OR X /= ABS 0.0 THEN + FAILED ("ABS 0.0 /= 0.0 -- (DECIMAL_M4)"); + END IF; + + -- CHECK THE VALUE OF NON_MODEL_VAR: + IF NON_MODEL_VAR NOT IN 0.0 .. 64.0 THEN + FAILED ("VALUE OF NON_MODEL_VAR NOT IN CORRECT RANGE " & + "- B"); + END IF; + + -- (C) + IF ABS NON_MODEL_VAR NOT IN 0.0 .. 64.0 OR + ABS DECIMAL_M4'(NON_MODEL_CONST) NOT IN 0.0 .. 64.0 THEN + FAILED ("ABS (2.0 / 3) NOT IN CORRECT RANGE - B"); + END IF; + IF EQUAL (3, 3) THEN + X := 37.0; -- INTERVAL IS 0.0 .. 64.0. + END IF; + IF EQUAL (3, 3) THEN + X := 928.0; + END IF; + + -- (D) + IF EQUAL (3, 3) THEN + X := -NON_MODEL_CONST; + END IF; + IF ABS X NOT IN 0.0 .. 64.0 OR + ABS (-DECIMAL_M4'(NON_MODEL_CONST)) NOT IN 0.0 .. 64.0 THEN + FAILED ("ABS -(2.0 / 3) NOT IN CORRECT RANGE - B"); + END IF; + IF EQUAL (3, 3) THEN + X := -37.0; -- INTERVAL IS -SMALL .. 0.0. + END IF; + IF EQUAL (3, 3) THEN + X := -928.0; + END IF; + END B; + + ------------------------------------------------------------------- + + RESULT; + + END C45651A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45662a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45662a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45662a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45662a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C45662A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE TRUTH TABLE FOR 'NOT' . + + -- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED + -- IN C45101(A,G). + + + -- RM 28 OCTOBER 1980 + -- TBN 10/21/85 RENAMED FROM C45401A.ADA. + + + WITH REPORT ; + PROCEDURE C45662A IS + + USE REPORT; + + TVAR , FVAR , CVAR : BOOLEAN := FALSE ; -- INITIAL VALUE IRRELEVANT + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + BEGIN + + TEST( "C45662A" , "CHECK THE TRUTH TABLE FOR 'NOT'" ) ; + + FOR A IN BOOLEAN LOOP + + CVAR := NOT A ; + + IF NOT A THEN + IF A THEN BUMP ; + END IF ; + END IF; + + IF CVAR THEN + IF A THEN BUMP ; + END IF ; + END IF; + + IF NOT( NOT( NOT( NOT( CVAR )))) + THEN + IF A THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + FOR I IN 1..2 LOOP + + CVAR := NOT ( I > 1 ) ; + + IF NOT ( I > 1 ) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + IF CVAR THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + IF NOT TRUE THEN BUMP ; END IF ; + IF NOT FALSE THEN NULL ; ELSE BUMP ; END IF ; + + TVAR := IDENT_BOOL( TRUE ); + FVAR := IDENT_BOOL( FALSE ); + + IF NOT TVAR THEN BUMP ; END IF ; + IF NOT FVAR THEN NULL ; ELSE BUMP ; END IF ; + + + IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" ); + END IF ; + + RESULT; + + END C45662A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45662b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45662b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45662b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45662b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C45662B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE TRUTH TABLE FOR 'NOT' ON DERIVED-BOOLEAN-TYPE OPERANDS. + + -- THE COMBINATIONS OF 'NOT' WITH 'AND' , 'OR' , 'XOR' ARE TESTED + -- IN C45101K. + + + -- RM 28 OCTOBER 1980 + -- TBN 10/21/85 RENAMED FROM C45401B-AB.ADA. REMOVED DUPLICATED + -- CODE NEAR END. + + WITH REPORT; USE REPORT; + PROCEDURE C45662B IS + + TYPE NB IS NEW BOOLEAN ; + + TVAR , FVAR , CVAR : NB := NB'(FALSE) ; -- INITIAL VALUE IRRELEVANT + ERROR_COUNT : INTEGER := 0 ; -- INITIAL VALUE ESSENTIAL + + PROCEDURE BUMP IS + BEGIN + ERROR_COUNT := ERROR_COUNT + 1 ; + END BUMP ; + + FUNCTION IDENT_NEW_BOOL( THE_ARGUMENT : NB ) RETURN NB IS + BEGIN + IF EQUAL(2,2) THEN RETURN THE_ARGUMENT; + ELSE RETURN NB'(FALSE) ; + END IF; + END ; + + + BEGIN + + TEST( "C45662B" , "CHECK THE TRUTH TABLE FOR 'NOT'" & + " ON DERIVED-BOOLEAN-TYPE OPERANDS" ) ; + + FOR A IN NB LOOP + + CVAR := NOT A ; + + IF BOOLEAN( NOT A ) THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( CVAR ) THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( + + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( + NOT( NOT( NOT( NOT( NOT( CVAR ))))) ))))) ))))) ))))) + ) + THEN + IF BOOLEAN( A ) THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + FOR I IN 1..2 LOOP + + CVAR := NOT( NB( I > 1 ) ) ; + + IF BOOLEAN( NOT( NB( I > 1 ))) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + IF BOOLEAN( CVAR ) THEN + IF I>1 THEN BUMP ; + END IF ; + END IF; + + END LOOP ; + + IF BOOLEAN( NOT( NB'(TRUE ))) THEN BUMP ; END IF ; + IF BOOLEAN( NOT( NB'(FALSE))) THEN NULL ; ELSE BUMP ; END IF ; + + + TVAR := IDENT_NEW_BOOL( NB'(TRUE ) ); + FVAR := IDENT_NEW_BOOL( NB'(FALSE) ); + + IF BOOLEAN( NOT TVAR ) THEN BUMP ; END IF ; + IF BOOLEAN( NOT FVAR ) THEN NULL ; ELSE BUMP ; END IF ; + + IF ERROR_COUNT /= 0 THEN FAILED( "'NOT' TRUTH TABLE" ); + END IF ; + + RESULT; + + END C45662B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45672a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45672a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c45672a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c45672a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C45672A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT "NOT" YIELDS THE CORRECT RESULTS WHEN APPLIED TO + -- ONE-DIMENSIONAL BOOLEAN ARRAYS. + + -- JWC 11/15/85 + + WITH REPORT;USE REPORT; + + PROCEDURE C45672A IS + BEGIN + + TEST ("C45672A", "CHECK THE UNARY OPERATOR 'NOT' APPLIED TO " & + "ONE-DIMENSIONAL BOOLEAN ARRAYS"); + + DECLARE + + TYPE ARR1 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN; + TYPE ARR2 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN; + TYPE ARR3 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE ARR4 IS ARRAY (INTEGER RANGE 1 .. 4) OF BOOLEAN; + TYPE ARR5 IS ARRAY (INTEGER RANGE 1 .. 40) OF BOOLEAN; + + PRAGMA PACK (ARR4); + PRAGMA PACK (ARR5); + + A1 : ARR1 := ARR1'(1 | 3 => TRUE, OTHERS => FALSE); + A2 : ARR2 := ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE, + OTHERS => FALSE); + A3 : ARR3(IDENT_INT(3) .. IDENT_INT(4)) := ARR3'(TRUE, FALSE); + A4 : ARR4 := ARR4'(1 | 3 => TRUE, OTHERS => FALSE); + A5 : ARR5 := ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 => TRUE, + OTHERS => FALSE); + A6 : ARR3 (IDENT_INT(9) .. IDENT_INT(7)); + + PROCEDURE P (A : ARR3; F : INTEGER; L : INTEGER) IS + BEGIN + IF A'FIRST /= F OR A'LAST /= L THEN + FAILED ("'NOT' YIELDED THE WRONG BOUNDS"); + END IF; + END P; + + BEGIN + + P (NOT A3, 3, 4); + P (NOT A6, 9, 7); + + IF NOT A1 /= ARR1'(1 | 3 => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL ARRAY"); + END IF; + + IF NOT A2 /= ARR2'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 + => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO LARGE ARRAY"); + END IF; + + IF NOT A4 /= ARR4'(1 | 3 => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL PACKED ARRAY"); + END IF; + + IF NOT A5 /= ARR5'(1 | 14 .. 18 | 30 .. 33 | 35 .. 37 + => FALSE, OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO LARGE PACKED ARRAY"); + END IF; + + IF "NOT" (RIGHT => A1) /= ARR1'(1 | 3 => FALSE, + OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED " & + "TO SMALL ARRAY USING NAMED NOTATION"); + END IF; + + IF "NOT" (RIGHT => A5) /= ARR5'(1 | 14 .. 18 | 30 .. 33 | + 35 .. 37 => FALSE, + OTHERS => TRUE) THEN + FAILED ("WRONG RESULT WHEN 'NOT' APPLIED TO LARGE " & + "PACKED ARRAY USING NAMED NOTATION"); + END IF; + + END; + + RESULT; + + END C45672A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,300 ---- + -- C460001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the target type of a type conversion is a general + -- access type, Program_Error is raised if the accessibility level + -- of the operand type is deeper than that of the target type. + -- Check for the case where the operand is an access parameter. + -- + -- Check for cases where the actual corresponding to the access + -- parameter is: + -- (a) An allocator. + -- (b) An expression of a named access type. + -- (c) Obj'Access. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the operand type + -- must be at the same or a less deep nesting level than the target + -- type -- the operand type must "live" as long as the target type. + -- Nesting levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares subprograms with access parameters, within which + -- a type conversion is attempted on the access parameter to an access + -- type A declared at some nesting level. The test verifies that + -- Program_Error is raised if the actual corresponding to the access + -- parameter is: + -- + -- (1) an allocator, and the accessibility level of the execution + -- of the called subprogram is deeper than that of the access + -- type A. + -- + -- (2) an expression of a named access type, and the accessibility + -- level of the named access type is deeper than that of the + -- access type A. + -- + -- (3) a reference to the Access attribute (e.g., X'Access), and + -- the accessibility level of X is deeper than that of the + -- access type A. + -- + -- Note that the static nesting level of the actual corresponding to the + -- access parameter can be deeper than that of the target type -- it is + -- the run-time nesting that matters for accessibility rules. Consider + -- the case where the access type A is declared within the called + -- subprogram. The accessibility check will never fail, even if the + -- actual happens to have a deeper static nesting level: + -- + -- procedure P (X: access T) is + -- type A is access all T; -- Static level = 2, e.g. + -- Acc : A := A(X); -- Check should never fail. + -- begin null; end; + -- . . . + -- declare + -- Actual : aliased T; -- Static level = 3, e.g. + -- begin + -- P (Actual'Access); + -- end; + -- + -- For the execution of P, the accessibility level of type A will + -- always be deeper than that of Actual, so there is no danger of a + -- dangling reference arising from the assignment to Acc. Thus, the + -- type conversion is safe, even though the static nesting level of + -- Actual is deeper than that of A. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C460001_0 is + + type Desig is array (1 .. 10) of Integer; + + X0 : aliased Desig; -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0 (X: access Desig; R : out Result_Kind); + procedure Never_Fails (X: access Desig; R : out Result_Kind); + + end C460001_0; + + + --==================================================================-- + + + package body C460001_0 is + + procedure Target_Is_Level_0 (X : access Desig; + R : out Result_Kind) is + begin + -- The accessibility level of type Acc_L0 is 0. + A0 := Acc_L0(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Target_Is_Level_0; + + ----------------------------------------------- + procedure Never_Fails (X: access Desig; + R : out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Local will always be deeper than or the same as that + -- of the actual corresponding to X. + AL := Acc_Local(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Never_Fails; + + end C460001_0; + + + --==================================================================-- + + + with C460001_0; + with Report; + + procedure C460001 is + + X1 : aliased C460001_0.Desig; -- Level = 1. + + type Acc_L1 is access all C460001_0.Desig; -- Level = 1. + A1 : Acc_L1; + + Expr_L0 : C460001_0.Acc_L0 := C460001_0.X0'Access; + Expr_L1 : Acc_L1 := X1'Access; + + Res : C460001_0.Result_Kind; + + use type C460001_0.Result_Kind; + + ----------------------------------------------- + procedure Target_Is_Level_1 (X : access C460001_0.Desig; + R : out C460001_0.Result_Kind) is + begin + -- The accessibility level of type Acc_L1 is 1. + A1 := Acc_L1(X); + R := C460001_0.OK; + exception + when Program_Error => + R := C460001_0.P_E; + when others => + R := C460001_0.O_E; + end Target_Is_Level_1; + + ----------------------------------------------- + procedure Display_Results (Result : in C460001_0.Result_Kind; + Expected: in C460001_0.Result_Kind; + Message : in String) is + begin + if Result /= Expected then + case Result is + when C460001_0.OK => Report.Failed ("No exception raised: " & + Message); + when C460001_0.P_E => Report.Failed ("Program_Error raised: " & + Message); + when C460001_0.O_E => Report.Failed ("Unexpected exception " & + "raised: " & Message); + end case; + end if; + end Display_Results; + + begin -- C460001 + + Report.Test ("C460001", "Check that if the target type of a type " & + "conversion is a general access type, Program_Error is " & + "raised if the accessibility level of the operand type " & + "is deeper than that of the target type: operand is an " & + "access parameter; corresponding actual is an allocator, " & + "expression of a named access type, Obj'Access"); + + + -- Actual is X'Access: + + C460001_0.Never_Fails (X1'Access, Res); + Display_Results (Res, C460001_0.OK, "X1'Access, local access type"); + + C460001_0.Target_Is_Level_0 (X1'Access, Res); + Display_Results (Res, C460001_0.P_E, "X1'Access, level 0 access type"); + + Target_Is_Level_1 (C460001_0.X0'Access, Res); + Display_Results (Res, C460001_0.OK, "X0'Access, level 1 access type"); + + Target_Is_Level_1 (X1'Access, Res); + Display_Results (Res, C460001_0.OK, "X1'Access, level 1 access type"); + + C460001_0.Target_Is_Level_0 (C460001_0.X0'Access, Res); + Display_Results (Res, C460001_0.OK, "X0'Access, level 0 access type"); + + + -- Actual is expression of a named access type: + + C460001_0.Never_Fails (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, local access type"); + + C460001_0.Target_Is_Level_0 (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, level 0 access type"); + + C460001_0.Target_Is_Level_0 (Expr_L1, Res); + Display_Results (Res, C460001_0.P_E, "Expr_L1, level 0 access type"); + + Target_Is_Level_1 (Expr_L1, Res); + Display_Results (Res, C460001_0.OK, "Expr_L1, level 1 access type"); + + Target_Is_Level_1 (Expr_L0, Res); + Display_Results (Res, C460001_0.OK, "Expr_L0, level 1 access type"); + + -- Actual is allocator (level of execution = 2): + + C460001_0.Never_Fails (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.OK, "Allocator level 2, " & + "local access type"); + + C460001_0.Target_Is_Level_0 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & + "level 0 access type"); + + Target_Is_Level_1 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 2, " & + "level 1 access type"); + + + Block_L2: + declare + X2 : aliased C460001_0.Desig; -- Level = 2. + type Acc_L2 is access all C460001_0.Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X1'Access; + begin + + -- Actual is X'Access: + + C460001_0.Never_Fails (X2'Access, Res); + Display_Results (Res, C460001_0.OK, "X2'Access, local access type"); + + Target_Is_Level_1 (X2'Access, Res); + Display_Results (Res, C460001_0.P_E, "X2'Access, level 1 access type"); + + -- Actual is expression of a named access type: + + C460001_0.Never_Fails (Expr_L2, Res); + Display_Results (Res, C460001_0.OK, "Expr_L2, local access type"); + + C460001_0.Target_Is_Level_0 (Expr_L2, Res); + Display_Results (Res, C460001_0.P_E, "Expr_L2, level 0 access type"); + + + -- Actual is allocator (level of execution = 3): + + C460001_0.Never_Fails (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.OK, "Allocator level 3, " & + "local access type"); + + Target_Is_Level_1 (new C460001_0.Desig, Res); + Display_Results (Res, C460001_0.P_E, "Allocator level 3, " & + "level 1 access type"); + + end Block_L2; + + Report.Result; + + end C460001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460002.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,330 ---- + -- C460002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the target type of a type conversion is a general + -- access type, Program_Error is raised if the accessibility level + -- of the operand type is deeper than that of the target type. + -- Check for the case where the operand is an access parameter, + -- and the actual corresponding to the access parameter is another + -- access parameter. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the operand type + -- must be at the same or a less deep nesting level than the target + -- type -- the operand type must "live" as long as the target type. + -- Nesting levels are the run-time nestings of masters: block statements; + -- subprogram, task, and entry bodies; and accept statements. Packages + -- are invisible to accessibility rules. + -- + -- This test declares subprograms with access parameters, within which + -- a type conversion is attempted on the access parameter to an access + -- type A declared at some nesting level. The test verifies that + -- Program_Error is raised if the actual corresponding to the access + -- parameter is another access parameter, and the actual corresponding + -- to this second access parameter is: + -- + -- (1) an expression of a named access type, and the accessibility + -- level of the named access type is deeper than that of the + -- access type A. + -- + -- (2) a reference to the Access attribute (e.g., X'Access), and + -- the accessibility level of X is deeper than that of the + -- access type A. + -- + -- Note that the static nesting level of the actual corresponding to the + -- access parameter can be deeper than that of the target type -- it is + -- the run-time nesting that matters for accessibility rules. Consider + -- the case where the access type A is declared within the called + -- subprogram. The accessibility check will never fail, even if the + -- actual happens to have a deeper static nesting level: + -- + -- procedure P (X: access T) is + -- type A is access all T; -- Static level = 2, e.g. + -- Acc : A := A(X); -- Check should never fail. + -- begin null; end; + -- . . . + -- procedure Q (Y: access T) is + -- begin + -- P(Y); + -- end; + -- . . . + -- declare + -- Actual : aliased T; -- Static level = 3, e.g. + -- begin + -- Q (Actual'Access); + -- end; + -- + -- For the execution of Q (and hence P), the accessibility level of + -- type A will always be deeper than that of Actual, so there is no + -- danger of a dangling reference arising from the assignment to + -- Acc. Thus, the type conversion is safe, even though the static + -- nesting level of Actual is deeper than that of A. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Changed maintenance documentation. + -- 15 Jul 98 EDS Avoid Optimization + -- 28 Jun 02 RLB Added pragma Elaborate_All. + --! + + with Report; use Report; pragma Elaborate_All (Report); + package C460002_0 is + + type Component is array (1 .. 10) of Natural; + + type Desig is record + C: Component; + end record; + + X0 : aliased Desig := (C=>(others => Ident_Int(3))); -- Level = 0. + + type Acc_L0 is access all Desig; -- Level = 0. + A0 : Acc_L0; + + type Result_Kind is (OK, P_E, O_E); + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind); + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind); + + end C460002_0; + + + --==================================================================-- + + + package body C460002_0 is + + procedure Target_Is_Level_0_Nest (Y: access Desig; S: out Result_Kind) is + + procedure Nested (X: access Desig; R: out Result_Kind) is + -- This procedure attempts a type conversion on the access parameter to + -- an access type declared at some nesting level. Program_Error is + -- raised if the accessibility level of the operand type is deeper than + -- that of the target type. + + begin + -- The accessibility level of type Acc_L0 is 0. + A0 := Acc_L0(X); + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Nested; + + begin + Nested (Y, S); + end Target_Is_Level_0_Nest; + + ------------------------------------------------------------- + + procedure Never_Fails_Nest (Y: access Desig; S: out Result_Kind) is + + type Acc_Deeper is access all Desig; + AD : Acc_Deeper; + + function Nested (X: access Desig) return Result_Kind is + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Deeper will always be deeper than or the same as that + -- of the actual corresponding to Y. + AD := Acc_Deeper(X); + if Natural(Ident_Int(AD.C(1))) /= 3 then --Avoid Optimization of AD + Report.Failed ("Initial Values not correct."); + end if; + return OK; + exception + when Program_Error => + return P_E; + when others => + return O_E; + end Nested; + + begin + S := Nested (Y); + end Never_Fails_Nest; + + ------------------------------------------------------------- + + procedure Called_By_Never_Fails_Same + (X: access Desig; R: out Result_Kind) is + type Acc_Local is access all Desig; + AL : Acc_Local; + begin + -- The type conversion below will always be safe, since the + -- accessibility level (although not necessarily the static nesting + -- depth) of Acc_Local will always be deeper than or the same as that + -- of the actual corresponding to X. + AL := Acc_Local(X); + if Natural(Ident_Int(AL.C(1))) /= 3 then --Avoid Optimization of AL + Report.Failed ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Never_Fails_Same; + + ------------------------------------------------------------- + + procedure Never_Fails_Same (Y: access Desig; S: out Result_Kind) is + begin + Called_By_Never_Fails_Same (Y, S); + end Never_Fails_Same; + + end C460002_0; + + + --==================================================================-- + + + with C460002_0; + use C460002_0; + + with Report; use Report; + + procedure C460002 is + + type Acc_L1 is access all Desig; -- Level = 1. + A1 : Acc_L1; + X1 : aliased Desig := (C=>(others => Ident_Int(3))); + Res : Result_Kind; + + + + procedure Called_By_Target_L1 (X: access Desig; R: out Result_Kind) is + begin + -- The accessibility level of type Acc_L1 is 1. + A1 := Acc_L1(X); + if Natural(Ident_Int(A1.C(1))) /= 3 then --Avoid Optimization of A1 + Report.Failed ("Initial Values not correct."); + end if; + R := OK; + exception + when Program_Error => + R := P_E; + when others => + R := O_E; + end Called_By_Target_L1; + + ------------------------------------------------------------- + + function Target_Is_Level_1_Same (Y: access Desig) return Result_Kind is + S : Result_Kind; + begin + Called_By_Target_L1 (Y, S); + return S; + end Target_Is_Level_1_Same; + + ------------------------------------------------------------- + + procedure Display_Results (Result : in Result_Kind; + Expected: in Result_Kind; + Msg : in String) is + begin + if Result /= Expected then + case Result is + when OK => Report.Failed ("No exception raised: " & Msg); + when P_E => Report.Failed ("Program_Error raised: " & Msg); + when O_E => Report.Failed ("Unexpected exception raised: " & Msg); + end case; + end if; + end Display_Results; + + begin -- C460002. + + Report.Test ("C460002", "Check that if the target type of a type " & + "conversion is a general access type, Program_Error is " & + "raised if the accessibility level of the operand type " & + "is deeper than that of the target type: operand is an " & + "access parameter; corresponding actual is another " & + "access parameter"); + + + -- Accessibility level of actual is 0 (actual is X'Access): + + Never_Fails_Same (X0'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 0 actual"); + + Never_Fails_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 0 actual"); + + Target_Is_Level_0_Nest (X0'Access, Res); + Display_Results (Res, OK, "Target_L0_Nest, level 0 actual"); + + Res := Target_Is_Level_1_Same (X0'Access); + Display_Results (Res, OK, "Target_L1_Same, level 0 actual"); + + + -- Accessibility level of actual is 1 (actual is X'Access): + + Never_Fails_Same (X1'Access, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 1 actual"); + + Never_Fails_Nest (X1'Access, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 1 actual"); + + Target_Is_Level_0_Nest (X1'Access, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 1 actual"); + + Res := Target_Is_Level_1_Same (X1'Access); + Display_Results (Res, OK, "Target_L1_Same, level 1 actual"); + + + Block_L2: + declare + X2 : aliased Desig := (C=>(others => Ident_Int(3))); + type Acc_L2 is access all Desig; -- Level = 2. + Expr_L2 : Acc_L2 := X2'Access; + begin + + -- Accessibility level of actual is 2 (actual is expression of named + -- access type): + + Never_Fails_Same (Expr_L2, Res); + Display_Results (Res, OK, "Never_Fails_Same, level 2 actual"); + + Never_Fails_Nest (Expr_L2, Res); + Display_Results (Res, OK, "Target_L1_Nest, level 2 actual"); + + Target_Is_Level_0_Nest (Expr_L2, Res); + Display_Results (Res, P_E, "Target_L0_Nest, level 2 actual"); + + Res := Target_Is_Level_1_Same (Expr_L2); + Display_Results (Res, P_E, "Target_L1_Same, level 2 actual"); + + end Block_L2; + + + Report.Result; + + end C460002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460004.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,335 ---- + -- C460004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the operand type of a type conversion is class-wide, + -- Constraint_Error is raised if the tag of the operand does not + -- identify a specific type that is covered by or descended from the + -- target type. + -- + -- TEST DESCRIPTION: + -- View conversions of class-wide operands to specific types are + -- placed on the right and left sides of assignment statements, and + -- conversions of class-wide operands to class-wide types are used + -- as actual parameters to dispatching operations. In all cases, a + -- check is made that Constraint_Error is raised if the tag of the + -- operand does not identify a specific type covered by or descended + -- from the target type, and not raised otherwise. + -- + -- A specific type is descended from itself and from those types it is + -- directly or indirectly derived from. A specific type is covered by + -- itself and each class-wide type to whose class it belongs. + -- + -- A class-wide type T'Class is descended from T and those types which + -- T is descended from. A class-wide type is covered by each class-wide + -- type to whose class it belongs. + -- + -- + -- CHANGE HISTORY: + -- 19 Jul 95 SAIC Initial prerelease version. + -- 18 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. + -- + --! + package C460004_0 is + + type Tag_Type is tagged record + C1 : Natural; + end record; + + procedure Proc (X : in out Tag_Type); + + + type DTag_Type is new Tag_Type with record + C2 : String (1 .. 5); + end record; + + procedure Proc (X : in out DTag_Type); + + + type DDTag_Type is new DTag_Type with record + C3 : String (1 .. 5); + end record; + + procedure Proc (X : in out DDTag_Type); + + procedure NewProc (X : in DDTag_Type); + + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class; + + end C460004_0; + + + --==================================================================-- + + with Report; + package body C460004_0 is + + procedure Proc (X : in out Tag_Type) is + begin + X.C1 := 25; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DTag_Type) is + begin + Proc ( Tag_Type(X) ); + X.C2 := "Earth"; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DDTag_Type) is + begin + Proc ( DTag_Type(X) ); + X.C3 := "Orbit"; + end Proc; + + ----------------------------------------- + procedure NewProc (X : in DDTag_Type) is + Y : DDTag_Type := X; + begin + Proc (Y); + exception + when others => + Report.Failed ("Unexpected exception in NewProc"); + end NewProc; + + ----------------------------------------- + function CWFunc (X : Tag_Type'Class) return Tag_Type'Class is + Y : Tag_Type'Class := X; + begin + Proc (Y); + return Y; + end CWFunc; + + end C460004_0; + + + --==================================================================-- + + + with C460004_0; + use C460004_0; + + with Report; + procedure C460004 is + + Tag_Type_Init : constant Tag_Type := (C1 => 0); + DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); + DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); + + Tag_Type_Value : constant Tag_Type := (C1 => 25); + DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); + DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); + + begin + + Report.Test ("C460004", "Check that for a view conversion of a " & + "class-wide operand, Constraint_Error is raised if the " & + "tag of the operand does not identify a specific type " & + "covered by or descended from the target type"); + + -- + -- View conversion to specific type: + -- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : Tag_Type := Tag_Type_Init; + begin + Target := Tag_Type(P); + if (Target /= Tag_Type_Value) then + Report.Failed ("Target has wrong value: #01"); + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #01"); + when others => + Report.Failed ("Unexpected exception: #01"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + Target : DTag_Type := DTag_Type_Init; + begin + Target := DTag_Type(CWFunc(DDTag_Type_Value)); + if (Target /= DTag_Type_Value) then + Report.Failed ("Target has wrong value: #02"); + end if; + exception + when Constraint_Error => Report.Failed ("Constraint_Error raised: #02"); + when others => Report.Failed ("Unexpected exception: #02"); + end; + + ---------------------------------------------------------------------- + + declare + Target : DDTag_Type; + begin + Target := DDTag_Type(CWFunc(Tag_Type_Value)); + -- CWFunc returns a Tag_Type; its tag is preserved through + -- the view conversion. Constraint_Error should be raised. + + Report.Failed ("Constraint_Error not raised: #03"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #03"); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + begin + NewProc (DDTag_Type(P)); + Report.Failed ("Constraint_Error not raised: #04"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #04"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Value); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Target : DDTag_Type := DDTag_Type_Init; + begin + Target := DDTag_Type(P); + if (Target /= DDTag_Type_Value) then + Report.Failed ("Target has wrong value: #05"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #05"); + when others + => Report.Failed ("Unexpected exception: #05"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Value); + end; + + + -- + -- View conversion to class-wide type: + -- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #06"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #06"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DDTag_Type'Class(Operand) ); + Report.Failed ("Constraint_Error not raised: #07"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #07"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( DTag_Type'Class(Operand) ); + if Operand not in DTag_Type then + Report.Failed ("Operand has wrong tag: #08"); + elsif (Operand /= Tag_Type'Class (DTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #08"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #08"); + when others => + Report.Failed ("Unexpected exception: #08"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Proc( Tag_Type'Class(Operand) ); + if Operand not in DDTag_Type then + Report.Failed ("Operand has wrong tag: #09"); + elsif (Operand /= Tag_Type'Class (DDTag_Type_Value)) then + Report.Failed ("Operand has wrong value: #09"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #09"); + when others => + Report.Failed ("Unexpected exception: #09"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Init); + end; + + + Report.Result; + + end C460004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460005.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,260 ---- + -- C460005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for a view conversion of a tagged type that is the left + -- side of an assignment statement, the assignment assigns to the + -- corresponding part of the object denoted by the operand. + -- + -- TEST DESCRIPTION: + -- View conversions of class-wide operands to specific types are + -- placed on the right and left sides of assignment statements, and + -- conversions of class-wide operands to class-wide types are used + -- as actual parameters to dispatching operations. In all cases, a + -- check is made that Constraint_Error is raised if the tag of the + -- operand does not identify a specific type covered by or descended + -- from the target type, and not raised otherwise. + -- + -- For the cases where the view conversion is the left side of an + -- assignment statement, and Constraint_Error should not be raised, + -- an additional check is made that only the corresponding portion + -- of the operand is updated by the assignment. For example: + -- + -- type T is tagged record + -- C1 : Integer := 0; + -- end record; + -- + -- type DT is new T with record + -- C2 : Integer := 0; + -- end record; + -- + -- A : T := (C1 => 5); + -- B : DT := (C1 => 0, C2 => 10); + -- CWDT : T'Class := B; + -- + -- T(CWDT) := A; -- Updates component C1; C2 remains unchanged. + -- -- Value of CWDT is (C1 => 5, C2 => 10). + -- + -- + -- CHANGE HISTORY: + -- 31 Jul 95 SAIC Initial prerelease version. + -- 22 Apr 96 SAIC ACVC 2.1: Added a check for correct tag. + -- 08 Sep 96 SAIC ACVC 2.1: Modified Report.Test. + -- + --! + + package C460005_0 is + + type Tag_Type is tagged record + C1 : Natural; + end record; + + procedure Proc (X : in out Tag_Type); + + + type DTag_Type is new Tag_Type with record + C2 : String (1 .. 5); + end record; + + procedure Proc (X : in out DTag_Type); + + + type DDTag_Type is new DTag_Type with record + C3 : String (1 .. 5); + end record; + + procedure Proc (X : in out DDTag_Type); + + end C460005_0; + + + --==================================================================-- + + + package body C460005_0 is + + procedure Proc (X : in out Tag_Type) is + begin + X.C1 := 25; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DTag_Type) is + begin + Proc ( Tag_Type(X) ); + X.C2 := "Earth"; + end Proc; + + ----------------------------------------- + procedure Proc (X : in out DDTag_Type) is + begin + Proc ( DTag_Type(X) ); + X.C3 := "Orbit"; + end Proc; + + end C460005_0; + + + --==================================================================-- + + + with C460005_0; + use C460005_0; + + with Report; + procedure C460005 is + + Tag_Type_Init : constant Tag_Type := (C1 => 0); + DTag_Type_Init : constant DTag_Type := (Tag_Type_Init with "Hello"); + DDTag_Type_Init : constant DDTag_Type := (DTag_Type_Init with "World"); + + Tag_Type_Value : constant Tag_Type := (C1 => 25); + DTag_Type_Value : constant DTag_Type := (Tag_Type_Value with "Earth"); + DDTag_Type_Value : constant DDTag_Type := (DTag_Type_Value with "Orbit"); + + Tag_Type_Res : constant Tag_Type := (C1 => 25); + DTag_Type_Res : constant DTag_Type := (Tag_Type_Res with "Hello"); + DDTag_Type_Res : constant DDTag_Type := (DTag_Type_Res with "World"); + + begin + + Report.Test ("C460005", "Check that, for a view conversion of a tagged " & + "type that is the left side of an assignment statement, " & + "the assignment assigns to the corresponding part of the " & + "object denoted by the operand"); + + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if (Operand /= Tag_Type'Class (Tag_Type_Value)) then + Report.Failed ("Operand has wrong value: #01"); + end if; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #01"); + when others => + Report.Failed ("Unexpected exception: #01"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + DTag_Type(Operand) := DTag_Type_Value; + Report.Failed ("Constraint_Error not raised: #02"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #02"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + DDTag_Type(Operand) := DDTag_Type_Value; + Report.Failed ("Constraint_Error not raised: #03"); + + exception + when Constraint_Error => null; -- expected exception + when others => Report.Failed ("Unexpected exception: #03"); + end CW_Proc; + + begin + CW_Proc (Tag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if Operand not in DTag_Type then + Report.Failed ("Operand has wrong tag: #04"); + elsif (Operand /= Tag_Type'Class (DTag_Type_Res)) + then -- Check to make + Report.Failed ("Operand has wrong value: #04"); -- sure that C2 was + end if; -- not modified. + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #04"); + when others => + Report.Failed ("Unexpected exception: #04"); + end CW_Proc; + + begin + CW_Proc (DTag_Type_Init); + end; + + ---------------------------------------------------------------------- + + declare + procedure CW_Proc (P : Tag_Type'Class) is + Operand : Tag_Type'Class := P; + begin + Tag_Type(Operand) := Tag_Type_Value; + + if Operand not in DDTag_Type then + Report.Failed ("Operand has wrong tag: #05"); + elsif (Operand /= Tag_Type'Class (DDTag_Type_Res)) + then -- Check to make + Report.Failed ("Operand has wrong value: #05"); -- sure that C2, C3 + end if; -- were not changed. + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: #05"); + when others => + Report.Failed ("Unexpected exception: #05"); + end CW_Proc; + + begin + CW_Proc (DDTag_Type_Init); + end; + + Report.Result; + + end C460005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460006.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,378 ---- + -- C460006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a view conversion to a tagged type is permitted in the + -- prefix of a selected component, an object renaming declaration, and + -- (if the operand is a variable) on the left side of an assignment + -- statement. Check that such a renaming or assignment does not change + -- the tag of the operand. + -- + -- Check that, for a view conversion of a tagged type, each + -- nondiscriminant component of the new view denotes the matching + -- component of the operand object. Check that reading the value of the + -- view yields the result of converting the value of the operand object + -- to the target subtype. + -- + -- TEST DESCRIPTION: + -- The fact that the tag of an object is not changed is verified by + -- making calls to primitive operations which in turn make (re)dispatching + -- calls, and confirming that the proper bodies are executed. + -- + -- Selected components are checked in three contexts: as the object name + -- in an object renaming declaration, as the left operand of an inequality + -- operation, and as the left side of an assignment statement. + -- + -- View conversions of an object of a 2nd level type extension are + -- renamed as objects of an ancestor type and of a class-wide type. In + -- one case the operand of the conversion is itself a renaming of an + -- object. + -- + -- View conversions of an object of a 2nd level type extension are + -- checked for equality with record aggregates of various ancestor types. + -- In one case, the view conversion is to a class-wide type, and it is + -- checked for equality with the result of a class-wide function with + -- the following structure: + -- + -- function F return T'Class is + -- A : DDT := Expected_Value; + -- X : T'Class := T(A); + -- begin + -- return X; + -- + -- end F; + -- + -- ... + -- + -- Var : DDT := Expected_Value; + -- + -- if (T'Class(Var) /= F) then -- Condition should yield FALSE. + -- FAIL; + -- end if; + -- + -- The view conversion to which X is initialized does not affect the + -- value or tag of the operand; the tag of X is that of type DDT (not T), + -- and the components are those of A. The result of this function + -- should equal the value of an object of type DDT initialized to the + -- same value as F.A. + -- + -- To check that assignment to a view conversion does not change the tag + -- of the operand, an assignment is made to a conversion of an object, + -- and the object is then passed as an actual to a dispatching operation. + -- Conversions to both specific and class-wide types are checked. + -- + -- + -- CHANGE HISTORY: + -- 20 Jul 95 SAIC Initial prerelease version. + -- 24 Apr 96 SAIC Added type conversions. + -- + --! + + package C460006_0 is + + type Call_ID_Kind is (None, Parent_Outer, Parent_Inner, + Child_Outer, Child_Inner, + Grandchild_Outer, Grandchild_Inner); + + type Root_Type is abstract tagged record + First_Call : Call_ID_Kind := None; + Second_Call : Call_ID_Kind := None; + end record; + + procedure Inner_Proc (X : in out Root_Type) is abstract; + procedure Outer_Proc (X : in out Root_Type) is abstract; + + end C460006_0; + + + --==================================================================-- + + + package C460006_0.C460006_1 is + + type Parent_Type is new Root_Type with record + C1 : Integer := 0; + end record; + + procedure Inner_Proc (X : in out Parent_Type); + procedure Outer_Proc (X : in out Parent_Type); + + end C460006_0.C460006_1; + + + --==================================================================-- + + + package body C460006_0.C460006_1 is + + procedure Inner_Proc (X : in out Parent_Type) is + begin + X.Second_Call := Parent_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Parent_Type) is + begin + X.First_Call := Parent_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + + end C460006_0.C460006_1; + + + --==================================================================-- + + + package C460006_0.C460006_1.C460006_2 is + + type Child_Type is new Parent_Type with record + C2 : String(1 .. 5) := "-----"; + end record; + + procedure Inner_Proc (X : in out Child_Type); + procedure Outer_Proc (X : in out Child_Type); + + end C460006_0.C460006_1.C460006_2; + + + --==================================================================-- + + + package body C460006_0.C460006_1.C460006_2 is + + procedure Inner_Proc (X : in out Child_Type) is + begin + X.Second_Call := Child_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Child_Type) is + begin + X.First_Call := Child_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + + end C460006_0.C460006_1.C460006_2; + + + --==================================================================-- + + + package C460006_0.C460006_1.C460006_2.C460006_3 is + + type Grandchild_Type is new Child_Type with record + C3: String(1 .. 5) := "-----"; + end record; + + procedure Inner_Proc (X : in out Grandchild_Type); + procedure Outer_Proc (X : in out Grandchild_Type); + + + function ClassWide_Func return Parent_Type'Class; + + + Grandchild_Value : constant Grandchild_Type := (First_Call => None, + Second_Call => None, + C1 => 15, + C2 => "Hello", + C3 => "World"); + + end C460006_0.C460006_1.C460006_2.C460006_3; + + + --==================================================================-- + + + package body C460006_0.C460006_1.C460006_2.C460006_3 is + + procedure Inner_Proc (X : in out Grandchild_Type) is + begin + X.Second_Call := Grandchild_Inner; + end Inner_Proc; + + ------------------------------------------------- + procedure Outer_Proc (X : in out Grandchild_Type) is + begin + X.First_Call := Grandchild_Outer; + Inner_Proc ( Parent_Type'Class(X) ); + end Outer_Proc; + + ------------------------------------------------- + function ClassWide_Func return Parent_Type'Class is + A : Grandchild_Type := Grandchild_Value; + X : Parent_Type'Class := Parent_Type(A); -- Value of X is still that of A. + begin + return X; + end ClassWide_Func; + + end C460006_0.C460006_1.C460006_2.C460006_3; + + + --==================================================================-- + + + with C460006_0.C460006_1.C460006_2.C460006_3; + + with Report; + procedure C460006 is + + package Root_Package renames C460006_0; + package Parent_Package renames C460006_0.C460006_1; + package Child_Package renames C460006_0.C460006_1.C460006_2; + package Grandchild_Package renames C460006_0.C460006_1.C460006_2.C460006_3; + + begin + Report.Test ("C460006", "Check that a view conversion to a tagged type " & + "is permitted in the prefix of a selected component, an " & + "object renaming declaration, and (if the operand is a " & + "variable) on the left side of an assignment statement. " & + "Check that such a renaming or assignment does not change " & + " the tag of the operand"); + + + -- + -- Check conversion as prefix of selected component: + -- + + Selected_Component_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + CW_Var : Parent_Type'Class := Var; + + Ren : Integer renames Parent_Type(Var).C1; + + begin + if Ren /= 15 then + Report.Failed ("Wrong value: selected component in renaming"); + end if; + + if Child_Type(Var).C2 /= "Hello" then + Report.Failed ("Wrong value: selected component in IF"); + end if; + + Grandchild_Type(CW_Var).C3(2..4) := "eir"; + if CW_Var /= Parent_Type'Class + (Grandchild_Type'(None, None, 15, "Hello", "Weird")) + then + Report.Failed ("Wrong value: selected component in assignment"); + end if; + end Selected_Component_Subtest; + + + -- + -- Check conversion in object renaming: + -- + + Object_Renaming_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + Ren1 : Parent_Type renames Parent_Type(Var); + Ren2 : Child_Type renames Child_Type(Var); + Ren3 : Parent_Type'Class renames Parent_Type'Class(Var); + Ren4 : Parent_Type renames Parent_Type(Ren2); -- Rename of rename. + begin + Outer_Proc (Ren1); + if Ren1 /= (Parent_Outer, Grandchild_Inner, 15) then + Report.Failed ("Value or tag not preserved by object renaming: Ren1"); + end if; + + Outer_Proc (Ren2); + if Ren2 /= (Child_Outer, Grandchild_Inner, 15, "Hello") then + Report.Failed ("Value or tag not preserved by object renaming: Ren2"); + end if; + + Outer_Proc (Ren3); + if Ren3 /= Parent_Type'Class + (Grandchild_Type'(Grandchild_Outer, + Grandchild_Inner, + 15, + "Hello", + "World")) + then + Report.Failed ("Value or tag not preserved by object renaming: Ren3"); + end if; + + Outer_Proc (Ren4); + if Ren4 /= (Parent_Outer, Grandchild_Inner, 15) then + Report.Failed ("Value or tag not preserved by object renaming: Ren4"); + end if; + end Object_Renaming_Subtest; + + + -- + -- Check reading view conversion, and conversion as left side of assignment: + -- + + View_Conversion_Subtest: + declare + use Root_Package, Parent_Package, Child_Package, Grandchild_Package; + + Var : Grandchild_Type := Grandchild_Value; + Specific : Child_Type; + ClassWide : Parent_Type'Class := Var; -- Grandchild_Type tag. + begin + if Parent_Type(Var) /= (None, None, 15) then + Report.Failed ("View has wrong value: #1"); + end if; + + if Child_Type(Var) /= (None, None, 15, "Hello") then + Report.Failed ("View has wrong value: #2"); + end if; + + if Parent_Type'Class(Var) /= ClassWide_Func then + Report.Failed ("Upward view conversion did not preserve " & + "extension's components"); + end if; + + + Parent_Type(Specific) := (None, None, 26); -- Assign to view. + Outer_Proc (Specific); -- Call dispatching op. + + if Specific /= (Child_Outer, Child_Inner, 26, "-----") then + Report.Failed ("Value or tag not preserved by assignment: Specific"); + end if; + + + Parent_Type(ClassWide) := (None, None, 44); -- Assign to view. + Outer_Proc (ClassWide); -- Call dispatching op. + + if ClassWide /= Parent_Type'Class + (Grandchild_Type'(Grandchild_Outer, + Grandchild_Inner, + 44, + "Hello", + "World")) + then + Report.Failed ("Value or tag not preserved by assignment: ClassWide"); + end if; + end View_Conversion_Subtest; + + Report.Result; + + end C460006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460007.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- C460007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in a numeric type conversion, if the target type is an + -- integer type and the operand type is real, the result is rounded + -- to the nearest integer, and away from zero if the result is exactly + -- halfway between two integers. Check for static and non-static type + -- conversions. + -- + -- TEST DESCRIPTION: + -- The following cases are considered: + -- + -- X.5 X.5 + delta -X.5 + delta + -- -X.5 X.5 - delta -X.5 - delta + -- + -- Both zero and non-zero values are used for X. The value of delta is + -- chosen to be a very small increment (on the order of 1.0E-10). For + -- fixed and floating point cases, the value of delta is chosen such that + -- "(-)X.5 +(-) delta" is a multiple of the small, or a machine number, + -- respectively. + -- + -- The following type conversions are performed: + -- + -- ID Real operand Cases Target integer subtype + -- ------------------------------------------------------------------ + -- 1 Real named number X.5 Nonstatic + -- 2 X.5 - delta Nonstatic + -- 3 -X.5 - delta Static + -- 4 Real literal -X.5 Static + -- 5 X.5 + delta Static + -- 6 -X.5 + delta Nonstatic + -- 7 Floating point object -X.5 - delta Nonstatic + -- 8 X.5 - delta Static + -- 9 Fixed point object X.5 Static + -- 10 X.5 + delta Static + -- 11 -X.5 + delta Nonstatic + -- The conversion is either assigned to a variable of the target subtype + -- or passed as a parameter to a subprogram (both nonstatic contexts). + -- + -- The subprogram Equal is used to circumvent potential optimizations. + -- + -- + -- CHANGE HISTORY: + -- 03 Oct 95 SAIC Initial prerelease version. + -- + --! + + with System; + package C460007_0 is + + -- + -- Target integer subtype (static): + -- + + type Static_Integer_Subtype is range -32_000 .. 32_000; + + Static_Target : Static_Integer_Subtype; + + function Equal (L, R: Static_Integer_Subtype) return Boolean; + + + -- + -- Named numbers: + -- + + NN_Half : constant := 0.5000000000; + NN_Less_Half : constant := 126.4999999999; + NN_More_Half : constant := -NN_Half - 0.0000000001; + + + -- + -- Floating point: + -- + + type My_Float is digits System.Max_Digits; + + Flt_Rnd_Toward_Zero : My_Float := My_Float'Pred(NN_Half); + Flt_Rnd_Away_Zero : constant My_Float := My_Float'Pred(-113.5); + + + -- + -- Fixed point: + -- + + type My_Fixed is delta 0.1 range -5.0 .. 5.0; + + Fix_Half : My_Fixed := 0.5; + Fix_Rnd_Away_Zero : My_Fixed := Fix_Half + My_Fixed'Small; + Fix_Rnd_Toward_Zero : constant My_Fixed := -3.5 + My_Fixed'Small; + + end C460007_0; + + + --==================================================================-- + + + package body C460007_0 is + + function Equal (L, R: Static_Integer_Subtype) return Boolean is + begin + return (L = R); + end Equal; + + end C460007_0; + + + --==================================================================-- + + + with C460007_0; + use C460007_0; + + with Report; + procedure C460007 is + + -- + -- Target integer subtype (nonstatic): + -- + + Limit : Static_Integer_Subtype := + Static_Integer_Subtype(Report.Ident_Int(128)); + + subtype Nonstatic_Integer_Subtype is Static_Integer_Subtype + range -Limit .. Limit; + + Nonstatic_Target : Static_Integer_Subtype; + + begin + + Report.Test ("C460007", "Rounding for type conversions of real operand " & + "to integer target"); + + + -- -------------------------- + -- Named number/literal cases: + -- -------------------------- + + Nonstatic_Target := Nonstatic_Integer_Subtype(NN_Half); + + if not Equal(Nonstatic_Target, 1) then -- Case 1. + Report.Failed ("Wrong result for named number operand" & + "(case 1), nonstatic target subtype"); + end if; + + if not Equal(Nonstatic_Integer_Subtype(NN_Less_Half), 126) then -- Case 2. + Report.Failed ("Wrong result for named number operand" & + "(case 2), nonstatic target subtype"); + end if; + + Static_Target := Static_Integer_Subtype(NN_More_Half); + + if not Equal(Static_Target, -1) then -- Case 3. + Report.Failed ("Wrong result for named number operand" & + "(case 3), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(-0.50), -1) then -- Case 4. + Report.Failed ("Wrong result for literal operand" & + "(case 4), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(29_546.5001), 29_547) then -- Case 5. + Report.Failed ("Wrong result for literal operand" & + "(case 5), static target subtype"); + end if; + + if not Equal(Nonstatic_Integer_Subtype(-66.499), -66) then -- Case 6. + Report.Failed ("Wrong result for literal operand" & + "(case 6), nonstatic target subtype"); + end if; + + + -- -------------------- + -- Floating point cases: + -- -------------------- + + Nonstatic_Target := Nonstatic_Integer_Subtype(Flt_Rnd_Away_Zero); + + if not Equal(Nonstatic_Target, -114) then -- Case 7. + Report.Failed ("Wrong result for floating point operand" & + "(case 7), nonstatic target subtype"); + end if; + -- Case 8. + if not Equal(Static_Integer_Subtype(Flt_Rnd_Toward_Zero), 0) then + Report.Failed ("Wrong result for floating point operand" & + "(case 8), static target subtype"); + end if; + + + -- ----------------- + -- Fixed point cases: + -- ----------------- + + Static_Target := Static_Integer_Subtype(Fix_Half); + + if not Equal(Static_Target, 1) then -- Case 9. + Report.Failed ("Wrong result for fixed point operand" & + "(case 9), static target subtype"); + end if; + + if not Equal(Static_Integer_Subtype(Fix_Rnd_Away_Zero), 1) then -- Case 10. + Report.Failed ("Wrong result for fixed point operand" & + "(case 10), static target subtype"); + end if; + + Nonstatic_Target := Nonstatic_Integer_Subtype(Fix_Rnd_Toward_Zero); + + if not Equal(Nonstatic_Target, -3) then -- Case 11. + Report.Failed ("Wrong result for fixed point operand" & + "(case 11), nonstatic target subtype"); + end if; + + + Report.Result; + + end C460007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460008.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,286 ---- + -- C460008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that conversion to a modular type raises Constraint_Error + -- when the operand value is outside the base range of the modular type. + -- + -- TEST DESCRIPTION: + -- Test conversion from integer, float, fixed and decimal types to + -- modular types. Test conversion to mod 255, mod 256 and mod 258 + -- to test the boundaries of 8 bit (+/-) unsigned numbers. + -- Test operand values that are negative, the value of the mod, + -- and greater than the value of the mod. + -- Declare a generic test procedure and instantiate it for each of the + -- unsigned types for each operand type. + -- + -- + -- CHANGE HISTORY: + -- 04 OCT 95 SAIC Initial version + -- 15 MAY 96 SAIC Revised for 2.1 + -- 24 NOV 98 RLB Moved decimal cases into new test, C460011, to + -- prevent this test from being inapplicable to + -- implementations not supporting decimal types. + -- + --! + + ------------------------------------------------------------------- C460008 + + with Report; + + procedure C460008 is + + Shy_By_One : constant := 2**8-1; + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + type Unsigned_8_Bit is mod 2**8; + type Unsigned_Over_8 is mod Heavy_By_Two; + + NPC : constant String := " not properly converted"; + + procedure Assert( Truth: Boolean; Message: String ) is + begin + if not Truth then + Report.Failed(Message); + end if; + end Assert; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is range <>; + type Target is mod <>; + procedure Integer_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Integer_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Int expected Constraint_Error " & Message); + -- the call to Comment is to make the otherwise dead assignment to + -- Item live. + -- To avoid invoking C_E on a call to 'Image in Report.Failed that + -- could cause a false pass + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Int Raised wrong exception " & Message); + end Integer_Conversion_Check; + + procedure Int_To_Short is + new Integer_Conversion_Check( Integer, Unsigned_Edge_8 ); + + procedure Int_To_Eight is + new Integer_Conversion_Check( Integer, Unsigned_8_Bit ); + + procedure Int_To_Wide is + new Integer_Conversion_Check( Integer, Unsigned_Over_8 ); + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is digits <>; + type Target is mod <>; + procedure Float_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Float_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Flt expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Flt raised wrong exception " & Message); + end Float_Conversion_Check; + + procedure Float_To_Short is + new Float_Conversion_Check( Float, Unsigned_Edge_8 ); + + procedure Float_To_Eight is + new Float_Conversion_Check( Float, Unsigned_8_Bit ); + + procedure Float_To_Wide is + new Float_Conversion_Check( Float, Unsigned_Over_8 ); + + function Identity( Root_Beer: Float ) return Float is + -- a knockoff of Report.Ident_Int for type Float + Nothing : constant Float := 0.0; + begin + if Report.Ident_Bool( Root_Beer = Nothing ) then + return Nothing; + else + return Root_Beer; + end if; + end Identity; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + generic + type Source is delta <>; + type Target is mod <>; + procedure Fixed_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Fixed_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Fix expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Fix raised wrong exception " & Message); + end Fixed_Conversion_Check; + + procedure Fixed_To_Short is + new Fixed_Conversion_Check( Duration, Unsigned_Edge_8 ); + + procedure Fixed_To_Eight is + new Fixed_Conversion_Check( Duration, Unsigned_8_Bit ); + + procedure Fixed_To_Wide is + new Fixed_Conversion_Check( Duration, Unsigned_Over_8 ); + + function Identity( A_Stitch: Duration ) return Duration is + Threadbare : constant Duration := 0.0; + begin + if Report.Ident_Bool( A_Stitch = Threadbare ) then + return Threadbare; + else + return A_Stitch; + end if; + end Identity; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("C460008", "Check that conversion to " & + "a modular type raises Constraint_Error when " & + "the operand value is outside the base range " & + "of the modular type" ); + + + -- Integer Error cases + + Int_To_Short( Report.Ident_Int( -1 ), "I2S Dynamic, Negative" ); + Int_To_Short( Report.Ident_Int( Shy_By_One ), "I2S Dynamic, At_Mod" ); + Int_To_Short( Report.Ident_Int( Heavy_By_Two+1 ), "I2S Dynamic, Over_Mod" ); + + Int_To_Eight( -Shy_By_One, "I28 Static, Negative" ); + Int_To_Eight( 2**8, "I28 Static, At_Mod" ); + Int_To_Eight( Heavy_By_Two+1, "I28 Static, Over_Mod" ); + + Int_To_Wide ( Report.Ident_Int( -(Heavy_By_Two*2) ), + "I2W Dynamic, Negative" ); + Int_To_Wide ( Heavy_By_Two, "I2W Static, At_Mod" ); + Int_To_Wide ( Report.Ident_Int( Heavy_By_Two*2 ), "I2W Dynamic, Over_Mod" ); + + -- Float Error cases + + Float_To_Short( -13.31, "F2S Static, Negative" ); + Float_To_Short( Identity ( Float(Shy_By_One)), "F2S Dynamic, At_Mod" ); + Float_To_Short( 6378.388, "F2S Static, Over_Mod" ); + + Float_To_Eight( Identity( -99.3574 ), "F28 Dynamic, Negative" ); + Float_To_Eight( 2.0**8, "F28 Static, At_Mod" ); + Float_To_Eight( 2.0**9, "F28 Static, Over_Mod" ); + + Float_To_Wide ( -0.54953_93129_81644, "FTW Static, Negative" ); + Float_To_Wide ( Identity( 2.0**8 +2.0 ), "FTW Dynamic, At_Mod" ); + Float_To_Wide ( Identity( 2.0**8 +2.5001 ), "FTW Dynamic, Over_Mod" ); + Float_To_Wide ( Identity( Float'Last ), "FTW Dynamic, Over_Mod" ); + + -- Fixed Error cases + + Fixed_To_Short( Identity( -5.00 ), "D2S Dynamic, Negative" ); + Fixed_To_Short( Shy_By_One * 1.0, "D2S Static, At_Mod" ); + Fixed_To_Short( 1995.9, "D2S Static, Over_Mod" ); + + Fixed_To_Eight( -0.5, "D28 Static, Negative" ); + Fixed_To_Eight( 2.0*128, "D28 Static, At_Mod" ); + Fixed_To_Eight( Identity( 2001.2 ), "D28 Dynamic, Over_Mod" ); + + Fixed_To_Wide ( Duration'First, "D2W Static, Negative" ); + Fixed_To_Wide ( Identity( 2*128.0 +2.0 ), "D2W Dynamic, At_Mod" ); + Fixed_To_Wide ( Duration'Last, "D2W Static, Over_Mod" ); + + -- having made it this far, the rest is downhill... + -- check a few, correct, edge cases, and we're done + + Eye_Dew: declare + A_Float : Float := 0.0; + Your_Time : Duration := 0.0; + Number : Integer := 0; + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + begin + Little := Unsigned_Edge_8(A_Float); + Assert( Little = 0, "Float => Little, 0"); + + + Moderate := Unsigned_8_Bit (Your_Time); + Assert( Moderate = 0, "Your_Time => Moderate, 0"); + + Big := Unsigned_Over_8 (Number); + Assert( Big = 0, "Number => Big, 0"); + + A_Float := 2.0**8-2.0; + Your_Time := 2.0*128-2.0; + Number := 2**8; + + Little := Unsigned_Edge_8(A_Float); + Assert( Little = 254, "Float => Little, 254"); + + Little := Unsigned_Edge_8(Your_Time); + Assert( Little = 254, "Your_Time => Little, 254"); + + Big := Unsigned_Over_8 (A_Float + 2.0); + Assert( Big = 256, "Sense => Big, 256"); + + Big := Unsigned_Over_8 (Number); + Assert( Big = 256, "Number => Big, 256"); + + end Eye_Dew; + + Report.Result; + + end C460008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460009.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,467 ---- + -- C460009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Constraint_Error is raised in cases of null arrays when: + -- 1. an assignment is made to a null array if the length of each + -- dimension of the operand does not match the length of + -- the corresponding dimension of the target subtype. + -- 2. an array actual parameter does not match the length of + -- corresponding dimensions of the formal in out parameter where + -- the actual parameter has the form of a type conversion. + -- 3. an array actual parameter does not match the length of + -- corresponding dimensions of the formal out parameter where + -- the actual parameter has the form of a type conversion. + -- + -- TEST DESCRIPTION: + -- This transition test creates examples where array of null ranges + -- raises Constraint_Error if any of the lengths mismatch. + -- + -- Inspired by C52103S.ADA, C64105E.ADA, and C64105F.ADA. + -- + -- + -- CHANGE HISTORY: + -- 21 Mar 96 SAIC Initial version for ACVC 2.1. + -- 21 Sep 96 SAIC ACVC 2.1: Added new case. + -- + --! + + with Report; + + procedure C460009 is + + subtype Int is Integer range 1 .. 3; + + begin + + Report.Test("C460009","Check that Constraint_Error is raised in " & + "cases of null arrays if any of the lengths mismatch " & + "in assignments and parameter passing"); + + --------------------------------------------------------------------------- + declare + + type Arr_Int1 is array (Int range <>) of Integer; + Arr_Obj1 : Arr_Int1 (2 .. Report.Ident_Int(1)); -- null array object + + begin + + -- Same lengths, no Constraint_Error raised. + Arr_Obj1 := (Report.Ident_Int(3) .. 2 => Report.Ident_Int(1)); + + Report.Comment ("Dead assignment prevention in Arr_Obj1 => " & + Integer'Image (Arr_Obj1'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj1 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj1 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int2 is array (Int range <>, Int range <>) of Integer; + Arr_Obj2 : Arr_Int2 (1 .. Report.Ident_Int(2), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + begin + + -- Same lengths, no Constraint_Error raised. + Arr_Obj2 := Arr_Int2'(Report.Ident_Int(2) .. 3 => + (Report.Ident_Int(2) .. Report.Ident_Int(1) => + Report.Ident_Int(1))); + + Report.Comment ("Dead assignment prevention in Arr_Obj2 => " & + Integer'Image (Arr_Obj2'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj2 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj2 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int3 is array (Int range <>, Int range <>) of Integer; + Arr_Obj3 : Arr_Int3 (1 .. Report.Ident_Int(2), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + + begin + + -- Lengths mismatch, Constraint_Error raised. + Arr_Obj3 := Arr_Int3'(Report.Ident_Int(3) .. 2 => + (Report.Ident_Int(1) .. Report.Ident_Int(3) => + Report.Ident_Int(1))); + + Report.Comment ("Dead assignment prevention in Arr_Obj3 => " & + Integer'Image (Arr_Obj3'Last)); + + Report.Failed ("Constraint_Error not raised in Arr_Obj3"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj3 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int4 is array (Int range <>, Int range <>, Int range <>) of + Integer; + Arr_Obj4 : Arr_Int4 (1 .. Report.Ident_Int(2), + Report.Ident_Int(1) .. Report.Ident_Int(3), + Report.Ident_Int(3) .. Report.Ident_Int(2)); + -- null array object + begin + + -- Lengths mismatch, Constraint_Error raised. + Arr_Obj4 := Arr_Int4'(Report.Ident_Int(1) .. 3 => + (Report.Ident_Int(1) .. Report.Ident_Int(2) => + (Report.Ident_Int(3) .. Report.Ident_Int(2) => + Report.Ident_Int(1)))); + + Report.Comment ("Dead assignment prevention in Arr_Obj4 => " & + Integer'Image (Arr_Obj4'Last)); + + Report.Failed ("Constraint_Error not raised in Arr_Obj4"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj4 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Int5 is array (Int range <>) of Integer; + Arr_Obj5 : Arr_Int5 (2 .. Report.Ident_Int(1)); -- null array object + + begin + + -- Only lengths of two null ranges are different, no Constraint_Error + -- raised. + Arr_Obj5 := (Report.Ident_Int(3) .. 1 => Report.Ident_Int(1)); + + Report.Comment ("Dead assignment prevention in Arr_Obj5 => " & + Integer'Image (Arr_Obj5'Last)); + + exception + + when Constraint_Error => + Report.Failed ("Arr_Obj5 - Constraint_Error exception raised"); + when others => + Report.Failed ("Arr_Obj5 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + subtype Str is String (Report.Ident_Int(5) .. 4); + -- null string + Str_Obj : Str; + + begin + + -- Same lengths, no Constraint_Error raised. + Str_Obj := (Report.Ident_Int(1) .. 0 => 'Z'); + Str_Obj(2 .. 1) := ""; + Str_Obj(4 .. 2) := (others => 'X'); + Str_Obj(Report.Ident_Int(6) .. 3) := ""; + Str_Obj(Report.Ident_Int(0) .. Report.Ident_Int(-1)) := (others => 'Y'); + + exception + + when Constraint_Error => + Report.Failed ("Str_Obj - Constraint_Error exception raised"); + when others => + Report.Failed ("Str_Obj - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Char5 is array (Int range <>, Int range <>) of Character; + subtype Formal is Arr_Char5 + (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); + Arr_Obj5 : Arr_Char5 (Report.Ident_Int(2) .. Report.Ident_Int(1), + Report.Ident_Int(1) .. Report.Ident_Int(2)) + := (Report.Ident_Int(2) .. Report.Ident_Int(1) => + (Report.Ident_Int(1) .. Report.Ident_Int(2) => ' ')); + + procedure Proc5 (P : in out Formal) is + begin + Report.Failed ("No exception raised in Proc5"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc5"); + when others => + Report.Failed ("Others exception raised in Proc5"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc5 (Formal(Arr_Obj5)); + + Report.Failed ("Constraint_Error not raised in the call Proc5"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj5 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array + (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; + + type Actual is array + (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; + + Arr_Obj6 : Actual := (5 .. 3 => (3 .. 5 => ' ')); + + procedure Proc6 (P : in out Formal) is + begin + Report.Failed ("No exception raised in Proc6"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc6"); + when others => + Report.Failed ("Others exception raised in Proc6"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc6 (Formal(Arr_Obj6)); + + Report.Failed ("Constraint_Error not raised in the call Proc6"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj6 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array (Int range <>, Int range <>) of Character; + type Actual is array (Positive range 5 .. 2, + Positive range 1 .. 3) of Character; + + Arr_Obj7 : Actual := (5 .. 2 => (1 .. 3 => ' ')); + + procedure Proc7 (P : in out Formal) is + begin + if P'Last /= 2 and P'Last(2) /= 3 then + Report.Failed ("Wrong bounds passed for Arr_Obj7"); + end if; + + -- Lengths mismatch, Constraint_Error raised. + P := (1 .. 3 => (3 .. 0 => ' ')); + + Report.Comment ("Dead assignment prevention in Proc7 => " & + Integer'Image (P'Last)); + + Report.Failed ("No exception raised in Proc7"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Others exception raised in Proc7"); + end; + + begin + + -- Same lengths, no Constraint_Error raised. + Proc7 (Formal(Arr_Obj7)); + + if Arr_Obj7'Last /= 2 and Arr_Obj7'Last(2) /= 3 then + Report.Failed ("Bounds changed for Arr_Obj7"); + end if; + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised after call Proc7"); + when others => + Report.Failed ("Arr_Obj7 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Arr_Char8 is array (Int range <>, Int range <>) of Character; + subtype Formal is Arr_Char8 + (Report.Ident_Int(2) .. 0, 1 .. Report.Ident_Int(3)); + Arr_Obj8 : Arr_Char8 (Report.Ident_Int(2) .. Report.Ident_Int(1), + Report.Ident_Int(1) .. Report.Ident_Int(2)); + + procedure Proc8 (P : out Formal) is + begin + Report.Failed ("No exception raised in Proc8"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc8"); + when others => + Report.Failed ("Others exception raised in Proc8"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc8 (Formal(Arr_Obj8)); + + Report.Failed ("Constraint_Error not raised in the call Proc8"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj8 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array + (Report.Ident_Int(1) .. 3, 3 .. Report.Ident_Int(1)) of Character; + + type Actual is array + (Report.Ident_Int(5) .. 3, 3 .. Report.Ident_Int(5)) of Character; + + Arr_Obj9 : Actual; + + procedure Proc9 (P : out Formal) is + begin + Report.Failed ("No exception raised in Proc9"); + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised in Proc9"); + when others => + Report.Failed ("Others exception raised in Proc9"); + end; + + begin + + -- Lengths mismatch in the type conversion, Constraint_Error raised. + Proc9 (Formal(Arr_Obj9)); + + Report.Failed ("Constraint_Error not raised in the call Proc9"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Arr_Obj9 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + declare + + type Formal is array (Int range <>, Int range <>) of Character; + type Actual is array (Positive range 5 .. 2, + Positive range 1 .. 3) of Character; + + Arr_Obj10 : Actual; + + procedure Proc10 (P : out Formal) is + begin + if P'Last /= 2 and P'Last(2) /= 3 then + Report.Failed ("Wrong bounds passed for Arr_Obj10"); + end if; + + -- Lengths mismatch, Constraint_Error raised. + P := (1 .. 3 => (3 .. 1 => ' ')); + + Report.Comment ("Dead assignment prevention in Proc10 => " & + Integer'Image (P'Last)); + + Report.Failed ("No exception raised in Proc10"); + + exception + + when Constraint_Error => null; -- exception expected. + when others => + Report.Failed ("Others exception raised in Proc10"); + end; + + begin + + -- Same lengths, no Constraint_Error raised. + Proc10 (Formal(Arr_Obj10)); + + if Arr_Obj10'Last /= 2 and Arr_Obj10'Last(2) /= 3 then + Report.Failed ("Bounds changed for Arr_Obj10"); + end if; + + exception + + when Constraint_Error => + Report.Failed ("Constraint_Error exception raised after call Proc10"); + when others => + Report.Failed ("Arr_Obj10 - others exception raised"); + + end; + + --------------------------------------------------------------------------- + Report.Result; + + end C460009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460010.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,354 ---- + -- C460010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for an array aggregate without an others choice assigned + -- to an object of a constrained array subtype, Constraint_Error is not + -- raised if the length of each dimension of the aggregate equals the + -- length of the corresponding dimension of the target object, even if + -- the bounds of the corresponding index ranges do not match. + -- + -- TEST DESCRIPTION: + -- The test verifies that sliding of array bounds is performed on array + -- aggregates that are part of a larger aggregate, where the bounds of + -- the corresponding index ranges do not match but the lengths of the + -- corresponding dimensions are the same. Both aggregates containing + -- named associations and positional associations are checked. Cases + -- involving static and nonstatic index constraints, as well as pre- + -- defined and modular integer index subtypes, are included. + -- + -- + -- CHANGE HISTORY: + -- 15 Apr 96 SAIC Prerelease version for ACVC 2.1. + -- 20 Oct 96 SAIC Removed unnecessary parentheses and type + -- conversions. + -- + --! + + with Report; + pragma Elaborate (Report); + + package C460010_0 is + + type Modular_Type is mod 10; -- Range 0 .. 9. + + + Two : Modular_Type := Modular_Type (Report.Ident_Int(2)); + Four : Modular_Type := Modular_Type (Report.Ident_Int(4)); + + type Array_Modular_Index is array (Modular_Type range <>) of Integer; + + subtype Array_Static_Modular_Constraint is Array_Modular_Index(2..4); + subtype Array_Nonstatic_Modular_Constraint is Array_Modular_Index(Two..Four); + + end C460010_0; + + + --==================================================================-- + + + with Report; + pragma Elaborate (Report); + + package C460010_1 is + + One : Integer := Report.Ident_Int(1); + Ten : Integer := Report.Ident_Int(10); + + subtype Integer_Subtype is Integer range One .. Ten; + + + Two : Integer := Report.Ident_Int(2); + Four : Integer := Report.Ident_Int(4); + + type Array_Integer_Index is array (Integer_Subtype range <>) of Boolean; + + subtype Array_Static_Integer_Constraint is Array_Integer_Index(2..4); + subtype Array_Nonstatic_Integer_Constraint is Array_Integer_Index(Two..Four); + + end C460010_1; + + + --==================================================================-- + + + -- Generic equality function: + + generic + type Operand_Type is private; + function C460010_2 (L, R : Operand_Type) return Boolean; + + + function C460010_2 (L, R : Operand_Type) return Boolean is + begin + return L = R; + end C460010_2; + + + --==================================================================-- + + + with C460010_0; + with C460010_1; + with C460010_2; + + with Report; + + procedure C460010 is + + generic function Generic_Equality renames C460010_2; + + begin + Report.Test ("C460010", "Check that Constraint_Error is not raised if " & + "an array aggregate without an others choice is assigned " & + "to an object of a constrained array subtype, and the " & + "length of each dimension of the aggregate equals the " & + "length of the corresponding dimension of the target object"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_0.Array_Static_Modular_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_1: + begin + Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 1"); + when others => + Report.Failed ("Unexpected exception raised: Case 1"); + end CASE_1; + + ---=---=---=---=---=---=--- + + CASE_2: + begin + Target := (1 => (5, 10, 15)); -- Positional associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 2"); + when others => + Report.Failed ("Unexpected exception raised: Case 2"); + end CASE_2; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Rec (Disc : C460010_0.Modular_Type := 4) is record + Arr : C460010_0.Array_Modular_Index(2 .. Disc); + end record; + + function Equals is new Generic_Equality (Rec); + Target : Rec; + begin + ---=---=---=---=---=---=--- + CASE_3: + begin + Target := (Disc => 4, Arr => (1 => 1, 2 => 2, 3 => 3)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 3"); + when others => + Report.Failed ("Unexpected exception raised: Case 3"); + end CASE_3; + + ---=---=---=---=---=---=--- + + CASE_4: + begin + Target := (Disc => 4, Arr => (1 ,2, 3)); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 4"); + when others => + Report.Failed ("Unexpected exception raised: Case 4"); + end CASE_4; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_0.Array_Nonstatic_Modular_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_5: + begin + Target := (1 => (1 => 1, 2 => 2, 3 => 3)); -- Named associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 5"); + when others => + Report.Failed ("Unexpected exception raised: Case 5"); + end CASE_5; + + ---=---=---=---=---=---=--- + + CASE_6: + begin + Target := (1 => ((5, 10, 15))); -- Positional associations. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 6"); + when others => + Report.Failed ("Unexpected exception raised: Case 6"); + end CASE_6; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_1.Array_Static_Integer_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_7: + begin + Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 7"); + when others => + Report.Failed ("Unexpected exception raised: Case 7"); + end CASE_7; + + ---=---=---=---=---=---=--- + + CASE_8: + begin + Target := (1 => ((False, False, True))); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 8"); + when others => + Report.Failed ("Unexpected exception raised: Case 8"); + end CASE_8; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + declare + type Arr is array (1..1) of C460010_1.Array_Nonstatic_Integer_Constraint; + function Equals is new Generic_Equality (Arr); + Target : Arr; + begin + ---=---=---=---=---=---=--- + CASE_9: + begin + Target := (1 => (1 => True, 2 => True, 3 => False)); -- Named. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 9"); + when others => + Report.Failed ("Unexpected exception raised: Case 9"); + end CASE_9; + + ---=---=---=---=---=---=--- + + CASE_10: + begin + Target := (1 => (False, False, True)); -- Positional. + + if not Equals (Target, Target) then + Report.Failed ("Avoid optimization"); -- Never executed. + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised: Case 10"); + when others => + Report.Failed ("Unexpected exception raised: Case 10"); + end CASE_10; + + ---=---=---=---=---=---=--- + end; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end C460010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460011.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,210 ---- + -- C460011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that conversion of a decimal type to a modular type raises + -- Constraint_Error when the operand value is outside the base range + -- of the modular type. + -- Check that a conversion of a decimal type to an integer type + -- rounds correctly. + -- + -- TEST DESCRIPTION: + -- Test conversion from decimal types to modular types. Test + -- conversion to mod 255, mod 256 and mod 258 to test the boundaries + -- of 8 bit (+/-) unsigned numbers. + -- Test operand values that are negative, the value of the mod, + -- and greater than the value of the mod. + -- Declare a generic test procedure and instantiate it for each of the + -- unsigned types for each operand type. + -- Check that the the operand is properly rounded during the conversion. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations which support + -- decimal types. + -- + -- CHANGE HISTORY: + -- 24 NOV 98 RLB Split decimal cases from C460008 into this + -- test, added conversions to integer types. + -- 18 JAN 99 RLB Repaired errors in test. + -- + --! + + ------------------------------------------------------------------- C460011 + + with Report; + + procedure C460011 is + + Shy_By_One : constant := 2**8-1; + Heavy_By_Two : constant := 2**8+2; + + type Unsigned_Edge_8 is mod Shy_By_One; + type Unsigned_8_Bit is mod 2**8; + type Unsigned_Over_8 is mod Heavy_By_Two; + + type Signed_8_Bit is range -128 .. 127; + type Signed_Over_8 is range -200 .. 200; + + NPC : constant String := " not properly converted"; + + procedure Assert( Truth: Boolean; Message: String ) is + begin + if not Truth then + Report.Failed(Message); + end if; + end Assert; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + type Decim is delta 0.1 digits 5; -- N/A => ERROR. + + generic + type Source is delta <> digits <>; + type Target is mod <>; + procedure Decimal_Conversion_Check( For_The_Value : Source; + Message : String ); + + procedure Decimal_Conversion_Check( For_The_Value : Source; + Message : String ) is + + Item : Target; + + begin + Item := Target( For_The_Value ); + Report.Failed("Deci expected Constraint_Error " & Message); + Report.Comment("Value of" & Target'Image(Item) & NPC); + exception + when Constraint_Error => null; -- expected case + when others => Report.Failed("Deci raised wrong exception " & Message); + end Decimal_Conversion_Check; + + procedure Decim_To_Short is + new Decimal_Conversion_Check( Decim, Unsigned_Edge_8 ); + + procedure Decim_To_Eight is + new Decimal_Conversion_Check( Decim, Unsigned_8_Bit ); + + procedure Decim_To_Wide is + new Decimal_Conversion_Check( Decim, Unsigned_Over_8 ); + + function Identity( Launder: Decim ) return Decim is + Flat_Broke : constant Decim := 0.0; + begin + if Report.Ident_Bool( Launder = Flat_Broke ) then + return Flat_Broke; + else + return Launder; + end if; + end Identity; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("C460011", "Check that conversion to " & + "a modular type raises Constraint_Error when " & + "the operand value is outside the base range " & + "of the modular type" ); + + -- Decimal Error cases + + Decim_To_Short( Identity( -5.00 ), "M2S Dynamic, Negative" ); + Decim_To_Short( Shy_By_One * 1.0, "M2S Static, At_Mod" ); + Decim_To_Short( 1995.9, "M2S Static, Over_Mod" ); + + Decim_To_Eight( -0.5, "M28 Static, Negative" ); + Decim_To_Eight( 2.0*128, "M28 Static, At_Mod" ); + Decim_To_Eight( Identity( 2001.2 ), "M28 Dynamic, Over_Mod" ); + + Decim_To_Wide ( Decim'First, "M2W Static, Negative" ); + Decim_To_Wide ( Identity( 2*128.0 +2.0 ), "M2W Dynamic, At_Mod" ); + Decim_To_Wide ( Decim'Last, "M2W Static, Over_Mod" ); + + -- Check a few, correct, edge cases, for modular types. + + Eye_Dew: declare + Sense : Decim := 0.00; + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + begin + Moderate := Unsigned_8_Bit (Sense); + Assert( Moderate = 0, "Sense => Moderate, 0"); + + Sense := 2*128.0; + + Big := Unsigned_Over_8 (Sense); + Assert( Big = 256, "Sense => Big, 256"); + + end Eye_Dew; + + Rounding: declare + Easy : Decim := Identity ( 2.0); + Simple : Decim := Identity ( 2.1); + Halfway : Decim := Identity ( 2.5); + Upward : Decim := Identity ( 2.8); + Chop : Decim := Identity (-2.2); + Neg_Half : Decim := Identity (-2.5); + Downward : Decim := Identity (-2.7); + + Little : Unsigned_Edge_8; + Moderate : Unsigned_8_Bit; + Big : Unsigned_Over_8; + + Also_Little:Signed_8_Bit; + Also_Big : Signed_Over_8; + + begin + Little := Unsigned_Edge_8 (Easy); + Assert( Little = 2, "Easy => Little, 2"); + + Moderate := Unsigned_8_Bit (Simple); + Assert( Moderate = 2, "Simple => Moderate, 2"); + + Big := Unsigned_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert( Big = 3, "Halfway => Big, 3"); + + Little := Unsigned_Edge_8 (Upward); + Assert( Little = 3, "Upward => Little, 3"); + + Also_Big := Signed_Over_8 (Halfway); -- Rounds up by 4.6(33). + Assert( Also_Big = 3, "Halfway => Also_Big, 3"); + + Also_Little := Signed_8_Bit (Chop); + Assert( Also_Little = -2, "Chop => Also_Little, -2"); + + Also_Big := Signed_Over_8 (Neg_Half); -- Rounds down by 4.6(33). + Assert( Also_Big = -3, "Halfway => Also_Big, -3"); + + Also_Little := Signed_8_Bit (Downward); + Assert( Also_Little = -3, "Downward => Also_Little, -3"); + + end Rounding; + + + Report.Result; + + end C460011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460012.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C460012.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the view created by a view conversion is constrained if the + -- target subtype is indefinite. (Defect Report 8652/0017, Technical + -- Corrigendum 4.6(54/1)). + -- + -- CHANGE HISTORY: + -- 25 JAN 2001 PHL Initial version. + -- 29 JUN 2001 RLB Reformatted for ACATS. Added optimization blocking. + -- 02 JUL 2001 RLB Fixed discriminant reference. + -- + --! + with Ada.Exceptions; + use Ada.Exceptions; + with Report; + use Report; + procedure C460012 is + + subtype Index is Positive range 1 .. 10; + + type Definite_Parent (D1 : Index := 6) is + record + F : String (1 .. D1) := (others => 'a'); + end record; + + type Indefinite_Child (D2 : Index) is new Definite_Parent (D1 => D2); + + Y : Definite_Parent; + + procedure P (X : in out Indefinite_Child) is + C : Character renames X.F (3); + begin + X := (1, "a"); + if C /= 'a' then + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, value of C changed"); + elsif X.D2 /= 1 then + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, discriminant not " & + "changed"); + -- This check primarily exists to prevent X from being optimized by + -- 11.6 permissions, or the Failed call being made before the assignment. + else + Failed ("No exception raised when changing the " & + "discriminant of a view conversion, discriminant changed"); + end if; + exception + when Constraint_Error => + null; + when E: others => + Failed ("Wrong exception " & Exception_Name (E) & " raised - " & + Exception_Message (E)); + end P; + + begin + Test ("C460012", + "Check that the view created by a view conversion " & + "is constrained if the target subtype is indefinite"); + + P (Indefinite_Child (Y)); + + if Y.D1 /= Ident_Int(6) then + Failed ("Discriminant of indefinite view changed"); + -- This check exists mainly to prevent Y from being optimized away. + end if; + + Result; + end C460012; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46011a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C46011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE + -- TARGET AND OPERAND TYPES ARE BOTH INTEGER TYPES. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46011A IS + + TYPE INT1 IS RANGE -100 .. 100; + I1 : INT1 := INT1'VAL (IDENT_INT (10)); + F1 : INT1 := INT1'VAL (IDENT_INT (-100)); + L1 : INT1 := INT1'VAL (IDENT_INT (100)); + + TYPE INT2 IS RANGE -100 .. 100; + I2 : INT2 := INT2'VAL (IDENT_INT (10)); + F2 : INT2 := INT2'VAL (IDENT_INT (-100)); + L2 : INT2 := INT2'VAL (IDENT_INT (100)); + + + TYPE NEWINTEGER IS NEW INTEGER; + N1 : NEWINTEGER := + NEWINTEGER'VAL (IDENT_INT (10)); + + T1 : INTEGER := IDENT_INT (10); + + U1 : CONSTANT := INTEGER'POS (10); + BEGIN + TEST ( "C46011A", "CHECK THAT INTEGER CONVERSIONS ARE " & + "PERFORMED CORRECTLY WHEN THE TARGET AND " & + "OPERAND TYPES ARE BOTH INTEGER TYPES" ); + + IF INT1 (U1) /= U1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (U1)'" ); + END IF; + + IF INT1 (I1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (I1)'" ); + END IF; + + IF INT1 (N1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (N1)'" ); + END IF; + + IF INT1 (10) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (10)'" ); + END IF; + + IF INT1 (T1) /= I1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (T1)'" ); + END IF; + + IF INT1 (F2) /= F1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (F2)'" ); + END IF; + + IF INT1 (L2) /= L1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT1 (L2)'" ); + END IF; + + IF INT2 (I1) /= I2 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (I1)'" ); + END IF; + + IF INT2 (T1) /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (T1)'" ); + END IF; + + IF INT2 (F1) /= -100 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (F1)'" ); + END IF; + + IF INT2 (L1) /= 100 THEN + FAILED ( "INCORRECT CONVERSION OF 'INT2 (L1)'" ); + END IF; + + IF NEWINTEGER (I1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (I1)'" ); + END IF; + + IF NEWINTEGER (N1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (N1)'" ); + END IF; + + IF NEWINTEGER (T1) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF 'NEWINTEGER (T1)'" ); + END IF; + + IF NEWINTEGER (INTEGER (N1)) /= N1 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'NEWINTEGER (INTEGER (N1))'" ); + END IF; + + IF NEWINTEGER (INTEGER (N1 + 1)) /= 11 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'NEWINTEGER (INTEGER (N1 + 1))'" ); + END IF; + + IF INTEGER (10) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (10)'" ); + END IF; + + IF INTEGER (N1) /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (N1)'" ); + END IF; + + IF INTEGER (I1) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1)'" ); + END IF; + + IF INTEGER (INT1 (NEWINTEGER (INT1 (I1)))) /= T1 THEN + FAILED ( "INCORRECT CONVERSION OF " & + "'INTEGER (INT1 (NEWINTEGER (INT1 (I1)))'" ); + END IF; + + + IF INTEGER (I1 + 1) /= 11 THEN + FAILED ( "INCORRECT CONVERSION OF 'INTEGER (I1 + 1)'" ); + END IF; + + RESULT; + END C46011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46013a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46013a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46013a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46013a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,260 ---- + -- C46013A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER CONVERSIONS ARE PERFORMED CORRECTLY WHEN THE + -- OPERAND TYPE IS A FIXED POINT TYPE. + + -- HISTORY: + -- JET 02/09/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C46013A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + TYPE FIX4 IS NEW FIX1; + + F1 : FIX1 := 7.75; + F2 : FIX2 := -111.25; + F3 : FIX3 := 0.875; + F4 : FIX4 := -15.25; + + TYPE INT IS RANGE -512 .. 512; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + RETURN I * INT(IDENT_INT(1)); + END IDENT; + + BEGIN + TEST ("C46013A", "CHECK THAT INTEGER CONVERSIONS ARE PERFORMED " & + "CORRECTLY WHEN THE OPERAND TYPE IS A FIXED " & + "POINT TYPE"); + + IF INTEGER(FIX1'(-7.25)) /= IDENT_INT(-7) THEN + FAILED ("INCORRECT VALUE (1)"); + END IF; + + IF INTEGER(FIX1'(6.75)) /= IDENT_INT(7) THEN + FAILED ("INCORRECT VALUE (2)"); + END IF; + + IF INTEGER(F1) /= IDENT_INT(8) THEN + FAILED ("INCORRECT VALUE (3)"); + END IF; + + IF INT(FIX1'(-7.25)) /= IDENT(-7) THEN + FAILED ("INCORRECT VALUE (4)"); + END IF; + + IF INTEGER(FIX1'(3.33)) /= IDENT_INT(3) AND + INTEGER(FIX1'(3.33)) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE (5)"); + END IF; + + IF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX1 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX1 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX1'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX1'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX1'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX1'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX1 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX1 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX2'(-127.9375)) /= IDENT_INT(-128) THEN + FAILED ("INCORRECT VALUE (6)"); + END IF; + + IF INTEGER(FIX2'(127.0625)) /= IDENT_INT(127) THEN + FAILED ("INCORRECT VALUE (7)"); + END IF; + + IF INTEGER(F2) /= IDENT_INT(-111) THEN + FAILED ("INCORRECT VALUE (8)"); + END IF; + + IF INT(FIX2'(-0.25)) /= IDENT(0) THEN + FAILED ("INCORRECT VALUE (9)"); + END IF; + + IF INTEGER(FIX2'(66.67)) /= IDENT_INT(67) AND + INTEGER(FIX2'(66.67)) /= IDENT_INT(66) THEN + FAILED ("INCORRECT VALUE (10)"); + END IF; + + IF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX2 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX2 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX2'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX2'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX2'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX2'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX2 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX2 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX3'(-0.25)) /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE (11)"); + END IF; + + IF INTEGER(FIX3'(511.75)) /= IDENT_INT(512) THEN + FAILED ("INCORRECT VALUE (12)"); + END IF; + + IF INTEGER(F3) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE (13)"); + END IF; + + IF INT(FIX3'(-7.0)) /= IDENT(-7) THEN + FAILED ("INCORRECT VALUE (14)"); + END IF; + + IF INTEGER(FIX3'(-66.67)) /= IDENT_INT(-67) AND + INTEGER(FIX3'(-66.67)) /= IDENT_INT(-66) THEN + FAILED ("INCORRECT VALUE (15)"); + END IF; + + IF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX3 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX3 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX3'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX3'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX3'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX3'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX3 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX3 HALF VALUES ROUND ERRATICALLY"); + END IF; + + IF INTEGER(FIX4'(-7.25)) /= IDENT_INT(-7) THEN + FAILED ("INCORRECT VALUE (16)"); + END IF; + + IF INTEGER(FIX4'(6.75)) /= IDENT_INT(7) THEN + FAILED ("INCORRECT VALUE (17)"); + END IF; + + IF INTEGER(F4) /= IDENT_INT(-15) THEN + FAILED ("INCORRECT VALUE (18)"); + END IF; + + IF INT(FIX4'(-31.75)) /= IDENT(-32) THEN + FAILED ("INCORRECT VALUE (19)"); + END IF; + + IF INTEGER(FIX4'(3.33)) /= IDENT_INT(3) AND + INTEGER(FIX4'(3.33)) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE (20)"); + END IF; + + IF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX4 HALF VALUES ROUND UP"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND DOWN"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND TO EVEN"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-1) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(1) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(2) THEN + COMMENT ("FIX4 HALF VALUES ROUND TOWARD ZERO"); + ELSIF INTEGER(FIX4'(-2.5)) = IDENT_INT(-3) AND + INTEGER(FIX4'(-1.5)) = IDENT_INT(-2) AND + INTEGER(FIX4'(1.5)) = IDENT_INT(2) AND + INTEGER(FIX4'(2.5)) = IDENT_INT(3) THEN + COMMENT ("FIX4 HALF VALUES ROUND AWAY FROM ZERO"); + ELSE + COMMENT ("FIX4 HALF VALUES ROUND ERRATICALLY"); + END IF; + + RESULT; + + END C46013A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46014a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,287 ---- + -- C46014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR PREDEFINED TYPE INTEGER, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED IF THE OPERAND VALUE OF A + -- CONVERSION LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S BASE + -- TYPE. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE + -- OPERAND VALUE LIES OUTSIDE OF THE RANGE OF THE TARGET TYPE'S + -- SUBTYPE BUT WITHIN THE RANGE OF THE BASE TYPE. + + -- HISTORY: + -- RJW 09/08/86 CREATED ORIGINAL TEST. + -- RJW 11/13/87 ADDED CODE TO PREVENT DEAD VARIABLE OPTIMIZATION. + -- JET 12/30/87 ADDED MORE CODE TO PREVENT OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + -- JRL 12/08/96 Changed usages of System.Max_Int and System.Min_Int to + -- Integer'Base'Last and Integer'Base'First in first two + -- subtests. + + WITH REPORT; USE REPORT; + PROCEDURE C46014A IS + + SUBTYPE SMALL IS INTEGER RANGE -100 .. 100; + S1 : SMALL; + + TYPE INT IS RANGE -100 .. 100; + T1 : INT; + + TYPE NEWINTEGER IS NEW INTEGER; + N1 : NEWINTEGER; + + SUBTYPE SUBNEW IS NEWINTEGER RANGE -100 .. 100; + SN : SUBNEW; + + I1 : INTEGER; + P1 : POSITIVE; + L1 : NATURAL; + + FUNCTION IDENT (I : INTEGER) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (I)); + END IDENT; + + FUNCTION IDENT (I : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (I))); + END IDENT; + + BEGIN + TEST ( "C46014A", "FOR PREDEFINED TYPE INTEGER, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF " & + "THE OPERAND VALUE OF A CONVERSION LIES " & + "OUTSIDE OF THE RANGE OF THE TARGET TYPE'S " & + "BASE TYPE. ALSO, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF THE OPERAND " & + "VALUE LIES OUTSIDE OF THE RANGE OF THE " & + "TARGET TYPE'S SUBTYPE BUT WITHIN THE " & + "RANGE OF THE BASE TYPE" ); + + BEGIN + I1 := Integer'Base'Last + Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'LAST + 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'LAST + 1"); + END; + + BEGIN + I1 := Integer'Base'First - Ident_Int(1); + Failed ("NO EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + Comment ("CONSTRAINT_ERROR RAISED FOR INTEGER'BASE'FIRST - 1"); + WHEN OTHERS => + Failed ("WRONG EXCEPTION RAISED FOR INTEGER'BASE'FIRST - 1"); + END; + + BEGIN + I1 := INTEGER (IDENT_INT (INTEGER'FIRST) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST) - 1)" ); + IF EQUAL (I1, I1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INTEGER (IDENT_INT (INTEGER'FIRST - 1)" ); + END; + + BEGIN + N1 := NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST) + 1)" ); + IF EQUAL (INTEGER (N1), INTEGER (N1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NEWINTEGER (IDENT_INT (INTEGER'LAST + 1)" ); + END; + + BEGIN + T1 := INT (INT'BASE'FIRST - IDENT (1)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ( "CONSTRAINT_ERROR RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'BASE'FIRST - IDENT (1))" ); + END; + + BEGIN + T1 := IDENT (-101); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := -101" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := -101" ); + END; + + BEGIN + T1 := INTEGER'POS (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101))" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "T1 := INTEGER'POS (IDENT_INT (101));" ); + END; + + BEGIN + T1 := INT (IDENT (INTEGER (INT'FIRST)) - 1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "INT (INT'FIRST - 1)" ); + END; + + BEGIN + T1 := INT (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR INT (101)" ); + IF EQUAL (INTEGER (T1), INTEGER (T1)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INT (101)" ); + END; + + BEGIN + S1 := SMALL (IDENT_INT (101)); + FAILED ( "NO EXCEPTION RAISED FOR SMALL (101)" ); + IF EQUAL (S1, S1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SMALL (101)" ); + END; + + BEGIN + SN := SUBNEW (IDENT_INT (-101)); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (-101)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (-101)" ); + END; + + BEGIN + P1 := IDENT_INT (101); + SN := SUBNEW (P1); + FAILED ( "NO EXCEPTION RAISED FOR SUBNEW (P1)" ); + IF EQUAL (INTEGER (SN), INTEGER (SN)) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR SUBNEW (P1)" ); + END; + + BEGIN + SN := IDENT (0); + P1 := POSITIVE (SN); + FAILED ( "NO EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + IF EQUAL (P1, P1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "POSITIVE (SN)" ); + END; + + BEGIN + N1 := IDENT (-1); + L1 := NATURAL (N1); + FAILED ( "NO EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + IF EQUAL (L1, L1) THEN + COMMENT ("SHOULDN'T GET HERE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + "NATURAL (N1)" ); + END; + + RESULT; + END C46014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46021a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46021a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46021a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46021a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,210 ---- + -- C46021A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOATING POINT CONVERSIONS ARE PERFORMED CORRECTLY + -- WHEN THE OPERAND TYPE IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION. + + -- HISTORY: + -- JET 02/12/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C46021A IS + + TYPE FLOAT5 IS DIGITS 5; + TYPE INT IS RANGE -32768..32767; + + TYPE NFLOAT5 IS NEW FLOAT5; + + FUNCTION IDENT (A : FLOAT5) RETURN FLOAT5 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN A; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + FUNCTION IDENT (A : NFLOAT5) RETURN NFLOAT5 IS + BEGIN + IF EQUAL(3,3) THEN + RETURN A; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + TEST ("C46021A", "CHECK THAT FLOATING POINT CONVERSIONS ARE " & + "PERFORMED CORRECTLY WHEN THE OPERAND TYPE " & + "IS AN INTEGER TYPE, FOR 5-DIGIT PRECISION"); + + IF FLOAT5(IDENT_INT(-7)) /= -7.0 THEN + FAILED ("INCORRECT VALUE (1)"); + END IF; + + IF FLOAT5(IDENT_INT(3)) /= 3.0 THEN + FAILED ("INCORRECT VALUE (2)"); + END IF; + + IF FLOAT5(IDENT_INT(-999)) /= -999.0 THEN + FAILED ("INCORRECT VALUE (3)"); + END IF; + + IF FLOAT5(IDENT_INT(101)) /= 101.0 THEN + FAILED ("INCORRECT VALUE (4)"); + END IF; + + IF FLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN + FAILED ("INCORRECT VALUE (5)"); + END IF; + + IF FLOAT5(IDENT_INT(32767)) /= 32767.0 THEN + FAILED ("INCORRECT VALUE (6)"); + END IF; + + IF FLOAT5(-7) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (7)"); + END IF; + + IF FLOAT5(3) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (8)"); + END IF; + + IF FLOAT5(-999) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (9)"); + END IF; + + IF FLOAT5(101) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (10)"); + END IF; + + IF FLOAT5(-32767) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (11)"); + END IF; + + IF FLOAT5(32767) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (12)"); + END IF; + + IF FLOAT5(INT'(-7)) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (13)"); + END IF; + + IF FLOAT5(INT'(3)) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (14)"); + END IF; + + IF FLOAT5(INT'(-999)) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (15)"); + END IF; + + IF FLOAT5(INT'(101)) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (16)"); + END IF; + + IF FLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (17)"); + END IF; + + IF FLOAT5(INT'(32767)) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (18)"); + END IF; + + IF NFLOAT5(IDENT_INT(-7)) /= -7.0 THEN + FAILED ("INCORRECT VALUE (19)"); + END IF; + + IF NFLOAT5(IDENT_INT(3)) /= 3.0 THEN + FAILED ("INCORRECT VALUE (20)"); + END IF; + + IF NFLOAT5(IDENT_INT(-999)) /= -999.0 THEN + FAILED ("INCORRECT VALUE (21)"); + END IF; + + IF NFLOAT5(IDENT_INT(101)) /= 101.0 THEN + FAILED ("INCORRECT VALUE (22)"); + END IF; + + IF NFLOAT5(IDENT_INT(-32767)) /= -32767.0 THEN + FAILED ("INCORRECT VALUE (23)"); + END IF; + + IF NFLOAT5(IDENT_INT(32767)) /= 32767.0 THEN + FAILED ("INCORRECT VALUE (24)"); + END IF; + + IF NFLOAT5(-7) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (25)"); + END IF; + + IF NFLOAT5(3) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (26)"); + END IF; + + IF NFLOAT5(-999) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (27)"); + END IF; + + IF NFLOAT5(101) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (28)"); + END IF; + + IF NFLOAT5(-32767) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (29)"); + END IF; + + IF NFLOAT5(32767) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (30)"); + END IF; + + IF NFLOAT5(INT'(-7)) /= IDENT(-7.0) THEN + FAILED ("INCORRECT VALUE (31)"); + END IF; + + IF NFLOAT5(INT'(3)) /= IDENT(3.0) THEN + FAILED ("INCORRECT VALUE (32)"); + END IF; + + IF NFLOAT5(INT'(-999)) /= IDENT(-999.0) THEN + FAILED ("INCORRECT VALUE (33)"); + END IF; + + IF NFLOAT5(INT'(101)) /= IDENT(101.0) THEN + FAILED ("INCORRECT VALUE (34)"); + END IF; + + IF NFLOAT5(INT'(-32767)) /= IDENT(-32767.0) THEN + FAILED ("INCORRECT VALUE (35)"); + END IF; + + IF NFLOAT5(INT'(32767)) /= IDENT(32767.0) THEN + FAILED ("INCORRECT VALUE (36)"); + END IF; + + RESULT; + + END C46021A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46024a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46024a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46024a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46024a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C46024A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK FLOATING POINT CONVERSIONS WHEN THE TARGET TYPE IS A + -- FIXED POINT TYPE, FOR DIGITS 5. + + -- HISTORY: + -- JET 02/19/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C46024A IS + + TYPE FLOAT5 IS DIGITS 5; + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + F5, F5A, F5B : FLOAT5; + + GENERIC + TYPE F IS DELTA <>; + FUNCTION IDENTG (A : F) RETURN F; + + FUNCTION IDENTG (A : F) RETURN F IS + BEGIN + RETURN A + F(IDENT_INT(0)); + END IDENTG; + + FUNCTION IDENT1 IS NEW IDENTG(FIX1); + FUNCTION IDENT2 IS NEW IDENTG(FIX2); + FUNCTION IDENT3 IS NEW IDENTG(FIX3); + + BEGIN + TEST ("C46024A", "CHECK FLOATING POINT CONVERSIONS WHEN THE " & + "TARGET TYPE IS A FIXED POINT TYPE, FOR " & + "5-DIGIT PRECISION"); + + IF FIX1(FLOAT5'(2#0.1000_0000_0000_0000_00#E-1)) /= + IDENT1(2#0.01#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + IF FIX1(FLOAT5'(-2#0.1111_1110_0000_0000_00#E5)) /= + IDENT1(-2#1_1111.11#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + IF FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) < + IDENT1(-2#1010.10#) OR + FIX1(FLOAT5'(-2#0.1010_0111_1111_1111_11#E4)) > + IDENT1(-2#1010.01#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + IF FIX2(FLOAT5'(-2#0.1000_0000_0000_0000_00#E-3)) /= + IDENT2(-2#0.0001#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + IF FIX2(FLOAT5'(2#0.1111_1111_1110_0000_00#E7)) /= + IDENT2(2#111_1111.1111#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F5 := 2#0.1010_1010_1010_1010_10#E5; + IF FIX2(F5) < IDENT2(2#1_0101.0101#) OR + FIX2(F5) > IDENT2(2#1_0101.0110#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + IF FIX3(FLOAT5'(2#0.1000_0000_0000_0000_00#E-5)) /= + IDENT3(2#0.000001#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + IF FIX3(FLOAT5'(-2#0.1111_1111_1111_1110_00#E9)) /= + IDENT3(-2#1_1111_1111.1111_11#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F5 := -2#0.1010_1010_1010_1010_10#E8; + IF FIX3(F5) < IDENT3(-2#1010_1010.1010_11#) OR + FIX3(F5) > IDENT3(-2#1010_1010.1010_10#) THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + F5A := 2#0.1010_1010_1010_1010_10#E4; + F5B := 2#0.1010_1010_1010_1010_10#E5; + + IF FIX1(F5A) = IDENT1(2#1010.11#) AND + FIX1(-F5A) = IDENT1(-2#1010.11#) AND + FIX1(F5B) = IDENT1(2#1_0101.01#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.01#) THEN + COMMENT ("CONVERSION ROUNDS TO NEAREST"); + ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN + COMMENT ("CONVERSION ROUNDS TO LEAST FIXED-POINT VALUE"); + ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND + FIX1(-F5A) = IDENT1(-2#1010.10#) THEN + COMMENT ("CONVERSION ROUNDS TO GREATEST FIXED-POINT VALUE"); + ELSIF FIX1(F5A) = IDENT1(2#1010.10#) AND + FIX1(-F5A) = IDENT1(-2#1010.10#) THEN + COMMENT ("CONVERSION ROUNDS TOWARD ZERO"); + ELSIF FIX1(F5B) = IDENT1(2#1_0101.10#) AND + FIX1(-F5B) = IDENT1(-2#1_0101.10#) THEN + COMMENT ("CONVERSION ROUNDS AWAY FROM ZERO"); + ELSE + COMMENT ("UNABLE TO DETERMINE CONVERSION PATTERN"); + END IF; + + RESULT; + + END C46024A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46031a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46031a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46031a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46031a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C46031A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE + -- IS AN INTEGER TYPE. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C46031A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + TYPE NEW_INT IS NEW INTEGER RANGE -16#200# .. 16#200#; + + I : INTEGER; + J : NEW_INT; + + FUNCTION IDENT_NEW (X : NEW_INT) RETURN NEW_INT IS + BEGIN + RETURN X * NEW_INT(IDENT_INT(1)); + END IDENT_NEW; + + BEGIN + TEST ("C46031A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS AN INTEGER TYPE"); + + I := IDENT_INT(-16#1F#); + IF FIX1(I) /= -16#1F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + J := IDENT_NEW(0); + IF FIX1(J) /= 0.0 THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + I := IDENT_INT(16#7F#); + IF FIX2(I) /= 16#7F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + J := IDENT_NEW(16#1#); + IF FIX2(J) /= 16#1.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + I := IDENT_INT(-16#55#); + IF FIX3(I) /= -16#55.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + J := IDENT_NEW(-16#1#); + IF FIX3(J) /= -16#1.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + RESULT; + + END C46031A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46032a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46032a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46032a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46032a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C46032A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE + -- IS A FLOATING POINT TYPE OF 5 DIGITS PRECISION. + + -- HISTORY: + -- JET 07/11/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C46032A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + TYPE FLOAT5 IS DIGITS 5; + + F5 : FLOAT5; + + FUNCTION IDENT5 (X : FLOAT5) RETURN FLOAT5 IS + BEGIN + RETURN X * FLOAT5(IDENT_INT(1)); + END IDENT5; + + BEGIN + TEST ("C46032A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS A FLOATING POINT TYPE " & + "OF 5 DIGITS PRECISION"); + + F5 := IDENT5(2#0.1100_0000_0000_0000_00#E0); + IF FIX1(F5) /= 16#0.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + F5 := IDENT5(2#0.1111_1110_0000_0000_00#E5); + IF FIX1(F5) /= 16#1F.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + F5 := IDENT5(-2#0.1010_1010_1010_1010_10#E2); + IF FIX1(F5) < -16#2.C# OR + FIX1(F5) > -16#2.8# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + F5 := IDENT5(2#0.1111_0000_0000_0000_00#E0); + IF FIX2(F5) /= 16#0.F# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + F5 := IDENT5(-2#0.1111_1110_0000_0000_00#E7); + IF FIX2(F5) /= -16#7F.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F5 := IDENT5(2#0.1111_1111_1101_0000_00#E7); + IF FIX2(F5) < 16#7F.E# OR + FIX2(F5) > 16#7F.F# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + F5 := IDENT5(2#0.1000_0000_0000_0000_00#E-5); + IF FIX3(F5) /= 16#0.04# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + F5 := -IDENT5(2#0.1010_1010_1010_1010_00#E9); + IF FIX3(F5) /= -16#155.54# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F5 := IDENT5(2#0.1000_0000_0000_0010_11#E9); + IF FIX3(F5) < 16#100.04# OR + FIX3(F5) > 16#100.08# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + RESULT; + + END C46032A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46033a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46033a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46033a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46033a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C46033A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK CONVERSIONS TO FIXED POINT TYPES WHEN THE OPERAND TYPE + -- IS ANOTHER FIXED POINT TYPE. + + -- HISTORY: + -- JET 07/12/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C46033A IS + + TYPE FIX1 IS DELTA 2#0.01# RANGE -16#20.0# .. 16#20.0#; + TYPE FIX2 IS DELTA 2#0.0001# RANGE -16#80.0# .. 16#80.0#; + TYPE FIX3 IS DELTA 2#0.000001# RANGE -16#200.0# .. 16#200.0#; + + F1 : FIX1; + F2 : FIX2; + F3 : FIX3; + + GENERIC + TYPE F IS DELTA <>; + FUNCTION IDENT_G (X : F) RETURN F; + + FUNCTION IDENT_G (X : F) RETURN F IS + BEGIN + RETURN X + F(IDENT_INT(0)); + END IDENT_G; + + FUNCTION IDENT IS NEW IDENT_G(FIX1); + FUNCTION IDENT IS NEW IDENT_G(FIX2); + FUNCTION IDENT IS NEW IDENT_G(FIX3); + + BEGIN + TEST ("C46033A", "CHECK CONVERSIONS TO FIXED POINT TYPES WHEN " & + "THE OPERAND TYPE IS ANOTHER FIXED POINT TYPE"); + + F1 := IDENT(-16#1F.C#); + IF FIX1(F1) /= -16#1F.C# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (1)"); + END IF; + + F1 := IDENT(16#0.4#); + IF FIX2(F1) /= 16#0.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (2)"); + END IF; + + F1 := IDENT(-16#10.4#); + IF FIX3(F1) /= -16#10.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (3)"); + END IF; + + F2 := IDENT(16#3.3#); + IF FIX1(F2) < 16#3.0# OR + FIX1(F2) > 16#3.4# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (4)"); + END IF; + + F2 := IDENT(-16#40.1#); + IF FIX2(F2) /= -16#40.1# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (5)"); + END IF; + + F2 := IDENT(16#0.0#); + IF FIX3(F2) /= 16#0.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (6)"); + END IF; + + F3 := IDENT(-16#0.04#); + IF FIX1(F3) < -16#0.4# OR + FIX1(F3) > -16#0.0# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (7)"); + END IF; + + F3 := -IDENT(16#55.A8#); + IF FIX2(F3) < -16#55.B# OR + FIX2(F3) > -16#55.A# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (8)"); + END IF; + + F3 := IDENT(16#101.84#); + IF FIX3(F3) /= 16#101.84# THEN + FAILED ("INCORRECT RESULT FROM CONVERSION (9)"); + END IF; + + RESULT; + + END C46033A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46041a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46041a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46041a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46041a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- C46041A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK ARRAY CONVERSIONS WHEN THE TARGET TYPE IS AN UNCONSTRAINED + -- ARRAY TYPE AND THE OPERAND TYPE REQUIRES CONVERSION OF THE INDEX + -- BOUNDS. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46041A IS + + TYPE INT IS RANGE -100 .. 100; + TYPE NEWINTEGER IS NEW INTEGER; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + TYPE NDAY1 IS NEW DAY RANGE SUN .. FRI; + TYPE NDAY2 IS NEW DAY RANGE MON .. SAT; + + TYPE NNDAY1 IS NEW NDAY1; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (INT'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS + BEGIN + RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS + BEGIN + RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS + BEGIN + RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X))); + END IDENT; + + BEGIN + TEST ( "C46041A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " & + "TYPE IS AN UNCONSTRAINED ARRAY TYPE AND " & + "THE OPERAND TYPE REQUIRES CONVERSION OF " & + "THE INDEX BOUNDS" ); + + DECLARE + + TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>) + OF INTEGER; + + TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT (11) .. IDENT (20)) := + (IDENT (11) .. IDENT (20) => 0); + + TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>) + OF INTEGER; + A2 : ARR2 (IDENT (11) .. IDENT (20), + IDENT (TUE) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (TUE) .. IDENT (THU) => 0)); + + TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>) + OF INTEGER; + A3 : ARR3 (IDENT (11) .. IDENT (20), + IDENT (TUE) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (TUE) .. IDENT (THU) => 0)); + + PROCEDURE CHECK (A : UNARR1) IS + BEGIN + IF A'FIRST /= 11 OR A'LAST /= 20 THEN + FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" ); + END IF; + END CHECK; + + PROCEDURE CHECK (A : UNARR2; STR : STRING) IS + BEGIN + IF A'FIRST (1) /= 11 OR A'LAST /= 20 OR + A'FIRST (2) /= TUE OR A'LAST (2) /= THU THEN + FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" & + STR & ")" ); + END IF; + END CHECK; + + BEGIN + BEGIN + CHECK (UNARR1 (A1)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR1 (A1)'" ); + END; + + BEGIN + CHECK (UNARR2 (A2), "2"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A2)'" ); + END; + + BEGIN + CHECK (UNARR2 (A3), "3"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'UNARR2 (A3)'" ); + END; + + END; + + RESULT; + END C46041A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46042a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46042a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46042a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46042a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C46042A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK ARRAY CONVERSIONS WHEN THE TARGET TYPE IS A CONSTRAINED + -- ARRAY TYPE AND THE OPERAND TYPE HAS BOUNDS THAT DO NOT BELONG TO + -- THE BASE TYPE OF THE TARGET TYPE'S INDEX SUBTYPE. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46042A IS + + TYPE INT IS RANGE -100 .. 100; + + TYPE NEWINTEGER IS NEW INTEGER; + + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + + TYPE NDAY1 IS NEW DAY RANGE MON .. FRI; + TYPE NDAY2 IS NEW DAY RANGE MON .. FRI; + + TYPE NNDAY1 IS NEW NDAY1; + + FUNCTION IDENT (X : INT) RETURN INT IS + BEGIN + RETURN INT'VAL (IDENT_INT (INT'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NEWINTEGER) RETURN NEWINTEGER IS + BEGIN + RETURN NEWINTEGER'VAL (IDENT_INT (NEWINTEGER'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY1) RETURN NDAY1 IS + BEGIN + RETURN NDAY1'VAL (IDENT_INT (NDAY1'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NDAY2) RETURN NDAY2 IS + BEGIN + RETURN NDAY2'VAL (IDENT_INT (NDAY2'POS (X))); + END IDENT; + + FUNCTION IDENT (X : NNDAY1) RETURN NNDAY1 IS + BEGIN + RETURN NNDAY1'VAL (IDENT_INT (NNDAY1'POS (X))); + END IDENT; + + BEGIN + TEST ( "C46042A", "CHECK ARRAY CONVERSIONS WHEN THE TARGET " & + "TYPE IS A CONSTRAINED ARRAY TYPE AND THE " & + "OPERAND TYPE HAS BOUNDS THAT DO NOT " & + "BELONG TO THE BASE TYPE OF THE TARGET " & + "TYPE'S INDEX SUBTYPE" ); + + DECLARE + + TYPE UNARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE CONARR1 IS UNARR1 (IDENT_INT (1) .. IDENT_INT (10)); + + TYPE UNARR2 IS ARRAY (INTEGER RANGE <>, NDAY1 RANGE <>) + OF INTEGER; + SUBTYPE CONARR2 IS UNARR2 (IDENT_INT (1) .. IDENT_INT (10), + IDENT (MON) .. IDENT (TUE)); + + TYPE ARR1 IS ARRAY (INT RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT (11) .. IDENT (20)) := + (IDENT (11) .. IDENT (20) => 0); + + TYPE ARR2 IS ARRAY (INT RANGE <>, NDAY2 RANGE <>) + OF INTEGER; + A2 : ARR2 (IDENT (11) .. IDENT (20), + IDENT (WED) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (WED) .. IDENT (THU) => 0)); + + TYPE ARR3 IS ARRAY (NEWINTEGER RANGE <>, NNDAY1 RANGE <>) + OF INTEGER; + A3 : ARR3 (IDENT (11) .. IDENT (20), + IDENT (WED) .. IDENT (THU)) := + (IDENT (11) .. IDENT (20) => + (IDENT (WED) .. IDENT (THU) => 0)); + + PROCEDURE CHECK (A : UNARR1) IS + BEGIN + IF A'FIRST /= 1 OR A'LAST /= 10 THEN + FAILED ( "INCORRECT CONVERSION OF UNARR1 (A1)" ); + END IF; + END CHECK; + + PROCEDURE CHECK (A : UNARR2; STR : STRING) IS + BEGIN + IF A'FIRST (1) /= 1 OR A'LAST /= 10 OR + A'FIRST (2) /= MON OR A'LAST (2) /= TUE THEN + FAILED ( "INCORRECT CONVERSION OF UNARR2 (A" & + STR & ")" ); + END IF; + END CHECK; + + BEGIN + BEGIN + CHECK (CONARR1 (A1)); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR1 (A1)'" ); + END; + + BEGIN + CHECK (CONARR2 (A2), "2"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A2)'" ); + END; + + BEGIN + CHECK (CONARR2 (A3), "3"); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED BY 'CONARR2 (A3)'" ); + END; + + END; + + RESULT; + END C46042A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46043b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46043b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46043b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46043b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- C46043B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN + -- UNCONSTRAINED ARRAY TYPE IF, FOR A NON-NULL DIMENSION OF THE + -- OPERAND TYPE, ONE BOUND DOES NOT BELONG TO THE CORRESPONDING INDEX + -- SUBTYPE OF THE TARGET TYPE. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46043B IS + + SUBTYPE SUBINT IS INTEGER RANGE IDENT_INT (0) .. IDENT_INT (9); + + BEGIN + TEST ( "C46043B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN UNCONSTRAINED ARRAY TYPE " & + "IF, FOR A NON-NULL DIMENSION OF THE OPERAND " & + "TYPE, ONE BOUND DOES NOT BELONG TO THE " & + "CORRESPONDING INDEX SUBTYPE OF THE TARGET " & + "TYPE" ); + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>) OF INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH ONE DIMENSIONAL " & + "ARRAYS" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE => 0); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH ONE " & + "DIMENSIONAL ARRAYS" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (1)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH TWO DIMENSIONAL " & + "ARRAYS" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH TWO " & + "DIMENSIONAL ARRAYS" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (0)); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 1" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH NULL ARRAYS - 1" ); + END; + + DECLARE + TYPE ARR1 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + A1 : ARR1 (IDENT_INT (1) .. IDENT_INT (10), + IDENT_INT (1) .. IDENT_INT (0)); + + SUBTYPE NOINT IS INTEGER + RANGE IDENT_INT (1) .. IDENT_INT (0); + + TYPE ARR2 IS ARRAY (SUBINT RANGE <>, NOINT RANGE <>) OF + INTEGER; + + PROCEDURE CHECK (A : ARR2) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED WITH NULL ARRAYS - 2" ); + END CHECK; + + BEGIN + A1 := (A1'RANGE (1) => (A1'RANGE (2) => 0)); + CHECK (ARR2 (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED " & + "WITH NULL ARRAYS - 2" ); + END; + + RESULT; + END C46043B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46044b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46044b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46044b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46044b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,235 ---- + -- C46044B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT ERROR IS RAISED FOR CONVERSION TO A + -- CONSTRAINED ARRAY TYPE IF THE TARGET TYPE IS NON-NULL AND + -- CORRESPONDING DIMENSIONS OF THE TARGET AND OPERAND DO NOT HAVE + -- THE SAME LENGTH. ALSO, CHECK THAT CONSTRAINT_ERROR IS RAISED IF + -- THE TARGET TYPE IS NULL AND THE OPERAND TYPE IS NON-NULL. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46044B IS + + TYPE ARR1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + SUBTYPE CARR1A IS ARR1 (IDENT_INT (1) .. IDENT_INT (6)); + C1A : CARR1A := (CARR1A'RANGE => 0); + + SUBTYPE CARR1B IS ARR1 (IDENT_INT (2) .. IDENT_INT (5)); + C1B : CARR1B := (CARR1B'RANGE => 0); + + SUBTYPE CARR1N IS ARR1 (IDENT_INT (1) .. IDENT_INT (0)); + C1N : CARR1N := (CARR1N'RANGE => 0); + + TYPE ARR2 IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + SUBTYPE CARR2A IS ARR2 (IDENT_INT (1) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (2)); + C2A : CARR2A := (CARR2A'RANGE (1) => (CARR2A'RANGE (2) => 0)); + + SUBTYPE CARR2B IS ARR2 (IDENT_INT (0) .. IDENT_INT (2), + IDENT_INT (0) .. IDENT_INT (2)); + C2B : CARR2B := (CARR2B'RANGE (1) => (CARR2B'RANGE (2) => 0)); + + SUBTYPE CARR2N IS ARR2 (IDENT_INT (2) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (2)); + C2N : CARR2N := (CARR2N'RANGE (1) => (CARR2N'RANGE (2) => 0)); + + PROCEDURE CHECK1 (A : ARR1; STR : STRING) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED - " & STR ); + END CHECK1; + + PROCEDURE CHECK2 (A : ARR2; STR : STRING) IS + BEGIN + FAILED ( "NO EXCEPTION RAISED - " & STR ); + END CHECK2; + + BEGIN + TEST ( "C46044B", "CHECK THAT CONSTRAINT ERROR IS RAISED FOR " & + "CONVERSION TO A CONSTRAINED ARRAY TYPE " & + "IF THE TARGET TYPE IS NON-NULL AND " & + "CORRESPONDING DIMENSIONS OF THE TARGET AND " & + "OPERAND DO NOT HAVE THE SAME LENGTH. " & + "ALSO, CHECK THAT CONSTRAINT_ERROR IS " & + "RAISED IF THE TARGET TYPE IS NULL AND " & + "THE OPERAND TYPE IS NON-NULL" ); + + BEGIN -- (A). + C1A := C1B; + CHECK1 (C1A, "(A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (A)" ); + END; + + BEGIN -- (B). + CHECK1 (CARR1A (C1B), "(B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (B)" ); + END; + + BEGIN -- (C). + C1B := C1A; + CHECK1 (C1B, "(C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (C)" ); + END; + + BEGIN -- (D). + CHECK1 (CARR1B (C1A), "(D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (D)" ); + END; + + BEGIN -- (E). + C1A := C1N; + CHECK1 (C1A, "(E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (E)" ); + END; + + BEGIN -- (F). + CHECK1 (CARR1A (C1N), "(F)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (F)" ); + END; + + BEGIN -- (G). + C2A := C2B; + CHECK2 (C2A, "(G)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (G)" ); + END; + + BEGIN -- (H). + CHECK2 (CARR2A (C2B), "(H)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (H)" ); + END; + + BEGIN -- (I). + C2B := C2A; + CHECK2 (C2B, "(I)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (I)" ); + END; + + BEGIN -- (J). + CHECK2 (CARR2A (C2B), "(J)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (J)" ); + END; + + BEGIN -- (K). + C2A := C2N; + CHECK2 (C2A, "(K)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (K)" ); + END; + + BEGIN -- (L). + CHECK2 (CARR2A (C2N), "(L)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (L)" ); + END; + + BEGIN -- (M). + C1N := C1A; + CHECK1 (C1N, "(M)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (M)" ); + END; + + BEGIN -- (N). + CHECK1 (CARR1N (C1A), "(N)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (N)" ); + END; + + BEGIN -- (O). + C2N := C2A; + CHECK2 (C2N, "(O)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (O)" ); + END; + + BEGIN -- (P). + CHECK2 (CARR2N (C2A), "(P)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED - (P)" ); + END; + + RESULT; + END C46044B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,414 ---- + -- C46051A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ENUMERATION, RECORD, ACCESS, PRIVATE, AND TASK VALUES CAN + -- BE CONVERTED IF THE OPERAND AND TARGET TYPES ARE RELATED BY + -- DERIVATION. + + -- R.WILLIAMS 9/8/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46051A IS + + BEGIN + TEST ( "C46051A", "CHECK THAT ENUMERATION, RECORD, ACCESS, " & + "PRIVATE, AND TASK VALUES CAN BE CONVERTED " & + "IF THE OPERAND AND TARGET TYPES ARE " & + "RELATED BY DERIVATION" ); + + DECLARE + TYPE ENUM IS (A, AB, ABC, ABCD); + E : ENUM := ABC; + + TYPE ENUM1 IS NEW ENUM; + E1 : ENUM1 := ENUM1'VAL (IDENT_INT (2)); + + TYPE ENUM2 IS NEW ENUM; + E2 : ENUM2 := ABC; + + TYPE NENUM1 IS NEW ENUM1; + NE : NENUM1 := NENUM1'VAL (IDENT_INT (2)); + BEGIN + IF ENUM (E) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" ); + END IF; + + IF ENUM (E1) /= E THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" ); + END IF; + + IF ENUM1 (E2) /= E1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" ); + END IF; + + IF ENUM2 (NE) /= E2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (NE)'" ); + END IF; + + IF NENUM1 (E) /= NE THEN + FAILED ( "INCORRECT CONVERSION OF 'NENUM (E)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ENUMERATION TYPES" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + R : REC; + + TYPE REC1 IS NEW REC; + R1 : REC1; + + TYPE REC2 IS NEW REC; + R2 : REC2; + + TYPE NREC1 IS NEW REC1; + NR : NREC1; + BEGIN + IF REC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" ); + END IF; + + IF REC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" ); + END IF; + + IF REC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" ); + END IF; + + IF REC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (NR)'" ); + END IF; + + IF NREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE CREC IS REC (3); + R : CREC; + + TYPE CREC1 IS NEW REC (3); + R1 : CREC1; + + TYPE CREC2 IS NEW REC (3); + R2 : CREC2; + + TYPE NCREC1 IS NEW CREC1; + NR : NCREC1; + BEGIN + IF CREC (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R)'" ); + END IF; + + IF CREC (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC (R1)'" ); + END IF; + + IF CREC1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC1 (R2)'" ); + END IF; + + IF CREC2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CREC2 (NR)'" ); + END IF; + + IF NCREC1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NCREC (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES WITH DISCRIMINANTS" ); + END; + + DECLARE + TYPE REC IS + RECORD + NULL; + END RECORD; + + TYPE ACCREC IS ACCESS REC; + AR : ACCREC; + + TYPE ACCREC1 IS NEW ACCREC; + AR1 : ACCREC1; + + TYPE ACCREC2 IS NEW ACCREC; + AR2 : ACCREC2; + + TYPE NACCREC1 IS NEW ACCREC1; + NAR : NACCREC1; + + FUNCTION F (A : ACCREC) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : ACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : ACCREC2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NACCREC1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (ACCREC (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR)'" ); + END IF; + + IF F (ACCREC (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC (AR1)'" ); + END IF; + + IF F (ACCREC1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC1 (AR2)'" ); + END IF; + + IF F (ACCREC2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'ACCREC2 (NAR)'" ); + END IF; + + IF F (NACCREC1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NACCREC (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ACCESS TYPES" ); + END; + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + SUBTYPE CACCR IS ACCR (3); + AR : CACCR; + + TYPE CACCR1 IS NEW ACCR (3); + AR1 : CACCR1; + + TYPE CACCR2 IS NEW ACCR (3); + AR2 : CACCR2; + + TYPE NCACCR1 IS NEW CACCR1; + NAR : NCACCR1; + + FUNCTION F (A : CACCR) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (A : CACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (A : CACCR2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (A : NCACCR1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (CACCR (AR)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR)'" ); + END IF; + + IF F (CACCR (AR1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR (AR1)'" ); + END IF; + + IF F (CACCR1 (AR2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR1 (AR2)'" ); + END IF; + + IF F (CACCR2 (NAR)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'CACCR2 (NAR)'" ); + END IF; + + IF F (NCACCR1 (AR)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NCACCR (AR)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "CONSTRAINED ACCESS TYPES" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + R : PRIV; + + TYPE PRIV1 IS NEW PRIV; + R1 : PRIV1; + + TYPE PRIV2 IS NEW PRIV; + R2 : PRIV2; + END PKG2; + + USE PKG2; + + PACKAGE PKG3 IS + TYPE NPRIV1 IS NEW PRIV1; + NR : NPRIV1; + END PKG3; + + USE PKG3; + BEGIN + IF PRIV (R) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R)'" ); + END IF; + + IF PRIV (R1) /= R THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV (R1)'" ); + END IF; + + IF PRIV1 (R2) /= R1 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV1 (R2)'" ); + END IF; + + IF PRIV2 (NR) /= R2 THEN + FAILED ( "INCORRECT CONVERSION OF 'PRIV2 (NR)'" ); + END IF; + + IF NPRIV1 (R) /= NR THEN + FAILED ( "INCORRECT CONVERSION OF 'NPRIV (R)'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "PRIVATE TYPES" ); + END; + + DECLARE + TASK TYPE TK; + T : TK; + + TYPE TK1 IS NEW TK; + T1 : TK1; + + TYPE TK2 IS NEW TK; + T2 : TK2; + + TYPE NTK1 IS NEW TK1; + NT : NTK1; + + TASK BODY TK IS + BEGIN + NULL; + END; + + FUNCTION F (T : TK) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (0); + END F; + + FUNCTION F (T : TK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (1); + END F; + + FUNCTION F (T : TK2) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (2); + END F; + + FUNCTION F (T : NTK1) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT (3); + END F; + + BEGIN + IF F (TK (T)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T))'" ); + END IF; + + IF F (TK (T1)) /= 0 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK (T1))'" ); + END IF; + + IF F (TK1 (T2)) /= 1 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK1 (T2))'" ); + END IF; + + IF F (TK2 (NT)) /= 2 THEN + FAILED ( "INCORRECT CONVERSION OF 'TK2 (NT))'" ); + END IF; + + IF F (NTK1 (T)) /= 3 THEN + FAILED ( "INCORRECT CONVERSION OF 'NTK (T))'" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "TASK TYPES" ); + END; + + RESULT; + END C46051A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C46051B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ENUMERATION VALUES CAN BE CONVERTED IF THE OPERAND + -- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND + -- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS. + + -- HISTORY: + -- JET 07/13/88 CREATED ORIGINAL TEST. + -- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED + -- EXTENSION TO 'ADA'. CHANGED THE CODES IN SECOND + -- ENUMERATION REPRESENTATION CLAUSE. + + WITH REPORT; USE REPORT; + PROCEDURE C46051B IS + + TYPE ENUM IS (WE, LOVE, WRITING, TESTS); + + TYPE ENUM1 IS NEW ENUM; + FOR ENUM1 USE + (WE => -1, LOVE => 0, WRITING => 3, TESTS => 9); + + TYPE ENUM2 IS NEW ENUM; + FOR ENUM2 USE + (WE => 10, LOVE => 15, WRITING => 16, TESTS => 19); + + TYPE ENUM3 IS NEW ENUM1; + + E : ENUM := ENUM'VAL (IDENT_INT (0)); + E1 : ENUM1 := ENUM1'VAL (IDENT_INT (1)); + E2 : ENUM2 := ENUM2'VAL (IDENT_INT (2)); + E3 : ENUM3 := ENUM3'VAL (IDENT_INT (3)); + + BEGIN + TEST ( "C46051B", "CHECK THAT ENUMERATION VALUES CAN BE " & + "CONVERTED IF THE OPERAND AND TARGET TYPES " & + "ARE RELATED BY DERIVATION, EVEN IF THE " & + "OPERAND AND TARGET TYPES HAVE DIFFERENT " & + "REPRESENTATIONS"); + + IF ENUM1 (E) /= WE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E)'" ); + END IF; + + IF ENUM (E1) /= LOVE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E1)'" ); + END IF; + + IF ENUM1 (E2) /= WRITING THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM1 (E2)'" ); + END IF; + + IF ENUM2 (E3) /= TESTS THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E3)'" ); + END IF; + + IF ENUM (E) /= WE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E)'" ); + END IF; + + IF ENUM2 (E1) /= LOVE THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM2 (E1)'" ); + END IF; + + IF ENUM3 (E2) /= WRITING THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM3 (E2)'" ); + END IF; + + IF ENUM (E3) /= TESTS THEN + FAILED ( "INCORRECT CONVERSION OF 'ENUM (E3)'" ); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "ENUMERATION TYPES" ); + RESULT; + END C46051B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46051c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46051c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C46051C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT RECORD VALUES CAN BE CONVERTED IF THE OPERAND + -- AND TARGET TYPES ARE RELATED BY DERIVATION, EVEN IF THE OPERAND + -- AND TARGET TYPES HAVE DIFFERENT REPRESENTATIONS. + + -- HISTORY: + -- JET 07/13/88 CREATED ORIGINAL TEST. + -- RJW 08/28/89 REMOVED APPLICABILITY CRITERIA AND CHANGED + -- EXTENSION TO 'ADA'. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + + PROCEDURE C46051C IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE+SYSTEM.STORAGE_UNIT-1) / SYSTEM.STORAGE_UNIT; + + TYPE ARR IS ARRAY (1..2) OF INTEGER; + + TYPE REC IS RECORD + F1 : INTEGER; + F2 : INTEGER; + F3 : INTEGER; + END RECORD; + + TYPE REC1 IS NEW REC; + FOR REC1 USE + RECORD + F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1; + F2 AT 1*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + END RECORD; + + TYPE REC2 IS NEW REC; + FOR REC2 USE + RECORD + F1 AT 0 RANGE 0 .. INTEGER'SIZE - 1; + F2 AT 2*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + F3 AT 3*UNITS_PER_INTEGER RANGE 0..INTEGER'SIZE - 1; + END RECORD; + + TYPE REC3 IS NEW REC1; + + R : REC := (IDENT_INT (0), 1, 2); + R1 : REC1 := (IDENT_INT (1), 2, 3); + R2 : REC2 := (IDENT_INT (2), 3, 4); + R3 : REC3 := (IDENT_INT (3), 4, 5); + + BEGIN + TEST ( "C46051C", "CHECK THAT RECORD VALUES CAN BE " & + "CONVERTED IF THE OPERAND AND TARGET TYPES " & + "ARE RELATED BY DERIVATION, EVEN IF THE " & + "OPERAND AND TARGET TYPES HAVE DIFFERENT " & + "REPRESENTATIONS"); + + IF REC1(R) /= (0,1,2) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R)'" ); + END IF; + + IF REC (R1) /= (1,2,3) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R1)'" ); + END IF; + + IF REC1 (R2) /= (2,3,4) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC1 (R2)'" ); + END IF; + + IF REC2 (R3) /= (3,4,5) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (R3)'" ); + END IF; + + IF REC (R) /= (0,1,2) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R)'" ); + END IF; + + IF REC2 (R1) /= (1,2,3) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC2 (R1)'" ); + END IF; + + IF REC3 (R2) /= (2,3,4) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC3 (R2)'" ); + END IF; + + IF REC (R3) /= (3,4,5) THEN + FAILED ( "INCORRECT CONVERSION OF 'REC (R3)'" ); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED DURING CONVERSION OF " & + "RECORD TYPES" ); + RESULT; + END C46051C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46052a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46052a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46052a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46052a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C46052A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN + -- ENUMERATION TYPE IF THE VALUE OF THE OPERAND DOES NOT BELONG TO THE + -- RANGE OF ENUMERATION VALUES FOR THE TARGET SUBTYPE. + + -- R.WILLIAMS 9/9/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46052A IS + + TYPE ENUM IS (A, AB, ABC, ABCD); + E : ENUM := ENUM'VAL (IDENT_INT (0)); + + FUNCTION IDENT (E : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (ENUM'POS (E))); + END IDENT; + + BEGIN + TEST ( "C46052A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN ENUMERATION TYPE IF THE " & + "VALUE OF THE OPERAND DOES NOT BELONG TO " & + "THE RANGE OF ENUMERATION VALUES FOR THE " & + "TARGET SUBTYPE" ); + + DECLARE + SUBTYPE SENUM IS ENUM RANGE AB .. ABCD; + BEGIN + E := IDENT (SENUM (E)); + FAILED ( "NO EXCEPTION RAISED FOR 'SENUM (E)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'SENUM (E)'" ); + END; + + DECLARE + SUBTYPE NOENUM IS ENUM RANGE ABCD .. AB; + BEGIN + E := IDENT (NOENUM (E)); + FAILED ( "NO EXCEPTION RAISED FOR 'NOENUM (E)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'NOENUM (E)'" ); + END; + + DECLARE + SUBTYPE SCHAR IS CHARACTER RANGE 'C' .. 'R'; + A : CHARACTER := IDENT_CHAR ('A'); + BEGIN + A := IDENT_CHAR (SCHAR (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'SCHAR (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'SCHAR (A)'" ); + END; + + DECLARE + SUBTYPE FRANGE IS BOOLEAN RANGE FALSE .. FALSE; + T : BOOLEAN := IDENT_BOOL (TRUE); + BEGIN + T := IDENT_BOOL (FRANGE (T)); + FAILED ( "NO EXCEPTION RAISED FOR 'FRANGE (T)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'FRANGE (T)'" ); + END; + + RESULT; + END C46052A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46053a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46053a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46053a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46053a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- C46053A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO A + -- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE SUBTYPE IF THE + -- DISCRIMINANTS OF THE TARGET SUBTYPE DO NOT EQUAL THOSE OF THE + -- OPERAND. + + -- R.WILLIAMS 9/9/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46053A IS + + BEGIN + TEST ( "C46053A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO A CONSTRAINED RECORD, " & + "PRIVATE, OR LIMITED PRIVATE SUBTYPE IF " & + "THE DISCRIMINANTS OF THE TARGET SUBTYPE DO " & + "NOT EQUAL THOSE OF THE OPERAND" ); + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE REC3 IS REC (IDENT_INT (3)); + R : REC (IDENT_INT (1)); + + PROCEDURE PROC (R : REC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (R.D); + END PROC; + + BEGIN + PROC (REC3 (R)); + FAILED ( "NO EXCEPTION RAISED FOR 'REC3 (R)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'REC3 (R)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + SUBTYPE PRIV3 IS PRIV (IDENT_INT (3)); + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + P : PRIV (IDENT_INT (0)); + END PKG2; + + USE PKG2; + + PROCEDURE PROC (P : PRIV) IS + I : INTEGER; + BEGIN + I := IDENT_INT (P.D); + END PROC; + + BEGIN + PROC (PRIV3 (P)); + FAILED ( "NO EXCEPTION RAISED FOR 'PRIV3 (P)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'PRIV3 (P)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE LIM (D : INTEGER) IS LIMITED PRIVATE; + SUBTYPE LIM3 IS LIM (IDENT_INT (3)); + PRIVATE + TYPE LIM (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + L : LIM (IDENT_INT (0)); + I : INTEGER; + END PKG2; + + USE PKG2; + + PROCEDURE PROC (L : LIM) IS + I : INTEGER; + BEGIN + I := IDENT_INT (L.D); + END PROC; + + BEGIN + PROC (LIM3 (L)); + FAILED ( "NO EXCEPTION RAISED FOR 'LIM3 (L)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'LIM3 (L)'" ); + END; + + RESULT; + END C46053A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46054a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46054a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c46054a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c46054a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C46054A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR CONVERSION TO AN + -- ACCESS SUBTYPE IF THE OPERAND VALUE IS NOT NULL AND THE + -- DISCRIMINANTS OR INDEX BOUNDS OF THE DESIGNATED OBJECT DO NOT + -- MATCH THOSE OF THE TARGET TYPE. + + -- R.WILLIAMS 9/9/86 + + WITH REPORT; USE REPORT; + PROCEDURE C46054A IS + + BEGIN + TEST ( "C46054A", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR " & + "CONVERSION TO AN ACCESS SUBTYPE IF THE " & + "OPERAND VALUE IS NOT NULL AND THE " & + "DISCRIMINANTS OR INDEX BOUNDS OF THE " & + "DESIGNATED OBJECT DO NOT MATCH THOSE OF " & + "THE TARGET TYPE" ); + + DECLARE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACREC IS ACCESS REC; + A : ACREC (IDENT_INT (0)) := NEW REC (IDENT_INT (0)); + + SUBTYPE ACREC3 IS ACREC (IDENT_INT (3)); + + PROCEDURE PROC (A : ACREC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D); + END PROC; + + BEGIN + PROC (ACREC3 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACREC3 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC3 (A)'" ); + END; + + DECLARE + TYPE REC (D1, D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACREC IS ACCESS REC; + + A : ACREC (IDENT_INT (3), IDENT_INT (1)) := + NEW REC (IDENT_INT (3), IDENT_INT (1)); + + SUBTYPE ACREC13 IS ACREC (IDENT_INT (1), IDENT_INT (3)); + + PROCEDURE PROC (A : ACREC) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D1); + END PROC; + + BEGIN + PROC (ACREC13 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACREC13 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACREC13 (A)'" ); + END; + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE ACARR IS ACCESS ARR; + A : ACARR (IDENT_INT (0) .. IDENT_INT (1)) := + NEW ARR'(IDENT_INT (0) .. IDENT_INT (1) => 0); + + SUBTYPE ACARR02 IS ACARR (IDENT_INT (0) .. IDENT_INT (2)); + + PROCEDURE PROC (A : ACARR) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A'LAST); + END PROC; + + BEGIN + PROC (ACARR02 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACARR02 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACARR02 (A)'" ); + END; + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + + TYPE ACARR IS ACCESS ARR; + A : ACARR (IDENT_INT (1) .. IDENT_INT (0), + IDENT_INT (4) .. IDENT_INT (5)) := + NEW ARR'(IDENT_INT (1) .. IDENT_INT (0) => + (IDENT_INT (4) .. IDENT_INT (5) => 0)); + + SUBTYPE NACARR IS ACARR (IDENT_INT (0) .. IDENT_INT (1), + IDENT_INT (5) .. IDENT_INT (4)); + + PROCEDURE PROC (A : NACARR) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A'LAST (1)); + END PROC; + + BEGIN + PROC (NACARR (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'NACARR (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'NACARR (A)'" ); + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PRIV (D : INTEGER) IS PRIVATE; + TYPE ACPRV IS ACCESS PRIV; + SUBTYPE ACPRV3 IS ACPRV (IDENT_INT (3)); + + PRIVATE + TYPE PRIV (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + USE PKG1; + + PACKAGE PKG2 IS + A : ACPRV (IDENT_INT (0)) := NEW PRIV (IDENT_INT (0)); + END PKG2; + + USE PKG2; + + PROCEDURE PROC (A : ACPRV) IS + I : INTEGER; + BEGIN + I := IDENT_INT (A.D); + END PROC; + + BEGIN + PROC (ACPRV3 (A)); + FAILED ( "NO EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR 'ACPRV3 (A)'" ); + END; + + RESULT; + END C46054A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460a01.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,408 ---- + -- C460A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the target type of a type conversion is a general + -- access type, Program_Error is raised if the accessibility level of + -- the operand type is deeper than that of the target type. Check for + -- cases where the type conversion occurs in an instance body, and + -- the operand type is passed as an actual during instantiation. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the operand type must + -- be at the same or a less deep nesting level than the target type -- the + -- operand type must "live" as long as the target type. Nesting levels + -- are the run-time nestings of masters: block statements; subprogram, + -- task, and entry bodies; and accept statements. Packages are invisible + -- to accessibility rules. + -- + -- This test checks for cases where the operand is a subprogram formal + -- parameter. + -- + -- The test declares three generic packages, each containing an access + -- type conversion in which the operand type is a formal type: + -- + -- (1) One in which the target type is declared within the + -- specification, and the conversion occurs within a nested + -- function. + -- + -- (2) One in which the target type is also a formal type, and + -- the conversion occurs within a nested function. + -- + -- (3) One in which the target type is declared outside the + -- generic, and the conversion occurs within a nested + -- procedure. + -- + -- The test verifies the following: + -- + -- For (1), Program_Error is not raised when the nested function is + -- called. Since the actual corresponding to the formal operand type + -- must always have the same or a less deep level than the target + -- type declared within the instance, the access type conversion is + -- always safe. + -- + -- For (2), Program_Error is raised when the nested function is + -- called if the operand type passed as an actual during instantiation + -- has an accessibility level deeper than that of the target type + -- passed as an actual, and that no exception is raised otherwise. + -- The exception is propagated to the innermost enclosing master. + -- + -- For (3), Program_Error is raised when the nested procedure is + -- called if the operand type passed as an actual during instantiation + -- has an accessibility level deeper than that of the target type. + -- The exception is handled within the nested procedure. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F460A00.A + -- => C460A01.A + -- + -- + -- CHANGE HISTORY: + -- 09 May 95 SAIC Initial prerelease version. + -- 24 Apr 96 SAIC Added code to avoid dead variable optimization. + -- 13 Feb 97 PWB.CTA Removed 'Class from qual expression at line 342. + --! + + generic + type Designated_Type is tagged private; + type Operand_Type is access Designated_Type; + package C460A01_0 is + type Target_Type is access all Designated_Type; + function Convert (P : Operand_Type) return Target_Type; + end C460A01_0; + + + --==================================================================-- + + + package body C460A01_0 is + function Convert (P : Operand_Type) return Target_Type is + begin + return Target_Type(P); -- Never fails. + end Convert; + end C460A01_0; + + + --==================================================================-- + + + generic + type Designated_Type is tagged private; + type Operand_Type is access all Designated_Type; + type Target_Type is access all Designated_Type; + package C460A01_1 is + function Convert (P : Operand_Type) return Target_Type; + end C460A01_1; + + + --==================================================================-- + + + package body C460A01_1 is + function Convert (P : Operand_Type) return Target_Type is + begin + return Target_Type(P); + end Convert; + end C460A01_1; + + + --==================================================================-- + + + with F460A00; + generic + type Designated_Type (<>) is new F460A00.Tagged_Type with private; + type Operand_Type is access Designated_Type; + package C460A01_2 is + procedure Proc (P : Operand_Type; + Res : out F460A00.TC_Result_Kind); + end C460A01_2; + + + --==================================================================-- + + with Report; + package body C460A01_2 is + procedure Proc (P : Operand_Type; + Res : out F460A00.TC_Result_Kind) is + Ptr : F460A00.AccTag_L0; + begin + Ptr := F460A00.AccTag_L0(P); + + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A01_2 instance"); + end if; + + Res := F460A00.OK; + exception + when Program_Error => Res := F460A00.PE_Exception; + when others => Res := F460A00.Others_Exception; + end Proc; + end C460A01_2; + + + --==================================================================-- + + + with F460A00; + with C460A01_0; + with C460A01_1; + with C460A01_2; + + with Report; + procedure C460A01 is + begin -- C460A01. -- [ Level = 1 ] + + Report.Test ("C460A01", "Run-time accessibility checks: instance " & + "bodies. Operand type of access type conversion is " & + "passed as actual to instance"); + + + SUBTEST1: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Operand: AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST1. + + declare -- [ Level = 3 ] + -- The instantiation of C460A01_0 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_0 (F460A00.Tagged_Type, AccTag_L2); + Target : Pack_OK.Target_Type; + begin + -- The accessibility level of Pack_OK.Target_Type will always be at + -- least as deep as the operand type passed as an actual. Thus, + -- a call to Pack_OK.Convert does not propagate an exception: + + Target := Pack_OK.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #1"); + end if; + + Result := F460A00.OK; -- Expected result. + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #1: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #1: Unexpected exception raised"); + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Operand : AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + + type AccTag_L3 is access all F460A00.Tagged_Type; + Target : AccTag_L3; + + -- The instantiation of C460A01_1 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_1 + (Designated_Type => F460A00.Tagged_Type, + Operand_Type => AccTag_L2, + Target_Type => AccTag_L3); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_OK is 2. The accessibility level of the actual passed as + -- the target type is 3. Therefore, the access type conversion in + -- Pack_OK.Convert does not raise an exception when the subprogram is + -- called. If an exception is (incorrectly) raised, it is propagated + -- to the innermost enclosing master: + + Target := Pack_OK.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #2"); + end if; + + Result := F460A00.OK; -- Expected result. + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #2"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #2: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #2: Unexpected exception raised"); + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + Target : AccTag_L2; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + + type AccTag_L3 is access all F460A00.Tagged_Type; + Operand : AccTag_L3 := new F460A00.Tagged_Type; + + -- The instantiation of C460A01_1 should NOT result in any + -- exceptions. + + package Pack_PE is new C460A01_1 + (Designated_Type => F460A00.Tagged_Type, + Operand_Type => AccTag_L3, + Target_Type => AccTag_L2); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_PE is 3. The accessibility level of the actual passed as + -- the target type is 2. Therefore, the access type conversion in + -- Pack_PE.Convert raises Program_Error when the subprogram is + -- called. The exception is propagated to the innermost enclosing + -- master: + + Target := Pack_PE.Convert(Operand); + + -- Avoid optimization (dead variable removal of Target): + if not Report.Equal (Target.C, Target.C) then -- Always false. + Report.Failed ("Unexpected error in SUBTEST #3"); + end if; + + Result := F460A00.OK; + exception + when Program_Error => Result := F460A00.PE_Exception; + -- Expected result. + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception raised"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + + TType : F460A00.Tagged_Type; + Operand : F460A00.AccTagClass_L0 + := new F460A00.Tagged_Type'(TType); + + -- The instantiation of C460A01_2 should NOT result in any + -- exceptions. + + package Pack_OK is new C460A01_2 (F460A00.Tagged_Type'Class, + F460A00.AccTagClass_L0); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_OK is 0. The accessibility level of the target type + -- (F460A00.AccTag_L0) is also 0. Therefore, the access type + -- conversion in Pack_OK.Proc does not raise an exception when the + -- subprogram is called. If an exception is (incorrectly) raised, + -- it is handled within the subprogram: + + Pack_OK.Proc(Operand, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #4"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised"); + end SUBTEST4; + + + + SUBTEST5: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST5. + + declare -- [ Level = 3 ] + + type AccDerTag_L3 is access all F460A00.Derived_Tagged_Type; + Operand : AccDerTag_L3 := new F460A00.Derived_Tagged_Type; + + -- The instantiation of C460A01_2 should NOT result in any + -- exceptions. + + package Pack_PE is new C460A01_2 (F460A00.Derived_Tagged_Type, + AccDerTag_L3); + begin + -- The accessibility level of the actual passed as the operand type + -- in Pack_PE is 3. The accessibility level of the target type + -- (F460A00.AccTag_L0) is 0. Therefore, the access type conversion + -- in Pack_PE.Proc raises Program_Error when the subprogram is + -- called. The exception is handled within the subprogram: + + Pack_PE.Proc(Operand, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #5"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #5: Unexpected exception raised"); + end SUBTEST5; + + Report.Result; + + end C460A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c460a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c460a02.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,413 ---- + -- C460A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the target type of a type conversion is a general + -- access type, Program_Error is raised if the accessibility level of + -- the operand type is deeper than that of the target type. Check for + -- cases where the type conversion occurs in an instance body, and + -- the operand type is declared inside the instance or is the anonymous + -- access type of an access parameter or access discriminant. + -- + -- TEST DESCRIPTION: + -- In order to satisfy accessibility requirements, the operand type must + -- be at the same or a less deep nesting level than the target type -- the + -- operand type must "live" as long as the target type. Nesting levels + -- are the run-time nestings of masters: block statements; subprogram, + -- task, and entry bodies; and accept statements. Packages are invisible + -- to accessibility rules. + -- + -- This test checks for cases where the operand is a component of a + -- generic formal object, a stand-alone object, and an access parameter. + -- + -- The test declares three generic units, each containing an access + -- type conversion in which the target type is a formal type: + -- + -- (1) A generic package in which the operand type is the anonymous + -- access type of an access discriminant, and the conversion + -- occurs within the declarative part of the body. + -- + -- (2) A generic package in which the operand type is declared within + -- the specification, and the conversion occurs within the + -- sequence of statements of the body. + -- + -- (3) A generic procedure in which the operand type is the anonymous + -- access type of an access parameter, and the conversion occurs + -- within the sequence of statements. + -- + -- The test verifies the following: + -- + -- For (1), Program_Error is raised when the package is instantiated + -- if the actual passed through the formal object has an accessibility + -- level deeper than that of the target type passed as an actual, and + -- that no exception is raised otherwise. The exception is propagated + -- to the innermost enclosing master. + -- + -- For (2), Program_Error is raised when the package is instantiated + -- if the package is instantiated at a level deeper than that of the + -- target type passed as an actual, and that no exception is raised + -- otherwise. The exception is handled within the package body. + -- + -- For (3), Program_Error is raised when the instance procedure is + -- called if the actual passed through the access parameter has an + -- accessibility level deeper than that of the target type passed as + -- an actual, and that no exception is raised otherwise. The exception + -- is handled within the instance procedure. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F460A00.A + -- => C460A02.A + -- + -- + -- CHANGE HISTORY: + -- 10 May 95 SAIC Initial prerelease version. + -- 24 Apr 96 SAIC Changed the target type formal to be + -- access-to-constant; Modified code to avoid dead + -- variable optimization. + -- + --! + + with F460A00; + generic + type Target_Type is access all F460A00.Tagged_Type; + FObj: in out F460A00.Composite_Type; + package C460A02_0 is + procedure Dummy; -- Needed to allow package body. + end C460A02_0; + + + --==================================================================-- + + with Report; + package body C460A02_0 is + Ptr: Target_Type := Target_Type(FObj.D); + + procedure Dummy is + begin + null; + end Dummy; + + begin + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_0 instance"); + end if; + + end C460A02_0; + + + --==================================================================-- + + + with F460A00; + generic + type Designated_Type is private; + type Target_Type is access all Designated_Type; + FObj : in out Target_Type; + FRes : in out F460A00.TC_Result_Kind; + package C460A02_1 is + type Operand_Type is access Designated_Type; + Ptr : Operand_Type := new Designated_Type; + + procedure Dummy; -- Needed to allow package body. + end C460A02_1; + + + --==================================================================-- + + + package body C460A02_1 is + procedure Dummy is + begin + null; + end Dummy; + begin + FRes := F460A00.UN_Init; + FObj := Target_Type(Ptr); + FRes := F460A00.OK; + exception + when Program_Error => FRes := F460A00.PE_Exception; + when others => FRes := F460A00.Others_Exception; + end C460A02_1; + + + --==================================================================-- + + + with F460A00; + generic + type Designated_Type is new F460A00.Tagged_Type with private; + type Target_Type is access constant Designated_Type; + procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind); + + + --==================================================================-- + + + with Report; + procedure C460A02_2 (P : access Designated_Type'Class; + Res : out F460A00.TC_Result_Kind) is + Ptr : Target_Type; + begin + Res := F460A00.UN_Init; + Ptr := Target_Type(P); + + -- Avoid optimization (dead variable removal of Ptr): + if not Report.Equal (Ptr.C, Ptr.C) then -- Always false. + Report.Failed ("Unexpected error in C460A02_2 instance"); + end if; + Res := F460A00.OK; + exception + when Program_Error => Res := F460A00.PE_Exception; + when others => Res := F460A00.Others_Exception; + end C460A02_2; + + + --==================================================================-- + + + with F460A00; + with C460A02_0; + with C460A02_1; + with C460A02_2; + + with Report; + procedure C460A02 is + begin -- C460A02. -- [ Level = 1 ] + + Report.Test ("C460A02", "Run-time accessibility checks: instance " & + "bodies. Operand type of access type conversion is " & + "declared inside instance or is anonymous"); + + + SUBTEST1: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + Operand_L2 : F460A00.Composite_Type(PTag_L2); + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST1. + + begin -- [ Level = 3 ] + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is also 2. Therefore, the access type conversion in + -- Pack_OK does not raise an exception upon instantiation: + + package Pack_OK is new C460A02_0 + (Target_Type => AccTag_L2, FObj => Operand_L2); + begin + Result := F460A00.OK; -- Expected result. + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #1"); + + end SUBTEST1; + + + + SUBTEST2: + declare -- [ Level = 2 ] + type AccTag_L2 is access all F460A00.Tagged_Type; + PTag_L2 : AccTag_L2 := new F460A00.Tagged_Type; + + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST2. + + declare -- [ Level = 3 ] + Operand_L3 : F460A00.Composite_Type(PTag_L2); + begin + declare -- [ Level = 4 ] + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 2. The accessibility level of the composite actual + -- (and thus, the level of the anonymous type of the access + -- discriminant, which is the same as that of the containing + -- object) is 3. Therefore, the access type conversion in Pack_PE + -- propagates Program_Error upon instantiation: + + package Pack_PE is new C460A02_0 (AccTag_L2, Operand_L3); + begin + Result := F460A00.OK; + end; + exception + when Program_Error => Result := F460A00.PE_Exception; + -- Expected result. + when others => Result := F460A00.Others_Exception; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #2"); + + end SUBTEST2; + + + + SUBTEST3: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST3. + + declare -- [ Level = 3 ] + type AccArr_L3 is access all F460A00.Array_Type; + Target: AccArr_L3; + + -- The accessibility level of the actual passed as the target type + -- in Pack_OK is 3. The accessibility level of the operand type is + -- that of the instance, which is also 3. Therefore, the access type + -- conversion in Pack_OK does not raise an exception upon + -- instantiation. If an exception is (incorrectly) raised, it is + -- handled within the instance: + + package Pack_OK is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => AccArr_L3, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #3"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly propagated"); + when others => + Report.Failed ("SUBTEST #3: Unexpected exception propagated"); + end SUBTEST3; + + + + SUBTEST4: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST4. + + declare -- [ Level = 3 ] + Target: F460A00.AccArr_L0; + + -- The accessibility level of the actual passed as the target type + -- in Pack_PE is 0. The accessibility level of the operand type is + -- that of the instance, which is 3. Therefore, the access type + -- conversion in Pack_PE raises Program_Error upon instantiation. + -- The exception is handled within the instance: + + package Pack_PE is new C460A02_1 + (Designated_Type => F460A00.Array_Type, + Target_Type => F460A00.AccArr_L0, + FObj => Target, + FRes => Result); + begin + null; + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #4"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #4: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #4: Unexpected exception raised"); + end SUBTEST4; + + + + SUBTEST5: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST5. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- The accessibility level of the actual passed to Proc is 0. The + -- accessibility level of the actual passed as the target type is + -- also 0. Therefore, the access type conversion in Proc does not + -- raise an exception when the subprogram is called. If an exception + -- is (incorrectly) raised, it is handled within the subprogram: + + Proc (F460A00.PTagClass_L0, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.OK, "SUBTEST #5"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #5: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #5: Unexpected exception raised"); + end SUBTEST5; + + + + SUBTEST6: + declare -- [ Level = 2 ] + Result : F460A00.TC_Result_Kind := F460A00.UN_Init; + begin -- SUBTEST6. + + declare -- [ Level = 3 ] + -- The instantiation of C460A02_2 should NOT result in any + -- exceptions. + + procedure Proc is new C460A02_2 (F460A00.Tagged_Type, + F460A00.AccTag_L0); + begin + -- In the call to (instantiated) procedure Proc, the first actual + -- parameter is an allocator. Its accessibility level is that of + -- the level of execution of Proc, which is 3. The accessibility + -- level of the actual passed as the target type is 0. Therefore, + -- the access type conversion in Proc raises Program_Error when the + -- subprogram is called. The exception is handled within the + -- subprogram: + + Proc (new F460A00.Tagged_Type, Result); + end; + + F460A00.TC_Check_Results (Result, F460A00.PE_Exception, "SUBTEST #6"); + + exception + when Program_Error => + Report.Failed ("SUBTEST #6: Program_Error incorrectly raised"); + when others => + Report.Failed ("SUBTEST #6: Unexpected exception raised"); + end SUBTEST6; + + Report.Result; + + end C460A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C47002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS + -- THE OPERANDS OF QUALIFIED EXPRESSIONS. + -- THIS TEST IS FOR DISCRETE TYPES. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47002A IS + + BEGIN + + TEST( "C47002A", "CHECK THAT VALUES HAVING DISCRETE TYPES " & + "CAN BE WRITTEN AS THE OPERANDS OF " & + "QUALIFIED EXPRESSIONS" ); + + DECLARE -- ENUMERATION TYPES. + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + TYPE WEEKEND IS (SAT, SUN); + + TYPE CHAR IS ('B', 'A'); + + TYPE MYBOOL IS (TRUE, FALSE); + + TYPE NBOOL IS NEW BOOLEAN; + + BEGIN + IF WEEKEND'(SAT) >= SUN THEN + FAILED ( "INCORRECT RESULTS FOR TYPE WEEKEND" ); + END IF; + + IF CHAR'('B') >= 'A' THEN + FAILED ( "INCORRECT RESULTS FOR TYPE CHAR" ); + END IF; + + IF MYBOOL'(TRUE) >= FALSE THEN + FAILED ( "INCORRECT RESULTS FOR TYPE MYBOOL" ); + END IF; + + IF NBOOL'(TRUE) <= FALSE THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NBOOL" ); + END IF; + END; + + DECLARE -- INTEGER TYPES. + + TYPE RESULTS IS (INT1, INT2, INT3); + + TYPE NEWINT IS NEW INTEGER; + + TYPE INT IS RANGE -10 .. 10; + + FUNCTION F (I : NEWINT) RETURN RESULTS IS + BEGIN + RETURN INT1; + END F; + + FUNCTION F (I : INT) RETURN RESULTS IS + BEGIN + RETURN INT2; + END F; + + FUNCTION F (I : INTEGER) RETURN RESULTS IS + BEGIN + RETURN INT3; + END F; + + BEGIN + IF F (NEWINT'(5)) /= INT1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NEWINT" ); + END IF; + + IF F (INT'(5)) /= INT2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE INT" ); + END IF; + + IF F (INTEGER'(5)) /= INT3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE INTEGER" ); + END IF; + END; + + RESULT; + END C47002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C47002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS + -- THE OPERANDS OF QUALIFIED EXPRESSIONS. + -- THIS TEST IS FOR REAL TYPES. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47002B IS + + BEGIN + + TEST( "C47002B", "CHECK THAT VALUES HAVING REAL TYPES " & + "CAN BE WRITTEN AS THE OPERANDS OF " & + "QUALIFIED EXPRESSIONS" ); + + DECLARE -- FLOATING POINT TYPES. + + TYPE RESULTS IS (FL1, FL2, FL3); + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + + TYPE NFLT IS NEW FLOAT; + + FUNCTION F (FL : FLT) RETURN RESULTS IS + BEGIN + RETURN FL1; + END F; + + FUNCTION F (FL : NFLT) RETURN RESULTS IS + BEGIN + RETURN FL2; + END F; + + FUNCTION F (FL : FLOAT) RETURN RESULTS IS + BEGIN + RETURN FL3; + END F; + + BEGIN + IF F (FLT'(0.0)) /= FL1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FLT" ); + END IF; + + IF F (NFLT'(0.0)) /= FL2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NFLT" ); + END IF; + + IF F (FLOAT'(0.0)) /= FL3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FLOAT" ); + END IF; + END; + + DECLARE -- FIXED POINT TYPES. + + TYPE RESULTS IS (FI1, FI2, FI3); + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + + TYPE NFIX IS NEW FIXED; + + FUNCTION F (FI : FIXED) RETURN RESULTS IS + BEGIN + RETURN FI1; + END F; + + FUNCTION F (FI : NFIX) RETURN RESULTS IS + BEGIN + RETURN FI2; + END F; + + FUNCTION F (FI : DURATION) RETURN RESULTS IS + BEGIN + RETURN FI3; + END F; + + BEGIN + IF F (FIXED'(0.0)) /= FI1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE FIXED" ); + END IF; + + IF F (NFIX'(0.0)) /= FI2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE NFIX" ); + END IF; + + IF F (DURATION'(0.0)) /= FI3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE DURATION" ); + END IF; + END; + + RESULT; + END C47002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C47002C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS + -- THE OPERANDS OF QUALIFIED EXPRESSIONS. + -- THIS TEST IS FOR ARRAY, RECORD, AND ACCESS TYPES. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47002C IS + + BEGIN + + TEST( "C47002C", "CHECK THAT VALUES HAVING ARRAY, RECORD, AND " & + "ACCESS TYPES CAN BE WRITTEN AS THE OPERANDS " & + "OF QUALIFIED EXPRESSIONS" ); + + DECLARE -- ARRAY TYPES. + + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARR1 IS ARR (1 .. 1); + SUBTYPE ARR5 IS ARR (1 .. 5); + + TYPE NARR IS NEW ARR; + SUBTYPE NARR2 IS NARR (2 .. 2); + + TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + SUBTYPE TARR15 IS TARR (1 .. 1, 1 .. 5); + SUBTYPE TARR51 IS TARR (1 .. 5, 1 .. 1); + + TYPE NTARR IS NEW TARR; + SUBTYPE NTARR26 IS NTARR (2 .. 6, 2 .. 6); + + FUNCTION F (X : ARR) RETURN ARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : NARR) RETURN NARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : TARR) RETURN TARR IS + BEGIN + RETURN X; + END; + + FUNCTION F (X : NTARR) RETURN NTARR IS + BEGIN + RETURN X; + END; + + BEGIN + IF F (ARR1'(OTHERS => 0))'LAST /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR1" ); + END IF; + + IF F (ARR5'(OTHERS => 0))'LAST /= 5 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE ARR5" ); + END IF; + + IF F (NARR2'(OTHERS => 0))'FIRST /= 2 OR + F (NARR2'(OTHERS => 0))'LAST /= 2 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE NARR2" ); + END IF; + + IF F (TARR15'(OTHERS => (OTHERS => 0)))'LAST /= 1 OR + F (TARR15'(OTHERS => (OTHERS => 0)))'LAST (2) /= 5 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR15" ); + END IF; + + IF F (TARR51'(OTHERS => (OTHERS => 0)))'LAST /= 5 OR + F (TARR51'(OTHERS => (OTHERS => 0)))'LAST (2) /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE TARR51" ); + END IF; + + IF F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST /= 2 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST /= 6 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'FIRST (2) /= 2 OR + F (NTARR26'(OTHERS => (OTHERS => 0)))'LAST (2) /= 6 THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE NTARR26" ); + END IF; + + END; + + DECLARE -- RECORD TYPES. + + TYPE GENDER IS (MALE, FEMALE, NEUTER); + + TYPE MAN IS + RECORD + AGE : POSITIVE; + END RECORD; + + TYPE WOMAN IS + RECORD + AGE : POSITIVE; + END RECORD; + + TYPE ANDROID IS NEW MAN; + + FUNCTION F (X: WOMAN) RETURN GENDER IS + BEGIN + RETURN FEMALE; + END F; + + FUNCTION F (X: MAN) RETURN GENDER IS + BEGIN + RETURN MALE; + END F; + + FUNCTION F (X : ANDROID) RETURN GENDER IS + BEGIN + RETURN NEUTER; + END F; + + BEGIN + IF F (MAN'(AGE => 23)) /= MALE THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE MAN" ); + END IF; + + IF F (WOMAN'(AGE => 38)) /= FEMALE THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE WOMAN" ); + END IF; + + IF F (ANDROID'(AGE => 2001)) /= NEUTER THEN + FAILED ( "INCORRECT RESULTS FOR TYPE ANDRIOD" ); + END IF; + END; + + DECLARE -- ACCESS TYPES. + + TYPE CODE IS (OLD, BRANDNEW, WRECK); + + TYPE CAR (D : CODE) IS + RECORD + NULL; + END RECORD; + + TYPE KEY IS ACCESS CAR; + + TYPE KEY_OLD IS ACCESS CAR (OLD); + KO : KEY_OLD := NEW CAR'(D => OLD); + + TYPE KEY_WRECK IS ACCESS CAR (WRECK); + + TYPE KEY_CARD IS NEW KEY; + KC : KEY_CARD := NEW CAR'(D => BRANDNEW); + + FUNCTION F (X : KEY_OLD) RETURN CODE IS + BEGIN + RETURN OLD; + END F; + + FUNCTION F (X : KEY_WRECK) RETURN CODE IS + BEGIN + RETURN WRECK; + END F; + + FUNCTION F (X : KEY_CARD) RETURN CODE IS + BEGIN + RETURN BRANDNEW; + END F; + BEGIN + IF KEY_OLD'(KO) /= KO THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_OLD - 1" ); + END IF; + + IF KEY_CARD'(KC) /= KC THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 1" ); + END IF; + + + IF F (KEY_OLD'(NULL)) /= OLD THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_OLD - 2" ); + END IF; + + IF F (KEY_WRECK'(NULL)) /= WRECK THEN + FAILED ( "INCORRECT RESULTS FOR SUBTYPE KEY_WRECK" ); + END IF; + + IF F (KEY_CARD'(NULL)) /= BRANDNEW THEN + FAILED ( "INCORRECT RESULTS FOR TYPE KEY_CARD - 2" ); + END IF; + END; + + RESULT; + END C47002C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47002d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,273 ---- + -- C47002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VALUES BELONGING TO EACH CLASS OF TYPE CAN BE WRITTEN AS + -- THE OPERANDS OF QUALIFIED EXPRESSIONS. + -- THIS TEST IS FOR PRIVATE AND LIMITED PRIVATE TYPES. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47002D IS + + BEGIN + + TEST( "C47002D", "CHECK THAT VALUES HAVING PRIVATE AND LIMITED " & + "PRIVATE TYPES CAN BE WRITTEN AS THE OPERANDS " & + "OF QUALIFIED EXPRESSIONS" ); + + DECLARE -- PRIVATE TYPES. + + TYPE RESULTS IS (P1, P2, P3, P4, P5); + + PACKAGE PKG1 IS + TYPE PINT IS PRIVATE; + TYPE PCHAR IS PRIVATE; + TYPE PARR IS PRIVATE; + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE PACC IS PRIVATE; + + FUNCTION F RETURN PINT; + FUNCTION F RETURN PCHAR; + FUNCTION F RETURN PARR; + FUNCTION F RETURN PREC; + FUNCTION F RETURN PACC; + + PRIVATE + TYPE PINT IS NEW INTEGER; + TYPE PCHAR IS NEW CHARACTER; + TYPE PARR IS ARRAY (1 .. 2) OF NATURAL; + + TYPE PREC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE PACC IS ACCESS PREC; + + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION F RETURN PINT IS + BEGIN + RETURN 1; + END F; + + FUNCTION F RETURN PCHAR IS + BEGIN + RETURN 'B'; + END F; + + FUNCTION F RETURN PARR IS + BEGIN + RETURN PARR'(OTHERS => 3); + END F; + + FUNCTION F RETURN PREC IS + BEGIN + RETURN PREC'(D => 4); + END F; + + FUNCTION F RETURN PACC IS + BEGIN + RETURN NEW PREC'(F); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + FUNCTION CHECK (P : PINT) RETURN RESULTS IS + BEGIN + RETURN P1; + END CHECK; + + FUNCTION CHECK (P : PCHAR) RETURN RESULTS IS + BEGIN + RETURN P2; + END CHECK; + + FUNCTION CHECK (P : PARR) RETURN RESULTS IS + BEGIN + RETURN P3; + END CHECK; + + FUNCTION CHECK (P : PREC) RETURN RESULTS IS + BEGIN + RETURN P4; + END CHECK; + + FUNCTION CHECK (P : PACC) RETURN RESULTS IS + BEGIN + RETURN P5; + END CHECK; + + BEGIN + IF CHECK (PINT'(F)) /= P1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PINT" ); + END IF; + + IF CHECK (PCHAR'(F)) /= P2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PCHAR" ); + END IF; + + IF CHECK (PARR'(F)) /= P3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PARR" ); + END IF; + + IF CHECK (PREC'(F)) /= P4 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PREC" ); + END IF; + + IF CHECK (PACC'(F)) /= P5 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE PACC" ); + END IF; + + END PKG2; + + BEGIN + NULL; + END; + + DECLARE -- LIMITED PRIVATE TYPES. + + TYPE RESULTS IS (LP1, LP2, LP3, LP4, LP5); + + PACKAGE PKG1 IS + TYPE LPINT IS LIMITED PRIVATE; + TYPE LPCHAR IS LIMITED PRIVATE; + TYPE LPARR IS LIMITED PRIVATE; + TYPE LPREC (D : INTEGER) IS LIMITED PRIVATE; + TYPE LPACC IS LIMITED PRIVATE; + + FUNCTION F RETURN LPINT; + FUNCTION F RETURN LPCHAR; + FUNCTION F RETURN LPARR; + FUNCTION F RETURN LPREC; + FUNCTION F RETURN LPACC; + + PRIVATE + TYPE LPINT IS NEW INTEGER; + TYPE LPCHAR IS NEW CHARACTER; + TYPE LPARR IS ARRAY (1 .. 2) OF NATURAL; + + TYPE LPREC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE LPACC IS ACCESS LPREC; + + END PKG1; + + PACKAGE BODY PKG1 IS + FUNCTION F RETURN LPINT IS + BEGIN + RETURN 1; + END F; + + FUNCTION F RETURN LPCHAR IS + BEGIN + RETURN 'B'; + END F; + + FUNCTION F RETURN LPARR IS + BEGIN + RETURN LPARR'(OTHERS => 3); + END F; + + FUNCTION F RETURN LPREC IS + BEGIN + RETURN LPREC'(D => 4); + END F; + + FUNCTION F RETURN LPACC IS + BEGIN + RETURN NEW LPREC'(F); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + FUNCTION CHECK (LP : LPINT) RETURN RESULTS IS + BEGIN + RETURN LP1; + END CHECK; + + FUNCTION CHECK (LP : LPCHAR) RETURN RESULTS IS + BEGIN + RETURN LP2; + END CHECK; + + FUNCTION CHECK (LP : LPARR) RETURN RESULTS IS + BEGIN + RETURN LP3; + END CHECK; + + FUNCTION CHECK (LP : LPREC) RETURN RESULTS IS + BEGIN + RETURN LP4; + END CHECK; + + FUNCTION CHECK (LP : LPACC) RETURN RESULTS IS + BEGIN + RETURN LP5; + END CHECK; + + BEGIN + IF CHECK (LPINT'(F)) /= LP1 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPINT" ); + END IF; + + IF CHECK (LPCHAR'(F)) /= LP2 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPCHAR" ); + END IF; + + IF CHECK (LPARR'(F)) /= LP3 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPARR" ); + END IF; + + IF CHECK (LPREC'(F)) /= LP4 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPREC" ); + END IF; + + IF CHECK (LPACC'(F)) /= LP5 THEN + FAILED ( "INCORRECT RESULTS FOR TYPE LPACC" ); + END IF; + + END PKG2; + + BEGIN + NULL; + END; + + RESULT; + END C47002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47003a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C47003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN + -- ENUMERATION TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE + -- VALUE OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47003A IS + + BEGIN + + TEST( "C47003A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN ENUMERATION " & + "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + TYPE WEEK IS (SUN, MON, TUE, WED, THU, FRI, SAT); + SUBTYPE MIDWEEK IS WEEK RANGE TUE .. THU; + + FUNCTION IDENT (W : WEEK) RETURN WEEK IS + BEGIN + RETURN WEEK'VAL (IDENT_INT (WEEK'POS (W))); + END IDENT; + + BEGIN + IF MIDWEEK'(IDENT (SUN)) = TUE THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE MIDWEEK - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE MIDWEEK - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE MIDWEEK" ); + END; + + DECLARE + + SUBTYPE CHAR IS CHARACTER RANGE 'C' .. 'R'; + + BEGIN + IF CHAR'(IDENT_CHAR ('A')) = 'C' THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE CHAR - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE CHAR - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE CHAR" ); + END; + + DECLARE + + TYPE NBOOL IS NEW BOOLEAN; + SUBTYPE NFALSE IS NBOOL RANGE FALSE .. FALSE; + + FUNCTION IDENT (B : NBOOL) RETURN NBOOL IS + BEGIN + RETURN NBOOL (IDENT_BOOL (BOOLEAN (B))); + END IDENT; + + BEGIN + IF NFALSE'(IDENT (TRUE)) = FALSE THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE NFALSE - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE NFALSE - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE NFALSE" ); + END; + + RESULT; + END C47003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47004a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C47004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN INTEGER + -- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE + -- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47004A IS + + BEGIN + + TEST( "C47004A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN INTEGER " & + "TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + TYPE INT IS RANGE -10 .. 10; + SUBTYPE SINT IS INT RANGE -5 .. 5; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + RETURN INT (IDENT_INT (INTEGER (I))); + END; + + BEGIN + IF SINT'(IDENT (10)) = 5 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SINT" ); + END; + + DECLARE + + SUBTYPE SINTEGER IS INTEGER RANGE -10 .. 10; + + BEGIN + IF SINTEGER'(IDENT_INT (20)) = 15 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINTEGER - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SINTEGER - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SINTEGER" ); + END; + + DECLARE + + TYPE NINTEGER IS NEW INTEGER; + SUBTYPE SNINT IS NINTEGER RANGE -10 .. 10; + + FUNCTION IDENT (I : NINTEGER) RETURN NINTEGER IS + BEGIN + RETURN NINTEGER (IDENT_INT (INTEGER (I))); + END; + + BEGIN + IF SNINT'(IDENT (-20)) = -10 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNINT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNINT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNINT" ); + END; + + RESULT; + END C47004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47005a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C47005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FLOATING + -- POINT TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE + -- OF THE OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + + -- HISTORY: + -- RJW 07/23/86 CREATED ORIGINAL TEST. + -- BCB 08/19/87 CHANGED HEADER TO STANDARD HEADER FORMAT. ADDED + -- TEST FOR UPPER SIDE OF RANGE. + + WITH REPORT; USE REPORT; + PROCEDURE C47005A IS + + BEGIN + + TEST( "C47005A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A FLOATING POINT TYPE, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED WHEN THE VALUE " & + "OF THE OPERAND DOES NOT LIE WITHIN THE " & + "RANGE OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SFLOAT IS FLOAT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFLOAT'(IDENT (-2.0)) = -1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLOAT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLOAT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFLOAT" ); + END; + + DECLARE + + TYPE FLT IS DIGITS 3 RANGE -5.0 .. 5.0; + SUBTYPE SFLT IS FLT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : FLT) RETURN FLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFLT'(IDENT (-2.0)) = -1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLT - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFLT - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFLT" ); + END; + + DECLARE + + TYPE NFLT IS NEW FLOAT; + SUBTYPE SNFLT IS NFLT RANGE -1.0 .. 1.0; + + FUNCTION IDENT (F : NFLT) RETURN NFLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SNFLT'(IDENT (2.0)) = 1.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFLT 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFLT 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNFLT" ); + END; + + RESULT; + END C47005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47006a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C47006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A FIXED POINT + -- TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE VALUE OF THE + -- OPERAND DOES NOT LIE WITHIN THE RANGE OF THE TYPE MARK. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47006A IS + + TYPE FIXED IS DELTA 0.5 RANGE -5.0 .. 5.0; + + BEGIN + + TEST( "C47006A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES A FIXED POINT TYPE, " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "WHEN THE VALUE OF THE OPERAND DOES NOT LIE " & + "WITHIN THE RANGE OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SFIXED IS FIXED RANGE -2.0 .. 2.0; + + FUNCTION IDENT (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + BEGIN + IF SFIXED'(IDENT (-5.0)) = -2.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFIXED - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SFIXED - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SFIXED" ); + END; + + DECLARE + + TYPE NFIX IS NEW FIXED; + SUBTYPE SNFIX IS NFIX RANGE -2.0 .. 2.0; + + FUNCTION IDENT (X : NFIX) RETURN NFIX IS + BEGIN + RETURN NFIX (IDENT_INT (INTEGER (X))); + END IDENT; + + BEGIN + IF SNFIX'(IDENT (-5.0)) = -2.0 THEN + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFIX - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR VALUE OUTSIDE OF " & + "SUBTYPE SNFIX - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR VALUE OUTSIDE " & + "OF SUBTYPE SNFIX" ); + END; + + RESULT; + END C47006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47007a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C47007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A CONSTRAINED + -- ARRAY TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS + -- OF THE OPERAND ARE NOT THE SAME AS THE BOUNDS OF THE TYPE MARK. + + -- RJW 7/23/86 + + WITH REPORT; USE REPORT; + PROCEDURE C47007A IS + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + + TYPE TARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + + TYPE NARR IS NEW ARR; + + TYPE NTARR IS NEW TARR; + + BEGIN + + TEST( "C47007A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A CONSTRAINED ARRAY TYPE, CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED WHEN THE BOUNDS " & + "OF THE OPERAND ARE NOT THE SAME AS THE " & + "BOUNDS OF THE TYPE MARK" ); + + DECLARE + + SUBTYPE SARR IS ARR (IDENT_INT (1) .. IDENT_INT (1)); + A : ARR (IDENT_INT (2) .. IDENT_INT (2)); + BEGIN + A := SARR'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SARR" ); + END; + + DECLARE + + SUBTYPE NULLA IS ARR (IDENT_INT (1) .. IDENT_INT (0)); + A : ARR (IDENT_INT (2) .. IDENT_INT (1)); + + BEGIN + A := NULLA'(A'FIRST .. A'LAST => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLA" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLA" ); + END; + + DECLARE + + SUBTYPE STARR IS TARR (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (5)); + A : TARR (IDENT_INT (2) .. IDENT_INT (6), + IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + A := STARR'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE STARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE STARR" ); + END; + + DECLARE + + SUBTYPE NULLT IS TARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (0)); + + A : TARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (2) .. IDENT_INT (1)); + BEGIN + A := NULLT'(A'FIRST .. A'LAST => + (A'FIRST (2) .. A'LAST (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLT" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLT" ); + END; + + DECLARE + + SUBTYPE SNARR IS NARR (IDENT_INT (1) .. IDENT_INT (1)); + A : NARR (IDENT_INT (2) .. IDENT_INT (2)); + + BEGIN + A := SNARR'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SNARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SNARR" ); + END; + + DECLARE + + SUBTYPE NULLNA IS NARR (IDENT_INT (1) .. IDENT_INT (0)); + A : NARR (IDENT_INT (2) .. IDENT_INT (1)); + + BEGIN + A := NULLNA'(A'RANGE => 0); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLNA" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLNA" ); + END; + + DECLARE + + SUBTYPE SNTARR IS NTARR (IDENT_INT (1) .. IDENT_INT (1), + IDENT_INT (1) .. IDENT_INT (5)); + + A : NTARR (IDENT_INT (2) .. IDENT_INT (2), + IDENT_INT (1) .. IDENT_INT (5)); + BEGIN + A := SNTARR'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE SNTARR" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE SNTARR" ); + END; + + DECLARE + + SUBTYPE NULLNT IS NTARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (0)); + + A : NTARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + BEGIN + A := NULLNT'(A'RANGE => (A'RANGE (2) => 0)); + FAILED ( "NO EXCEPTION RAISED WHEN BOUNDS NOT THE SAME AS " & + "THOSE OF SUBTYPE NULLNT" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WHEN BOUNDS NOT " & + "THE SAME AS THOSE OF SUBTYPE NULLNT" ); + END; + + RESULT; + END C47007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47008a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,299 ---- + -- C47008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A + -- CONSTRAINED RECORD, PRIVATE, OR LIMITED PRIVATE TYPE, CHECK THAT + -- CONSTRAINT_ERROR IS RAISED WHEN THE DISCRIMINANTS OF THE OPERAND + -- DO NOT EQUAL THOSE OF THE TYPE MARK. + + -- HISTORY: + -- RJW 07/23/86 + -- DWC 07/24/87 CHANGED CODE TO TEST FOR FIRST DISCRIMINANT + -- AND LAST DISCRIMINANT MISMATCH. + + WITH REPORT; USE REPORT; + PROCEDURE C47008A IS + + TYPE GENDER IS (MALE, FEMALE, NEUTER); + + FUNCTION IDENT (G : GENDER) RETURN GENDER IS + BEGIN + RETURN GENDER'VAL (IDENT_INT (GENDER'POS (G))); + END IDENT; + + BEGIN + + TEST( "C47008A", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES A CONSTRAINED RECORD, " & + "PRIVATE, OR LIMITED PRIVATE TYPE, CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " & + "DISCRIMANTS OF THE OPERAND DO NOT EQUAL " & + "THOSE OF THE TYPE MARK" ); + + DECLARE + + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE WOMAN IS PERSON (IDENT (FEMALE)); + TOM : PERSON (MALE) := (SEX => IDENT (MALE)); + + BEGIN + IF WOMAN'(TOM) = PERSON'(SEX => MALE) THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE WOMAN - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE WOMAN" ); + END; + + DECLARE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + + SUBTYPE COUPLE IS PAIR (IDENT (FEMALE), IDENT (MALE)); + JONESES : PAIR (IDENT (MALE), IDENT (FEMALE)); + + BEGIN + IF COUPLE'(JONESES) = PAIR'(SEX1 => MALE, SEX2 => FEMALE) + THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE COUPLE - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE COUPLE" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE PERSON (SEX : GENDER) IS PRIVATE; + SUBTYPE MAN IS PERSON (IDENT (MALE)); + + TESTWRITER : CONSTANT PERSON; + + PRIVATE + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + TESTWRITER : CONSTANT PERSON := (SEX => FEMALE); + + END PKG; + + USE PKG; + + ROSA : PERSON (IDENT (FEMALE)); + + BEGIN + IF MAN'(ROSA) = TESTWRITER THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE MAN - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE MAN - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE MAN" ); + END; + + DECLARE + PACKAGE PKG IS + TYPE PAIR (SEX1, SEX2 : GENDER) IS PRIVATE; + SUBTYPE FRIENDS IS PAIR (IDENT (FEMALE), IDENT (MALE)); + + ALICE_AND_JERRY : CONSTANT FRIENDS; + + PRIVATE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + + ALICE_AND_JERRY : CONSTANT FRIENDS := + (IDENT (FEMALE), IDENT (MALE)); + + END PKG; + + USE PKG; + + DICK_AND_JOE : PAIR (IDENT (MALE), IDENT (MALE)); + + BEGIN + IF FRIENDS'(DICK_AND_JOE) = ALICE_AND_JERRY THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH DISC " & + "NOT EQUAL TO THOSE OF SUBTYPE FRIENDS - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE FRIENDS" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE PERSON (SEX : GENDER) IS LIMITED PRIVATE; + SUBTYPE ANDROID IS PERSON (IDENT (NEUTER)); + + FUNCTION F RETURN PERSON; + FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN; + PRIVATE + TYPE PERSON (SEX : GENDER) IS + RECORD + NULL; + END RECORD; + + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN PERSON IS + BEGIN + RETURN PERSON'(SEX => (IDENT (MALE))); + END F; + + FUNCTION "=" (A, B : PERSON) RETURN BOOLEAN IS + BEGIN + RETURN A.SEX = B.SEX; + END; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + BEGIN + IF ANDROID'(F) = F THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "ANDROID - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "ANDROID - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & + "WITH DISC NOT EQUAL TO THOSE OF " & + "SUBTYPE ANDROID" ); + END PKG2; + + BEGIN + NULL; + END; + + DECLARE + PACKAGE PKG1 IS + TYPE PAIR (SEX1, SEX2 : GENDER) IS LIMITED PRIVATE; + SUBTYPE LOVERS IS PAIR (IDENT (FEMALE), IDENT (MALE)); + + FUNCTION F RETURN PAIR; + FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN; + PRIVATE + TYPE PAIR (SEX1, SEX2 : GENDER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN PAIR IS + BEGIN + RETURN PAIR'(SEX1 => (IDENT (FEMALE)), + SEX2 => (IDENT (FEMALE))); + END F; + + FUNCTION "=" (A, B : PAIR) RETURN BOOLEAN IS + BEGIN + RETURN A.SEX1 = B.SEX2; + END; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + BEGIN + IF LOVERS'(F) = F THEN + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "LOVERS - 1"); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR OPERAND WITH " & + "DISC NOT EQUAL TO THOSE OF SUBTYPE " & + "LOVERS - 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR OPERAND " & + "WITH DISC NOT EQUAL TO THOSE OF " & + "SUBTYPE LOVERS" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; + END C47008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47009a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,254 ---- + -- C47009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES A + -- CONSTRAINED ACCESS TYPE, CHECK THAT CONSTRAINT_ERROR IS RAISED + -- WHEN THE VALUE OF THE OPERAND IS NOT NULL AND THE DESIGNATED + -- OBJECT HAS INDEX BOUNDS OR DISCRIMINANT VALUES THAT DO NOT EQUAL + -- THOSE SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT. + + -- HISTORY: + -- RJW 7/23/86 + -- DWC 07/24/87 REVISED TO MAKE THE ACCESS TYPE UNCONSTRAINED + -- AND TO PREVENT DEAD VARIABLE OPTIMIZATION. + + WITH REPORT; USE REPORT; + PROCEDURE C47009A IS + + BEGIN + + TEST( "C47009A", "WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION " & + "DENOTES A CONSTRAINED ACCESS TYPE, CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN THE " & + "VALUE OF THE OPERAND IS NOT NULL AND THE " & + "DESIGNATED OBJECT HAS INDEX BOUNDS OR " & + "DISCRIMINANT VALUES THAT DO NOT EQUAL THOSE " & + "SPECIFIED IN THE ACCESS TYPE'S CONSTRAINT" ); + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE ACC1 IS ACCESS ARR; + SUBTYPE ACC1S IS ACC1 (IDENT_INT (1) .. IDENT_INT (5)); + A : ACC1; + B : ARR (IDENT_INT (2) .. IDENT_INT (6)); + + BEGIN + A := ACC1S'(NEW ARR'(B'FIRST .. B'LAST => 0)); + IF A'FIRST = 1 THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC1" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + TYPE ACC2 IS ACCESS ARR; + SUBTYPE ACC2S IS ACC2 (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + A : ACC2; + B : ARR (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (2) .. IDENT_INT (2)); + + BEGIN + A := ACC2S'(NEW ARR'(B'RANGE => (B'RANGE (2) => 0))); + IF A'FIRST = 1 THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC2" ); + END; + + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC3 IS ACCESS REC; + SUBTYPE ACC3S IS ACC3 (IDENT_INT (3)); + A : ACC3; + B : REC (IDENT_INT (5)) := (D => (IDENT_INT (5))); + + BEGIN + A := ACC3S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC3" ); + END; + + DECLARE + + TYPE REC (D1,D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC4 IS ACCESS REC; + SUBTYPE ACC4S IS ACC4 (IDENT_INT (4), IDENT_INT (5)); + A : ACC4; + B : REC (IDENT_INT (5), IDENT_INT (4)) := + (D1 => (IDENT_INT (5)), D2 => (IDENT_INT (4))); + + BEGIN + A := ACC4S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC4 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC4 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " & + "DIFFERENT FROM THOSE OF TYPE ACC4" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE REC (D : INTEGER) IS PRIVATE; + + B : CONSTANT REC; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + B : CONSTANT REC := (D => (IDENT_INT (4))); + END PKG; + + USE PKG; + + TYPE ACC5 IS ACCESS REC; + SUBTYPE ACC5S IS ACC5 (IDENT_INT (3)); + A : ACC5; + + BEGIN + A := ACC5S'(NEW REC'(B)); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC5 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC5 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC VALUES " & + "DIFFERENT FROM THOSE OF TYPE ACC5" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE REC (D : INTEGER) IS LIMITED PRIVATE; + TYPE ACC6 IS ACCESS REC; + SUBTYPE ACC6S IS ACC6 (IDENT_INT (6)); + + FUNCTION F RETURN ACC6; + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE BODY PKG1 IS + + FUNCTION F RETURN ACC6 IS + BEGIN + RETURN NEW REC'(D => IDENT_INT (5)); + END F; + + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + A : ACC6; + + BEGIN + A := ACC6S'(F); + IF A = NULL THEN + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC6 - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED FOR INDEX BOUNDS " & + "DIFFERENT FROM THOSE OF TYPE ACC6 - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR DISC " & + "VALUES DIFFERENT FROM THOSE OF TYPE " & + "ACC6" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; + END C47009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47009b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47009b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c47009b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c47009b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- C47009B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- WHEN THE TYPE MARK IN A QUALIFIED EXPRESSION DENOTES AN ACCESS + -- TYPE, CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN THE VALUE + -- OF THE OPERAND IS NULL. + + -- HISTORY: + -- RJW 07/23/86 CREATED ORIGINAL TEST. + -- BCB 08/18/87 CHANGED HEADER TO STANDARD HEADER FORMAT. CHANGED + -- CONSTRAINTS OF B SUBTYPES TO VALUES WHICH ARE + -- CLOSER TO THE VALUES OF THE A SUBTYPES. INDENTED + -- THE EXCEPTION STATEMENTS IN SUBTEST 11. + + WITH REPORT; USE REPORT; + PROCEDURE C47009B IS + + BEGIN + + TEST( "C47009B", "WHEN THE TYPE MARK IN A QUALIFIED " & + "EXPRESSION DENOTES AN ACCESS TYPE, " & + "CHECK THAT CONSTRAINT_ERROR IS NOT " & + "RAISED WHEN THE VALUE OF THE OPERAND IS NULL" ); + + DECLARE + + TYPE ACC1 IS ACCESS BOOLEAN; + A : ACC1; + + BEGIN + A := ACC1'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC1" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC1" ); + END; + + DECLARE + + TYPE ACC2 IS ACCESS INTEGER; + A : ACC2; + + BEGIN + A := ACC2'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC2" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC2" ); + END; + + DECLARE + + TYPE CHAR IS ('A', 'B'); + TYPE ACC3 IS ACCESS CHAR; + A : ACC3; + + BEGIN + A := ACC3'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC3" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC3" ); + END; + + DECLARE + + TYPE FLOAT1 IS DIGITS 5 RANGE -1.0 .. 1.0; + TYPE ACC4 IS ACCESS FLOAT1; + A : ACC4; + + BEGIN + A := ACC4'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC4" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC4" ); + END; + + DECLARE + + TYPE FIXED IS DELTA 0.5 RANGE -1.0 .. 1.0; + TYPE ACC5 IS ACCESS FIXED; + A : ACC5; + + BEGIN + A := ACC5'(NULL); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR TYPE ACC5" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR TYPE ACC5" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF INTEGER; + TYPE ACC6 IS ACCESS ARR; + SUBTYPE ACC6A IS ACC6 (IDENT_INT (1) .. IDENT_INT (5)); + SUBTYPE ACC6B IS ACC6 (IDENT_INT (2) .. IDENT_INT (10)); + A : ACC6A; + B : ACC6B; + + BEGIN + A := ACC6A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC6" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC6" ); + END; + + DECLARE + + TYPE ARR IS ARRAY (NATURAL RANGE <>, NATURAL RANGE <>) + OF INTEGER; + TYPE ACC7 IS ACCESS ARR; + SUBTYPE ACC7A IS ACC7 (IDENT_INT (1) .. IDENT_INT (5), + IDENT_INT (1) .. IDENT_INT (1)); + SUBTYPE ACC7B IS ACC7 (IDENT_INT (1) .. IDENT_INT (15), + IDENT_INT (1) .. IDENT_INT (10)); + A : ACC7A; + B : ACC7B; + + BEGIN + A := ACC7A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC7" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC7" ); + END; + + DECLARE + + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC8 IS ACCESS REC; + SUBTYPE ACC8A IS ACC8 (IDENT_INT (5)); + SUBTYPE ACC8B IS ACC8 (IDENT_INT (6)); + A : ACC8A; + B : ACC8B; + + BEGIN + A := ACC8A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC8" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC8" ); + END; + + DECLARE + + TYPE REC (D1,D2 : INTEGER) IS + RECORD + NULL; + END RECORD; + + TYPE ACC9 IS ACCESS REC; + SUBTYPE ACC9A IS ACC9 (IDENT_INT (4), IDENT_INT (5)); + SUBTYPE ACC9B IS ACC9 (IDENT_INT (5), IDENT_INT (4)); + A : ACC9A; + B : ACC9B; + + BEGIN + A := ACC9A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC9" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC9" ); + END; + + DECLARE + + PACKAGE PKG IS + TYPE REC (D : INTEGER) IS PRIVATE; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + + END PKG; + + USE PKG; + + TYPE ACC10 IS ACCESS REC; + SUBTYPE ACC10A IS ACC10 (IDENT_INT (10)); + SUBTYPE ACC10B IS ACC10 (IDENT_INT (9)); + A : ACC10A; + B : ACC10B; + + BEGIN + A := ACC10A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF " & + "TYPE ACC10" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC10" ); + END; + + DECLARE + + PACKAGE PKG1 IS + TYPE REC (D : INTEGER) IS LIMITED PRIVATE; + + PRIVATE + TYPE REC (D : INTEGER) IS + RECORD + NULL; + END RECORD; + END PKG1; + + PACKAGE PKG2 IS END PKG2; + + PACKAGE BODY PKG2 IS + USE PKG1; + + TYPE ACC11 IS ACCESS REC; + SUBTYPE ACC11A IS ACC11 (IDENT_INT (11)); + SUBTYPE ACC11B IS ACC11 (IDENT_INT (12)); + A : ACC11A; + B : ACC11B; + + BEGIN + A := ACC11A'(B); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR SUBTYPES OF" & + " TYPE ACC11" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR SUBTYPES OF " & + "TYPE ACC11" ); + END PKG2; + + BEGIN + NULL; + END; + + RESULT; + END C47009B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C48004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A SCALAR SUBTYPE. + + -- RM 01/12/80 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48004A IS + + USE REPORT; + + BEGIN + + TEST("C48004A","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS A SCALAR SUBTYPE"); + + DECLARE + + SUBTYPE TA IS INTEGER RANGE 1 .. 7; + TYPE ATA IS ACCESS TA; + VA : ATA; + + BEGIN + + VA := NEW TA; + VA.ALL := IDENT_INT(6); + IF VA.ALL /= 6 THEN + FAILED ("INCORRECT VALUE"); + END IF; + + END; + + RESULT; + + END C48004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- C48004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED + -- RECORD, PRIVATE, OR LIMITED PRIVATE TYPE. + + -- RM 01/12/80 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48004B IS + + USE REPORT; + + BEGIN + + TEST("C48004B","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS A CONSTRAINED RECORD, PRIVATE, OR " & + "LIMITED PRIVATE TYPE"); + + DECLARE + + TYPE TB0(A , B : INTEGER ) IS + RECORD + C : INTEGER := 7; + END RECORD; + SUBTYPE TB IS TB0( 2 , 3 ); + TYPE ATB IS ACCESS TB0; + VB : ATB; + + TYPE TBB0( A , B : INTEGER := 5 ) IS + RECORD + C : INTEGER := 6; + END RECORD; + SUBTYPE TBB IS TBB0( 4 , 5 ); + TYPE ATBB IS ACCESS TBB0; + VBB : ATBB; + + PACKAGE P IS + TYPE PRIV0( A , B : INTEGER ) IS PRIVATE; + TYPE LPRIV0( A , B : INTEGER := 1 ) IS LIMITED PRIVATE; + FUNCTION FUN(LP : LPRIV0) RETURN INTEGER; + PRIVATE + TYPE PRIV0( A , B : INTEGER ) IS + RECORD + Q : INTEGER; + END RECORD; + TYPE LPRIV0( A , B : INTEGER := 1 ) IS + RECORD + Q : INTEGER := 7; + END RECORD; + END P; + + USE P; + + SUBTYPE PRIV IS P.PRIV0( 12 , 13 ); + TYPE A_PRIV IS ACCESS P.PRIV0; + VP : A_PRIV; + + TYPE A_LPRIV IS ACCESS LPRIV0; + VLP : A_LPRIV; + + TYPE LCR(A, B : INTEGER := 4) IS + RECORD + C : P.LPRIV0; + END RECORD; + SUBTYPE SLCR IS LCR(1, 2); + TYPE A_SLCR IS ACCESS SLCR; + VSLCR : A_SLCR; + + PACKAGE BODY P IS + FUNCTION FUN(LP : LPRIV0) RETURN INTEGER IS + BEGIN + RETURN LP.Q; + END FUN; + END P; + + BEGIN + + VB := NEW TB; + IF ( VB.A /= IDENT_INT(2) OR + VB.B /= 3 OR + VB.C /= 7 ) THEN FAILED( "WRONG VALUES - B1" ); + END IF; + + VBB := NEW TBB0; + IF ( VBB.A /= IDENT_INT(5) OR + VBB.B /= 5 OR + VBB.C /= 6 ) THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + VP := NEW PRIV; + IF ( VP.A /= IDENT_INT(12) OR + VP.B /= 13 ) THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + VLP := NEW LPRIV0; + IF ( VLP.A /= IDENT_INT(1) OR + VLP.B /= 1 OR + P.FUN(VLP.ALL) /= IDENT_INT(7) ) THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + VSLCR := NEW SLCR; + IF ( VSLCR.A /= IDENT_INT(1) OR + VSLCR.B /= IDENT_INT(2) OR + P.FUN(VSLCR.C) /= IDENT_INT(7) ) THEN + FAILED ("WRONG VALUES - B5"); + END IF; + + END; + + RESULT; + + END C48004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C48004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS AN UNCONSTRAINED + -- RECORD, PRIVATE, OR LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT + -- VALUES. + + -- EG 08/03/84 + + WITH REPORT; + + PROCEDURE C48004C IS + + USE REPORT; + + BEGIN + + TEST("C48004C","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF " & + "T IS AN UNCONSTRAINED RECORD, PRIVATE, OR " & + "LIMITED TYPE WHOSE DISCRIMINANTS HAVE DEFAULT " & + "VALUES"); + + DECLARE + + TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS + RECORD + C : INTEGER := 7; + END RECORD; + + PACKAGE P IS + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS PRIVATE; + TYPE UL(A, B : INTEGER := 1) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + RECORD + Q : INTEGER; + END RECORD; + TYPE UL(A, B : INTEGER := 1) IS + RECORD + Q : INTEGER; + END RECORD; + + END P; + + USE P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UP IS ACCESS UP; + TYPE A_UL IS ACCESS UL; + + V_UR : A_UR; + V_UP : A_UP; + V_UL : A_UL; + + BEGIN + + V_UR := NEW UR; + IF ( V_UR.A /= IDENT_INT(1) OR V_UR.B /= 2 OR + V_UR.C /= 7 ) THEN + FAILED("WRONG VALUES - UR"); + END IF; + + V_UP := NEW UP; + IF ( V_UP.A /= IDENT_INT(12) OR V_UP.B /= 13 ) THEN + FAILED("WRONG VALUES - UP"); + END IF; + + V_UL := NEW UL; + IF ( V_UL.A /= IDENT_INT(1) OR V_UL.B /= 1 ) THEN + FAILED("WRONG VALUES - UL"); + END IF; + + END; + + RESULT; + + END C48004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C48004D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A RECORD, PRIVATE, + -- OR LIMITED TYPE WITHOUT DISCRIMINANTS. + + -- RM 01/12/80 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48004D IS + + USE REPORT; + + BEGIN + + TEST("C48004D","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS A RECORD, PRIVATE, OR LIMITED TYPE WITHOUT " & + "DISCRIMINANTS"); + + DECLARE + + TYPE TC IS + RECORD + C : INTEGER := 18; + END RECORD; + TYPE ATC IS ACCESS TC; + VC : ATC; + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + TYPE LPRIV IS LIMITED PRIVATE; + TYPE A_PRIV IS ACCESS PRIV; + TYPE A_LPRIV IS ACCESS LPRIV; + PROCEDURE CHECK( X: A_PRIV ); + PROCEDURE LCHECK( X: A_LPRIV ); + PROCEDURE LRCHECK( X: LPRIV ); + PRIVATE + TYPE PRIV IS + RECORD + Q : INTEGER := 19; + END RECORD; + TYPE LPRIV IS + RECORD + Q : INTEGER := 20; + END RECORD; + END P; + + + VP : P.A_PRIV; + VLP : P.A_LPRIV; + + TYPE LCR IS + RECORD + C : P.LPRIV; + END RECORD; + TYPE A_LCR IS ACCESS LCR; + VLCR : A_LCR; + + PACKAGE BODY P IS + + PROCEDURE CHECK( X: A_PRIV ) IS + BEGIN + IF X.Q /= 19 THEN FAILED( "WRONG VALUES - C2" ); + END IF; + END CHECK; + + PROCEDURE LCHECK( X: A_LPRIV ) IS + BEGIN + IF X.Q /= 20 THEN FAILED( "WRONG VALUES - C3" ); + END IF; + END LCHECK; + + PROCEDURE LRCHECK (X : LPRIV) IS + BEGIN + IF X.Q /= 20 THEN + FAILED ("WRONG VALUES - C4"); + END IF; + END LRCHECK; + + END P; + + BEGIN + + VC := NEW TC; + IF VC.C /= 18 THEN FAILED( "WRONG VALUES - C1" ); + END IF; + + VP := NEW P.PRIV; + P.CHECK( VP ); + VLP := NEW P.LPRIV; + P.LCHECK( VLP ); + + VLCR := NEW LCR; + P.LRCHECK( VLCR.ALL.C ); + + END; + + RESULT; + + END C48004D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C48004E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS A CONSTRAINED ARRAY + -- TYPE. + + -- RM 01/12/80 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48004E IS + + USE REPORT; + + BEGIN + + TEST("C48004E","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS A CONSTRAINED ARRAY TYPE"); + + DECLARE + + TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN; + SUBTYPE ARR IS ARR0(1 .. 10); + TYPE A_ARR IS ACCESS ARR; + VARR : A_ARR; + + PACKAGE P IS + TYPE LPRIV IS LIMITED PRIVATE; + FUNCTION CHECK (X : LPRIV) RETURN INTEGER; + PRIVATE + TYPE LPRIV IS + RECORD + Q : INTEGER := 20; + END RECORD; + END P; + + TYPE LPARR IS ARRAY(1 .. 2) OF P.LPRIV; + TYPE A_LPARR IS ACCESS LPARR; + + V_A_LPARR : A_LPARR; + + PACKAGE BODY P IS + FUNCTION CHECK (X : LPRIV) RETURN INTEGER IS + BEGIN + RETURN X.Q; + END CHECK; + END P; + + BEGIN + + VARR := NEW ARR; + IF ( VARR'FIRST /= IDENT_INT(1) OR + VARR'LAST /= 10 ) THEN FAILED("WRONG BOUNDS - CASE 1"); + END IF; + + V_A_LPARR := NEW LPARR; + IF ( P.CHECK(V_A_LPARR.ALL(1)) /= IDENT_INT(20) OR + P.CHECK(V_A_LPARR.ALL(2)) /= IDENT_INT(20) ) THEN + FAILED ("WRONG VALUES - CASE 2"); + END IF; + + END; + + RESULT; + + END C48004E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48004f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48004f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C48004F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORM "NEW T" IS PERMITTED IF T IS AN ACCESS TYPE. + + -- RM 01/12/80 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48004F IS + + USE REPORT; + + BEGIN + + TEST("C48004F","CHECK THAT THE FORM 'NEW T' IS PERMITTED IF T " & + "IS AN ACCESS TYPE"); + + DECLARE + + TYPE AINT IS ACCESS INTEGER; + TYPE A_AINT IS ACCESS AINT; + VA_AINT : A_AINT; + + TYPE AST IS ACCESS STRING; + SUBTYPE CAST_4 IS AST(1 .. 4); + TYPE A_AST IS ACCESS AST; + TYPE ACAST_3 IS ACCESS AST(1 .. 3); + V_AAST : A_AST; + V_ACAST_3 : ACAST_3; + + TYPE UR(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + SUBTYPE CR IS UR(1, 2); + TYPE A_CR IS ACCESS CR; + TYPE AA_CR IS ACCESS A_CR; + V_AA_CR : AA_CR; + + BEGIN + + VA_AINT := NEW AINT; + IF VA_AINT.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 1"); + END IF; + + BEGIN + + V_ACAST_3 := NEW CAST_4; + IF V_ACAST_3.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 2"); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - CASE 2"); + + END; + + V_AAST := NEW AST; + IF V_AAST.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 3"); + END IF; + + V_AA_CR := NEW A_CR; + IF V_AA_CR.ALL /= NULL THEN + FAILED ("VARIABLE IS NOT NULL - CASE 4"); + END IF; + + END; + + RESULT; + + END C48004F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48005a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- C48005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT + -- EACH TIME IT IS EXECUTED AND THAT IF T IS AN UNCONSTRAINED RECORD, + -- PRIVATE, OR LIMITED TYPE, THE ALLOCATED OBJECT HAS THE DISCRIMINANT + -- VALUES SPECIFIED BY X. + + -- EG 08/08/84 + + WITH REPORT; + + PROCEDURE C48005A IS + + USE REPORT; + + BEGIN + + TEST("C48005A","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " & + "NEW OBJECT AND THAT IF T IS AN UNCONSTRAINED " & + "RECORD, PRIVATE, OR LIMITED TYPE, THE " & + "ALLOCATED OBJECT HAS THE DISCRIMINANT " & + "VALUES SPECIFIED BY X"); + + DECLARE + + TYPE UR1(A : INTEGER) IS + RECORD + B : INTEGER := 7; + C : INTEGER := 4; + END RECORD; + TYPE UR2(A : INTEGER) IS + RECORD + CASE A IS + WHEN 1 => + A1 : INTEGER := 4; + WHEN 2 => + A2 : INTEGER := 5; + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + + TYPE A_UR1 IS ACCESS UR1; + TYPE A_UR2 IS ACCESS UR2; + + V1AUR1 : A_UR1; + V1AUR2, V2AUR2 : A_UR2; + + TYPE REC (A : INTEGER) IS + RECORD + B : INTEGER; + END RECORD; + + TYPE A_REC IS ACCESS REC; + + V_A_REC : A_REC; + + TYPE ARR IS ARRAY(1 .. 1) OF INTEGER; + + TYPE RECVAL IS + RECORD + A : INTEGER; + B : ARR; + END RECORD; + + FUNCTION FUN (A : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(A); + END FUN; + FUNCTION FUN (A : INTEGER) RETURN RECVAL IS + BEGIN + FAILED ("WRONG OVERLOADED FUNCTION CALLED"); + RETURN (1, (1 => 2)); + END FUN; + + BEGIN + + V1AUR1 := NEW UR1(3); + IF ( V1AUR1.A /= 3 OR V1AUR1.B /= 7 OR + V1AUR1.C /= IDENT_INT(4) ) THEN + FAILED("WRONG VALUES - V1UAR1"); + END IF; + + V1AUR2 := NEW UR2(IDENT_INT(2)); + IF ( V1AUR2.A /= 2 OR V1AUR2.A2 /= IDENT_INT(5) ) THEN + FAILED("WRONG VALUES - V1AUR2"); + END IF; + + V2AUR2 := NEW UR2(IDENT_INT(3)); + IF ( V2AUR2.A /= IDENT_INT(3) ) THEN + FAILED("WRONG VALUES - V2AUR2"); + END IF; + + V_A_REC := NEW REC(FUN(2)); + END; + + RESULT; + + END C48005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48005b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- C48005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T X" ALLOCATES A NEW OBJECT + -- EACH TIME IT IS EXECUTED AND THAT IF X IS AN INDEX CONSTRAINT AND T + -- AN UNCONSTRAINED ARRAY TYPE, THE ALLOCATED OBJECT HAS THE INDEX + -- BOUNDS SPECIFIED BY X. + + -- EG 08/10/84 + + WITH REPORT; + + PROCEDURE C48005B IS + + USE REPORT; + + BEGIN + + TEST("C48005B","CHECK THAT THE FORM 'NEW T X' ALLOCATES A " & + "NEW OBJECT AND THAT IF X IS AN INDEX " & + "CONSTRAINT AND T AN UNCONSTRAINED ARRAY " & + "TYPE, THE ALLOCATED OBJECT HAS THE INDEX " & + "BOUND SPECIFIED BY X"); + + DECLARE + + TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) + OF INTEGER; + + TYPE A_UA1 IS ACCESS UA1; + TYPE A_UA2 IS ACCESS UA2; + + V_A_UA1 : A_UA1; + V_A_UA2 : A_UA2; + + BEGIN + + V_A_UA1 := NEW UA1(4 .. 7); + IF ( V_A_UA1'FIRST /= IDENT_INT(4) OR + V_A_UA1'LAST /= IDENT_INT(7) ) THEN + FAILED("WRONG ARRAY BOUNDS - V_A_UA1"); + END IF; + + V_A_UA2 := NEW UA2(2 .. 3, 4 .. 6); + IF ( V_A_UA2'FIRST(1) /= IDENT_INT(2) OR + V_A_UA2'LAST(1) /= IDENT_INT(3) OR + V_A_UA2'FIRST(2) /= IDENT_INT(4) OR + V_A_UA2'LAST(2) /= IDENT_INT(6) ) THEN + FAILED("WRONG ARRAY BOUNDS - V_A_UA2"); + END IF; + + END; + + RESULT; + + END C48005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48006a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C48006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW + -- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A SCALAR OR ACCESS + -- TYPE, THE ALLOCATED OBJECT HAS THE VALUE OF X. + + -- RM 01/14/80 + -- RM 01/O1/82 + -- SPS 10/27/82 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48006A IS + + USE REPORT; + + BEGIN + + TEST("C48006A","CHECK THAT THE FORM 'NEW T'(X)' " & + "ALLOCATES A NEW OBJECT " & + "AND THAT IF T IS A SCALAR OR ACCESS TYPE, THE " & + "ALLOCATED OBJECT HAS THE VALUE OF X"); + + DECLARE + + TYPE ATA IS ACCESS INTEGER; + TYPE AATA IS ACCESS ATA; + VA1, VA2, VA3 : ATA; + VAA1, VAA2, VAA3 : AATA; + + BEGIN + + VA1 := NEW INTEGER'(5 + 7); + IF VA1.ALL /= IDENT_INT(12) THEN + FAILED("WRONG VALUES - VA1"); + END IF; + + VA2 := NEW INTEGER'(1 + 2); + IF (VA1.ALL /= IDENT_INT(12) OR + VA2.ALL /= IDENT_INT( 3)) THEN + FAILED("WRONG VALUES - VA2"); + END IF; + + VA3 := NEW INTEGER'(IDENT_INT(3) + IDENT_INT(4)); + IF (VA1.ALL /= IDENT_INT(12) OR + VA2.ALL /= IDENT_INT( 3) OR + VA3.ALL /= IDENT_INT( 7)) THEN + FAILED("WRONG VALUES - VA3"); + END IF; + + VAA1 := NEW ATA'(NEW INTEGER'(3)); + IF VAA1.ALL.ALL /= IDENT_INT(3) THEN + FAILED ("WRONG VALUES - VAA1"); + END IF; + + VAA2 := NEW ATA'(NEW INTEGER'(IDENT_INT(5))); + IF (VAA1.ALL.ALL /= 3 OR + VAA2.ALL.ALL /= 5 ) THEN + FAILED ("WRONG VALUES - VAA2"); + END IF; + + VAA3 := NEW ATA'(NEW INTEGER'(IDENT_INT(6))); + IF (VAA1.ALL.ALL /= 3 OR + VAA2.ALL.ALL /= 5 OR + VAA3.ALL.ALL /= 6 ) THEN + FAILED ("WRONG VALUES - VAA3"); + END IF; + + END; + + RESULT; + + END C48006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48006b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,236 ---- + -- C48006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ALLOCATOR OF THE FORM "NEW T'(X)" ALLOCATES A NEW + -- OBJECT EACH TIME IT IS EXECUTED AND THAT IF T IS A RECORD, ARRAY, OR + -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED), THE ALLOCATED OBJECT HAS + -- THE VALUE OF (X). + + -- RM 01/14/80 + -- RM 01/O1/82 + -- SPS 10/27/82 + -- EG 07/05/84 + -- JBG 11/08/85 AVOID CONFLICT WITH AI-7 OR AI-275 + + WITH REPORT; + + PROCEDURE C48006B IS + + USE REPORT ; + + BEGIN + + TEST("C48006B","CHECK THAT THE FORM 'NEW T'(X)' " & + "ALLOCATES A NEW OBJECT " & + "AND THAT IF T IS A RECORD, ARRAY, OR PRIVATE " & + "TYPE, THE ALLOCATED OBJECT HAS THE VALUE (X)"); + + -- RECORD OR ARRAY TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + TYPE TB0( A , B : INTEGER ) IS + RECORD + C : INTEGER := 7 ; + END RECORD; + SUBTYPE TB IS TB0( 2 , 3 ); + TYPE ATB IS ACCESS TB ; + TYPE ATB0 IS ACCESS TB0 ; + VB1 , VB2 : ATB ; + VB01 , VB02 : ATB0 ; + + TYPE ARR0 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + SUBTYPE ARR IS ARR0( 1..4 ); + TYPE A_ARR IS ACCESS ARR ; + TYPE A_ARR0 IS ACCESS ARR0 ; + VARR1 , VARR2 : A_ARR ; + VARR01 , VARR02 : A_ARR0 ; + + BEGIN + + VB1 := NEW TB'( 2 , 3 , 5 ); + IF ( VB1.A /=IDENT_INT( 2) OR + VB1.B /=IDENT_INT( 3) OR + VB1.C /=IDENT_INT( 5) ) + THEN FAILED( "WRONG VALUES - B1 1" ); + END IF; + + VB2 := NEW TB'( IDENT_INT(2), IDENT_INT(3), IDENT_INT(6)); + IF ( VB2.A /= 2 OR + VB2.B /= 3 OR + VB2.C /= 6 OR + VB1.A /= 2 OR + VB1.B /= 3 OR + VB1.C /= 5 ) + THEN FAILED( "WRONG VALUES - B1 2" ); + END IF; + + VB01 := NEW TB0'( 1 , 2 , 3 ); + IF ( VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 1" ); + END IF; + + VB02 := NEW TB0'( IDENT_INT(4) , IDENT_INT(5) , + IDENT_INT(6) ); + IF ( VB02.A /=IDENT_INT( 4) OR + VB02.B /=IDENT_INT( 5) OR + VB02.C /=IDENT_INT( 6) OR + VB01.A /=IDENT_INT( 1) OR + VB01.B /=IDENT_INT( 2) OR + VB01.C /=IDENT_INT( 3) ) + THEN FAILED( "WRONG VALUES - B2 2" ); + END IF; + + VARR1 := NEW ARR'( 5 , 6 , 7 , 8 ); + IF ( VARR1(1) /=IDENT_INT( 5) OR + VARR1(2) /=IDENT_INT( 6) OR + VARR1(3) /=IDENT_INT( 7) OR + VARR1(4) /=IDENT_INT( 8) ) + THEN FAILED( "WRONG VALUES - B3 1" ); + END IF ; + + VARR2 := NEW ARR'( IDENT_INT(1) , IDENT_INT(2) , IDENT_INT(3), + IDENT_INT(4) ); + IF ( VARR2(1) /= 1 OR + VARR2(2) /= 2 OR + VARR2(3) /= 3 OR + VARR2(4) /= 4 OR + VARR1(1) /= 5 OR + VARR1(2) /= 6 OR + VARR1(3) /= 7 OR + VARR1(4) /= 8 ) + THEN FAILED( "WRONG VALUES - B3 2" ); + END IF ; + + VARR01 := NEW ARR0'( 11 , 12 , 13 ); + IF ( VARR01(INTEGER'FIRST) /= IDENT_INT(11) OR + VARR01(INTEGER'FIRST + 1) /= IDENT_INT(12) OR + VARR01(INTEGER'FIRST + 2) /= IDENT_INT(13) ) + THEN FAILED( "WRONG VALUES - B4 1" ); + END IF ; + IF ( VARR01.ALL'FIRST /= IDENT_INT( INTEGER'FIRST ) OR + VARR01.ALL'LAST /= IDENT_INT( INTEGER'FIRST + 2 ) ) + THEN FAILED( "WRONG VALUES - B4 2" ); + END IF ; + + VARR02 := NEW ARR0'( 1 => IDENT_INT(14) , 2 => IDENT_INT(15)); + IF ( VARR02(1) /= 14 OR + VARR02(2) /= 15 OR + VARR01(INTEGER'FIRST) /= 11 OR + VARR01(INTEGER'FIRST + 1) /= 12 OR + VARR01(INTEGER'FIRST + 2) /= 13 ) + THEN FAILED( "WRONG VALUES - B4 3" ); + END IF ; + + END ; + + -- PRIVATE TYPE (CONSTRAINED OR UNCONSTRAINED) + + DECLARE + + PACKAGE P IS + TYPE UP(A, B : INTEGER) IS PRIVATE; + -- SUBTYPE CP IS UP(1, 2); + -- TYPE A_CP IS ACCESS CP; + TYPE A_UP IS ACCESS UP; + CONS1_UP : CONSTANT UP; + CONS2_UP : CONSTANT UP; + CONS3_UP : CONSTANT UP; + CONS4_UP : CONSTANT UP; + -- PROCEDURE CHECK1 (X : A_CP); + -- PROCEDURE CHECK2 (X, Y : A_CP); + PROCEDURE CHECK3 (X : A_UP); + PROCEDURE CHECK4 (X, Y : A_UP); + PRIVATE + TYPE UP(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + CONS1_UP : CONSTANT UP := (1, 2, 3); + CONS2_UP : CONSTANT UP := (IDENT_INT(1), IDENT_INT(2), + IDENT_INT(4)); + CONS3_UP : CONSTANT UP := (7, 8, 9); + CONS4_UP : CONSTANT UP := (IDENT_INT(10), IDENT_INT(11), + IDENT_INT(12)); + END P; + + USE P; + + -- V_A_CP1, V_A_CP2 : A_CP; + V_A_UP1, V_A_UP2 : A_UP; + + PACKAGE BODY P IS + -- PROCEDURE CHECK1 (X : A_CP) IS + -- BEGIN + -- IF (X.A /= IDENT_INT(1) OR + -- X.B /= IDENT_INT(2) OR + -- X.C /= IDENT_INT(3)) THEN + -- FAILED ("WRONG VALUES - CP1"); + -- END IF; + -- END CHECK1; + -- PROCEDURE CHECK2 (X, Y : A_CP) IS + -- BEGIN + -- IF (X.A /= 1 OR X.B /= 2 OR X.C /= 3 OR + -- Y.A /= 1 OR Y.B /= 2 OR Y.C /= 4) THEN + -- FAILED ("WRONG VALUES - CP2"); + -- END IF; + -- END CHECK2; + PROCEDURE CHECK3 (X : A_UP) IS + BEGIN + IF (X.A /= IDENT_INT(7) OR + X.B /= IDENT_INT(8) OR + X.C /= IDENT_INT(9)) THEN + FAILED ("WRONG VALUES - UP1"); + END IF; + END CHECK3; + PROCEDURE CHECK4 (X, Y : A_UP) IS + BEGIN + IF (X.A /= 7 OR X.B /= 8 OR X.C /= 9 OR + Y.A /= 10 OR Y.B /= 11 OR Y.C /= 12) THEN + FAILED ("WRONG VALUES - UP2"); + END IF; + END CHECK4; + END P; + + BEGIN + + -- V_A_CP1 := NEW CP'(CONS1_UP); + -- CHECK1(V_A_CP1); + + -- V_A_CP2 := NEW CP'(CONS2_UP); + -- CHECK2(V_A_CP1, V_A_CP2); + + V_A_UP1 := NEW P.UP'(CONS3_UP); + CHECK3(V_A_UP1); + + V_A_UP2 := NEW P.UP'(CONS4_UP); + CHECK4(V_A_UP1, V_A_UP2); + + END; + + RESULT; + + END C48006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C48007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS + -- RAISED IF T IS AN UNCONSTRAINED TYPE WITH DEFAULT DISCRIMINANTS + -- (RECORD, PRIVATE OR LIMITED) AND ONE DEFAULT DISCRIMINANT VALUE DOES + -- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE + -- TYPE. + + -- EG 08/10/84 + + WITH REPORT; + + PROCEDURE C48007A IS + + USE REPORT; + + BEGIN + + TEST("C48007A","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED TYPE WITH " & + "DEFAULT DISCRIMINANTS"); + + DECLARE + + TYPE UR(A : INTEGER := 1; B : INTEGER := 2) IS + RECORD + C : INTEGER := 7; + END RECORD; + + PACKAGE P IS + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + PRIVATE; + TYPE UL(A, B : INTEGER := 4) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A : INTEGER := 12; B : INTEGER := 13) IS + RECORD + C : INTEGER := 8; + END RECORD; + TYPE UL(A, B : INTEGER := 4) IS + RECORD + C : INTEGER := 9; + END RECORD; + + END P; + + USE P; + + TYPE A_UR IS ACCESS UR(1, 9); + TYPE A_UP IS ACCESS UP(9, 13); + TYPE A_UL IS ACCESS UL(4, 9); + + VUR : A_UR; + VUP : A_UP; + VUL : A_UL; + + BEGIN + + BEGIN -- UR + + VUR := NEW UR; + FAILED("NO EXCEPTION RAISED - UR"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UR"); + + END; + + BEGIN -- UP + + VUP := NEW UP; + FAILED("NO EXCEPTION RAISED - UP"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UP"); + + END; + + BEGIN -- UL + + VUL := NEW UL; + FAILED("NO EXCEPTION RAISED - UL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - UL"); + + END; + + END; + + RESULT; + + END C48007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C48007B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS + -- RAISED IF T IS A CONSTRAINED TYPE WITH DISCRIMINANTS (RECORD, PRIVATE + -- OR LIMITED) AND AT LEAST ONE DISCRIMINANT VALUE SPECIFIED FOR T DOES + -- NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE ALLOCATOR'S BASE + -- TYPE. + + -- EG 08/10/84 + + WITH REPORT; + + PROCEDURE C48007B IS + + USE REPORT; + + BEGIN + + TEST("C48007B","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED TYPE WITH " & + "DISCRIMINANT"); + + DECLARE + + TYPE UR(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + PACKAGE P IS + + TYPE UP(A, B : INTEGER) IS PRIVATE; + TYPE UL(A, B : INTEGER) IS LIMITED PRIVATE; + + PRIVATE + + TYPE UP(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + TYPE UL(A, B : INTEGER) IS + RECORD + C : INTEGER; + END RECORD; + + END P; + + USE P; + + SUBTYPE CR IS UR(1, 2); + SUBTYPE CP IS UP(12, 13); + SUBTYPE CL IS UL(4, 4); + + TYPE A_UR IS ACCESS UR(1, 9); + TYPE A_UP IS ACCESS UP(9, 13); + TYPE A_UL IS ACCESS UL(4, 9); + + VUR : A_UR; + VUP : A_UP; + VUL : A_UL; + + BEGIN + + BEGIN -- CR + + VUR := NEW CR; + FAILED("NO EXCEPTION RAISED - CR"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CR"); + + END; + + BEGIN -- CP + + VUP := NEW CP; + FAILED("NO EXCEPTION RAISED - CP"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CP"); + + END; + + BEGIN -- CL + + VUL := NEW CL; + FAILED("NO EXCEPTION RAISED - CL"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CL"); + + END; + + END; + + RESULT; + + END C48007B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48007c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48007c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,162 ---- + -- C48007C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T", CHECK THAT CONSTRAINT_ERROR IS + -- RAISED IF T IS A CONSTRAINED ARRAY TYPE AND AT LEAST ONE INDEX BOUND + -- FOR T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED FOR THE + -- ALLOCATOR'S BASE TYPE. + + -- EG 08/10/84 + + WITH REPORT; + + PROCEDURE C48007C IS + + USE REPORT; + + BEGIN + + TEST("C48007C","FOR ALLOCATORS OF THE FORM 'NEW T' CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ARRAY TYPE"); + + DECLARE + + TYPE UA1 IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE UA2 IS ARRAY(INTEGER RANGE <>, INTEGER RANGE <>) OF + INTEGER; + TYPE UA3 IS ARRAY(INTEGER RANGE <>) OF UA1(1 .. 2); + + SUBTYPE CA11 IS UA1(1 .. 3); + SUBTYPE CA12 IS UA1(3 .. 2); + SUBTYPE CA21 IS UA2(1 .. 2, 1 .. 2); + SUBTYPE CA22 IS UA2(1 .. 2, 2 .. 0); + SUBTYPE CA31 IS UA3(1 .. 2); + SUBTYPE CA32 IS UA3(4 .. 1); + + TYPE A_UA11 IS ACCESS UA1(2 .. 4); + TYPE A_UA12 IS ACCESS UA1(4 .. 3); + TYPE A_UA21 IS ACCESS UA2(1 .. 3, 1 .. 2); + TYPE A_UA22 IS ACCESS UA2(1 .. 2, 2 .. 1); + TYPE A_UA31 IS ACCESS UA3(1 .. 3); + TYPE A_UA32 IS ACCESS UA3(3 .. 1); + + V11 : A_UA11; + V12 : A_UA12; + V21 : A_UA21; + V22 : A_UA22; + V31 : A_UA31; + V32 : A_UA32; + + BEGIN + + BEGIN -- V11 + + V11 := NEW CA11; + FAILED("NO EXCEPTION RAISED - V11"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V11"); + + END; + + BEGIN -- V12 + + V12 := NEW CA12; + FAILED("NO EXCEPTION RAISED - V12"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V12"); + + END; + + BEGIN -- V21 + + V21 := NEW CA21; + FAILED("NO EXCEPTION RAISED - V21"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V21"); + + END; + + BEGIN -- V22 + + V22 := NEW CA22; + FAILED("NO EXCEPTION RAISED - V22"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V22"); + + END; + + BEGIN -- V31 + + V31 := NEW CA31; + FAILED("NO EXCEPTION RAISED - V31"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V31"); + + END; + + BEGIN -- V32 + + V32 := NEW CA32; + FAILED("NO EXCEPTION RAISED - V32"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - V32"); + + END; + + END; + + RESULT; + + END C48007C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48008a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,345 ---- + -- C48008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS + -- RAISED IF T IS AN UNCONSTRAINED RECORD, PRIVATE, OR LIMITED TYPE, X + -- IS A DISCRIMINANT CONSTRAINT, AND + -- 1) ONE OF THE VALUES OF X IS OUTSIDE THE RANGE OF THE CORRESPONDING + -- DISCRIMINANT; + -- 2) ONE OF THE DISCRIMINANT VALUES IS NOT COMPATIBLE WITH A + -- CONSTRAINT OF A SUBCOMPONENT IN WHICH IT IS USED; + -- 3) ONE OF THE DISCRIMINANT VALUES DOES NOT EQUAL THE CORRESPONDING + -- VALUE OF THE ALLOCATOR'S BASE TYPE; + -- 4) A DEFAULT INITIALIZATION RAISES AN EXCEPTION. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/02/83 + -- EG 07/05/84 + -- PWB 02/05/86 CORRECTED TEST ERROR: + -- CHANGED "FAILED" TO "COMMENT" IN PROCEDURE INCR_CHECK, + -- SO AS NOT TO PROHIBIT EVAL OF DEFLT EXPR (AI-00397/01) + -- ADDED COMMENTS FOR CASES. + + WITH REPORT; + + PROCEDURE C48008A IS + + USE REPORT; + + BEGIN + + TEST( "C48008A" , "FOR ALLOCATORS OF THE FORM 'NEW T X', " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED RECORD AND " & + "PRIVATE TYPES"); + + DECLARE + + DISC_FLAG : BOOLEAN := FALSE; + INCR_VAL : INTEGER; + FUNCTION INCR(A : INTEGER) RETURN INTEGER; + + SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); + SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); + SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); + + TYPE REC (A : I2_9) IS + RECORD + B : INTEGER := INCR(2); + END RECORD; + + TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; + + TYPE T_REC (C : I1_10) IS + RECORD + D : REC(C); + END RECORD; + + TYPE T_ARR (C : I1_10) IS + RECORD + D : ARR(2..C); + E : ARR(C..9); + END RECORD; + + TYPE T_REC_REC (A : I1_10) IS + RECORD + B : T_REC(A); + END RECORD; + + TYPE T_REC_ARR (A : I1_10) IS + RECORD + B : T_ARR(A); + END RECORD; + + TYPE TB ( A : I1_7 ) IS + RECORD + R : INTEGER := INCR(1); + END RECORD; + + TYPE UR (A : INTEGER) IS + RECORD + B : I2_9 := INCR(1); + END RECORD; + + TYPE A_T_REC_REC IS ACCESS T_REC_REC; + TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; + TYPE ATB IS ACCESS TB; + TYPE ACTB IS ACCESS TB(3); + TYPE A_UR IS ACCESS UR; + + VA_T_REC_REC : A_T_REC_REC; + VA_T_REC_ARR : A_T_REC_ARR; + VB : ATB; + VCB : ACTB; + V_A_UR : A_UR; + + BOOL : BOOLEAN; + + FUNCTION DISC (A : INTEGER) RETURN INTEGER; + + + PACKAGE P IS + TYPE PRIV( A : I1_10 := DISC(8) ) IS PRIVATE; + CONS_PRIV : CONSTANT PRIV; + PRIVATE + TYPE PRIV( A : I1_10 := DISC(8) ) IS + RECORD + R : INTEGER := INCR(1); + END RECORD; + CONS_PRIV : CONSTANT PRIV := (2, 3); + END P; + + TYPE A_PRIV IS ACCESS P.PRIV; + TYPE A_CPRIV IS ACCESS P.PRIV (3); + + VP : A_PRIV; + VCP : A_CPRIV; + + PROCEDURE PREC_REC (X : A_T_REC_REC) IS + BEGIN + NULL; + END PREC_REC; + + PROCEDURE PREC_ARR (X : A_T_REC_ARR) IS + BEGIN + NULL; + END PREC_ARR; + + PROCEDURE PB (X : ATB) IS + BEGIN + NULL; + END PB; + + PROCEDURE PCB (X : ACTB) IS + BEGIN + NULL; + END PCB; + + PROCEDURE PPRIV (X : A_PRIV) IS + BEGIN + NULL; + END PPRIV; + + PROCEDURE PCPRIV (X : A_CPRIV) IS + BEGIN + NULL; + END PCPRIV; + + FUNCTION DISC (A : INTEGER) RETURN INTEGER IS + BEGIN + DISC_FLAG := TRUE; + RETURN A; + END DISC; + + FUNCTION INCR(A : INTEGER) RETURN INTEGER IS + BEGIN + INCR_VAL := IDENT_INT(INCR_VAL+1); + RETURN A; + END INCR; + + PROCEDURE INCR_CHECK(CASE_ID : STRING) IS + BEGIN + IF INCR_VAL /= IDENT_INT(0) THEN + COMMENT ("DEFAULT INITIAL VALUE WAS EVALUATED - " & + "CASE " & CASE_ID); + END IF; + END INCR_CHECK; + + BEGIN + + BEGIN -- A1A: 0 ILLEGAL FOR TB.A. + INCR_VAL := 0; + VB := NEW TB (A => 0); + FAILED ("NO EXCEPTION RAISED - CASE A1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1A"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1A" ); + END; -- A1A + + BEGIN -- A1B: 8 ILLEGAL IN I1_7. + INCR_VAL := 0; + VB := NEW TB (A => I1_7'(IDENT_INT(8))); + FAILED ("NO EXCEPTION RAISED - CASE A1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1B"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1B"); + END; -- A1B + + BEGIN -- A1C: 8 ILLEGAL FOR TB.A. + INCR_VAL := 0; + PB(NEW TB (A => 8)); + FAILED ("NO EXCEPTION RAISED - CASE A1C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1C"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1C"); + END; --A1C + + BEGIN --A1D: 0 ILLEGAL FOR TB.A. + INCR_VAL := 0; + BOOL := ATB'(NEW TB(A => 0)) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A1D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A1D"); + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE A1D"); + END; --A1D + + BEGIN --A1E: 11 ILLEGAL FOR PRIV.A. + DISC_FLAG := FALSE; + INCR_VAL := 0; + VP := NEW P.PRIV(11); + FAILED("NO EXCEPTION RAISED - CASE A1E"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF DISC_FLAG THEN + FAILED ("DISCR DEFAULT EVALUATED WHEN " & + "EXPLICIT VALUE WAS PROVIDED - A1E"); + END IF; + INCR_CHECK("A1E"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE A1E"); + END; -- A1E + + BEGIN -- A2A: 1 ILLEGAL FOR REC.A. + INCR_VAL := 0; + VA_T_REC_REC := NEW T_REC_REC(A => I1_10'(IDENT_INT(1))); + FAILED ("NO EXCEPTION RAISED - CASE A2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A2A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2A"); + END; -- A2A + + BEGIN --A2B: 10 ILLEGAL FOR REC.A. + INCR_VAL := 0; + VA_T_REC_REC := NEW T_REC_REC (10); + FAILED ("NO EXCEPTION RAISED - CASE A2B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A2B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2B"); + END; -- A2B + + BEGIN -- A2C: 1 ILLEGAL FOR T.ARR.E'FIRST. + INCR_VAL := 0; + PREC_ARR (NEW T_REC_ARR (1)); + FAILED ("NO EXCEPTION RAISED - CASE A2C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK ("A2C"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2C"); + END; -- A2C + + BEGIN -- A2D: 10 ILLEGAL FOR T_ARR.D'LAST. + INCR_VAL := 0; + BOOL := NEW T_REC_ARR (IDENT_INT(10)) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A2D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK ("A2D"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A2D"); + END; -- A2D + + BEGIN -- A3A: ASSIGNMENT VIOLATES CONSTRAINT ON VCB'S SUBTYPE. + INCR_VAL := 0; + VCB := NEW TB (4); + FAILED ("NO EXCEPTION RAISED - CASE A3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3A"); + END; -- A3A + + BEGIN -- A3B: PARM ASSOC VIOLATES CONSTRAINT ON PARM SUBTYPE. + INCR_VAL := 0; + PCB (NEW TB (4)); + FAILED ("NO EXCEPTION RAISED - CASE A3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3B"); + END; -- A3B + + BEGIN -- A3C: 2 VIOLATES CONSTRAINT ON SUBTYPE ACTB. + INCR_VAL := 0; + BOOL := ACTB'(NEW TB (IDENT_INT(2))) = NULL; + FAILED ("NO EXCEPTION RAISED - CASE A3C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + INCR_CHECK("A3C"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A3C"); + END; -- A3C + + BEGIN -- A4A: EVALUATION OF DEFAULT RAISES EXCEPTION. + INCR_VAL := 0; + V_A_UR := NEW UR(4); + FAILED ("NO EXCEPTION RAISED - CASE A4A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE A4A"); + END; -- A4A + + END; + + RESULT; + + END C48008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48008c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48008c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48008c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48008c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C48008C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T X", CHECK THAT CONSTRAINT_ERROR IS + -- RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) S, X + -- IS AN INDEX CONSTRAINT, AND THE BOUNDS OF X ARE NOT COMPATIBLE WITH + -- AN INDEX SUBTYPE OF T. + + -- RM 01/08/80 + -- NL 10/13/81 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48008C IS + + USE REPORT; + + BEGIN + + TEST("C48008C","FOR ALLOCATORS OF THE FORM 'NEW T X', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ARRAY TYPE"); + + DECLARE + + SUBTYPE TWO IS INTEGER RANGE 1..2; + TYPE TF IS ARRAY( TWO RANGE <> , TWO RANGE <> ) OF INTEGER; + TYPE ATF IS ACCESS TF; + VF : ATF; + + BEGIN + + BEGIN + VF := NEW TF ( 0..1 , 1..2 ); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1"); + END; + + BEGIN + VF := NEW TF(1 .. 2, 2 .. IDENT_INT(3)); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2"); + END; + + END; + + RESULT; + + END C48008C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C48009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS A SCALAR SUBTYPE AND X IS OUTSIDE THE RANGE OF T, + -- OR IS WITHIN T'S RANGE AND OUTSIDE OF THE RANGE OF VALUES PERMITTED + -- FOR OBJECTS DESIGNATED BY VALUES OF THE ALLOCATOR'S BASE TYPE. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/02/83 + -- EG 07/05/84 + -- EDS 12/01/97 ADDED IDENT_INT TO MAKE EXPRESSION NON-STATIC. + + WITH REPORT; + + PROCEDURE C48009A IS + + USE REPORT; + + BEGIN + + TEST( "C48009A" , "FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK" & + " THAT CONSTRAINT_ERROR IS RAISED WHEN" & + " APPROPRIATE - SCALAR TYPES"); + DECLARE -- A1 + + SUBTYPE TA IS INTEGER RANGE 1..7; + TYPE ATA IS ACCESS TA; + VA : ATA; + + BEGIN + + VA := NEW TA'( IDENT_INT(0) ); + FAILED ("NO EXCEPTION RAISED - 1"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ( "WRONG EXCEPTION RAISED - 1" ); + + END; -- A1 + + DECLARE -- A2 + + SUBTYPE T1_7 IS INTEGER RANGE 1..7; + TYPE AT2_6 IS ACCESS INTEGER RANGE 2..6; + VAT2_6 : AT2_6; + + BEGIN + + BEGIN + + VAT2_6 := NEW T1_7'(1); + FAILED ("NO EXCEPTION RAISED - 2"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + + END; + + BEGIN + + VAT2_6 := NEW T1_7'(7); + FAILED ("NO EXCEPTION RAISED - 3"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + + END; + + END; -- A2 + + RESULT; + + END C48009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,255 ---- + -- C48009B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS AN UNCONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN + -- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN + -- X: + -- 1) DOES NOT SATISFY THE RANGE CONSTRAINT FOR THE CORRESPONDING + -- DISCRIMINANT OF T. + -- 2) DOES NOT EQUAL THE DISCRIMINANT VALUE SPECIFIED IN THE + -- DECLARATION OF THE ALLOCATOR'S BASE TYPE. + -- 3) A DISCRIMINANT VALUE IS COMPATIBLE WITH A DISCRIMINANT'S SUBTYPE + -- BUT DOES NOT PROVIDE A COMPATIBLE INDEX OR DISCRIMINANT + -- CONSTRAINT FOR A SUBCOMPONENT DEPENDENT ON THE DISCRIMINANT. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/02/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48009B IS + + USE REPORT; + + BEGIN + + TEST( "C48009B" , "FOR ALLOCATORS OF THE FORM 'NEW T '(X)', " & + "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED RECORD AND " & + "PRIVATE TYPES"); + + DECLARE + + SUBTYPE I1_7 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(7); + SUBTYPE I1_10 IS INTEGER RANGE IDENT_INT(1)..IDENT_INT(10); + SUBTYPE I2_9 IS INTEGER RANGE IDENT_INT(2)..IDENT_INT(9); + + TYPE REC (A : I2_9) IS + RECORD + NULL; + END RECORD; + + TYPE ARR IS ARRAY (I2_9 RANGE <>) OF INTEGER; + + TYPE T_REC (C : I1_10) IS + RECORD + D : REC(C); + END RECORD; + + TYPE T_ARR (C : I1_10) IS + RECORD + D : ARR(2..C); + E : ARR(C..9); + END RECORD; + + TYPE T_REC_REC (A : I1_10) IS + RECORD + B : T_REC(A); + END RECORD; + + TYPE T_REC_ARR (A : I1_10) IS + RECORD + B : T_ARR(A); + END RECORD; + + TYPE TB ( A : I1_7 ) IS + RECORD + R : INTEGER; + END RECORD; + + TYPE A_T_REC_REC IS ACCESS T_REC_REC; + TYPE A_T_REC_ARR IS ACCESS T_REC_ARR; + TYPE ATB IS ACCESS TB; + TYPE ACTB IS ACCESS TB(3); + + VA_T_REC_REC : A_T_REC_REC; + VA_T_REC_ARR : A_T_REC_ARR; + VB : ATB; + VCB : ACTB; + + PACKAGE P IS + TYPE PRIV( A : I1_10 ) IS PRIVATE; + CONS_PRIV : CONSTANT PRIV; + PRIVATE + TYPE PRIV( A : I1_10 ) IS + RECORD + R : INTEGER; + END RECORD; + CONS_PRIV : CONSTANT PRIV := (2, 3); + END P; + + USE P; + + TYPE A_PRIV IS ACCESS P.PRIV; + TYPE A_CPRIV IS ACCESS P.PRIV (3); + + VP : A_PRIV; + VCP : A_CPRIV; + + FUNCTION ALLOC1(X : P.PRIV) RETURN A_CPRIV IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW P.PRIV'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC1; + FUNCTION ALLOC2(X : TB) RETURN ACTB IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW TB'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC2; + + BEGIN + + BEGIN -- B1 + VB := NEW TB'(A => IDENT_INT(0), R => 1); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1A" ); + END; + + BEGIN + VB := NEW TB'(A => 8, R => 1); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1B"); + END; -- B1 + + BEGIN -- B2 + VCB := NEW TB'(2, 3); + FAILED ("NO EXCEPTION RAISED - CASE 2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2A"); + END; + + BEGIN + IF ALLOC2((IDENT_INT(4), 3)) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2B"); + END IF; + FAILED ("NO EXCEPTION RAISED - CASE 2B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2B"); + END; + + BEGIN + + IF ALLOC1(CONS_PRIV) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2C"); + END IF; + FAILED ("NO EXCEPTION RAISED - CASE 2C"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2C"); + + END; -- B2 + + BEGIN -- B3 + + VA_T_REC_REC := NEW T_REC_REC'(1, (1, (A => 1))); + FAILED ("NO EXCEPTION RAISED - CASE 3A"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + + END; + + BEGIN + + VA_T_REC_REC := NEW T_REC_REC'(10, + (10, (A => 10))); + FAILED ("NO EXCEPTION RAISED - CASE 3B"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + + END; + + BEGIN + + VA_T_REC_ARR := NEW T_REC_ARR'(1, (1, (OTHERS => 1), + (OTHERS => 2))); + FAILED ("NO EXCEPTION RAISED - CASE 3C"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3C"); + + END; + + BEGIN + + VA_T_REC_ARR := NEW T_REC_ARR'(10, (10, (OTHERS => 1), + (OTHERS => 2))); + FAILED ("NO EXCEPTION RAISED - CASE 3D"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3D"); + + END; + + END; + + RESULT; + + END C48009B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C48009C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS A CONSTRAINED RECORD OR PRIVATE TYPE, (X) IS AN + -- AGGREGATE OR A VALUE OF TYPE T, AND ONE OF THE DISCRIMINANT VALUES IN + -- X: + -- 1) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE FOR T. + -- 2) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE SPECIFIED + -- IN THE DECLARATION OF THE ALLOCATOR'S BASE TYPE. + -- 3) DOES NOT EQUAL THE CORRESPONDING DISCRIMINANT VALUE IN THE + -- ACCESS TO ACCESS CASE. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48009C IS + + USE REPORT; + + BEGIN + + TEST("C48009C","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED RECORD TYPES"); + + DECLARE + + TYPE TC0(A, B : INTEGER) IS + RECORD + C : INTEGER RANGE 1 .. 7; + END RECORD; + SUBTYPE TC IS TC0(2, 3); + TYPE ATC IS ACCESS TC0(2, 3); + SUBTYPE TC4_5 IS TC0(IDENT_INT(4), IDENT_INT(5)); + VC : ATC; + + BEGIN + + BEGIN + VC := NEW TC'(102, 3, 4); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE 1"); + END; + + BEGIN + VC := NEW TC4_5'(IDENT_INT(4), IDENT_INT(5), 1); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED - CASE 2"); + END; + + END; + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE A_UR IS ACCESS UR; + SUBTYPE CA_UR IS A_UR(2); + TYPE A_CA_UR IS ACCESS CA_UR; + + V : A_CA_UR; + + BEGIN + + V := NEW CA_UR'(NEW UR'(A => IDENT_INT(3))); + FAILED ("NO EXCEPTION RAISED - CASE 3"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3"); + + END; + + RESULT; + + END C48009C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C48009D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS AN UNCONSTRAINED ARRAY TYPE WITH INDEX SUBTYPE(S) + -- S, + -- 1) X HAS TOO MANY VALUES FOR S; + -- 2) A NAMED NON-NULL BOUND OF X LIES OUTSIDE S'S RANGE; + -- 3) THE BOUND'S OF X ARE NOT EQUAL TO BOUNDS SPECIFIED FOR THE + -- ALLOCATOR'S DESIGNATED BASE TYPE. (THEY ARE EQUAL TO THE BOUNDS + -- SPECIFIED FOR T). + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/03/83 + -- EG 07/05/84 + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + -- KAS 11/14/95 FOR SLIDING ASSIGNMENT, CHANGED FAIL TO COMMENT ON LANGUAGE + -- KAS 12/02/95 INCLUDED SECOND CASE + -- PWN 05/03/96 Enforced Ada 95 sliding rules + + WITH REPORT; + + PROCEDURE C48009D IS + + USE REPORT ; + + BEGIN + + TEST("C48009D","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ARRAY TYPES"); + DECLARE + + SUBTYPE TWO IS INTEGER RANGE 1 .. 2; + SUBTYPE TWON IS INTEGER RANGE IDENT_INT(1) .. IDENT_INT(2); + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE TD IS ARRAY(TWO RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE TDN IS ARRAY(TWON RANGE <>) OF INTEGER RANGE 1 .. 7; + TYPE ATD IS ACCESS TD; + TYPE ATDN IS ACCESS TDN; + TYPE A_UA IS ACCESS UA; + TYPE A_CA IS ACCESS UA(3 .. 4); + TYPE A_CAN IS ACCESS UA(4 .. 3); + VD : ATD; + VDN : ATDN; + V_A_CA : A_CA; + V_A_CAN : A_CAN; + + BEGIN + + BEGIN + VD := NEW TD'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1A"); + END; + + BEGIN + VDN := NEW TDN'(3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1B"); + END; + + BEGIN + VD := NEW TD'(IDENT_INT(0) .. 2 => 6); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2"); + END; + + BEGIN + V_A_CA := NEW UA'(2 .. 3 => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3A"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + END; + + BEGIN + V_A_CAN := NEW UA'(IDENT_INT(3) .. IDENT_INT(2) => 3); + COMMENT ("ADA 95 SLIDING ASSIGNMENT - CASE 3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON SLIDING ASSIGNMENT - CASE 3B"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + END; + + END; + + RESULT; + + END C48009D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- C48009E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS A CONSTRAINED ARRAY TYPE AND: + -- 1) A NAMED NULL OR NON-NULL BOUND FOR X DOES NOT EQUAL THE + -- CORRESPONDING BOUND FOR T; + -- 2) A BOUND OF T DOES NOT EQUAL THE CORRESPONDING VALUE SPECIFIED IN + -- THE DECLARATION OF THE ALLOCATOR'S BASE TYPE; + -- 3) A POSITIONAL AGGREGATE DOES NOT HAVE THE NUMBER OF COMPONENTS + -- REQUIRED BY T OR BY THE ALLOCATOR'S BASE TYPE. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/03/83 + -- EG 07/05/84 + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + -- KAS 11/14/95 CHANGED FAILURE AT SLIDING ASSIGNMENT TO COMMENT ON LANGUAGE + -- KAS 11/30/95 REINSTRUMENTED CASES TO SELECT LANGUAGE SEMANTICS + -- PWN 05/03/96 Enforced Ada 95 sliding rules + -- PWN 10/24/96 Adjusted expected results for Ada 95. + -- TMB 11/19/96 BACKED OUT CHANGE FOR SLIDING WITH ACCESS TYPES + -- MRM 12/16/96 Removed problem code from withdrawn version of test, and + -- implemented a dereference-index check to ensure Ada95 + -- required behavior. + -- PWB.CTA 03/07/97 Restored checks from 1.11 in 2 cases where sliding does + -- not occur + WITH REPORT; + + PROCEDURE C48009E IS + + USE REPORT ; + + BEGIN + + TEST("C48009E","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ARRAY TYPES"); + DECLARE + + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE CA3_2 IS ARRAY(3 .. 2) OF INTEGER; + TYPE SA1_3 IS ARRAY(1 .. 3) OF INTEGER; + TYPE NA1_3 IS ARRAY(1 .. IDENT_INT(3)) OF INTEGER; + SUBTYPE CA2_6 IS UA(2 .. 6); + SUBTYPE CA1_4 IS UA(1 .. 4); + SUBTYPE CA1_6 IS UA(1 .. 6); + SUBTYPE CA4_1 IS UA(4 .. 1); + SUBTYPE CA4_2 IS UA(4 .. 2); + + TYPE A_CA3_2 IS ACCESS CA3_2; + TYPE A_SA1_3 IS ACCESS SA1_3; + TYPE A_NA1_3 IS ACCESS NA1_3; + TYPE A_CA1_5 IS ACCESS UA(1 .. 5); + TYPE A_CA4_2 IS ACCESS CA4_2; + + V_A_CA3_2 : A_CA3_2; + V_A_SA1_3 : A_SA1_3; + V_A_NA1_3 : A_NA1_3; + V_A_CA1_5 : A_CA1_5; + + FUNCTION ALLOC1(X : CA2_6) RETURN A_CA1_5 IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW CA2_6'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC1; + FUNCTION ALLOC2(X : CA4_1) RETURN A_CA4_2 IS + BEGIN + IF EQUAL(1, 1) THEN + RETURN NEW CA4_1'(X); + ELSE + RETURN NULL; + END IF; + END ALLOC2; + + BEGIN + + BEGIN + V_A_CA3_2 := NEW CA3_2'(IDENT_INT(4) .. IDENT_INT(2) + => 5); + FAILED ("NO EXCEPTION RAISED - CASE 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1A"); + END; + + BEGIN + V_A_NA1_3 := NEW NA1_3'(1 .. IDENT_INT(2) => 4); + FAILED ("NO EXCEPTION RAISED - CASE 1B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 1B"); + END; + + BEGIN + -- note that ALLOC1 returns A_CA1_5, so both + -- (1) and (5) are valid index references! + IF ALLOC1((2 .. 6 => 2))(5) /= 2 THEN + FAILED ("Wrong Value Returned - CASE 2A"); + ELSIF ALLOC1((2 .. 6 => 3))(1) /= 3 THEN + FAILED ("Unlikely Index Case - CASE 2A"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - CASE 2A"); + END; + + BEGIN + IF ALLOC2((4 .. 1 => 3)) = NULL THEN + FAILED ("IMPOSSIBLE - CASE 2B"); + END IF; + COMMENT ("ADA 95 SLIDING ASSIGNMENT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("ADA 83 NON-SLIDING ASSIGNMENT"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 2B"); + END; + + BEGIN + V_A_SA1_3 := NEW SA1_3'(1, 2); + FAILED ("NO EXCEPTION RAISED - CASE 3A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3A"); + END; + + BEGIN + V_A_SA1_3 := NEW SA1_3'(3, 4, 5, 6); + FAILED ("NO EXCEPTION RAISED - CASE 3B"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3B"); + END; + + BEGIN + V_A_NA1_3 := NEW NA1_3'(1, 2); + FAILED ("NO EXCEPTION RAISED - CASE 3C"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3C"); + END; + + BEGIN -- SATISFIES T BUT NOT BASE TYPE. + V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4); + FAILED ("NO EXCEPTION RAISED - CASE 3D"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3D"); + END; + + BEGIN -- SATISFIES T BUT NOT BASE TYPE. + V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5, 6); + FAILED ("NO EXCEPTION RAISED - CASE 3E"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3E"); + END; + + BEGIN -- SATISFIES BASE TYPE BUT NOT T. + V_A_CA1_5 := NEW CA1_4'(1, 2, 3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 3F"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3F"); + END; + + BEGIN -- SATISFIES BASE TYPE BUT NOT T. + V_A_CA1_5 := NEW CA1_6'(1, 2, 3, 4, 5); + FAILED ("NO EXCEPTION RAISED - CASE 3G"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CASE 3G"); + END; + + END ; + + RESULT ; + + END C48009E ; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C48009F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS A CONSTRAINED OR UNCONSTRAINED MULTI-DIMENSIONAL + -- ARRAY TYPE AND ALL COMPONENTS OF X DO NOT HAVE THE SAME LENGTH OR + -- BOUNDS. + + -- RM 01/08/80 + -- NL 10/13/81 + -- SPS 10/26/82 + -- JBG 03/03/83 + -- EG 07/05/84 + + WITH REPORT; + + PROCEDURE C48009F IS + + USE REPORT; + + BEGIN + + TEST("C48009F","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "X IS AN ILL-FORMED MULTIDIMENSIONAL AGGREGATE"); + + DECLARE + + TYPE TG00 IS ARRAY( 4..2 ) OF INTEGER; + TYPE TG10 IS ARRAY( 1..2 ) OF INTEGER; + TYPE TG20 IS ARRAY( INTEGER RANGE <> ) OF INTEGER; + + TYPE TG0 IS ARRAY( 3..2 ) OF TG00; + TYPE TG1 IS ARRAY( 1..2 ) OF TG10; + TYPE TG2 IS ARRAY( INTEGER RANGE <> ) OF TG20(1..3); + + TYPE ATG0 IS ACCESS TG0; + TYPE ATG1 IS ACCESS TG1; + TYPE ATG2 IS ACCESS TG2; + + VG0 : ATG0; + VG1 : ATG1; + VG2 : ATG2; + + BEGIN + + BEGIN + VG0 := NEW TG0 '( 5..4 => ( 3..1 => 2 ) ); + FAILED ("NO EXCEPTION RAISED - CASE 0"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 0" ); + END; + + BEGIN + VG1 := NEW TG1 '( ( 1 , 2 ) , ( 3 , 4 , 5 ) ); + FAILED ("NO EXCEPTION RAISED - CASE 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 1" ); + END; + + BEGIN + VG2 := NEW TG2'( 1 => ( 1..2 => 7) , 2 => ( 1..3 => 7)); + FAILED ("NO EXCEPTION RAISED - CASE 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - CASE 2" ); + END; + + END; + + RESULT; + + END C48009F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C48009G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT + -- CONSTRAINT_ERROR IS RAISED IF T IS A CONSTRAINED ACCESS + -- TYPE AND THE OBJECT DESIGNATED BY X DOES NOT HAVE DISCRIMINANTS + -- OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING VALUES FOR T. + + -- HISTORY: + -- EG 08/30/84 CREATED ORIGINAL TEST. + -- JET 01/05/87 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT + -- OPTIMIZATION. + + WITH REPORT; + + PROCEDURE C48009G IS + + USE REPORT; + + GENERIC + TYPE G_TYPE IS PRIVATE; + FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN; + + FUNCTION EQUAL_G (X : G_TYPE; Y : G_TYPE) RETURN BOOLEAN IS + BEGIN + IF (IDENT_INT(3) = 3) AND (X = Y) THEN + RETURN TRUE; + ELSE + RETURN FALSE; + END IF; + END EQUAL_G; + + BEGIN + + TEST("C48009G","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - CONSTRAINED ACCESS TYPE"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + + TYPE UR(A : INT) IS + RECORD + B : INTEGER; + END RECORD; + TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A, B : INT) IS PRIVATE; + TYPE UL(A, B : INT) IS LIMITED PRIVATE; + CONS_UP : CONSTANT UP; + PRIVATE + TYPE UP(A, B : INT) IS + RECORD + C : INTEGER; + END RECORD; + TYPE UL(A, B : INT) IS + RECORD + C : INTEGER; + END RECORD; + CONS_UP : CONSTANT UP := (2, 2, (IDENT_INT(3))); + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + SUBTYPE CA_UR IS A_UR(2); + SUBTYPE CA_UA IS A_UA(2 .. 3); + SUBTYPE CA_UP IS A_UP(3, 2); + SUBTYPE CA_UL IS A_UL(2, 4); + + TYPE A_CA_UR IS ACCESS CA_UR; + TYPE A_CA_UA IS ACCESS CA_UA; + TYPE A_CA_UP IS ACCESS CA_UP; + TYPE A_CA_UL IS ACCESS CA_UL; + + V_A_CA_UR : A_CA_UR; + V_A_CA_UA : A_CA_UA; + V_A_CA_UP : A_CA_UP; + V_A_CA_UL : A_CA_UL; + + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UR); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UA); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UP); + FUNCTION EQUAL IS NEW EQUAL_G(A_CA_UL); + + BEGIN + + BEGIN + V_A_CA_UR := NEW CA_UR'(NEW UR'(1,(IDENT_INT(2)))); + + IF EQUAL (V_A_CA_UR, V_A_CA_UR) THEN + FAILED ("NO EXCEPTION RAISED - UR"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_A_CA_UA := NEW CA_UA'(NEW UA'(1 => 2, + 2 => IDENT_INT(3))); + + IF EQUAL (V_A_CA_UA, V_A_CA_UA) THEN + FAILED ("NO EXCEPTION RAISED - UA"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_A_CA_UP := NEW CA_UP'(NEW P.UP'(P.CONS_UP)); + + IF EQUAL (V_A_CA_UP, V_A_CA_UP) THEN + FAILED ("NO EXCEPTION RAISED - UP"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_A_CA_UR := NEW CA_UR'(NULL); + + IF NOT EQUAL (V_A_CA_UR, V_A_CA_UR) THEN + COMMENT ("NO EXCEPTION RAISED - UR"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UR"); + END; + + BEGIN + V_A_CA_UA := NEW CA_UA'(NULL); + + IF NOT EQUAL (V_A_CA_UA, V_A_CA_UA) THEN + COMMENT ("NO EXCEPTION RAISED - UA"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UA"); + END; + + BEGIN + V_A_CA_UP := NEW CA_UP'(NULL); + + IF NOT EQUAL (V_A_CA_UP, V_A_CA_UP) THEN + COMMENT ("NO EXCEPTION RAISED - UP"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UP"); + END; + + BEGIN + V_A_CA_UL := NEW CA_UL'(NULL); + + IF NOT EQUAL (V_A_CA_UL, V_A_CA_UL) THEN + COMMENT ("NO EXCEPTION RAISED - UL"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + + END C48009G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C48009H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS AN (UNCONSTRAINED) ACCESS TYPE, THE DESIGNATED TYPE + -- FOR T'BASE IS CONSTRAINED, AND THE OBJECT DESIGNATED BY X DOES NOT + -- HAVE DISCRIMINANTS OR INDEX BOUNDS THAT EQUAL THE CORRESPONDING + -- VALUES FOR T'S DESIGNATED TYPE. + + -- EG 08/30/84 + + WITH REPORT; + + PROCEDURE C48009H IS + + USE REPORT; + + BEGIN + + TEST("C48009H","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - UNCONSTRAINED ACCESS TYPE OF A " & + "CONSTRAINED TYPE"); + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INTEGER) IS PRIVATE; + TYPE UL(A : INTEGER) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_CR IS ACCESS UR(IDENT_INT(2)); + TYPE A_CA IS ACCESS UA(2 .. IDENT_INT(4)); + TYPE A_CP IS ACCESS P.UP(3); + TYPE A_CL IS ACCESS P.UL(4); + + TYPE AA_CR IS ACCESS A_CR; + TYPE AA_CA IS ACCESS A_CA; + TYPE AA_CP IS ACCESS A_CP; + TYPE AA_CL IS ACCESS A_CL; + + V_AA_CR : AA_CR; + V_AA_CA : AA_CA; + V_AA_CP : AA_CP; + V_AA_CL : AA_CL; + + BEGIN + + BEGIN + V_AA_CR := NEW A_CR'(NEW UR(3)); + FAILED ("NO EXCEPTION RAISED - CR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CR"); + END; + + BEGIN + V_AA_CA := NEW A_CA'(NEW UA(IDENT_INT(3) .. 5)); + FAILED ("NO EXCEPTION RAISED - CA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CA"); + END; + + BEGIN + V_AA_CP := NEW A_CP'(NEW P.UP(IDENT_INT(4))); + FAILED ("NO EXCEPTION RAISED - CP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CP"); + END; + + BEGIN + V_AA_CL := NEW A_CL'(NEW P.UL(5)); + FAILED ("NO EXCEPTION RAISED - CL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CL"); + END; + + END; + + RESULT; + + END C48009H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009i.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C48009I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF THE DESIGNATED TYPE FOR "NEW T'(X)" IS A CONSTRAINED + -- ACCESS TYPE, CA, T IS CA'BASE, AND A DISCRIMINANT OR INDEX VALUE OF X + -- DOES NOT EQUAL A VALUE SPECIFIED FOR CA. + + -- EG 08/30/84 + + WITH REPORT; + + PROCEDURE C48009I IS + + USE REPORT; + + BEGIN + + TEST("C48009I","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - ACCESS TYPE OF CONSTRAINED " & + "ACCESS TYPE"); + + DECLARE + + TYPE UR(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INTEGER RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INTEGER) IS PRIVATE; + TYPE UL(A : INTEGER) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INTEGER) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INTEGER) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + TYPE AC_A_UR IS ACCESS A_UR(2); + TYPE AC_A_UA IS ACCESS A_UA(2 .. 4); + TYPE AC_A_UP IS ACCESS A_UP(3); + TYPE AC_A_UL IS ACCESS A_UL(4); + + V_AC_A_UR : AC_A_UR; + V_AC_A_UA : AC_A_UA; + V_AC_A_UP : AC_A_UP; + V_AC_A_UL : AC_A_UL; + + BEGIN + + BEGIN + V_AC_A_UR := NEW A_UR'(NEW UR(3)); + FAILED ("NO EXCEPTION RAISED - UR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_AC_A_UA := NEW A_UA'(NEW UA(3 .. 5)); + FAILED ("NO EXCEPTION RAISED - UA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_AC_A_UP := NEW A_UP'(NEW P.UP(IDENT_INT(4))); + FAILED ("NO EXCEPTION RAISED - UP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_AC_A_UL := NEW A_UL'(NEW P.UL(IDENT_INT(5))); + FAILED ("NO EXCEPTION RAISED - UL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + + END C48009I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48009j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48009j.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C48009J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR ALLOCATORS OF THE FORM "NEW T'(X)", CHECK THAT CONSTRAINT_ERROR + -- IS RAISED IF T IS AN UNCONSTRAINED ACCESS TYPE, ITS DESIGNATED TYPE + -- IS ALSO UNCONSTRAINED, AND A DISCRIMINANT VALUE FOR X LIES OUTSIDE + -- THE RANGE OF THE CORRESPONDING DISCRIMINANT SPECIFICATION FOR THE + -- DESIGNATED TYPE, OR A NON-NULL INDEX BOUND LIES OUTSIDE THE RANGE OF + -- AN INDEX SUBTYPE OF THE DESIGNATED TYPE. + + -- EG 08/30/84 + + WITH REPORT; + + PROCEDURE C48009J IS + + USE REPORT; + + BEGIN + + TEST("C48009J","FOR ALLOCATORS OF THE FORM 'NEW T'(X)', CHECK " & + "THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "APPROPRIATE - ACCESS TYPE OF UNCONSTRAINED " & + "ACCESS TYPE"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + + TYPE UR(A : INT) IS + RECORD + NULL; + END RECORD; + TYPE UA IS ARRAY(INT RANGE <>) OF INTEGER; + + PACKAGE P IS + TYPE UP(A : INT) IS PRIVATE; + TYPE UL(A : INT) IS LIMITED PRIVATE; + PRIVATE + TYPE UP(A : INT) IS + RECORD + NULL; + END RECORD; + TYPE UL(A : INT) IS + RECORD + NULL; + END RECORD; + END P; + + TYPE A_UR IS ACCESS UR; + TYPE A_UA IS ACCESS UA; + TYPE A_UP IS ACCESS P.UP; + TYPE A_UL IS ACCESS P.UL; + + TYPE AA_UR IS ACCESS A_UR; + TYPE AA_UA IS ACCESS A_UA; + TYPE AA_UP IS ACCESS A_UP; + TYPE AA_UL IS ACCESS A_UL; + + V_AA_UR : AA_UR; + V_AA_UA : AA_UA; + V_AA_UP : AA_UP; + V_AA_UL : AA_UL; + + BEGIN + + BEGIN + V_AA_UR := NEW A_UR'(NEW UR(INT(IDENT_INT(6)))); + FAILED ("NO EXCEPTION RAISED - UR"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UR"); + END; + + BEGIN + V_AA_UA := NEW A_UA'(NEW UA(4 .. 7)); + FAILED ("NO EXCEPTION RAISED - UA"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UA"); + END; + + BEGIN + V_AA_UP := NEW A_UP'(NEW P.UP(0)); + FAILED ("NO EXCEPTION RAISED - UP"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UP"); + END; + + BEGIN + V_AA_UL := NEW A_UL'(NEW P.UL(INT(IDENT_INT(0)))); + FAILED ("NO EXCEPTION RAISED - UL"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - UL"); + END; + + END; + + RESULT; + + END C48009J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48010a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C48010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NULL ARRAYS AND NULL RECORDS CAN BE ALLOCATED. + + -- EG 08/30/84 + + WITH REPORT; + + PROCEDURE C48010A IS + + USE REPORT; + + BEGIN + + TEST("C48010A","CHECK THAT NULL ARRAYS AND NULL RECORDS CAN " & + "BE ALLOCATED"); + + DECLARE + + TYPE CA IS ARRAY(4 .. 3) OF INTEGER; + TYPE CR IS + RECORD + NULL; + END RECORD; + + TYPE A_CA IS ACCESS CA; + TYPE A_CR IS ACCESS CR; + + TYPE AA_CA IS ACCESS A_CA; + TYPE AA_CR IS ACCESS A_CR; + + V_A_CA : A_CA; + V_A_CR : A_CR; + V_AA_CA : AA_CA; + V_AA_CR : AA_CR; + + BEGIN + + V_A_CA := NEW CA; + IF V_A_CA = NULL THEN + FAILED ("NULL ARRAY WAS NOT ALLOCATED - CA"); + ELSIF V_A_CA.ALL'FIRST /= 4 AND V_A_CA.ALL'LAST /= 3 THEN + FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - CA"); + END IF; + + V_A_CR := NEW CR; + IF V_A_CR = NULL THEN + FAILED ("NULL RECORD WAS NOT ALLOCATED - CR"); + END IF; + + V_AA_CA := NEW A_CA'(NEW CA); + IF V_AA_CA.ALL = NULL THEN + FAILED ("NULL ARRAY WAS NOT ALLOCATED - A_CA"); + ELSIF V_AA_CA.ALL.ALL'FIRST /= 4 AND + V_AA_CA.ALL.ALL'LAST /= 3 THEN + FAILED ("NULL ARRAY BOUNDS ARE INCORRECT - A_CA"); + END IF; + + V_AA_CR := NEW A_CR'(NEW CR); + IF (V_AA_CR = NULL OR V_AA_CR.ALL = NULL) THEN + FAILED ("NULL RECORD WAS NOT ALLOCATED - A_CR"); + END IF; + + END; + + RESULT; + + END C48010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48011a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C48011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADED ALLOCATORS ARE DETERMINED TO HAVE THE + -- APPROPRIATE TYPE. + + -- HISTORY: + -- JET 08/17/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C48011A IS + + TYPE ACC1 IS ACCESS INTEGER; + TYPE ACC2 IS ACCESS INTEGER; + + A1 : ACC1 := NULL; + A2 : ACC2 := NULL; + + TYPE REC1 IS RECORD + A : INTEGER; + END RECORD; + + TYPE REC2 IS RECORD + A : ACC2; + END RECORD; + + TYPE AREC1 IS ACCESS REC1; + TYPE AREC2 IS ACCESS REC2; + + PROCEDURE PROC(A : ACC1) IS + BEGIN + IF A.ALL /= 1 THEN + FAILED("INCORRECT CALL OF FIRST PROC"); + END IF; + END PROC; + + PROCEDURE PROC(A : INTEGER) IS + BEGIN + IF A /= 2 THEN + FAILED("INCORRECT CALL OF SECOND PROC"); + END IF; + END PROC; + + FUNCTION FUNC(I : INTEGER) RETURN AREC1 IS + BEGIN + IF I /= 1 THEN + FAILED("INCORRECT CALL OF FIRST FUNC"); + END IF; + RETURN NEW REC1'(A => 0); + END FUNC; + + FUNCTION FUNC(I : INTEGER) RETURN AREC2 IS + BEGIN + IF I /= 2 THEN + FAILED("INCORRECT CALL OF SECOND FUNC"); + END IF; + RETURN NEW REC2'(A => NULL); + END FUNC; + + BEGIN + TEST ("C48011A", "CHECK THAT OVERLOADED ALLOCATORS ARE " & + "DETERMINED TO HAVE THE APPROPRIATE TYPE"); + + IF A1 = NEW INTEGER'(1) THEN + FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 1"); + END IF; + + IF A2 = NEW INTEGER'(2) THEN + FAILED("INCORRECT RETURN VALUE FROM ALLOCATOR 2"); + END IF; + + FUNC(1).A := INTEGER'(1); + FUNC(IDENT_INT(2)).A := NEW INTEGER'(2); + + PROC(NEW INTEGER'(IDENT_INT(1))); + PROC(IDENT_INT(2)); + + RESULT; + END C48011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c48012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c48012a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C48012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DISCRIMINANTS GOVERNING VARIANT PARTS NEED NOT BE + -- SPECIFIED WITH STATIC VALUES IN AN ALLOCATOR OF THE FORM + -- "NEW T X". + + -- EG 08/30/84 + + WITH REPORT; + + PROCEDURE C48012A IS + + USE REPORT; + + BEGIN + + TEST("C48012A","CHECK THAT DISCRIMINANTS GOVERNING VARIANT " & + "PARTS NEED NOT BE SPECIFIED WITH STATIC " & + "VALUES IN AN ALLOCATOR OF THE FORM 'NEW T X'"); + + DECLARE + + TYPE INT IS RANGE 1 .. 5; + TYPE ARR IS ARRAY(INT RANGE <>) OF INTEGER; + + TYPE UR(A : INT) IS + RECORD + CASE A IS + WHEN 1 => + NULL; + WHEN OTHERS => + B : ARR(1 .. A); + END CASE; + END RECORD; + + TYPE A_UR IS ACCESS UR; + + V_A_UR : A_UR; + + BEGIN + + V_A_UR := NEW UR(A => INT(IDENT_INT(2))); + IF V_A_UR.A /= 2 THEN + FAILED ("WRONG DISCRIMINANT VALUE"); + ELSIF V_A_UR.B'FIRST /= 1 AND V_A_UR.B'LAST /= 2 THEN + FAILED ("WRONG BOUNDS IN VARIANT PART"); + END IF; + + END; + + RESULT; + + END C48012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- C490001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for a real static expression that is not part of a larger + -- static expression, and whose expected type T is a floating point type + -- that is not a descendant of a formal scalar type, the value is rounded + -- to the nearest machine number of T if T'Machine_Rounds is true, and is + -- truncated otherwise. Check that if rounding is performed, and the value + -- is exactly halfway between two machine numbers, one of the two machine + -- numbers is used. + -- + -- TEST DESCRIPTION: + -- The test obtains a machine number M1 for a floating point subtype S by + -- passing a real literal to S'Machine. It then obtains an adjacent + -- machine number M2 by using S'Succ (or S'Pred). It then constructs + -- values which lie between these two machine numbers: one (A) which is + -- closer to M1, one (B) which is exactly halfway between M1 and M2, and + -- one (C) which is closer to M2. This is done for both positive and + -- negative machine numbers. + -- + -- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, + -- C must be rounded to M2, A must be rounded to M1, and B must be rounded + -- to either M1 or M2. If S'Machine_Rounds is false, all the values must + -- be truncated to M1. + -- + -- A, B, and C are constructed using the following static expressions: + -- + -- A: constant S := M1 + (M2 - M1)*Z; -- Z slightly less than 0.5. + -- B: constant S := M1 + (M2 - M1)*Z; -- Z equals 0.5. + -- C: constant S := M1 + (M2 - M1)*Z; -- Z slightly more than 0.5. + -- + -- Since these are static expressions, they must be evaluated exactly, + -- and no rounding may occur until the final result is calculated. + -- + -- The checks for equality between the members of (A, B, C) and (M1, M2) + -- are performed at run-time within the body of a subprogram. + -- + -- The test performs additional checks that the rounding performed on + -- real literals is consistent for a floating point subtype. A literal is + -- assigned to a constant of a floating point subtype S. The same literal + -- is then passed to a subprogram, along with the constant, and an + -- equality check is performed within the body of the subprogram. + -- + -- + -- CHANGE HISTORY: + -- 25 Sep 95 SAIC Initial prerelease version. + -- 25 May 01 RLB Repaired to work with the repeal of the round away + -- rule by AI-268. + -- + --! + + with System; + package C490001_0 is + + type My_Flt is digits System.Max_Digits; + + procedure Float_Subtest (A, B: in My_Flt; Msg: in String); + + procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String); + + + -- + -- Positive cases: + -- + + -- |----|-------------|-----------------|-------------------|-----------| + -- | | | | | | + -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 + + + Positive_Float : constant My_Flt := 12.440193950021943; + + -- The literal value 12.440193950021943 is rounded up or down to the + -- nearest machine number of My_Flt when Positive_Float is initialized. + -- The value of Positive_Float should therefore be a machine number, and + -- the use of 'Machine in the initialization of P_M1 will be redundant for + -- a correct implementation. It's done anyway to make certain that P_M1 is + -- a machine number, independent of whether an implementation correctly + -- performs rounding. + + P_M1 : constant My_Flt := My_Flt'Machine(Positive_Float); + P_M2 : constant My_Flt := My_Flt'Succ(P_M1); + + -- P_M1 and P_M2 are adjacent machine numbers. Note that because it is not + -- certain whether 12.440193950021943 is a machine number, nor whether + -- 'Machine rounds it up or down, 12.440193950021943 may not lie between + -- P_M1 and P_M2. The test does not depend on this information, however; + -- the literal is only used as a "seed" to obtain the machine numbers. + + + -- The following entities are used to verify that rounding is performed + -- according to the value of 'Machine_Rounds. If language rules are + -- obeyed, the intermediate expressions in the following static + -- initialization expressions will not be rounded; all calculations will + -- be performed exactly. The final result, however, will be rounded to + -- a machine number (either P_M1 or P_M2, depending on the value of + -- My_Flt'Machine_Rounds). Thus, the value of each constant below will + -- equal that of P_M1 or P_M2. + + Less_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*2.9/6.0); + Pos_Exactly_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)/2.0); + More_Pos_Than_Half : constant My_Flt := P_M1 + ((P_M2 - P_M1)*4.6/9.0); + + + -- + -- Negative cases: + -- + + -- -|-------------|-----------------|-------------------|-----------|----| + -- | | | | | | + -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 + + + -- The descriptions for the positive cases above apply to the negative + -- cases below as well. Note that, for N_M2, 'Pred is used rather than + -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. + + Negative_Float : constant My_Flt := -0.692074550952117; + + + N_M1 : constant My_Flt := My_Flt'Machine(Negative_Float); + N_M2 : constant My_Flt := My_Flt'Pred(N_M1); + + More_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*4.1/8.0); + Neg_Exactly_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)/2.0); + Less_Neg_Than_Half : constant My_Flt := N_M1 + ((N_M2 - N_M1)*2.4/5.0); + + end C490001_0; + + + --==================================================================-- + + + with TCTouch; + package body C490001_0 is + + procedure Float_Subtest (A, B: in My_Flt; Msg: in String) is + begin + TCTouch.Assert (A = B, Msg); + end Float_Subtest; + + procedure Float_Subtest (A, B, C: in My_Flt; Msg: in String) is + begin + TCTouch.Assert (A = B or A = C, Msg); + end Float_Subtest; + + end C490001_0; + + + --==================================================================-- + + + with C490001_0; -- Floating point support. + use C490001_0; + + with Report; + procedure C490001 is + begin + Report.Test ("C490001", "Rounding of real static expressions: " & + "floating point subtypes"); + + + -- Check that rounding direction is consistent for literals: + + Float_Subtest (12.440193950021943, P_M1, "Positive Float: literal"); + Float_Subtest (-0.692074550952117, N_M1, "Negative Float: literal"); + + + -- Now check that rounding is performed correctly for values between + -- machine numbers, according to the value of 'Machine_Rounds: + + if My_Flt'Machine_Rounds then + Float_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Float: = half"); + Float_Subtest (More_Pos_Than_Half, P_M2, "Positive Float: > half"); + Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); + + Float_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Float: = half"); + Float_Subtest (More_Neg_Than_Half, N_M2, "Negative Float: > half"); + Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); + else + Float_Subtest (Pos_Exactly_Half, P_M1, "Positive Float: = half"); + Float_Subtest (More_Pos_Than_Half, P_M1, "Positive Float: > half"); + Float_Subtest (Less_Pos_Than_Half, P_M1, "Positive Float: < half"); + + Float_Subtest (Neg_Exactly_Half, N_M1, "Negative Float: = half"); + Float_Subtest (More_Neg_Than_Half, N_M1, "Negative Float: > half"); + Float_Subtest (Less_Neg_Than_Half, N_M1, "Negative Float: < half"); + end if; + + + Report.Result; + end C490001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490002.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- C490002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for a real static expression that is not part of a larger + -- static expression, and whose expected type T is an ordinary fixed + -- point type that is not a descendant of a formal scalar type, the value + -- is rounded to the nearest integral multiple of the small of T if + -- T'Machine_Rounds is true, and is truncated otherwise. Check that if + -- rounding is performed, and the value is exactly halfway between two + -- multiples of the small, one of the two multiples of small is used. + -- + -- TEST DESCRIPTION: + -- The test obtains an integral multiple M1 of the small of an ordinary + -- fixed point subtype S by dividing a real literal by S'Small, and then + -- truncating the result using 'Truncation. It then obtains an adjacent + -- multiple M2 of the small by using S'Succ (or S'Pred). It then + -- constructs values which lie between these multiples: one (A) which is + -- closer to M1, one (B) which is exactly halfway between M1 and M2, and + -- one (C) which is closer to M2. This is done for both positive and + -- negative multiples of the small. + -- + -- Let M1 be closer to zero than M2. Then if S'Machine_Rounds is true, + -- C must be rounded to M2, A must be rounded to M1, and B must be rounded + -- to either M1 or M2. If S'Machine_Rounds is false, all the values must + -- be truncated to M1. + -- + -- A, B, and C are constructed using the following static expressions: + -- + -- A: constant S := M1 + (M2 - M1)/Z; -- Z slightly more than 2.0. + -- B: constant S := M1 + (M2 - M1)/Z; -- Z equals 2.0. + -- C: constant S := M1 + (M2 - M1)/Z; -- Z slightly less than 2.0. + -- + -- Since these are static expressions, they must be evaluated exactly, + -- and no rounding may occur until the final result is calculated. + -- + -- The checks for equality between the members of (A, B, C) and (M1, M2) + -- are performed at run-time within the body of a subprogram. + -- + -- The test performs additional checks that the rounding performed on + -- real literals is consistent for ordinary fixed point subtypes. A + -- named number (initialized with a literal) is assigned to a constant of + -- a fixed point subtype S. The same literal is then passed to a + -- subprogram, along with the constant, and an equality check is + -- performed within the body of the subprogram. + -- + -- + -- CHANGE HISTORY: + -- 26 Sep 95 SAIC Initial prerelease version. + -- + --! + + package C490002_0 is + + type My_Fix is delta 0.0625 range -1000.0 .. 1000.0; + + Small : constant := My_Fix'Small; -- Named number. + + procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String); + + procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String); + + + -- + -- Positive cases: + -- + + -- |----|-------------|-----------------|-------------------|-----------| + -- | | | | | | + -- 0 P_M1 Less_Pos_Than_Half Pos_Exactly_Half More_Pos_Than_Half P_M2 + + + Positive_Real : constant := 0.11433; -- Named number. + Pos_Multiplier : constant := Float'Truncation(Positive_Real/Small); + + -- Pos_Multiplier is the number of integral multiples of small contained + -- in Positive_Real. P_M1 is thus the largest integral multiple of + -- small less than or equal to Positive_Real. Note that since Positive_Real + -- is a named number and not a fixed point object, P_M1 is generated + -- without assuming that rounding is performed correctly for fixed point + -- subtypes. + + Positive_Fixed : constant My_Fix := Positive_Real; + + P_M1 : constant My_Fix := Pos_Multiplier * Small; + P_M2 : constant My_Fix := My_Fix'Succ(P_M1); + + -- P_M1 and P_M2 are adjacent multiples of the small of My_Fix. Note that + -- 0.11433 either equals P_M1 (if it is an integral multiple of the small) + -- or lies between P_M1 and P_M2 (since truncation was forced in + -- generating Pos_Multiplier). It is not certain, however, exactly where + -- it lies between them (halfway, less than halfway, more than halfway). + -- This fact is irrelevant to the test. + + + -- The following entities are used to verify that rounding is performed + -- according to the value of 'Machine_Rounds. If language rules are + -- obeyed, the intermediate expressions in the following static + -- initialization expressions will not be rounded; all calculations will + -- be performed exactly. The final result, however, will be rounded to + -- an integral multiple of the small (either P_M1 or P_M2, depending on the + -- value of My_Fix'Machine_Rounds). Thus, the value of each constant below + -- will equal that of P_M1 or P_M2. + + Less_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.050); + Pos_Exactly_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/2.000); + More_Pos_Than_Half : constant My_Fix := P_M1 + ((P_M2 - P_M1)/1.975); + + + -- + -- Negative cases: + -- + + -- -|-------------|-----------------|-------------------|-----------|----| + -- | | | | | | + -- N_M2 More_Neg_Than_Half Neg_Exactly_Half Less_Neg_Than_Half N_M1 0 + + + -- The descriptions for the positive cases above apply to the negative + -- cases below as well. Note that, for N_M2, 'Pred is used rather than + -- 'Succ. Thus, N_M2 is further from 0.0 (i.e. more negative) than N_M1. + + Negative_Real : constant := -467.13988; -- Named number. + Neg_Multiplier : constant := Float'Truncation(Negative_Real/Small); + + Negative_Fixed : constant My_Fix := Negative_Real; + + N_M1 : constant My_Fix := Neg_Multiplier * Small; + N_M2 : constant My_Fix := My_Fix'Pred(N_M1); + + More_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/1.980); + Neg_Exactly_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.000); + Less_Neg_Than_Half : constant My_Fix := N_M1 + ((N_M2 - N_M1)/2.033); + + end C490002_0; + + + --==================================================================-- + + + with TCTouch; + package body C490002_0 is + + procedure Fixed_Subtest (A, B: in My_Fix; Msg: in String) is + begin + TCTouch.Assert (A = B, Msg); + end Fixed_Subtest; + + procedure Fixed_Subtest (A, B, C: in My_Fix; Msg: in String) is + begin + TCTouch.Assert (A = B or A = C, Msg); + end Fixed_Subtest; + + end C490002_0; + + + --==================================================================-- + + + with C490002_0; -- Fixed point support. + use C490002_0; + + with Report; + procedure C490002 is + begin + Report.Test ("C490002", "Rounding of real static expressions: " & + "ordinary fixed point subtypes"); + + + -- Literal cases: If the named numbers used to initialize Positive_Fixed + -- and Negative_Fixed are rounded to an integral multiple of the small + -- prior to assignment (as expected), then Positive_Fixed and + -- Negative_Fixed are already integral multiples of the small, and + -- equal either P_M1 or P_M2 (resp., N_M1 or N_M2). An equality check + -- can determine in which direction rounding occurred. For example: + -- + -- if (Positive_Fixed = P_M1) then -- Rounding was toward 0.0. + -- + -- Check here that the rounding direction is consistent for literals: + + if (Positive_Fixed = P_M1) then + Fixed_Subtest (0.11433, P_M1, "Positive Fixed: literal"); + else + Fixed_Subtest (0.11433, P_M2, "Positive Fixed: literal"); + end if; + + if (Negative_Fixed = N_M1) then + Fixed_Subtest (-467.13988, N_M1, "Negative Fixed: literal"); + else + Fixed_Subtest (-467.13988, N_M2, "Negative Fixed: literal"); + end if; + + + -- Now check that rounding is performed correctly for values between + -- multiples of the small, according to the value of 'Machine_Rounds: + + if My_Fix'Machine_Rounds then + Fixed_Subtest (Pos_Exactly_Half, P_M1, P_M2, "Positive Fixed: = half"); + Fixed_Subtest (More_Pos_Than_Half, P_M2, "Positive Fixed: > half"); + Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); + + Fixed_Subtest (Neg_Exactly_Half, N_M1, N_M2, "Negative Fixed: = half"); + Fixed_Subtest (More_Neg_Than_Half, N_M2, "Negative Fixed: > half"); + Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); + else + Fixed_Subtest (Pos_Exactly_Half, P_M1, "Positive Fixed: = half"); + Fixed_Subtest (More_Pos_Than_Half, P_M1, "Positive Fixed: > half"); + Fixed_Subtest (Less_Pos_Than_Half, P_M1, "Positive Fixed: < half"); + + Fixed_Subtest (Neg_Exactly_Half, N_M1, "Negative Fixed: = half"); + Fixed_Subtest (More_Neg_Than_Half, N_M1, "Negative Fixed: > half"); + Fixed_Subtest (Less_Neg_Than_Half, N_M1, "Negative Fixed: < half"); + end if; + + + Report.Result; + end C490002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c490003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c490003.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- C490003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a static expression is legal if its evaluation fails + -- no language-defined check other than Overflow_Check. Check that such + -- a static expression is legal if it is part of a larger static + -- expression, even if its value is outside the base range of the + -- expected type. + -- + -- Check that if a static expression is part of the right operand of a + -- short circuit control form whose value is determined by its left + -- operand, it is not evaluated. + -- + -- Check that a static expression in a non-static context is evaluated + -- exactly. + -- + -- TEST DESCRIPTION: + -- The first part of the objective is tested by constructing static + -- expressions which involve predefined operations of integer, floating + -- point, and fixed point subtypes. Intermediate expressions within the + -- static expressions have values outside the base range of the expected + -- type. In one case, the extended-range intermediates are compared as + -- part of a boolean expression. In the remaining two cases, further + -- predefined operations on the intermediates bring the final result + -- within the base range. An implementation which compiles these static + -- expressions satisfies this portion of the objective. A check is + -- performed at run-time to ensure that the static expressions evaluate + -- to values within the base range of their respective expected types. + -- + -- The second part of the objective is tested by constructing + -- short-circuit control forms whose left operands have the values + -- shown below: + -- + -- (TRUE) or else (...) + -- (FALSE) and then (...) + -- + -- In both cases the left operand determines the value of the condition. + -- In the test each right operand involves a division by zero, which will + -- raise Constraint_Error if evaluated. A check is made that no exception + -- is raised when each short-circuit control form is evaluated, and that + -- the value of the condition is that of the left operand. + -- + -- The third part of the objective is tested by evaluating static + -- expressions involving many operations in contexts which do not + -- require a static expression, and verifying that the exact + -- mathematical results are calculated. + -- + -- + -- CHANGE HISTORY: + -- 15 Sep 95 SAIC Initial prerelease version for ACVC 2.1. + -- 20 Oct 96 SAIC Modified expressions in C490003_0 to avoid + -- the use of universal operands. + -- + --! + + with System; + package C490003_0 is + + type My_Flt is digits System.Max_Digits; + + Flt_Range_Diff : My_Flt := (My_Flt'Base'Last - My_Flt'Base'First) - + (My_Flt'Last - My_Flt'First); -- OK. + + + type My_Fix is delta 0.125 range -128.0 .. 128.0; + + Symmetric : Boolean := (My_Fix'Base'Last - My_Fix'Base'First) = + (My_Fix'Base'Last + My_Fix'Base'Last); -- OK. + + + Center : constant Integer := Integer'Base'Last - + (Integer'Base'Last - + Integer'Base'First) / 2; -- OK. + + end C490003_0; + + + --==================================================================-- + + + with Ada.Numerics; + package C490003_1 is + + Zero : constant := 0.0; + Pi : constant := Ada.Numerics.Pi; + + Two_Pi : constant := 2.0 * Pi; + Half_Pi : constant := Pi/2.0; + + Quarter : constant := 90.0; + Half : constant := 180.0; + Full : constant := 360.0; + + Deg_To_Rad : constant := Half_Pi/90; + Rad_To_Deg : constant := 1.0/Deg_To_Rad; + + end C490003_1; + + + --==================================================================-- + + + with C490003_0; + with C490003_1; + + with Report; + procedure C490003 is + begin + Report.Test ("C490003", "Check that static expressions failing " & + "Overflow_Check are legal if part of a larger static " & + "expression. Check that static expressions as right " & + "operands of short-circuit control forms are not " & + "evaluated if value of control form is determined by " & + "left operand. Check that static expressions in non-static " & + "contexts are evaluated exactly"); + + + -- + -- Static expressions within larger static expressions: + -- + + + if C490003_0.Flt_Range_Diff not in C490003_0.My_Flt'Base'Range then + Report.Failed ("Error evaluating static expression: floating point"); + end if; + + if C490003_0.Symmetric not in Boolean'Range then + Report.Failed ("Error evaluating static expression: fixed point"); + end if; + + if C490003_0.Center not in Integer'Base'Range then + Report.Failed ("Error evaluating static expression: integer"); + end if; + + + -- + -- Short-circuit control forms: + -- + + declare + N : constant := 0.0; + begin + + begin + if not ( (N = 0.0) or else (1.0/N > 0.5) ) then + Report.Failed ("Error evaluating OR ELSE"); + end if; + exception + when Constraint_Error => + Report.Failed ("Right side of OR ELSE was evaluated"); + when others => + Report.Failed ("OR ELSE: unexpected exception raised"); + end; + + begin + if (N /= 0.0) and then (1.0/N <= 0.5) then + Report.Failed ("Error evaluating AND THEN"); + end if; + exception + when Constraint_Error => + Report.Failed ("Right side of AND THEN was evaluated"); + when others => + Report.Failed ("AND THEN: unexpected exception raised"); + end; + + end; + + + -- + -- Exact evaluation of static expressions: + -- + + + declare + use C490003_1; + + Left : constant := 6.0 + 0.3125*( (Full*0.375) + (Half/2.4) - + ((Quarter + 36.0)/3.0) )/10.0; -- 11.25 + Right : constant := (Pi/3.0) * 1.2 * (15.0/96.0); -- Pi/16 + begin + if Deg_To_Rad*Left /= Right then + Report.Failed ("Static expressions not evaluated exactly: #1"); + end if; + + if ((Pi*Rad_To_Deg)*2.0 + 4.0*Quarter)/16.0 /= Rad_To_Deg*(Pi/4.0) then + Report.Failed ("Static expressions not evaluated exactly: #2"); + end if; + end; + + + Report.Result; + end C490003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49020a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49020a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49020a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49020a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C49020A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ENUMERATION LITERALS (INCLUDING CHARACTER LITERALS) CAN BE + -- USED IN STATIC EXPRESSIONS TOGETHER WITH RELATIONAL AND EQUALITY + -- OPERATORS. + + -- L.BROWN 09/30/86 + + WITH REPORT; USE REPORT; + PROCEDURE C49020A IS + + CAS_BOL : BOOLEAN := TRUE; + OBJ1 : INTEGER := 4; + TYPE ENUM IS (RED,GREEN,BLUE,OFF,ON,'A','B'); + + BEGIN + TEST("C49020A","ENUMERATION LITERALS (INCLUDING CHARACTER "& + "LITERALS) TOGETHER WITH RELATIONAL OPERATORS "& + "CAN BE USED IN STATIC EXPRESSION"); + + CASE CAS_BOL IS + WHEN (RED <= BLUE) => + OBJ1 := 5; + WHEN (BLUE = GREEN) => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 1"); + END CASE; + + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN (GREEN >= ON) => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 2"); + WHEN (ENUM'('A') < ENUM'('B')) => + OBJ1 := 6; + END CASE; + + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN (BLUE > 'B') => + FAILED("INCORRECT VALUE RETURNED BY ENUMERATION "& + "EXPRESSION 3"); + WHEN (OFF /= 'A') => + OBJ1 := 7; + END CASE; + + RESULT; + + END C49020A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49021a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49021a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49021a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49021a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C49021A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BOOLEAN LITERALS CAN BE USED IN STATIC EXPRESSIONS + -- TOGETHER WITH THE LOGICAL OPERATORS, THE NOT OPERATOR, AND THE + -- RELATIONAL AND EQUALITY OPERATORS. + + -- L.BROWN 09/25/86 + + WITH REPORT; USE REPORT; + PROCEDURE C49021A IS + + CAS_BOL : BOOLEAN := TRUE; + X1 : CONSTANT := BOOLEAN'POS((TRUE AND FALSE)OR(TRUE AND TRUE)); + X2 : CONSTANT := BOOLEAN'POS((TRUE <= FALSE)AND(FALSE >= FALSE)); + + BEGIN + TEST("C49021A","BOOLEAN LITERALS TOGETHER WITH CERTAIN OPERATORS,"& + "CAN BE USED IN STATIC EXPRESSIONS."); + IF X1 /= 1 THEN + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 1"); + END IF; + + IF X2 /= 0 THEN + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN EXPRESSION 2"); + END IF; + + CASE CAS_BOL IS + WHEN ((TRUE AND FALSE) XOR (TRUE XOR TRUE)) => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 2"); + WHEN OTHERS => + CAS_BOL := TRUE; + END CASE; + + CASE CAS_BOL IS + WHEN ((TRUE > FALSE) OR (FALSE <= TRUE)) => + CAS_BOL := TRUE; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 3"); + END CASE; + + CASE CAS_BOL IS + WHEN NOT((TRUE OR FALSE) = (FALSE AND TRUE)) => + CAS_BOL := TRUE; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 4"); + END CASE; + + CASE CAS_BOL IS + WHEN (((TRUE = FALSE) OR (FALSE AND TRUE)) /= (TRUE < TRUE))=> + FAILED("INCORRECT VALUE RETURNED BY BOOLEAN " & + "EXPRESSION 5"); + WHEN OTHERS => + CAS_BOL := TRUE; + END CASE; + + RESULT; + + END C49021A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C49022A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NAMED NUMBER DECLARATIONS (INTEGER) MAY USE EXPRESSIONS + -- WITH INTEGERS. + + -- BAW 29 SEPT 80 + -- TBN 10/28/85 RENAMED FROM C4A001A.ADA. ADDED RELATIONAL + -- OPERATORS AND USE OF NAMED NUMBERS. + + WITH REPORT; + PROCEDURE C49022A IS + + USE REPORT; + + ADD1 : CONSTANT := 1 + 1; + ADD2 : CONSTANT := 1 + (-1); + ADD3 : CONSTANT := (-1) + 1; + ADD4 : CONSTANT := (-1) + (-1); + SUB1 : CONSTANT := 1 - 1; + SUB2 : CONSTANT := 1 - (-1); + SUB3 : CONSTANT := (-1) - 1; + SUB4 : CONSTANT := (-1) - (-1); + MUL1 : CONSTANT := 1 * 1; + MUL2 : CONSTANT := 1 * (-1); + MUL3 : CONSTANT := (-1) * 1; + MUL4 : CONSTANT := (-1) * (-1); + DIV1 : CONSTANT := 1 / 1; + DIV2 : CONSTANT := 1 / (-1); + DIV3 : CONSTANT := (-1) / 1; + DIV4 : CONSTANT := (-1) / (-1); + REM1 : CONSTANT := 14 REM 5; + REM2 : CONSTANT := 14 REM(-5); + REM3 : CONSTANT :=(-14) REM 5; + REM4 : CONSTANT :=(-14) REM(-5); + MOD1 : CONSTANT := 4 MOD 3; + MOD2 : CONSTANT := 4 MOD (-3); + MOD3 : CONSTANT := (-4) MOD 3; + MOD4 : CONSTANT := (-4) MOD (-3); + EXP1 : CONSTANT := 1 ** 1; + EXP2 : CONSTANT := (-1) ** 1; + ABS1 : CONSTANT := ABS( - 10 ); + ABS2 : CONSTANT := ABS( + 10 ); + TOT1 : CONSTANT := ADD1 + SUB1 - MUL1 + DIV1 - REM3 + MOD2 - EXP1; + LES1 : CONSTANT := BOOLEAN'POS (1 < 2); + LES2 : CONSTANT := BOOLEAN'POS (1 < (-2)); + LES3 : CONSTANT := BOOLEAN'POS ((-1) < (-2)); + LES4 : CONSTANT := BOOLEAN'POS (ADD1 < SUB1); + GRE1 : CONSTANT := BOOLEAN'POS (2 > 1); + GRE2 : CONSTANT := BOOLEAN'POS ((-1) > 2); + GRE3 : CONSTANT := BOOLEAN'POS ((-1) > (-2)); + GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1); + LEQ1 : CONSTANT := BOOLEAN'POS (1 <= 1); + LEQ2 : CONSTANT := BOOLEAN'POS ((-1) <= 1); + LEQ3 : CONSTANT := BOOLEAN'POS ((-1) <= (-2)); + LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB3); + GEQ1 : CONSTANT := BOOLEAN'POS (2 >= 1); + GEQ2 : CONSTANT := BOOLEAN'POS ((-2) >= 1); + GEQ3 : CONSTANT := BOOLEAN'POS ((-2) >= (-1)); + GEQ4 : CONSTANT := BOOLEAN'POS (ADD2 >= SUB3); + EQU1 : CONSTANT := BOOLEAN'POS (2 = 2); + EQU2 : CONSTANT := BOOLEAN'POS ((-2) = 2); + EQU3 : CONSTANT := BOOLEAN'POS ((-2) = (-2)); + EQU4 : CONSTANT := BOOLEAN'POS (ADD2 = SUB3); + NEQ1 : CONSTANT := BOOLEAN'POS (2 /= 2); + NEQ2 : CONSTANT := BOOLEAN'POS ((-2) /= 1); + NEQ3 : CONSTANT := BOOLEAN'POS ((-2) /= (-2)); + NEQ4 : CONSTANT := BOOLEAN'POS (ADD2 /= SUB3); + + + BEGIN + TEST("C49022A","CHECK THAT NAMED NUMBER DECLARATIONS (INTEGER) " & + "MAY USE EXPRESSIONS WITH INTEGERS"); + + IF ADD1 /= 2 OR ADD2 /= 0 OR ADD3 /= 0 OR ADD4 /= -2 THEN + FAILED("ERROR IN THE ADDING OPERATOR +"); + END IF; + + IF SUB1 /= 0 OR SUB2 /= 2 OR SUB3 /= -2 OR SUB4 /= 0 THEN + FAILED("ERROR IN THE ADDING OPERATOR -"); + END IF; + + IF MUL1 /= 1 OR MUL2 /= -1 OR MUL3 /= -1 OR MUL4 /= 1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF DIV1 /= 1 OR DIV2 /= -1 OR DIV3 /= -1 OR DIV4 /= 1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF REM1 /= 4 OR REM2 /= 4 OR REM3 /= -4 OR REM4 /= -4 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR REM"); + END IF; + + IF MOD1 /= 1 OR MOD2 /= -2 OR MOD3 /= 2 OR MOD4 /= -1 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR MOD"); + END IF; + + IF EXP1 /= 1 OR EXP2 /= -1 THEN + FAILED("ERROR IN THE EXPONENTIATING OPERATOR"); + END IF; + + IF ABS1 /= 10 OR ABS2 /= 10 THEN + FAILED("ERROR IN THE ABS OPERATOR"); + END IF; + + IF TOT1 /= 3 THEN + FAILED("ERROR IN USING NAMED NUMBERS WITH OPERATORS"); + END IF; + + IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN OPERATOR"); + END IF; + + IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 1 OR GRE4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN OPERATOR"); + END IF; + + IF LEQ1 /= 1 OR LEQ2 /= 1 OR LEQ3 /= 0 OR LEQ4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR"); + END IF; + + IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR"); + END IF; + + IF EQU1 /= 1 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 0 THEN + FAILED("ERROR IN THE EQUAL OPERATOR"); + END IF; + + IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 0 OR NEQ4 /= 1 THEN + FAILED("ERROR IN THE NOT EQUAL OPERATOR"); + END IF; + + RESULT; + + END C49022A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C49022B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN NUMBER DECLARATIONS, IDENTIFIERS CORRECTLY REPRESENT + -- VALUES OF OTHER LITERALS. + + -- BAW 29 SEPT 80 + -- TBN 10/22/85 RENAMED FROM C4A003A.ADA AND ADDED RELATIONAL + -- OPERATORS USING NAMED NUMBERS. + + + WITH REPORT; + PROCEDURE C49022B IS + + USE REPORT; + + A : CONSTANT := 10; -- A = 10 + B : CONSTANT := 25 - (2 * A); -- B = 5 + C : CONSTANT := A / B; -- C = 2 + D : CONSTANT := (C * A) - (B - C); -- D = 17 + E : CONSTANT := D ** C; -- E = 289 + F : CONSTANT := (E MOD A) + 1; -- F = 10 + G : CONSTANT := A REM B + C + D + E + ABS(-F); -- G = 318 + H : CONSTANT := BOOLEAN'POS (A > B); -- H = 1 + I : CONSTANT := BOOLEAN'POS (A < B); -- I = 0 + J : CONSTANT := BOOLEAN'POS (C >= A); -- J = 0 + K : CONSTANT := BOOLEAN'POS (B <= B); -- K = 1 + L : CONSTANT := BOOLEAN'POS (D = A); -- L = 0 + M : CONSTANT := BOOLEAN'POS (A /= F); -- M = 0 + + BEGIN + TEST("C49022B","CHECK THAT IN NUMBER DECLARATIONS, IDENTIFIERS " & + "CORRECTLY REPRESENT VALUES OF OTHER LITERALS"); + + IF G /= 318 THEN + FAILED("USE OF OTHER NUMBER DECLARATIONS GIVES " & + "WRONG RESULTS"); + END IF; + + IF H /= 1 OR I /= 0 OR J /= 0 OR K /= 1 THEN + FAILED("USE OF NAMED NUMBERS AND RELATIONAL OPERATORS " & + "GIVES WRONG RESULTS"); + END IF; + + IF L /= 0 OR M /= 0 THEN + FAILED("USE OF NAMED NUMBERS AND EQUALITY OPERATORS " & + "GIVES WRONG RESULTS"); + END IF; + + RESULT; + + END C49022B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49022c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49022c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C49022C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NAMED NUMBER DECLARATIONS (REAL) MAY USE EXPRESSIONS + -- WITH REALS. + + -- BAW 29 SEPT 80 + -- TBN 10/24/85 RENAMED FROM C4A011A.ADA. ADDED RELATIONAL + -- OPERATORS AND NAMED NUMBERS. + + WITH REPORT; + PROCEDURE C49022C IS + + USE REPORT; + + ADD1 : CONSTANT := 2.5 + 1.5; + ADD2 : CONSTANT := 2.5 + (-1.5); + ADD3 : CONSTANT := (-2.5) + 1.5; + ADD4 : CONSTANT := (-2.5) + (-1.5); + SUB1 : CONSTANT := 2.5 - 1.5; + SUB2 : CONSTANT := 2.5 - (-1.5); + SUB3 : CONSTANT := (-2.5) - 1.5; + SUB4 : CONSTANT := (-2.5) - (-1.5); + MUL1 : CONSTANT := 2.5 * 1.5; + MUL2 : CONSTANT := 2.5 * (-1.5); + MUL3 : CONSTANT := (-2.5) * 1.5; + MUL4 : CONSTANT := (-2.5) * (-1.5); + MLR1 : CONSTANT := 2 * 1.5; + MLR2 : CONSTANT := (-2) * 1.5; + MLR3 : CONSTANT := 2 * (-1.5); + MLR4 : CONSTANT := (-2) * (-1.5); + MLL1 : CONSTANT := 1.5 * 2 ; + MLL2 : CONSTANT := 1.5 * (-2); + MLL3 : CONSTANT :=(-1.5) * 2 ; + MLL4 : CONSTANT :=(-1.5) * (-2); + DIV1 : CONSTANT := 3.75 / 2.5; + DIV2 : CONSTANT := 3.75 / (-2.5); + DIV3 : CONSTANT := (-3.75) / 2.5; + DIV4 : CONSTANT := (-3.75) / (-2.5); + DVI1 : CONSTANT := 3.0 / 2; + DVI2 : CONSTANT := (-3.0) / 2; + DVI3 : CONSTANT := 3.0 / (-2); + DVI4 : CONSTANT := (-3.0) / (-2); + EXP1 : CONSTANT := 2.0 ** 1; + EXP2 : CONSTANT := 2.0 ** (-1); + EXP3 : CONSTANT := (-2.0) ** 1; + EXP4 : CONSTANT := (-2.0) ** (-1); + ABS1 : CONSTANT := ABS( - 3.75 ); + ABS2 : CONSTANT := ABS( + 3.75 ); + TOT1 : CONSTANT := ADD1 + SUB4 - MUL1 + DIV1 - EXP2 + ABS1; + LES1 : CONSTANT := BOOLEAN'POS (1.5 < 2.0); + LES2 : CONSTANT := BOOLEAN'POS (1.5 < (-2.0)); + LES3 : CONSTANT := BOOLEAN'POS ((-1.5) < (-2.0)); + LES4 : CONSTANT := BOOLEAN'POS (ADD2 < SUB1); + GRE1 : CONSTANT := BOOLEAN'POS (2.0 > 1.5); + GRE2 : CONSTANT := BOOLEAN'POS ((-2.0) > 1.5); + GRE3 : CONSTANT := BOOLEAN'POS ((-2.0) > (-1.5)); + GRE4 : CONSTANT := BOOLEAN'POS (ADD1 > SUB1); + LEQ1 : CONSTANT := BOOLEAN'POS (1.5 <= 2.0); + LEQ2 : CONSTANT := BOOLEAN'POS (1.5 <= (-2.0)); + LEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) <= (-2.0)); + LEQ4 : CONSTANT := BOOLEAN'POS (ADD2 <= SUB1); + GEQ1 : CONSTANT := BOOLEAN'POS (2.0 >= 1.5); + GEQ2 : CONSTANT := BOOLEAN'POS ((-2.0) >= 1.5); + GEQ3 : CONSTANT := BOOLEAN'POS ((-2.0) >= (-1.5)); + GEQ4 : CONSTANT := BOOLEAN'POS (ADD1 >= SUB2); + EQU1 : CONSTANT := BOOLEAN'POS (1.5 = 2.0); + EQU2 : CONSTANT := BOOLEAN'POS ((-1.5) = 2.0); + EQU3 : CONSTANT := BOOLEAN'POS ((-1.5) = (-1.5)); + EQU4 : CONSTANT := BOOLEAN'POS (ADD1 = SUB2); + NEQ1 : CONSTANT := BOOLEAN'POS (1.5 /= 1.5); + NEQ2 : CONSTANT := BOOLEAN'POS ((-1.5) /= 1.5); + NEQ3 : CONSTANT := BOOLEAN'POS ((-1.5) /= (-2.0)); + NEQ4 : CONSTANT := BOOLEAN'POS (ADD1 /= SUB2); + + + BEGIN + TEST("C49022C","CHECK THAT NAMED NUMBER DECLARATIONS (REAL) " & + "MAY USE EXPRESSIONS WITH REALS."); + + IF ADD1 /= 4.0 OR ADD2 /= 1.0 OR ADD3 /= -1.0 OR ADD4 /= -4.0 THEN + FAILED("ERROR IN THE ADDING OPERATOR +"); + END IF; + + IF SUB1 /= 1.0 OR SUB2 /= 4.0 OR SUB3 /= -4.0 OR SUB4 /= -1.0 THEN + FAILED("ERROR IN THE ADDING OPERATOR -"); + END IF; + + IF MUL1 /= 3.75 OR MUL2 /= -3.75 OR + MUL3 /= -3.75 OR MUL4 /= 3.75 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF MLR1 /= 3.0 OR MLR2 /= -3.0 OR + MLR3 /= -3.0 OR MLR4 /= 3.0 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF MLL1 /= 3.0 OR MLL2 /= -3.0 OR MLL3 /= -3.0 OR MLL4 /= 3.0 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR *"); + END IF; + + IF DIV1 /= 1.5 OR DIV2 /= -1.5 OR DIV3 /= -1.5 OR DIV4 /= 1.5 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF DVI1 /= 1.5 OR DVI2 /= -1.5 OR DVI3 /= -1.5 OR DVI4 /= 1.5 THEN + FAILED("ERROR IN THE MULTIPLYING OPERATOR /"); + END IF; + + IF EXP1 /= 2.0 OR EXP2 /= 0.5 OR EXP3 /= -2.0 OR EXP4 /= -0.5 THEN + FAILED("ERROR IN THE EXPONENTIATING OPERATOR"); + END IF; + + IF ABS1 /= 3.75 OR ABS2 /= 3.75 THEN + FAILED("ERROR IN THE ABS OPERATOR"); + END IF; + + IF TOT1 /= 4.00 THEN + FAILED("ERROR IN USE OF NAMED NUMBERS WITH OPERATORS"); + END IF; + + IF LES1 /= 1 OR LES2 /= 0 OR LES3 /= 0 OR LES4 /= 0 THEN + FAILED("ERROR IN THE LESS THAN OPERATOR"); + END IF; + + IF GRE1 /= 1 OR GRE2 /= 0 OR GRE3 /= 0 OR GRE4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN OPERATOR"); + END IF; + + IF LEQ1 /= 1 OR LEQ2 /= 0 OR LEQ3 /= 0 OR LEQ4 /= 1 THEN + FAILED("ERROR IN THE LESS THAN EQUAL OPERATOR"); + END IF; + + IF GEQ1 /= 1 OR GEQ2 /= 0 OR GEQ3 /= 0 OR GEQ4 /= 1 THEN + FAILED("ERROR IN THE GREATER THAN EQUAL OPERATOR"); + END IF; + + IF EQU1 /= 0 OR EQU2 /= 0 OR EQU3 /= 1 OR EQU4 /= 1 THEN + FAILED("ERROR IN THE EQUAL OPERATOR"); + END IF; + + IF NEQ1 /= 0 OR NEQ2 /= 1 OR NEQ3 /= 1 OR NEQ4 /= 0 THEN + FAILED("ERROR IN THE NOT EQUAL OPERATOR"); + END IF; + + RESULT; + + END C49022C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49023a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49023a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49023a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49023a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C49023A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONSTANT DECLARED BY AN OBJECT DECLARATION CAN BE USED + -- IN A STATIC EXPRESSION IF THE CONSTANT WAS DECLARED WITH A STATIC + -- SUBTYPE AND INITIALIZED WITH A STATIC EXPRESSION. + + -- L.BROWN 10/01/86 + + WITH REPORT; USE REPORT; + PROCEDURE C49023A IS + + BEGIN + TEST("C49023A","A CONSTANT DECLARED BY AN OBJECT DECLARATION "& + "UNDER CERTAIN CONDITIONS CAN BE USED IN A "& + "STATIC EXPRESSION"); + DECLARE + TYPE ENUM IS (RED,GREEN,BLUE,YELLOW); + SUBTYPE SENUM IS ENUM RANGE RED .. BLUE; + CONEN : CONSTANT SENUM := GREEN; + TYPE INT IS RANGE 1 .. 10; + SUBTYPE SINT IS INT RANGE 1 .. 5; + CONIN : CONSTANT SINT := 3; + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0; + SUBTYPE SFLT IS FLT RANGE 10.0 .. 20.0; + CONFL : CONSTANT SFLT := 11.0; + TYPE FIX IS DELTA 0.25 RANGE 0.0 .. 25.0; + SUBTYPE SFIX IS FIX RANGE 0.0 .. 12.0; + CONFI : CONSTANT SFIX := 0.25; + CAS_EN : ENUM := CONEN; + TYPE ITEG IS RANGE 1 .. CONIN; + TYPE FLTY IS DIGITS CONIN; + TYPE FIXY IS DELTA CONFI RANGE 0.0 .. 10.0; + TYPE REAL IS DELTA 0.25 RANGE 0.0 .. 11.0; + TYPE FIXTY IS DELTA 0.25 RANGE 0.0 .. CONFL; + + FUNCTION IDENT_REAL (X : REAL) RETURN REAL; + + PACKAGE P IS + TYPE T IS PRIVATE; + CON1 : CONSTANT T; + PRIVATE + TYPE T IS NEW INTEGER; + CON1 : CONSTANT T := 10; + TYPE NINT IS RANGE 1 .. CON1; + END P; + PACKAGE BODY P IS + TYPE CON2 IS RANGE CON1 .. 50; + BEGIN + IF NINT'LAST /= NINT(IDENT_INT(10)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 1"); + END IF; + IF CON2'FIRST /= CON2(IDENT_INT(10)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 2"); + END IF; + END P; + + FUNCTION IDENT_REAL (X : REAL) RETURN REAL IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0.0; + END IF; + END IDENT_REAL; + + BEGIN + + IF ITEG'LAST /= ITEG(IDENT_INT(3)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 3"); + END IF; + + IF FLTY'DIGITS /= IDENT_INT(3) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 4"); + END IF; + + IF FIXY'DELTA /= IDENT_REAL(0.25) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 5"); + END IF; + + IF FIXTY'LAST /= FIXTY(IDENT_REAL(11.0)) THEN + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 6"); + END IF; + + CASE CAS_EN IS + WHEN CONEN => + CAS_EN := RED; + WHEN OTHERS => + FAILED("INCORRECT VALUE FOR STATIC EXPRESSION 7"); + END CASE; + + END; + + RESULT; + + END C49023A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49024a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49024a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49024a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49024a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C49024A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FUNCTION CALL CAN APPEAR IN A STATIC EXPRESSION IF THE + -- FUNCTION NAME DENOTES A PREDEFINED OPERATOR AND HAS THE FORM OF AN + -- OPERATOR SYMBOL OR AN EXPANDED NAME WHOSE SELECTOR IS AN OPERATOR + -- SYMBOL. + + -- L.BROWN 10/02/86 + + WITH REPORT; USE REPORT; + PROCEDURE C49024A IS + + PACKAGE P IS + TYPE TY IS NEW INTEGER; + END P; + + CON1 : CONSTANT P.TY := 3; + CON2 : CONSTANT P.TY := 4; + TYPE INT1 IS RANGE 1 .. P."+"(CON1,CON2); + CON3 : CONSTANT := 5; + CON4 : CONSTANT := 7; + TYPE FLT IS DIGITS "-"(CON4,CON3); + TYPE FIX1 IS DELTA 1.0 RANGE 0.0 .. 25.0; + CON5 : CONSTANT := 3.0; + CON6 : CONSTANT := 6.0; + TYPE FIX2 IS DELTA 1.0 RANGE 0.0 .. "/"(CON6,CON5); + TYPE ENUM IS (RED,BLUE,GREEN,BLACK); + CON7 : CONSTANT BOOLEAN := TRUE; + CON8 : CONSTANT ENUM := BLUE; + CAS_INT1 : CONSTANT := 10; + CAS_INT2 : CONSTANT := 2; + OBJ1 : INTEGER := 10; + CAS_BOL : BOOLEAN := TRUE; + CON9 : CONSTANT ENUM := BLACK; + CON10 : CONSTANT FIX1 := 2.0; + CON11 : CONSTANT FIX1 := 10.0; + TYPE FIX3 IS DELTA "+"(CON10) RANGE 0.0 .. 20.0; + TYPE INT2 IS RANGE 0 .. "ABS"("-"(CON4)); + CON12 : CONSTANT CHARACTER := 'D'; + CON13 : CONSTANT CHARACTER := 'B'; + CON14 : CONSTANT BOOLEAN := FALSE; + CON15 : CONSTANT := 10; + + BEGIN + + TEST("C49024A","A FUNCTION CALL CAN BE IN A STATIC EXPRESSION "& + "IF THE FUNCTION NAME DENOTES A PREDEFINED "& + "OPERATOR AND HAS THE FORM OF AN OPERATOR SYMBOL"); + + CASE CAS_BOL IS + WHEN ("NOT"(CON7)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 1"); + WHEN ("/="(CON8,CON9)) => + OBJ1 := 2; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("*"(CON3,CON4) = CAS_INT1) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 2"); + WHEN ("ABS"(CON15) = CAS_INT1) => + OBJ1 := 3; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("<"(CON11,CON10)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 3"); + WHEN ("<="(CON13,CON12)) => + OBJ1 := 4; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("REM"(CON4,CON3) = CAS_INT2) => + OBJ1 := 5; + WHEN ("**"(CON3,CON4) = CAS_INT2) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 4"); + END CASE; + + CASE CAS_BOL IS + WHEN (P.">"(CON1,CON2)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 5"); + WHEN ("OR"(CON7,CON14)) => + OBJ1 := 6; + END CASE; + CAS_BOL := TRUE; + + CASE CAS_BOL IS + WHEN ("MOD"(CON4,CON3) = CAS_INT2) => + OBJ1 := 7; + WHEN ("ABS"(CON4) = CAS_INT2) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 6"); + END CASE; + + CASE CAS_BOL IS + WHEN ("AND"(CON7,CON14)) => + FAILED("INCORRECT VALUE RETURNED FOR STATIC "& + "OPERATORS 7"); + WHEN (">="(CON12,CON13)) => + OBJ1 := 9; + END CASE; + + RESULT; + + END C49024A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49025a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49025a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49025a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49025a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C49025A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CERTAIN ATTRIBUTES CAN BE USED IN STATIC EXPRESSIONS + -- SUCH AS: 'SUCC, 'PRED, 'POS, 'VAL, 'AFT, 'DELTA, 'DIGITS, 'FIRST, + --'FORE, 'LAST, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_MANTISSA, + --'MACHINE_OVERFLOWS, 'MACHINE_RADIX, 'MACHINE_ROUNDS, 'SIZE, 'SMALL, 'WIDTH. + + -- L.BROWN 10/07/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C49025A IS + + TYPE ENUM IS (RED,BLUE,GREEN,BLACK); + TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 20.0; + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 25.0; + TYPE INT IS RANGE 1 .. 100; + TYPE TINT1 IS RANGE 1 .. ENUM'POS(BLUE); + TYPE TFLT IS DIGITS FIX'AFT RANGE 0.0 .. 10.0; + TYPE TFIX2 IS DELTA FIX'DELTA RANGE 0.0 .. 5.0; + TYPE TFLT1 IS DIGITS FLT'DIGITS; + TYPE ITN IS RANGE 0 .. INT'FIRST; + TYPE TINT2 IS RANGE 1 .. FIX'FORE; + TYPE TFLT3 IS DIGITS 3 RANGE 5.0 .. FLT'LAST; + CON3 : CONSTANT := FLT'MACHINE_EMAX; + TYPE TINT3 IS RANGE FLT'MACHINE_EMIN .. 1; + CON4 : CONSTANT := FLT'MACHINE_MANTISSA; + TYPE TINT4 IS RANGE 1 .. FLT'MACHINE_RADIX; + CON6 : CONSTANT := INT'SIZE; + TYPE TFIX5 IS DELTA 0.125 RANGE 0.0 .. FIX'SMALL; + TYPE TINT6 IS RANGE 1 .. ENUM'WIDTH; + OBJ1 : INTEGER := 1; + CAS_OBJ : BOOLEAN := TRUE; + + BEGIN + + TEST("C49025A","CHECK THAT CERTAIN ATTRIBUTES CAN "& + "BE USED IN STATIC EXPRESSIONS."); + + CASE CAS_OBJ IS + WHEN (ENUM'PRED(BLUE) = ENUM'(RED)) => + OBJ1 := 2; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 1"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (ENUM'SUCC(RED) = ENUM'(BLUE)) => + OBJ1 := 3; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 2"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (ENUM'VAL(3) = ENUM'(BLACK)) => + OBJ1 := 4; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 3"); + END CASE; + CAS_OBJ := TRUE; + + CASE CAS_OBJ IS + WHEN (TRUE OR FLT'MACHINE_OVERFLOWS) => + OBJ1 := 5; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 4"); + END CASE; + CAS_OBJ := FALSE; + + CASE CAS_OBJ IS + WHEN (FALSE AND FIX'MACHINE_ROUNDS) => + OBJ1 := 6; + WHEN OTHERS => + FAILED("INCORRECT VALUE RETURNED FOR ATTRIBUTE 5"); + END CASE; + + RESULT; + + END C49025A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49026a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49026a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c49026a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c49026a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C49026A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A QUALIFIED EXPRESSION CAN APPEAR IN A STATIC EXPRESSION. + + -- L.BROWN 10/07/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C49026A IS + + TYPE ENUM IS (RED,GREEN,BLUE,YELLOW); + TYPE INT1 IS RANGE 1 .. 50; + TYPE FLT1 IS DIGITS 3 RANGE 1.0 .. 5.0; + TYPE FIX1 IS DELTA 0.125 RANGE 0.0 .. 10.0; + TYPE INT2 IS RANGE 1 .. INT1'(25); + TYPE FLT2 IS DIGITS 3 RANGE 1.0 .. FLT1'(2.0); + TYPE FIX2 IS DELTA 0.125 RANGE 0.0 .. FIX1'(5.0); + TYPE FLT3 IS DIGITS INT1'(3); + TYPE FIX3 IS DELTA FIX1'(0.125) RANGE 0.0 .. 5.0; + OBJ1 : INTEGER := 2; + CAS_OBJ : ENUM := GREEN; + + BEGIN + + TEST("C49026A","QUALIFIED EXPRESSIONS CAN APPEAR IN STATIC "& + "EXPRESSIONS"); + + CASE CAS_OBJ IS + WHEN ENUM'(GREEN) => + OBJ1 := 3; + WHEN OTHERS => + FAILED("INCORRECT VALUE FOR QUALIFIED EXPRESSION 1"); + END CASE; + + RESULT; + + END C49026A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a005b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C4A005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A NONSTATIC UNIVERSAL INTEGER EXPRESSION RAISES + -- CONSTRAINT_ERROR IF DIVISION BY ZERO IS ATTEMPTED + -- OR IF THE SECOND OPERAND OF REM OR MOD IS ZERO. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- JBG 5/2/85 + -- EG 10/24/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387; PREVENT DEAD VARIABLE OPTIMIZATION + -- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C4A005B IS + BEGIN + TEST("C4A005B", "CHECK CONSTRAINT_ERROR FOR " & + "NONSTATIC UNIVERSAL " & + "INTEGER EXPRESSIONS - DIVISION BY ZERO"); + BEGIN + DECLARE + X : BOOLEAN := 1 = 1/INTEGER'POS(IDENT_INT(0)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - DIV"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - DIV"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - DIV"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR / BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DIV"); + END; + + BEGIN + DECLARE + X : BOOLEAN := 1 = 1 REM INTEGER'POS(IDENT_INT(0)); + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - REM"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - REM"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - REM"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR REM BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REM"); + END; + + BEGIN + DECLARE + X : BOOLEAN := 1 = INTEGER'POS(IDENT_INT(1)) MOD 0; + BEGIN + FAILED ("CONSTRAINT_ERROR NOT RAISED - MOD"); + IF X /= IDENT_BOOL(X) THEN + FAILED ("WRONG RESULT - MOD"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION IN WRONG PLACE - MOD"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR MOD BY 0"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MOD"); + END; + + RESULT; + + END C4A005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a006a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- C4A006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A UNIVERSAL_INTEGER + -- EXPRESSION CONTAINING AN EXPONENTIATION OPERATOR IF THE EXPONENT + -- HAS A NEGATIVE VALUE. + + -- BAW 9/29/80 + -- SPS 4/7/82 + -- TBN 10/23/85 RENAMED FROM B4A006A-B.ADA. REVISED TO CHECK FOR + -- CONSTRAINT_ERROR WHEN EXPONENT IS NEGATIVE IN + -- A NONSTATIC CONTEXT. + + WITH REPORT; USE REPORT; + PROCEDURE C4A006A IS + + BEGIN + TEST ("C4A006A", "CHECK THAT A NEGATIVE EXPONENT IN " & + "UNIVERSAL_INTEGER EXPONENTIATION RAISES " & + "CONSTRAINT_ERROR"); + + DECLARE + B : BOOLEAN; + BEGIN + + B := (1 ** IDENT_INT(-1)) = 1; + FAILED ("EXCEPTION NOT RAISED"); + IF NOT B THEN + FAILED ("(1 ** (-1)) /= 1"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; + END C4A006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a007a.tst 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + -- C4A007A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- USE OF MAX_INT IN NUMBER DECLARATION + + -- BAW 29 SEPT 80 + + WITH REPORT; + PROCEDURE C4A007A IS + + USE REPORT; + + X : CONSTANT := $MAX_INT - ($MAX_INT MOD 2); + Y : CONSTANT := ($MAX_INT / 2) * 2; + + BEGIN TEST("C4A007A","USING THE INTEGER VALUE MAX_INT IN NUMBER " & + " DECLARATIONS "); + + IF X /= Y + THEN FAILED("USING THE INTEGER VALUE MAX_INT GIVES " & + " GIVES WRONG RESULTS "); + END IF; + + RESULT; + + END C4A007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a010a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C4A010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT STATIC UNIVERSAL_REAL EXPRESSIONS ARE EVALUATED EXACTLY. + + -- SMALL RATIONAL NUMBERS ARE USED IN THIS TEST. + + -- JBG 5/3/85 + + WITH REPORT; USE REPORT; + PROCEDURE C4A010A IS + + C13 : CONSTANT := 1.0/3.0; + C47 : CONSTANT := 4.0/7.0; + C112: CONSTANT := 13.0/12.0; + HALF: CONSTANT := 3.5/7.0; + + BEGIN + + TEST ("C4A010A", "CHECK STATIC UNIVERSAL_REAL ACCURACY FOR " & + "SMALL RATIONAL NUMBERS"); + + IF C13 - C47 /= -5.0/21.0 THEN + FAILED ("REAL SUBTRACTION RESULT INCORRECT"); + END IF; + + IF C47 + C112 = 1.0 + 55.0/84.0 THEN + NULL; + ELSE + FAILED ("REAL ADDITION RESULT INCORRECT"); + END IF; + + IF C112 - C13 /= 6.0/8.0 THEN + FAILED ("LCD NOT FOUND"); + END IF; + + IF 0.1 * 0.1 /= 0.01 THEN + FAILED ("REAL MULTIPLICATION RESULT INCORRECT"); + END IF; + + IF C112/C13 /= 13.0/4 THEN + FAILED ("REAL QUOTIENT RESULT INCORRECT"); + END IF; + + IF 0.1 ** 4 /= 0.0001 THEN + FAILED ("POSITIVE EXPONENTIATION RESULT INCORRECT"); + END IF; + + IF C13 ** (-3) /= 27.0 * 0.5 * 2 THEN + FAILED ("NEGATIVE EXPONENTIATION RESULT INCORRECT"); + END IF; + + IF HALF /= 0.1/0.2 THEN + FAILED ("FRACTIONAL NUMERATOR AND DENOMINATOR"); + END IF; + + RESULT; + + END C4A010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a010b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C4A010B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT STATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED + -- EXACTLY. IN PARTICULAR, CHECK THAT THE CASCADING USE OF FRACTIONAL + -- VALUES DOES NOT RESULT IN THE LOSS OF PRECISION. + + -- RJW 7/31/86 + + WITH REPORT; USE REPORT; + PROCEDURE C4A010B IS + + + BEGIN + + TEST( "C4A010B", "CHECK THAT STATIC UNIVERSAL REAL EXPRESSIONS " & + "ARE EVALUATED EXACTLY. IN PARTICULAR, CHECK " & + "THAT THE CASCADING USE OF FRACTIONAL VALUES " & + "DOES NOT RESULT IN THE LOSS OF PRECISION" ); + + DECLARE + B : CONSTANT := 2.0/3.0; + + X0 : CONSTANT := 1.0; + X1 : CONSTANT := X0 + B; + X2 : CONSTANT := X1 + B ** 2; + X3 : CONSTANT := X2 + B ** 3; + X4 : CONSTANT := X3 + B ** 4; + X5 : CONSTANT := X4 + B ** 5; + X6 : CONSTANT := X5 + B ** 6; + X7 : CONSTANT := X6 + B ** 7; + X8 : CONSTANT := X7 + B ** 8; + X9 : CONSTANT := X8 + B ** 9; + + Y1 : CONSTANT := B ** 10; + Y2 : CONSTANT := 1.0; + Y3 : CONSTANT := Y1 - Y2; + Y4 : CONSTANT := B; + Y5 : CONSTANT := Y4 - Y2; + Y6 : CONSTANT := Y3 / Y5; + + BEGIN + IF X9 /= 58025.0/19683.0 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 1" ); + END IF; + + IF Y6 /= 58025.0/19683.0 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 2" ); + END IF; + + IF X9 /= Y6 THEN + FAILED ( "INCORRECT RESULTS FOR SERIES OF NAMED " & + "NUMBERS - 3" ); + END IF; + + END; + + RESULT; + END C4A010B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a011a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- C4A011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NONSTATIC UNIVERSAL REAL EXPRESSIONS ARE EVALUATED WITH + -- THE ACCURACY OF THE MOST PRECISE PREDEFINED FLOATING POINT TYPE + -- (I. E., THE TYPE FOR WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS). + + -- RJW 8/4/86 + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C4A011A IS + + TYPE MAX_FLOAT IS DIGITS MAX_DIGITS; + + C5L : CONSTANT := 16#0.AAAA8#; + C5U : CONSTANT := 16#0.AAAAC#; + + C6L : CONSTANT := 16#0.AAAAA8#; + C6U : CONSTANT := 16#0.AAAAB0#; + + C7L : CONSTANT := 16#0.AAAAAA8#; + C7U : CONSTANT := 16#0.AAAAAB0#; + + C8L : CONSTANT := 16#0.AAAAAAA#; + C8U : CONSTANT := 16#0.AAAAAAB#; + + C9L : CONSTANT := 16#0.AAAAAAAA#; + C9U : CONSTANT := 16#0.AAAAAAAC#; + + C10L : CONSTANT := 16#0.AAAAAAAAA#; + C10U : CONSTANT := 16#0.AAAAAAAAC#; + + C11L : CONSTANT := 16#0.AAAAAAAAA8#; + C11U : CONSTANT := 16#0.AAAAAAAAAC#; + + C12L : CONSTANT := 16#0.AAAAAAAAAA8#; + C12U : CONSTANT := 16#0.AAAAAAAAAB0#; + + C13L : CONSTANT := 16#0.AAAAAAAAAAA8#; + C13U : CONSTANT := 16#0.AAAAAAAAAAB0#; + + C14L : CONSTANT := 16#0.AAAAAAAAAAAA#; + C14U : CONSTANT := 16#0.AAAAAAAAAAAB#; + + C15L : CONSTANT := 16#0.AAAAAAAAAAAAA#; + C15U : CONSTANT := 16#0.AAAAAAAAAAAAC#; + + C16L : CONSTANT := 16#0.AAAAAAAAAAAAAA#; + C16U : CONSTANT := 16#0.AAAAAAAAAAAAAC#; + + C17L : CONSTANT := 16#0.AAAAAAAAAAAAAA8#; + C17U : CONSTANT := 16#0.AAAAAAAAAAAAAAC#; + + C18L : CONSTANT := 16#0.AAAAAAAAAAAAAAA8#; + C18U : CONSTANT := 16#0.AAAAAAAAAAAAAAB0#; + + C19L : CONSTANT := 16#0.AAAAAAAAAAAAAAAA8#; + C19U : CONSTANT := 16#0.AAAAAAAAAAAAAAAB0#; + + C20L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAA#; + C20U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAB#; + + C21L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAA#; + C21U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAC#; + + C22L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA#; + C22U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAC#; + + C23L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAA8#; + C23U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAC#; + + C24L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAA8#; + C24U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAB0#; + + C25L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAA8#; + C25U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAB0#; + + C26L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAA#; + C26U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAB#; + + C27L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAA#; + C27U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAC#; + + C28L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA#; + C28U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAC#; + + C29L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAA8#; + C29U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAC#; + + C30L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAA8#; + C30U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAB0#; + + C31L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAA#; + C31U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAB#; + + C32L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAA#; + C32U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAB#; + + C33L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA#; + C33U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + + C34L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAA8#; + C34U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + + C35L : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAA8#; + C35U : CONSTANT := 16#0.AAAAAAAAAAAAAAAAAAAAAAAAAAAAAC#; + + BEGIN + + TEST ( "C4A011A", "CHECK THAT NONSTATIC UNIVERSAL REAL " & + "EXPRESSIONS ARE EVALUATED WITH THE " & + "ACCURACY OF THE MOST PRECISE PREDEFINED " & + "FLOATING POINT TYPE (I. E., THE TYPE FOR " & + "WHICH 'DIGITS EQUALS SYSTEM.MAX_DIGITS" ); + + CASE MAX_DIGITS IS + WHEN 5 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C5L .. C5U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 5" ); + END IF; + WHEN 6 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C6L .. C6U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 6" ); + END IF; + WHEN 7 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C7L .. C7U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 7" ); + END IF; + WHEN 8 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C8L .. C8U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 8" ); + END IF; + WHEN 9 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C9L .. C9U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 9" ); + END IF; + WHEN 10 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C10L .. C10U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 10" ); + END IF; + WHEN 11 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C11L .. C11U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 11" ); + END IF; + WHEN 12 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C12L .. C12U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 12" ); + END IF; + WHEN 13 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C13L .. C13U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 13" ); + END IF; + WHEN 14 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C14L .. C14U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 14" ); + END IF; + WHEN 15 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C15L .. C15U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 15" ); + END IF; + WHEN 16 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C16L .. C16U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 16" ); + END IF; + WHEN 17 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C17L .. C17U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 17" ); + END IF; + WHEN 18 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C18L .. C18U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 18" ); + END IF; + WHEN 19 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C19L .. C19U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 19" ); + END IF; + WHEN 20 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C20L .. C20U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 20" ); + END IF; + WHEN 21 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C21L .. C21U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 21" ); + END IF; + WHEN 22 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C22L .. C22U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 22" ); + END IF; + WHEN 23 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C23L .. C23U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 23" ); + END IF; + WHEN 24 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C24L .. C24U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 24" ); + END IF; + WHEN 25 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C25L .. C25U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 25" ); + END IF; + WHEN 26 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C26L .. C26U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 26" ); + END IF; + WHEN 27 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C27L .. C27U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 27" ); + END IF; + WHEN 28 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C28L .. C28U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 28" ); + END IF; + WHEN 29 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C29L .. C29U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 29" ); + END IF; + WHEN 30 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C30L .. C30U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 30" ); + END IF; + WHEN 31 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C31L .. C31U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 31" ); + END IF; + WHEN 32 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C32L .. C32U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 32" ); + END IF; + WHEN 33 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C33L .. C33U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 33" ); + END IF; + WHEN 34 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C34L .. C34U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 34" ); + END IF; + WHEN 35 => + IF (2.0 * INTEGER'POS (IDENT_INT (1))) / 3.0 NOT IN + C35L .. C35U THEN + FAILED ( "INCORRECT ACCURACY FOR A MAX_DIGITS " & + "VALUE OF 35" ); + END IF; + WHEN OTHERS => + NOT_APPLICABLE ( "MAX_DIGITS OUT OF RANGE OF TEST. " & + "MAX_DIGITS = " & + INTEGER'IMAGE (MAX_DIGITS)); + END CASE; + + RESULT; + + END C4A011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a012b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C4A012B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR + -- A UNIVERSAL_REAL EXPRESSION IF DIVISION BY ZERO IS ATTEMPTED. + + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR + -- 0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT VALUE). + + -- HISTORY: + -- RJW 09/04/86 CREATED ORIGINAL TEST. + -- CJJ 09/04/87 ADDED PASS MESSAGE FOR RAISING NUMERIC_ERROR; + -- MODIFIED CODE TO PREVENT COMPILER OPTIMIZING + -- OUT THE TEST. + -- JET 12/31/87 ADDED MORE CODE TO PREVENT OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + -- JRL 02/29/96 Added code to check for value of Machine_Overflows; if + -- False, test is inapplicable. + + WITH REPORT; USE REPORT; + + PROCEDURE C4A012B IS + + F : FLOAT; + + I3 : INTEGER := -3; + + SUBTYPE SINT IS INTEGER RANGE -10 .. 10; + SI5 : CONSTANT SINT := -5; + + FUNCTION IDENT (X:FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3,3) THEN + RETURN X; + ELSE + RETURN 1.0; + END IF; + END IDENT; + + BEGIN + + TEST ( "C4A012B", "CHECK THAT CONSTRAINT_ERROR " & + "IS RAISED FOR " & + "0.0 ** (-1) (OR ANY OTHER NEGATIVE EXPONENT " & + "VALUE)" ); + + IF FLOAT'MACHINE_OVERFLOWS = FALSE THEN + REPORT.NOT_APPLICABLE ("Float'Machine_Overflows = False"); + ELSE + + BEGIN + F := IDENT (0.0) ** (-1); + FAILED ( "THE EXPRESSION '0.0 ** (-1)' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (-1)' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (-1)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 2"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (-1))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (INTEGER'POS (IDENT_INT (-1))); + FAILED ( "THE EXPRESSION '0.0 ** " & + "(INTEGER'POS (IDENT_INT (-1)))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** " & + "(INTEGER'POS (IDENT_INT (-1)))' RAISED " & + "THE WRONG EXCEPTION" ); + END; + + BEGIN + F := IDENT(0.0) ** I3; + FAILED ( "THE EXPRESSION '0.0 ** I3' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 4"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** I3' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (I3)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 5"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (I3))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + BEGIN + F := IDENT (0.0) ** SI5; + FAILED ( "THE EXPRESSION '0.0 ** SI5' DID NOT RAISE " & + "AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 6"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** SI5' RAISED THE " & + "WRONG EXCEPTION" ); + END; + + BEGIN + F := 0.0 ** (IDENT_INT (SI5)); + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' DID " & + "NOT RAISE AN EXCEPTION" ); + IF EQUAL ( INTEGER(F), INTEGER(F) ) THEN + COMMENT ("SHOULDN'T BE HERE!"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - 7"); + WHEN OTHERS => + FAILED ( "THE EXPRESSION '0.0 ** (IDENT_INT (SI5))' " & + "RAISED THE WRONG EXCEPTION" ); + END; + + END IF; + + RESULT; + + END C4A012B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a013a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C4A013A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A NONSTATIC + -- UNIVERSAL_REAL EXPRESSION IF THE VALUE WOULD LIE OUTSIDE THE RANGE OF + -- THE BASE TYPE OF THE MOST ACCURATE PREDEFINED FLOATING POINT TYPE AND + -- MACHINE_OVERFLOWS IS TRUE FOR THAT TYPE. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- BAW 29 SEPT 80 + -- TBN 10/30/85 RENAMED FROM C4A013A.ADA. + -- JRK 1/13/86 COMPLETELY REVISED TO CHECK NONSTATIC UNIVERSAL_REAL + -- EXPRESSIONS WHOSE RESULTS OVERFLOW. REVISED + -- NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH SYSTEM, REPORT; + USE SYSTEM, REPORT; + + PROCEDURE C4A013A IS + + TYPE F IS DIGITS MAX_DIGITS; + + B : BOOLEAN; + + BEGIN + TEST ("C4A013A", "CHECK NONSTATIC UNIVERSAL_REAL EXPRESSIONS " & + "WHOSE RESULTS OVERFLOW"); + + BEGIN + B := 1.0 < 1.0 / (1.0 * INTEGER'POS (IDENT_INT (0))); + + IF F'MACHINE_OVERFLOWS THEN + FAILED ("MACHINE_OVERFLOWS IS TRUE, BUT NO EXCEPTION " & + "WAS RAISED"); + ELSE COMMENT ("MACHINE_OVERFLOWS IS FALSE AND NO EXCEPTION " & + "WAS RAISED"); + END IF; + + IF NOT B THEN -- USE B TO PREVENT DEAD VARIABLE OPTIMIZATION. + COMMENT ("1.0 < 1.0 / 0.0 YIELDS FALSE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; + END C4A013A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c4/c4a014a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C4A014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ROUNDING IS DONE CORRECTLY FOR STATIC UNIVERSAL REAL + -- EXPRESSIONS. + + -- JBG 5/3/85 + -- JBG 11/3/85 DECLARE INTEGER CONSTANTS INSTEAD OF UNIVERSAL INTEGER + -- DTN 11/27/91 DELETED SUBPART (B). + + WITH REPORT; USE REPORT; + PROCEDURE C4A014A IS + + C15 : CONSTANT := 1.5; + C25 : CONSTANT := 2.5; + CN15 : CONSTANT := -1.5; + CN25 : CONSTANT := -2.5; + + C15R : CONSTANT INTEGER := INTEGER(C15); + C25R : CONSTANT INTEGER := INTEGER(C25); + CN15R : CONSTANT INTEGER := INTEGER(CN15); + CN25R : CONSTANT INTEGER := INTEGER(CN25); + + C15_1 : BOOLEAN := 1 = C15R; + C15_2 : BOOLEAN := 2 = C15R; + C25_2 : BOOLEAN := 2 = C25R; + C25_3 : BOOLEAN := 3 = C25R; + + CN15_N1 : BOOLEAN := -1 = CN15R; + CN15_N2 : BOOLEAN := -2 = CN15R; + CN25_N2 : BOOLEAN := -2 = CN25R; + CN25_N3 : BOOLEAN := -3 = CN25R; + + BEGIN + + TEST ("C4A014A", "CHECK ROUNDING TO INTEGER FOR UNIVERSAL REAL " & + "EXPRESSIONS"); + + IF 1 /= INTEGER(1.4) THEN + FAILED ("INTEGER(1.4) DOES NOT EQUAL 1"); + END IF; + + IF 2 /= INTEGER(1.6) THEN + FAILED ("INTEGER(1.6) DOES NOT EQUAL 2"); + END IF; + + IF -1 /= INTEGER(-1.4) THEN + FAILED ("INTEGER(-1.4) DOES NOT EQUAL -1"); + END IF; + + IF -2 /= INTEGER(-1.6) THEN + FAILED ("INTEGER(-1.6) DOES NOT EQUAL -2"); + END IF; + + IF NOT (C15_1 OR C15_2) OR (NOT (C25_2 OR C25_3)) THEN + FAILED ("ROUNDING OF POSITIVE VALUES NOT CORRECT"); + END IF; + + IF NOT (CN15_N1 OR CN15_N2) OR (NOT (CN25_N2 OR CN25_N3)) THEN + FAILED ("ROUNDING OF NEGATIVE VALUES NOT CORRECT"); + END IF; + + RESULT; + + END C4A014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c51004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c51004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c51004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c51004a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,261 ---- + -- C51004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LABELS, LOOP IDENTIFIERS, AND BLOCK IDENTIFIERS ARE + -- IMPLICITLY DECLARED AT THE END OF THE DECLARATIVE PART. PRIOR TO + -- THE END OF THE DECLARATIVE PART, THEY MAY BE USED TO REFERENCE + -- ENTITIES IN AN ENCLOSING SCOPE. SUBTESTS ARE: + -- (A) BLOCK. + -- (B) PROCEDURE BODY. + -- (C) PACKAGE BODY. + -- (D) GENERIC FUNCTION BODY. + -- (E) GENERIC PACKAGE BODY. + -- (F) TASK BODY. + + -- CPP 6/1/84 + + WITH REPORT; USE REPORT; + PROCEDURE C51004A IS + + BEGIN + TEST("C51004A", "CHECK THAT LABELS, LOOP IDENTIFIERS, AND BLOCK " & + "IDENTIFIERS MAY BE USED PRIOR TO THEIR IMPLICIT " & + "DECLARATION"); + + OUTER: DECLARE + + TYPE IDN1 IS NEW INTEGER; + IDN2 : CONSTANT INTEGER := 2; + TYPE IDN3 IS ACCESS INTEGER; + + BEGIN -- OUTER + + ----------------------------------------------- + + A : DECLARE + + A1 : IDN1; + A2 : CONSTANT INTEGER := IDN2; + A3 : IDN3; + + TEMP : INTEGER; + + BEGIN -- A + + <> TEMP := 0; + + IDN2 : FOR I IN 1..1 LOOP + TEMP := A2; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + END A; + + ----------------------------------------------- + + B : DECLARE + + PROCEDURE P (TEMP : OUT INTEGER) IS + + B1 : IDN1; + B2 : CONSTANT INTEGER := IDN2 + 2; + B3 : IDN3; + + BEGIN -- P + + <> <> TEMP := 0; + + IDN2 : WHILE B2 < 0 LOOP + TEMP := 0; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + NULL; + END IDN3; + + END P; + + BEGIN -- B + NULL; + END B; + + ----------------------------------------------- + + C : DECLARE + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + + C1 : IDN1; + C2 : CONSTANT INTEGER := 2 * IDN2; + C3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <> TEMP := 0; + + IDN2 : LOOP + TEMP := 0; + EXIT; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + END PKG; + + BEGIN -- C + NULL; + END C; + + --------------------------------------------------- + + D : DECLARE + + GENERIC + TYPE Q IS (<>); + FUNCTION FN RETURN INTEGER; + + FUNCTION FN RETURN INTEGER IS + + D1 : IDN1; + D2 : CONSTANT INTEGER := IDN2; + D3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <> TEMP := 0; + + IDN2 : FOR I IN 1..5 LOOP + TEMP := 0; + END LOOP IDN2; + + IDN3 : BEGIN + NULL; + END IDN3; + + RETURN TEMP; + + END FN; + + BEGIN + NULL; + END D; + + ----------------------------------------------- + + E : DECLARE + + GENERIC + + TYPE ELEMENT IS (<>); + ITEM : ELEMENT; + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + + E1 : IDN1 RANGE 1..5; + E2 : CONSTANT INTEGER := IDN2; + E3 : IDN3; + + TEMP : ELEMENT; + + BEGIN + + <> <> TEMP := ITEM; + + IDN2 : WHILE TEMP /= ITEM LOOP + TEMP := ITEM; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + NULL; + END IDN3; + + END PKG; + + BEGIN -- E + + DECLARE + PACKAGE P1 IS NEW PKG (INTEGER, 0); + BEGIN + NULL; + END; + + END E; + + ----------------------------------------------- + + F : DECLARE + + TASK T; + + TASK BODY T IS + + F1 : IDN1 RANGE -4..2; + F2 : CONSTANT INTEGER := IDN2; + F3 : IDN3; + + TEMP : INTEGER; + + BEGIN + + <> TEMP := 1; + + IDN2 : LOOP + TEMP := TEMP + 1; + EXIT; + END LOOP IDN2; + + IDN3 : DECLARE + BEGIN + TEMP := TEMP + 1; + END IDN3; + + END T; + + BEGIN -- F + NULL; + END F; + + ----------------------------------------------- + + END OUTER; + + RESULT; + END C51004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,177 ---- + -- C52005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A STATIC + -- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN, + -- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES. + + -- DCB 2/5/80 + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005A IS + + USE REPORT; + + BEGIN + TEST ("C52005A", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED " + & "ON STATIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " & + "AND ENUMERATION ASSIGNMENTS"); + + ------------------------- + + DECLARE + I1 : INTEGER RANGE 0..10 := 5; + + BEGIN + I1 := 11; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 5 THEN + FAILED ("VALUE ALTERED BEFORE INT RANGE" & + "EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + I2 : INTEGER RANGE 0..10 := 5; + + BEGIN + I2 := 10; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT"); + END; + + ------------------------- + + DECLARE + B1 : BOOLEAN RANGE TRUE..TRUE := TRUE; + + BEGIN + B1 := FALSE; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF B1 /= TRUE THEN + FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION"); + END IF; + END; + + ------------------------- + + DECLARE + B2 : BOOLEAN := TRUE; + + BEGIN + B2 := FALSE; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT"); + + END; + + ------------------------- + + DECLARE + C1 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C1 := 'A'; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF C1 /= 'M' THEN + FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " & + "EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + C2 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C2 := 'B'; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT"); + + END; + + ------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + WORKDAY := SUN; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF WORKDAY /= TUE THEN + FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + WORKDAY := FRI; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT"); + + END; + + ------------------------- + + RESULT; + END C52005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C52005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED + -- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE + -- OF FLOATING POINT ASSIGNMENTS. + + -- DCB 2/6/80 + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005B IS + + USE REPORT; + + BEGIN + TEST ("C52005B", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON STATIC OUT OF RANGE FLOATING POINT ASSIGNMENTS"); + + ------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL1 : FLT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL1 := 101.0; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL2 : FLT RANGE 0.0 .. 100.0 := 50.0; + + + BEGIN + FL2 := 100.0; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT" & + "ASSIGNMENT"); + + END; + + ------------------------- + + DECLARE + FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL1 := -0.001; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + FL2 := 0.0; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT"); + + END; + + ---------------------- + + RESULT; + END C52005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C52005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED + -- WHEN A STATIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE + -- OF FIXED POINT ASSIGNMENTS. + + -- DCB 2/6/80 + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005C IS + + USE REPORT; + + BEGIN + TEST ("C52005C", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON STATIC OUT OF RANGE FIXED POINT ASSIGNMENTS"); + + ----------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX1 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + FX1 := 7.01; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FX1 /= 4.50 THEN + FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX2 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + FX2 := 7.00; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT"); + + END; + + ------------------------- + + RESULT; + END C52005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C52005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED WHEN A DYNAMIC + -- EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE OF INTEGER, BOOLEAN, + -- CHARACTER, AND ENUMERATION ASSIGNMENT TARGET VARIABLES. + + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005D IS + + USE REPORT; + + BEGIN + TEST ("C52005D", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED " + & "ON DYNAMIC OUT OF RANGE INTEGER, BOOLEAN, CHARACTER, " & + "AND ENUMERATION ASSIGNMENTS"); + + ------------------------- + + DECLARE + I1 : INTEGER RANGE 0..10 := 5; + + BEGIN + I1 := IDENT_INT(11); + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE INT ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 5 THEN + FAILED ("VALUE ALTERED BEFORE INT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + I2 : INTEGER RANGE 0..10 := 5; + + BEGIN + I2 := IDENT_INT(10); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL INTEGER ASSIGNMENT"); + END; + + ------------------------- + + DECLARE + B1 : BOOLEAN RANGE TRUE..TRUE := TRUE; + + BEGIN + B1 := IDENT_BOOL(FALSE); + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE BOOL ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF B1 /= TRUE THEN + FAILED ("VALUE ALTERED BEFORE BOOLEAN RANGE EXCEPTION"); + END IF; + END; + + ------------------------- + + DECLARE + B2 : BOOLEAN := TRUE; + + BEGIN + B2 := IDENT_BOOL(FALSE); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL BOOLEAN ASSNMNT"); + + END; + + ------------------------- + + DECLARE + C1 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C1 := IDENT_CHAR('A'); + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE CHAR ASSNMNT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF C1 /= 'M' THEN + FAILED ("VALUE ALTERED BEFORE CHARACTER RANGE " & + "EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + C2 : CHARACTER RANGE 'B'..'Z' := 'M'; + + BEGIN + C2 := IDENT_CHAR('B'); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED OF LEGAL CHARACTER ASSNMNT"); + + END; + + ------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + ALLDAYS : DAY := TUE; + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + IF EQUAL(3,3) THEN + ALLDAYS := SUN; + END IF; + WORKDAY := ALLDAYS; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE ENUM. " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF WORKDAY /= TUE THEN + FAILED ("VALUE ALTERED BEFORE ENUM. RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE DAY IS (SUN, MON, TUE, WED, THU, FRI, SAT); + ALLDAYS : DAY := TUE; + WORKDAY : DAY RANGE MON..FRI := TUE; + + BEGIN + IF EQUAL(3,3) THEN + ALLDAYS := FRI; + END IF; + WORKDAY := ALLDAYS; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL ENUM. ASSNMNT"); + + END; + + ------------------------- + + RESULT; + END C52005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C52005E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED + -- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE + -- OF FLOATING POINT ASSIGNMENTS. + + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005E IS + + USE REPORT; + + BEGIN + TEST ("C52005E", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON DYNAMIC OUT OF RANGE FLOATING POINT ASSIGNMENTS"); + + ------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL : FLT := 50.0; + FL1 : FLT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := 101.0; + END IF; + FL1 := FL; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLT1 PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLT1 PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE FLT IS DIGITS 3 RANGE 0.0 .. 5.0E2; + FL : FLT := 50.0; + FL2 : FLT RANGE 0.0 .. 100.0 := 50.0; + + + BEGIN + IF EQUAL(3,3) THEN + FL := 100.0; + END IF; + FL2 := FL; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING1 PT ASSNMT"); + + END; + + ------------------------- + + DECLARE + FL : FLOAT := 50.0; + FL1 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := -0.001; + END IF; + FL1 := FL; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FLTG PT " & + "ASSIGNMENT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FL1 /= 50.0 THEN + FAILED ("VALUE ALTERED BEFORE FLTG PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + FL : FLOAT := 50.0; + FL2 : FLOAT RANGE 0.0 .. 100.0 := 50.0; + + BEGIN + IF EQUAL(3,3) THEN + FL := 0.0; + END IF; + FL2 := FL; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FLOATING PT ASSNMT"); + + END; + + ---------------------- + + RESULT; + END C52005E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52005f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52005f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C52005F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONSTRAINT_ERROR EXCEPTION IS RAISED + -- WHEN A DYNAMIC EXPRESSION VALUE IS OUTSIDE THE STATIC RANGE + -- OF FIXED POINT ASSIGNMENTS. + + -- JRK 7/21/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52005F IS + + USE REPORT; + + BEGIN + TEST ("C52005F", "CHECK THAT CONSTRAINT_ERROR EXCEPTION IS RAISED" + & " ON DYNAMIC OUT OF RANGE FIXED POINT ASSIGNMENTS"); + + ----------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX : REAL := 4.50; + FX1 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + IF EQUAL(3,3) THEN + FX := 7.01; + END IF; + FX1 := FX; + + FAILED ("EXCEPTION NOT RAISED FOR OUT OF RANGE FIXED ASSNMT"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF FX1 /= 4.50 THEN + FAILED ("VALUE ALTERED BEFORE FIXED PT RANGE EXCEPTION"); + END IF; + + END; + + ------------------------- + + DECLARE + TYPE REAL IS DELTA 0.01 RANGE 0.00 .. 9.99; + FX : REAL := 4.50; + FX2 : REAL RANGE 0.00 .. 7.00 := 4.50; + + BEGIN + IF EQUAL(3,3) THEN + FX := 7.00; + END IF; + FX2 := FX; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("EXCEPTION RAISED ON LEGAL FIXED PT ASSNMT"); + + END; + + ------------------------- + + RESULT; + END C52005F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52008a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C52008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RECORD VARIABLE CONSTRAINED BY A SPECIFIED DISCRIMINANT + -- VALUE CANNOT HAVE ITS DISCRIMINANT VALUE ALTERED BY ASSIGNMENT. + -- ASSIGNING AN ENTIRE RECORD VALUE WITH A DIFFERENT DISCRIMINANT VALUE + -- SHOULD RAISE CONSTRAINT_ERROR AND LEAVE THE TARGET VARIABLE + -- UNALTERED. THIS TEST USES STATIC DISCRIMINANT VALUES. + + -- ASL 6/25/81 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52008A IS + + USE REPORT; + + TYPE REC(DISC : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + R : REC(5) := (5,0); + + BEGIN + + TEST ("C52008A", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " & + "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " & + "STATIC DISCRIMINANT VALUE"); + + BEGIN + R := (DISC => 5, COMP => 3); + IF R /= (5,3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + R := (DISC => 4, COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF R /= (5,3) THEN + FAILED ("TARGET RECORD VALUE ALTERED BY " & + "ASSIGNMENT TO VALUE WITH DIFFERENT " & + "DISCRIMINANT VALUE EVEN AFTER " & + "CONSTRAINT_ERROR RAISED"); + END IF; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + + END C52008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52008b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C52008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD VARIABLE DECLARED WITH A SPECIFIED + -- DISCRIMINANT CONSTRAINT CANNOT HAVE A DISCRIMINANT VALUE ALTERED + -- BY ASSIGNMENT. ASSIGNING AN ENTIRE RECORD VALUE WITH A + -- DIFFERENT DISCRIMINANT VALUE SHOULD RAISE CONSTRAINT_ERROR AND + -- LEAVE THE TARGET VARIABLE UNALTERED. THIS TEST USES NON-STATIC + -- DISCRIMINANT VALUES. + + -- HISTORY: + -- ASL 6/25/81 CREATED ORIGINAL TEST + -- JRK 11/18/82 + -- RJW 8/17/89 ADDED SUBTYPE 'SUBINT'. + + WITH REPORT; + PROCEDURE C52008B IS + + USE REPORT; + + TYPE REC1(D1,D2 : INTEGER) IS + RECORD + COMP1 : STRING(D1..D2); + END RECORD; + + TYPE AR_REC1 IS ARRAY (NATURAL RANGE <>) OF REC1(IDENT_INT(3), + IDENT_INT(5)); + + SUBTYPE SUBINT IS INTEGER RANGE -128 .. 127; + + TYPE REC2(D1,D2,D3,D4 : SUBINT := 0) IS + RECORD + COMP1 : STRING(1..D1); + COMP2 : STRING(D2..D3); + COMP5 : AR_REC1(1..D4); + COMP6 : REC1(D3,D4); + END RECORD; + + STR : STRING(IDENT_INT(3)..IDENT_INT(5)) := "ZZZ"; + + R1A : REC1(IDENT_INT(3),IDENT_INT(5)) := (3,5,STR); + R1C : REC1(5,6) := (5,6,COMP1 => (5..6 => 'K')); + + Q,R : REC2(IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6)); + TEMP : REC2(2,3,5,6); + + W : REC2(1,4,6,8); + OK : BOOLEAN := FALSE; + + + BEGIN + + TEST ("C52008B", "CANNOT ASSIGN RECORD VARIABLE WITH SPECIFIED " & + "DISCRIMINANT VALUE A VALUE WITH A DIFFERENT " & + "(DYNAMIC) DISCRIMINANT VALUE"); + + BEGIN + R1A := (IDENT_INT(3),5,"XYZ"); + + R := (IDENT_INT(2),IDENT_INT(3),IDENT_INT(5),IDENT_INT(6), + "AB", + STR, + (1..6 => R1A), + R1C); + + TEMP := R; + Q := TEMP; + R.COMP1 := "YY"; + OK := TRUE; + W := R; + FAILED ("ASSIGNMENT MADE USING INCORRECT DISCRIMINANT " & + "VALUES"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT OK + OR Q /= TEMP + OR R = TEMP + OR R = Q + OR W.D4 /= 8 THEN + FAILED ("LEGITIMATE ASSIGNMENT FAILED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + + END C52008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52009a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C52009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT + -- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD + -- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT + -- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO + -- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES + -- THE TARGET RECORD UNALTERED. THIS TEST USES STATIC DISCRIMINANT + -- VALUES. + + -- ASL 6/25/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C52009A IS + + USE REPORT; + + TYPE REC (DISC : INTEGER) IS + RECORD + COMP : INTEGER; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + HR : REC_NAME := NEW REC'(5,0); + + BEGIN + + TEST ("C52009A", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " & + "(STATIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " & + "BY AN ACCESS VALUE"); + + BEGIN + HR.ALL := (DISC => 5, COMP => 3); + IF HR.ALL /= (5,3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + HR.ALL := (DISC => 4, COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF HR.ALL /= (5,3) THEN + FAILED ("TARGET RECORD VALUE ALTERED BY " & + "ASSIGNMENT WITH A DIFFERENT " & + "DISCRIMINANT VALUE EVEN AFTER " & + "CONSTRAINT_ERROR RAISED"); + END IF; + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + + END C52009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52009b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52009b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52009b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52009b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C52009B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RECORD VARIABLE DESIGNATED BY AN ACCESS VALUE CANNOT + -- HAVE ITS DISCRIMINANT ALTERED, EVEN BY A COMPLETE RECORD + -- ASSIGNMENT, AND EVEN THOUGH THE THE TARGET ACCESS VARIABLE IS NOT + -- CONSTRAINED TO A SPECIFIC DISCRIMINANT VALUE. ATTEMPTING TO + -- CHANGE THE TARGET'S DISCRIMINANT RAISES CONSTRAINT_ERROR AND LEAVES + -- THE TARGET RECORD UNALTERED. THIS TEST USES NON-STATIC DISCRIMINANT + -- VALUES AND A TYPE WITH DEFAULT DISCRIMINANTS. + + -- ASL 7/6/81 + -- SPS 10/26/82 + -- JBG 1/10/84 + + WITH REPORT; + PROCEDURE C52009B IS + + USE REPORT; + + TYPE REC(DISC : INTEGER := 5) IS + RECORD + COMP : INTEGER := 0; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + + HR : REC_NAME := NEW REC; + + BEGIN + + TEST ("C52009B", "CANNOT CHANGE, THROUGH ASSIGNMENT, THE " & + "(DYNAMIC) DISCRIMINANT VALUE OF A RECORD DESIGNATED " & + "BY AN ACCESS VALUE"); + + BEGIN + HR.ALL := (DISC => IDENT_INT(5), COMP => 3); + IF HR.ALL /= (IDENT_INT(5),3) THEN + FAILED ("LEGAL ASSIGNMENT FAILED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN DISCRIMINANT " & + "VALUE NOT CHANGED"); + END; + + BEGIN + HR.ALL := (DISC => IDENT_INT(4), COMP => 2); + FAILED ("RECORD ASSIGNED VALUE WITH DIFFERENT DISCRIMINANT " & + "VALUE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("DETECTED ATTEMPT TO CHANGE DISCRIMINANT " & + "VALUE"); + WHEN OTHERS => FAILED ("WRONG EXCEPTION"); + END; + + RESULT; + + END C52009B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52010a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- C52010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT RECORD ASSIGNMENTS USE "COPY" SEMANTICS. (PART I). + + + -- FACTORS AFFECTING THE SITUATION TO BE TESTED: + -- + -- COMPONENT TYPE * INTEGER + -- * BOOLEAN (OMITTED) + -- * CHARACTER (OMITTED) + -- * USER-DEFINED ENUMERATION + -- + -- DERIVED VS. NON-DERIVED + -- + -- TYPE VS. SUBTYPE + -- + -- ORDER OF COMPONENT ASSIGNMENTS * LEFT-TO-RIGHT + -- * RIGHT-TO-LEFT + -- * INSIDE-OUT + -- * OUTSIDE IN + + + -- RM 02/23/80 + -- SPS 3/21/83 + + WITH REPORT; + PROCEDURE C52010A IS + + USE REPORT; + + TYPE ENUM IS ( AA , BB , CC , DD , EE , FF , GG , HH , + II , JJ , KK , LL , MM , NN , PP , QQ , + TT , UU , VV , WW , XX , YY ); + + BEGIN + + TEST ( "C52010A" , "CHECK THAT RECORD ASSIGNMENTS USE ""COPY""" & + " SEMANTICS" ); + + + DECLARE + TYPE REC IS + RECORD + X , Y : INTEGER ; + END RECORD; + R : REC ; + BEGIN + + R := ( 5 , 8 ) ; + R := ( X => 1 , Y => R.X ) ; + IF R /= ( 1 , 5 ) THEN + FAILED ( "WRONG VALUE (1)" ); + END IF; + + R := ( 5 , 8 ) ; + R := ( Y => 1 , X => R.Y ) ; + IF R /= ( 8 , 1 ) THEN + FAILED ( "WRONG VALUE (2)" ); + END IF; + + R := ( 5 , 8 ) ; + R := ( R.Y+1 , R.X+1 ) ; + IF R /= ( 9 , 6 ) THEN + FAILED ( "WRONG VALUE (3)" ); + END IF; + + END; + + DECLARE + TYPE REC3 IS + RECORD + DEEP0 : INTEGER ; + DEEP : INTEGER ; + END RECORD; + TYPE REC2 IS + RECORD + YX : REC3 ; + MODERATE : INTEGER ; + END RECORD; + TYPE REC IS + RECORD + SHALLOW : INTEGER ; + YZ : REC2 ; + END RECORD; + R : REC ; + BEGIN + R := ( 0 , ((5, 1 ), 2 )); + R := ( R.YZ.MODERATE+8, ((7, R.SHALLOW+1),R.YZ.YX.DEEP+99)); + IF R/= ( 10, ((7, 1), 100)) + THEN + FAILED ( "WRONG VALUE (4)" ); + END IF; + END; + + + DECLARE + TYPE SUB_ENUM IS NEW ENUM RANGE AA..DD ; + TYPE REC IS + RECORD + X , Y : SUB_ENUM ; + END RECORD; + R : REC ; + BEGIN + R := ( AA , CC ) ; + R := ( X => BB , Y => R.X ) ; + IF R /= ( BB , AA ) THEN + FAILED ( "WRONG VALUE (5)" ); + END IF; + + R := ( AA , CC ) ; + R := ( Y => BB , X => R.Y ) ; + IF R /= ( CC , BB ) THEN + FAILED ( "WRONG VALUE (6)" ); + END IF; + + R := ( AA , CC ) ; + R := ( SUB_ENUM'SUCC( R.Y ) , SUB_ENUM'SUCC( R.X ) ) ; + IF R /= ( DD , BB ) THEN + FAILED ( "WRONG VALUE (7)" ); + END IF; + + END; + + + DECLARE + TYPE REC3 IS + RECORD + DEEP0 : ENUM ; + DEEP : ENUM ; + END RECORD; + TYPE REC2 IS + RECORD + YX : REC3 ; + MODERATE : ENUM ; + END RECORD; + TYPE REC IS + RECORD + SHALLOW : ENUM ; + YZ : REC2 ; + END RECORD; + R : REC ; + BEGIN + + R := ( TT , + (( YY , II ) , + AA ) ) ; + + R := ( ENUM'SUCC(ENUM'SUCC( R.YZ.MODERATE )) , + (( AA , ENUM'SUCC( R.SHALLOW ) ) , + ( ENUM'SUCC(ENUM'SUCC(ENUM'SUCC(ENUM'SUCC( + R.YZ.YX.DEEP )))) ) ) ) ; + + IF R/= ( CC , + (( AA , UU ) , + MM ) ) + THEN + FAILED ( "WRONG VALUE (8)" ); + END IF; + + END; + + RESULT ; + + END C52010A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52011a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C52011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK INDEX CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES. + -- SPECIFICALLY, CHECK THAT: + + -- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT + -- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED + -- IS NULL. + + -- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED + -- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE. + + -- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS + -- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES. + + -- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT + -- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS + -- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER + -- FROM THOSE ON THE SUBTYPE. + + -- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED + -- SUBTYPES OF THIS TYPE. + + -- ASL 6/29/81 + -- RM 6/17/82 + -- SPS 10/26/82 + -- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION. + + WITH REPORT; + PROCEDURE C52011A IS + + USE REPORT; + + TYPE ARR IS ARRAY(INTEGER RANGE <>) OF INTEGER; + TYPE ARR_NAME IS ACCESS ARR; + SUBTYPE S1 IS ARR_NAME(IDENT_INT(1)..IDENT_INT(10)); + SUBTYPE S2 IS ARR_NAME(IDENT_INT(3)..IDENT_INT(6)); + + W : ARR_NAME := NULL; -- E. + X1,X2 : S1 := NULL; -- E. + Y1,Y2 : S2 := NULL; -- E. + + W_NONNULL : ARR_NAME := NEW ARR'(3..5=>7) ; + X1_NONNULL : S1 := NEW ARR'(IDENT_INT(1)..IDENT_INT(10)=>7); + Y1_NONNULL : S2 := NEW ARR'(IDENT_INT(3)..IDENT_INT( 6)=>7); + + TOO_EARLY : BOOLEAN := TRUE; + + BEGIN + + TEST ("C52011A", "INDEX CONSTRAINTS ON ACCESS SUBTYPE OBJECTS " & + "MUST BE SATISFIED FOR ASSIGNMENT"); + + BEGIN + + IF EQUAL(3,3) THEN + W_NONNULL := X1; -- A. + END IF; + IF W_NONNULL /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := X2; -- A. + END IF; + IF X1_NONNULL /= X2 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := Y1; -- A. + END IF; + IF X1 /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + X1 := NEW ARR'(1..IDENT_INT(10) => 5); + IF EQUAL(3,3) THEN + X2 := X1; -- B. + END IF; + IF X2 /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + + IF EQUAL(3,3) THEN + W := X1; -- B. + END IF; + IF W /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 5"); + END IF; + + BEGIN + Y1 := X1; -- C. + IF Y1'FIRST /= REPORT.IDENT_INT(3) THEN + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + + END; + + W := NEW ARR'(IDENT_INT(3)..IDENT_INT(6) => 3); + + BEGIN + X1 := W; -- D. + IF X1'FIRST /= REPORT.IDENT_INT(1) THEN + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL ; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + + END; + + + RESULT; + + + END C52011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52011b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52011b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52011b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52011b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,180 ---- + -- C52011B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK DISCRIMINANT CONSTRAINTS FOR ASSIGNMENT OF ACCESS SUBTYPES. + -- SPECIFICALLY, CHECK THAT: + + -- A) ANY ACCESS TYPE VARIABLE AND CONSTRAINED SUBTYPE VARIABLES OF THAT + -- TYPE MAY BE ASSIGNED TO ONE ANOTHER IF THE VALUE BEING ASSIGNED + -- IS NULL. + + -- B) VARIABLES OF THE SAME CONSTRAINED ACCESS SUBTYPE MAY BE ASSIGNED + -- TO ONE ANOTHER OR TO VARIABLES OF THE BASE ACCESS TYPE. + + -- C) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF NON-NULL OBJECTS + -- BETWEEN DIFFERENTLY CONSTRAINED ACCESS SUBTYPES. + + -- D) CONSTRAINT_ERROR IS RAISED UPON ASSIGNMENT OF A NON-NULL OBJECT + -- OF A BASE ACCESS TYPE VARIABLE TO A VARIABLE OF ONE OF ITS + -- CONSTRAINED SUBTYPES IF THE CONSTRAINTS ON THE OBJECT DIFFER + -- FROM THOSE ON THE SUBTYPE. + + -- E) NULL CAN BE ASSIGNED TO BASE ACCESS TYPES AND ANY CONSTRAINED + -- SUBTYPES OF THIS TYPE. + + -- ASL 7/06/81 + -- RM 6/17/82 + -- RLB 6/29/01 - FIXED TO ALLOW AGGRESIVE OPTIMIZATION. + + WITH REPORT; + PROCEDURE C52011B IS + + USE REPORT; + + TYPE REC(DISC : INTEGER := -1 ) IS + RECORD + NULL; + END RECORD; + + TYPE REC_NAME IS ACCESS REC; + SUBTYPE S1 IS REC_NAME(IDENT_INT(5)); + SUBTYPE S2 IS REC_NAME(IDENT_INT(3)); + + W : REC_NAME := NULL; -- E. + X1,X2 : S1 := NULL; -- E. + Y1,Y2 : S2 := NULL; -- E. + + W_NONNULL : REC_NAME := NEW REC(7) ; + X1_NONNULL : S1 := NEW REC(IDENT_INT(5)); + Y1_NONNULL : S2 := NEW REC(IDENT_INT(3)); + + TOO_EARLY : BOOLEAN := TRUE; + + BEGIN + + TEST ("C52011B", "DISCRIMINANT CONSTRAINTS ON ACCESS SUBTYPE " & + "OBJECTS MUST BE SATISFIED FOR ASSIGNMENT"); + + BEGIN + + IF EQUAL(3,3) THEN + W_NONNULL := X1; -- A. + END IF; + IF W_NONNULL /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 1"); + END IF; + + IF EQUAL(3,3) THEN + W := Y1; -- A. + END IF; + IF W /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 2"); + END IF; + + IF EQUAL(3,3) THEN + X1_NONNULL := Y1; -- A. + END IF; + IF X1_NONNULL /= Y1 THEN + FAILED ("ASSIGNMENT FAILED - 3"); + END IF; + + IF EQUAL(3,3) THEN + Y1_NONNULL := Y2; -- A. + END IF; + IF Y1_NONNULL /= Y2 THEN + FAILED ("ASSIGNMENT FAILED - 4"); + END IF; + + X1 := NEW REC(IDENT_INT(5)); + IF EQUAL(3,3) THEN + X2 := X1; -- B. + END IF; + IF X1 /= X2 THEN + FAILED ("ASSIGNMENT FAILED - 5"); + END IF; + + IF EQUAL(3,3) THEN + W := X1; -- B. + END IF; + IF W /= X1 THEN + FAILED ("ASSIGNMENT FAILED - 6"); + END IF; + + BEGIN + Y1 := X1; -- C. + IF Y1.DISC /= REPORT.IDENT_INT(3) THEN + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE BETWEEN TWO " & + "VARIABLES OF DIFFERENT CONSTRAINED ACCESS SUBTYPES " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 1"); + + END; + + W := NEW REC(IDENT_INT(3)); + + BEGIN + X1 := W; -- D. + IF X1.DISC /= REPORT.IDENT_INT(5) THEN + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS CHANGED"); + ELSE + FAILED ("NON-NULL ASSIGNMENT MADE FROM UNCONSTRAINED " & + "ACCESS TYPE DESIGNATING CONSTRAINED OBJECT TO "& + "ACCESS SUBTYPE WITH DIFFERENT CONSTRAINT " & + "AND CONSTRAINT IS NOT CHANGED"); + END IF; + EXCEPTION + + WHEN CONSTRAINT_ERROR => + NULL ; + + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - 2"); + + END; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + + END; + + + RESULT; + + + END C52011B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52101a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52101a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52101a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52101a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C52101A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAY SUBTYPE CONVERSION IS APPLIED AFTER AN ARRAY VALUE + -- IS DETERMINED. + + -- BHS 6/22/84 + + WITH REPORT; + PROCEDURE C52101A IS + + USE REPORT; + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + SUBTYPE WEEKDAY IS DAY RANGE MON..FRI; + + TYPE ARR IS ARRAY (WEEKDAY RANGE <>) OF INTEGER; + TYPE ARR_DAY IS ARRAY (DAY RANGE <>) OF INTEGER; + + NORM : ARR (MON..FRI); -- INDEX SUBTYPE WEEKDAY + NORM_DAY : ARR_DAY (MON..FRI); -- INDEX SUBTYPE DAY + + BEGIN + TEST ("C52101A", "CHECK THAT ARRAY SUBTYPE CONVERSION " & + "APPLIED AFTER ARRAY VAL. DETERMINED"); + + BEGIN -- ILLEGAL CASE + NORM := (WED..SUN => 0); -- ERROR: INDEX SUBTYPE + + FAILED ("EXCEPTION NOT RAISED FOR INDEX SUBTYPE ERROR"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("IMPROPER AGGREGATE BOUNDS DETECTED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + + END; + + + BEGIN -- LEGAL CASE + NORM_DAY := (WED..FRI => 0, SAT..SUN => 1); + IF NORM_DAY /= ( 0, 0, IDENT_INT(0), IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT ASSIGNMENT IN LEGAL CASE"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON LEGAL INDEX " & + "SUBTYPE CONVERSION"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED IN LEGAL CASE"); + + END; + + + RESULT; + + END C52101A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,251 ---- + -- C52102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES + -- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES + -- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS, + -- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + + -- PART 1: STATIC BOUNDS + + + -- RM 02/25/80 + -- SPS 2/18/83 + -- JBG 8/21/83 + -- JBG 5/8/84 + -- JBG 6/09/84 + + WITH REPORT; + PROCEDURE C52102A IS + + USE REPORT; + + + BEGIN + + + TEST( "C52102A" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT (PART 1: STATIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF INTEGER; + + BEGIN + A := ( 11 , 12 , 13 , 14 ); + A := ( 1 , A(1) , A(2) , A(1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( 11 , 12 , 13 , 14 ); + A := ( A(4) , A(3) , A(4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER; + + BEGIN + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(-4..0) := A(0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(0..4) := A(-4..0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := 0 & A(1..2) & A(1..2) & A(1..5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := A(6..9) & A(8..9) & A(8..9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( TRUE , A(1) , A(2) , A(1) ); + IF A /= ( TRUE , FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( A(4) , A(3) , A(4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN; + + BEGIN + A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE); + A(-4..0) := A(0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE); + A(0..4) := A(-4..0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := FALSE & A(1..2) & A(1..2) & A(1..5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + A := "ARGH"; + A := ( 'Q' , A(1) , A(2) , A(1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + A := "ARGH"; + A := ( A(4) , A(3) , A(4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( 96..104 ); + + BEGIN + A := "APHRODITE"; + A(96..100) := A(100..104); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + A := "APHRODITE"; + A(100..104) := A(96..100) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (1..9); + + BEGIN + A := "CAMBRIDGE"; + A := 'S' & A(1..2) & A(1..2) & A(1..4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + A := "CAMBRIDGE"; + A := A(8..8) & A(6..8) & A(6..8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + + END C52102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,278 ---- + -- C52102B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES + -- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES + -- THE SEMANTICS OF "COPY" ASSIGNMENT. (THIS TEST IS IN TWO PARTS, + -- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + + -- PART 2: DYNAMIC BOUNDS + + + -- RM 02/27/80 + -- SPS 2/18/83 + -- JBG 3/15/84 + -- JBG 6/9/84 + + WITH REPORT; + PROCEDURE C52102B IS + + USE REPORT; + IDENT_INT_0 : INTEGER := IDENT_INT(0); + IDENT_INT_1 : INTEGER := IDENT_INT (1); + IDENT_INT_2 : INTEGER := IDENT_INT (2); + IDENT_INT_3 : INTEGER := IDENT_INT (3); + IDENT_INT_4 : INTEGER := IDENT_INT (4); + IDENT_INT_5 : INTEGER := IDENT_INT (5); + IDENT_INT_6 : INTEGER := IDENT_INT (6); + IDENT_INT_8 : INTEGER := IDENT_INT (8); + IDENT_INT_9 : INTEGER := IDENT_INT (9); + + BEGIN + + + TEST( "C52102B" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT (PART 2: DYNAMIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( 11 , 12 , 13 , 14 ); + A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( 11 , 12 , 13 , 14 ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(-4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -4 , -3 , -2 , -1 , 100 , 1 , 2 , 3 , 4 ); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : ARR (1..10); + + BEGIN + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := 0 & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( 1 , 2 , 3 , 4 , 5 , 6 , 7 , 8 , 9 , 10 ); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( TRUE , FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := ( FALSE , TRUE , TRUE , FALSE ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN; + + BEGIN + A := (FALSE,FALSE,FALSE,FALSE,FALSE,TRUE, TRUE, TRUE,TRUE); + A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (FALSE,FALSE,FALSE,FALSE, TRUE,TRUE, TRUE, TRUE,TRUE); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := FALSE & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + A := "ARGH"; + A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + A := "ARGH"; + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( IDENT_INT(96)..104 ); + + BEGIN + A := "APHRODITE"; + A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100).. + IDENT_INT(104)); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + A := "APHRODITE"; + A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96).. + IDENT_INT(100)) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (IDENT_INT_1..9); + + BEGIN + A := "CAMBRIDGE"; + A := 'S' & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + A := "CAMBRIDGE"; + A := A(IDENT_INT_8..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + + END C52102B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,280 ---- + -- C52102C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES + -- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES + -- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES + -- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS, + -- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + + -- PART 1: STATIC BOUNDS + + + -- RM 02/25/80 + -- SPS 2/18/83 + -- JBG 8/21/83 + -- JBG 5/8/84 + -- JBG 6/09/84 + -- BHS 6/26/84 + + WITH REPORT; + PROCEDURE C52102C IS + + USE REPORT; + + FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT; + FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL; + + BEGIN + + + TEST( "C52102C" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " & + "ARE DYNAMIC (PART 1: STATIC BOUNDS)" ); + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF INTEGER; + + BEGIN + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14)); + A := ( 1 , A(1) , A(2) , A(1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14)); + A := ( A(4) , A(3) , A(4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF INTEGER; + + BEGIN + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1),ID_I(2), ID_I(3), ID_I(4) ); + A(-4..0) := A(0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4) ); + A(0..4) := A(-4..0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) ); + A := 0 & A(1..2) & A(1..2) & A(1..5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10) ); + A := A(6..9) & A(8..9) & A(8..9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( TRUE , A(1) , A(2) , A(1) ); + IF A /= ( TRUE ,FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( A(4) , A(3) , A(4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( INTEGER RANGE -4..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(-4..0) := A(0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(TRUE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(0..4) := A(-4..0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := FALSE & A(1..2) & A(1..2) & A(1..5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := A(6..9) & A(8..9) & A(8..9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( 'Q' , A(1) , A(2) , A(1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( A(4) , A(3) , A(4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( 96..104 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(96..100) := A(100..104); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(100..104) := A(96..100) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (1..9); + + BEGIN + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := 'S' & A(1..2) & A(1..2) & A(1..4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := A(8..8) & A(6..8) & A(6..8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + + END C52102C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52102d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52102d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,307 ---- + -- C52102D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ASSIGNMENT OF OVERLAPPING SOURCE AND TARGET VARIABLES + -- (INCLUDING ARRAYS AND SLICES IN VARIOUS COMBINATIONS) SATISFIES + -- THE SEMANTICS OF "COPY" ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES + -- REQUIRE RUN-TIME EVALUATION. (THIS TEST IS IN TWO PARTS, + -- COVERING RESPECTIVELY STATIC AND DYNAMIC BOUNDS.) + + -- PART 2: DYNAMIC BOUNDS + + + -- RM 02/27/80 + -- SPS 2/18/83 + -- JBG 3/15/84 + -- JBG 6/9/84 + -- BHS 6/26/84 + + WITH REPORT; + PROCEDURE C52102D IS + + USE REPORT; + IDENT_INT_0 : INTEGER := IDENT_INT(0); + IDENT_INT_1 : INTEGER := IDENT_INT (1); + IDENT_INT_2 : INTEGER := IDENT_INT (2); + IDENT_INT_3 : INTEGER := IDENT_INT (3); + IDENT_INT_4 : INTEGER := IDENT_INT (4); + IDENT_INT_5 : INTEGER := IDENT_INT (5); + IDENT_INT_6 : INTEGER := IDENT_INT (6); + IDENT_INT_8 : INTEGER := IDENT_INT (8); + IDENT_INT_9 : INTEGER := IDENT_INT (9); + + FUNCTION ID_I (X : INTEGER) RETURN INTEGER RENAMES IDENT_INT; + FUNCTION ID_B (X : BOOLEAN) RETURN BOOLEAN RENAMES IDENT_BOOL; + + BEGIN + + + TEST( "C52102D" , "CHECK THAT THE ASSIGNMENT OF OVERLAPPING " & + "SOURCE AND TARGET VARIABLES (INCLUDING " & + "ARRAYS AND SLICES IN VARIOUS COMBINATIONS) " & + "SATISFIES THE SEMANTICS OF ""COPY"" " & + "ASSIGNMENT WHEN INITIAL ASSIGNMENT VALUES " & + "ARE DYNAMIC (PART 2: DYNAMIC BOUNDS)" ); + + ------------------------------------------------------------------- + -------------------- ARRAYS OF INTEGERS ------------------------- + + DECLARE + A : ARRAY( 1..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) ); + A := ( 1 , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( 1 , 11 , 12 , 11 ) THEN + FAILED( "WRONG VALUES - I1" ); + END IF; + + A := ( ID_I(11), ID_I(12), ID_I(13), ID_I(14) ); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 1 ); + IF A /= ( 14 , 13 , 14 , 1 ) THEN + FAILED( "WRONG VALUES - I2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -4..IDENT_INT_4 ) OF INTEGER; + + BEGIN + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4)); + A(-4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= ( 100 , 1 , 2 , 3 , 4 , 1 , 2 , 3 , 4 ) + THEN + FAILED( "WRONG VALUES - I3" ); + END IF; + + A := ( -ID_I(4), -ID_I(3), -ID_I(2), -ID_I(1), + ID_I(100), ID_I(1), ID_I(2), ID_I(3), ID_I(4)); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= ( -4 , -3 , -2 , -1 , -4 , -3 , -2 , -1 , 100 ) + THEN + FAILED( "WRONG VALUES - I4" ); + END IF; + + END; + + + DECLARE + TYPE INT_ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + A : INT_ARR (1..10); + + BEGIN + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10)); + A := 0 & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A /= ( 0 , 1 , 2 , 1 , 2 , 1 , 2 , 3 , 4 , 5 ) + THEN + FAILED( "WRONG VALUES - I5" ); + END IF; + + A := ( ID_I(1), ID_I(2), ID_I(3), ID_I(4), ID_I(5), + ID_I(6), ID_I(7), ID_I(8), ID_I(9), ID_I(10)); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & 0 & 0; + IF A /= ( 6 , 7 , 8 , 9 , 8 , 9 , 8 , 9 , 0 , 0 ) + THEN + FAILED( "WRONG VALUES - I6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- ARRAYS OF BOOLEANS ------------------------- + + DECLARE + A : ARRAY( 1..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( TRUE , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= ( TRUE ,FALSE , TRUE , FALSE ) + THEN + FAILED( "WRONG VALUES - B1" ); + END IF; + + A := (ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), ID_B(FALSE)); + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , TRUE ); + IF A /= ( FALSE , TRUE , FALSE, TRUE ) + THEN + FAILED( "WRONG VALUES - B2" ); + END IF; + + END; + + + DECLARE + A : ARRAY( -IDENT_INT_4..4 ) OF BOOLEAN; + + BEGIN + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(FALSE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(-IDENT_INT_4..IDENT_INT_0) := A(IDENT_INT_0..4); + IF A /= (FALSE, TRUE, TRUE, TRUE, TRUE,TRUE, TRUE, TRUE,TRUE) + THEN + FAILED( "WRONG VALUES - B3" ); + END IF; + + A := (ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), ID_B(FALSE), + ID_B(TRUE), ID_B(TRUE), ID_B(TRUE), + ID_B(TRUE), ID_B(TRUE)); + A(IDENT_INT_0..4) := A(-4..IDENT_INT_0); + IF A /= (FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B4" ); + END IF; + + END; + + + DECLARE + TYPE B_ARR IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A : B_ARR (1..10); + + BEGIN + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := FALSE & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_5); + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B5" ); + END IF; + + A := (ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), ID_B(FALSE), + ID_B(TRUE), ID_B(FALSE), ID_B(TRUE), + ID_B(FALSE), ID_B(TRUE), ID_B(FALSE)); + A := A(IDENT_INT_6..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & + A(IDENT_INT_8..IDENT_INT_9) & FALSE & TRUE; + IF A/=(FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE,FALSE,TRUE) + THEN + FAILED( "WRONG VALUES - B6" ); + END IF; + + END; + + + ------------------------------------------------------------------- + -------------------- CHARACTER STRINGS -------------------------- + + DECLARE + A : STRING( 1..4 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( 'Q' , A(IDENT_INT_1) , A(IDENT_INT_2) , + A(IDENT_INT_1) ); + IF A /= "QARA" THEN + FAILED( "WRONG VALUES - C1" ); + END IF; + + IF EQUAL (3,3) THEN + A := "ARGH"; + END IF; + A := ( A(IDENT_INT_4) , A(IDENT_INT_3) , + A(IDENT_INT_4) , 'X' ); + IF A /= "HGHX" THEN + FAILED( "WRONG VALUES - C2" ); + END IF; + + END; + + + DECLARE + A : STRING( IDENT_INT(96)..104 ); + + BEGIN + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(IDENT_INT(96)..IDENT_INT(100)) := A(IDENT_INT(100).. + IDENT_INT(104)); + IF A /= "ODITEDITE" THEN + FAILED( "WRONG VALUES - C3" ); + END IF; + + IF EQUAL (3,3) THEN + A := "APHRODITE"; + END IF; + A(IDENT_INT(100)..IDENT_INT(104)) := A(IDENT_INT(96).. + IDENT_INT(100)) ; + IF A /= "APHRAPHRO" THEN + FAILED( "WRONG VALUES - C4" ); + END IF; + + END; + + + DECLARE + TYPE CH_ARR IS ARRAY (INTEGER RANGE <>) OF CHARACTER; + A : CH_ARR (IDENT_INT_1..9); + + BEGIN + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := 'S' & A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_2) & + A(IDENT_INT_1..IDENT_INT_4); + IF A /= "SCACACAMB" THEN + FAILED( "WRONG VALUES - C5" ); + END IF; + + IF EQUAL (3,3) THEN + A := "CAMBRIDGE"; + END IF; + A := A(IDENT_INT_8..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & + A(IDENT_INT_6..IDENT_INT_8) & "EA"; + IF A /= "GIDGIDGEA" THEN + FAILED( "WRONG VALUES - C6" ); + END IF; + + END; + + + RESULT; + + + END C52102D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,385 ---- + -- C52103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 2/18/83 + + WITH REPORT; + PROCEDURE C52103A IS + + USE REPORT ; + + BEGIN + + TEST( "C52103A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 2-11-4- + -- -13-6 ; THUS THE 8 SELECTIONS ARE + -- 2-11-4-13-6-7-8-9 (IN THIS ORDER) + -- .) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA21 IS ARRAY( INTEGER RANGE 1..5 , INTEGER RANGE 0..7 + ) OF INTEGER ; + + SUBTYPE TA22 IS TA21 ; + + ARR21 : TA21 ; + ARR22 : TA22 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + ARR21( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARR22 := ARR21 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + + IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT" ); + END IF; + + END LOOP; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 2" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 1..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX11( I ) := I * I ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 5..9 LOOP + + IF ARRX12( I ) /= ( I-4 ) * ( I-4 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" ); + END IF; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TA42 IS ARRAY( INTEGER RANGE 1..5 ) OF BOOLEAN ; + + SUBTYPE TA41 IS TA42 ; + + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARR41(2) := TRUE ; + + ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( 1 ) := TRUE ; + + + -- SLICE ASSIGNMENT: + + ARR42(2..5) := ARR41(1..4) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN 2..5 LOOP + + IF ARR42( I ) /= FALSE AND I /= 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( 1 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 4" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- C52103B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 2/18/83 + + WITH REPORT; + PROCEDURE C52103B IS + + USE REPORT ; + + BEGIN + + TEST( "C52103B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 11..15 ); + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15 + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( 11..15 ) /= "QUINC" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA61 IS ARRAY( INTEGER RANGE 11..15 ) OF CHARACTER ; + + ARR61 : TA61 ; + + BEGIN + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR61( 11..11 ) := "Q" ; + + + -- SLICE ASSIGNMENT: + + ARR61( 12..15 ) := "UINC" ; -- "UINC"(1..4) SLIDES TO 12..15 + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR61 /= "QUINC" OR + ARR61( 11..15 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 6" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + -- C52103C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + + + PROCEDURE C52103C IS + + USE REPORT ; + + BEGIN + + TEST( "C52103C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..5 ) := "ABCDE" ; + ARR72 : STRING( 5..9 ) := "FGHIJ" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "ABCDE" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR82( 5..5 ) := "Q" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 ) := "BCDE" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( 5..9 ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR92( 5..5 ) := "Q" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 ) := ARR91( 1..5 )(2..5 )( 2..5 ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QBCDE" OR + ARR92( 5..9 ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- C52103F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103F IS + + USE REPORT ; + + BEGIN + + TEST( "C52103F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 10-3-12- + -- -5-14 ; THUS THE 8 SELECTIONS ARE + -- 10-3-12-5-14-7-8-9 (IN THIS ORDER + -- ).) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..0 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( 7..6 , 20..27 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA3 IS ARRAY( INTEGER RANGE 100..99 ) OF INTEGER ; + + SUBTYPE TA31 IS TA3 ; + SUBTYPE TA32 IS TA3 ; + + ARR31 : TA31 ; + ARR32 : TA32 ; + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARR32 := ARR31 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 3" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52(6..5) := ARRX51(4..3) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C52103G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103G IS + + USE REPORT ; + + BEGIN + + TEST( "C52103G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA51 IS ARRAY( INTEGER RANGE 11..10 ) OF CHARACTER ; + + ARR51 : TA51 ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARR51 := "" ; + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARR51 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" ); + END IF; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 5" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 11..15 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( 13..12 ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 11..15 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,175 ---- + -- C52103H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103H IS + + USE REPORT ; + + BEGIN + + TEST( "C52103H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..0 ) := "" ; + ARR72 : STRING( 5..4 ) ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( 5..9 ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 )( 6..5 ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( 5..9 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..4 ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103k.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,393 ---- + -- C52103K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103K IS + + USE REPORT ; + + BEGIN + + TEST( "C52103K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 2-11-4- + -- -13-6 ; THUS THE 8 SELECTIONS ARE + -- 2-11-4-13-6-7-8-9 (IN THIS ORDER) + -- .) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA21 IS ARRAY( + INTEGER RANGE IDENT_INT(1)..IDENT_INT(5) , + INTEGER RANGE IDENT_INT(0)..IDENT_INT(7) + ) OF INTEGER ; + + SUBTYPE TA22 IS TA21 ; + + ARR21 : TA21 ; + ARR22 : TA22 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + ARR21( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARR22 := ARR21 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + + IF ARR22( I , J ) /= ( I-0 ) * ( I-0 ) * ( J-0 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT" ); + END IF; + + END LOOP; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 2" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX11( I ) := I * I ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + + IF ARRX12( I ) /= ( I-4 ) * ( I-4 ) + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (11)" ); + END IF; + + END LOOP; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TA42 IS ARRAY( + INTEGER RANGE IDENT_INT(1)..IDENT_INT(5) + ) OF BOOLEAN ; + + SUBTYPE TA41 IS TA42 ; + + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARR41( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARR41(2) := TRUE ; + + ARR41(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( 1 ) := TRUE ; + + + -- SLICE ASSIGNMENT: + + ARR42( IDENT_INT(2)..IDENT_INT(5) ) := + ARR41( + IDENT_INT(1)..IDENT_INT(4) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN IDENT_INT(2)..IDENT_INT(5) LOOP + + IF ARR42( I ) /= FALSE AND I /= 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 3 + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( 1 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 4" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103l.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C52103L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY. + + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103L IS + + USE REPORT ; + + BEGIN + + TEST( "C52103L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(15) ); + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "QUINC" ; -- "QUINC"(1..5) SLIDES TO 11..15 + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA61 IS ARRAY( + INTEGER RANGE IDENT_INT(11)..IDENT_INT(15) + ) OF CHARACTER ; + + ARR61 : TA61 ; + + BEGIN + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR61( IDENT_INT(11)..IDENT_INT(11) ) := "Q" ; + + + -- SLICE ASSIGNMENT: + + ARR61( IDENT_INT(12)..IDENT_INT(15) ) := "UINC" ; + -- "UINC"(1..4) SLIDES TO 12..15 + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR61 /= "QUINC" OR + ARR61( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (6)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 6" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103L ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103m.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C52103M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103M IS + + USE REPORT ; + + BEGIN + + TEST( "C52103M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "FGHIJ" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "ABCDE" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := "BCDE" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(5) ) := "Q" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(2)..IDENT_INT(5) ) + ( IDENT_INT(2)..IDENT_INT(5) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QBCDE" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103M ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103p.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,344 ---- + -- C52103P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + + WITH REPORT; + PROCEDURE C52103P IS + + USE REPORT ; + + BEGIN + + TEST( "C52103P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE SELECTIONS ARE 7 , 8 , 9 , + -- AND PRECISELY 5 CASES FROM THE + -- TWO 5-CASE SERIES 2-3-4-5-6 AND + -- 10-11-12-13-14) + -- + -- ( IN THE CURRENT DIVISION, THE 5 + -- FLOATING SELECTIONS ARE 10-3-12- + -- -5-14 ; THUS THE 8 SELECTIONS ARE + -- 10-3-12-5-14-7-8-9 (IN THIS ORDER + -- ).) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1) ARRAY OBJECTS DECLARED IN THE SAME DECLARATION. + -- (TWO-DIMENSIONAL; NON-CONSTRAINABLE TYPEMARK.) + -- + -- (THIS WILL BE THE ONLY CASE INVOLVING OBJECTS DECLARED + -- IN THE SAME DECLARATION.) + -- + -- + -- (2) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED WITHOUT EVER USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- (SLICING IS ILLEGAL; SINCE IN THIS TEST WE ARE NEVER + -- USING AGGREGATES + -- (EXCEPT FOR ONE-DIMENSIONAL ARRAYS OF CHARACTERS; + -- SEE (5) ) + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS + -- (AS IN T1(ARR) , WHERE ARR IS AN ARRAY + -- OBJECT AND T1 IS AN ARRAY TYPEMARK SIMILAR + -- -- AS MORE PRECISELY SPECIFIED IN RM 4.6(B) -- + -- TO THE TYPEMARK OF ARR ), + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- (SINCE WE ARE NOT USING AGGREGATES + -- AND WE ARE NOT USING CONVERSION-TO-CONSTRAINED-TYPEMARKS, + -- THE ARRAY ASSIGNMENT CANNOT INVOLVE ANY SLIDING, + -- AND THE TYPEMARKS ARE ESSENTIALLY THE SAME.) + -- + -- + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- (THE ASSIGNMENT MAY REQUIRE SLIDING.) + -- + -- (MOST SUBSEQUENT SUBCASES IN THIS TEST (OTHER THAN NULL + -- ASSIGNMENTS) WILL INVOLVE SLIDING; WE ASSUME THAT + -- SUBCASES WHICH WORK IN CONJUNCTION WITH SLIDING WORK + -- ALSO WHEN NO SLIDING IS INVOLVED.) + -- + -- + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (6) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(0) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( IDENT_INT(7)..IDENT_INT(6) , + IDENT_INT(20)..IDENT_INT(27) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (3) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TA3 IS ARRAY( + INTEGER RANGE IDENT_INT(100)..IDENT_INT(99) + ) OF INTEGER ; + + SUBTYPE TA31 IS TA3 ; + SUBTYPE TA32 IS TA3 ; + + ARR31 : TA31 ; + ARR32 : TA32 ; + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARR32 := ARR31 ; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 3" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(5) ) := + ARRX51( + IDENT_INT(4)..IDENT_INT(3) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (VALUES)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103q.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- C52103Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSWEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 2/18/83 + + WITH REPORT; + PROCEDURE C52103Q IS + + USE REPORT ; + + BEGIN + + TEST( "C52103Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (5) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + + DECLARE + + TYPE TA51 IS ARRAY( + INTEGER RANGE IDENT_INT(11)..IDENT_INT(10) + ) OF CHARACTER ; + + ARR51 : TA51 ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARR51 := "" ; + + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARR51 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (5)" ); + END IF; + + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 5" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (14)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103r.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,181 ---- + -- C52103R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSWEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 2/18/83 + + WITH REPORT; + PROCEDURE C52103R IS + + USE REPORT ; + + BEGIN + + TEST( "C52103R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(0) ) := "" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "STRING ASSIGNMENT NOT CORRECT (7)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(5) ) := "" ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (8)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(8)..IDENT_INT(7) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(5)..IDENT_INT(4) ) ; + + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT (9)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52103R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52103x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52103x.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,241 ---- + -- C52103X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS A SPECIAL CASE IN + + -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY + + -- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST . + -- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH + -- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE + -- CONSTRAINT_ERROR TO BE RAISED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- RM 07/31/81 + -- SPS 10/26/82 + -- JBG 06/15/83 + -- EG 11/02/84 + -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE C52103X IS + + USE REPORT ; + + BEGIN + + TEST( "C52103X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " & + "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " & + "CHECK WHETHER CONSTRAINT_ERROR " & + "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS" ); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (4) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED WITHOUT EVER USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR + -- FOR THE TYPE DECLARATION. + BEGIN + + DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY TYPE + + TYPE TA42 IS ARRAY( + INTEGER RANGE IDENT_INT(-2)..IDENT_INT(INTEGER'LAST) + ) OF BOOLEAN ; + -- CONSTRAINT_ERROR MAY BE RAISED BY THE + -- ARRAY TYPE DECLARATION. + PRAGMA PACK (TA42); + + SUBTYPE TA41 IS TA42 ; + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " & + "WITH 'LENGTH = INTEGER'LAST + 3"); + + OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT + -- HAVE INTEGER'LAST + 3 COMPONENTS; + -- STORAGE_ERROR MAY BE RAISED. + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + COMMENT ("NO STORAGE_ERROR OR CONSTRAINT_ERROR RAISED " & + "WHEN ALLOCATING TWO BIG BOOLEAN ARRAYS"); + -- INITIALIZATION OF RHS ARRAY: + + -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED, + -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG + -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH + -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED. + + NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR HERE. + FOR I IN IDENT_INT(-2)..IDENT_INT(2) LOOP + ARR41(I) := FALSE ; -- VALUES ARE:: FTFFT + END LOOP; + + ARR41(-1) := TRUE ; + + ARR41( 2) := TRUE ; -- RHS IS: F T F F T + + + -- INITIALIZATION OF UNUSED COMPONENT OF LHS ARRAY: + + ARR42( -2 ) := TRUE ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN " & + "ASSIGNING TO ARRAY COMPONENTS"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + + END NO_EXCP; + + DO_SLICE: BEGIN + -- SLICE ASSIGNMENT: + + ARR42( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) := + ARR41( + IDENT_INT(-2)..IDENT_INT(INTEGER'LAST-1)) ; + + COMMENT ("NO EXCEPTION RAISED DURING SLICE " & + "ASSIGNMENT"); + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + CHK_SLICE: BEGIN + FOR I IN IDENT_INT(-1)..IDENT_INT(2) LOOP + + IF ARR42( I ) /= FALSE AND I /= 0 + THEN + FAILED( "SLICE ASSIGNMENT NOT " & + "CORRECT (VALUES)" ); + ELSIF ARR42( I ) /= TRUE AND I = 0 + THEN + FAILED( "SLICE ASSIGNMENT NOT " & + "CORRECT (VALUES)" ); + END IF; + + END LOOP; + + IF ARR42( -2 ) /= TRUE + THEN + FAILED( "SLICE ASSIGNMENT NOT CORRECT " & + "(SLIDING)" ); + END IF; + + EXCEPTION + + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + + END CHK_SLICE; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED DURING " & + "SLICE ASSIGNMENT"); + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED DURING SLICE " & + "ASSIGNMENT"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION DURING SLICE " & + "ASSIGNMENT"); + END DO_SLICE; + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY TYPE WITH INTEGER'LAST + 3 COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + + RESULT ; + + + END C52103X; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,343 ---- + -- C52104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104A IS + + USE REPORT ; + + BEGIN + + TEST( "C52104A" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1..6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..5 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0( 0..5 , 2..9 ); + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + FOR J IN 0..7 LOOP + ARRX01( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 0..5 LOOP + + FOR J IN 2..9 LOOP + ARRX02( I , J ) := I * I * J * 3 ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 0..5 LOOP + + FOR J IN 2..9 LOOP + + IF ARRX02( I , J ) /= I * I * J * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (10)" ); + END IF; + + END LOOP; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 1..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 6..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + + ARRX11( I ) := I * I ; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 6..9 LOOP + ARRX12( I ) := I * I * 3 ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN 6..9 LOOP + + IF ARRX12( I ) /= I * I * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (11)" ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + + -- SLICE ASSIGNMENT: + + ARRX52(6..9) := ARRX51(3..3) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN 5..9 LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED ( 12 ) " ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C52104B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104B IS + + USE REPORT ; + + BEGIN + + TEST( "C52104B" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 2..6 ) := "QUINC" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "ABCD" ; + FAILED( "NO EXCEPTION RAISED (13)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( 2..6 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (13)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 5..9 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- SLICE ASSIGNMENT: + + ARRX42( 6..9 ) := "ABCDEFGH" ; + FAILED( "NO EXCEPTION RAISED (14)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 5..9 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + -- C52104C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION A : STATICALLY-DETERMINABLE NON-NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104C IS + + USE REPORT ; + + BEGIN + + TEST( "C52104C" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..5 ) := "ABCDE" ; + ARR72 : STRING( 5..8 ) := "FGHI" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "FGHI" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) := "QBCDE" ; + + BEGIN + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 ) := "EIN" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( 5..9 ) /= "QBCDE" + THEN + FAILED( "LHS ARRAY ALTERED (8)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..7 ) := "ABCDEFG" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 ) := ARR91( 1..7 )( 1..6 )( 1..6 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "LHS VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,292 ---- + -- C52104F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSWEWHERE.) + + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 10/27/82 + + WITH REPORT; + PROCEDURE C52104F IS + + USE REPORT ; + + BEGIN + + TEST( "C52104F" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE DYNAMIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS C (FOR NON-NULL ARRAYS) AND D (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1 .. 6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( 1..1 , 0..7 ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( 1..0 , 0..7 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( 4..5 ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( 5..4 ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( 1..5 ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( 5..9 ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN 1..5 LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN 5..9 LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( 6..5 ) := ARRX51( 4..4 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C52104G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + -- JBG 4/24/84 + + WITH REPORT; + PROCEDURE C52104G IS + + USE REPORT ; + + BEGIN + + TEST( "C52104G" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( 11..10 ) := "" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "AZ" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX31 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( 11..15 ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( 13..12 ) := "ABCD" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( 11..15 ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C52104H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION B : STATICALLY-DETERMINABLE NULL LENGTHS. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104H IS + + USE REPORT ; + + BEGIN + + TEST( "C52104H" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( 1..1 ) := "A" ; + ARR72 : STRING( 5..4 ) := "" ; + + BEGIN + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( 5..9 ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( 5..9 ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( 5..9 )( 6..9 )( 6..5 ) := "ABC" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( 5..9 ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (8)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( 5..9 ) ; + + ARR91 : STRING( 1..5 ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( 5..9 ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( 5..9 )( 6..9 )( 8..7 ) := ARR91( 1..5 )( 5..7 ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( 5..9 ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104k.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,347 ---- + -- C52104K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104K IS + + USE REPORT ; + + BEGIN + + TEST( "C52104K" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: NULL ARRAYS....... TREATED IN DIVISION B. + -- SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + -- (-) THE STATIC-ARRAY COUNTERPARTS OF THESE TESTS ARE IN DI- + -- VISIONS A (FOR NON-NULL ARRAYS) AND B (FOR NULL ARRAYS). + -- + -- + + + ------------------------------------------------------------------- + + -- (1..6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(5) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0( IDENT_INT(0)..IDENT_INT(5) , + IDENT_INT(2)..IDENT_INT(9) ); + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02 ; + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(0)..IDENT_INT(7) LOOP + ARRX01( I , J ) := I * I * J ; + END LOOP; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP + ARRX02( I , J ) := I * I * J * 3 ; + END LOOP; + + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(0)..IDENT_INT(5) LOOP + + FOR J IN IDENT_INT(2)..IDENT_INT(9) LOOP + + IF ARRX02( I , J ) /= I * I * J * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (10)" ); + END IF; + + END LOOP; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(1)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(6)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + + ARRX11( I ) := I * I ; + + END LOOP; + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP + ARRX12( I ) := I * I * 3 ; + END LOOP; + + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ARRAY ASSIGNMENT: + + FOR I IN IDENT_INT(6)..IDENT_INT(9) LOOP + + IF ARRX12( I ) /= I * I * 3 + THEN + FAILED( "ORIG. VALUE ALTERED (11)" ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + + -- SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(9) ) := + ARRX51( + IDENT_INT(3)..IDENT_INT(3) ) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED ( 12 ) " ); + END IF; + + END LOOP; + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104l.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C52104L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + + -- HISTORY: + -- RM 07/20/81 CREATED ORIGINAL TEST. + -- SPS 03/22/83 + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; + PROCEDURE C52104L IS + + USE REPORT ; + + BEGIN + + TEST( "C52104L" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(2)..IDENT_INT(6) ) := "QUINC" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "ABCD" ; + FAILED( "NO EXCEPTION RAISED (13)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX31 /= "QUINC" OR + ARRX31( IDENT_INT(2)..IDENT_INT(6) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (13)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(5)..IDENT_INT(9) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(6)..IDENT_INT(9) ) := "ABCDEFGH" ; + FAILED( "NO EXCEPTION RAISED (14)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104m.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C52104M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION C : NON-NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104M IS + + USE REPORT ; + + BEGIN + + TEST( "C52104M" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(8) ) := "FGHI" ; + + BEGIN + + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "FGHI" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) := "QBCDE" ; + + BEGIN + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := "EIN" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR82 /= "QBCDE" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QBCDE" + THEN + FAILED( "LHS ARRAY ALTERED (8)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(7) ) := "ABCDEFG" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(7) ) + ( IDENT_INT(1)..IDENT_INT(6) ) + ( IDENT_INT(1)..IDENT_INT(6) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "LHS VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104p.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,292 ---- + -- C52104P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + + + WITH REPORT; + PROCEDURE C52104P IS + + USE REPORT ; + + BEGIN + + TEST( "C52104P" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + -- CASES DISTINGUISHED: ( 8 SELECTED CASES ARE IMPLEMENTED) + -- + -- ( THE 8 SELECTIONS ARE THE 5-CASE + -- SERIES 10-11-12-13-14 FOLLOWED + -- BY 7 , 8 , 9 (IN THIS ORDER). ) + -- + -- + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + -- + -- + -- (1..6) (DO NOT APPLY TO NON-MATCHING OBJECTS, SINCE WE WANT + -- THE OBJECTS TO HAVE THE S A M E BASE TYPE.) + -- + -- + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + -- + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + -- + -- (-) CONSTRAINABLE TYPES: ONLY SUBTESTS 2, 3, 4, 5, 6 + -- WILL BE REPLICATED -- AS SUBTESTS 10, 11, 12, 13, 14 . + -- + -- + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + -- + -- + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + -- + -- + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + -- + -- + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- (STRING LITERALS ARE THE ONLY AGGREGATES WE ARE USING + -- IN THIS TEST. TO FORCE SLIDING, THE LOWER LIMIT IMPLIED + -- BY THE TYPEMARK WILL NOT BE 1 .) + -- + -- + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + -- + -- + -- + -- (-) SPECIAL CASES: SUPERLONG ARRAYS.. (TREATED FOR DYNAMIC + -- ARRAYS ONLY, + -- DIVISIONS C AND D .) + -- + -- + + + ------------------------------------------------------------------- + + -- (1 .. 6: NOT APPLICABLE) + -- + -- + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX0 IS ARRAY( INTEGER RANGE <> , INTEGER RANGE <> + ) OF INTEGER ; + + SUBTYPE TABOX01 IS TABOX0( IDENT_INT(1)..IDENT_INT(1) , + IDENT_INT(0)..IDENT_INT(7) ); + SUBTYPE TABOX02 IS TABOX0 ; + + ARRX01 : TABOX01 ; + ARRX02 : TABOX02( IDENT_INT(1)..IDENT_INT(0) , + IDENT_INT(0)..IDENT_INT(7) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX02 := ARRX01 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 10" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 10" ); + + END ; + + + ------------------------------------------------------------------- + + -- (11) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF INTEGERS.) + + DECLARE + + TYPE TABOX1 IS ARRAY( INTEGER RANGE <> ) OF INTEGER ; + + SUBTYPE TABOX11 IS TABOX1( IDENT_INT(4)..IDENT_INT(5) ) ; + + ARRX11 : TABOX11 ; + ARRX12 : TABOX1( IDENT_INT(5)..IDENT_INT(4) ); + + BEGIN + + -- ARRAY ASSIGNMENT: + + ARRX12 := ARRX11 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 11" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + NULL ; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 11" ); + + END ; + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + + SUBTYPE TABOX51 IS TABOX5( IDENT_INT(1)..IDENT_INT(5) ); + + ARRX51 : TABOX51 ; + ARRX52 : TABOX5( IDENT_INT(5)..IDENT_INT(9) ); + + BEGIN + + -- INITIALIZATION OF RHS ARRAY: + + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + ARRX51( I ) := FALSE ; -- VALUES WILL BE: F T F F T + END LOOP; + + ARRX51(2) := TRUE ; + + ARRX51(5) := TRUE ; -- RHS VALUES ARE: F T F F T + + + -- INITIALIZATION OF LHS ARRAY: + + FOR I IN IDENT_INT(5)..IDENT_INT(9) LOOP + ARRX52( I ) := TRUE ; -- VALUES WILL BE: T F T T F + END LOOP; + + ARRX52(6) := FALSE ; + + ARRX52(9) := FALSE ; -- LHS VALUES ARE: T F T T F + + + -- NULL SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(6)..IDENT_INT(5) ) := + ARRX51 + ( IDENT_INT(4)..IDENT_INT(4) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 12" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + IF ARRX52( 5 ) /= TRUE OR + ARRX52( 6 ) /= FALSE OR + ARRX52( 7 ) /= TRUE OR + ARRX52( 8 ) /= TRUE OR + ARRX52( 9 ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 12" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104q.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C52104Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE SECOND FILE IN + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + -- JBG 4/24/84 + + WITH REPORT; + PROCEDURE C52104Q IS + + USE REPORT ; + + BEGIN + + TEST( "C52104Q" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (13) UNSLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX3 IS ARRAY( NATURAL RANGE <> ) OF CHARACTER ; + + ARRX31 : TABOX3( IDENT_INT(11)..IDENT_INT(10) ) := "" ; + + BEGIN + + + -- ARRAY ASSIGNMENT (WITH STRING AGGREGATE): + + ARRX31 := "AZ" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 13" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX31 /= "" + THEN + FAILED( "ARRAY ASSIGNMENT NOT CORRECT (13)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 13" ); + + END ; + + + ------------------------------------------------------------------- + + -- (14) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS 'CHARACTER' . + + DECLARE + + TYPE TABOX4 IS ARRAY( INTEGER RANGE <> ) OF CHARACTER ; + + SUBTYPE TABOX42 IS TABOX4( IDENT_INT(11)..IDENT_INT(15) ); + + ARRX42 : TABOX42 ; + + BEGIN + + -- INITIALIZATION OF LHS ARRAY: + + ARRX42 := "QUINC" ; + + + -- NULL SLICE ASSIGNMENT: + + ARRX42( IDENT_INT(13)..IDENT_INT(12) ) := "ABCD" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 14" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE SLICE ASSIGNMENT: + + IF ARRX42 /= "QUINC" OR + ARRX42( IDENT_INT(11)..IDENT_INT(15) ) /= "QUINC" + THEN + FAILED( "LHS ARRAY ALTERED (14)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 14" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104r.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,190 ---- + -- C52104R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS THE THIRD FILE IN + -- DIVISION D : NULL LENGTHS NOT DETERMINABLE STATICALLY. + + + -- RM 07/20/81 + -- SPS 3/22/83 + + WITH REPORT; + PROCEDURE C52104R IS + + USE REPORT ; + + BEGIN + + TEST( "C52104R" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS THE LENGTHS MUST MATCH" ); + + + -- ( EACH DIVISION COMPRISES 3 FILES, + -- COVERING RESPECTIVELY THE FIRST + -- 3 , NEXT 2 , AND LAST 3 OF THE 8 + -- SELECTIONS FOR THE DIVISION.) + + + ------------------------------------------------------------------- + + -- (7) UNSLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + + DECLARE + + ARR71 : STRING( IDENT_INT(1)..IDENT_INT(1) ) := "A" ; + ARR72 : STRING( IDENT_INT(5)..IDENT_INT(4) ) := "" ; + + BEGIN + + -- STRING ASSIGNMENT: + + ARR72 := ARR71 ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 7" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR72 /= "" + THEN + FAILED( "ORIGINAL VALUE ALTERED (7)" ); + END IF; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 7" ); + + END ; + + + ------------------------------------------------------------------- + + -- (8) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' , WITH + -- STRING LITERALS. + -- + + DECLARE + + ARR82 : STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING LITERAL ASSIGNMENT: + + ARR82( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(5) ) := "ABC" ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 8" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR82 /= "QUINC" OR + ARR82( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (8)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 8" ); + + END ; + + + ------------------------------------------------------------------- + + -- (9) SLICED OBJECTS OF THE PREDEFINED TYPE 'STRING' (BY + -- THEMSELVES). + -- + + DECLARE + + SUBTYPE TA92 IS STRING( IDENT_INT(5)..IDENT_INT(9) ) ; + + ARR91 : STRING( IDENT_INT(1)..IDENT_INT(5) ) := "ABCDE" ; + ARR92 : TA92 ; + + BEGIN + + + -- INITIALIZATION OF LHS ARRAY: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) := "QUINC" ; + + + -- STRING SLICE ASSIGNMENT: + + ARR92( IDENT_INT(5)..IDENT_INT(9) ) + ( IDENT_INT(6)..IDENT_INT(9) ) + ( IDENT_INT(8)..IDENT_INT(7) ) := + ARR91 + ( IDENT_INT(1)..IDENT_INT(5) ) + ( IDENT_INT(5)..IDENT_INT(7) ) ; + FAILED( "EXCEPTION NOT RAISED - SUBTEST 9" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + -- CHECKING THE VALUES AFTER THE STRING ASSIGNMENT: + + IF ARR92 /= "QUINC" OR + ARR92( IDENT_INT(5)..IDENT_INT(9) ) /= "QUINC" + THEN + FAILED( "ORIGINAL VALUE ALTERED (9)" ); + END IF; + + WHEN OTHERS => + + FAILED( "WRONG EXCEPTION RAISED - SUBTEST 9" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C52104R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104x.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,222 ---- + -- C52104X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS A SPECIAL CASE IN + + -- DIVISION C : NON-NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY + + -- WHICH TREATS ARRAYS OF LENGTH GREATER THAN INTEGER'LAST . + -- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH + -- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE + -- CONSTRAINT_ERROR TO BE RAISED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- RM 07/31/81 + -- SPS 02/07/83 + -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- JRK 06/24/86 FIXED COMMENTS ABOUT NUMERIC_ERROR/CONSTRAINT_ERROR. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X INCOMPATIBILITY + + WITH REPORT; + PROCEDURE C52104X IS + + USE REPORT ; + + BEGIN + + TEST( "C52104X" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE " & + "ASSIGNMENTS, THE LENGTHS MUST MATCH; ALSO " & + "CHECK WHETHER CONSTRAINT_ERROR " & + "OR STORAGE_ERROR ARE RAISED FOR LARGE ARRAYS"); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (12) SLICED ONE-DIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS + -- WERE DEFINED USING THE "BOX" SYMBOL + -- AND FOR WHICH THE COMPONENT TYPE IS NOT 'CHARACTER' . + -- ((ONE-DIMENSIONAL) ARRAYS OF BOOLEANS.) + + CONSTR_ERR: -- THIS BLOCK CATCHES CONSTRAINT_ERROR + -- FOR THE SUBTYPE DECLARATION. + BEGIN + + DCL_ARR: DECLARE -- THIS BLOCK DECLARES THE ARRAY SUBTYPE. + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> ) OF BOOLEAN ; + PRAGMA PACK (TABOX5); + + SUBTYPE TABOX51 IS TABOX5 + (IDENT_INT(-6)..IDENT_INT(INTEGER'LAST-4)); + -- CONSTRAINT_ERROR MAY BE RAISED BY THIS + -- SUBTYPE DECLARATION. + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR TYPE " & + "WITH 'LENGTH = INTEGER'LAST + 3"); + + OBJ_DCL: DECLARE -- THIS BLOCK DECLARES TWO BOOLEAN ARRAYS THAT + -- HAVE INTEGER'LAST + 3 COMPONENTS; + -- STORAGE_ERROR MAY BE RAISED. + ARRX51 : TABOX51 ; + ARRX52 : TABOX5 + (IDENT_INT(-2)..IDENT_INT( INTEGER'LAST)); + + BEGIN + + COMMENT ("NO STORAGE_ERROR OR " & + "CONSTRAINT_ERROR RAISED WHEN ALLOCATING TWO " & + "BIG BOOLEAN ARRAYS"); + + -- INITIALIZATION OF LHS ARRAY: + + NO_EXCP: BEGIN -- NO EXCEPTION SHOULD OCCUR IN THIS BLOCK + FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP + ARRX52( I ) := FALSE ; + END LOOP; + + + -- INITIALIZATION OF RHS ARRAY: + + -- ONLY A SHORT INITIAL SEGMENT IS INITIALIZED, + -- SINCE A COMPLETE INITIALIZATION MIGHT TAKE TOO LONG + -- AND THE EXECUTION MIGHT BE ABORTED BEFORE THE LENGTH + -- COMPARISON OF THE ARRAY ASSIGNMENT IS ATTEMPTED. + + FOR I IN IDENT_INT(-6)..IDENT_INT(5) LOOP + ARRX51( I ) := TRUE ; + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED WHEN " & + "ASSIGNING TO ARRAY COMPONENTS"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + + END NO_EXCP; + + DO_SLICE: BEGIN + -- SLICE ASSIGNMENT: + + ARRX52( IDENT_INT(-1)..IDENT_INT(INTEGER'LAST )) := + ARRX51( + IDENT_INT(-4)..IDENT_INT(INTEGER'LAST-4) ) ; + FAILED( "EXCEPTION NOT RAISED (12)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + + COMMENT ("CONSTRAINT_ERROR RAISED DURING " & + "CHECK FOR SLICE ASSIGNMENT"); + + -- CHECKING THE VALUES AFTER THE SLICE + -- ASSIGNMENT: + + FOR I IN IDENT_INT(-2)..IDENT_INT(9) LOOP + + IF ARRX52( I ) /= FALSE + THEN + FAILED( "LHS ARRAY ALTERED (12A)"); + END IF; + + END LOOP; + + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED DURING CHECK " & + "FOR SLICE ASSIGNMENT"); + + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED DURING SLICE"); + + END DO_SLICE; + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING " & + "TWO PACKED BOOLEAN ARRAYS WITH " & + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " & + "COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + RESULT ; + + END C52104X; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104y.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104y.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c52104y.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c52104y.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- C52104Y.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ATTEMPTED ASSIGNMENTS BETWEEN + -- ARRAYS WITH NON-MATCHING LENGTHS LEAVE THE DESTINATION ARRAY + -- INTACT AND CAUSE CONSTRAINT_ERROR TO BE RAISED. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + -- THIS IS A SPECIAL CASE IN + + -- DIVISION D : NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY + + -- WHICH (THE SPECIAL CASE) TREATS TWO-DIMENSIONAL ARRAYS WHOSE LENGTH + -- ALONG ONE DIMENSION IS GREATER THAN INTEGER'LAST AND WHOSE + -- LENGTH ALONG THE OTHER DIMENSION IS 0 . + -- AN ADDITIONAL OBJECTIVE OF THIS TEST IS TO CHECK WHETHER LENGTH + -- COMPARISONS (AND LENGTH COMPUTATIONS) CAUSE CONSTRAINT_ERROR + -- TO BE RAISED. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- RM 07/31/81 + -- SPS 03/22/83 + -- JBG 06/16/83 + -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE C52104Y IS + + USE REPORT ; + + BEGIN + + TEST( "C52104Y" , "CHECK THAT IN ARRAY ASSIGNMENTS AND IN SLICE" & + " ASSIGNMENTS, THE LENGTHS MUST MATCH" ); + + -- IN THIS TEST WE CAN'T USE AGGREGATE ASSIGNMENT (EXCEPT WHEN + -- THE AGGREGATES ARE STRING LITERALS); THEREFORE: + -- + -- (1) ARRAYS WILL BE INITIALIZED BY INDIVIDUAL ASSIGNMENTS; + -- (2) CAN'T USE NON-NULL CONSTANT ARRAYS. + + + -- WE ASSUME THAT IN AN ARRAY_TYPE_DEFINITION THE INDEX PORTION + -- AND THE COMPONENT_TYPE PORTION ARE FUNCTIONALLY ORTHOGONAL + -- ALSO AT THE IMPLEMENTATION LEVEL, I.E. THAT THE CORRECTNESS + -- OF THE ACCESSING MECHANISM FOR ARRAYS DOES NOT DEPEND ON + -- COMPONENT_TYPE. ACCORDINGLY WE ARE TESTING FOR SOME BUT + -- NOT ALL KINDS OF COMPONENT_TYPE. (COMPONENT_TYPES INCLUDED: + -- INTEGER , CHARACTER , BOOLEAN .) + + + ------------------------------------------------------------------- + + -- (10) MULTIDIMENSIONAL ARRAY OBJECTS WHOSE TYPEMARKS WERE + -- DEFINED USING THE "BOX" COMPOUND SYMBOL. + -- (TWO-DIMENSIONAL ARRAYS OF BOOLEANS.) + + CONSTR_ERR: + BEGIN -- THIS BLOCK CATCHES CONSTRAINT_ERROR IF IT IS + -- RAISED BY THE SUBTYPE DECLARATION. + + DCL_ARR: DECLARE + + TYPE TABOX5 IS ARRAY( INTEGER RANGE <> , + INTEGER RANGE <> ) OF BOOLEAN ; + PRAGMA PACK (TABOX5); + + SUBTYPE TABOX52 IS TABOX5( + IDENT_INT(13)..IDENT_INT( 13 ) , + IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) ); + + BEGIN + + COMMENT ("NO CONSTRAINT_ERROR FOR NON-NULL ARRAY SUBTYPE " & + "WHEN ONE DIMENSION HAS INTEGER'LAST + 3 " & + "COMPONENTS"); + + OBJ_DCL: DECLARE -- THIS BLOCK DECLARES ONE NULL ARRAY AND ONE + -- PACKED BOOLEAN ARRAY WITH INTEGER'LAST + 3 + -- COMPONENTS; STORAGE ERROR MAY BE RAISED. + + ARRX51 : TABOX5( + IDENT_INT(13)..IDENT_INT( 12 ) , + IDENT_INT(-6)..IDENT_INT( INTEGER'LAST-4 ) ); + ARRX52 : TABOX52 ; -- BIG ARRAY HERE. + + BEGIN + + COMMENT ("NO CONSTRAINT OR STORAGE ERROR WHEN ARRAY "& + "WITH INTEGER'LAST+3 COMPONENTS ALLOCATED"); + + -- NULL ARRAY ASSIGNMENT: + + ARRX52 := ARRX51 ; + FAILED( "EXCEPTION NOT RAISED (10)" ); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN " & + "CHECKING LENGTHS FOR ARRAY HAVING " & + "> INTEGER'LAST COMPONENTS ON ONE " & + "DIMENSION"); + + + WHEN OTHERS => + FAILED( "OTHER EXCEPTION RAISED - SUBTEST 10"); + + END OBJ_DCL; + + EXCEPTION + + WHEN STORAGE_ERROR => + COMMENT ("STORAGE_ERROR RAISED WHEN DECLARING ONE "& + "PACKED BOOLEAN ARRAY WITH INTEGER'LAST "& + "+ 3 COMPONENTS"); + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING "& + "ONE PACKED BOOLEAN ARRAY WITH "& + "INTEGER'LAST + 3 COMPONENTS"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + + END DCL_ARR; + + EXCEPTION + + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED WHEN DECLARING AN " & + "ARRAY SUBTYPE WITH INTEGER'LAST + 3 " & + "COMPONENTS"); + + WHEN STORAGE_ERROR => + FAILED ("STORAGE_ERROR RAISED FOR TYPE DECLARATION"); + + WHEN OTHERS => + FAILED( "OTHER EXCEPTION RAISED - 4"); + + END CONSTR_ERR; + + RESULT ; + + END C52104Y; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c53007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c53007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c53007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c53007a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- C53007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONTROL FLOWS CORRECTLY IN SIMPLE NESTED IF_STATEMENTS. + + -- JRK 7/23/80 + -- SPS 3/4/83 + + WITH REPORT; + PROCEDURE C53007A IS + + USE REPORT; + + CI1 : CONSTANT INTEGER := 1; + CI9 : CONSTANT INTEGER := 9; + CBT : CONSTANT BOOLEAN := TRUE; + CBF : CONSTANT BOOLEAN := FALSE; + + VI1 : INTEGER := IDENT_INT(1); + VI9 : INTEGER := IDENT_INT(9); + VBT : BOOLEAN := IDENT_BOOL(TRUE); + VBF : BOOLEAN := IDENT_BOOL(FALSE); + + FLOW_COUNT : INTEGER := 0; + + BEGIN + TEST ("C53007A", "CHECK THAT CONTROL FLOWS CORRECTLY IN SIMPLE " & + "NESTED IF_STATEMENTS"); + + IF VBF THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 1"); + ELSIF CI9 < 20 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + IF VI1 /= 0 AND TRUE THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSE FAILED ("INCORRECT CONTROL FLOW 2"); + END IF; + ELSE FAILED ("INCORRECT CONTROL FLOW 3"); + END IF; + + IF CBF OR ELSE VI9 = 9 THEN -- (TRUE) + IF VI1 + CI9 > 0 OR (CBF AND VBT) THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + END IF; + ELSIF VBF OR VI1 > 10 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 4"); + END IF; + + IF NOT CBT AND THEN NOT VBT AND THEN CI9 < 0 THEN -- (FALSE) + IF FALSE OR NOT TRUE THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 5"); + ELSIF VI1 >= 0 THEN -- (TRUE) + NULL; + ELSE FAILED ("INCORRECT CONTROL FLOW 6"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 7"); + ELSIF (VI1 * CI9 + 3 < 0) OR (VBT AND NOT (CI1 < 0)) THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + IF NOT CBT OR ELSE CI9 + 1 = 0 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 8"); + ELSE FLOW_COUNT := FLOW_COUNT + 1; + IF VI1 * 2 > 0 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSIF TRUE THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 9"); + ELSE NULL; + END IF; + END IF; + ELSIF FALSE AND CBF THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 10"); + ELSE IF VBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 11"); + ELSIF VI1 = 0 THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 12"); + ELSE FAILED ("INCORRECT CONTROL FLOW 13"); + END IF; + END IF; + + IF 3 = 5 OR NOT VBT THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 14"); + IF TRUE AND CBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 15"); + ELSE FAILED ("INCORRECT CONTROL FLOW 16"); + END IF; + ELSIF CBF THEN -- (FALSE) + IF VI9 >= 0 OR FALSE THEN -- (TRUE) + IF VBT THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 17"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 18"); + ELSIF VI1 + CI9 /= 0 THEN -- (TRUE) + FAILED ("INCORRECT CONTROL FLOW 19"); + END IF; + FAILED ("INCORRECT CONTROL FLOW 20"); + ELSE IF VBT AND CI9 - 9 = 0 THEN -- (TRUE) + IF FALSE THEN -- (FALSE) + FAILED ("INCORRECT CONTROL FLOW 21"); + ELSIF NOT VBF AND THEN CI1 > 0 THEN -- (TRUE) + FLOW_COUNT := FLOW_COUNT + 1; + ELSE FAILED ("INCORRECT CONTROL FLOW 22"); + END IF; + FLOW_COUNT := FLOW_COUNT + 1; + ELSIF NOT CBF OR VI1 /= 0 THEN -- (TRUE) + IF VBT THEN -- (TRUE) + NULL; + END IF; + FAILED ("INCORRECT CONTROL FLOW 23"); + ELSE FAILED ("INCORRECT CONTROL FLOW 24"); + END IF; + FLOW_COUNT := FLOW_COUNT + 1; + END IF; + + IF FLOW_COUNT /= 9 THEN + FAILED ("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + END C53007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c540001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c540001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c540001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c540001.a 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,410 ---- + -- C540001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an expression in a case statement may be of a generic formal + -- type. Check that a function call may be used as a case statement + -- expression. Check that a call to a generic formal function may be + -- used as a case statement expression. Check that a call to an inherited + -- function may be used as a case statement expression even if its result + -- type does not correspond to any nameable subtype. + -- + -- TEST DESCRIPTION: + -- This transition test creates examples where expressions in a case + -- statement can be a generic formal object and a call to a generic formal + -- function. This test also creates examples when either a function call, + -- a renaming of a function, or a call to an inherited function is used + -- in the case expressions, the choices of the case statement only need + -- to cover the values in the result of the function. + -- + -- Inspired by B54A08A.ADA. + -- + -- + -- CHANGE HISTORY: + -- 12 Feb 96 SAIC Initial version for ACVC 2.1. + -- + --! + + package C540001_0 is + type Int is range 1 .. 2; + + end C540001_0; + + --==================================================================-- + + with C540001_0; + package C540001_1 is + type Enum_Type is (Eh, Bee, Sea, Dee); -- Range of Enum_Type'Val is 0..3. + type Mixed is ('A','B', 'C', None); + subtype Small_Num is Natural range 0 .. 10; + type Small_Int is range 1 .. 2; + function Get_Small_Int (P : Boolean) return Small_Int; + procedure Assign_Mixed (P1 : in Boolean; + P2 : out Mixed); + + type Tagged_Type is tagged + record + C1 : Enum_Type; + end record; + function Get_Tagged (P : Tagged_Type) return C540001_0.Int; + + end C540001_1; + + --==================================================================-- + + package body C540001_1 is + function Get_Small_Int (P : Boolean) return Small_Int is + begin + if P then + return Small_Int'First; + else + return Small_Int'Last; + end if; + end Get_Small_Int; + + --------------------------------------------------------------------- + procedure Assign_Mixed (P1 : in Boolean; + P2 : out Mixed) is + begin + case Get_Small_Int (P1) is -- Function call as expression + when 1 => P2 := None; -- in case statement. + when 2 => P2 := 'A'; + -- No others needed. + end case; + + end Assign_Mixed; + + --------------------------------------------------------------------- + function Get_Tagged (P : Tagged_Type) return C540001_0.Int is + begin + return C540001_0.Int'Last; + end Get_Tagged; + + end C540001_1; + + --==================================================================-- + + generic + + type Formal_Scalar is range <>; + + FSO : Formal_Scalar; + + package C540001_2 is + + type Enum is (Alpha, Beta, Theta); + + procedure Assign_Enum (ET : out Enum); + + end C540001_2; + + --==================================================================-- + + package body C540001_2 is + + procedure Assign_Enum (ET : out Enum) is + begin + case FSO is -- Type of expression in case + when 1 => ET := Alpha; -- statement is generic formal type. + when 2 => ET := Beta; + when others => ET := Theta; + end case; + + end Assign_Enum; + + end C540001_2; + + --==================================================================-- + + with C540001_1; + generic + + type Formal_Enum_Type is new C540001_1.Enum_Type; + + with function Formal_Func (P : C540001_1.Small_Num) + return Formal_Enum_Type is <>; + + function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type; + + --==================================================================-- + + function C540001_3 (P : C540001_1.Small_Num) return Formal_Enum_Type is + + begin + return Formal_Func (P); + end C540001_3; + + --==================================================================-- + + with C540001_1; + generic + + type Formal_Int_Type is new C540001_1.Small_Int; + + with function Formal_Func return Formal_Int_Type; + + package C540001_4 is + + procedure Gen_Assign_Mixed (P : out C540001_1.Mixed); + + end C540001_4; + + --==================================================================-- + + package body C540001_4 is + + procedure Gen_Assign_Mixed (P : out C540001_1.Mixed) is + begin + case Formal_Func is -- Case expression is + when 1 => P := C540001_1.'A'; -- generic function. + when others => P := C540001_1.'B'; + end case; + + end Gen_Assign_Mixed; + + end C540001_4; + + --==================================================================-- + + with C540001_1; + package C540001_5 is + type New_Tagged is new C540001_1.Tagged_Type with + record + C2 : C540001_1.Mixed; + end record; + + -- Inherits Get_Tagged (P : New_Tagged) return C540001_0.Int; + -- Note that the return type of the inherited function is not + -- nameable here. + + procedure Assign_Tagged (P1 : in New_Tagged; + P2 : out New_Tagged); + + end C540001_5; + + --==================================================================-- + + package body C540001_5 is + + procedure Assign_Tagged (P1 : in New_Tagged; + P2 : out New_Tagged) is + begin + case Get_Tagged (P1) is -- Case expression is + -- inherited function. + when 2 => P2 := (C540001_1.Bee, 'B'); + when others => P2 := (C540001_1.Sea, C540001_1.None); + end case; + + end Assign_Tagged; + + end C540001_5; + + --==================================================================-- + + with Report; + with C540001_1; + with C540001_2; + with C540001_3; + with C540001_4; + with C540001_5; + + procedure C540001 is + type Value is range 1 .. 5; + + begin + Report.Test ("C540001", "Check that an expression in a case statement " & + "may be of a generic formal type. Check that a function " & + "call may be used as a case statement expression. Check " & + "that a call to a generic formal function may be used as " & + "a case statement expression. Check that a call to an " & + "inherited function may be used as a case statement " & + "expression"); + + Generic_Formal_Object_Subtest: + begin + declare + One : Value := 1; + package One_Pck is new C540001_2 (Value, One); + use One_Pck; + EObj : Enum; + begin + Assign_Enum (EObj); + if EObj /= Alpha then + Report.Failed ("Incorrect result for value of one in generic" & + "formal object subtest"); + end if; + end; + + declare + Five : Value := 5; + package Five_Pck is new C540001_2 (Value, Five); + use Five_Pck; + EObj : Enum; + begin + Assign_Enum (EObj); + if EObj /= Theta then + Report.Failed ("Incorrect result for value of five in generic" & + "formal object subtest"); + end if; + end; + + end Generic_Formal_Object_Subtest; + + Instantiated_Generic_Function_Subtest: + declare + type New_Enum_Type is new C540001_1.Enum_Type; + + function Get_Enum_Value (P : C540001_1.Small_Num) + return New_Enum_Type is + begin + return New_Enum_Type'Val (P); + end Get_Enum_Value; + + function Val_Func is new C540001_3 + (Formal_Enum_Type => New_Enum_Type, + Formal_Func => Get_Enum_Value); + + procedure Assign_Num (P : in out C540001_1.Small_Num) is + begin + case Val_Func (P) is -- Case expression is + -- instantiated generic + when New_Enum_Type (C540001_1.Eh) | -- function. + New_Enum_Type (C540001_1.Sea) => P := 4; + when New_Enum_Type (C540001_1.Bee) => P := 7; + when others => P := 9; + end case; + + end Assign_Num; + + SNObj : C540001_1.Small_Num; + + begin + SNObj := 0; + Assign_Num (SNObj); + if SNObj /= 4 then + Report.Failed ("Incorrect result for value of zero in call to " & + "generic function subtest"); + end if; + + SNObj := 3; + Assign_Num (SNObj); + if SNObj /= 9 then + Report.Failed ("Incorrect result for value of three in call to " & + "generic function subtest"); + end if; + + end Instantiated_Generic_Function_Subtest; + + -- When a function call, a renaming of a function, or a call to an + -- inherited function is used in the case expressions, the choices + -- of the case statement only need to cover the values in the result + -- of the function. + + Function_Call_Subtest: + declare + MObj : C540001_1.Mixed := 'B'; + BObj : Boolean := True; + use type C540001_1.Mixed; + begin + C540001_1.Assign_Mixed (BObj, MObj); + if MObj /= C540001_1.None then + Report.Failed ("Incorrect result for value of true in function" & + "call subtest"); + end if; + + BObj := False; + C540001_1.Assign_Mixed (BObj, MObj); + if MObj /= C540001_1.'A' then + Report.Failed ("Incorrect result for value of false in function" & + "call subtest"); + end if; + + end Function_Call_Subtest; + + Function_Renaming_Subtest: + declare + use C540001_1; + function Rename_Get_Small_Int (P : Boolean) + return Small_Int renames Get_Small_Int; + MObj : Mixed := None; + BObj : Boolean := False; + begin + case Rename_Get_Small_Int (BObj) is + when 1 => MObj := 'A'; + when 2 => MObj := 'B'; + -- No others needed. + end case; + + if MObj /= 'B' then + Report.Failed ("Incorrect result for value of false in function" & + "renaming subtest"); + end if; + + end Function_Renaming_Subtest; + + Call_To_Generic_Formal_Function_Subtest: + declare + type New_Small_Int is new C540001_1.Small_Int; + + function Get_Int_Value return New_Small_Int is + begin + return New_Small_Int'First; + end Get_Int_Value; + + package Int_Pck is new C540001_4 + (Formal_Int_Type => New_Small_Int, + Formal_Func => Get_Int_Value); + + use type C540001_1.Mixed; + MObj : C540001_1.Mixed := C540001_1.None; + + begin + Int_Pck.Gen_Assign_Mixed (MObj); + if MObj /= C540001_1.'A' then + Report.Failed ("Incorrect result in call to generic formal " & + "function subtest"); + end if; + + end Call_To_Generic_Formal_Function_Subtest; + + Call_To_Inherited_Function_Subtest: + declare + NTObj1 : C540001_5.New_Tagged := (C1 => C540001_1.Eh, + C2 => C540001_1.'A'); + NTObj2 : C540001_5.New_Tagged := (C540001_1.Dee, C540001_1.'C'); + use type C540001_1.Mixed; + use type C540001_1.Enum_Type; + begin + C540001_5.Assign_Tagged (NTObj1, NTObj2); + if NTObj2.C1 /= C540001_1.Bee or + NTObj2.C2 /= C540001_1.'B' then + Report.Failed ("Incorrect result in inherited function subtest"); + end if; + + end Call_To_Inherited_Function_Subtest; + + Report.Result; + + end C540001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a03a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C54A03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BOOLEAN, CHARACTER, USER-DEFINED ENUMERATED, INTEGER, + -- AND DERIVED TYPES MAY BE USED IN A CASE EXPRESSION. + + -- DAT 1/22/81 + -- PWB 4/22/86 RENAME TO -AB; + -- REMOVE EXTRANEOUS FROM BEGINNING OF LINE 45. + + WITH REPORT; + PROCEDURE C54A03A IS + + USE REPORT; + + TYPE D_INT IS NEW INTEGER RANGE 1 .. 2; + TYPE D_BOOL IS NEW BOOLEAN; + TYPE D_BOOL_2 IS NEW D_BOOL; + TYPE M_ENUM IS (FIRST, SECOND, THIRD); + TYPE M_CHAR IS NEW CHARACTER RANGE ASCII.NUL .. 'Z'; + TYPE M_ENUM_2 IS NEW M_ENUM; + + I : INTEGER := 1; + D_I : D_INT := 1; + B : BOOLEAN := TRUE; + D_B : D_BOOL := TRUE; + D_B_2 : D_BOOL_2 := FALSE; + E : M_ENUM := THIRD; + C : CHARACTER := 'A'; + M_C : M_CHAR := 'Z'; + D_E : M_ENUM_2 := SECOND; + + BEGIN + TEST ("C54A03A", "CHECK VARIOUS DISCRETE TYPES " & + "IN CASE EXPRESSIONS"); + + CASE I IS + WHEN 2 | 3 => FAILED ("WRONG CASE 1"); + WHEN 1 => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 2"); + END CASE; + + CASE D_I IS + WHEN 1 => NULL; + WHEN 2 => FAILED ("WRONG CASE 2A"); + END CASE; + + CASE B IS + WHEN TRUE => NULL; + WHEN FALSE => FAILED ("WRONG CASE 3"); + END CASE; + + CASE D_B IS + WHEN TRUE => NULL; + WHEN FALSE => FAILED ("WRONG CASE 4"); + END CASE; + + CASE D_B_2 IS + WHEN FALSE => NULL; + WHEN TRUE => FAILED ("WRONG CASE 5"); + END CASE; + + CASE E IS + WHEN SECOND | FIRST => FAILED ("WRONG CASE 6"); + WHEN THIRD => NULL; + END CASE; + + CASE C IS + WHEN 'A' .. 'Z' => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 7"); + END CASE; + + CASE M_C IS + WHEN 'Z' => NULL; + WHEN OTHERS => FAILED ("WRONG CASE 8"); + END CASE; + + CASE D_E IS + WHEN FIRST => FAILED ("WRONG CASE 9"); + WHEN SECOND | THIRD => NULL; + END CASE; + + RESULT; + END C54A03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a04a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C54A04A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PRIVATE (DISCRETE) TYPES MAY BE USED IN CASE EXPRESSIONS + -- WITHIN THE DEFINING PACKAGE. + + -- DAT 1/29/81 + + WITH REPORT; + PROCEDURE C54A04A IS + + USE REPORT; + + PACKAGE P IS + + TYPE T IS PRIVATE; + TYPE LT IS LIMITED PRIVATE; + + PRIVATE + + TYPE T IS ('Z', X); + TYPE LT IS NEW INTEGER RANGE 0 .. 1; + + END P; + + VT : P.T; + VLT : P.LT; + + PACKAGE BODY P IS + + BEGIN + TEST ("C54A04A", "PRIVATE DISCRETE TYPES MAY APPEAR IN " & + "CASE EXPRESSIONS IN PACKAGE BODY"); + + VT := 'Z'; + VLT := LT (IDENT_INT (1)); + + CASE VT IS + WHEN X => FAILED ("WRONG CASE 1"); + WHEN 'Z' => NULL; -- OK + END CASE; + + CASE VLT IS + WHEN 1 => NULL; -- OK + WHEN 0 => FAILED ("WRONG CASE 2"); + END CASE; + END P; + + BEGIN + + -- TEST CALLED FROM PACKAGE BODY, ALREADY ELABORATED. + + RESULT; + END C54A04A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a07a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C54A07A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A VARIABLE USED AS A CASE EXPRESSION IS NOT CONSIDERED + -- LOCAL TO THE CASE STATEMENT. IN PARTICULAR, CHECK THAT THE + -- VARIABLE CAN BE ASSIGNED A NEW VALUE, AND THE ASSIGNMENT TAKES + -- EFFECT IMMEDIATELY (I.E. THE CASE STATEMENT DOES NOT USE A + -- COPY OF THE CASE EXPRESSION). + + + -- RM 01/21/80 + + + WITH REPORT ; + PROCEDURE C54A07A IS + + USE REPORT ; + + BEGIN + + TEST("C54A07A" , "CHECK THAT A VARIABLE USED AS A CASE" & + " EXPRESSION IS NOT CONSIDERED LOCAL TO" & + " THE CASE STATEMENT" ); + + DECLARE -- A + BEGIN + + B1 : DECLARE + + TYPE VARIANT_REC( DISCR : BOOLEAN := TRUE ) IS + RECORD + A , B : INTEGER ; + CASE DISCR IS + WHEN TRUE => P , Q : CHARACTER ; + WHEN FALSE => X , Y : INTEGER ; + END CASE; + END RECORD ; + + V : VARIANT_REC := ( TRUE , 1 , 2 , + IDENT_CHAR( 'P' ) , + IDENT_CHAR( 'Q' ) ); + + BEGIN + + IF EQUAL( 3 , 7 ) THEN V := ( FALSE , 3 , 4 , 7 , 8 ); + END IF; + + CASE V.DISCR IS + + WHEN TRUE => + + IF ( V.P /= 'P' OR + V.Q /= 'Q' ) + THEN FAILED( "WRONG VALUES - 1" ); + END IF; + + B1.V := ( FALSE , 3 , 4 , + IDENT_INT( 5 ) , + IDENT_INT( 6 ) ); + + IF V.DISCR THEN FAILED( "WRONG DISCR." ); + END IF; + + IF ( V.X /= 5 OR + V.Y /= 6 ) + THEN FAILED( "WRONG VALUES - 2" ); + END IF; + + WHEN FALSE => + FAILED( "WRONG BRANCH IN CASE STMT." ); + + END CASE; + + EXCEPTION + + WHEN OTHERS => FAILED("EXCEPTION RAISED"); + + END B1 ; + + EXCEPTION + + WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECLARATIONS"); + + END ; -- A + + + RESULT ; + + + END C54A07A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C54A13A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A CASE EXPRESSION IS A DECLARED VARIABLE OR + -- CONSTANT, OR ONE OF THESE IN PARENTHESES, AND ITS SUBTYPE IS + -- NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY + -- APPEAR AS A CHOICE. + + -- HISTORY: + -- BCB 02/29/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C54A13A IS + + SUBTYPE INT IS INTEGER RANGE IDENT_INT(5) .. IDENT_INT(10); + + A : INT := 8; + B : CONSTANT INT := 7; + C, D : INTEGER; + + FUNCTION IDENT(X : INT) RETURN INT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN + TEST ("C54A13A", "CHECK THAT IF A CASE EXPRESSION IS A DECLARED " & + "VARIABLE OR CONSTANT, OR ONE OF THESE IN " & + "PARENTHESES, AND ITS SUBTYPE IS NONSTATIC, " & + "THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE " & + "MAY APPEAR AS A CHOICE"); + + CASE A IS + WHEN 0 => C := IDENT_INT(5); + WHEN 8 => C := IDENT_INT(10); + WHEN 30000 => C := IDENT_INT(15); + WHEN -30000 => C := IDENT_INT(20); + WHEN OTHERS => C := IDENT_INT(25); + END CASE; + + IF C /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 1"); + END IF; + + CASE B IS + WHEN 0 => D := IDENT_INT(5); + WHEN 100 => D := IDENT_INT(10); + WHEN 30000 => D := IDENT_INT(15); + WHEN -30000 => D := IDENT_INT(20); + WHEN OTHERS => D := IDENT_INT(25); + END CASE; + + IF D /= IDENT_INT(25) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 2"); + END IF; + + CASE (A) IS + WHEN 0 => C := IDENT_INT(5); + WHEN 8 => C := IDENT_INT(10); + WHEN 30000 => C := IDENT_INT(15); + WHEN -30000 => C := IDENT_INT(20); + WHEN OTHERS => C := IDENT_INT(25); + END CASE; + + IF C /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 3"); + END IF; + + CASE (B) IS + WHEN 0 => D := IDENT_INT(5); + WHEN 110 => D := IDENT_INT(10); + WHEN 30000 => D := IDENT_INT(15); + WHEN -30000 => D := IDENT_INT(20); + WHEN OTHERS => D := IDENT_INT(25); + END CASE; + + IF D /= IDENT_INT(25) THEN + FAILED ("IMPROPER VALUE FOR CASE EXPRESSION - 4"); + END IF; + + RESULT; + END C54A13A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C54A13B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A CASE EXPRESSION IS A GENERIC "IN" OR "IN OUT" + -- PARAMETER WITH A NON-STATIC SUBTYPE OR ONE OF THESE IN + -- PARENTHESES, THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY + -- APPEAR AS A CHOICE. + + -- HISTORY: + -- BCB 07/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C54A13B IS + + L : INTEGER := IDENT_INT(1); + R : INTEGER := IDENT_INT(100); + + SUBTYPE INT IS INTEGER RANGE L .. R; + + GENERIC + IN_PAR : IN INT; + IN_OUT_PAR : IN OUT INT; + PROCEDURE GEN_PROC (I : IN OUT INTEGER); + + IN_VAR : INT := IDENT_INT (10); + IN_OUT_VAR : INT := IDENT_INT (100); + CHECK_VAR : INT := IDENT_INT (1); + + PROCEDURE GEN_PROC (I : IN OUT INTEGER) IS + BEGIN + CASE IN_PAR IS + WHEN 0 => I := I + IDENT_INT (2); + WHEN 10 => I := I + IDENT_INT (1); + WHEN -3000 => I := I + IDENT_INT (3); + WHEN OTHERS => I := I + IDENT_INT (4); + END CASE; + + CASE IN_OUT_PAR IS + WHEN 0 => IN_OUT_PAR := IDENT_INT (0); + WHEN 100 => IN_OUT_PAR := IDENT_INT (50); + WHEN -3000 => IN_OUT_PAR := IDENT_INT (-3000); + WHEN OTHERS => IN_OUT_PAR := IDENT_INT (5); + END CASE; + + CASE (IN_PAR) IS + WHEN 0 => I := I + IDENT_INT (2); + WHEN 10 => I := I + IDENT_INT (1); + WHEN -3000 => I := I + IDENT_INT (3); + WHEN OTHERS => I := I + IDENT_INT (4); + END CASE; + + CASE (IN_OUT_PAR) IS + WHEN 0 => IN_OUT_PAR := IDENT_INT (200); + WHEN 50 => IN_OUT_PAR := IDENT_INT (25); + WHEN -3000 => IN_OUT_PAR := IDENT_INT (300); + WHEN OTHERS => IN_OUT_PAR := IDENT_INT (400); + END CASE; + + END GEN_PROC; + + PROCEDURE P IS NEW GEN_PROC (IN_VAR, IN_OUT_VAR); + + BEGIN + TEST ("C54A13B", "CHECK THAT IF A CASE EXPRESSION IS A " & + "GENERIC 'IN' OR 'IN OUT' PARAMETER WITH A " & + "NON-STATIC SUBTYPE OR ONE OF " & + "THESE IN PARENTHESES, THEN ANY VALUE OF " & + "THE EXPRESSION'S BASE TYPE MAY APPEAR AS " & + "A CHOICE"); + + P (CHECK_VAR); + + IF NOT EQUAL (CHECK_VAR, IDENT_INT(3)) THEN + FAILED ("INCORRECT CHOICES MADE FOR IN PARAMETER IN CASE"); + END IF; + + IF NOT EQUAL (IN_OUT_VAR, IDENT_INT(25)) THEN + FAILED ("INCORRECT CHOICESMADE FOR IN OUT PARAMETER IN CASE"); + END IF; + + RESULT; + END C54A13B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C54A13C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A CASE EXPRESSION IS A QUALIFIED EXPRESSION, A + -- TYPE CONVERSION, OR ONE OF THESE IN PARENTHESES, AND ITS + -- SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE EXPRESSION'S + -- BASE TYPE MAY APPEAR AS A CHOICE. + + -- HISTORY: + -- BCB 07/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C54A13C IS + + L : INTEGER := 1; + R : INTEGER := 100; + + SUBTYPE INT IS INTEGER RANGE L .. R; + + A : INT := 50; + + B : INTEGER := 50; + + C : INTEGER; + + BEGIN + TEST ("C54A13C", "CHECK THAT IF A CASE EXPRESSION IS A " & + "QUALIFIED EXPRESSION, A TYPE CONVERSION, " & + "OR ONE OF THESE IN PARENTHESES, AND ITS " & + "SUBTYPE IS NONSTATIC, THEN ANY VALUE OF THE " & + "EXPRESSION'S BASE TYPE MAY APPEAR AS A CHOICE"); + + CASE INT'(A) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " & + "CASE"); + END IF; + + CASE INT(B) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN CASE"); + END IF; + + CASE (INT'(A)) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR QUALIFIED EXPRESSION IN " & + "PARENTHESES IN CASE"); + END IF; + + CASE (INT(B)) IS + WHEN 0 => C := IDENT_INT (5); + WHEN 50 => C := IDENT_INT (10); + WHEN -3000 => C := IDENT_INT (15); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF C /= IDENT_INT (10) THEN + FAILED ("INCORRECT CHOICE MADE FOR TYPE CONVERSION IN " & + "PARENTHESES IN CASE"); + END IF; + + RESULT; + END C54A13C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a13d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- C54A13D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A CASE EXPRESSION IS A FUNCTION INVOCATION, + -- ATTRIBUTE, STATIC EXPRESSION, OR ONE OF THESE IN PARENTHESES, + -- THEN ANY VALUE OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS A + -- CHOICE. + + -- HISTORY: + -- BCB 07/19/88 CREATED ORIGINAL TEST. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + -- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBLE ALTERNATIVE IN FIRST CASE. + + WITH REPORT; USE REPORT; + + PROCEDURE C54A13D IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + CONS : CONSTANT INT := 0; + + C : INT; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + + SUBTYPE SUBENUM IS ENUM RANGE THREE .. FOUR; + + FUNCTION FUNC RETURN INT IS + BEGIN + RETURN 0; + END FUNC; + + BEGIN + TEST ("C54A13D", "CHECK THAT IF A CASE EXPRESSION IS A FUNCTION " & + "INVOCATION, ATTRIBUTE, STATIC EXPRESSION, OR " & + "ONE OF THESE IN PARENTHESES, THEN ANY VALUE " & + "OF THE EXPRESSION'S BASE TYPE MAY APPEAR AS " & + "A CHOICE"); + + CASE FUNC IS + WHEN 0 => C := IDENT_INT (5); + WHEN 100 => C := IDENT_INT (10); + WHEN OTHERS => C := IDENT_INT (20); + END CASE; + + IF NOT EQUAL (C,5) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "FUNCTION INVOCATION - 1"); + END IF; + + CASE (FUNC) IS + WHEN 0 => C := IDENT_INT (25); + WHEN 100 => C := IDENT_INT (50); + WHEN -3000 => C := IDENT_INT (75); + WHEN OTHERS => C := IDENT_INT (90); + END CASE; + + IF NOT EQUAL (C,25) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "FUNCTION INVOCATION - 2"); + END IF; + + CASE SUBENUM'FIRST IS + WHEN ONE => C := IDENT_INT (100); + WHEN TWO => C := IDENT_INT (99); + WHEN THREE => C := IDENT_INT (98); + WHEN FOUR => C := IDENT_INT (97); + WHEN FIVE => C := IDENT_INT (96); + WHEN SIX => C := IDENT_INT (95); + END CASE; + + IF NOT EQUAL (C,98) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " & + "ATTRIBUTE - 1"); + END IF; + + CASE (SUBENUM'FIRST) IS + WHEN ONE => C := IDENT_INT (90); + WHEN TWO => C := IDENT_INT (89); + WHEN THREE => C := IDENT_INT (88); + WHEN FOUR => C := IDENT_INT (87); + WHEN FIVE => C := IDENT_INT (86); + WHEN SIX => C := IDENT_INT (85); + END CASE; + + IF NOT EQUAL (C,88) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS AN " & + "ATTRIBUTE - 2"); + END IF; + + CASE CONS * 1 IS + WHEN 0 => C := IDENT_INT (1); + WHEN 100 => C := IDENT_INT (2); + WHEN -3000 => C := IDENT_INT (3); + WHEN OTHERS => C := IDENT_INT (4); + END CASE; + + IF NOT EQUAL (C,1) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "STATIC EXPRESSION - 1"); + END IF; + + CASE (CONS * 1) IS + WHEN 0 => C := IDENT_INT (10); + WHEN 100 => C := IDENT_INT (20); + WHEN -3000 => C := IDENT_INT (30); + WHEN OTHERS => C := IDENT_INT (40); + END CASE; + + IF NOT EQUAL (C,10) THEN + FAILED ("IMPROPER CHOICE FOR CASE EXPRESSION WHICH IS A " & + "STATIC EXPRESSION - 2"); + END IF; + + RESULT; + END C54A13D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a22a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,68 ---- + -- C54A22A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK ALL FORMS OF CHOICE IN CASE CHOICES. + + -- DAT 1/29/81 + -- SPS 1/21/83 + + WITH REPORT; + PROCEDURE C54A22A IS + + USE REPORT; + + TYPE T IS RANGE 1 .. 10; + C5 : CONSTANT T := 5; + SUBTYPE S1 IS T RANGE 1 .. 5; + SUBTYPE S2 IS T RANGE C5 + 1 .. 7; + SUBTYPE SN IS T RANGE C5 + 4 .. C5 - 4 + 7; -- NULL RANGE. + SUBTYPE S10 IS T RANGE C5 + 5 .. T'LAST; + + BEGIN + TEST ("C54A22A", "CHECK ALL FORMS OF CASE CHOICES"); + + CASE T'(C5 + 3) IS + WHEN SN -- 9..8 + | S1 RANGE 1 .. 0 -- 1..0 + | S2 RANGE C5 + 2 .. C5 + 1 -- 7..6 + | 3 .. 2 -- 3..2 + => FAILED ("WRONG CASE 1"); + + WHEN S1 RANGE 4 .. C5 -- 4..5 + | S1 RANGE C5 - 4 .. C5 / 2 -- 1..2 + | 3 .. 1 + C5 MOD 3 -- 3..3 + | SN -- 9..8 + | S1 RANGE 5 .. C5 - 1 -- 5..4 + | 6 .. 7 -- 6..7 + | S10 -- 10..10 + | 9 -- 9 + | S10 RANGE 10 .. 9 => -- 10..9 + FAILED ("WRONG CASE 2"); + + WHEN C5 + C5 - 2 .. 8 -- 8 + => NULL; + END CASE; + + RESULT; + END C54A22A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a23a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + -- C54A23A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CASE CHOICES MAY BE CONSTANT NAMES + + -- DAT 3/18/81 + -- SPS 4/7/82 + + WITH REPORT; USE REPORT; + + PROCEDURE C54A23A IS + + C1 : CONSTANT INTEGER := 1; + C2 : CONSTANT INTEGER := 2; + C3 : CONSTANT INTEGER := 3; + + BEGIN + TEST ("C54A23A", "CASE CHOICES MAY BE CONSTANTS"); + + CASE IDENT_INT (C3) IS + WHEN C1 | C2 + => FAILED ("WRONG CASE CHOICE 1"); + WHEN 3 => NULL; + WHEN OTHERS => FAILED ("WRONG CASE CHOICE 2"); + END CASE; + + RESULT; + END C54A23A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a24a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C54A24A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NULL SUBRANGE CHOICES MAY OCCUR IN CASE STATEMENT, WITH + -- OUT-OF-BOUNDS RANGE BOUNDS, AND WHERE VACUOUS CHOICES ARE NULL. + -- CHECK THAT AN UNNEEDED OTHERS CHOICE IS PERMITTED. + + -- DAT 1/29/81 + -- JBG 8/21/83 + + WITH REPORT; + PROCEDURE C54A24A IS + + USE REPORT; + + TYPE T IS RANGE 1 .. 1010; + SUBTYPE ST IS T RANGE 5 .. 7; + + V : ST := 6; + + BEGIN + TEST ("C54A24A", "CHECK NULL CASE SUBRANGE CHOICES, WITH " & + "OUTRAGEOUS BOUNDS"); + + CASE V IS + WHEN -1000 .. -1010 => NULL; + WHEN T RANGE -5 .. -6 => NULL; + WHEN 12 .. 11 | ST RANGE 1000 .. 99 => NULL; + WHEN ST RANGE -99 .. -999 => NULL; + WHEN ST RANGE 6 .. 6 => V := V - 1; + WHEN T RANGE ST'BASE'LAST .. ST'BASE'FIRST => NULL; + WHEN 5 | 7 => NULL; + WHEN ST RANGE T'BASE'LAST .. T'BASE'FIRST => NULL; + WHEN T'BASE'LAST .. T'BASE'FIRST => NULL; + WHEN OTHERS => V := V + 1; + END CASE; + IF V /= 5 THEN + FAILED ("IMPROPER CASE EXECUTION"); + END IF; + + RESULT; + END C54A24A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a24b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- C54A24B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NULL SUBTYPE RANGES ARE ACCEPTABLE CASE CHOICES, + -- WHERE THE BOUNDS ARE BOTH OUT OF THE SUBRANGE'S RANGE, AND + -- WHERE VACUOUS CHOICES HAVE NON-NULL STATEMENT SEQUENCES. + -- CHECK THAT AN UNNEEDED OTHERS CLAUSE IS PERMITTED. + + -- HISTORY: + -- DAT 01/29/81 CREATED ORIGINAL TEST. + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; + PROCEDURE C54A24B IS + + USE REPORT; + + TYPE C IS NEW CHARACTER RANGE 'A' .. 'D'; + X : C := 'B'; + + BEGIN + TEST ("C54A24B", "NULL CASE CHOICE SUBRANGES WITH VALUES " & + "OUTSIDE SUBRANGE"); + + CASE X IS + WHEN C RANGE C'BASE'LAST .. C'BASE'FIRST + | C RANGE 'Z' .. ' ' => X := 'A'; + WHEN C => NULL; + WHEN OTHERS => X := 'C'; + END CASE; + IF X /= 'B' THEN + FAILED ("WRONG CASE EXECUTION"); + END IF; + + RESULT; + END C54A24B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- C54A42A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT MAY HANDLE A LARGE NUMBER OF + -- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES + -- AND THAT EACH TIME THE APPROPRIATE ALTERNATIVE IS EXECUTED. + + -- (OPTIMIZATION TEST.) + + + -- RM 03/24/81 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + + WITH REPORT; + PROCEDURE C54A42A IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42A" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A LARGE NUMBER OF POTENTIAL VALUES GROUPED" & + " INTO A SMALL NUMBER OF ALTERNATIVES" ); + + DECLARE + + STATCON : CONSTANT CHARACTER := 'B' ; + STATVAR : CHARACTER := 'Q' ; + DYNCON : CONSTANT CHARACTER := IDENT_CHAR( 'Y' ); + DYNVAR : CHARACTER := IDENT_CHAR( 'Z' ); + + BEGIN + + CASE CHARACTER'('A') IS + WHEN ASCII.NUL .. 'A' => NULL ; + WHEN 'B' => FAILED( "WRONG ALTERN. A2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. A3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. A4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. A5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. A6" ); + END CASE; + + CASE STATCON IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. B1" ); + WHEN 'B' => NULL ; + WHEN 'P' => FAILED( "WRONG ALTERN. B3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. B4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. B5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. B6" ); + END CASE; + + CASE STATVAR IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. C1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. C2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. C3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. C4" ); + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. C5" ); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNCON IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. D1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. D2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. D3" ); + WHEN 'Y' => NULL ; + WHEN 'Z' .. ASCII.DEL => FAILED( "WRONG ALTERN. D5" ); + WHEN OTHERS => FAILED( "WRONG ALTERN. D6" ); + END CASE; + + CASE DYNVAR IS + WHEN ASCII.NUL .. 'A' => FAILED( "WRONG ALTERN. E1" ); + WHEN 'B' => FAILED( "WRONG ALTERN. E2" ); + WHEN 'P' => FAILED( "WRONG ALTERN. E3" ); + WHEN 'Y' => FAILED( "WRONG ALTERN. E4" ); + WHEN 'Z' .. ASCII.DEL => NULL ; + WHEN OTHERS => FAILED( "WRONG ALTERN. E6" ); + END CASE; + + END ; + + + DECLARE + + NUMBER : CONSTANT := -100 ; + LITEXPR : CONSTANT := 0 * NUMBER + 16 ; + STATCON : CONSTANT INTEGER := +100 ; + DYNVAR : INTEGER := IDENT_INT( 102 ) ; + DYNCON : CONSTANT INTEGER := IDENT_INT( 17 ) ; + + BEGIN + + CASE INTEGER'(-102) IS + WHEN INTEGER'FIRST..-101 => NULL ; + WHEN -100 => FAILED("WRONG ALTERN. F2"); + WHEN 17 => FAILED("WRONG ALTERN. F2"); + WHEN 100 => FAILED("WRONG ALTERN. F4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. F5"); + WHEN OTHERS => FAILED("WRONG ALTERN. F6"); + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. G1"); + WHEN -100 => NULL ; + WHEN 17 => FAILED("WRONG ALTERN. G3"); + WHEN 100 => FAILED("WRONG ALTERN. G4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. G5"); + WHEN OTHERS => FAILED("WRONG ALTERN. G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. H1"); + WHEN -100 => FAILED("WRONG ALTERN. H2"); + WHEN 17 => FAILED("WRONG ALTERN. H3"); + WHEN 100 => FAILED("WRONG ALTERN. H4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. H5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATCON IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. I1"); + WHEN -100 => FAILED("WRONG ALTERN. I2"); + WHEN 17 => FAILED("WRONG ALTERN. I3"); + WHEN 100 => NULL ; + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. I5"); + WHEN OTHERS => FAILED("WRONG ALTERN. I6"); + END CASE; + + CASE DYNVAR IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. J1"); + WHEN -100 => FAILED("WRONG ALTERN. J2"); + WHEN 17 => FAILED("WRONG ALTERN. J3"); + WHEN 100 => FAILED("WRONG ALTERN. J4"); + WHEN 101..INTEGER'LAST => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERN. J6"); + END CASE; + + CASE DYNCON IS + WHEN INTEGER'FIRST..-101 => FAILED("WRONG ALTERN. K1"); + WHEN -100 => FAILED("WRONG ALTERN. K2"); + WHEN 17 => NULL ; + WHEN 100 => FAILED("WRONG ALTERN. K4"); + WHEN 101..INTEGER'LAST => FAILED("WRONG ALTERN. K5"); + WHEN OTHERS => FAILED("WRONG ALTERN. K6"); + END CASE; + END ; + + + RESULT ; + + + END C54A42A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- C54A42B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF + -- POTENTIAL VALUES GROUPED INTO A SMALL NUMBER OF ALTERNATIVES. + + -- (OPTIMIZATION TEST -- JUMP TABLE.) + + + -- RM 03/26/81 + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + + WITH REPORT; + PROCEDURE C54A42B IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42B" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SMALL NUMBER OF POTENTIAL VALUES GROUPED" & + " INTO A SMALL NUMBER OF ALTERNATIVES" ); + + DECLARE + + STATCON : CONSTANT CHARACTER RANGE 'A'..'K' := 'J' ; + STATVAR : CHARACTER RANGE 'A'..'K' := 'A' ; + DYNCON : CONSTANT CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('K'); + DYNVAR : CHARACTER RANGE 'A'..'K' :=IDENT_CHAR('G'); + + BEGIN + + CASE STATVAR IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE A1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE A2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE A3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE A4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE A5" ); + WHEN OTHERS => NULL ; + END CASE; + + CASE CHARACTER'('B') IS + WHEN 'B' | 'E' => NULL ; + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE B2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE B3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE B4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE B5" ); + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE B6" ); + END CASE; + + CASE DYNVAR IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE C1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE C2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE C3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE C4" ); + WHEN 'G' => NULL ; + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE C6" ); + END CASE; + + CASE IDENT_CHAR(STATCON) IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE D1" ); + WHEN 'J' | 'C' => NULL ; + WHEN 'F' => FAILED( "WRONG ALTERNATIVE D3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE D4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE D5" ); + WHEN OTHERS => FAILED( "WRONG ALTERNATIVE D6" ); + END CASE; + + CASE DYNCON IS + WHEN 'B' | 'E' => FAILED( "WRONG ALTERNATIVE E1" ); + WHEN 'J' | 'C' => FAILED( "WRONG ALTERNATIVE E2" ); + WHEN 'F' => FAILED( "WRONG ALTERNATIVE E3" ); + WHEN 'D' | 'H'..'I' => FAILED( "WRONG ALTERNATIVE E4" ); + WHEN 'G' => FAILED( "WRONG ALTERNATIVE E5" ); + WHEN OTHERS => NULL ; + END CASE; + + END ; + + + DECLARE + + NUMBER : CONSTANT := 1 ; + LITEXPR : CONSTANT := NUMBER + 5 ; + STATCON : CONSTANT INTEGER RANGE 0..10 := 9 ; + DYNVAR : INTEGER RANGE 0..10 := IDENT_INT( 10 ); + DYNCON : CONSTANT INTEGER RANGE 0..10 := IDENT_INT( 2 ); + + BEGIN + + CASE INTEGER'(0) IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE F4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE INTEGER'(NUMBER) IS + WHEN 1 | 4 => NULL ; + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE G4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE H4"); + WHEN 6 => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6"); + END CASE; + + CASE STATCON IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 9 | 2 => NULL ; + WHEN 5 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE I4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 9 | 2 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 5 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE J4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE J5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNCON IS + WHEN 1 | 4 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 9 | 2 => NULL ; + WHEN 5 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 3 | 7..8 => FAILED("WRONG ALTERNATIVE K4"); + WHEN 6 => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + + END C54A42B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C54A42C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES A SPARSE SET OF + -- POTENTIAL VALUES (OF TYPE INTEGER) IN A LARGE RANGE. + + -- (OPTIMIZATION TEST) + + + -- RM 03/26/81 + + + WITH REPORT; + PROCEDURE C54A42C IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42C" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SPARSE SET OF POTENTIAL VALUES IN A LARGE" & + " RANGE" ); + + DECLARE + + NUMBER : CONSTANT := 1001 ; + LITEXPR : CONSTANT := NUMBER + 998 ; + STATCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST := 1000 ; + DYNVAR : INTEGER RANGE 1..INTEGER'LAST := + IDENT_INT( INTEGER'LAST-50 ); + DYNCON : CONSTANT INTEGER RANGE 1..INTEGER'LAST := + IDENT_INT( 1000 ); + + BEGIN + + CASE INTEGER'( NUMBER ) IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE F4"); + WHEN INTEGER'LAST-100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT( 10 ) IS + WHEN 1 .. 10 => NULL ; + WHEN 1000 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE G4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE H4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE H5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATCON IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 1000 => NULL ; + WHEN 2000 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE I4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 1000 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 2000 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE J4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J6"); + END CASE; + + CASE DYNCON IS + WHEN 1 .. 10 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 1000 => NULL ; + WHEN 2000 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 4000 .. 4100 => FAILED("WRONG ALTERNATIVE K4"); + WHEN INTEGER'LAST -100 .. + INTEGER'LAST => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + + END C54A42C ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C54A42D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES A FEW ALTERNATIVES + -- COVERING A LARGE RANGE OF INTEGERS. + + + -- (OPTIMIZATION TEST.) + + + -- RM 03/30/81 + + + WITH REPORT; + PROCEDURE C54A42D IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42D" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " A FEW ALTERNATIVES COVERING A LARGE RANGE" & + " OF INTEGERS" ); + + DECLARE + + NUMBER : CONSTANT := 2000 ; + LITEXPR : CONSTANT := NUMBER + 2000 ; + STATCON : CONSTANT INTEGER := 2001 ; + DYNVAR : INTEGER := IDENT_INT( 0 ); + DYNCON : CONSTANT INTEGER := IDENT_INT( 1 ); + + BEGIN + + CASE INTEGER'(-4000) IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE F1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4"); + END CASE; + + CASE INTEGER'(NUMBER) IS + WHEN 1..2000 => NULL ; + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE H1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 2002..INTEGER'LAST=>NULL ; + END CASE; + + CASE STATCON IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE I1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2"); + WHEN 2001 => NULL ; + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4"); + END CASE; + + CASE DYNVAR IS + WHEN 1..2000 => FAILED("WRONG ALTERNATIVE J1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4"); + END CASE; + + CASE DYNCON IS + WHEN 1..2000 => NULL ; + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 2002..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4"); + END CASE; + + END ; + + + RESULT ; + + + END C54A42D ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42e.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C54A42E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES A SMALL RANGE OF + -- POTENTIAL VALUES OF TYPE INTEGER, SITUATED FAR FROM 0 AND + -- GROUPED INTO A SMALL NUMBER OF ALTERNATIVES. + + -- (OPTIMIZATION TEST -- BIASED JUMP TABLE.) + + + -- RM 03/26/81 + + + WITH REPORT; + PROCEDURE C54A42E IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42E" , "TEST THAT A CASE_STATEMENT HANDLES CORRECTLY" & + " A SMALL, FAR RANGE OF POTENTIAL VALUES OF" & + " TYPE INTEGER" ); + + DECLARE + + NUMBER : CONSTANT := 4001 ; + LITEXPR : CONSTANT := NUMBER + 5 ; + STATCON : CONSTANT INTEGER RANGE 4000..4010 := 4009 ; + DYNVAR : INTEGER RANGE 4000..4010 := + IDENT_INT( 4010 ); + DYNCON : CONSTANT INTEGER RANGE 4000..4010 := + IDENT_INT( 4002 ); + + BEGIN + + CASE INTEGER'(4000) IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE F1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE F2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE F4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE F5"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN 4001 | 4004 => NULL ; + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE G2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE G4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE G5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE G6"); + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE H1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE H2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE H4"); + WHEN 4006 => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H6"); + END CASE; + + CASE STATCON IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE I1"); + WHEN 4009 | 4002 => NULL ; + WHEN 4005 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE I4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE I5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I6"); + END CASE; + + CASE DYNVAR IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE J1"); + WHEN 4009 | 4002 => FAILED("WRONG ALTERNATIVE J2"); + WHEN 4005 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE J4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE J5"); + WHEN OTHERS => NULL ; + + END CASE; + + CASE DYNCON IS + WHEN 4001 | 4004 => FAILED("WRONG ALTERNATIVE K1"); + WHEN 4009 | 4002 => NULL ; + WHEN 4005 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 4003 | + 4007..4008 => FAILED("WRONG ALTERNATIVE K4"); + WHEN 4006 => FAILED("WRONG ALTERNATIVE K5"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE K6"); + END CASE; + + END ; + + + RESULT ; + + + END C54A42E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42f.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- C54A42F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES SEVERAL SMALL, + -- NON-CONTIGUOUS RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS' + -- ALTERNATIVE. + + + -- (OPTIMIZATION TEST.) + + + -- RM 03/31/81 + + + WITH REPORT; + PROCEDURE C54A42F IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42F" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " SEVERAL SMALL, NON-CONTIGUOUS ENUMERATION" & + " RANGES COVERED BY A SINGLE 'OTHERS' " & + " ALTERNATIVE" ); + + DECLARE + + TYPE DAY IS (SUN , MON , TUE , WED , THU , FRI , SAT ); + + DYNVAR2 : DAY := MON ; + STATVAR : DAY := TUE ; + STATCON : CONSTANT DAY := WED ; + DYNVAR : DAY := THU ; + DYNCON : CONSTANT DAY := DAY'VAL( IDENT_INT(5) ); -- FRI + + BEGIN + + IF EQUAL(1,289) THEN + DYNVAR := SUN ; + DYNVAR2 := SUN ; + END IF; + + CASE SUN IS -- SUN + WHEN THU => FAILED("WRONG ALTERNATIVE F1"); + WHEN SUN => NULL ; + WHEN SAT => FAILED("WRONG ALTERNATIVE F3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE F4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5"); + END CASE; + + CASE DYNVAR2 IS -- MON + WHEN THU => FAILED("WRONG ALTERNATIVE G1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE G2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE G3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE G4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE STATVAR IS -- TUE + WHEN THU => FAILED("WRONG ALTERNATIVE H1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE H2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE H3"); + WHEN TUE..WED => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5"); + END CASE; + + CASE STATCON IS -- WED + WHEN THU => FAILED("WRONG ALTERNATIVE I1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE I2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE I3"); + WHEN TUE..WED => NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE I5"); + END CASE; + + CASE DYNVAR IS -- THU + WHEN THU => NULL ; + WHEN SUN => FAILED("WRONG ALTERNATIVE J2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE J3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE J4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5"); + END CASE; + + CASE DYNCON IS -- FRI + WHEN THU => FAILED("WRONG ALTERNATIVE K1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE K2"); + WHEN SAT => FAILED("WRONG ALTERNATIVE K3"); + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE K4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DAY'SUCC( DYNCON ) IS -- SAT + WHEN THU => FAILED("WRONG ALTERNATIVE L1"); + WHEN SUN => FAILED("WRONG ALTERNATIVE L2"); + WHEN SAT => NULL ; + WHEN TUE..WED => FAILED("WRONG ALTERNATIVE L4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE L5"); + END CASE; + END ; + + + RESULT ; + + + END C54A42F ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c54a42g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- C54A42G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CASE_STATEMENT CORRECTLY HANDLES SEVERAL NON-CONTIGUOUS + -- RANGES OF INTEGERS COVERED BY A SINGLE 'OTHERS' ALTERNATIVE. + + + -- (OPTIMIZATION TEST.) + + + -- RM 03/30/81 + + + WITH REPORT; + PROCEDURE C54A42G IS + + USE REPORT ; + + BEGIN + + TEST( "C54A42G" , "TEST THAT A CASE_STATEMENT CORRECTLY HANDLES" & + " SEVERAL NON-CONTIGUOUS RANGES OF INTEGERS" & + " COVERED BY A SINGLE 'OTHERS' ALTERNATIVE" ); + + DECLARE + + NUMBER : CONSTANT := 2000 ; + LITEXPR : CONSTANT := NUMBER + 2000 ; + STATCON : CONSTANT INTEGER := 2002 ; + DYNVAR : INTEGER := IDENT_INT( 0 ); + DYNCON : CONSTANT INTEGER := IDENT_INT( 1 ); + + BEGIN + + CASE INTEGER'(-4000) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE F1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE F3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE F4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE F5"); + END CASE; + + CASE IDENT_INT(NUMBER) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE G1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE G2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE G3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE G4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT(LITEXPR) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE H1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE H2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE H3"); + WHEN 2100..INTEGER'LAST=>NULL ; + WHEN OTHERS => FAILED("WRONG ALTERNATIVE H5"); + END CASE; + + CASE IDENT_INT(STATCON) IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE I1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE I2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE I3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE I4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE DYNVAR IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE J1"); + WHEN INTEGER'FIRST..0=> NULL ; + WHEN 2001 => FAILED("WRONG ALTERNATIVE J3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE J4"); + WHEN OTHERS => FAILED("WRONG ALTERNATIVE J5"); + END CASE; + + CASE DYNCON IS + WHEN 100..1999 => FAILED("WRONG ALTERNATIVE K1"); + WHEN INTEGER'FIRST..0=> FAILED("WRONG ALTERNATIVE K2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE K3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE K4"); + WHEN OTHERS => NULL ; + END CASE; + + CASE IDENT_INT( -3900 ) IS + WHEN -3000..1999 => FAILED("WRONG ALTERNATIVE X1"); + WHEN INTEGER'FIRST.. + -4000 => FAILED("WRONG ALTERNATIVE X2"); + WHEN 2001 => FAILED("WRONG ALTERNATIVE X3"); + WHEN 2100..INTEGER'LAST=>FAILED("WRONG ALTERNATIVE X4"); + WHEN OTHERS => NULL ; + END CASE; + + END ; + + + RESULT ; + + + END C54A42G ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b03a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C55B03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE LOOP_PARAMETER IS ASSIGNED VALUES IN ASCENDING ORDER + -- IF REVERSE IS ABSENT, AND DESCENDING ORDER IF REVERSE IS PRESENT. + + -- DAS 1/12/81 + -- SPS 3/2/83 + + WITH REPORT; + PROCEDURE C55B03A IS + + USE REPORT; + I1 : INTEGER; + + BEGIN + TEST( "C55B03A" , "CHECK CORRECT ORDER OF VALUE SEQUENCING" & + " FOR A LOOP_PARAMETER" ); + + I1 := 0; + FOR I IN IDENT_INT(1)..IDENT_INT(5) LOOP + I1 := I1 + 1; + IF ( I /= I1 ) THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY" ); + END IF; + END LOOP; + + I1 := 6; + FOR I IN REVERSE IDENT_INT(1)..IDENT_INT(5) LOOP + I1 := I1 - 1; + IF ( I /= I1 ) THEN + FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY" ); + END IF; + END LOOP; + + RESULT; + + END C55B03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b04a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C55B04A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A LOOP IS NOT ENTERED IF THE LOWER BOUND OF THE DISCRETE + -- RANGE IS GREATER THAN THE UPPER BOUND, WHETHER REVERSE IS PRESENT + -- OR NOT. + + -- CHECK THAT LOOP BOUNDS ARE EVALUATED ONLY ONCE, UPON ENTRY TO + -- THE LOOP. + + -- DAS 01/12/81 + -- SPS 3/2/83 + -- JBG 8/21/83 + + WITH REPORT; + PROCEDURE C55B04A IS + + USE REPORT; + + C10 : CONSTANT INTEGER := 10; + I10 : INTEGER; + + BEGIN + TEST ( "C55B04A", "CHECK OPERATION OF A FOR LOOP OVER A NULL " & + "DISCRETE RANGE" ); + + -- NOTE: EXIT STATEMENTS ARE INCLUDED TO AID IN RECOVERY FROM + -- TEST FAILURE. + + -- SUBTESTS INVOLVING STATIC BOUNDS: + + FOR I IN 10..1 LOOP + FAILED ( "LOOPING OVER NULL RANGE 10..1" ); + EXIT; + END LOOP; + + FOR I IN REVERSE INTEGER RANGE -1..-10 LOOP + FAILED ( "LOOPING OVER NULL RANGE -1..-10" ); + EXIT; + END LOOP; + + FOR I IN (C10 + 3)..(-3 * C10 + 27) LOOP -- 13..-3 + FAILED ("LOOPING OVER NULL RANGE (C10 + 3)..(-3 * C10 + 27)"); + EXIT; + END LOOP; + + + -- SUBTESTS INVOLVING DYNAMIC BOUNDS: + + I10 := IDENT_INT(10); + + FOR I IN REVERSE I10..(I10-1) LOOP -- 10..9 + FAILED ( "LOOPING OVER NULL RANGE I10..(I10-1)"); + EXIT; + END LOOP; + + + FOR I IN (C10 - I10)..(I10 - 11) LOOP -- 0..-1 + FAILED ( "LOOPING OVER NULL RANGE (C10 - I10)..(I10 - 11)" ); + EXIT; + END LOOP; + + + -- SUBTEST OF BOUNDS EVALUTION ONLY AT ENTRY: + + FOR I IN 1..I10 LOOP + I10 := I10 - 1; + END LOOP; + IF (I10 /= 0) THEN + FAILED ( "LOOP BOUNDS NOT FIXED AT LOOP ENTRY" ); + END IF; + + RESULT; + + END C55B04A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b05a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C55B05A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOOPS WITH BOUNDS INTEGER'LAST OR + -- INTEGER'FIRST DO NOT RAISE INVALID EXCEPTIONS. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- DAT 3/26/81 + -- SPS 3/2/83 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE C55B05A IS + BEGIN + TEST ("C55B05A", "LOOPS WITH INTEGER'FIRST AND 'LAST AS BOUNDS"); + + DECLARE + + COUNT : INTEGER := 0; + + PROCEDURE C IS + BEGIN + COUNT := COUNT + 1; + END C; + + BEGIN + FOR I IN INTEGER'LAST .. INTEGER'FIRST LOOP + FAILED ("WRONG NULL RANGE LOOP EXECUTION"); + EXIT; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'FIRST LOOP + C; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP + C; C; + END LOOP; + FOR I IN INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP + FAILED ("NULL RANGE ERROR 2"); + EXIT; + END LOOP; + FOR I IN INTEGER'FIRST .. INTEGER'LAST LOOP + C; + EXIT; + END LOOP; + FOR I IN INTEGER LOOP + C; + EXIT; + END LOOP; + FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST LOOP + C; C; C; + END LOOP; + FOR I IN INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP + C; + END LOOP; + FOR I IN 0 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 3"); + EXIT; + END LOOP; + FOR I IN -1 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 4"); + EXIT; + END LOOP; + FOR I IN -3 .. IDENT_INT(0) LOOP + FOR J IN INTEGER'FIRST .. INTEGER'FIRST - I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'FIRST - I .. INTEGER'FIRST + 3 - I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'LAST - 3 .. INTEGER'LAST + I LOOP + C; C; C; C; + END LOOP; + FOR J IN INTEGER'LAST + I .. INTEGER'LAST LOOP + C; C; C; C; + END LOOP; + END LOOP; + + FOR I IN REVERSE INTEGER'LAST .. INTEGER'FIRST LOOP + FAILED ("REVERSE WRONG NULL RANGE LOOP EXECUTION"); + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST LOOP + C; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'FIRST + 2 LOOP + C; C; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST + 1 .. INTEGER'FIRST LOOP + FAILED ("NULL RANGE ERROR 8"); + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'FIRST .. INTEGER'LAST LOOP + C; + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER LOOP + C; + EXIT; + END LOOP; + FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST LOOP + C; C; C; + END LOOP; + FOR I IN REVERSE INTEGER'LAST - 2 .. INTEGER'LAST - 1 LOOP + C; + END LOOP; + FOR I IN REVERSE 0 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 9"); + EXIT; + END LOOP; + FOR I IN REVERSE -1 .. INTEGER'FIRST LOOP + FAILED ("NULL LOOP ERROR 7"); + EXIT; + END LOOP; + FOR I IN REVERSE -3 .. IDENT_INT(0) LOOP + FOR J IN REVERSE INTEGER'FIRST .. INTEGER'FIRST - I LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'FIRST - I + .. INTEGER'FIRST + 3 - I + LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'LAST - 3 .. INTEGER'LAST + I + LOOP + C; C; C; C; + END LOOP; + FOR J IN REVERSE INTEGER'LAST + I .. INTEGER'LAST LOOP + C; C; C; C; + END LOOP; + END LOOP; + + IF COUNT /= 408 THEN + FAILED ("WRONG LOOP EXECUTION COUNT"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED INCORRECTLY"); + END; + + RESULT; + END C55B05A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b06a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,313 ---- + -- C55B06A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOOPS MAY BE SPECIFIED FOR BOOLEAN, INTEGER, + -- CHARACTER, ENUMERATION, AND DERIVED TYPES, INCLUDING + -- TYPES DERIVED FROM DERIVED TYPES. DERIVED BOOLEAN IS NOT + -- TESTED IN THIS TEST. + + -- DAT 3/26/81 + -- JBG 9/29/82 + -- SPS 3/11/83 + -- JBG 10/5/83 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C55B06A IS + + TYPE ENUM IS ('A', 'B', 'D', 'C', Z, X, D, A, C); + + TYPE D1 IS NEW CHARACTER RANGE 'A' .. 'Z'; + TYPE D2 IS NEW INTEGER; + TYPE D3 IS NEW ENUM; + TYPE D4 IS NEW D1; + TYPE D5 IS NEW D2; + TYPE D6 IS NEW D3; + + ONE : INTEGER := IDENT_INT(1); + COUNT : INTEGER := 0; + OLDCOUNT : INTEGER := 0; + + PROCEDURE Q IS + BEGIN + COUNT := COUNT + ONE; + END Q; + + BEGIN + TEST ("C55B06A", "TEST LOOPS FOR ALL DISCRETE TYPES"); + + FOR I IN BOOLEAN LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 1"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 2"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 3"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER LOOP + Q; + EXIT WHEN I = INTEGER'FIRST + 2; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 4"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 3 .. IDENT_INT (5) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 5"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER RANGE -2 .. -1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 6"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN INTEGER RANGE INTEGER'FIRST .. INTEGER'FIRST + 1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 7"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. CHARACTER'('Z') LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 9"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN CHARACTER RANGE 'A' .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 10"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN ENUM LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN + FAILED ("LOOP 11"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN ENUM RANGE D .. C LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 12"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. ENUM'(Z) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 13"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 14"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1 RANGE 'A' .. 'Z' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 15"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D1'('A') .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 16"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2 LOOP + Q; + IF I > D2'FIRST + 3 THEN + EXIT; + END IF; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 17"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2 RANGE -100 .. -99 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 18"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D2'(1) .. 2 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 19"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D3 LOOP + IF I IN 'A' .. 'C' THEN + Q; -- 4 + ELSE + Q; Q; -- 10 + END IF; + END LOOP; + IF OLDCOUNT + IDENT_INT(14) /= COUNT THEN + FAILED ("LOOP 20"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D3 RANGE 'A' .. Z LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 21"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN 'A' .. D3'(Z) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 22"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 23"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4'('A') .. 'Z' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(26) /= COUNT THEN + FAILED ("LOOP 24"); + END IF; + OLDCOUNT := COUNT; + + FOR I IN D4 RANGE 'B' .. 'D' LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(3) /= COUNT THEN + FAILED ("LOOP 25"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5 LOOP + Q; -- 4 + EXIT WHEN J = D5(INTEGER'FIRST) + 3; + Q; -- 3 + END LOOP; + IF OLDCOUNT + IDENT_INT(7) /= COUNT THEN + FAILED ("LOOP 26"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5 RANGE -2 .. -1 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(2) /= COUNT THEN + FAILED ("LOOP 27"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D5'(-10) .. D5'(-6) LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 28"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6 LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(9) /= COUNT THEN + FAILED ("LOOP 29"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6 RANGE Z .. A LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(4) /= COUNT THEN + FAILED ("LOOP 30"); + END IF; + OLDCOUNT := COUNT; + + FOR J IN D6'('D') .. D LOOP + Q; + END LOOP; + IF OLDCOUNT + IDENT_INT(5) /= COUNT THEN + FAILED ("LOOP 31"); + END IF; + OLDCOUNT := COUNT; + + + RESULT; + END C55B06A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b06b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- C55B06B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOOPS MAY BE SPECIFIED FOR DERIVED BOOLEAN AND + -- DERIVED DERIVED BOOLEAN. + + -- DAT 3/26/81 + -- SPS 3/2/83 + + WITH REPORT; USE REPORT; + + PROCEDURE C55B06B IS + + TYPE E IS (FALSE, TRUE); + TYPE B1 IS NEW BOOLEAN; + TYPE B2 IS NEW B1; + TYPE B3 IS NEW E; + + ONE : INTEGER := IDENT_INT (1); + COUNT : INTEGER := 0; + OLD_COUNT : INTEGER := 0; + + PROCEDURE Q IS + BEGIN + COUNT := COUNT + 1; + END Q; + + BEGIN + TEST ("C55B06B", "LOOPS OVER DERIVED BOOLEAN"); + + FOR I IN BOOLEAN LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 1"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN BOOLEAN RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 2"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN BOOLEAN'(FALSE) .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 3"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN E LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 4"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN E RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 5"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. E'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 6"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B1 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 7"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B1 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 8"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. B1'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 9"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 10"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 11"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B2'(FALSE) .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 12"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B3 LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 13"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN B3 RANGE FALSE .. TRUE LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 14"); + ELSE + OLD_COUNT := COUNT; + END IF; + + FOR I IN FALSE .. B3'(TRUE) LOOP + Q; + END LOOP; + IF OLD_COUNT + IDENT_INT (2) /= COUNT THEN + FAILED ("LOOP 15"); + ELSE + OLD_COUNT := COUNT; + END IF; + + RESULT; + END C55B06B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b07a.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- C55B07A.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LOOPS OVER RANGES OF TYPE LONG_INTEGER + -- CAN BE WRITTEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- THE TYPE LONG_INTEGER. + -- + -- IF THE TYPE LONG_INTEGER IS NOT SUPPORTED, THEN THE + -- DECLARATION OF CHECK MUST BE REJECTED. + + -- HISTORY: + -- RM 07/06/82 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + + + WITH REPORT; USE REPORT; + + PROCEDURE C55B07A IS + + CHECK : LONG_INTEGER; -- N/A => ERROR. + + TYPE NEW_LONG_INTEGER IS NEW LONG_INTEGER ; + + THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY... + + LI_VAR : LONG_INTEGER := 1 ; + LI_CON : CONSTANT LONG_INTEGER := 1 ; + + NLI_VAR : NEW_LONG_INTEGER := 1 ; + NLI_CON : CONSTANT NEW_LONG_INTEGER := 1 ; + + SUBTYPE LI_SEGMENT IS LONG_INTEGER RANGE + LONG_INTEGER'LAST..LONG_INTEGER'LAST ; + + SUBTYPE NLI_SEGMENT IS NEW_LONG_INTEGER RANGE + NEW_LONG_INTEGER'FIRST.. + NEW_LONG_INTEGER'FIRST ; + + COUNT : INTEGER := 0; + + PROCEDURE BUMP ( DUMMY : INTEGER ) IS + BEGIN + COUNT := COUNT + 1; + END BUMP; + + BEGIN + + TEST ( "C55B07A" , "LOOPS OVER RANGES OF TYPE LONG_INTEGER " ); + + FOR I IN 1..LI_CON LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NLI_VAR..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..LONG_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..NEW_LONG_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN REVERSE NLI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LONG_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NEW_LONG_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN LONG_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = LONG_INTEGER'FIRST + 1; + END LOOP; + + FOR I IN NEW_LONG_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = NEW_LONG_INTEGER'FIRST + 1; + END LOOP; + + + IF COUNT /= 12 THEN + FAILED ("WRONG LOOP COUNT"); + END IF; + + + RESULT; + + + END C55B07A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b07b.dep 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- C55B07B.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LOOPS OVER RANGES OF TYPE SHORT_INTEGER + -- CAN BE WRITTEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- THE TYPE SHORT_INTEGER. + -- + -- IF THE TYPE SHORT_INTEGER IS NOT SUPPORTED, THEN THE + -- DECLARATION OF CHECK MUST BE REJECTED. + + -- HISTORY: + -- RM 07/08/82 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + + + WITH REPORT; USE REPORT; + + PROCEDURE C55B07B IS + + CHECK : SHORT_INTEGER; -- N/A => ERROR. + + TYPE NEW_SHORT_INTEGER IS NEW SHORT_INTEGER ; + + THE_COUNT : INTEGER := 777 ; -- JUST A DUMMY... + + SI_VAR : SHORT_INTEGER := 1 ; + SI_CON : CONSTANT SHORT_INTEGER := 1 ; + + NSI_VAR : NEW_SHORT_INTEGER := 1 ; + NSI_CON : CONSTANT NEW_SHORT_INTEGER := 1 ; + + SUBTYPE SI_SEGMENT IS SHORT_INTEGER RANGE + SHORT_INTEGER'LAST..SHORT_INTEGER'LAST ; + + SUBTYPE NSI_SEGMENT IS NEW_SHORT_INTEGER RANGE + NEW_SHORT_INTEGER'FIRST.. + NEW_SHORT_INTEGER'FIRST ; + + COUNT : INTEGER := 0; + + PROCEDURE BUMP ( DUMMY : INTEGER ) IS + BEGIN + COUNT := COUNT + 1; + END BUMP; + + BEGIN + + TEST ( "C55B07B" , "LOOPS OVER RANGES OF TYPE SHORT_INTEGER " ); + + FOR I IN 1..SI_CON LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NSI_VAR..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..SHORT_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN 1..NEW_SHORT_INTEGER(1) LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN REVERSE NSI_SEGMENT LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SHORT_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN NEW_SHORT_INTEGER RANGE 1..1 LOOP + BUMP(THE_COUNT) ; + END LOOP; + + FOR I IN SHORT_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = SHORT_INTEGER'FIRST + 1; + END LOOP; + + FOR I IN NEW_SHORT_INTEGER LOOP + BUMP(THE_COUNT) ; + EXIT WHEN I = NEW_SHORT_INTEGER'FIRST + 1; + END LOOP; + + + IF COUNT /= 12 THEN + FAILED ("WRONG LOOP COUNT"); + END IF; + + + RESULT; + + + END C55B07B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b10a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C55B10A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, IN 'FOR I IN L .. R LOOP', IF EITHER L OR R IS AN + -- OVERLOADED ENUMERATION LITERAL, THE OVERLOADING IS CORRECTLY + -- RESOLVED AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C55B10A IS + + TYPE ENUM IS (ALPH, BET, NEITHER); + + GLOBAL : ENUM := NEITHER; + + TYPE ALPHA IS (A, B, C, D, E); + TYPE BETA IS (G, F, E, D, C); + + PROCEDURE VAR(DEC : ALPHA) IS + BEGIN + IF EQUAL(3, 3) THEN + GLOBAL := ALPH; + END IF; + END; + + PROCEDURE VAR(DEC : BETA) IS + BEGIN + IF EQUAL(3, 3) THEN + GLOBAL := BET; + END IF; + END; + + BEGIN + TEST("C55B10A", "CHECK THAT, IN 'FOR I IN L .. R LOOP', IF " & + "EITHER L OR R IS AN OVERLOADED ENUMERATION " & + "LITERAL, THE OVERLOADING IS CORRECTLY RESOLVED " & + "AND THE LOOP PARAMETER HAS THE APPROPRIATE TYPE"); + + FOR I IN A .. E LOOP + VAR(I); + + IF GLOBAL /= ALPH THEN + FAILED("WRONG TYPE FOR ALPHA"); + END IF; + END LOOP; + + FOR I IN G .. E LOOP + VAR(I); + + IF GLOBAL /= BET THEN + FAILED("WRONG TYPE FOR BETA"); + END IF; + END LOOP; + + RESULT; + END C55B10A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b11a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C55B11A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, IN 'FOR IN ST RANGE L .. R LOOP', THE PARAMETER IS OF + -- THE TYPE ST'BASE; THAT IS THAT IT CAN BE ASSIGNED TO OTHER + -- VARIABLES DECLARED WITH SOME OTHER SUBTYPES OF ST. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C55B11A IS + + TYPE ENUM IS (A, B, C, D, E, F, G, H); + + SUBTYPE ONE IS ENUM RANGE A .. H; + SUBTYPE TWO IS ENUM RANGE B .. H; + SUBTYPE THREE IS ENUM RANGE C .. H; + SUBTYPE FOUR IS ENUM RANGE D .. H; + + GLOBAL : INTEGER := 0; + + VAR_1 : ONE; + VAR_2 : TWO; + VAR_3 : THREE; + VAR_4 : FOUR; + + PROCEDURE CHECK_VAR(T : ENUM) IS + BEGIN + GLOBAL := GLOBAL + 1; + CASE T IS + WHEN D => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("VAR_1 WRONG VALUE"); + END IF; + + WHEN E => + IF GLOBAL /= IDENT_INT(2) THEN + FAILED("VAR_2 WRONG VALUE"); + END IF; + + WHEN F => + IF GLOBAL /= IDENT_INT(3) THEN + FAILED("VAR_3 WRONG VALUE"); + END IF; + + WHEN G => + IF GLOBAL /= IDENT_INT(4) THEN + FAILED("VAR_4 WRONG VALUE"); + END IF; + + WHEN OTHERS => + + FAILED("WRONG VALUE TO PROCEDURE"); + END CASE; + END CHECK_VAR; + + BEGIN + TEST("C55B11A", "CHECK THAT, IN 'FOR IN ST RANGE L .. R LOOP', " & + "THE PARAMETER IS OF THE TYPE ST'BASE; THAT IS " & + "THAT IT CAN BE ASSIGNED TO OTHER VARIABLES " & + "DECLARED WITH SOME OTHER SUBTYPES OF ST"); + + FOR I IN ONE RANGE D .. G LOOP + CASE I IS + WHEN D => + VAR_1 := I; + CHECK_VAR(VAR_1); + WHEN E => + VAR_2 := I; + CHECK_VAR(VAR_2); + WHEN F => + VAR_3 := I; + CHECK_VAR(VAR_3); + WHEN G => + VAR_4 := I; + CHECK_VAR(VAR_4); + END CASE; + END LOOP; + + RESULT; + END C55B11A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b11b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C55B11B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FORM 'FOR I IN ST RANGE L .. R LOOP' IS ACCEPTED + -- EVEN IF BOTH L AND R ARE OVERLOADED ENUMERATION LITERALS (SO + -- THAT L .. R WOULD BE ILLEGAL WITHOUT ST RANGE). + + -- HISTORY: + -- DHH 09/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C55B11B IS + TYPE ST IS (A, B, C, D, E, F, G, H); + TYPE SI IS (A, B, C, D, F, E, G, H); + + GLOBAL : INTEGER := 0; + + PROCEDURE CHECK_VAR(T : ST) IS + BEGIN + GLOBAL := GLOBAL + 1; + CASE T IS + WHEN D => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("1 WRONG VALUE"); + END IF; + + WHEN E => + IF GLOBAL /= IDENT_INT(2) THEN + FAILED("2 WRONG VALUE"); + END IF; + + WHEN F => + IF GLOBAL /= IDENT_INT(3) THEN + FAILED("3 WRONG VALUE"); + END IF; + + WHEN G => + IF GLOBAL /= IDENT_INT(4) THEN + FAILED("4 WRONG VALUE"); + END IF; + + WHEN OTHERS => + FAILED("WRONG VALUE TO PROCEDURE"); + + END CASE; + END CHECK_VAR; + + PROCEDURE CHECK_VAR(T : SI) IS + BEGIN + FAILED("WRONG PROCEDURE CALLED"); + END CHECK_VAR; + + BEGIN + TEST ("C55B11B", "CHECK THAT THE 'FORM FOR I IN ST RANGE L .. R " & + "LOOP' IS ACCEPTED EVEN IF BOTH L AND R ARE " & + "OVERLOADED ENUMERATION LITERALS (SO THAT L .. " & + "R WOULD BE ILLEGAL WITHOUT ST RANGE)"); + + FOR I IN ST RANGE D .. G LOOP + CHECK_VAR(I); + END LOOP; + + RESULT; + END C55B11B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b15a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- C55B15A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A DISCRETE_RANGE OF THE FORM 'ST RANGE L..R' + -- RAISES AN EXCEPTION BECAUSE L OR R IS A NON-STATIC + -- EXPRESSION WHOSE VALUE IS OUTSIDE THE RANGE OF VALUES + -- ASSOCIATED WITH ST (OR BECAUSE ST'FIRST IS NON-STATIC + -- AND L IS STATIC AND LESS THAN ST'FIRST ; SIMILARLY FOR + -- ST'LAST AND R ), CONTROL DOES NOT ENTER THE LOOP. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- RM 04/13/81 + -- SPS 11/01/82 + -- BHS 07/13/84 + -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + -- GJD 11/15/95 REMOVED CASE OF POTENTIALLY STATICALLY INCOMPATIBLE RANGE. + + WITH SYSTEM; + WITH REPORT; + PROCEDURE C55B15A IS + + USE REPORT ; + + BEGIN + + TEST( "C55B15A" , "WHEN 'FOR I IN ST RANGE L..R LOOP' " & + "RAISES AN EXCEPTION, CONTROL DOES NOT ENTER " & + "THE BODY OF THE LOOP" ); + + ------------------------------------------------------------------- + ----------------- STATIC (SUB)TYPE, DYNAMIC RANGE ----------------- + + DECLARE + + SUBTYPE ST IS INTEGER RANGE 1..4 ; + + FIRST : CONSTANT INTEGER := IDENT_INT( 1) ; + SECOND : CONSTANT INTEGER := IDENT_INT( 2) ; + THIRD : CONSTANT INTEGER := IDENT_INT( 3) ; + FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ; + FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ; + TENTH : CONSTANT INTEGER := IDENT_INT(10) ; + ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ; + + BEGIN + + BEGIN + + FOR I IN ST RANGE 3..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (I1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (I1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE 0..THIRD LOOP + FAILED( "EXCEPTION NOT RAISED (I2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (I2)" ); + + END ; + END ; + + + ------------------------------------------------------------------- + ----------------- DYNAMIC (SUB)TYPE, STATIC RANGE ----------------- + + DECLARE + + TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J ); + + SUBTYPE ST IS ENUM RANGE ENUM'VAL( IDENT_INT( 1) ) .. + ENUM'VAL( IDENT_INT( 4) ) ; + + FIRST : CONSTANT ENUM := A ; + SECOND : CONSTANT ENUM := B ; + THIRD : CONSTANT ENUM := C ; + FOURTH : CONSTANT ENUM := D ; + FIFTH : CONSTANT ENUM := E ; + TENTH : CONSTANT ENUM := J ; + ZEROTH : CONSTANT ENUM := AMINUS ; + + BEGIN + + BEGIN + + FOR I IN ST RANGE C..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (E1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (E1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE AMINUS..THIRD LOOP + FAILED( "EXCEPTION NOT RAISED (E2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (E2)" ); + + END ; + + END ; + + + DECLARE + + SUBTYPE ST IS CHARACTER RANGE IDENT_CHAR( 'A' ) .. + IDENT_CHAR( 'D' ) ; + + FIRST : CONSTANT CHARACTER := 'A' ; + SECOND : CONSTANT CHARACTER := 'B' ; + THIRD : CONSTANT CHARACTER := 'C' ; + FOURTH : CONSTANT CHARACTER := 'D' ; + FIFTH : CONSTANT CHARACTER := 'E' ; + TENTH : CONSTANT CHARACTER := 'J' ; + ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO; PRECEDES LETTERS + + BEGIN + + BEGIN + + FOR I IN ST RANGE 'C'..TENTH LOOP + FAILED( "EXCEPTION NOT RAISED (C1)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (C1)" ); + + END ; + + + BEGIN + + FOR I IN ST RANGE '0'..THIRD LOOP -- ZERO..'C' + FAILED( "EXCEPTION NOT RAISED (C2)" ); + END LOOP; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => NULL ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED (C2)" ); + + END ; + + END ; + + + RESULT ; + + + END C55B15A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55b16a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C55B16A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THE PROCESSING OF ITERATIONS OVER AN ENUMERATION TYPE + -- WHOSE (USER-DEFINED) REPRESENTATION CONSISTS OF A NON-CONTIGUOUS + -- SET OF INTEGERS. + -- + -- (INHERITANCE (AND SUBSEQUENT OVERRIDING) OF REPRESENTATION + -- SPECIFICATIONS WILL BE TESTED ELSEWHERE.) + + -- HISTORY: + -- RM 08/06/82 CREATED ORIGINAL TEST. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH REPORT; USE REPORT; + PROCEDURE C55B16A IS + + I1 : INTEGER := 0 ; + + TYPE ENUM IS ( 'A' , 'B' , 'D' , 'C' , Z , X , D , A , C ); + FOR ENUM USE ( -15 , -14 , -11 , -10 , + 1 , 3 , 4 , 8 , 9 ); + + BEGIN + + TEST ("C55B16A" , "TEST LOOPING OVER ENUMERATION TYPES WITH" & + " NON-CONTIGUOUS REPRESENTATION" ); + + I1 := IDENT_INT(0) ; + + FOR X IN ENUM LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 0..8 + THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (1)" ); + END IF; + + I1 := I1 + IDENT_INT(1) ; + + END LOOP; + + + I1 := IDENT_INT(6) ; + + FOR X IN ENUM RANGE D .. C LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 6..8 + THEN + FAILED ( "LOOP_PARAMETER ASCENDING INCORRECTLY (2)" ); + END IF; + + I1 := I1 + IDENT_INT(1) ; + + END LOOP; + + + I1 := IDENT_INT(4) ; + + FOR X IN REVERSE 'A'..ENUM'(Z) LOOP + + IF X /= ENUM'VAL(I1) OR + ENUM'POS(X) /= I1 -- 4..0 + THEN + FAILED ( "LOOP_PARAMETER DESCENDING INCORRECTLY (3)" ); + END IF; + + I1 := I1 - IDENT_INT(1) ; + + END LOOP; + + + RESULT ; + + + END C55B16A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55c02a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + -- C55C02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHILE LOOPS WITH FALSE CONDITIONS ARE NEVER EXECUTED. + + -- DAT 1/29/81 + -- DLD 8/06/82 + + WITH REPORT; + PROCEDURE C55C02A IS + + USE REPORT; + + BEGIN + TEST ("C55C02A", "INITIAL FALSE CONDITIONS IN WHILE LOOPS"); + + WHILE FALSE LOOP + FAILED ("STATIC FALSE WHILE LOOP ENTERED"); + EXIT; + END LOOP; + + WHILE IDENT_BOOL (FALSE) LOOP + FAILED ("DYNAMIC FALSE WHILE LOOP ENTERED"); + EXIT; + END LOOP; + + RESULT; + END C55C02A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c55c02b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C55C02B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE WHILE CONDITION IS EVALUATED EACH TIME. + + -- DAT 1/29/81 + -- SPS 3/2/83 + + WITH REPORT; + PROCEDURE C55C02B IS + + USE REPORT; + + I : INTEGER := 0; + + FT : ARRAY (FALSE .. TRUE) OF BOOLEAN + := (IDENT_BOOL (FALSE), IDENT_BOOL (TRUE)); + + BEGIN + TEST ("C55C02B", "WHILE CONDITION IS EVALUATED EACH TIME THROUGH"); + + WHILE I /= 10 LOOP + I := I + 1; + END LOOP; + IF I /= 10 THEN + FAILED ("BAD LOOP FLOW - OPTIMIZABLE CONDITION"); + END IF; + + I := 10; + WHILE FT (IDENT_BOOL (I /= 14)) LOOP + I := I + 1; + END LOOP; + IF I /= 14 THEN + FAILED ("BAD LOOP FLOW - DYNAMIC CONDITION"); + END IF; + + RESULT; + END C55C02B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c56002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c56002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c56002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c56002a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- C56002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT BLOCKS CAN HAVE DECLARATIVE PARTS AND THAT + -- THE EFFECT OF THESE DECLARATIONS IS LIMITED TO THE BLOCKS + -- IN WHICH THEY OCCUR. + + + -- RM 04/16/81 + -- SPS 3/4/83 + + WITH REPORT; + PROCEDURE C56002A IS + + USE REPORT ; + + BEGIN + + TEST( "C56002A" , "BLOCKS CAN HAVE DECLARATIVE PARTS AND" & + " THE EFFECT OF THESE DECLARATIONS IS LIMITED" & + " TO THE BLOCKS IN WHICH THEY OCCUR" ) ; + + DECLARE + + FIRST : CONSTANT INTEGER := IDENT_INT( 1) ; + SECOND : CONSTANT INTEGER := IDENT_INT( 2) ; + THIRD : CONSTANT INTEGER := IDENT_INT( 3) ; + FOURTH : CONSTANT INTEGER := IDENT_INT( 4) ; + FIFTH : CONSTANT INTEGER := IDENT_INT( 5) ; + TENTH : CONSTANT INTEGER := IDENT_INT(10) ; + ZEROTH : CONSTANT INTEGER := IDENT_INT( 0) ; + + BEGIN + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 1" ); + END IF; + + DECLARE + + TYPE ENUM IS ( AMINUS , A,B,C,D,E, F,G,H,I,J ); + + FIRST : CONSTANT ENUM := A ; + SECOND : CONSTANT ENUM := B ; + THIRD : CONSTANT ENUM := C ; + FOURTH : CONSTANT ENUM := D ; + FIFTH : CONSTANT ENUM := E ; + TENTH : CONSTANT ENUM := J ; + ZEROTH : CONSTANT ENUM := AMINUS ; + + BEGIN + + IF FIRST /= ENUM'VAL( IDENT_INT( 1 ) ) OR + SECOND /= ENUM'VAL( IDENT_INT( 2 ) ) OR + THIRD /= ENUM'VAL( IDENT_INT( 3 ) ) OR + FOURTH /= ENUM'VAL( IDENT_INT( 4 ) ) OR + FIFTH /= ENUM'VAL( IDENT_INT( 5 ) ) OR + TENTH /= ENUM'VAL( IDENT_INT(10 ) ) OR + ZEROTH /= ENUM'VAL( IDENT_INT( 0 ) ) + THEN + FAILED( "WRONG VALUES - 2" ); + END IF; + + END ; + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 3" ); + END IF; + + DECLARE + + FIRST : CONSTANT CHARACTER := 'A' ; + SECOND : CONSTANT CHARACTER := 'B' ; + THIRD : CONSTANT CHARACTER := 'C' ; + FOURTH : CONSTANT CHARACTER := 'D' ; + FIFTH : CONSTANT CHARACTER := 'E' ; + TENTH : CONSTANT CHARACTER := 'J' ; + ZEROTH : CONSTANT CHARACTER := '0' ;--ZERO < ANY LETTER + + BEGIN + + IF FIRST /= IDENT_CHAR( 'A' ) OR + SECOND /= IDENT_CHAR( 'B' ) OR + THIRD /= IDENT_CHAR( 'C' ) OR + FOURTH /= IDENT_CHAR( 'D' ) OR + FIFTH /= IDENT_CHAR( 'E' ) OR + TENTH /= IDENT_CHAR( 'J' ) OR + ZEROTH /= IDENT_CHAR( '0' ) + THEN + FAILED( "WRONG VALUES - 4" ); + END IF; + + END ; + + IF FIRST /= 1 OR + SECOND /= 2 OR + THIRD /= 3 OR + FOURTH /= 4 OR + FIFTH /= 5 OR + TENTH /=10 OR + ZEROTH /= 0 + THEN + FAILED( "WRONG VALUES - 5" ); + END IF; + + + END ; + + + RESULT ; + + + END C56002A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57003a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- C57003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXIT STATEMENT IS EVALUATED EACH TIME THROUGH A LOOP, + -- AND THAT IT IS EVALUATED CORRECTLY WHETHER POSITIONED AT THE + -- BEGINNING, MIDDLE, OR END OF THE LOOP. + + + + -- EACH TEST IS A LOOP ON J WHERE THE EXIT CONDITIONS ARE TO EVALUATE + -- TO 'FALSE' A CERTAIN NUMBER OF TIMES UNTIL, AT THE APPROPRIATE + -- TIME, ONE OF THEM EVALUATES TO 'TRUE' AND CAUSES THE LOOP TO BE + -- EXITED. + -- + -- + -- THE TEST IS PERFORMED 30 TIMES FOR EACH OF THE FIRST TWO + -- DATA TYPES CONSIDERED ('INTEGER', USER-DEFINED ENUMERATION) + -- AND 26 TIMES FOR 'CHARACTER' (THUS 86 TIMES ALTOGETHER). + -- + -- + -- EACH DATA TYPE HAS ITS OWN SEPARATE SECTION OF CODE. ALL SECTIONS + -- FOLLOW THE SAME TESTING ALGORITHM (MUTATIS MUTANDIS). THE CALCU- + -- LATIONS WHICH KEEP TRACK OF THE FLOW OF CONTROL ARE ALL DONE IN + -- INTEGER ARITHMETIC. THERE ARE THREE DATA TYPES, THUS THREE + -- SECTIONS. + -- + -- + -- FOR EACH DATA TYPE, THE 30 TESTS ARE DIVIDED INTO 3 "SEGMENTS" + -- + -- << NOTE: THE NUMBER OF SEGMENTS IS WRITTEN " 3 " , + -- THE NUMBER OF SECTIONS IS WRITTEN "THREE" >> + -- + -- (OF 10 TESTS EACH, EXCEPT 10,10,6 FOR 'CHARACTER'), NUMBERED + -- 0 , 1 , 2 AND CORRESPONDING TO THE 3 SIGNIFICANTLY DIFFERENT + -- POSITIONS OF AN EXIT STATEMENT WITH RESPECT TO THE LOOP IT IS IN + -- ( "AT THE VERY TOP" , "AT THE VERY BOTTOM" , "ANYWHERE IN BETWEEN" + -- ). AT THE BEGINNING OF EACH TEST, THE VARIABLE WHICH_SEGMENT + -- IS UPDATED TO CONTAIN THE NEW VALUE OF THIS IDENTIFYING NUMBER + -- (FOR THE TEST ABOUT TO BEGIN): + -- + -- EXIT AT THE TOP ........ WHICH_SEGMENT = 0 + -- EXIT FROM THE MIDDLE ........ WHICH_SEGMENT = 1 + -- EXIT AT THE BOTTOM ........ WHICH_SEGMENT = 2 . + -- + -- + -- WITHIN EACH SECTION, THE TESTS ARE NUMBERED FROM 1 TO 30 + -- (26 FOR 'CHARACTER'). THIS NUMBER IS STORED IN THE INTEGER + -- VARIABLE INT_I (EQUAL TO THE CURRENT VALUE OF THE OUTER-LOOP + -- INDEX WHEN THAT INDEX IS OF INTEGER TYPE), WHOSE APPROPRIATE VALUE + -- FOR EACH TEST IS SET AT THE BEGINNING OF THE TEST. + -- + -- + -- AS PART OF THE EVALUATION PROCESS, THE PROGRAM COMPUTES FOR EACH + -- TEST (I.E. FOR EACH VALUE OF I , OR OF INT_I ) THE APPROPRIATE + -- NUMBER OF INNER-LOOP ITERATIONS REQUIRED BEFORE EXIT; THIS IS + -- THE EXPECTED VALUE OF J (EXPRESSED AS AN INTEGER IN THE RANGE + -- 1..10 ) AND STORES IT IN EXPECTED_J . FOR EACH OF THE THREE + -- SECTIONS, THE TIME SEQUENCE OF THESE 30 VALUES IS + -- + -- 1 2 3 4 5 6 7 8 9 10 << SEGMENT 1 >> + -- 6 6 7 7 8 8 9 9 10 10 << SEGMENT 2 >> + -- 7 8 8 8 9 9 9 10 10 10 << SEGMENT 3 >> + -- + -- (EACH SECTION GETS ALL 3 ROWS, NOT ONE ROW PER SECTION; + -- FOR 'CHARACTER', WHERE ONLY 26 VALUES ARE REQUIRED, THE LAST 4 + -- VALUES ARE OMITTED). THIS NUMBER IS COMPARED WITH THE ACTUAL + -- VALUE OF J (ACTUAL NUMBER OF INNER-LOOP ITERATIONS BEFORE THE + -- EXECUTION OF THE EXIT STATEMENT) AS SAVED JUST BEFORE THE EXIT + -- FROM THE LOOP (AGAIN IN THE FORM OF AN INTEGER IN THE RANGE + -- 1..30 , IRRESPECTIVE OF THE DATA TYPE BEING TESTED), I F + -- SUCH SAVED VALUE IS AVAILABLE. + -- + -- + -- THE ACTUAL VALUE OF INNER-LOOP ITERATIONS (AS SAVED IMMEDIATELY + -- BEFORE THE EXIT, AS OPPOSED TO A VALUE LEFT OVER FROM SOME + -- PREVIOUS ITERATION) IS AVAILABLE ONLY IF WHICH_SEGMENT /= 0 , + -- AND IS THEN STORED IN SAVE_J . + -- + -- + -- FOR THE CASE WHICH_SEGMENT = 0 , THE ITERATIONS ARE COUNTED IN + -- THE VARIABLE COUNT , WHOSE VALUE AT THE COMPLETION OF THE + -- I-TH TEST ( I IN 1..10 ) MUST BE EQUAL TO EXPECTED_J - 1 , + -- AND THUS TO I - 1 (METHODOLOGICALLY AS WELL AS COMPUTATIONALLY + -- THIS IS NO DIFFERENT FROM USING THE MOST RECENT VALUE OF SAVE_J + -- WHEN A CURRENT ONE CANNOT BE OBTAINED). AFTER BEING INCREMENTED + -- BY 1 , COUNT IS CHECKED AGAINST EXPECTED_J . + -- + -- + -- THIS CONCLUDES THE DESCRIPTION OF THE CASE WHICH_SEGMENT = 0 , + -- AND THUS OF THE ALGORITHM. THE ONLY REASON FOR SPLITTING THE + -- CASE WHICH_SEGMENT /= 0 INTO TWO IS THE DESIRE TO PROVIDE FOR + -- DISTINCT MESSAGES. + + + + -- RM 04/23/81 + -- SPS 3/7/83 + + WITH REPORT; + PROCEDURE C57003A IS + + USE REPORT ; + + BEGIN + + TEST( "C57003A" , "TEST THAT THE EXIT STATEMENT IS EVALUATED" & + " EACH TIME THROUGH THE LOOP" ); + + DECLARE + + WHICH_SEGMENT : INTEGER RANGE 0..2 ; -- BOUNDS ARE TIGHT + SAVE_J : INTEGER RANGE 1..10 ; + EXPECTED_J : INTEGER RANGE 1..10 ; + COUNT : INTEGER RANGE 0..100 := 0 ; + INT_I : INTEGER RANGE 1..30 ; + + TYPE ENUM IS ( CHANGE_THE_ORIGIN_FROM_0_TO_1 , + + A1 , A2 , A3 , A4 , A5 , A6 , A7 , A8 , A9 , A10 , + A11, A12, A13, A14, A15, A16, A17, A18, A19, A20 , + A21, A22, A23, A24, A25, A26, A27, A28, A29, A30 ); + + BEGIN + + + -------------------------------------------------------------- + ----------------------- INTEGER ---------------------------- + + + FOR I IN INTEGER RANGE 1..30 LOOP + + + WHICH_SEGMENT := ( I - 1 ) / 10 ; + EXPECTED_J := ( I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN INTEGER RANGE 1..10 LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + 1*J >= I ;--COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := J ; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2*J >= I ; + + NULL ; + NULL ; + NULL ; + SAVE_J := J ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3*J >= I ; + + END LOOP; + + + COUNT := COUNT + 1 ; -- SEE HEADER + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT; INT, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; I,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; I,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + + + -------------------------------------------------------------- + ---------------------- CHARACTER --------------------------- + + + FOR I IN CHARACTER RANGE 'A'..'Z' LOOP + + INT_I := CHARACTER'POS(I) - CHARACTER'POS('A') + 1; + + WHICH_SEGMENT := ( INT_I - 1 ) / 10 ; + EXPECTED_J := ( INT_I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN CHARACTER RANGE 'A'..'J' LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := CHARACTER'POS(J) - CHARACTER'POS('A') + 1; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2 * SAVE_J >= INT_I ; + + NULL ; + NULL ; + NULL ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3 * SAVE_J >= INT_I ; + + END LOOP; + + + COUNT := COUNT + 1 ; + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT;CHAR, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; C,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; C,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + + + -------------------------------------------------------------- + --------------------- ENUMERATION -------------------------- + + + FOR I IN ENUM RANGE A1..A30 LOOP + + + INT_I := ENUM'POS(I) ; + + WHICH_SEGMENT := ( INT_I - 1 ) / 10 ; + EXPECTED_J := ( INT_I + WHICH_SEGMENT ) / + ( WHICH_SEGMENT + 1 ) ; + + COUNT := 0 ; + + + FOR J IN ENUM RANGE A1..A10 LOOP + + -- J NOT SAVED HERE (SO THAT 'EXIT' BE FIRST STMT) + + EXIT WHEN WHICH_SEGMENT = 0 AND + J >= I ; -- COUNT+:=1 ON NXT LINE INSTEAD + COUNT := COUNT + 1 ; + + NULL ; + NULL ; + NULL ; + SAVE_J := ENUM'POS(J) ; + EXIT WHEN WHICH_SEGMENT = 1 AND + 2 * SAVE_J >= INT_I ; + + NULL ; + NULL ; + NULL ; + EXIT WHEN WHICH_SEGMENT = 2 AND + 3 * SAVE_J >= INT_I ; + + END LOOP; + + + COUNT := COUNT + 1 ; + + CASE WHICH_SEGMENT IS + WHEN 0 => + IF COUNT /= EXPECTED_J THEN + FAILED( "WRONG COUNT;ENUM, EXIT AT TOP" ); + END IF; + WHEN 1 => -- WOULD WORK ALSO FOR 0 + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; E,EXIT AT MIDDLE" ); + END IF; + WHEN 2 => + IF SAVE_J /= EXPECTED_J THEN + FAILED( "WRONG COUNT; E,EXIT AT BOTTOM" ); + END IF; + END CASE; + + END LOOP; + + -------------------------------------------------------------- + + END ; + + + RESULT ; + + + END C57003A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57004a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C57004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION + -- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER + -- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING + -- THE EXIT STATEMENT. + + -- CASE 1 : UNCONDITIONAL EXITS. + + + -- RM 04/24/81 + -- SPS 3/7/83 + + WITH REPORT; + PROCEDURE C57004A IS + + USE REPORT ; + + BEGIN + + TEST( "C57004A" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" & + " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" & + " SITUATED IN-BETWEEN" ); + + DECLARE + + COUNT : INTEGER := 0 ; + + BEGIN + + OUTERMOST : + FOR X IN INTEGER RANGE 1..2 LOOP + + FOR Y IN INTEGER RANGE 1..2 LOOP + + COMMENT( "BEFORE 1" ); + + LOOP1 : + FOR I IN 1..10 LOOP + COMMENT( "INSIDE 1" ); + EXIT LOOP1 ; + FAILED( "EXIT NOT OBEYED (1)" ); + FOR J IN 1..10 LOOP + FAILED( "OUTER EXIT NOT OBEYED (1)" ); + EXIT ; + FAILED( "BOTH EXITS IGNORED (1)" ); + END LOOP; + END LOOP LOOP1 ; + + + COMMENT( "BEFORE 2" ); + COUNT := COUNT + 1 ; + + LOOP2 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN CHARACTER LOOP + COMMENT( "INSIDE 2" ); + EXIT LOOP2 ; + FAILED( "EXIT NOT OBEYED (2)" ); + FOR J IN BOOLEAN LOOP + FAILED( "OUTER EXIT NOT " & + "OBEYED (2)"); + EXIT ; + FAILED( "BOTH EXITS IGNORED " & + "(2)"); + END LOOP; + END LOOP; + + END LOOP; + END LOOP LOOP2 ; + + + COMMENT( "BEFORE 3" ); + COUNT := COUNT + 1 ; + + LOOP3 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN BOOLEAN LOOP + COMMENT( "INSIDE 3" ); + BEGIN + EXIT LOOP3 ; + FAILED( "EXIT NOT OBEYED (3)" ); + END ; + FAILED( "EXIT NOT OBEYED (3BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP3 ; + + + COMMENT( "BEFORE 4" ); + COUNT := COUNT + 1 ; + + LOOP4 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + + FOR I IN INTEGER RANGE 1..10 LOOP + COMMENT( "INSIDE 4" ); + CASE A IS + WHEN 1 => + EXIT LOOP4 ; + FAILED("EXIT NOT OBEYED " & + "(4)" ); + END CASE; + FAILED( "EXIT NOT OBEYED (4BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP4 ; + + + COMMENT( "AFTER 4" ); + COUNT := COUNT + 1 ; + EXIT OUTERMOST ; + + END LOOP; + + FAILED( "MISSED FINAL EXIT" ); + + END LOOP OUTERMOST ; + + + IF COUNT /= 4 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + RESULT ; + + + END C57004A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c57004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c57004b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,162 ---- + -- C57004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXIT STATEMENT WITH A LOOP NAME TERMINATES EXECUTION + -- OF THE LOOP STATEMENT WHOSE NAME IT MENTIONS, AND OF ALL OTHER + -- LOOP STATEMENTS (IF ANY) INTERIOR TO THE FIRST LOOP AND ENCLOSING + -- THE EXIT STATEMENT. + + -- CASE 2 : CONDITIONAL EXITS. + + + -- RM 04/27/81 + -- SPS 3/7/83 + + WITH REPORT; + PROCEDURE C57004B IS + + USE REPORT ; + + BEGIN + + TEST( "C57004B" , "CHECK THAT A NAMING EXIT STATEMENT TERMINATES" & + " EXECUTION OF THE NAMED LOOP AND OF ALL LOOPS" & + " SITUATED IN-BETWEEN" ); + + DECLARE + + COUNT : INTEGER := 0 ; + + BEGIN + + OUTERMOST : + FOR X IN INTEGER RANGE 1..2 LOOP + + FOR Y IN INTEGER RANGE 1..2 LOOP + + COMMENT( "BEFORE 1" ); + + LOOP1 : + FOR I IN 1..10 LOOP + COMMENT( "INSIDE 1" ); + EXIT LOOP1 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (1)" ); + FOR J IN 1..10 LOOP + FAILED( "OUTER EXIT NOT OBEYED (1)" ); + EXIT WHEN EQUAL(1,1) ; + FAILED( "BOTH EXITS IGNORED (1)" ); + END LOOP; + END LOOP LOOP1 ; + + + COMMENT( "BEFORE 2" ); + COUNT := COUNT + 1 ; + + LOOP2 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN CHARACTER LOOP + COMMENT( "INSIDE 2" ); + EXIT LOOP2 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (2)" ); + FOR J IN BOOLEAN LOOP + FAILED( "OUTER EXIT NOT " & + "OBEYED (2)"); + EXIT WHEN EQUAL(1,1) ; + FAILED( "BOTH EXITS IGNORED " & + "(2)"); + END LOOP; + END LOOP; + + END LOOP; + END LOOP LOOP2 ; + + + COMMENT( "BEFORE 3" ); + COUNT := COUNT + 1 ; + + LOOP3 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + FOR I IN BOOLEAN LOOP + COMMENT( "INSIDE 3" ); + BEGIN + EXIT LOOP3 WHEN EQUAL(1,1) ; + FAILED( "EXIT NOT OBEYED (3)" ); + END ; + FAILED( "EXIT NOT OBEYED (3BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP3 ; + + + COMMENT( "BEFORE 4" ); + COUNT := COUNT + 1 ; + + LOOP4 : + FOR A IN 1..1 LOOP + FOR B IN 1..1 LOOP + + + FOR I IN INTEGER RANGE 1..10 LOOP + COMMENT( "INSIDE 4" ); + CASE A IS + WHEN 1 => + EXIT LOOP4 WHEN EQUAL(1,1); + FAILED("EXIT NOT OBEYED " & + "(4)" ); + END CASE; + FAILED( "EXIT NOT OBEYED (4BIS)" ); + END LOOP; + + END LOOP; + END LOOP LOOP4 ; + + + COMMENT( "AFTER 4" ); + COUNT := COUNT + 1 ; + EXIT OUTERMOST ; + + END LOOP; + + FAILED( "MISSED FINAL EXIT" ); + + END LOOP OUTERMOST ; + + + IF COUNT /= 4 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + + END ; + + + RESULT ; + + + END C57004B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C58004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS, + -- BOTH FUNCTIONS AND PROCEDURES. + + -- DCB 2/8/80 + -- SPS 3/7/83 + -- JBG 5/17/83 + + WITH REPORT; + PROCEDURE C58004C IS + + USE REPORT; + + I1, I2 : INTEGER := 0; -- INITIAL VALUE IS IMMATERIAL + + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS + + BEGIN + IF IP1 = 1 THEN + IP2 := 1; + RETURN; + ELSE FACTORIALP (IP1 - 1, IP2); + IP2 := IP1 * IP2; + RETURN; + END IF; + + IP2 := 0; + + END FACTORIALP; + + FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS + + BEGIN + IF IF1 = 1 THEN RETURN (1); + END IF; + + RETURN (IF1 * FACTORIALF(IF1 - 1) ); + + END FACTORIALF; + + BEGIN + TEST ("C58004C", "CHECK THAT THE RETURN STATEMENT WORKS FOR" & + " RECURSIVE FUNCTIONS AND PROCEDURES"); + + I1 := FACTORIALF (5); + + IF I1 /= 120 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " & + "WORKING"); + END IF; + + FACTORIALP (5, I2); + + IF I2 = 0 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " & + "WORKING"); + ELSIF I2 /= 120 THEN + FAILED + ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY"); + END IF; + + RESULT; + END C58004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004d.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C58004D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RETURN STATEMENT TERMINATES EXECUTION + -- OF THE INNERMOST ENCLOSING SUBPROGRAM. + + -- CHECKS GENERIC SUBPROGRAMS. + + -- SPS 3/7/83 + -- JRK 1/31/84 + + WITH REPORT; + PROCEDURE C58004D IS + + USE REPORT; + + I1, I2 : INTEGER; + + GENERIC + PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER); + + PROCEDURE ADDM (IA1 : IN OUT INTEGER; IA2 : IN INTEGER) IS + + GENERIC + PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER); + + PROCEDURE MULT (IM1 : IN OUT INTEGER; IM2 : IN INTEGER) IS + BEGIN + IM1 := IM1 * IM2; + + IF IM1 > 0 THEN RETURN; + END IF; + + IM1 := 0; + END MULT; + + PROCEDURE MLT IS NEW MULT; + + BEGIN + MLT (IA1, IA2); + IA1 := IA1 + IA2; + + IF IA1 > 0 THEN RETURN; + END IF; + + IA1 := 0; + END ADDM; + + PROCEDURE ADM IS NEW ADDM; + + BEGIN + TEST ("C58004D","CHECK THAT RETURN TERMINATES EXECUTION OF ONLY" & + " THE INNERMOST ENCLOSING GENERIC SUBPROGRAM"); + + I1 := 2; + I2 := 3; + ADM (I1,I2); -- SAME AS I1 := (I1 * I2) + I2 + + IF I1 = 0 THEN + FAILED ("RETURN DOES NOT TERMINATE SUBPROGRAM"); + ELSIF I1 = 6 THEN + FAILED + ("RETURN TERMINATES ALL SUBPROGRAMS NOT JUST INNERMOST"); + ELSIF I1 /= 9 THEN + FAILED ("RETURN STATEMENT NOT WORKING CORRECTLY"); + END IF; + + RESULT; + END C58004D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58004g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58004g.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C58004G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE RETURN STATEMENT WORKS FOR RECURSIVE SUBPROGRAMS, + -- BOTH FUNCTIONS AND PROCEDURES. + + -- CHECK GENERIC SUBPROGRAMS. + + -- SPS 3/7/83 + -- JBG 9/13/83 + + WITH REPORT; + PROCEDURE C58004G IS + + USE REPORT; + + I1, I2 : INTEGER := 0; + + GENERIC + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER); + + GENERIC + FUNCTION FACTORIALF (IF1: INTEGER) RETURN INTEGER; + + PROCEDURE FACTORIALP (IP1 : IN INTEGER; IP2 : IN OUT INTEGER) IS + BEGIN + IF IP1 = 1 THEN + IP2 := 1; + RETURN; + ELSE FACTORIALP (IP1 - 1, IP2); + IP2 := IP1 * IP2; + RETURN; + END IF; + + IP2 := 0; + + END FACTORIALP; + + FUNCTION FACTORIALF (IF1 : INTEGER) RETURN INTEGER IS + + BEGIN + IF IF1 = 1 THEN RETURN (1); + END IF; + + RETURN (IF1 * FACTORIALF(IF1 - 1) ); + + END FACTORIALF; + + PROCEDURE FACTP IS NEW FACTORIALP; + FUNCTION FACTF IS NEW FACTORIALF; + + BEGIN + TEST ("C58004G", "CHECK THAT THE RETURN STATEMENT WORKS FOR" & + " RECURSIVE GENERIC FUNCTIONS AND PROCEDURES"); + + I1 := FACTF (5); + + IF I1 /= 120 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE FUNCTION NOT " & + "WORKING"); + END IF; + + FACTP (5, I2); + + IF I2 = 0 THEN + FAILED ("RETURN STATEMENT IN RECURSIVE PROCEDURE NOT " & + "WORKING"); + ELSIF I2 /= 120 THEN + FAILED + ("RETURN STMT IN RECURSIVE PROCEDURE NOT WORKING CORRECTLY"); + END IF; + + RESULT; + END C58004G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- C58005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A FUNCTION IS READY TO RETURN CONTROL TO ITS INVOKER + -- THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT + -- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS + -- ARE NOT SATISFIED. + + -- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE + -- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE + -- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED + -- ELSEWHERE. + + + -- RM 05/14/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C58005A IS + + USE REPORT ; + + INTVAR : INTEGER ; + + BEGIN + + TEST( "C58005A" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" & + " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" & + " VIOLATED" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0 ; + END FN1 ; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0) ; + END FN2 ; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100) ; + BEGIN + RETURN HUNDRED - 90 ; + END FN3 ; + + BEGIN + + INTVAR := 0 ; + + BEGIN + INTVAR := FN1( 0 ) + INTVAR ; -- EXCEPTION. + FAILED( "EXCEPTION NOT RAISED - 1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" ) ; + END ; + + BEGIN + INTVAR := FN2( 1 ) + INTVAR ; -- 10+1=11 -- NO EXCEPTION. + INTVAR := INTVAR + 100 ; -- 11+100=111 + EXCEPTION + WHEN OTHERS => FAILED( "EXCEPTION RAISED - 2" ) ; + END ; + + BEGIN + INTVAR := FN2(11 ) + INTVAR ; -- EXCEPTION. + FAILED( "EXCEPTION NOT RAISED - 3" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => INTVAR := INTVAR + 10 ; -- 121 + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 3" ) ; + END ; + + BEGIN + INTVAR := FN3( 0 ) + INTVAR ;--121+10=131 --NO EXCEPTION. + INTVAR := INTVAR + 1000 ;-- 131+1000=1131 + EXCEPTION + WHEN OTHERS => FAILED( "EXCEPTION RAISED - 4" ) ; + END ; + + + END ; + + + IF INTVAR /= 1131 THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + + RESULT ; + + + END C58005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C58005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FUNCTION IS READY TO RETURN CONTROL TO ITS + -- INVOKER THE CONSTRAINTS ON THE RETURN VALUES ARE CHECKED, AND THAT + -- CONSTRAINT ERROR IS THEN RAISED IF AND ONLY IF THE CONSTRAINTS + -- ARE NOT SATISFIED. + + -- THIS TEST CHECKS THAT THE EXCEPTION IS RAISED UNDER THE APPROPRIATE + -- CONDITIONS; IT ALSO CHECKS THE IDENTITY OF THE EXCEPTION. THE + -- PRECISE MOMENT AND PLACE THE EXCEPTION IS RAISED IS TESTED + -- ELSEWHERE. + + -- SPS 3/10/83 + -- JBG 9/13/83 + -- AH 8/29/86 ADDED CALLS TO "FAILED" AFTER "IF" STATEMENTS. + + WITH REPORT; + PROCEDURE C58005B IS + + USE REPORT; + + BEGIN + + TEST( "C58005B" , "CHECK THAT EXCEPTIONS ARE RAISED BY A RETURN" & + " STATEMENT IF AND ONLY IF THE CONSTRAINTS ARE" & + " VIOLATED" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + GENERIC + FUNCTION FN1 ( X : I1 ) RETURN I2; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X; + END FN1; + + FUNCTION F1 IS NEW FN1; + + BEGIN + + BEGIN + IF F1(IDENT_INT(0)) IN I2 THEN + FAILED( "EXCEPTION NOT RAISED - 1A" ); + ELSE + FAILED( "EXCEPTION NOT RAISED - 1B" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 1" ); + END; + + BEGIN + IF F1(IDENT_INT(11)) IN I2 THEN + FAILED( "EXCEPTION NOT RAISED - 2A" ); + ELSE + FAILED( "EXCEPTION NOT RAISED - 2B" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED( "WRONG EXCEPTION RAISED - 2" ); + END; + + END; + + RESULT; + + END C58005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58005h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58005h.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,172 ---- + -- C58005H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINTS ON THE RETURN VALUE OF A FUNCTION ARE + -- SATISIFIED WHEN THE FUNCTION RETURNS CONTROL TO ITS INVOKER. + + -- THIS TESTS CHECKS FOR CONSTRAINTS ON CONSTRAINED ACCESS TYPES WITH + -- RECORD, ARRAY, PRIVATE AND LIMITED PRIVATE DESIGNATED TYPES. + + -- SPS 3/10/83 + -- RLB 6/29/01 - Repaired test to work in the face of aggressive optimizations. + -- The objects must be used, and must be tied somehow to the + -- calls to Failed. + + WITH REPORT; + USE REPORT; + PROCEDURE C58005H IS + + PACKAGE PACK IS + TYPE PV (D : NATURAL) IS PRIVATE; + TYPE LP (D : NATURAL) IS LIMITED PRIVATE; + PRIVATE + TYPE PV (D : NATURAL) IS RECORD + NULL; + END RECORD; + TYPE LP (D : NATURAL) IS RECORD + NULL; + END RECORD; + END PACK; + + USE PACK; + + TYPE ARR IS ARRAY (NATURAL RANGE <>) OF NATURAL; + TYPE REC (D : NATURAL) IS RECORD + NULL; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + TYPE ACC_ARR IS ACCESS ARR; + TYPE ACC_PV IS ACCESS PV; + TYPE ACC_LP IS ACCESS LP; + + SUBTYPE ACC_REC1 IS ACC_REC (D => 1); + SUBTYPE ACC_REC2 IS ACC_REC (D => 2); + + SUBTYPE ACC_ARR1 IS ACC_ARR (1 .. 10); + SUBTYPE ACC_ARR2 IS ACC_ARR (2 .. 5); + + SUBTYPE ACC_PV1 IS ACC_PV (D => 1); + SUBTYPE ACC_PV2 IS ACC_PV (D => 2); + + SUBTYPE ACC_LP1 IS ACC_LP (D => 1); + SUBTYPE ACC_LP2 IS ACC_LP (D => 2); + + VAR1 : ACC_REC1 := NEW REC(1); + VAR2 : ACC_REC2 := NEW REC(2); + VAA1 : ACC_ARR1 := NEW ARR(1 .. 10); + VAA2 : ACC_ARR2 := NEW ARR(2 .. 5); + VAP1 : ACC_PV1 := NEW PV(1); + VAP2 : ACC_PV2 := NEW PV(2); + VAL1 : ACC_LP1 := NEW LP(1); + VAL2 : ACC_LP2 := NEW LP(2); + + FUNCTION FREC ( X : ACC_REC1) RETURN ACC_REC2 IS + BEGIN + RETURN X; + END FREC; + + FUNCTION FARR ( X : ACC_ARR1) RETURN ACC_ARR2 IS + BEGIN + RETURN X; + END FARR; + + FUNCTION FPV ( X : ACC_PV1) RETURN ACC_PV2 IS + BEGIN + RETURN X; + END FPV; + + FUNCTION FLP ( X : ACC_LP1) RETURN ACC_LP2 IS + BEGIN + RETURN X; + END FLP; + + PACKAGE BODY PACK IS + FUNCTION LF (X : LP) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(3); + END LF; + BEGIN + NULL; + END PACK; + + BEGIN + + TEST ("C58005H", "CHECK ACCESS CONSTRAINTS ON RETURN VALUES " & + "OF FUNCTIONS"); + + BEGIN + VAR2 := FREC (VAR1); + IF VAR2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - REC 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - REC"); + END; + + BEGIN + VAA2 := FARR (VAA1); + IF VAA2'FIRST /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - ARR 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - ARR"); + END; + + BEGIN + VAP2 := FPV (VAP1); + IF VAP2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - PV 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PV"); + END; + + BEGIN + VAL2 := FLP (VAL1); + IF VAL2.D /= REPORT.IDENT_INT(2) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 1"); + ELSE + FAILED ("CONSTRAINT_ERROR NOT RAISED - LP 2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - LP"); + END; + + RESULT; + END C58005H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58006a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C58006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE EVALUATION OF A RETURN STATEMENT'S EXPRESSION + -- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF + -- THE FUNCTION. + + -- RM 05/11/81 + -- SPS 10/26/82 + -- SPS 3/8/83 + -- JBG 9/13/83 + + WITH REPORT; + PROCEDURE C58006A IS + + USE REPORT; + + BEGIN + + TEST( "C58006A" , "CHECK THAT EXCEPTION RAISED BY A RETURN" & + " STATEMENT CAN BE HANDLED LOCALLY" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F1"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN1"); + END FN1; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F2"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN2"); + END FN2; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100); + BEGIN + RETURN HUNDRED; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F3"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN3"); + END FN3; + + BEGIN + + BEGIN + IF FN1( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN1( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN1( 0 )"); + END; + + BEGIN + IF FN2( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN2( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN2( 0 )"); + END; + + BEGIN + IF FN2(11 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN2(11 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN2(11 )"); + END; + + BEGIN + IF FN3( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - FN3( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - FN3( 0 )"); + END; + + END; + + RESULT; + + END C58006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c58006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c58006b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- C58006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE EVALUATION OF A RETURN STATEMENT'S EXPRESSION + -- RAISES AN EXCEPTION, THE EXCEPTION CAN BE HANDLED WITHIN THE BODY OF + -- THE FUNCTION. + + -- CHECKS GENERIC FUNCTIONS. + + -- SPS 3/8/83 + -- JBG 9/13/83 + + WITH REPORT; + PROCEDURE C58006B IS + + USE REPORT; + + BEGIN + + TEST( "C58006B" , "CHECK THAT EXCEPTION RAISED BY A RETURN" & + " STATEMENT CAN BE HANDLED LOCALLY" ); + + + DECLARE + SUBTYPE I1 IS INTEGER RANGE -10..90; + SUBTYPE I2 IS INTEGER RANGE 1..10; + + GENERIC + FUNCTION FN1 (X : I1) RETURN I2; + + GENERIC + FUNCTION FN2 (X : I1) RETURN I2; + + GENERIC + FUNCTION FN3 (X : I1) RETURN I2; + + FUNCTION FN1( X : I1 ) + RETURN I2 IS + BEGIN + RETURN 0; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F1"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN1"); + END FN1; + + FUNCTION FN2( X : I1 ) + RETURN I2 IS + BEGIN + RETURN X + IDENT_INT(0); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F2"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN2"); + END FN2; + + FUNCTION FN3( X : I1 ) + RETURN I2 IS + HUNDRED : INTEGER RANGE -100..100 := IDENT_INT(100); + BEGIN + RETURN HUNDRED; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("EXCEPTION RAISED - F3"); + RETURN 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FN3"); + END FN3; + + FUNCTION F1 IS NEW FN1; + FUNCTION F2 IS NEW FN2; + FUNCTION F3 IS NEW FN3; + + BEGIN + + BEGIN + IF F1( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F1( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F1( 0 )"); + END; + + BEGIN + IF F2( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F2( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F2( 0 )"); + END; + + BEGIN + IF F2(11 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F2(11 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F2(11 )"); + END; + + BEGIN + IF F3( 0 ) /= IDENT_INT(1) THEN + FAILED ("NO EXCEPTION RAISED - F3( 0 )"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION PROPAGATED - F3( 0 )"); + END; + + END; + + RESULT; + + END C58006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002a.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C59002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT JUMPS OUT OF AN EXCEPTION HANDLER CONTAINED IN A BLOCK + -- TO A STATEMENT IN AN ENCLOSING UNIT ARE ALLOWED AND ARE PERFORMED + -- CORRECTLY. + + + -- RM 05/22/81 + -- SPS 3/8/83 + + WITH REPORT; + PROCEDURE C59002A IS + + USE REPORT ; + + BEGIN + + TEST( "C59002A" , "CHECK THAT JUMPS OUT OF EXCEPTION HANDLERS" & + " ARE ALLOWED" ); + + DECLARE + + FLOW : INTEGER := 1 ; + EXPON: INTEGER RANGE 0..3 := 0 ; + + BEGIN + + GOTO START ; + + FAILED( "'GOTO' NOT OBEYED" ); + + << BACK_LABEL >> + FLOW := FLOW * 3**EXPON ; -- 1*5*9 + EXPON := EXPON + 1 ; + GOTO FINISH ; + + << START >> + FLOW := FLOW * 7**EXPON ; -- 1 + EXPON := EXPON + 1 ; + + DECLARE + BEGIN + RAISE CONSTRAINT_ERROR ; + FAILED( "EXCEPTION NOT RAISED - 1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + GOTO FORWARD_LABEL ; + END ; + + FAILED( "INNER 'GOTO' NOT OBEYED - 1" ); + + << FORWARD_LABEL >> + FLOW := FLOW * 5**EXPON ; -- 1*5 + EXPON := EXPON + 1 ; + + DECLARE + BEGIN + RAISE CONSTRAINT_ERROR ; + FAILED( "EXCEPTION NOT RAISED - 2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + GOTO BACK_LABEL ; + END ; + + FAILED( "INNER 'GOTO' NOT OBETED - 2" ); + + << FINISH >> + FLOW := FLOW * 2**EXPON ; -- 1*5*9*8 + + IF FLOW /= 360 THEN + FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT ; + + + END C59002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002b.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C59002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT JUMPS OUT OF COMPOUND STATEMENTS (OTHER THAN + -- ACCEPT STATEMENTS) ARE POSSIBLE AND ARE CORRECTLY PERFORMED. + + + -- FLOW OF CONTROL: A -> B -> C -> D -> E -> F -> G -> H . + -- | | | | | | | + -- IF LOOP CASE BLOCK IF LOOP CASE + -- LOOP CASE BLOCK + + + -- A : GOTO B L111 -> L311 + -- FAILURE L121 + -- E : GOTO F L131 -> L331 + + -- FAILURE L100 + + -- C : GOTO D L211 -> L411 + -- FAILURE L221 + -- G : GOTO H L231 + + -- FAILURE L200 + + -- B : GOTO C L311 -> L211 + -- FAILURE L321 + -- F : GOTO G L331 + + -- FAILURE L300 + + -- D : GOTO E L411 -> L131 + -- FAILURE L421 + -- H : L431 -> (OUT) + + -- PRINT RESULTS + + + -- RM 06/05/81 + -- SPS 3/8/83 + + WITH REPORT; + PROCEDURE C59002B IS + + USE REPORT ; + + BEGIN + + TEST( "C59002B" , "CHECK THAT ONE CAN JUMP OUT OF COMPOUND STATE" & + "MENTS" ); + + + DECLARE + + FLOW_STRING : STRING(1..8) := "XXXXXXXX" ; + INDEX : INTEGER := 1 ; + + BEGIN + + << L111 >> + + FLOW_STRING(INDEX) := 'A' ; + INDEX := INDEX + 1 ; + + IF FALSE THEN + FAILED( "WRONG 'IF' BRANCH" ); + ELSE + GOTO L311 ; + END IF; + + << L121 >> + + FAILED( "AT L121 - WRONGLY" ); + + << L131 >> + + FLOW_STRING(INDEX) := 'E' ; + INDEX := INDEX + 1 ; + + IF FALSE THEN + FAILED( "WRONG 'IF' BRANCH" ); + ELSE + FOR J IN 1..1 LOOP + GOTO L331 ; + END LOOP; + END IF; + + << L100 >> + + FAILED( "AT L100 - WRONGLY" ); + + << L211 >> + + FLOW_STRING(INDEX) := 'C' ; + INDEX := INDEX + 1 ; + + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + GOTO L411 ; + END CASE; + + << L221 >> + + FAILED( "AT L221 - WRONGLY" ); + + << L231 >> + + FLOW_STRING(INDEX) := 'G' ; + INDEX := INDEX + 1 ; + + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + DECLARE + BEGIN + GOTO L431 ; + END ; + END CASE; + + << L200 >> + + FAILED( "AT L200 - WRONGLY" ); + + << L311 >> + + FLOW_STRING(INDEX) := 'B' ; + INDEX := INDEX + 1 ; + + FOR I IN 1..1 LOOP + GOTO L211 ; + END LOOP; + + << L321 >> + + FAILED( "AT L321 - WRONGLY" ); + + << L331 >> + + FLOW_STRING(INDEX) := 'F' ; + INDEX := INDEX + 1 ; + + FOR I IN 1..1 LOOP + CASE 2 IS + WHEN 1 => + FAILED( "WRONG 'CASE' BRANCH" ); + WHEN OTHERS => + GOTO L231 ; + END CASE; + END LOOP; + + << L300 >> + + FAILED( "AT L300 - WRONGLY" ); + + << L411 >> + + FLOW_STRING(INDEX) := 'D' ; + INDEX := INDEX + 1 ; + + DECLARE + K : INTEGER := 17 ; + BEGIN + GOTO L131 ; + END; + + << L421 >> + + FAILED( "AT L421 - WRONGLY" ); + + << L431 >> + + FLOW_STRING(INDEX) := 'H' ; + + + IF FLOW_STRING /= "ABCDEFGH" THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT ; + + + END C59002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c5/c59002c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c5/c59002c.ada 2003-10-27 11:28:52.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C59002C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT JUMPS OUT OF SELECT STATEMENTS (OTHER THAN + -- FROM INSIDE ACCEPT BODIES IN SELECT_ALTERNATIVES) + -- ARE POSSIBLE AND ARE CORRECTLY PERFORMED. + + -- THIS TEST CONTAINS SHARED VARIABLES. + + + -- RM 08/15/82 + -- SPS 12/13/82 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; + WITH SYSTEM; + USE SYSTEM; + PROCEDURE C59002C IS + + USE REPORT ; + + FLOW_STRING : STRING(1..2) := "XX" ; + INDEX : INTEGER := 1 ; + + + BEGIN + + TEST( "C59002C" , "CHECK THAT ONE CAN JUMP OUT OF SELECT STATE" & + "MENTS" ); + + ------------------------------------------------------------------- + + DECLARE + + TASK T IS + + + ENTRY E1 ; + ENTRY E2 ; + END T ; + + TASK BODY T IS + BEGIN + + WHILE E2'COUNT <= 0 LOOP + DELAY 1.0 ; + END LOOP; + + SELECT + ACCEPT E1 DO + FAILED( " E1 ACCEPTED; NO ENTRY CALL (1)" ); + END ; + OR + ACCEPT E2 ; + GOTO L123 ; + FAILED( "'GOTO' NOT OBEYED (1)" ); + OR + DELAY 10.0 ; + FAILED( "DELAY ALTERNATIVE SELECTED (1)" ); + END SELECT; + + FAILED( "WRONG DESTINATION FOR 'GOTO' (1)" ); + + << L123 >> + + FLOW_STRING(INDEX) := 'A' ; + INDEX := INDEX + 1 ; + + END T; + + BEGIN + + T.E2 ; + + END; + + ------------------------------------------------------------------- + + DECLARE + + TASK T IS + ENTRY E1 ; + ENTRY E2 ; + END T ; + + TASK BODY T IS + BEGIN + + SELECT + ACCEPT E1 DO + FAILED( " E1 ACCEPTED; NO ENTRY CALL (2)" ); + END ; + OR + ACCEPT E2 DO + FAILED( " E2 ACCEPTED; NO ENTRY CALL (2)" ); + END ; + OR + DELAY 10.0 ; + GOTO L321 ; + FAILED( "'GOTO' NOT OBEYED (2)" ); + END SELECT; + + FAILED( "WRONG DESTINATION FOR 'GOTO' (2)" ); + + << L321 >> + + FLOW_STRING(INDEX) := 'B' ; + INDEX := INDEX + 1 ; + + END T; + + BEGIN + + NULL ; + + END; + + ------------------------------------------------------------------- + + IF FLOW_STRING /= "AB" THEN + FAILED("WRONG FLOW OF CONTROL" ); + END IF; + + + RESULT ; + + + END C59002C ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61008a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- C61008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF THE DEFAULT VALUE + -- FOR A FORMAL PARAMETER DOES NOT SATISFY THE CONSTRAINTS OF THE + -- SUBTYPE_INDICATION WHEN THE DECLARATION IS ELABORATED, ONLY WHEN + -- THE DEFAULT IS USED. + + -- SUBTESTS ARE: + -- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND + -- INITIALIZED WITH A STATIC AGGREGATE. + -- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS + -- INITIALIZED WITH A STATIC VALUE. + -- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC + -- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + -- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- + -- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + -- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT + -- INITIALIZED WITH A STATIC AGGREGATE. + + -- DAS 1/20/81 + -- SPS 10/26/82 + -- VKG 1/13/83 + -- SPS 2/9/83 + -- BHS 7/9/84 + + WITH REPORT; + PROCEDURE C61008A IS + + USE REPORT; + + BEGIN + + TEST ("C61008A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER"); + + -------------------------------------------------- + + DECLARE -- (A) + + PROCEDURE PA (I1, I2 : INTEGER) IS + + TYPE A1 IS ARRAY (1..I1,1..I2) OF INTEGER; + + PROCEDURE PA1 (A : A1 := ((1,0),(0,1))) IS + BEGIN + FAILED ("BODY OF PA1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PA1"); + END PA1; + + BEGIN + PA1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PA1"); + END PA; + + BEGIN -- (A) + PA (IDENT_INT(1), IDENT_INT(10)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO PA"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PROCEDURE PB (I1, I2 : INTEGER) IS + + SUBTYPE INT IS INTEGER RANGE I1..I2; + + PROCEDURE PB1 (I : INT := -1) IS + BEGIN + FAILED ("BODY OF PB1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PB1"); + END PB1; + + BEGIN + PB1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PB1"); + END PB; + + BEGIN -- (B) + PB (IDENT_INT(0), IDENT_INT(63)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO PB"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PROCEDURE PC (I1, I2 : INTEGER) IS + TYPE AR1 IS ARRAY (1..3) OF INTEGER RANGE I1..I2; + TYPE REC IS + RECORD + I : INTEGER RANGE I1..I2; + A : AR1 ; + END RECORD; + + PROCEDURE PC1 (R : REC := (-3,(0,2,3))) IS + BEGIN + FAILED ("BODY OF PC1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PC1"); + END PC1; + + BEGIN + PC1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PC1"); + END PC; + + BEGIN -- (C) + PC (IDENT_INT(1), IDENT_INT(3)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO PC"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D1) + + PROCEDURE P1D (I1, I2 : INTEGER) IS + + TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2; + + PROCEDURE P1D1 (A : A1 := ((1,-1),(1,2))) IS + BEGIN + FAILED ("BODY OF P1D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P1D1"); + END P1D1; + + BEGIN + P1D1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - P1D1"); + END P1D; + + BEGIN -- (D1) + P1D (IDENT_INT(1), IDENT_INT(2)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO P1D"); + END; -- (D1) + + -------------------------------------------------- + + DECLARE -- (D2) + + PROCEDURE P2D (I1, I2 : INTEGER) IS + + TYPE A1 IS ARRAY (1..2,1..2) OF INTEGER RANGE I1..I2; + + PROCEDURE P2D1 (A : A1 := (3..4 => (1,2))) IS + BEGIN + FAILED ("BODY OF P2D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P2D1"); + END P2D1; + + BEGIN + P2D1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - P2D1"); + END P2D; + + BEGIN -- (D2) + P2D (IDENT_INT(1), IDENT_INT(2)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO P2D"); + END; -- (D2) + + -------------------------------------------------- + + DECLARE -- (E) + + PROCEDURE PE (I1, I2 : INTEGER) IS + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE ARR IS ARRAY (1..3) OF INT; + TYPE REC (I : INT) IS + RECORD + A : ARR; + END RECORD; + + SUBTYPE REC4 IS REC(I1); + + PROCEDURE PE1 (R : REC4 := (3,(1,2,3))) IS + BEGIN + FAILED ("BODY OF PE1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PE1"); + END PE1; + + BEGIN + PE1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PE1"); + END PE; + + BEGIN -- (E) + PE (IDENT_INT(4), IDENT_INT(10)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN CALL TO PE"); + END; -- (E) + + -------------------------------------------------- + + RESULT; + + END C61008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61009a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C61009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME, + -- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER- + -- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION + -- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE + -- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE SUBPROGRAM + -- IS CALLED. + + -- DAS 1/21/81 + -- ABW 7/20/82 + -- SPS 12/10/82 + + WITH REPORT; + PROCEDURE C61009A IS + + USE REPORT; + + TYPE INT IS RANGE 1 .. 10; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + A : ARR (0..CONSTRAINT); + END RECORD; + + C7 : CONSTANT INTEGER := 7; + V7 : INTEGER := 7; + + TYPE A_INT IS ACCESS INTEGER; + C_A : CONSTANT A_INT := NEW INTEGER'(7); + + SUBTYPE RECTYPE1 IS RECTYPE (2 + 5); + SUBTYPE RECTYPE2 IS RECTYPE (C7); + SUBTYPE RECTYPE3 IS RECTYPE (V7); + + FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 10; + END "&"; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END FUNC; + + -- STATIC EXPRESSION + + PROCEDURE PROC1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) IS + BEGIN + IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC1 PARAMETER"); + END IF; + END PROC1; + + -- CONSTANT NAME + + PROCEDURE PROC2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) IS + BEGIN + IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC2 PARAMETER"); + END IF; + END PROC2; + + -- ATTRIBUTE NAME + + PROCEDURE PROC3 (P1 : INT := INT'LAST) IS + BEGIN + IF (P1 /= INT (10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC3 PARAMETER"); + END IF; + END PROC3; + + -- VARIABLE + + PROCEDURE PROC4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) IS + BEGIN + IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC4 PARAMETER"); + END IF; + END PROC4; + + --DEREFERENCED ACCESS + + PROCEDURE PROC5 (P5 : INTEGER := C_A.ALL) IS + BEGIN + IF(P5 /= C_A.ALL) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC5 PARAMETER"); + END IF; + END PROC5; + + --USER-DEFINED OPERATOR + + PROCEDURE PROC6 (P6 : INTEGER := 6&4) IS + BEGIN + IF (P6 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC6 PARAMETER"); + END IF; + END PROC6; + + --USER-DEFINED FUNCTION + + PROCEDURE PROC7 (P7 : INTEGER := FUNC(10)) IS + BEGIN + IF (P7 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC7 PARAMETER"); + END IF; + END PROC7; + + -- ALLOCATOR + + PROCEDURE PROC8 (P8 : A_INT := NEW INTEGER'(7)) IS + BEGIN + IF (P8.ALL /= IDENT_INT(7)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR PROC8 PARAMETER"); + END IF; + END PROC8; + + BEGIN + TEST ("C61009A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " & + "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " & + "DEFINED OPERATORS, USER-DEFINED FUNCTIONS " & + "DEREFERENCED ACCESSES, AND ALLOCATORS IN " & + "THE FORMAL PART OF A SUBPROGRAM SPECIFICATION"); + + PROC1; + PROC2; + PROC3; + PROC4; + PROC5; + PROC6; + PROC7; + PROC8; + + RESULT; + + END C61009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c61010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c61010a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,246 ---- + -- C61010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN IN OR IN OUT FORMAL PARAMETER CAN BE DECLARED WITH A + -- LIMITED PRIVATE TYPE OR A LIMITED COMPOSITE TYPE. + + -- DAS 1/22/81 + -- JRK 1/20/84 TOTALLY REVISED. + + WITH REPORT; USE REPORT; + PROCEDURE C61010A IS + + PACKAGE PKG IS + + TYPE ITYPE IS LIMITED PRIVATE; + + PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER; + M : STRING); + + PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER); + + SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20; + TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE; + + PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING); + + PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING); + + PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER; + S : STRING); + + PRIVATE + + TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99; + + TYPE VRTYPE (C : INT_0_20 := 20) IS + RECORD + I : INTEGER; + S : STRING (1 .. C); + END RECORD; + + END PKG; + + USE PKG; + + I1 : ITYPE; + + TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE; + + A1 : ATYPE; + + VR1 : VRTYPE; + + D : CONSTANT INT_0_20 := 10; + + TYPE RTYPE IS + RECORD + J : ITYPE; + R : VRTYPE (D); + END RECORD; + + R1 : RTYPE; + + PACKAGE BODY PKG IS + + PROCEDURE LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS + BEGIN + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_IN_I; + + PROCEDURE LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER; + M : STRING) IS + BEGIN + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_INOUT_I; + + PROCEDURE SET_I (X : IN OUT ITYPE; V : INTEGER) IS + BEGIN + X := ITYPE (IDENT_INT (V)); + END SET_I; + + PROCEDURE LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING) IS + BEGIN + IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & M); + END IF; + END LOOK_IN_VR; + + PROCEDURE LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING) IS + BEGIN + IF (X.C /= C OR X.I /= I) OR ELSE X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & M); + END IF; + END LOOK_INOUT_VR; + + PROCEDURE SET_VR (X : IN OUT VRTYPE; C : INTEGER; I : INTEGER; + S : STRING) IS + BEGIN + X := (IDENT_INT(C), IDENT_INT(I), IDENT_STR(S)); + END SET_VR; + + BEGIN + I1 := ITYPE (IDENT_INT(2)); + + FOR I IN A1'RANGE LOOP + A1 (I) := ITYPE (3 + IDENT_INT(I)); + END LOOP; + + VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234")); + + R1.J := ITYPE (IDENT_INT(6)); + R1.R := (IDENT_INT(D), IDENT_INT(19), + IDENT_STR("ABCDEFGHIJ")); + END PKG; + + PROCEDURE CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) IS + BEGIN + LOOK_IN_I (X, V, M); + END CHECK_IN_I; + + PROCEDURE CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING) IS + BEGIN + LOOK_INOUT_I (X, OV, M & " - A"); + SET_I (X, NV); + LOOK_INOUT_I (X, NV, M & " - B"); + LOOK_IN_I (X, NV, M & " - C"); + END CHECK_INOUT_I; + + PROCEDURE CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) IS + BEGIN + FOR I IN X'RANGE LOOP + LOOK_IN_I (X(I), V+I, M & " -" & INTEGER'IMAGE (I)); + END LOOP; + END CHECK_IN_A; + + PROCEDURE CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING) IS + BEGIN + FOR I IN X'RANGE LOOP + LOOK_INOUT_I (X(I), OV+I, M & " - A" & + INTEGER'IMAGE (I)); + SET_I (X(I), NV+I); + LOOK_INOUT_I (X(I), NV+I, M & " - B" & + INTEGER'IMAGE (I)); + LOOK_IN_I (X(I), NV+I, M & " - C" & INTEGER'IMAGE (I)); + END LOOP; + END CHECK_INOUT_A; + + PROCEDURE CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING) IS + BEGIN + LOOK_IN_VR (X, C, I, S, M); + END CHECK_IN_VR; + + PROCEDURE CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; OS : STRING; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING) IS + BEGIN + LOOK_INOUT_VR (X, OC, OI, OS, M & " - A"); + SET_VR (X, NC, NI, NS); + LOOK_INOUT_VR (X, NC, NI, NS, M & " - B"); + LOOK_IN_VR (X, NC, NI, NS, M & " - C"); + END CHECK_INOUT_VR; + + PROCEDURE CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING) IS + BEGIN + LOOK_IN_I (X.J, J, M & " - A"); + LOOK_IN_VR (X.R, C, I, S, M & " - B"); + END CHECK_IN_R; + + PROCEDURE CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING) IS + BEGIN + LOOK_INOUT_I (X.J, OJ, M & " - A"); + LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B"); + SET_I (X.J, NJ); + SET_VR (X.R, NC, NI, NS); + LOOK_INOUT_I (X.J, NJ, M & " - C"); + LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D"); + LOOK_IN_I (X.J, NJ, M & " - E"); + LOOK_IN_VR (X.R, NC, NI, NS, M & " - F"); + END CHECK_INOUT_R; + + BEGIN + TEST ("C61010A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " & + "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS"); + + CHECK_IN_I (I1, 2, "IN I"); + + CHECK_INOUT_I (I1, 2, 5, "INOUT I"); + + CHECK_IN_A (A1, 3, "IN A"); + + CHECK_INOUT_A (A1, 3, 17, "INOUT A"); + + CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR"); + + CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210", + "INOUT VR"); + + CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R"); + + CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, "ZYXWVUTSRQ", + "INOUT R"); + + RESULT; + END C61010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,190 ---- + -- C62002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE COMPONENTS OF ACCESS IN PARAMETERS CAN BE USED AS THE + -- TARGET OF AN ASSIGNMENT STATEMENT OR AS AN ACTUAL PARAMETER OF + -- ANY MODE. SUBTESTS ARE: + -- (A) INTEGER ACCESS TYPE. + -- (B) ARRAY ACCESS TYPE. + -- (C) RECORD ACCESS TYPE. + + -- DAS 1/23/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C62002A IS + + USE REPORT; + + BEGIN + + TEST ("C62002A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS" & + " MAY BE USED IN ASSIGNMENT CONTEXTS"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE PTRINT IS ACCESS INTEGER; + PI : PTRINT; + + PROCEDURE PROCA (PI : IN PTRINT) IS + + PROCEDURE PROCA1 (I : OUT INTEGER) IS + BEGIN + I := 7; + END PROCA1; + + PROCEDURE PROCA2 (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END PROCA2; + BEGIN + + PROCA1 (PI.ALL); + PROCA2 (PI.ALL); + PI.ALL := PI.ALL + 1; + IF (PI.ALL /= 9) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF INTEGER" & + " ACCESS PARAMETER FAILED"); + END IF; + END PROCA; + + BEGIN -- (A) + + PI := NEW INTEGER '(0); + PROCA (PI); + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + TYPE TBL IS ARRAY (1..3) OF INTEGER; + TYPE PTRTBL IS ACCESS TBL; + PT : PTRTBL; + + PROCEDURE PROCB (PT : IN PTRTBL) IS + + PROCEDURE PROCB1 (I : OUT INTEGER) IS + BEGIN + I := 7; + END PROCB1; + + PROCEDURE PROCB2 (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END PROCB2; + + PROCEDURE PROCB3 (T : OUT TBL) IS + BEGIN + T := (1,2,3); + END PROCB3; + + PROCEDURE PROCB4 (T : IN OUT TBL) IS + BEGIN + T(3) := T(3) - 1; + END PROCB4; + + BEGIN + + PROCB3 (PT.ALL); -- (1,2,3) + PROCB4 (PT.ALL); -- (1,2,2) + PROCB1 (PT(2)); -- (1,7,2) + PROCB2 (PT(1)); -- (2,7,2) + PT(3) := PT(3) + 7; -- (2,7,9) + IF (PT.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF ARRAY" & + " ACCESS PARAMETER FAILED"); + END IF; + END PROCB; + + BEGIN -- (B) + + PT := NEW TBL '(0,0,0); + PROCB (PT); + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + TYPE REC IS + RECORD + I1 : INTEGER; + I2 : INTEGER; + I3 : INTEGER; + END RECORD; + TYPE PTRREC IS ACCESS REC; + PR : PTRREC; + + PROCEDURE PROCC (PR : IN PTRREC) IS + + PROCEDURE PROCC1 (I : OUT INTEGER) IS + BEGIN + I := 7; + END PROCC1; + + PROCEDURE PROCC2 (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END PROCC2; + + PROCEDURE PROCC3 (R : OUT REC) IS + BEGIN + R := (1,2,3); + END PROCC3; + + PROCEDURE PROCC4 (R : IN OUT REC) IS + BEGIN + R.I3 := R.I3 - 1; + END PROCC4; + + BEGIN + + PROCC3 (PR.ALL); -- (1,2,3) + PROCC4 (PR.ALL); -- (1,2,2) + PROCC1 (PR.I2); -- (1,7,2) + PROCC2 (PR.I1); -- (2,7,2) + PR.I3 := PR.I3 + 7; -- (2,7,9) + IF (PR.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF RECORD" & + " ACCESS PARAMETER FAILED"); + END IF; + END PROCC; + + BEGIN -- (C) + + PR := NEW REC '(0,0,0); + PROCC (PR); + + END; -- (C) + + --------------------------------------------- + + RESULT; + + END C62002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62003a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C62003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED. + -- SUBTESTS ARE: + -- (A) SCALAR PARAMETERS TO PROCEDURES. + -- (B) SCALAR PARAMETERS TO FUNCTIONS. + -- (C) ACCESS PARAMETERS TO PROCEDURES. + -- (D) ACCESS PARAMETERS TO FUNCTIONS. + + -- DAS 01/14/80 + -- SPS 10/26/82 + -- CPP 05/25/84 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + + WITH REPORT; + PROCEDURE C62003A IS + + USE REPORT; + + BEGIN + TEST ("C62003A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " & + "COPIED"); + + -------------------------------------------------- + + DECLARE -- (A) + + I : INTEGER; + E : EXCEPTION; + + PROCEDURE P (PI : IN INTEGER; PO : OUT INTEGER; + PIO : IN OUT INTEGER) IS + + TMP : INTEGER; + + BEGIN + + TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY. + + PO := 10; + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := PI; -- RESET TMP FOR NEXT CASE. + END IF; + + PIO := PIO + 100; + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := PI; -- RESET TMP FOR NEXT CASE. + END IF; + + I := I + 1; + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO SCALAR ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + BEGIN -- (A) + I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED. + P (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + EXCEPTION + WHEN E => + IF (I /= 1) THEN + CASE I IS + WHEN 11 => + FAILED ("OUT ACTUAL SCALAR PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL SCALAR " & + "PARAMETERS CHANGED GLOBAL " & + "VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO GLOBAL " & + "VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I,J : INTEGER; + + FUNCTION F (FI : IN INTEGER) RETURN INTEGER IS + + TMP : INTEGER := FI; + + BEGIN + + I := I + 1; + IF (FI /= TMP) THEN + FAILED ("ASSIGNMENT TO SCALAR ACTUAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (100); + END F; + + BEGIN -- (B) + I := 100; + J := F(I); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + TYPE ACCTYPE IS ACCESS INTEGER; + + I : ACCTYPE; + E : EXCEPTION; + + PROCEDURE P (PI : IN ACCTYPE; PO : OUT ACCTYPE; + PIO : IN OUT ACCTYPE) IS + + TMP : ACCTYPE; + + BEGIN + + TMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY. + + I := NEW INTEGER'(101); + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO ACCESS ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := PI; -- RESET TMP FOR NEXT CASE. + END IF; + + PO := NEW INTEGER'(1); + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := PI; -- RESET TMP FOR NEXT CASE. + END IF; + + PIO := NEW INTEGER'(10); + IF (PI /= TMP) THEN + FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + BEGIN -- (C) + I := NEW INTEGER'(100); + P (I, I, I); + FAILED ("EXCEPTION NOT RAISED - C"); + EXCEPTION + WHEN E => + IF (I.ALL /= 101) THEN + FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - C"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE ACCTYPE IS ACCESS INTEGER; + + I,J : ACCTYPE; + + FUNCTION F (FI : IN ACCTYPE) RETURN ACCTYPE IS + + TMP : ACCTYPE := FI; + + BEGIN + + I := NEW INTEGER; + IF (FI /= TMP) THEN + FAILED ("ASSIGNMENT TO ACCESS ACTUAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (NULL); + END F; + + BEGIN -- (D) + I := NULL; + J := F(I); + END; -- (D) + + -------------------------------------------------- + + RESULT; + + END C62003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62003b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,301 ---- + -- C62003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE + -- PASSED BY COPY. + -- SUBTESTS ARE: + -- (A) PRIVATE SCALAR PARAMETERS TO PROCEDURES. + -- (B) PRIVATE SCALAR PARAMETERS TO FUNCTIONS. + -- (C) PRIVATE ACCESS PARAMETERS TO PROCEDURES. + -- (D) PRIVATE ACCESS PARAMETERS TO FUNCTIONS. + + -- CPP 05/25/84 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C62003B IS + + BEGIN + TEST("C62003B", "CHECK THAT PRIVATE SCALAR AND ACCESS " & + "PARAMETERS ARE COPIED"); + + --------------------------------------------------- + + A_B: DECLARE + + PACKAGE SCALAR_PKG IS + + TYPE T IS PRIVATE; + C0 : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T; + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER; + + PRIVATE + TYPE T IS NEW INTEGER; + C0 : CONSTANT T := 0; + C1 : CONSTANT T := 1; + C10 : CONSTANT T := 10; + C100 : CONSTANT T := 100; + + END SCALAR_PKG; + + + PACKAGE BODY SCALAR_PKG IS + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS + BEGIN -- "+" + RETURN T(INTEGER(OLD) + INTEGER(INCREMENT)); + END "+"; + + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS + BEGIN -- CONVERT + RETURN INTEGER(OLD_PRIVATE); + END CONVERT; + + END SCALAR_PKG; + + USE SCALAR_PKG; + + --------------------------------------------------- + + BEGIN -- A_B + + A : DECLARE + + I : T; + E : EXCEPTION; + + PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS + + TEMP : T; + + BEGIN -- P + + TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY. + + PO := C10; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TEMP := PI; -- RESET TEMP FOR NEXT CASE. + END IF; + + PIO := PIO + C100; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) IN " & + "OUT PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TEMP := PI; -- RESET TEMP FOR NEXT CASE. + END IF; + + I := I + C1; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " & + "ACTUAL PARAMETER CHANGES THE " & + "VALUE OF INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + BEGIN -- A + I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE + -- DETECTED. + P (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + EXCEPTION + WHEN E => + IF (I /= C1) THEN + CASE CONVERT(I) IS + WHEN 11 => + FAILED ("OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL " & + "PRIVATE (SCALAR) " & + "PARAMETER CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END A; + + --------------------------------------------------- + + B : DECLARE + + I, J : T; + + FUNCTION F (FI : IN T) RETURN T IS + + TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY. + + BEGIN -- F + + I := I + C1; + IF (FI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (SCALAR) " & + "ACTUAL FUNCTION PARAMETER CHANGES " & + "THE VALUE OF INPUT PARAMETER "); + END IF; + + RETURN C0; + END F; + + BEGIN -- B + I := C0; + J := F(I); + END B; + + END A_B; + + --------------------------------------------------- + + C_D: DECLARE + + PACKAGE ACCESS_PKG IS + + TYPE T IS PRIVATE; + C_NULL : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + C101 : CONSTANT T; + + PRIVATE + TYPE T IS ACCESS INTEGER; + C_NULL : CONSTANT T := NULL; + C1 : CONSTANT T := NEW INTEGER'(1); + C10 : CONSTANT T := NEW INTEGER'(10); + C100 : CONSTANT T := NEW INTEGER'(100); + C101 : CONSTANT T := NEW INTEGER'(101); + + END ACCESS_PKG; + + USE ACCESS_PKG; + + --------------------------------------------------- + + BEGIN -- C_D; + + C : DECLARE + + I : T; + E : EXCEPTION; + PROCEDURE P (PI : IN T; PO : OUT T; PIO : IN OUT T) IS + + TEMP : T; + + BEGIN -- P + + TEMP := PI; -- SAVE VALUE OF PI AT PROC ENTRY. + + I := C101; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) " & + "ACTUAL VARIABLE CHANGES THE VALUE " & + "OF INPUT PARAMETER"); + TEMP := PI; -- RESET TEMP FOR NEXT CASE. + END IF; + + PO := C1; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TEMP := PI; -- RESET TEMP FOR NEXT CASE. + END IF; + + PIO := C10; + IF (PI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE (ACCESS) IN " & + "OUT PARAMETER CHANGES THE VALUE " & + "OF INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + BEGIN -- C + I := C100; + P (I, I, I); + FAILED ("EXCEPTION NOT RAISED - C"); + EXCEPTION + WHEN E => + IF (I /= C101) THEN + FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - C"); + END C; + + --------------------------------------------------- + + D : DECLARE + + I, J : T; + + FUNCTION F (FI : IN T) RETURN T IS + + TEMP : T := FI; -- SAVE VALUE OF FI AT FN ENTRY. + + BEGIN -- F + I := C100; + IF (FI /= TEMP) THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) ACTUAL FUNCTION " & + "PARAMETER CHANGES THE VALUE " & + "OF INPUT PARAMETER"); + END IF; + RETURN C_NULL; + END F; + + BEGIN -- D + I := C_NULL; + J := F(I); + END D; + + END C_D; + + --------------------------------------------------- + + RESULT; + + END C62003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62004a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C62004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES, + -- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE + -- IDENTICAL ARGUMENTS. (NOTE: ALIASING MAY NOT WORK FOR ARGUMENTS + -- TO ALL SUBROUTINES SINCE PARAMETER PASSING IS IMPLEMENTATION + -- DEPENDENT. HOWEVER, THIS TEST IS NOT ERRONEOUS.) + + -- DAS 1/26/81 + + WITH REPORT; + PROCEDURE C62004A IS + + USE REPORT; + + TYPE MATRIX IS ARRAY (1..3,1..3) OF INTEGER; + + A : MATRIX := ((1,2,3),(4,5,6),(7,8,9)); + + PROCEDURE MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) IS + BEGIN + FOR I IN 1..3 LOOP + FOR J IN 1..3 LOOP + SUM(I,J) := X(I,J) + Y(I,J); + END LOOP; + END LOOP; + END MAT_ADD; + + BEGIN + + TEST ("C62004A", "CHECK THAT ALIASING IS PERMITTED FOR" & + " PARAMETERS OF COMPOSITE TYPES"); + + MAT_ADD (A, A, A); + + IF (A /= ((2,4,6),(8,10,12),(14,16,18))) THEN + FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT"); + END IF; + + RESULT; + + END C62004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c62006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c62006a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C62006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL PARAMETER, AS WELL AS + -- THE DISCRIMINANTS OF THE SUBCOMPONENTS OF AN OUT FORMAL PARAMETER, + -- MAY BE READ INSIDE THE PROCEDURE. + + -- SPS 2/17/84 + + WITH REPORT; USE REPORT; + PROCEDURE C62006A IS + BEGIN + + TEST ("C62006A", "CHECK THAT THE DISCRIMINANTS OF AN OUT FORMAL " & + "PARAMETER CAN BE READ INSIDE THE PROCEDURE"); + + DECLARE + + TYPE R1 (D1 : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE R2 (D2 : POSITIVE) IS RECORD + C : R1 (2); + END RECORD; + + R : R2 (5); + + PROCEDURE P (REC : OUT R2) IS + BEGIN + + IF REC.D2 /= 5 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" & + " OUT PARAMETER"); + END IF; + + IF REC.C.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + " OF THE SUBCOMPONENT OF AN OUT PARAMETER"); + END IF; + END P; + + BEGIN + P (R); + END; + + RESULT; + + END C62006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c631001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c631001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c631001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c631001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C631001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if different forms of a name are used in the default + -- expression of a discriminant part, the selector may be an operator + -- symbol or a character literal. + -- + -- TEST DESCRIPTION: + -- This transition test defines private types where their selectors in + -- the default expression of the discriminant parts at the full type + -- declarations are an operator and a literal, respectively. + -- The test also declares procedures that use an operator and a literal + -- as selectors in the formal parts. + -- + -- Inspired by B63102A.ADA. + -- + -- + -- CHANGE HISTORY: + -- 25 Mar 96 SAIC Initial version for ACVC 2.1. + -- 26 Feb 97 PWB.CTA Removed use of function called before elaboration + --! + + with Report; + + procedure C631001 is + + package C631001_0 is + + type Int_Type is range 1 .. 100; + type Enu_Type is ('A', 'B', 'C', 'D'); + + type Private_Enu (D : Enu_Type := 'B') is private; + + function "+" (X, Y : Int_Type) return Int_Type; + + procedure Int_Proc (P1 : in Int_Type := "+" (10, 15); + P2 : out Int_Type); + + procedure Enu_Proc (P1 : in Enu_Type := 'C'; + P2 : out Enu_Type); + + private + + type Private_Enu (D : Enu_Type := C631001_0.'B') is -- OK. + record + C2 : Enu_Type := D; + end record; + + ----------------------------------------------------------------- + PE_Obj : C631001_0.Private_Enu; + + end C631001_0; + + --==================================================================-- + + package body C631001_0 is + + function "+" (X, Y : Int_Type) return Int_Type is + begin + return 10; + end "+"; + + ----------------------------------------------------------------- + procedure Int_Proc (P1 : in Int_Type := C631001_0."+" (10, 15); -- OK. + P2 : out Int_Type) is + + begin + P2 := P1; + end Int_Proc; + + ----------------------------------------------------------------- + procedure Enu_Proc (P1 : in Enu_Type := C631001_0.'C'; -- OK. + P2 : out Enu_Type) is + begin + P2 := P1; + end Enu_Proc; + + ----------------------------------------------------------------- + + end C631001_0; + + --------------------------------------------------------------------------- + Int_Obj : C631001_0.Int_Type := 50; + Enu_Obj : C631001_0.Enu_Type := C631001_0.'D'; + + -- Direct visibility to operator symbols + use type C631001_0.Int_Type; + use type C631001_0.Enu_Type; + + begin -- main + + Report.Test ("C631001", "Check that if different forms of a name are " & + "used in the default expression of a discriminant part, " & + "the selector may be an operator symbol or a character " & + "literal"); + + C631001_0.Int_Proc (P2 => Int_Obj); + + if Int_Obj /= 10 then + Report.Failed ("Wrong result for Int_Obj"); + end if; + + C631001_0.Enu_Proc (P2 => Enu_Obj); + + if Enu_Obj /= 'C' then + Report.Failed ("Wrong result for Enu_Obj"); + end if; + + Report.Result; + + end C631001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c640001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c640001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c640001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c640001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- C640001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the prefix of a subprogram call with an actual parameter + -- part may be an implicit dereference of an access-to-subprogram value. + -- Check that, for an access-to-subprogram type whose designated profile + -- contains parameters of a tagged generic formal type, an access-to- + -- subprogram value may designate dispatching and non-dispatching + -- operations, and that dereferences of such a value call the appropriate + -- subprogram. + -- + -- TEST DESCRIPTION: + -- The test declares a tagged type (Table) with a dispatching operation + -- (Clear), as well as a derivative (Table2) which overrides that + -- operation. A subprogram with the same name and profile as Clear is + -- declared in a separate package -- it is therefore not a dispatching + -- operation of Table. For the purposes of the test, each version of Clear + -- modifies the components of its parameter in a unique way. + -- + -- Additionally, an operation (Reset) of type Table is declared which + -- makes a re-dispatching call to Clear, i.e., + -- + -- procedure Reset (A: in out Table) is + -- begin + -- ... + -- Clear (Table'Class(A)); -- Re-dispatch based on tag of actual. + -- ... + -- end Reset; + -- + -- An access-to-subprogram type is declared within a generic package, + -- with a designated profile which declares a parameter of a generic + -- formal tagged private type. + -- + -- The generic is instantiated with type Table. The instance defines an + -- array of access-to-subprogram values (which represents a table of + -- operations to be performed sequentially on a single operand). + -- Access values designating the dispatching version of Clear, the + -- non-dispatching version of Clear, and Reset (which re-dispatches to + -- Clear) are placed in this array. + -- + -- In the instance, each subprogram in the array is called by implicitly + -- dereferencing the corresponding access value. For the dispatching and + -- non-dispatching versions of Clear, the actual parameter passed is of + -- type Table. For Reset, the actual parameter passed is a view conversion + -- of an object of type Table2 to type Table, i.e., Table(Table2_Obj). + -- Since the tag of the operand never changes, the call to Clear within + -- Reset should execute Table2's version of Clear. + -- + -- The main program verifies that the appropriate version of Clear is + -- called in each case, by checking that the components of the actual are + -- updated as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C640001_0 is + + -- Data type artificial for testing purposes. + + Row_Len : constant := 10; + + T : constant Boolean := True; + F : constant Boolean := False; + + type Row_Type is array (1 .. Row_Len) of Boolean; + + function Is_True (A : in Row_Type) return Boolean; + function Is_False (A : in Row_Type) return Boolean; + + + Init : constant Row_Type := (T, F, T, F, T, F, T, F, T, F); + + type Table is tagged record -- Tagged type. + Row1 : Row_Type := Init; + Row2 : Row_Type := Init; + end record; + + procedure Clear (A : in out Table); -- Dispatching operation. + + procedure Reset (A : in out Table); -- Re-dispatching operation. + + -- ...Other operations. + + + type Table2 is new Table with null record; -- Extension of Table (but + -- structurally identical). + + procedure Clear (A : in out Table2); -- Overrides parent's op. + + -- ...Other operations. + + + end C640001_0; + + + --===================================================================-- + + + package body C640001_0 is + + function Is_True (A : in Row_Type) return Boolean is + begin + for I in A'Range loop + if A(I) /= True then -- Return true if all elements + return False; -- of A are True. + end if; + end loop; + return True; + end Is_True; + + + function Is_False (A : in Row_Type) return Boolean is + begin + return A = Row_Type'(others => False); -- Return true if all elements + end Is_False; -- of A are False. + + + procedure Clear (A : in out Table) is + begin + for I in Row_Type'Range loop -- This version of Clear sets + A.Row1(I) := False; -- the elements of Row1 only + end loop; -- to False. + end Clear; + + + procedure Reset (A : in out Table) is + begin + Clear (Table'Class(A)); -- Redispatch to appropriate + -- ... Other "reset" activities. -- version of Clear. + end Reset; + + + procedure Clear (A : in out Table2) is + begin + for I in Row_Type'Range loop -- This version of Clear sets + A.Row1(I) := True; -- the elements of Row1 only + end loop; -- to True. + end Clear; + + + end C640001_0; + + + --===================================================================-- + + + with C640001_0; + package C640001_1 is + + procedure Clear (T : in out C640001_0.Table); -- Non-dispatching operation. + + end C640001_1; + + + --===================================================================-- + + + package body C640001_1 is + + procedure Clear (T : in out C640001_0.Table) is + begin + for I in C640001_0.Row_Type'Range loop -- This version of Clear sets + T.Row2(I) := True; -- the elements of Row2 only + end loop; -- to True. + end Clear; + + end C640001_1; + + + --===================================================================-- + + + -- This unit represents a support package for table-driven processing of + -- data objects. Process_Operand performs a set of operations are performed + -- sequentially on a single operand. Note that parameters are provided to + -- specify which subset of operations in the operations table are to be + -- performed (ordinarily these might be omitted, but the test requires that + -- each operation be called individually for a single operand). + + generic + type Tag is tagged private; + package C640001_2 is + + type Proc_Ptr is access procedure (P: in out Tag); + + type Op_List is private; + + procedure Add_Op (Op : in Proc_Ptr; -- Add operation to + List : in out Op_List); -- to list of ops. + + procedure Process_Operand (Operand : in out Tag; -- Execute a subset + List : in Op_List; -- of a list of + First_Op : in Positive; -- operations using + Last_Op : in Positive); -- a given operand. + + -- ...Other operations. + + private + type Op_Array is array (1 .. 3) of Proc_Ptr; + + type Op_List is record + Top : Natural := 0; + Ops : Op_Array; + end record; + end C640001_2; + + + --===================================================================-- + + + package body C640001_2 is + + procedure Add_Op (Op : in Proc_Ptr; + List : in out Op_List) is + begin + List.Top := List.Top + 1; -- Artificial; no Constraint_Error protection. + List.Ops(List.Top) := Op; + end Add_Op; + + + procedure Process_Operand (Operand : in out Tag; + List : in Op_List; + First_Op : in Positive; + Last_Op : in Positive) is + begin + for I in First_Op .. Last_Op loop + List.Ops(I)(Operand); -- Implicit dereference of an + end loop; -- access-to-subprogram value. + end Process_Operand; + + end C640001_2; + + + --===================================================================-- + + + with C640001_0; + with C640001_1; + with C640001_2; + + with Report; + procedure C640001 is + + package Table_Support is new C640001_2 (C640001_0.Table); + + Sub_Ptr : Table_Support.Proc_Ptr; + My_List : Table_Support.Op_List; + My_Table1 : C640001_0.Table; -- Initial values of both Row1 & + -- Row2 are (T,F,T,F,T,F,T,F,T,F). + My_Table2 : C640001_0.Table2; -- Initial values of both Row1 & + -- Row2 are (T,F,T,F,T,F,T,F,T,F). + begin + Report.Test ("C640001", "Check that, for an access-to-subprogram type " & + "whose designated profile contains parameters " & + "of a tagged generic formal type, an access-" & + "to-subprogram value may designate dispatching " & + "and non-dispatching operations"); + + -- + -- Add subprogram access values to list: + -- + + Sub_Ptr := C640001_0.Clear'Access; -- Designates dispatching op. + Table_Support.Add_Op (Sub_Ptr, My_List); -- (1st operation on My_List). + + Sub_Ptr := C640001_1.Clear'Access; -- Designates non-dispatching op. + Table_Support.Add_Op (Sub_Ptr, My_List); -- (2nd operation on My_List). + + Sub_Ptr := C640001_0.Reset'Access; -- Designates re-dispatching op. + Table_Support.Add_Op (Sub_Ptr, My_List); -- (3rd operation on My_List). + + + -- + -- Call dispatching operation: + -- + + Table_Support.Process_Operand (My_Table1, My_List, 1, 1); -- Call 1st op. + + if not C640001_0.Is_False (My_Table1.Row1) then + Report.Failed ("Wrong result after calling dispatching operation"); + end if; + + + -- + -- Call non-dispatching operation: + -- + + Table_Support.Process_Operand (My_Table1, My_List, 2, 2); -- Call 2nd op. + + if not C640001_0.Is_True (My_Table1.Row2) then + Report.Failed ("Wrong result after calling non-dispatching operation"); + end if; + + + -- + -- Call re-dispatching operation: + -- + + Table_Support.Process_Operand (C640001_0.Table(My_Table2), -- View conv. + My_List, 3, 3); -- Call 3rd op. + + if not C640001_0.Is_True (My_Table2.Row1) then + Report.Failed ("Wrong result after calling re-dispatching operation"); + end if; + + + Report.Result; + end C640001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64002b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C64002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE CALLED WITH APPROPRIATE + -- NOTATION. + + -- DAS 1/27/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64002B IS + + USE REPORT; + + I : INTEGER := 1; + + FUNCTION F0 RETURN INTEGER IS + BEGIN + RETURN 7; + END F0; + + PROCEDURE P0 IS + BEGIN + I := 15; + END P0; + + BEGIN + + TEST ("C64002B", "CHECK THAT PARAMETERLESS SUBPROGRAMS CAN BE" & + " CALLED"); + + IF (F0 /= 7) THEN + FAILED ("PARAMETERLESS FUNCTION CALL RETURNS BAD VALUE"); + END IF; + + P0; + IF (I /= 15) THEN + FAILED ("PARAMETERLESS PROCEDURE CALL YIELDS INCORRECT" & + " RESULT"); + END IF; + + RESULT; + + END C64002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64004g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64004g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64004g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64004g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C64004G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR CALLS TO SUBPROGRAMS HAVING AT LEAST ONE DEFAULT + -- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND + -- FORMAL PARAMETERS. + + -- DAS 1/27/81 + + + WITH REPORT; + PROCEDURE C64004G IS + + USE REPORT; + + Y1,Y2,Y3 : INTEGER := 0; + O1,O2 : INTEGER := 0; + + PROCEDURE P (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER) IS + BEGIN + O1 := I1; + O2 := I2; + O3 := I3; + END P; + + FUNCTION F (I1: INTEGER := 1; I2: INTEGER) RETURN INTEGER IS + BEGIN + C64004G.O1 := I1; + C64004G.O2 := I2; + RETURN 1; + END F; + + BEGIN + + TEST ("C64004G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL" & + " PARAMETERS (HAVING DEFAULT VALUES)"); + + P (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 1"); + END IF; + + P (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 2"); + END IF; + + P (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2); + IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 3"); + END IF; + + P (41, 42, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARANETER ASSOCIATION - 4"); + END IF; + + P (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53); + IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 5"); + END IF; + + Y1 := F (I1=>61, I2=>62); + IF (O1 /= 61) OR (O2 /= 62) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 6"); + END IF; + + Y2 := F (I2=>72, I1=>71); + IF (O1 /= 71) OR (O2 /= 72) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 7"); + END IF; + + Y3 := F (I2=>82); + IF (O1 /= 1) OR (O2 /= 82) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 8"); + END IF; + + RESULT; + + END C64004G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C64005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBPROGRAM CAN BE CALLED + -- RECURSIVELY AND THAT NON-LOCAL VARIABLES AND + -- CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN + -- RECURSIVE INVOCATIONS. + + -- CVP 5/1/81 + + WITH REPORT; + PROCEDURE C64005A IS + + USE REPORT; + + TWENTY : CONSTANT INTEGER := 20; + C1 : CONSTANT INTEGER := 1; + I1, I2 : INTEGER := 0; + + PROCEDURE RECURSE (I1A : INTEGER; I2 : IN OUT INTEGER) IS + C1 : CONSTANT INTEGER := 5; + BEGIN + IF I1A < TWENTY THEN + RECURSE (I1A+C1, I2); + I1 := I1 + C64005A.C1; + I2 := I2 + I1A; + END IF; + END RECURSE; + + BEGIN + TEST ("C64005A", "RECURSIVE SUBPROGRAMS WITH " & + "NON-LOCAL DATA ACCESS"); + + RECURSE (0, I2); + + IF I1 /= 4 OR I2 /= 30 THEN + FAILED ("RECURSIVE PROCEDURE INVOCATIONS " & + "WITH GLOBAL DATA ACCESS NOT PERFORMED " & + "CORRECTLY"); + END IF; + + RESULT; + END C64005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C64005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBPROGRAM CAN BE CALLED RECURSIVELY AND THAT NON-LOCAL + -- VARIABLES AND CONSTANTS ARE PROPERLY ACCESSED FROM WITHIN RECURSIVE + -- INVOCATIONS. + + -- CPP 7/2/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64005B IS + + COUNT : INTEGER := 0; + TWENTY : CONSTANT INTEGER := 20; + C1 : CONSTANT INTEGER := 1; + G1, G2, G3 : INTEGER := 0; + G4, G5 : INTEGER := 0; + + PROCEDURE R (A1 : INTEGER; A2 : IN OUT INTEGER; A3 : OUT INTEGER) + IS + C1 : CONSTANT INTEGER := 5; + TEN : CONSTANT INTEGER := 10; + J1, J2 : INTEGER := 1; + J3 : INTEGER := 0; + + PROCEDURE RECURSE (P1 : INTEGER; P2 : IN OUT INTEGER) IS + C1 : INTEGER := 2; + BEGIN -- RECURSE + C1 := IDENT_INT (10); + IF P1 < TWENTY THEN + RECURSE (P1 + C1, G2); + G1 := G1 + C64005B.C1; + G3 := G3 + P1; + P2 := P2 + IDENT_INT(2); + A2 := A2 + IDENT_INT(1); + J2 := J2 + R.C1; + END IF; + END RECURSE; + + BEGIN -- R + IF A2 < TEN THEN + A2 := A2 + C1; + RECURSE (0, J1); + J3 := J3 + TEN; + COUNT := COUNT + 1; + COMMENT ("ON PASS # " & INTEGER'IMAGE(COUNT)); + COMMENT ("VALUE OF A2 IS " & INTEGER'IMAGE(A2)); + COMMENT ("VALUE OF J3 IS " & INTEGER'IMAGE(J3)); + R (0, A2, J3); + J3 := J3 + A2; + END IF; + A3 := J1 + J3; + END R; + + BEGIN + TEST("C64005B", "RECURSIVE SUBPROGRAMS WITH ALL KINDS " & + "OF DATA ACCESS"); + + R (0, G4, G5); + + IF (COUNT /= 2) OR (G1 /= 4) OR + (G2 /= 4) OR (G3 /= 20) OR + (G4 /= 14) OR (G5 /= 35) THEN + FAILED ("RECURSIVE INVOCATIONS' DATA ACCESS IS NOT" & + " WORKING CORRECTLY"); + END IF; + + COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT)); + COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1)); + COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2)); + COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3)); + COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4)); + COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5)); + + RESULT; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED ("PROGRAM_ERROR RAISED"); + COMMENT ("VALUE OF COUNT IS " & INTEGER'IMAGE(COUNT)); + COMMENT ("VALUE OF G1 IS " & INTEGER'IMAGE(G1)); + COMMENT ("VALUE OF G2 IS " & INTEGER'IMAGE(G2)); + COMMENT ("VALUE OF G3 IS " & INTEGER'IMAGE(G3)); + COMMENT ("VALUE OF G4 IS " & INTEGER'IMAGE(G4)); + COMMENT ("VALUE OF G5 IS " & INTEGER'IMAGE(G5)); + RESULT; + + END C64005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,330 ---- + -- C64005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT + -- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM + -- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR + -- STATIC CHAIN LEVEL CAN BE ACCESSED. + + -- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES. + + -- JRK 7/26/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C64005C IS + + SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C'; + SUBTYPE CALL IS CHARACTER RANGE '1' .. '3'; + + MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) - + LEVEL'POS (LEVEL'FIRST) + 1; + T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV + + MAX_LEV*(MAX_LEV+1)/2*2)) + 1; + G_LEN : CONSTANT := 2 + 4 * MAX_LEV; + + TYPE TRACE IS + RECORD + E : NATURAL := 0; + S : STRING (1 .. T_LEN); + END RECORD; + + V : CHARACTER := IDENT_CHAR ('<'); + L : CHARACTER := IDENT_CHAR ('>'); + T : TRACE; + G : STRING (1 .. G_LEN); + + PROCEDURE C64005CA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + PROCEDURE C64005CB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + PROCEDURE C64005CC (L : LEVEL; C : CALL; + T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_C); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V & + C64005CB.V & C64005CC.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005CA (IDENT_CHAR(LEVEL'FIRST), + IDENT_CHAR('2'), T); + + WHEN '2' => + C64005CC (L, IDENT_CHAR('3'), T); + + WHEN '3' => + -- APPEND MID-POINT SYMBOL TO T. + T.S (T.E+1) := IDENT_CHAR ('='); + T.E := T.E + 1; + + -- G := CATENATE ALL V, L, C; + G := C64005C.V & C64005C.L & + C64005CA.V & C64005CA.L & C64005CA.C & + C64005CB.V & C64005CB.L & C64005CB.C & + C64005CC.V & C64005CC.L & C64005CC.C; + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005CC.L & C64005CC.C & + C64005CB.L & C64005CB.C & + C64005CA.L & C64005CA.C & + C64005C.L; + T.E := T.E + N; + + END C64005CC; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_B); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V & + C64005CB.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005CC (LEVEL'SUCC(L), IDENT_CHAR('1'), T); + + WHEN '2' => + C64005CB (L, IDENT_CHAR('3'), T); + + WHEN '3' => + C64005CC (LEVEL'SUCC(L), IDENT_CHAR('2'), T); + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005CB.L & C64005CB.C & + C64005CA.L & C64005CA.C & + C64005C.L; + T.E := T.E + N; + + END C64005CB; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_A); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005C.V & C64005CA.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005CB (LEVEL'SUCC(L), IDENT_CHAR('1'), T); + + WHEN '2' => + C64005CA (L, IDENT_CHAR('3'), T); + + WHEN '3' => + C64005CB (LEVEL'SUCC(L), IDENT_CHAR('2'), T); + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005CA.L & C64005CA.C & C64005C.L; + T.E := T.E + N; + + END C64005CA; + + BEGIN + TEST ("C64005C", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " & + "PARAMETERS AT ALL LEVELS OF NESTED " & + "RECURSIVE PROCEDURES ARE ACCESSIBLE"); + + -- APPEND V TO T. + T.S (T.E+1) := V; + T.E := T.E + 1; + + C64005CA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T); + + -- APPEND L TO T. + T.S (T.E+1) := L; + T.E := T.E + 1; + + COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E)); + COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E)); + COMMENT ("GLOBAL SNAPSHOT IS: " & G); + + -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY. + + DECLARE + SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A .. + CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1); + + CT : TRACE; + CG : STRING (1 .. G_LEN); + BEGIN + COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " & + INTEGER'IMAGE(T_LEN)); + + IF T.E /= IDENT_INT (T_LEN) THEN + FAILED ("WRONG FINAL CALL TRACE LENGTH"); + + ELSE CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR I IN LC_LEVEL LOOP + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '1'; + CT.E := CT.E + 2; + END LOOP; + END LOOP; + + FOR I IN LC_LEVEL LOOP + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := I; + CT.S (CT.E+2) := '2'; + CT.E := CT.E + 2; + + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + END LOOP; + + CT.S (CT.E+1) := '='; + CT.E := CT.E + 1; + + FOR I IN REVERSE LEVEL LOOP + FOR J IN REVERSE LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + + CT.S (CT.E+1) := I; + CT.S (CT.E+2) := '2'; + CT.E := CT.E + 2; + + FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + END LOOP; + + FOR I IN REVERSE LEVEL LOOP + FOR J IN REVERSE LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '1'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + + IF CT.E /= IDENT_INT (T_LEN) THEN + FAILED ("WRONG ITERATIVE TRACE LENGTH"); + + ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S); + + IF T.S /= CT.S THEN + FAILED ("WRONG FINAL CALL TRACE"); + END IF; + END IF; + END IF; + + DECLARE + E : NATURAL := 0; + BEGIN + CG (1..2) := "<>"; + E := E + 2; + + FOR I IN LEVEL LOOP + CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) - + LEVEL'POS(LEVEL'FIRST) + + LC_LEVEL'POS + (LC_LEVEL'FIRST)); + CG (E+2) := '3'; + CG (E+3) := I; + CG (E+4) := '3'; + E := E + 4; + END LOOP; + + COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG); + + IF G /= CG THEN + FAILED ("WRONG GLOBAL SNAPSHOT"); + END IF; + END; + END; + + RESULT; + END C64005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005d0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,219 ---- + -- C64005D0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NESTED SUBPROGRAMS CAN BE CALLED RECURSIVELY AND THAT + -- NON-LOCAL VARIABLES AND FORMAL PARAMETERS ARE PROPERLY ACCESSED FROM + -- WITHIN RECURSIVE INVOCATIONS. THIS TEST CHECKS THAT EVERY DISPLAY OR + -- STATIC CHAIN LEVEL CAN BE ACCESSED. + + -- THIS TEST USES 3 LEVELS OF NESTED RECURSIVE PROCEDURES (SEPARATELY + -- COMPILED AS SUBUNITS). + + -- SEPARATE FILES ARE: + -- C64005D0M THE MAIN PROCEDURE. + -- C64005DA A RECURSIVE PROCEDURE SUBUNIT OF C64005D0M. + -- C64005DB A RECURSIVE PROCEDURE SUBUNIT OF C64005DA. + -- C64005DC A RECURSIVE PROCEDURE SUBUNIT OF C64005DB. + + -- JRK 7/30/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C64005D0M IS + + SUBTYPE LEVEL IS CHARACTER RANGE 'A' .. 'C'; + SUBTYPE CALL IS CHARACTER RANGE '1' .. '3'; + + MAX_LEV : CONSTANT := LEVEL'POS (LEVEL'LAST) - + LEVEL'POS (LEVEL'FIRST) + 1; + T_LEN : CONSTANT := 2 * (1 + 3 * (MAX_LEV + + MAX_LEV*(MAX_LEV+1)/2*2)) + 1; + G_LEN : CONSTANT := 2 + 4 * MAX_LEV; + + TYPE TRACE IS + RECORD + E : NATURAL := 0; + S : STRING (1 .. T_LEN); + END RECORD; + + V : CHARACTER := IDENT_CHAR ('<'); + L : CHARACTER := IDENT_CHAR ('>'); + T : TRACE; + G : STRING (1 .. G_LEN); + + PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + SEPARATE; + + BEGIN + TEST ("C64005D", "CHECK THAT NON-LOCAL VARIABLES AND FORMAL " & + "PARAMETERS AT ALL LEVELS OF NESTED " & + "RECURSIVE PROCEDURES ARE ACCESSIBLE (FOR " & + "3 LEVELS OF SEPARATELY COMPILED SUBUNITS)"); + + -- APPEND V TO T. + T.S (T.E+1) := V; + T.E := T.E + 1; + + C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('1'), T); + + -- APPEND L TO T. + T.S (T.E+1) := L; + T.E := T.E + 1; + + COMMENT ("FINAL CALL TRACE LENGTH IS: " & INTEGER'IMAGE(T.E)); + COMMENT ("FINAL CALL TRACE IS: " & T.S(1..T.E)); + COMMENT ("GLOBAL SNAPSHOT IS: " & G); + + -- CHECK THAT T AND G ARE CORRECT BY COMPUTING THEM ITERATIVELY. + + DECLARE + SUBTYPE LC_LEVEL IS CHARACTER RANGE ASCII.LC_A .. + CHARACTER'VAL (CHARACTER'POS(ASCII.LC_A) + MAX_LEV - 1); + + CT : TRACE; + CG : STRING (1 .. G_LEN); + BEGIN + COMMENT ("CORRECT FINAL CALL TRACE LENGTH IS: " & + INTEGER'IMAGE(T_LEN)); + + IF T.E /= IDENT_INT (T_LEN) THEN + FAILED ("WRONG FINAL CALL TRACE LENGTH"); + + ELSE CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR I IN LC_LEVEL LOOP + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '1'; + CT.E := CT.E + 2; + END LOOP; + END LOOP; + + FOR I IN LC_LEVEL LOOP + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. LC_LEVEL'PRED(I) LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := I; + CT.S (CT.E+2) := '2'; + CT.E := CT.E + 2; + + CT.S (CT.E+1) := '<'; + CT.E := CT.E + 1; + + FOR J IN LC_LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + END LOOP; + + CT.S (CT.E+1) := '='; + CT.E := CT.E + 1; + + FOR I IN REVERSE LEVEL LOOP + FOR J IN REVERSE LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + + CT.S (CT.E+1) := I; + CT.S (CT.E+2) := '2'; + CT.E := CT.E + 2; + + FOR J IN REVERSE LEVEL'FIRST .. LEVEL'PRED(I) LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '3'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + END LOOP; + + FOR I IN REVERSE LEVEL LOOP + FOR J IN REVERSE LEVEL'FIRST .. I LOOP + CT.S (CT.E+1) := J; + CT.S (CT.E+2) := '1'; + CT.E := CT.E + 2; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + END LOOP; + + CT.S (CT.E+1) := '>'; + CT.E := CT.E + 1; + + IF CT.E /= IDENT_INT (T_LEN) THEN + FAILED ("WRONG ITERATIVE TRACE LENGTH"); + + ELSE COMMENT ("CORRECT FINAL CALL TRACE IS: " & CT.S); + + IF T.S /= CT.S THEN + FAILED ("WRONG FINAL CALL TRACE"); + END IF; + END IF; + END IF; + + DECLARE + E : NATURAL := 0; + BEGIN + CG (1..2) := "<>"; + E := E + 2; + + FOR I IN LEVEL LOOP + CG (E+1) := LC_LEVEL'VAL (LEVEL'POS(I) - + LEVEL'POS(LEVEL'FIRST) + + LC_LEVEL'POS + (LC_LEVEL'FIRST)); + CG (E+2) := '3'; + CG (E+3) := I; + CG (E+4) := '3'; + E := E + 4; + END LOOP; + + COMMENT ("CORRECT GLOBAL SNAPSHOT IS: " & CG); + + IF G /= CG THEN + FAILED ("WRONG GLOBAL SNAPSHOT"); + END IF; + END; + END; + + RESULT; + END C64005D0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005da.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005da.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005da.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005da.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C64005DA.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 7/30/84 + + SEPARATE (C64005D0M) + + PROCEDURE C64005DA (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + SEPARATE; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_A); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005DB (LEVEL'SUCC(L), IDENT_CHAR('1'), T); + + WHEN '2' => + C64005DA (L, IDENT_CHAR('3'), T); + + WHEN '3' => + C64005DB (LEVEL'SUCC(L), IDENT_CHAR('2'), T); + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005DA.L & C64005DA.C & C64005D0M.L; + T.E := T.E + N; + + END C64005DA; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005db.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005db.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005db.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005db.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C64005DB.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 7/30/84 + + SEPARATE (C64005D0M.C64005DA) + + PROCEDURE C64005DB (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + SEPARATE; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_B); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005DC (LEVEL'SUCC(L), IDENT_CHAR('1'), T); + + WHEN '2' => + C64005DB (L, IDENT_CHAR('3'), T); + + WHEN '3' => + C64005DC (LEVEL'SUCC(L), IDENT_CHAR('2'), T); + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005DB.L & C64005DB.C & + C64005DA.L & C64005DA.C & + C64005D0M.L; + T.E := T.E + N; + + END C64005DB; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64005dc.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C64005DC.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 7/30/84 + + SEPARATE (C64005D0M.C64005DA.C64005DB) + + PROCEDURE C64005DC (L : LEVEL; C : CALL; T : IN OUT TRACE) IS + + V : STRING (1..2); + + M : CONSTANT NATURAL := LEVEL'POS (L) - + LEVEL'POS (LEVEL'FIRST) + 1; + N : CONSTANT NATURAL := 2 * M + 1; + + BEGIN + + V (1) := IDENT_CHAR (ASCII.LC_C); + V (2) := C; + + -- APPEND ALL V TO T. + T.S (T.E+1 .. T.E+N) := C64005D0M.V & C64005DA.V & C64005DB.V & + C64005DC.V; + T.E := T.E + N; + + CASE C IS + + WHEN '1' => + C64005DA (IDENT_CHAR(LEVEL'FIRST), IDENT_CHAR('2'), T); + + WHEN '2' => + C64005DC (L, IDENT_CHAR('3'), T); + + WHEN '3' => + -- APPEND MID-POINT SYMBOL TO T. + T.S (T.E+1) := IDENT_CHAR ('='); + T.E := T.E + 1; + + -- G := CATENATE ALL V, L, C; + G := C64005D0M.V & C64005D0M.L & + C64005DA.V & C64005DA.L & C64005DA.C & + C64005DB.V & C64005DB.L & C64005DB.C & + C64005DC.V & C64005DC.L & C64005DC.C; + END CASE; + + -- APPEND ALL L AND C TO T IN REVERSE ORDER. + T.S (T.E+1 .. T.E+N) := C64005DC.L & C64005DC.C & + C64005DB.L & C64005DB.C & + C64005DA.L & C64005DA.C & + C64005D0M.L; + T.E := T.E + N; + + END C64005DC; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c641001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c641001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c641001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c641001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,281 ---- + -- C641001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that actual parameters passed by reference are view converted + -- to the nominal subtype of the formal parameter. + -- + -- TEST DESCRIPTION: + -- Check that sliding is allowed for formal parameters, especially + -- check cases that would have caused errors in Ada'83. + -- Check that length check for a formal parameter (esp out mode) + -- is performed before the call, not after. + -- + -- notes: 6.2; by reference ::= tagged, task, protected, + -- limited (nonprivate), or composite containing such + -- 4.6; view conversion + -- + -- + -- CHANGE HISTORY: + -- 26 JAN 96 SAIC Initial version + -- 04 NOV 96 SAIC Commentary revision for release 2.1 + -- 27 FEB 97 PWB.CTA Corrected reference to the wrong string + --! + + ----------------------------------------------------------------- C641001_0 + + package C641001_0 is + + subtype String_10 is String(1..10); + + procedure Check_String_10( S : out String_10; Start, Stop: Natural ); + + procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String; + Index: Natural ); + + type Tagged_Data(Bound: Natural) is tagged record + Data_Item : String(1..Bound) := (others => '*'); + end record; + + type Tag_List is array(Natural range <>) of Tagged_Data(5); + + subtype Tag_List_10 is Tag_List(1..10); + + procedure Check_Tag_Slice( TL : in out Tag_List_10 ); + + procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ); + + end C641001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body C641001_0 is + + String_Data : constant String := "1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + + procedure Check_String_10( S : out String_10; Start, Stop: Natural ) is + begin + if S'Length /= 10 then + Report.Failed("Length check not performed prior to execution"); + end if; + S := String_Data(Start..Stop); + exception + when others => Report.Failed("Exception encountered in Check_String_10"); + end Check_String_10; + + procedure Check_Illegal_Slice_Reference( Slice_Passed : in out String; + Index: Natural ) is + begin + -- essentially "do-nothing" for optimization foilage... + if Slice_Passed(Index) in Character then + -- Intent is ^^^^^ should raise Constraint_Error + Report.Failed("Illegal Slice provided legal character"); + else + Report.Failed("Illegal Slice provided illegal character"); + end if; + exception + when Constraint_Error => + null; -- expected case + when others => + Report.Failed("Wrong exception in Check_Illegal_Slice_Reference"); + end Check_Illegal_Slice_Reference; + + procedure Check_Tag_Slice( TL : in out Tag_List_10 ) is + -- if the view conversion is not performed, one of the following checks + -- will fail (given data passed as 0..9 and then 2..11) + begin + Check_Under_Index: -- index 0 should raise C_E + begin + TCTouch.Assert( TL(Report.Ident_Int(0)).Data_Item = "*****", + "Index 0 (illegal); bad data" ); + Report.Failed("Index 0 did not raise Constraint_Error"); + exception + when Constraint_Error => + null; -- expected case + when others => + Report.Failed("Wrong exception in Check_Under_Index "); + end Check_Under_Index; + + Check_Over_Index: -- index 11 should raise C_E + begin + TCTouch.Assert( TL(Report.Ident_Int(11)).Data_Item = "*****", + "Index 11 (illegal); bad data" ); + Report.Failed("Index 11 did not raise Constraint_Error"); + exception + when Constraint_Error => + null; -- expected case + when others => + Report.Failed("Wrong exception in Check_Over_Index "); + end Check_Over_Index; + + end Check_Tag_Slice; + + procedure Check_Out_Tagged_Data( Formal : out Tagged_Data ) is + begin + TCTouch.Assert( Formal.Data_Item = "*****", "out formal data bad" ); + Formal.Data_Item(1) := '!'; + end Check_Out_Tagged_Data; + + end C641001_0; + + ------------------------------------------------------------------- C641001 + + with Report; + with TCTouch; + with C641001_0; + procedure C641001 is + + function II( I: Integer ) return Integer renames Report.Ident_Int; + -- ^^ name chosen to allow embedding in calls + + A_String_10 : C641001_0.String_10; + Slicable : String(1..40); + Tag_Slices : C641001_0.Tag_List(0..11); + + Global_Data : String(1..26) := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + + procedure Check_Out_Sliding( Lo1, Hi1, Lo2, Hi2 : Natural ) is + + subtype One_Constrained_String is String(Lo1..Hi1); -- 1 5 + subtype Two_Constrained_String is String(Lo2..Hi2); -- 6 10 + + procedure Out_Param( Param : out One_Constrained_String ) is + begin + Param := Report.Ident_Str( Global_Data(Lo2..Hi2) ); + end Out_Param; + Object : Two_Constrained_String; + begin + Out_Param( Object ); + if Object /= Report.Ident_Str( Global_Data(Lo2..Hi2) ) then + Report.Failed("Bad result in Check_Out_Sliding"); + end if; + exception + when others => Report.Failed("Exception in Check_Out_Sliding"); + end Check_Out_Sliding; + + procedure Check_Dynamic_Subtype_Cases(F_Lower,F_Upper: Natural; + A_Lower,A_Upper: Natural) is + + subtype Dyn_String is String(F_Lower..F_Upper); + + procedure Check_Dyn_Subtype_Formal_Out( Param : out Dyn_String ) is + begin + Param := Global_Data(11..20); + end Check_Dyn_Subtype_Formal_Out; + + procedure Check_Dyn_Subtype_Formal_In( Param : in Dyn_String ) is + begin + if Param /= Global_Data(11..20) then + Report.Failed("Dynamic case, data mismatch"); + end if; + end Check_Dyn_Subtype_Formal_In; + + Stuff: String(A_Lower..A_Upper); + + begin + Check_Dyn_Subtype_Formal_Out( Stuff ); + Check_Dyn_Subtype_Formal_In( Stuff ); + end Check_Dynamic_Subtype_Cases; + + begin -- Main test procedure. + + Report.Test ("C641001", "Check that actual parameters passed by " & + "reference are view converted to the nominal " & + "subtype of the formal parameter" ); + + -- non error cases for string slices + + C641001_0.Check_String_10( A_String_10, 1, 10 ); + TCTouch.Assert( A_String_10 = "1234567890", "Nominal case" ); + + C641001_0.Check_String_10( A_String_10, 11, 20 ); + TCTouch.Assert( A_String_10 = "ABCDEFGHIJ", "Sliding to subtype" ); + + C641001_0.Check_String_10( Slicable(1..10), 1, 10 ); + TCTouch.Assert( Slicable(1..10) = "1234567890", "Slice, no sliding" ); + + C641001_0.Check_String_10( Slicable(1..10), 21, 30 ); + TCTouch.Assert( Slicable(1..10) = "KLMNOPQRST", "Sliding to slice" ); + + C641001_0.Check_String_10( Slicable(11..20), 11, 20 ); + TCTouch.Assert( Slicable(11..20) = "ABCDEFGHIJ", "Sliding to same" ); + + C641001_0.Check_String_10( Slicable(21..30), 11, 20 ); + TCTouch.Assert( Slicable(21..30) = "ABCDEFGHIJ", "Sliding up" ); + + -- error cases for string slices + + C641001_0.Check_Illegal_Slice_Reference( Slicable(21..30), 20 ); + + C641001_0.Check_Illegal_Slice_Reference( Slicable(1..15), Slicable'Last ); + + -- checks for view converting actuals to formals + + -- catch low bound fault + C641001_0.Check_Tag_Slice( Tag_Slices(II(0)..9) ); -- II ::= Ident_Int + TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" ); + TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" ); + + -- catch high bound fault + C641001_0.Check_Tag_Slice( Tag_Slices(2..II(11)) ); + TCTouch.Assert( Tag_Slices'First = 0, "Tag_Slices'First = 0" ); + TCTouch.Assert( Tag_Slices'Last = 11, "Tag_Slices'Last = 11" ); + + Check_Formal_Association_Check: + begin + C641001_0.Check_String_10( Slicable, 1, 10 ); -- catch length fault + Report.Failed("Exception not raised at Check_Formal_Association_Check"); + exception + when Constraint_Error => + null; -- expected case + when others => + Report.Failed("Wrong exception at Check_Formal_Association_Check"); + end Check_Formal_Association_Check; + + -- check for constrained actual, unconstrained formal + C641001_0.Check_Out_Tagged_Data( Tag_Slices(5) ); + TCTouch.Assert( Tag_Slices(5).Data_Item = "!****", + "formal out returned bad result" ); + + -- additional checks for out mode formal parameters, dynamic subtypes + + Check_Out_Sliding( II(1),II(5), II(6),II(10) ); + + Check_Out_Sliding( 21,25, 6,10 ); + + Check_Dynamic_Subtype_Cases(F_Lower => II(1), F_Upper => II(10), + A_Lower => II(1), A_Upper => II(10)); + + Check_Dynamic_Subtype_Cases(F_Lower => II(21), F_Upper => II(30), + A_Lower => II( 1), A_Upper => II(10)); + + Check_Dynamic_Subtype_Cases(F_Lower => II( 1), F_Upper => II(10), + A_Lower => II(21), A_Upper => II(30)); + + Report.Result; + + end C641001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,379 ---- + -- C64103B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR IN-OUT PARAMETERS OF A SCALAR TYPE, + -- CONSTRAINT_ERROR IS RAISED: + -- BEFORE A SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL + -- PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL PARAMETER'S + -- SUBTYPE; + -- AFTER A SUBPROGRAM CALL WHEN THE CONVERTED FORMAL PARAMETER + -- IS OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S SUBTYPE. + + -- HISTORY: + -- CPP 07/18/84 CREATED ORIGINAL TEST. + -- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH + -- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND + -- SUBTEST. + + WITH REPORT; USE REPORT; + PROCEDURE C64103B IS + BEGIN + TEST ("C64103B", "FOR IN-OUT PARAMETERS OF A SCALAR TYPE, " & + "CONSTRAINT_ERROR IS RAISED: BEFORE A " & + "SUBPROGRAM CALL WHEN THE CONVERTED ACTUAL " & + "PARAMETER IS OUTSIDE THE RANGE OF THE FORMAL " & + "PARAMETER'S SUBTYPE; AFTER A SUBPROGRAM " & + "CALL WHEN THE CONVERTED FORMAL PARAMETER IS " & + "OUTSIDE THE RANGE OF THE ACTUAL PARAMETER'S " & + "SUBTYPE"); + + + DECLARE + A0 : INTEGER := -9; + A1 : INTEGER := IDENT_INT(-1); + TYPE SUBINT IS RANGE -8 .. -2; + + TYPE FLOAT_TYPE IS DIGITS 3 RANGE 0.0 .. 3.0; + A2 : FLOAT_TYPE := 0.12; + A3 : FLOAT_TYPE := 2.5; + TYPE NEW_FLOAT IS DIGITS 3 RANGE 1.0 .. 2.0; + + TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0; + A4 : FIXED_TYPE := -2.0; + A5 : FIXED_TYPE := 4.0; + TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0; + + A6 : CHARACTER := 'A'; + SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q'; + + TYPE COLOR IS (RED, BURGUNDY, LILAC, MAROON, MAGENTA); + SUBTYPE A_COLOR IS COLOR RANGE RED..LILAC; + SUBTYPE B_COLOR IS COLOR RANGE MAROON..MAGENTA; + A7 : B_COLOR := MAROON; + + PROCEDURE P1 (X : IN OUT SUBINT; + S : STRING) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (A" & + S & ")"); + END P1; + + PROCEDURE P2 (X : IN OUT NEW_FLOAT; + S : STRING) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A" & + S & ")"); + END P2; + + PROCEDURE P3 (X : IN OUT NEW_FIXED; + S : STRING) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P3 (A" & + S & ")"); + END P3; + + PROCEDURE P4 (X : IN OUT SUPER_CHAR; + S : STRING) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P4 (A" & + S & ")"); + END P4; + + PROCEDURE P5 (X : IN OUT A_COLOR; + S : STRING) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P5 (A" & + S & ")"); + END P5; + BEGIN + BEGIN + P1 (SUBINT (A0), "1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (A1)"); + END; + + BEGIN + P1 (SUBINT (A1), "2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (A2)"); + END; + + BEGIN + P2 (NEW_FLOAT (A2), "1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (A1)"); + END; + + BEGIN + P2 (NEW_FLOAT (A3), "2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (A2)"); + END; + + BEGIN + P3 (NEW_FIXED (A4), "1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (A1)"); + END; + + BEGIN + P3 (NEW_FIXED (A5), "2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (A2)"); + END; + + BEGIN + P4 (SUPER_CHAR (A6),"1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P4 (A1)"); + END; + + BEGIN + P5 (A_COLOR (A7), "1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P5 (A1)"); + END; + END; + + + DECLARE + CALLED : BOOLEAN; + TYPE SUBINT IS RANGE -8 .. -2; + A0 : SUBINT := -3; + A1 : INTEGER := -9; + A2 : INTEGER := -1; + + TYPE FLOAT IS DIGITS 3 RANGE -1.0 .. 2.0; + TYPE A_FLOAT IS DIGITS 3 RANGE 0.0 .. 1.0; + A3 : A_FLOAT := 1.0; + A4 : FLOAT := -0.5; + A5 : FLOAT := 1.5; + + TYPE NEW_FIXED IS DELTA 1.0 RANGE -1.0 .. 3.0; + A6 : NEW_FIXED := 0.0; + TYPE FIXED_TYPE IS DELTA 1.0 RANGE -2.0 .. 5.0; + A7 : FIXED_TYPE := -2.0; + A8 : FIXED_TYPE := 4.0; + + SUBTYPE SUPER_CHAR IS CHARACTER RANGE 'B'..'Q'; + A9 : SUPER_CHAR := 'C'; + A10 : CHARACTER := 'A'; + A11 : CHARACTER := 'R'; + + PROCEDURE P1 (X : IN OUT INTEGER; Y : INTEGER) IS + BEGIN + CALLED := TRUE; + X := IDENT_INT (Y); + END P1; + + PROCEDURE P2 (X : IN OUT FLOAT; Y : FLOAT) IS + BEGIN + CALLED := TRUE; + X := Y; + END P2; + + PROCEDURE P3 ( X : IN OUT FIXED_TYPE; Y : FIXED_TYPE) IS + BEGIN + CALLED := TRUE; + X := Y; + END P3; + + PROCEDURE P4 (X : IN OUT CHARACTER; Y : CHARACTER) IS + BEGIN + CALLED := TRUE; + X := IDENT_CHAR(Y); + END P4; + BEGIN + BEGIN + CALLED := FALSE; + P1 (INTEGER(A0), A1); + IF A0 = -3 THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P1 (B1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B1)"); + END; + + BEGIN + CALLED := FALSE; + P1 (INTEGER(A0), A2); + IF A0 = -3 THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B3)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P1 (B2)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B2)"); + END; + + BEGIN + CALLED := FALSE; + P2 (FLOAT (A3), A4); + IF A3 = 1.0 THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P2 (B1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (B1)"); + END; + + BEGIN + CALLED := FALSE; + P2 (FLOAT (A3), A5); + IF A3 = 1.0 THEN + FAILED ("EXCEPTION NOT RAISED -P2 (B3)"); + ELSE + FAILED ("EXCEPTION NOT RAISED -P2 (B4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P2 (B2)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (B2)"); + END; + + BEGIN + CALLED := FALSE; + P3 (FIXED_TYPE (A6), A7); + IF A6 = 0.0 THEN + FAILED ("EXCEPTION NOT RAISED -P3 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED -P3 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P3 (B1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (B1)"); + END; + + BEGIN + CALLED := FALSE; + P3 (FIXED_TYPE (A6), A8); + IF A6 = 0.0 THEN + FAILED ("EXCEPTION NOT RAISED -P3 (B3)"); + ELSE + FAILED ("EXCEPTION NOT RAISED -P3 (B4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P3 (B2)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (B2)"); + END; + + BEGIN + CALLED := FALSE; + P4 (CHARACTER (A9), A10); + IF A9 = 'C' THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P4 (B1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P4 (B1)"); + END; + + BEGIN + CALLED := FALSE; + P4 (CHARACTER (A9), A11); + IF A9 = 'C' THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B3)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P4 (B4)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P4 (B2)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P4 (B2)"); + END; + END; + + RESULT; + END C64103B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- C64103C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS + -- ON IN OUT ARRAY PARAMETERS. IN PARTICULAR: + -- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL + -- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S + -- CONSTRAINTS. + -- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO + -- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE + -- OUTSIDE OF A FORMAL INDEX SUBTYPE FOR A NON-NULL DIMENSION (SEE + -- AI-00313 FOR MULTIDIMENSIONAL CASE) + -- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A + -- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER + -- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL. + -- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN + -- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE + -- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- CPP 07/19/84 + -- JBG 06/05/85 + -- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- MRM 03/30/93 REMOVE NUMERIC_ERROR FOR 9X COMPATIBILITY + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C64103C IS + + BEGIN + TEST ("C64103C", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " & + "TYPE CONVERSIONS OF IN OUT ARRAY PARAMETERS"); + + ----------------------------------------------- + + DECLARE -- (A) + BEGIN -- (A) + + DECLARE + TYPE SUBINT IS RANGE 0..8; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE); + + PROCEDURE P2 (X : IN OUT ARRAY_TYPE) IS + BEGIN + NULL; + END P2; + BEGIN + P2 (ARRAY_TYPE (A0)); -- OK. + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -P2 (A)"); + END; + + END; -- (A) + + ----------------------------------------------- + + DECLARE -- (B1) NON-NULL ACTUAL PARAMETER + + TYPE SUBINT IS RANGE 0..8; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A1 : AR1 (-1..7) := (-1..7 => TRUE); + A2 : AR1 (1..9) := (1..9 => TRUE); + + PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)"); + END P1; + + BEGIN -- (B1) + + BEGIN + COMMENT ("CALL TO P1 (B1) ON A1"); + P1 (ARRAY_TYPE (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B1)"); + END; + + BEGIN + COMMENT ("CALL TO P1 (B1) ON A2"); + P1 (ARRAY_TYPE (A2)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B1)"); + END; + + END; -- (B1) + + DECLARE -- (B2) NULL ACTUAL PARAMETER; MULTIDIMENSIONAL + + TYPE SUBINT IS RANGE 0..8; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>, + SUBINT RANGE <>) OF BOOLEAN; + TYPE AR1 IS ARRAY (INTEGER RANGE <>, + INTEGER RANGE <>)OF BOOLEAN; + A1 : AR1 (IDENT_INT(-1)..7, 5..4) := + (OTHERS => (OTHERS => TRUE)); + A2 : AR1 (5..4, 1..IDENT_INT(9)) := + (OTHERS => (OTHERS => TRUE)); + PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)"); + END P1; + + BEGIN -- (B2) + + BEGIN + COMMENT ("CALL TO P1 (B2) ON A1"); + P1 (ARRAY_TYPE (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B2)"); + END; + + BEGIN + COMMENT ("CALL TO P1 (B2) ON A2"); + P1 (ARRAY_TYPE (A2)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B2)"); + END; + + END; -- (B2) + + ----------------------------------------------- + + BEGIN -- (C) + + DECLARE + TYPE INDEX1 IS RANGE 1..3; + TYPE INDEX2 IS RANGE 1..4; + TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN; + A0 : AR_TYPE := (1..3 => (1..4 => FALSE)); + + TYPE I1 IS RANGE 1..4; + TYPE I2 IS RANGE 1..3; + TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN; + + PROCEDURE P1 (X : IN OUT ARRAY_TYPE) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)"); + END P1; + BEGIN + P1 (ARRAY_TYPE (A0)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (C)"); + END; + + END; -- (C) + + ----------------------------------------------- + + DECLARE -- (D) + BEGIN -- (D) + + DECLARE + TYPE SM_INT IS RANGE 0..2; + TYPE LG IS RANGE 0 .. SYSTEM.MAX_INT; + SUBTYPE LG_INT IS LG RANGE SYSTEM.MAX_INT - 3 .. + SYSTEM.MAX_INT; + TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN; + TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN; + A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) := + (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE); + + PROCEDURE P1 (X : IN OUT AR_SMALL) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)"); + END P1; + BEGIN + IF LG (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN + P1 (AR_SMALL (A0)); + ELSE + COMMENT ("NOT APPLICABLE -P1 (D)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - P1 (D)"); + END; + + END; -- (D) + + ----------------------------------------------- + + RESULT; + + END C64103C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- C64103D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE APPROPRIATE EXCEPTION IS RAISED FOR TYPE CONVERSIONS + -- ON OUT ARRAY PARAMETERS. IN PARTICULAR: + -- (A) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN THE ACTUAL + -- COMPONENT'S CONSTRAINTS DIFFER FROM THE FORMAL COMPONENT'S + -- CONSTRAINTS. + -- (B) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO + -- AN UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE + -- OUTSIDE OF A FORMAL INDEX SUBTYPE. + -- (C) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL FOR CONVERSION TO A + -- CONSTRAINED ARRAY TYPE WHEN THE NUMBER OF COMPONENTS PER + -- DIMENSION OF THE ACTUAL DIFFERS FROM THAT OF THE FORMAL. + -- (D) CONSTRAINT_ERROR IS RAISED BEFORE THE CALL WHEN CONVERSION TO AN + -- UNCONSTRAINED ARRAY TYPE CAUSES AN ACTUAL INDEX BOUND TO LIE + -- OUTSIDE OF THE BASE INDEX TYPE OF THE FORMAL. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- CPP 07/19/84 + -- EG 10/29/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C64103D IS + + BEGIN + TEST ("C64103D", "CHECK THAT APPROPRIATE EXCEPTION IS RAISED ON " & + "TYPE CONVERSIONS OF OUT ARRAY PARAMETERS"); + + ----------------------------------------------- + + DECLARE -- (A) + BEGIN -- (A) + + DECLARE + TYPE SUBINT IS RANGE 0..8; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + A0 : ARRAY_TYPE (0..3) := (0..3 => TRUE); + + PROCEDURE P2 (X : OUT ARRAY_TYPE) IS + BEGIN + NULL; + END P2; + BEGIN + P2 (ARRAY_TYPE (A0)); -- OK. + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED -P2 (A)"); + END; + + END; -- (A) + + ----------------------------------------------- + + DECLARE -- (B) + + TYPE SUBINT IS RANGE 0..8; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + TYPE AR1 IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + A1 : AR1 (-1..7) := (-1..7 => TRUE); + A2 : AR1 (1..9) := (1..9 => TRUE); + + PROCEDURE P1 (X : OUT ARRAY_TYPE) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (B)"); + END P1; + + BEGIN -- (B) + + BEGIN + COMMENT ("CALL TO P1 (B) ON A1"); + P1 (ARRAY_TYPE (A1)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B)"); + END; + + BEGIN + COMMENT ("CALL TO P1 (B) ON A2"); + P1 (ARRAY_TYPE (A2)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B)"); + END; + + END; -- (B) + + ----------------------------------------------- + + DECLARE -- (C) + BEGIN -- (C) + + DECLARE + TYPE INDEX1 IS RANGE 1..3; + TYPE INDEX2 IS RANGE 1..4; + TYPE AR_TYPE IS ARRAY (INDEX1, INDEX2) OF BOOLEAN; + A0 : AR_TYPE := (1..3 => (1..4 => FALSE)); + + TYPE I1 IS RANGE 1..4; + TYPE I2 IS RANGE 1..3; + TYPE ARRAY_TYPE IS ARRAY (I1, I2) OF BOOLEAN; + + PROCEDURE P1 (X : OUT ARRAY_TYPE) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (C)"); + END P1; + BEGIN + P1 (ARRAY_TYPE (A0)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (C)"); + END; + + END; -- (C) + + ----------------------------------------------- + + DECLARE -- (D) + BEGIN -- (D) + + DECLARE + TYPE SM_INT IS RANGE 0..2; + TYPE LG_INT IS RANGE SYSTEM.MIN_INT..SYSTEM.MAX_INT; + TYPE AR_SMALL IS ARRAY (SM_INT RANGE <>) OF BOOLEAN; + TYPE AR_LARGE IS ARRAY (LG_INT RANGE <>) OF BOOLEAN; + A0 : AR_LARGE (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT) := + (SYSTEM.MAX_INT - 2..SYSTEM.MAX_INT => TRUE); + + PROCEDURE P1 (X : OUT AR_SMALL) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P1 (D)"); + END P1; + BEGIN + IF LG_INT (SM_INT'BASE'LAST) < LG_INT'BASE'LAST THEN + P1 (AR_SMALL (A0)); + ELSE + COMMENT ("NOT APPLICABLE -P1 (D)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED - P1 (D)"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - P1 (D)"); + END; + + END; -- (D) + + ----------------------------------------------- + + RESULT; + + END C64103D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,219 ---- + -- C64103E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR IN-OUT PARAMETERS OF AN ACCESS TYPE, + -- CONSTRAINT_ERROR IS RAISED: + -- BEFORE A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS + -- OF THE ACTUAL DESIGNATED PARAMETER ARE DIFFERENT FROM + -- THOSE OF THE FORMAL DESIGNATED PARAMETER; + -- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS + -- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM + -- THOSE OF THE ACTUAL DESIGNATED PARAMETER. + + -- HISTORY: + -- CPP 07/23/84 CREATED ORIGINAL TEST. + -- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH + -- REFERENCED THE ACTUAL PARAMETERS IN THE SECOND + -- SUBTEST. + + WITH REPORT; USE REPORT; + PROCEDURE C64103E IS + BEGIN + TEST ("C64103E", "FOR IN-OUT PARAMETERS OF AN ACCESS TYPE, " & + "CONSTRAINT_ERROR IS RAISED: BEFORE A " & + "SUBPROGRAM CALL WHEN THE BOUNDS OR " & + "DISCRIMINANTS OF THE ACTUAL DESIGNATED " & + "PARAMETER ARE DIFFERENT FROM THOSE OF THE " & + "FORMAL DESIGNATED PARAMETER; AFTER A " & + "SUBPROGRAM CALL WHEN THE BOUNDS OR " & + "DISCRIMINANTS OF THE FORMAL DESIGNATED " & + "PARAMETER ARE DIFFERENT FROM THOSE OF THE " & + "ACTUAL DESIGNATED PARAMETER"); + + + BEGIN + DECLARE + TYPE AST IS ACCESS STRING; + SUBTYPE AST_3 IS AST(1..3); + SUBTYPE AST_5 IS AST(3..5); + X_3 : AST_3 := NEW STRING(1..IDENT_INT(3)); + + PROCEDURE P1 (X : IN OUT AST_5) IS + BEGIN + FAILED("EXCEPTION NOT RAISED BEFORE CALL -P1 (A)"); + END P1; + BEGIN + P1 (AST_5 (X_3)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (A)"); + END; + + DECLARE + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE A_ARRAY IS ACCESS ARRAY_TYPE; + SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3)); + TYPE A2_ARRAY IS NEW A_ARRAY (2..4); + A0 : A1_ARRAY := NEW ARRAY_TYPE (1..3); + + PROCEDURE P2 (X : IN OUT A2_ARRAY) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL -P2 (A)"); + END P2; + BEGIN + P2 (A2_ARRAY (A0)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (A)"); + END; + + DECLARE + TYPE SUBINT IS RANGE 0..8; + TYPE REC1 (DISC : SUBINT := 8) IS + RECORD + FIELD : SUBINT := DISC; + END RECORD; + TYPE A1_REC IS ACCESS REC1; + TYPE A2_REC IS NEW A1_REC(3); + A0 : A1_REC := NEW REC1(4); + + PROCEDURE P3 (X : IN OUT A2_REC) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL " & + "-P3 (A)"); + END P3; + + BEGIN + P3 (A2_REC (A0)); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (A)"); + END; + + END; + + + BEGIN + DECLARE + TYPE AST IS ACCESS STRING; + SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3)); + X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A'); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P1 (X : IN OUT AST) IS + BEGIN + CALLED := TRUE; + X := NEW STRING'(3..5 => 'C'); + END P1; + BEGIN + P1 (AST (X_3)); + IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL" & + "-P1 (B)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (B)"); + END; + + DECLARE + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE A_ARRAY IS ACCESS ARRAY_TYPE; + SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3)); + A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P2 (X : IN OUT A_ARRAY) IS + BEGIN + CALLED := TRUE; + X := NEW ARRAY_TYPE'(2..4 => FALSE); + END P2; + BEGIN + P2 (A_ARRAY (A0)); + IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL" & + "-P1 (B)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (B)"); + END; + + DECLARE + TYPE SUBINT IS RANGE 0..8; + TYPE REC1 (DISC : SUBINT := 8) IS + RECORD + FIELD : SUBINT := DISC; + END RECORD; + TYPE A1_REC IS ACCESS REC1; + TYPE A2_REC IS NEW A1_REC; + A0 : A1_REC(4) := NEW REC1(4); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P3 (X : IN OUT A2_REC) IS + BEGIN + CALLED := TRUE; + X := NEW REC1; + END P3; + + BEGIN + P3 (A2_REC (A0)); + IF A0.ALL = REC1'(4,4) THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (B2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL" & + "-P1 (B)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (B)"); + END; + + END; + + RESULT; + END C64103E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64103f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64103f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C64103F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR OUT PARAMETERS OF AN ACCESS TYPE, + -- CONSTRAINT_ERROR IS RAISED: + -- AFTER A SUBPROGRAM CALL WHEN THE BOUNDS OR DISCRIMINANTS + -- OF THE FORMAL DESIGNATED PARAMETER ARE DIFFERENT FROM + -- THOSE OF THE ACTUAL DESIGNATED PARAMETER. + + -- HISTORY: + -- CPP 07/23/84 CREATED ORIGINAL TEST. + -- VCL 10/27/87 MODIFIED THIS HEADER; ADDED STATEMENTS WHICH + -- REFERENCE THE ACTUAL PARAMETERS. + + WITH REPORT; USE REPORT; + PROCEDURE C64103F IS + BEGIN + TEST ("C64103F", "FOR OUT PARAMETERS OF AN ACCESS TYPE, " & + "CONSTRAINT_ERROR IS RAISED: AFTER A " & + "SUBPROGRAM CALL WHEN THE BOUNDS OR " & + "DISCRIMINANTS OF THE FORMAL DESIGNATED " & + "PARAMETER ARE DIFFERENT FROM THOSE OF THE " & + "ACTUAL DESIGNATED PARAMETER"); + + + BEGIN + DECLARE + TYPE AST IS ACCESS STRING; + SUBTYPE AST_3 IS AST(IDENT_INT(1)..IDENT_INT(3)); + SUBTYPE AST_5 IS AST(3..5); + X_3 : AST_3 := NEW STRING'(1..IDENT_INT(3) => 'A'); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P1 (X : OUT AST_5) IS + BEGIN + CALLED := TRUE; + X := NEW STRING'(3..5 => 'C'); + END P1; + BEGIN + P1 (AST_5 (X_3)); + IF X_3.ALL = STRING'(1 .. 3 => 'A') THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P1 (A2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P1 (A)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P1 (A)"); + END; + + DECLARE + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE A_ARRAY IS ACCESS ARRAY_TYPE; + SUBTYPE A1_ARRAY IS A_ARRAY (1..IDENT_INT(3)); + TYPE A2_ARRAY IS NEW A_ARRAY (2..4); + A0 : A1_ARRAY := NEW ARRAY_TYPE'(1..3 => TRUE); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P2 (X : OUT A2_ARRAY) IS + BEGIN + CALLED := TRUE; + X := NEW ARRAY_TYPE'(2..4 => FALSE); + END P2; + BEGIN + P2 (A2_ARRAY (A0)); + IF A0.ALL = ARRAY_TYPE'(1 .. 3 => TRUE) THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P2 (A2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P1 (A)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P2 (A)"); + END; + + DECLARE + TYPE SUBINT IS RANGE 0..8; + TYPE REC1 (DISC : SUBINT := 8) IS + RECORD + FIELD : SUBINT := DISC; + END RECORD; + TYPE A1_REC IS ACCESS REC1; + TYPE A2_REC IS NEW A1_REC (3); + A0 : A1_REC(4) := NEW REC1(4); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P3 (X : OUT A2_REC) IS + BEGIN + CALLED := TRUE; + X := NEW REC1(3); + END P3; + + BEGIN + P3 (A2_REC (A0)); + IF A0.ALL = REC1'(4,4) THEN + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A1)"); + ELSE + FAILED ("EXCEPTION NOT RAISED AFTER CALL -P3 (A2)"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "-P1 (A)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -P3 (A)"); + END; + END; + + RESULT; + END C64103F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- C64104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR + -- ARGUMENTS. SUBTESTS ARE: + -- (A) STATIC IN ARGUMENT. + -- (B) DYNAMIC IN ARGUMENT. + -- (C) IN OUT, OUT OF RANGE ON CALL. + -- (D) OUT, OUT OF RANGE ON RETURN. + -- (E) IN OUT, OUT OF RANGE ON RETURN. + + -- HISTORY: + -- DAS 01/14/81 + -- CPP 07/03/84 + -- LB 11/20/86 ADDED CODE TO ENSURE IN SUBTESTS WHICH CHECK + -- RETURNED VALUES, THAT SUBPROGRAMS ARE ACTUALLY + -- CALLED. + -- JET 08/04/87 FIXED HEADER FOR STANDARD FORMAT. + + WITH REPORT; USE REPORT; + PROCEDURE C64104A IS + + SUBTYPE DIGIT IS INTEGER RANGE 0..9; + + CALLED : BOOLEAN; + D : DIGIT; + I : INTEGER; + M1 : CONSTANT INTEGER := IDENT_INT(-1); + COUNT : INTEGER := 0; + SUBTYPE SI IS INTEGER RANGE M1 .. 10; + + PROCEDURE P1 (PIN : IN DIGIT; WHO : STRING) IS -- (A), (B) + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P1 " & WHO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P1 FOR " & WHO); + END P1; + + PROCEDURE P2 (PINOUT : IN OUT DIGIT; WHO : STRING) IS -- (C) + BEGIN + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - P2 " & WHO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P2 FOR " & WHO); + END P2; + + PROCEDURE P3 (POUT : OUT SI; WHO : STRING) IS -- (D) + BEGIN + IF WHO = "10" THEN + POUT := IDENT_INT(10); -- (10 IS NOT A DIGIT) + ELSE + POUT := -1; + END IF; + CALLED := TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P3 FOR " & WHO); + END P3; + + PROCEDURE P4 (PINOUT : IN OUT INTEGER; WHO : STRING) IS -- (E) + BEGIN + IF WHO = "10" THEN + PINOUT := 10; -- (10 IS NOT A DIGIT) + ELSE + PINOUT := IDENT_INT(-1); + END IF; + CALLED := TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN P4 FOR" & WHO); + END P4; + + BEGIN + + TEST ("C64104A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR OUT OF RANGE SCALAR ARGUMENTS"); + + BEGIN -- (A) + P1 (10, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P1 (10)"); + END; -- (A) + + BEGIN -- (B) + P1 (IDENT_INT (-1), "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P1 (" & + "IDENT_INT (-1))"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P1 (" & + "IDENT_INT (-1))"); + END; --(B) + + BEGIN -- (C) + I := IDENT_INT (10); + P2 (I, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P2 (10)"); + END; -- (C) + + BEGIN -- (C1) + I := IDENT_INT (-1); + P2 (I, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR P2 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P2 (-1)"); + END; -- (C1) + + BEGIN -- (D) + CALLED := FALSE; + D := IDENT_INT (1); + P3 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" & + " P3 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P3 WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P3 (10)"); + END; -- (D) + + BEGIN -- (D1) + CALLED := FALSE; + D := IDENT_INT (1); + P3 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" & + " P3 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P3 WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P3 (-1)"); + END; -- (D1) + + BEGIN -- (E) + CALLED := FALSE; + D := 9; + P4 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" & + " P4 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P4 WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P4 (10)"); + END; -- (E) + + BEGIN -- (E1) + CALLED := FALSE; + D := 0; + P4 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM" & + " P4 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P4 WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR P4 (-1)"); + END; -- (E1) + + IF (COUNT /= 8) THEN + FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED"); + END IF; + + RESULT; + + END C64104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C64104B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES + -- WITH RESPECT TO PARAMETERS OF RECORD TYPES. SUBTESTS INVOLVE + -- ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT EQUAL + -- TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS: + -- (A) IN PARAMETER, STATIC AGGREGATE. + -- (B) IN PARAMETER, DYNAMIC AGGREGATE. + -- (C) IN PARAMETER, VARIABLE. + -- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL. + -- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL. + + -- DAS 2/11/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104B IS + + USE REPORT; + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE REC (N : INT := 0) IS + RECORD + A : STRING (1..N); + END RECORD; + SUBTYPE SREC IS REC(N=>3); + PROCEDURE P1 (R : IN SREC) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL TO P1"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + PROCEDURE P2 (R : IN OUT SREC) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL TO P2"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P2"); + END P2; + + PROCEDURE P3 (R : OUT SREC) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL TO P3"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P3"); + END P3; + + BEGIN + + TEST ("C64104B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " & + "PARAMETERS OF RECORD TYPES"); + + BEGIN -- (A) + P1 ((2,"AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)"); + END; -- (A) + + BEGIN -- (B) + P1 ((IDENT_INT(2), "AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)"); + END; -- (B) + + DECLARE -- (C) + R : REC := (IDENT_INT(2), "AA"); + BEGIN -- (C) + P1 (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)"); + END; -- (C) + + DECLARE -- (D) + R : REC := (IDENT_INT(2), "AA"); + BEGIN -- (D) + P2 (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)"); + END; -- (D) + + + DECLARE -- (E) + R : REC; + BEGIN -- (E) + P3 (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)"); + END; -- (E) + + RESULT; + + END C64104B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,200 ---- + -- C64104C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE + -- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS, NAMELY + -- WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS + -- (BEFORE THE CALL FOR ALL MODES). + -- SUBTESTS ARE: + -- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE. + -- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE. + -- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE. + -- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE. + -- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE. + -- (F) IN OUT MODE, NULL STRING AGGREGATE. + -- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE). + -- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE. + + -- JRK 3/17/81 + -- SPS 10/26/82 + -- CPP 8/6/84 + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + + WITH REPORT; + PROCEDURE C64104C IS + + USE REPORT; + + BEGIN + TEST ("C64104C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS"); + + -------------------------------------------------- + + DECLARE -- (A) + SUBTYPE ST IS STRING (1..3); + + PROCEDURE P (A : ST) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL - (A)"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)"); + END P; + + BEGIN -- (A) + + P ("AB"); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE S IS INTEGER RANGE 1..3; + TYPE T IS ARRAY (S,S) OF INTEGER; + + PROCEDURE P (A : T) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL - (B)"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)"); + END P; + + BEGIN -- (B) + + P ((1..3 => (1..IDENT_INT(2) => 0))); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER; + SUBTYPE ST IS T (1..3,1..3); + V : T (1..IDENT_INT(2), 1..3) := + (1..IDENT_INT(2) => (1..3 => 0)); + + PROCEDURE P (A :ST) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL - (C)"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); + END P; + + BEGIN -- (C) + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF + INTEGER; + SUBTYPE ST IS T (1..3, 1..3, 1..3); + V : T (1..3, 1..2, 1..3) := + (1..3 => (1..2 => (1..3 => 0))); + + PROCEDURE P (A : IN OUT ST) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALLL - (D)"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); + END P; + + BEGIN -- (D) + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + + DECLARE -- (G) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER; + SUBTYPE ST IS T (2..1, 2..1); + V : T (2..1, 2..1) := (2..1 => (2..1 => ' ')); + + PROCEDURE P (A : IN OUT ST) IS + BEGIN + COMMENT ("OK CASE CALLED CORRECTLY"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)"); + END P; + + BEGIN -- (G) + + P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)"); + END; -- (G) + + -------------------------------------------------- + + -------------------------------------------------- + + RESULT; + END C64104C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C64104D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- ABW 6/11/82 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104D IS + + USE REPORT; + + BEGIN + TEST ("C64104D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1) IS PRIVATE; + TYPE AR IS ARRAY (E1 .. E3) OF INTEGER; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + A : AR; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A(E3); + V : A (E2) := NEW T (E2); + + PROCEDURE P (X : A1) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; + + END C64104D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C64104E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104E IS + + USE REPORT; + + BEGIN + TEST ("C64104E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A(BOOLEAN, 'A'..'C'); + V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B')); + + PROCEDURE P (X : A1) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C64104F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104F IS + + USE REPORT; + + BEGIN + TEST ("C64104F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE A IS ACCESS STRING; + SUBTYPE A1 IS A(1..3); + V : A (2..4) := NEW STRING (2..4); + + PROCEDURE P (X : IN OUT A1) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C64104G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104G IS + + USE REPORT; + + BEGIN + TEST ("C64104G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE T (C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INT := 0 + ) IS + RECORD + J : INTEGER; + CASE B IS + WHEN FALSE => + K : INTEGER; + WHEN TRUE => + S : STRING (1 .. I); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('Z', TRUE, 5); + V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5); + + PROCEDURE P (X : IN OUT SA ) IS + BEGIN + FAILED ("EXCEPTION NOT RAISED ON CALL"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104h.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C64104H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE + -- DISCRIMINANTS. + + -- HISTORY: + -- JRK 03/18/81 CREATED ORIGINAL TEST. + -- NL 10/13/81 + -- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE + -- ACTUALLY BEING CALLED. + -- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. + + + WITH REPORT; + PROCEDURE C64104H IS + + USE REPORT; + + BEGIN + TEST ("C64104H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..10; + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C'; + TYPE T (I : INT := 0; C : CHAR := 'A') IS + LIMITED PRIVATE; + PRIVATE + TYPE T (I : INT := 0; C : CHAR := 'A') IS + RECORD + J : INTEGER; + CASE C IS + WHEN 'A' => + K : INTEGER; + WHEN 'B' => + S : STRING (1..I); + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + END PKG; + USE PKG; + + CALLED : BOOLEAN; + TYPE A IS ACCESS T; + + V : A (2,'B') := NEW T (2,'B'); + + PROCEDURE P (X : IN OUT A) IS + BEGIN + CALLED := TRUE; + X := NEW T (2,'A'); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + CALLED := FALSE; + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104i.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C64104I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL + -- BOUNDS. + + -- HISTORY: + -- JRK 03/18/81 CREATED ORIGINAL TEST. + -- NL 10/13/81 + -- LB 11/25/86 ADDED CODE TO ENSURE THAT SUBPROGRAMS ARE + -- ACTUALLY BEING CALLED. + -- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. + + + WITH REPORT; + PROCEDURE C64104I IS + + USE REPORT; + + BEGIN + TEST ("C64104I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN; + + TYPE E IS (E1, E2, E3); + + TYPE T IS ARRAY (CHARACTER RANGE <>, + E RANGE <>, + BOOLEAN RANGE <> + ) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A ('A'..'Z', E1..E2, BOOLEAN) := + NEW T ('A'..'Z', E1..E2, BOOLEAN); + + PROCEDURE P (X : IN OUT A) IS + BEGIN + CALLED := TRUE; + IF EQUAL (3,3) THEN + X := NEW T ('A'..'Z', E2..E3, BOOLEAN); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + CALLED := FALSE; + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104j.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C64104J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE + -- DIMENSIONAL BOUNDS. + + -- HISTORY: + -- JRK 03/18/81 CREATED ORIGINAL TEST. + -- NL 10/13/81 + -- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO + -- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED. + + WITH REPORT; + PROCEDURE C64104J IS + + USE REPORT; + + BEGIN + TEST ("C64104J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE A IS ACCESS STRING; + + CALLED : BOOLEAN := FALSE; + + V : A (1..3) := NEW STRING (1..3); + + PROCEDURE P (X : OUT A) IS + BEGIN + CALLED := TRUE; + X := NEW STRING (2..3); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104k.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C64104K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC + -- RECORD DISCRIMINANT. + + -- HISTORY: + -- JRK 03/18/81 CREATED ORIGINAL TEST. + -- NL 10/13/81 + -- SPS 10/26/82 + -- BCB 11/12/87 CHANGED HEADING TO STANDARD FORMAT. ADDED CODE TO + -- ENSURE THAT SUBPROGRAMS ARE ACTUALLY CALLED. + + WITH REPORT; + PROCEDURE C64104K IS + + USE REPORT; + + BEGIN + TEST ("C64104K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + A : ARR (FALSE..B); + END RECORD; + + TYPE A IS ACCESS T; + + CALLED : BOOLEAN := FALSE; + + V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE)); + + PROCEDURE P (X : OUT A) IS + BEGIN + CALLED := TRUE; + X := NEW T (TRUE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("SUBPROGRAM P WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + + END C64104K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104l.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C64104L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC + -- PRIVATE DISCRIMINANTS. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104L IS + + USE REPORT; + + BEGIN + TEST ("C64104L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER; + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR (E1 .. D); + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(E2, TRUE); + V : A (E2, FALSE) := NEW T (E2, FALSE); + + ENTERED : BOOLEAN := FALSE; + + PROCEDURE P (X : OUT SA ) IS + BEGIN + ENTERED := TRUE; + X := NEW T (E2, TRUE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("CONSTRAINT_ERROR RAISED BEFORE " & + "CALL"); + END IF; + WHEN OTHERS => + IF NOT ENTERED THEN + FAILED ("OTHER EXCEPTION RAISED BEFORE CALL"); + ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " & + "RETURN"); + END IF; + END; + + ------------------------------------------------ + + RESULT; + + END C64104L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104m.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C64104M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO + -- DIMENSIONAL BOUNDS. + + -- JRK 3/18/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64104M IS + + USE REPORT; + + BEGIN + TEST ("C64104M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE T IS ARRAY (INTEGER RANGE <>, + CHARACTER RANGE <> + ) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z'); + + ENTERED : BOOLEAN := FALSE; + Y : CONSTANT CHARACTER := IDENT_CHAR('Y'); + SUBTYPE SA IS A(1..10, 'A'..Y); + PROCEDURE P (X : OUT SA ) IS + BEGIN + ENTERED := TRUE; + X := NEW T (1..10, 'A'..IDENT_CHAR('Y')); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE"); + END P; + + BEGIN + + P (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("CONSTRAINT_ERROR RAISED BEFORE " & + "CALL"); + END IF; + WHEN OTHERS => + IF NOT ENTERED THEN + FAILED ("OTHER EXCEPTION RAISED BEFORE CALL"); + ELSE FAILED ("WRONG EXCEPTION RAISED AFTER " & + "RETURN"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + + END C64104M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104n.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C64104N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL + -- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE + -- WHERE THE VALUE OF THE FORMAL PARAMETER DOES NOT BELONG TO THE + -- SUBTYPE OF THE ACTUAL PARAMETER. + + -- HISTORY: + -- DAVID A. TAFFS + -- CPP 07/23/84 + -- RDH 04/18/90 REVISED TO CHECK THAT SUBPROGRAM IS ACTUALLY + -- CALLED. + -- THS 09/21/90 REWORDED COMMENT STATING THAT THE TEST DOES NOT + -- ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9). + + WITH REPORT; USE REPORT; + PROCEDURE C64104N IS + + BEGIN + TEST ("C64104N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " & + "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER " & + "BOUNDS DIFFER"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS NEW INTEGER; + DC : CONSTANT T := -1; + END P; + + PROCEDURE Q (X : IN OUT P.T) IS + BEGIN + CALLED := TRUE; + X := P.DC; + IF P. "=" (X, P.DC) THEN + COMMENT("PROCEDURE Q WAS CALLED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE SUBPROGRAM"); + END Q; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + Q (Y); + END CALL; + + -- NOTE CALL HAS VARIABLE OF A PRIVATE TYPE AS AN OUT PARAMETER. + -- THIS TEST DOES NOT ACCEPT THE LITERAL INTERPRETATION OF 6.4.1(9). + -- REFER TO ADA IMPLEMENTOR'S GUIDE 6.4.1 SEMANTIC RAMIFICATION 19 + -- AND AI-00025 FOR CLARIFICATION AS TO WHY THE LITERAL + -- INTERPRETATION IS REJECTED. + + PACKAGE BODY P IS + Z : T RANGE 0..1 := 0; + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL(Z); + END PP; + END P; + + BEGIN + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- EXCEPTION + BEGIN + FAILED ("NO EXCEPTION RAISED"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED("SUBPROGRAM Q WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + END; + + RESULT; + + END; + END C64104N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64104o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64104o.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C64104O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE + -- CHECK THAT CONSTRAINT_ERROR IS RAISED AT THE PLACE OF THE CALL + -- FOR THE CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE + -- THE ACTUAL BOUNDS OR DISCRIMINANTS OF THE DESIGNATED OBJECT DIFFER + -- FROM THOSE OF THE FORMAL. + + -- HISTORY + -- CPP 7/23/84 CREATED ORIGINAL TEST. + -- DHH 8/31/87 ADDED COMMENT IN PROCEDURE Q SO THAT CODE WILL NOT BE + -- OPTIMIZED OUT OF EXISTENCE. + + + WITH REPORT; USE REPORT; + PROCEDURE C64104O IS + + BEGIN + + TEST ("C64104O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " & + "CONSTRAINT_ERROR WHEN ACTUAL AND FORMAL PARAMETER BOUNDS " & + "DIFFER"); + + DECLARE + + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS ACCESS STRING; + DC : CONSTANT T := NEW STRING'("AAA"); + END P; + + PROCEDURE Q (X : IN OUT P.T) IS + + BEGIN + + CALLED := TRUE; + X := P.DC; + IF P. "=" (X, P.DC) THEN + COMMENT("PROCEDURE Q WAS CALLED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED INSIDE SUBPROGRAM"); + END Q; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + Q(Y); + END CALL; + + PACKAGE BODY P IS + Z : T(1..5) := NEW STRING'("CCCCC"); + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL(Z); + END PP; + END P; + + BEGIN + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("SUBPROGRAM Q WAS NOT CALLED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; + END; + + END C64104O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C64105A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN + -- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE + -- RANGE CONSTRAINTS OF THE FORMAL PARAMETER. + + -- DAS 1/29/81 + -- CPP 8/6/84 + + WITH REPORT; + PROCEDURE C64105A IS + + USE REPORT; + + SUBTYPE SUBINT1 IS INTEGER RANGE -10..10; + SUBTYPE SUBINT2 IS INTEGER RANGE -20..20; + + I10 : SUBINT1 := 10; + I20 : SUBINT2 := 20; + + PROCEDURE P1 (I : OUT SUBINT1) IS + BEGIN + I := SUBINT1'FIRST; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + BEGIN + + TEST ("C64105A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED" & + " AT THE TIME OF CALL WHEN THE VALUE OF AN" & + " ACTUAL OUT SCALAR PARAMETER DOES NOT" & + " SATISFY THE RANGE CONSTRAINTS OF THE FORMAL" & + " PARAMETER"); + + DECLARE + BEGIN + P1 (SUBINT1(I20)); + IF I20 /= IDENT_INT(-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO P1 - 1"); + END; + + DECLARE + BEGIN + I20 := IDENT_INT(20); + P1 (I20); + IF I20 /= IDENT_INT(-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO P1 - 2"); + END; + + RESULT; + + END C64105A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C64105B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- IN THE FOLLOWING CIRCUMSTANCES: + -- (1) BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS + -- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT + -- FROM THE FORMAL PARAMETER. + -- (2) + -- (3) + -- SUBTESTS ARE: + -- (A) CASE 1, IN MODE, STATIC ONE DIMENSIONAL BOUNDS. + -- (B) CASE 1, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + -- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + -- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + + -- JRK 3/20/81 + -- SPS 10/26/82 + -- CPP 8/6/84 + + WITH REPORT; + PROCEDURE C64105B IS + + USE REPORT; + + BEGIN + TEST ("C64105B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE THE CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS " & + "PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT " & + "FROM THE FORMAL PARAMETER" ); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(E2..E4); + V : A (E1..E2) := NULL; + + PROCEDURE P (X : SA ) IS + BEGIN + NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (A)"); + END P; + + BEGIN -- (A) + + P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + PROCEDURE P (X : IN OUT SA ) IS + BEGIN + NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (B)"); + END P; + + BEGIN -- (B) + + P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(E2..E4); + V : A (E1..E2) := NULL; + + PROCEDURE P (X : SA ) IS + BEGIN + NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); + END P; + + BEGIN -- (C) + + P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + PROCEDURE P (X : IN OUT SA ) IS + BEGIN + NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); + END P; + + BEGIN -- (D) + + P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + RESULT; + END C64105B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- C64105C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- IN THE FOLLOWING CIRCUMSTANCES: + -- (1) + -- (2) AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL + -- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS + -- DIFFERENT CONSTRAINTS. + -- (3) + -- SUBTESTS ARE: + -- (C) CASE 2, IN OUT MODE, STATIC PRIVATE DISCRIMINANT. + -- (D) CASE 2, OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + -- (E) SAME AS (C), WITH TYPE CONVERSION. + -- (F) SAME AS (D), WITH TYPE CONVERSION. + + -- JRK 3/20/81 + -- SPS 10/26/82 + -- CPP 8/8/84 + + WITH REPORT; + PROCEDURE C64105C IS + + USE REPORT; + + BEGIN + TEST ("C64105C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AFTER THE CALL, WHEN AN IN OUT OR OUT FORMAL " & + "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " & + "DIFFERENT CONSTRAINTS" ); + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + PROCEDURE P (X : IN OUT SA) IS + BEGIN + ENTERED := TRUE; + X := NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); + END P; + + BEGIN -- (C) + + P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + PROCEDURE P (X : OUT SA) IS + BEGIN + ENTERED := TRUE; + X := NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); + END P; + + BEGIN -- (D) + + P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + DECLARE -- (E) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + PROCEDURE P (X : IN OUT SA) IS + BEGIN + ENTERED := TRUE; + X := NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (C)"); + END P; + + BEGIN -- (E) + + P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + -------------------------------------------------- + + DECLARE -- (F) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + PROCEDURE P (X : OUT SA) IS + BEGIN + ENTERED := TRUE; + X := NULL; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (D)"); + END P; + + BEGIN -- (D) + + P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (F)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (F)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (F)"); + END; -- (F) + + -------------------------------------------------- + + RESULT; + END C64105C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64105d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64105d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C64105D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- IN THE FOLLOWING CIRCUMSTANCES: + -- (1) + -- (2) + -- (3) BEFORE OR AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL + -- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE + -- CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL + -- PARAMETER. + -- SUBTESTS ARE: + -- (G) CASE 3, STATIC LIMITED PRIVATE DISCRIMINANT. + -- (H) CASE 3, DYNAMIC ONE DIMENSIONAL BOUNDS. + + -- JRK 3/20/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C64105D IS + + USE REPORT; + + BEGIN + TEST ("C64105D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AND AFTER THE CALL, WHEN AN UNCONSTRAINED ACTUAL " & + "OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE " & + "CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL " & + "PARAMETER" ); + + -------------------------------------------------- + + DECLARE -- (G) + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..5; + TYPE T (I : INT := 0) IS LIMITED PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE T (I : INT := 0) IS + RECORD + J : INTEGER; + A : ARR (1..I); + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A(3); + V : A := NEW T (2); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P (X : OUT SA) IS + BEGIN + CALLED := TRUE; + X := NEW T (3); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (G)"); + END P; + + BEGIN -- (G) + + P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (G)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (G)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (G)"); + END; -- (G) + + -------------------------------------------------- + + DECLARE -- (H) + + TYPE A IS ACCESS STRING; + SUBTYPE SA IS A (1..2); + V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7)); + CALLED : BOOLEAN := FALSE; + + PROCEDURE P (X : OUT SA) IS + BEGIN + CALLED := TRUE; + X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE - (H)"); + END P; + + BEGIN -- (H) + + P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (H)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (H)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (H)"); + END; -- (H) + + -------------------------------------------------- + + RESULT; + END C64105D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,351 ---- + -- C64106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY + -- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS. + -- SUBTESTS ARE: + -- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS. + -- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS. + -- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS. + -- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS. + + -- DAS 1/15/81 + -- JBG 5/16/83 + -- CPP 5/22/84 + + WITH REPORT; + PROCEDURE C64106A IS + + USE REPORT; + + BEGIN + TEST ("C64106A", "CHECK USE OF ACTUAL CONSTRAINTS BY " & + "UNCONSTRAINED FORMAL PARAMETERS"); + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + REC1 : RECTYPE := (10,10,"0123456789"); + REC2 : RECTYPE := (17,7,"C64106A.........."); + REC3 : RECTYPE := (1,1,"A"); + REC4 : RECTYPE; -- 80 + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE); + END PKG; + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) IS + BEGIN + IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN + FAILED ("RECORD TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN + FAILED ("RECORD TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN + FAILED ("RECORD TYPE IN OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + REC2 := PKG.REC2; + END CHK_RECTYPE1; + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS + BEGIN + IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN + FAILED ("RECORD TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END CHK_RECTYPE2; + END PKG; + + BEGIN -- (A) + + PKG.CHK_RECTYPE1 (PKG.REC1, PKG.REC2, PKG.REC3); + PKG.CHK_RECTYPE2 (PKG.REC4); + + END; -- (A) + + --------------------------------------------- + + B : DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE; + + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE); + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE(10); + REC2 : PKG.RECTYPE(17); + REC3 : PKG.RECTYPE(1); + REC4 : PKG.RECTYPE(10); + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) IS + BEGIN + IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN + FAILED ("PRIVATE TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN + FAILED ("PRIVATE TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN + FAILED ("PRIVATE TYPE IN OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF ACTUAL"); + END IF; + REC2 := B.REC2; + END CHK_RECTYPE1; + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS + BEGIN + IF (REC.CONSTRAINT /= IDENT_INT(10)) THEN + FAILED ("PRIVATE TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END CHK_RECTYPE2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C64106A.........."); + REC3 := (1,1,"A"); + + END PKG; + + BEGIN -- (B) + + PKG.CHK_RECTYPE1 (REC1, REC2, REC3); + PKG.CHK_RECTYPE2 (REC4); + + END B; -- (B) + + --------------------------------------------- + + C : DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + LIMITED PRIVATE; + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE); + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE; -- 10 + REC2 : PKG.RECTYPE; -- 17 + REC3 : PKG.RECTYPE; -- 1 + REC4 : PKG.RECTYPE; -- 80 + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) IS + BEGIN + IF (REC1.CONSTRAINT /= IDENT_INT(10)) THEN + FAILED ("LIMITED PRIVATE TYPE IN PARAMETER " & + "DID NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF (REC2.CONSTRAINT /= IDENT_INT(17)) THEN + FAILED ("LIMITED PRIVATE TYPE OUT PARAMETER " & + "DID NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF (REC3.CONSTRAINT /= IDENT_INT(1)) THEN + FAILED ("LIMITED PRIVATE TYPE IN OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + REC2 := C.REC2; + END CHK_RECTYPE1; + + PROCEDURE CHK_RECTYPE2 (REC : OUT RECTYPE) IS + BEGIN + IF (REC.CONSTRAINT /= IDENT_INT(80)) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END CHK_RECTYPE2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C64106A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (C) + + PKG.CHK_RECTYPE1 (REC1, REC2, REC3); + PKG.CHK_RECTYPE2 (REC4); + + END C; -- (C) + + --------------------------------------------- + + D : DECLARE -- (D) + + TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF + CHARACTER; + + A1, A2, A3 : ATYPE(-1..1, 4..5) := (('A','B'), + ('C','D'), + ('E','F')); + + A4 : ATYPE(-1..1, 4..5); + + CA1 : CONSTANT ATYPE(8..9, -7..INTEGER'FIRST) := + (8..9 => (-7..INTEGER'FIRST => 'A')); + + S1 : STRING(1..INTEGER'FIRST) := ""; + S2 : STRING(-5..-7) := ""; + S3 : STRING(1..0) := ""; + + PROCEDURE CHK_ARRAY1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE; + A3 : IN OUT ATYPE) IS + BEGIN + IF ((A1'FIRST(1) /= IDENT_INT(-1)) OR + (A1'LAST(1) /= IDENT_INT(1)) OR + (A1'FIRST(2) /= IDENT_INT(4)) OR + (A1'LAST(2) /= IDENT_INT(5))) THEN + FAILED ("ARRAY TYPE IN PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL"); + END IF; + IF ((A2'FIRST(1) /= IDENT_INT(-1)) OR + (A2'LAST(1) /= IDENT_INT(1)) OR + (A2'FIRST(2) /= IDENT_INT(4)) OR + (A2'LAST(2) /= IDENT_INT(5))) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID NOT USE" & + "CONSTRAINTS OF ACTUAL"); + END IF; + IF ((A3'FIRST(1) /= IDENT_INT(-1)) OR + (A3'LAST(1) /= IDENT_INT(1)) OR + (A3'FIRST(2) /= IDENT_INT(4)) OR + (A3'LAST(2) /= IDENT_INT(5))) THEN + FAILED ("ARRAY TYPE IN OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL"); + END IF; + A2 := D.A2; + END CHK_ARRAY1; + + PROCEDURE CHK_ARRAY2 (A4 : OUT ATYPE) IS + BEGIN + IF ((A4'FIRST(1) /= IDENT_INT(-1)) OR + (A4'LAST(1) /= IDENT_INT(1)) OR + (A4'FIRST(2) /= IDENT_INT(4)) OR + (A4'LAST(2) /= IDENT_INT(5))) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF UNINITIALIZED " & + "ACTUAL"); + END IF; + A4 := A2; + END CHK_ARRAY2; + + PROCEDURE CHK_STRING (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING) IS + BEGIN + IF ((S1'FIRST /= IDENT_INT(1)) OR + (S1'LAST /= IDENT_INT(INTEGER'FIRST))) THEN + FAILED ("STRING TYPE IN PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL " & + "STRING"); + END IF; + IF ((S2'FIRST /= IDENT_INT(-5)) OR + (S2'LAST /= IDENT_INT(-7))) THEN + FAILED ("STRING TYPE IN OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL STRING"); + END IF; + IF ((S3'FIRST /= IDENT_INT(1)) OR + (S3'LAST /= IDENT_INT(0))) THEN + FAILED ("STRING TYPE OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL STRING"); + END IF; + S3 := ""; + END CHK_STRING; + + BEGIN -- (D) + CHK_ARRAY1 (A1, A2, A3); + CHK_ARRAY2 (A4); + CHK_STRING (S1, S2, S3); + END D; -- (D) + + RESULT; + END C64106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,237 ---- + -- C64106B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED RECORD, + -- PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT CONSTRAINTS + -- RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE THE + -- CONSTRAINT OF THE ACTUAL PARAMETER. + -- SUBTESTS ARE: + -- (A) RECORD TYPE. + -- (B) PRIVATE TYPE. + -- (C) LIMITED PRIVATE TYPE. + + -- DAS 1/15/81 + -- CPP 8/9/84 + + WITH REPORT; + PROCEDURE C64106B IS + + USE REPORT; + + BEGIN + + TEST ("C64106B", "CHECK ASSIGNMENT TO FORMAL PARAMETERS OF " & + "UNCONSTRAINED TYPE (WITH NO DEFAULT)"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END PKG; + + REC9 : PKG.RECTYPE(IDENT_INT(9)) := + (IDENT_INT(9), 9, "123456789"); + REC6 : PKG.RECTYPE(IDENT_INT(6)) := + (IDENT_INT(6), 5, "AEIOUY"); + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) IS + + REC4 : CONSTANT RECTYPE(IDENT_INT(4)) := + (IDENT_INT(4), 4, "OOPS"); + + BEGIN + BEGIN -- (A.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED - A.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A.1"); + END; -- (A.1) + + BEGIN -- (A.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED - A.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A.2"); + END; -- (A.2) + + REC9 := (IDENT_INT(9), 9, "987654321"); + + END CHK_RECTYPE; + END PKG; + + BEGIN -- (A) + + PKG.CHK_RECTYPE (REC9, REC6); + IF REC9.STRFIELD /= IDENT_STR("987654321") THEN + FAILED ("ASSIGNMENT TO REC9 FAILED - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE; + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC9 : PKG.RECTYPE(9); + REC6 : PKG.RECTYPE(6); + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + BEGIN -- (B.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED - B.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B.1"); + END; -- (B.1) + + BEGIN -- (B.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED - B.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B.2"); + END; -- (B.2) + END CHK_RECTYPE; + + BEGIN + REC9 := (9, 9, "123456789"); + REC6 := (6, 5, "AEIOUY"); + END PKG; + + BEGIN -- (B) + + PKG.CHK_RECTYPE (REC9, REC6); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE; + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC6 : PKG.RECTYPE(IDENT_INT(6)); + REC9 : PKG.RECTYPE(IDENT_INT(9)); + + PACKAGE BODY PKG IS + + PROCEDURE CHK_RECTYPE (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + BEGIN -- (C.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED - C.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - C.1"); + END; -- (C.1) + + BEGIN -- (C.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED - C.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - C.2"); + END; -- (C.2) + END CHK_RECTYPE; + + BEGIN + REC6 := (6, 5, "AEIOUY"); + REC9 := (9, 9, "123456789"); + END PKG; + + BEGIN -- (C) + + PKG.CHK_RECTYPE (REC9, REC6); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C64106B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,309 ---- + -- C64106C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED + -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT + -- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS + -- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING + -- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER. + + -- SUBTESTS ARE: + -- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. + -- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. + -- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + + -- DAS 1/16/81 + -- VKG 1/7/83 + -- CPP 8/9/84 + + WITH REPORT; + PROCEDURE C64106C IS + + USE REPORT; + + BEGIN + + TEST ("C64106C", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " & + "UNCONSTRAINED TYPES (WITH DEFAULTS)"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + REC91,REC92,REC93 : RECTYPE(9); + REC_OOPS : RECTYPE(4); + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END PKG; + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + IF (NOT REC11'CONSTRAINED) OR + (REC11.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ("CONSTRAINT ON RECORD " & + "TYPE IN PARAMETER " & + "NOT RECOGNIZED"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + FAILED ("CONSTRAINT ERROR NOT RAISED - " & + "A.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "A.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "A.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "A.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (A) + + PKG.P (PKG.REC91, PKG.REC92, PKG.REC93); + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + IF (NOT REC11'CONSTRAINED) OR + (REC11.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ("CONSTRAINT ON PRIVATE " & + "TYPE IN PARAMETER " & + "NOT RECOGNIZED"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + FAILED ("CONSTRAINT ERROR NOT RAISED - " & + "B.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "B.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "B.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "B.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.P (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91,REC92,REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + IF (NOT REC11'CONSTRAINED) OR + (REC11.CONSTRAINT /= 9) THEN + FAILED ("CONSTRAINT ON LIMITED PRIVATE " & + "TYPE IN PARAMETER " & + "NOT RECOGNIZED"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + FAILED ("CONSTRAINT ERROR NOT RAISED - " & + "C.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "C.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "C.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "C.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.P (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C64106C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64106d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64106d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,280 ---- + -- C64106D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO FORMAL PARAMETERS OF UNCONSTRAINED + -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT + -- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER + -- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT + -- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER. + + -- SUBTESTS ARE: + -- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. + -- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. + -- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + + -- JRK 4/16/81 + -- CPP 8/9/84 + -- JRK 11/28/84 + + WITH REPORT; + PROCEDURE C64106D IS + + USE REPORT; + + BEGIN + + TEST ("C64106D", "CHECK ASSIGNMENTS TO FORMAL PARAMETERS OF " & + "UNCONSTRAINED TYPES WITH UNCONSTRAINED " & + "ACTUAL PARAMETERS"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE := + (IDENT_INT(5), 5, IDENT_STR("12345")); + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + + IF NOT REC11'CONSTRAINED THEN + FAILED ("REC11 IS NOT CONSTRAINED - A.1"); + END IF; + IF REC11.CONSTRAINT /= IDENT_INT(9) THEN + FAILED ("REC11 CONSTRAINT IS NOT 9 " & + "- A.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - A.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + USE PKG; + + BEGIN -- (A) + + PKG.P (REC91, REC92, REC93); + IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN + FAILED ("RESULTANT VALUE OF REC92 OR REC93 INCORRECT"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + + IF REC3'CONSTRAINED THEN + FAILED ("REC3 IS CONSTRAINED - B.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - B.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.P (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + PROCEDURE P (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) IS + + PROCEDURE P1 (REC11 : IN RECTYPE; + REC12 : IN OUT RECTYPE; + REC13 : OUT RECTYPE) IS + BEGIN + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER + REC12 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - C.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER + REC13 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - C.2"); + END; + END P1; + + BEGIN + P1 (REC1, REC2, REC3); + END P; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.P (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C64106D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64107a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64107a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64107a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64107a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C64107A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE + -- TIME OF CALL. + + -- DAS 1/29/81 + -- SPS 12/13/82 + + WITH REPORT; + PROCEDURE C64107A IS + + USE REPORT; + + TYPE VECTOR IS ARRAY (1..10) OF INTEGER; + TYPE PTRINT IS ACCESS INTEGER; + + I : INTEGER := 1; + A : VECTOR := (1,2,3,4,5,6,7,8,9,10); + P1 : PTRINT := NEW INTEGER'(2); + P2 : PTRINT := P1; + + PROCEDURE PROC1 (I : OUT INTEGER; J : OUT INTEGER) IS + BEGIN + I := 10; + J := -1; + END PROC1; + + PROCEDURE PROC2 (P : OUT PTRINT; I : OUT INTEGER) IS + BEGIN + P := NEW INTEGER'(3); + I := 5; + END PROC2; + + BEGIN + + TEST ("C64107A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED" & + " AND IDENTIFIED AT THE TIME OF CALL"); + + PROC1 (I, A(I)); + IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN + FAILED ("A(I) EVALUATED UPON RETURN"); + END IF; + + PROC2 (P1, P1.ALL); + IF (P2.ALL /= 5) THEN + FAILED ("P1.ALL EVALUATED UPON RETURN"); + END IF; + + RESULT; + + END C64107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64108a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- C64108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED + -- AS ACTUAL PARAMETERS. + + -- DAS 2/10/81 + -- SPS 10/26/82 + -- SPS 11/5/82 + + WITH REPORT; + PROCEDURE C64108A IS + + USE REPORT; + SUBTYPE INT IS INTEGER RANGE 1..3; + TYPE REC (N : INT) IS + RECORD + S : STRING (1..N); + END RECORD; + TYPE PTRSTR IS ACCESS STRING; + + R1,R2,R3 : REC(3); + S1,S2,S3 : STRING (1..3); + PTRTBL : ARRAY (1..3) OF PTRSTR; + + PROCEDURE P1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING) IS + BEGIN + S3 := S2; + S2 := S1; + END P1; + + PROCEDURE P2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER) IS + BEGIN + C3 := C2; + C2 := C1; + END P2; + + FUNCTION F1 (X : INT) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL(X); + END F1; + + FUNCTION "+" (S1,S2 : STRING) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL(CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1); + END "+"; + + BEGIN + + TEST ("C64108A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE" & + " NAMES ARE PERMITTED AS ACTUAL PARAMETERS"); + + S1 := "AAA"; + S2 := "BBB"; + P1 (S1, S2, S3); + IF (S2 /= "AAA") OR (S3 /= "BBB") THEN + FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + S3 := IDENT_STR("CCC"); + P2 (S1(1), S2(IDENT_INT(1)), S3(1)); + IF (S2 /= "ABB") OR (S3 /= "BCC") THEN + FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " & + "WORKING"); + END IF; + + R1.S := "AAA"; + R2.S := "BBB"; + P1 (R1.S, R2.S, R3.S); + IF (R2.S /= "AAA") OR (R3.S /= "BBB") THEN + FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER" & + " NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + P1 (S1(1..IDENT_INT(2)), S2(1..2), S3(IDENT_INT(1)..IDENT_INT(2))); + IF (S2 /= "AAB") OR (S3 /= "BBC") THEN + FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + P1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL); + IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN + FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" & + " PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + S1 := IDENT_STR("AAA"); + S2 := IDENT_STR("BBB"); + S3 := IDENT_STR("CCC"); + P1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL); + IF (PTRTBL(2).ALL /= "AAA") OR (PTRTBL(3).ALL /= "BBB") THEN + FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR FUNCTION" & + " VALUE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + P2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1))); + IF (PTRTBL(2).ALL /= "ABB") OR (PTRTBL(3).ALL /= "BCC") THEN + FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL" & + " PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + P1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), F1(3)(2..IDENT_INT(3))); + IF (PTRTBL(2).ALL /= "BAA") OR (PTRTBL(3).ALL /= "CBB") THEN + FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER" & + " NOT WORKING"); + END IF; + + RESULT; + + END C64108A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C64109A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (A) CHECK ALL PARAMETER MODES. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109A IS + + BEGIN + TEST ("C64109A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS"); + + -------------------------------------------- + + DECLARE -- (A) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5)); + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + REC : RECORD_TYPE := (I => 23, + A => (1..3 => IDENT_INT(7), 4..5 => 9)); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR + ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER"); + END IF; + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR'FIRST /= IDENT_INT(1) OR + ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN"); + END IF; + + RETURN TRUE; + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN OUT PARAMETER NOT PASSED " & + "CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(1) OR + ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 5); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= IDENT_INT(1) OR + ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS FOR OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 3); + END P3; + + BEGIN -- (A) + + P1 (REC.A); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + BOOL := F1 (REC.A); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + + P2 (REC.A); + IF REC.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + + P3 (REC.A); + IF REC.A /= (3, 3, 3, 3, 3) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + + END; -- (A) + + -------------------------------------------- + + RESULT; + END C64109A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- C64109B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (B) CHECK MULTIDIMENSIONAL ARRAYS. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109B IS + + BEGIN + TEST ("C64109B", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " & + "MULTIDIMENSIONAL ARRAYS"); + + DECLARE -- (B) + + TYPE MULTI_TYPE IS ARRAY (POSITIVE RANGE <>, + POSITIVE RANGE <>) OF BOOLEAN; + SUBTYPE MULTI_SUBTYPE IS MULTI_TYPE (1..2, 1..3); + TYPE RECORD_TYPE IS + RECORD + I : BOOLEAN; + A : MULTI_SUBTYPE; + END RECORD; + REC : RECORD_TYPE := + (I => FALSE, + A => (1..2 => (1..3 => IDENT_BOOL(TRUE)))); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : MULTI_TYPE) IS + BEGIN + IF ARR /= (1..2 => (1..3 => TRUE)) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN + FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER"); + ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3 + THEN + FAILED ("2ND DIM NOT CORRECT - IN PARAMETER"); + END IF; + END P1; + + FUNCTION F1 (ARR : MULTI_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (1..2 => (1..3 => TRUE)) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN + FAILED ("FIRST DIM NOT CORRECT - IN PARAMETER FN"); + ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3 + THEN + FAILED ("2ND DIM NOT CORRECT - IN PARAMETER FN"); + END IF; + RETURN TRUE; + END F1; + + PROCEDURE P2 (ARR : IN OUT MULTI_TYPE) IS + BEGIN + IF ARR /= (1..2 => (1..3 => TRUE)) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN + FAILED ("FIRST DIM NOT CORRECT - IN OUT PARAMETER"); + ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3 + THEN + FAILED ("2ND DIM NOT CORRECT - IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE(1) => (ARR'RANGE(2) => FALSE)); + END P2; + + PROCEDURE P3 (ARR : OUT MULTI_TYPE) IS + BEGIN + FOR I IN 1 .. 2 LOOP + FOR J IN 1 .. 3 LOOP + IF (J MOD 2) = 0 THEN + ARR(I, J) := TRUE; + ELSE + ARR(I, J) := FALSE; + END IF; + END LOOP; + END LOOP; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(2) THEN + FAILED ("FIRST DIM NOT CORRECT - OUT PARAMETER"); + ELSIF ARR'FIRST(2) /= IDENT_INT(1) OR ARR'LAST(2) /= 3 + THEN + FAILED ("2ND DIM NOT CORRECT - OUT PARAMETER"); + END IF; + END P3; + + BEGIN -- (B) + + P1 (REC.A); + IF REC.A /= (1..2 => (1..3 => TRUE)) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + BOOL := F1 (REC.A); + IF REC.A /= (1..2 => (1..3 => TRUE)) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + + P2 (REC.A); + IF REC.A /= (1..2 => (1..3 => FALSE)) THEN + FAILED ("IN OUT PARAM CHANGED BY PROCEDURE"); + END IF; + + P3 (REC.A); + FOR I IN 1 .. 2 LOOP + FOR J IN 1 .. 3 LOOP + IF (J MOD 2) = 0 THEN + IF REC.A(I, J) /= TRUE THEN + FAILED ("OUT PARAM RETURNED " & + "INCORRECTLY - (B)"); + END IF; + ELSE + IF REC.A(I, J) /= FALSE THEN + FAILED ("OUT PARAM RETURNED " & + "INCORRECTLY - (B)2"); + END IF; + END IF; + END LOOP; + END LOOP; + + END; -- (B) + + RESULT; + END C64109B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- C64109C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY + -- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE + -- DISCRIMINANT. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109C IS + + BEGIN + TEST ("C64109C", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " & + "RECORDS WITH DISCRIMINANTS"); + + DECLARE -- (C) + + SUBTYPE SUBINT IS INTEGER RANGE 1..6; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER; + TYPE RECORD_TYPE (BOUND : INTEGER) IS + RECORD + B : BOOLEAN; + A : ARRAY_TYPE (1..BOUND); + AA : ARRAY_TYPE (BOUND..6); + END RECORD; + REC : RECORD_TYPE (BOUND => IDENT_INT(4)) := + (BOUND => 4, + B => TRUE, + A => (1..IDENT_INT(4) => 6), + AA => (4..6 => 8)); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS - IN PARAMETER"); + END IF; + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN"); + END IF; + RETURN TRUE; + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (8, 8, 8) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(6) THEN + FAILED ("WRONG BOUNDS - IN OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 10); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS - OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 4); + END P3; + + BEGIN -- (C) + + P1 (REC.A); + IF REC.A /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + BOOL := F1 (REC.A); + IF REC.A /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + + P2 (REC.AA); + IF REC.AA /= (10, 10, 10) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + + P3 (REC.A); + IF REC.A /= (4, 4, 4, 4) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + + END; -- (C) + + RESULT; + END C64109C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C64109D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109D IS + + BEGIN + TEST ("C64109D", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " & + "OBJECTS DESIGNATED BY ACCESS TYPES"); + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(3)); + TYPE NODE_TYPE; + TYPE ACCESS_TYPE IS ACCESS NODE_TYPE; + TYPE NODE_TYPE IS + RECORD + A : ARRAY_SUBTYPE; + NEXT : ACCESS_TYPE; + END RECORD; + PTR : ACCESS_TYPE := NEW NODE_TYPE' + (A => (IDENT_INT(1)..3 => IDENT_INT(5)), + NEXT => NULL); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - IN PARAMETER"); + END IF; + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN"); + END IF; + + RETURN TRUE; + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_SUBTYPE) IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - IN OUT PARAMETER"); + END IF; + + ARR := (OTHERS => 6); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 7); + END P3; + + BEGIN -- (D) + + P1 (PTR.A); + IF PTR.A /= (5, 5, 5) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + BOOL := F1 (PTR.A); + IF PTR.A /= (5, 5, 5) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + + P2 (PTR.A); + IF PTR.A /= (6, 6, 6) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + + P3 (PTR.A); + IF PTR.A /= (7, 7, 7) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + + END; -- (D) + + RESULT; + END C64109D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C64109E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS + -- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109E IS + + BEGIN + TEST ("C64109E", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " & + "ARRAYS WITH DIFFERENT BOUNDS PASSED TO UNCONSTRAINED " & + "FORMAL"); + + DECLARE -- (E) + + SUBTYPE SUBINT IS INTEGER RANGE 0..5; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + TYPE RECORD_TYPE IS + RECORD + A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(2)); + B : ARRAY_TYPE (1..3); + END RECORD; + REC : RECORD_TYPE := (A => (0..2 => IDENT_BOOL(TRUE)), + B => (1..3 => IDENT_BOOL(FALSE))); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG IN PARAMETER BOUNDS - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY - 2"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG IN PARAMETER BOUNDS - 2"); + END IF; + END P1; + + FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) + RETURN BOOLEAN IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2"); + END IF; + RETURN TRUE; + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE; + ARR2 : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2"); + END IF; + ARR := (ARR'RANGE => FALSE); + ARR2 := (ARR2'RANGE => TRUE); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG OUT PARAMETER BOUNDS - 1"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG OUT PARAMETER BOUNDS - 2"); + END IF; + ARR := (ARR'RANGE => FALSE); + ARR2 := (ARR2'RANGE => TRUE); + END P3; + + BEGIN -- (E) + + P1 (REC.A, REC.B); + IF REC.A /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + IF REC.B /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE - 2"); + END IF; + + BOOL := F1 (REC.A, REC.B); + IF REC.A /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + IF REC.B /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION - 2"); + END IF; + + P2 (REC.A, REC.B); + IF REC.A /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + IF REC.B /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2"); + END IF; + + P3 (REC.A, REC.B); + IF REC.A /= (FALSE, FALSE, FALSE) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + IF REC.B /= (TRUE, TRUE, TRUE) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY - 2"); + END IF; + + END; -- (E) + + RESULT; + END C64109E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- C64109F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO SUBPROGRAMS. SPECIFICALLY, + -- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN + -- ANOTHER CALL. + + -- CPP 8/20/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64109F IS + + BEGIN + TEST ("C64109F", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO SUBPROGRAMS - " & + "FORMAL AS AN ACTUAL"); + + DECLARE -- (F) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS + ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5)); + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + REC : RECORD_TYPE := (I => 23, + A => (1..3 => 7, 4..5 => 9)); + BOOL : BOOLEAN; + + PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS + BEGIN + IF A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY"); + END IF; + IF A'FIRST /= 1 OR A'LAST /= 5 THEN + FAILED ("BOUNDS WRONG - IN OUT"); + END IF; + A := (6, 6, 6, 6, 6); + END P_CALLED; + + PROCEDURE P (A : IN OUT ARRAY_TYPE) IS + BEGIN + P_CALLED (A); + END P; + + FUNCTION F_CALLED (A : ARRAY_SUBTYPE) RETURN BOOLEAN IS + GOOD : BOOLEAN; + BEGIN + GOOD := (A = (7, 7, 7, 9, 9)); + IF NOT GOOD THEN + FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY"); + END IF; + IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(5) THEN + FAILED ("BOUNDS WRONG - FUNCTION"); + END IF; + RETURN GOOD; + END F_CALLED; + + FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + RETURN (F_CALLED (A)); + END F; + + PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS + BEGIN + IF A'FIRST /= 1 OR A'LAST /= 5 THEN + FAILED ("BOUNDS WRONG - OUT"); + END IF; + A := (8, 8, 8, 8, 8); + END P_OUT_CALLED; + + PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS + BEGIN + P_OUT_CALLED (A); + A := (9, 9, 9, 9, 9); + END P_OUT; + + BEGIN -- (F) + + P (REC.A); + IF REC.A /= (6, 6, 6, 6, 6) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + + REC.A := (7, 7, 7, 9, 9); + BOOL := F (REC.A); + IF NOT BOOL THEN + FAILED ("IN PARAM NOT RETURNED CORRECTLY"); + END IF; + + REC.A := (7, 7, 7, 9, 9); + P_OUT (REC.A); + IF REC.A /= (9, 9, 9, 9, 9) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2"); + END IF; + + END; -- (F) + + -------------------------------------------- + + RESULT; + END C64109F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C64109G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SLICES OF ARRAYS ARE PASSED CORRECTLY TO SUBPROGRAMS. + -- SPECIFICALLY, + -- (A) CHECK ALL PARAMETER MODES. + + -- CPP 8/28/84 + -- PWN 05/31/96 Corrected spelling problem. + + WITH REPORT; USE REPORT; + PROCEDURE C64109G IS + + BEGIN + TEST ("C64109G", "CHECK THAT SLICES OF ARRAYS ARE PASSED " & + "CORRECTLY TO SUBPROGRAMS"); + + -------------------------------------------- + + DECLARE -- (A) + + SUBTYPE SUBINT IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER; + ARR : ARRAY_TYPE (1..5) := (1..3 => 7, 4..5 => 9); + BOOL : BOOLEAN; + + PROCEDURE P1 (S : ARRAY_TYPE) IS + BEGIN + IF S(IDENT_INT(3)) /= 7 THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)"); + END IF; + IF S(4) /= 9 THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2"); + END IF; + END P1; + + FUNCTION F1 (S : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF S(3) /= 7 THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)"); + END IF; + IF S(IDENT_INT(4)) /= 9 THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY - (A)2"); + END IF; + RETURN TRUE; + END F1; + + PROCEDURE P2 (S : IN OUT ARRAY_TYPE) IS + BEGIN + IF S(3) /= 7 THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)"); + END IF; + IF S(4) /= 9 THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY - (A)2"); + END IF; + FOR I IN 3 .. 4 LOOP + S(I) := 5; + END LOOP; + END P2; + + PROCEDURE P3 (S : OUT ARRAY_TYPE) IS + BEGIN + FOR I IN 3 .. 4 LOOP + S(I) := 3; + END LOOP; + END P3; + + BEGIN -- (A) + + P1 (ARR(3..4)); + IF ARR(3) /= 7 THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)"); + END IF; + IF ARR(4) /= 9 THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE - (A)2"); + END IF; + + BOOL := F1 (ARR(IDENT_INT(3)..IDENT_INT(4))); + IF ARR(3) /= 7 THEN + FAILED ("IN PARAM CHANGED BY FUNCTION - (A)"); + END IF; + IF ARR(4) /= 9 THEN + FAILED ("IN PARAM CHANGED BY FUNCTION - (A)2"); + END IF; + + P2 (ARR(3..4)); + FOR I IN 3 .. 4 LOOP + IF ARR(I) /= 5 THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY - (A)"); + END IF; + END LOOP; + + P3 (ARR(IDENT_INT(3)..4)); + FOR I IN 3 .. 4 LOOP + IF ARR(I) /= 3 THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY - (A)"); + END IF; + END LOOP; + + END; + + RESULT; + + END C64109G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109h.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C64109H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE + -- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY, + -- (A) CHECK ALL PARAMETER MODES. + + -- HISTORY: + -- TBN 07/11/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 MODIFIED REC.A REFERENCES. + + WITH REPORT; USE REPORT; + PROCEDURE C64109H IS + + BEGIN + TEST ("C64109H", "CHECK THAT SLICES OF ARRAYS WHICH ARE " & + "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " & + "TO SUBPROGRAMS"); + + DECLARE -- (A) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5)); + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + REC : RECORD_TYPE := (I => 23, + A => (1..3 => IDENT_INT(7), 4..5 => 9)); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(3) OR + ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (7, 7, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR'FIRST /= IDENT_INT(2) OR + ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER FOR FN"); + END IF; + + RETURN TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F1"); + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (7, 7, 7, 9) THEN + FAILED ("IN OUT PARAMETER NOT PASSED " & + "CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(1) OR + ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 5); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P2"); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= IDENT_INT(3) OR + ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS FOR OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 3); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P3"); + END P3; + + BEGIN -- (A) + + BEGIN -- (B) + P1 (REC.A (3..5)); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P1"); + END; -- (B) + + BEGIN -- (C) + BOOL := F1 (REC.A (2..4)); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF F1"); + END; -- (C) + + BEGIN -- (D) + P2 (REC.A (1..4)); + IF REC.A /= (5, 5, 5, 5, 9) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P2"); + END; -- (D) + + BEGIN -- (E) + P3 (REC.A (3..4)); + IF REC.A /= (5, 5, 3, 3, 9) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P3"); + END; -- (E) + + END; -- (A) + + RESULT; + END C64109H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109i.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C64109I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE + -- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY, + -- (C) CHECK RECORDS HAVING A DISCRIMINANT, WITH MORE THAN ONE ARRAY + -- COMPONENT, WHERE THE BOUNDS OF THE ARRAY DEPEND ON THE + -- DISCRIMINANT. + + -- HISTORY: + -- TBN 07/10/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 REMOVED PARTIAL ARRAY REFERENCES IN + -- RECORD FIELDS. + + WITH REPORT; USE REPORT; + PROCEDURE C64109I IS + + BEGIN + TEST ("C64109I", "CHECK THAT SLICES OF ARRAYS WHICH ARE " & + "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " & + "TO SUBPROGRAMS - RECORDS WITH DISCRIMINANTS"); + + DECLARE -- (C) + + SUBTYPE SUBINT IS INTEGER RANGE 1..6; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF INTEGER; + TYPE RECORD_TYPE (BOUND : INTEGER) IS + RECORD + B : BOOLEAN; + A : ARRAY_TYPE (1..BOUND); + AA : ARRAY_TYPE (BOUND..6); + END RECORD; + REC : RECORD_TYPE (BOUND => IDENT_INT(4)) := + (BOUND => 4, + B => TRUE, + A => (1..IDENT_INT(4) => 6), + AA => (4..6 => 8)); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (6, 6, 6) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 1 OR ARR'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG BOUNDS - IN PARAMETER"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (6, 6, 6) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + + IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN"); + END IF; + RETURN TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F1"); + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (8, 8) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= 4 OR ARR'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG BOUNDS - IN OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 10); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P2"); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= 2 OR ARR'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG BOUNDS - OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 4); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P3"); + END P3; + + BEGIN -- (C) + + BEGIN -- (D) + P1 (REC.A (1..3)); + IF REC.A /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P1"); + END; -- (D) + + BEGIN -- (E) + BOOL := F1 (REC.A (2..4)); + IF REC.A /= (6, 6, 6, 6) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF F1"); + END; -- (E) + + BEGIN -- (F) + P2 (REC.AA (4..5)); + IF REC.AA /= (10, 10, 8) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P2"); + END; -- (F) + + BEGIN -- (G) + P3 (REC.A (2..3)); + IF REC.A /= (6, 4, 4, 6) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P3"); + END; -- (G) + + END; -- (C) + + RESULT; + END C64109I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109j.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C64109J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE + -- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY, + -- (D) CHECK OBJECTS DESIGNATED BY ACCESS TYPES. + + -- HISTORY: + -- TBN 07/10/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 MODIFIED PTR.A REFERENCES. + + WITH REPORT; USE REPORT; + PROCEDURE C64109J IS + + BEGIN + TEST ("C64109J", "CHECK THAT SLICES OF ARRAYS WHICH ARE " & + "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " & + "TO SUBPROGRAMS - OBJECTS DESIGNATED BY ACCESS " & + "TYPES"); + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE(1..IDENT_INT(5)); + TYPE NODE_TYPE; + TYPE ACCESS_TYPE IS ACCESS NODE_TYPE; + TYPE NODE_TYPE IS + RECORD + A : ARRAY_SUBTYPE; + NEXT : ACCESS_TYPE; + END RECORD; + PTR : ACCESS_TYPE := NEW NODE_TYPE' + (A => (IDENT_INT(1)..5 => IDENT_INT(5)), + NEXT => NULL); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE) IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - IN PARAMETER"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + FUNCTION F1 (ARR : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + + IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN + FAILED ("WRONG BOUNDS - IN PARAMETER FOR FN"); + END IF; + + RETURN TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F1"); + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (5, 5, 5) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG BOUNDS - IN OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 6); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P2"); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE) IS + BEGIN + + IF ARR'FIRST /= IDENT_INT(3) OR ARR'LAST /= 5 THEN + FAILED ("WRONG BOUNDS - OUT PARAMETER"); + END IF; + + ARR := (ARR'RANGE => 7); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P3"); + END P3; + + BEGIN -- (D) + + BEGIN -- (E) + P1 (PTR.A (1..3)); + IF PTR.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P1"); + END; -- (E) + + BEGIN -- (F) + BOOL := F1 (PTR.A (2..4)); + IF PTR.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF F1"); + END; -- (F) + + BEGIN -- (G) + P2 (PTR.A (1..3)); + IF PTR.A /= (6, 6, 6, 5, 5) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P2"); + END; -- (G) + + BEGIN -- (H) + P3 (PTR.A (3..5)); + IF PTR.A /= (6, 6, 7, 7, 7) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P3"); + END; -- (H) + + END; -- (D) + + RESULT; + END C64109J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109k.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- C64109K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE + -- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY, + -- (E) CHECK THE CASE WHERE THE FORMAL IS UNCONSTRAINED, AND ARRAYS + -- WITH DIFFERENT BOUNDS ARE PASSED AS ACTUALS. + + -- HISTORY: + -- TBN 07/11/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 MODIFIED REC.A REFERENCES. + + WITH REPORT; USE REPORT; + PROCEDURE C64109K IS + + BEGIN + TEST ("C64109K", "CHECK THAT SLICES OF ARRAYS WHICH ARE " & + "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " & + "TO SUBPROGRAMS - ARRAYS WITH DIFFERENT BOUNDS " & + "PASSED TO UNCONSTRAINED FORMAL"); + + DECLARE -- (E) + + SUBTYPE SUBINT IS INTEGER RANGE 0..5; + TYPE ARRAY_TYPE IS ARRAY (SUBINT RANGE <>) OF BOOLEAN; + TYPE RECORD_TYPE IS + RECORD + A : ARRAY_TYPE (IDENT_INT(0)..IDENT_INT(4)); + B : ARRAY_TYPE (1..5); + END RECORD; + REC : RECORD_TYPE := (A => (0..4 => IDENT_BOOL(TRUE)), + B => (1..5 => IDENT_BOOL(FALSE))); + BOOL : BOOLEAN; + + PROCEDURE P1 (ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG IN PARAMETER BOUNDS - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY - 2"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG IN PARAMETER BOUNDS - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P1"); + END P1; + + FUNCTION F1 ( ARR : ARRAY_TYPE; ARR2 : ARRAY_TYPE) + RETURN BOOLEAN IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR'FIRST /= IDENT_INT(1) OR ARR'LAST /= 3 THEN + FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM NOT PASSED CORRECTLY TO FN"); + END IF; + IF ARR2'FIRST /= 3 OR ARR2'LAST /= IDENT_INT(5) THEN + FAILED ("WRONG IN PARAMETER BOUNDS FOR FN - 2"); + END IF; + RETURN TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F1"); + END F1; + + PROCEDURE P2 (ARR : IN OUT ARRAY_TYPE; + ARR2 : IN OUT ARRAY_TYPE) IS + BEGIN + IF ARR /= (TRUE, TRUE, TRUE) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT(2) OR ARR'LAST /= 4 THEN + FAILED ("WRONG IN OUT PARAMETER BOUNDS - 1"); + END IF; + IF ARR2 /= (FALSE, FALSE, FALSE) THEN + FAILED ("IN OUT PARAM NOT PASSED CORRECTLY"); + END IF; + IF ARR2'FIRST /= 2 OR ARR2'LAST /= IDENT_INT(4) THEN + FAILED ("WRONG IN OUT PARAMETER BOUNDS - 2"); + END IF; + ARR := (ARR'RANGE => FALSE); + ARR2 := (ARR2'RANGE => TRUE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P2"); + END P2; + + PROCEDURE P3 (ARR : OUT ARRAY_TYPE; ARR2 : OUT ARRAY_TYPE) IS + BEGIN + IF ARR'FIRST /= IDENT_INT(0) OR ARR'LAST /= 2 THEN + FAILED ("WRONG OUT PARAMETER BOUNDS - 1"); + END IF; + IF ARR2'FIRST /= 1 OR ARR2'LAST /= IDENT_INT(3) THEN + FAILED ("WRONG OUT PARAMETER BOUNDS - 2"); + END IF; + ARR := (ARR'RANGE => FALSE); + ARR2 := (ARR2'RANGE => TRUE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P3"); + END P3; + + BEGIN -- (E) + + BEGIN -- (F) + P1 (REC.A (0..2), REC.B (1..3)); + IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P1"); + END; -- (F) + + BEGIN -- (G) + BOOL := F1 (REC.A (1..3), REC.B (3..5)); + IF REC.A /= (TRUE, TRUE, TRUE, TRUE, TRUE) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION"); + END IF; + IF REC.B /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN + FAILED ("IN PARAM CHANGED BY FUNCTION - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF F1"); + END; -- (G) + + BEGIN -- (H) + P2 (REC.A (2..4), REC.B (2..4)); + IF REC.A /= (TRUE, TRUE, FALSE, FALSE, FALSE) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + IF REC.B /= (FALSE, TRUE, TRUE, TRUE, FALSE) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P2"); + END; -- (H) + + BEGIN -- (I) + P3 (REC.A (0..2), REC.B (1..3)); + IF REC.A /= (FALSE, FALSE, FALSE, FALSE, FALSE) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + IF REC.B /= (TRUE, TRUE, TRUE, TRUE, FALSE) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P3"); + END; -- (I) + + END; -- (E) + + RESULT; + END C64109K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64109l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64109l.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C64109L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SLICES OF ARRAYS WHICH ARE COMPONENTS OF RECORDS ARE + -- PASSED CORRECTLY TO SUBPROGRAMS. SPECIFICALLY, + -- (F) CHECK THAT A FORMAL PARAMETER CAN BE USED AS AN ACTUAL IN + -- ANOTHER SUBPROGRAM CALL. + + -- HISTORY: + -- TBN 07/11/86 CREATED ORIGINAL TEST. + -- JET 08/04/87 MODIFIED REC.A REFERENCES. + + WITH REPORT; USE REPORT; + PROCEDURE C64109L IS + + BEGIN + TEST ("C64109L", "CHECK THAT SLICES OF ARRAYS WHICH ARE " & + "COMPONENTS OF RECORDS ARE PASSED CORRECTLY " & + "TO SUBPROGRAMS - FORMAL AS AN ACTUAL"); + + DECLARE -- (F) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS + ARRAY_TYPE (IDENT_INT(1)..IDENT_INT(5)); + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + REC : RECORD_TYPE := (I => 23, + A => (1..3 => 7, 4..5 => 9)); + BOOL : BOOLEAN; + + PROCEDURE P_CALLED (A : IN OUT ARRAY_TYPE) IS + BEGIN + IF A /= (7, 7, 7) THEN + FAILED ("IN OUT PARAM NOT RECEIVED CORRECTLY"); + END IF; + IF A'FIRST /= 1 OR A'LAST /= IDENT_INT(3) THEN + FAILED ("BOUNDS WRONG - IN OUT"); + END IF; + A := (A'RANGE => 6); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P_CALLED"); + END P_CALLED; + + PROCEDURE P (A : IN OUT ARRAY_TYPE) IS + BEGIN + P_CALLED (A); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P"); + END P; + + FUNCTION F_CALLED (A : ARRAY_TYPE) RETURN BOOLEAN IS + GOOD : BOOLEAN; + BEGIN + GOOD := (A = (6, 9, 9)); + IF NOT GOOD THEN + FAILED ("IN PARAMETER NOT RECEIVED CORRECTLY"); + END IF; + IF A'FIRST /= 3 OR A'LAST /= IDENT_INT(5) THEN + FAILED ("BOUNDS WRONG - FUNCTION"); + END IF; + RETURN GOOD; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F_CALLED"); + END F_CALLED; + + FUNCTION F (A : ARRAY_TYPE) RETURN BOOLEAN IS + BEGIN + RETURN (F_CALLED (A)); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN FUNCTION F"); + END F; + + PROCEDURE P_OUT_CALLED (A : OUT ARRAY_TYPE) IS + BEGIN + IF A'FIRST /= IDENT_INT(2) OR A'LAST /= 4 THEN + FAILED ("BOUNDS WRONG - OUT"); + END IF; + A := (8, 8, 8); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE " & + "P_OUT_CALLED"); + END P_OUT_CALLED; + + PROCEDURE P_OUT (A : OUT ARRAY_TYPE) IS + BEGIN + P_OUT_CALLED (A); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN PROCEDURE P_OUT"); + END P_OUT; + + BEGIN -- (F) + + BEGIN -- (G) + P (REC.A (1..3)); + IF REC.A /= (6, 6, 6, 9, 9) THEN + FAILED ("IN OUT PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P"); + END; -- (G) + + BEGIN -- (H) + BOOL := F (REC.A (3..5)); + IF NOT BOOL THEN + FAILED ("IN PARAM NOT RETURNED CORRECTLY"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF F"); + END; -- (H) + + BEGIN -- (I) + P_OUT (REC.A (2..4)); + IF REC.A /= (6, 8, 8, 8, 9) THEN + FAILED ("OUT PARAM NOT RETURNED CORRECTLY - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING CALL OF P_OUT"); + END; -- (I) + + END; -- (F) + + RESULT; + END C64109L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64201b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64201b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64201b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64201b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C64201B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INITALIZATION OF IN PARAMETERS OF A TASK + -- TYPE IS PERMITTED. + -- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.) + + -- CVP 5/14/81 + -- ABW 7/1/82 + -- BHS 7/9/84 + + WITH REPORT; + PROCEDURE C64201B IS + + USE REPORT; + + BEGIN + + TEST( "C64201B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " & + "OF A TASK TYPE IS PERMITTED" ); + + DECLARE + + GLOBAL : INTEGER := 10; + + TASK TYPE T_TYPE IS + ENTRY E (X : IN OUT INTEGER); + END; + + TSK1, TSK2 : T_TYPE; + + TASK BODY T_TYPE IS + BEGIN + ACCEPT E (X : IN OUT INTEGER) DO + X := X - 1; + END E; + ACCEPT E (X : IN OUT INTEGER) DO + X := X + 1; + END E; + END T_TYPE; + + + PROCEDURE PROC1 (T : T_TYPE := TSK1) IS + BEGIN + T.E (X => GLOBAL); + END PROC1; + + PROCEDURE PROC2 (T : T_TYPE := TSK1) IS + BEGIN + T.E (X => GLOBAL); + IF (GLOBAL /= IDENT_INT(8)) THEN + FAILED( "TASK NOT PASSED IN PROC1, " & + "DEFAULT TSK1 EMPLOYED" ); + END IF; + END PROC2; + + PROCEDURE TERM (T : T_TYPE; NUM : CHARACTER) IS + BEGIN + IF NOT T'TERMINATED THEN + ABORT T; + COMMENT ("ABORTING TASK " & NUM); + END IF; + END TERM; + + BEGIN + + PROC1(TSK2); + IF GLOBAL /= 9 THEN + FAILED ("INCORRECT GLOBAL VALUE AFTER PROC1"); + ELSE + PROC2; + END IF; + + TERM(TSK1, '1'); + TERM(TSK2, '2'); + END; + + RESULT; + + END C64201B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64201c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64201c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64201c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64201c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- C64201C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INITIALIZATION OF IN PARAMETERS OF A COMPOSITE + -- TYPE HAVING AT LEAST ONE COMPONENT (INCLUDING COMPONENTS + -- OF COMPONENTS) OF A TASK TYPE IS PERMITTED. + -- (SEE ALSO 7.4.4/T2 FOR TESTS OF LIMITED PRIVATE TYPES.) + + -- CVP 5/14/81 + -- ABW 7/1/82 + -- BHS 7/9/84 + + WITH REPORT; + USE REPORT; + PROCEDURE C64201C IS + + + GLOBAL : INTEGER := 10; + + + TASK TYPE T IS + ENTRY E (X : IN OUT INTEGER); + END; + + TYPE REC_T IS + RECORD + TT : T; + BB : BOOLEAN := TRUE; + END RECORD; + + TYPE REC_REC_T IS + RECORD + RR : REC_T; + END RECORD; + + TYPE ARR_T IS ARRAY (1 .. 2) OF T; + + TYPE ARR_REC_T IS ARRAY (1 .. 2) OF REC_T; + + RT1, RT2 : REC_T; + RRT1, RRT2 : REC_REC_T; + AT1, AT2 : ARR_T; + ART1, ART2 : ARR_REC_T; + + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT INTEGER) DO + X := X - 1; + END E; + ACCEPT E (X : IN OUT INTEGER) DO + X := X + 1; + END E; + END T; + + + PROCEDURE PROC1A (P1X : REC_T := RT1) IS + BEGIN + IF P1X.BB THEN -- EXPECT RT2 PASSED. + FAILED( "RECORD OF TASK NOT PASSED, DEFAULT EMPLOYED" ); + END IF; + END PROC1A; + + PROCEDURE PROC1B (P1X : REC_T := RT1) IS + BEGIN + IF NOT P1X.BB THEN -- EXPECT DEFAULT USED. + FAILED( "DEFAULT RECORD OF TASK NOT EMPLOYED" ); + END IF; + END PROC1B; + + + PROCEDURE PROC2A (P2X : REC_REC_T := RRT1) IS + BEGIN + IF P2X.RR.BB THEN -- EXPECT RRT2 PASSED. + FAILED( "RECORD OF RECORD OF TASK NOT PASSED, " & + "DEFAULT EMPLOYED" ); + END IF; + END PROC2A; + + PROCEDURE PROC2B (P2X : REC_REC_T := RRT1) IS + BEGIN + IF NOT P2X.RR.BB THEN -- EXPECT DEFAULT USED. + FAILED( "DEFAULT RECORD OF RECORD OF TASK " & + "NOT EMPLOYED" ); + END IF; + END PROC2B; + + + PROCEDURE PROC3 (P3X : ARR_T := AT1) IS + BEGIN + P3X(1).E (X => GLOBAL); -- CALL TO AT2(1).E, + -- GLOBAL => GLOBAL - 1. + END PROC3; + + PROCEDURE PROC4 (P4X : ARR_T := AT1) IS + BEGIN + P4X(1).E (X => GLOBAL); -- CALL TO DEFAULT AT1(1).E, + -- GLOBAL => GLOBAL - 1. + IF GLOBAL /= IDENT_INT(8) THEN + FAILED( "ARRAY OF TASKS NOT PASSED " & + "CORRECTLY IN PROC3" ); + END IF; + END PROC4; + + PROCEDURE PROC5 (P5X : ARR_REC_T := ART1) IS + BEGIN + P5X(1).TT.E (X => GLOBAL); -- CALL TO ART2(1).TT.E, + -- GLOBAL => GLOBAL - 1. + END PROC5; + + PROCEDURE PROC6 (P6X : ARR_REC_T := ART1) IS + BEGIN + P6X(1).TT.E (X => GLOBAL); -- CALL DEFAULT ART1(1).TT.E, + -- GLOBAL => GLOBAL - 1. + IF GLOBAL /= IDENT_INT(8) THEN + FAILED( "ARRAY OF RECORDS OF TASKS NOT " & + "PASSED IN PROC5" ); + END IF; + END PROC6; + + PROCEDURE TERM (TSK : T; NUM : CHARACTER) IS + BEGIN + IF NOT TSK'TERMINATED THEN + ABORT TSK; + COMMENT ("ABORTING TASK " & NUM); + END IF; + END TERM; + + + BEGIN + + TEST( "C64201C" , "CHECK THAT INITIALIZATION OF IN " & + "PARAMETERS OF A COMPOSITE TYPE " & + "IS PERMITTED" ); + + RT2.BB := FALSE; + RRT2.RR.BB := FALSE; + + PROC1A(RT2); -- NO ENTRY CALL + PROC1B; -- NO ENTRY CALL + PROC2A(RRT2); -- NO ENTRY CALL + PROC2B; -- NO ENTRY CALL + + PROC3(AT2); -- CALL AT2(1).E + IF GLOBAL /= 9 THEN + FAILED ("INCORRECT GLOBAL VALUE AFTER PROC3"); + ELSE + PROC4; -- CALL AT1(1).E + END IF; + + GLOBAL := 10; + PROC5(ART2); -- CALL ART2(1).TT.E + IF GLOBAL /= 9 THEN + FAILED ("INCORRECT GLOBAL VALUE AFTER PROC5"); + ELSE + PROC6; -- CALL ART1(1).TT.E + END IF; + + -- MAKE SURE ALL TASKS TERMINATED + TERM (RT1.TT, '1'); + TERM (RT2.TT, '2'); + TERM (RRT1.RR.TT, '3'); + TERM (RRT2.RR.TT, '4'); + TERM (AT1(1), '5'); + TERM (AT2(1), '6'); + TERM (AT1(2), '7'); + TERM (AT2(2), '8'); + TERM (ART1(1).TT, '9'); + TERM (ART2(1).TT, 'A'); + TERM (ART1(2).TT, 'B'); + TERM (ART2(2).TT, 'C'); + + RESULT; + + END C64201C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c64202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c64202a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C64202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED + -- EACH TIME THEY ARE NEEDED. + + -- SPS 2/22/84 + + WITH REPORT; USE REPORT; + PROCEDURE C64202A IS + BEGIN + + TEST ("C64202A", "CHECK THAT THE DEFAULT EXPRESSION IS EVALUATED" & + " EACH TIME IT IS NEEDED"); + + DECLARE + X : INTEGER := 1; + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + PROCEDURE P (CALL : POSITIVE; X, Y : INTEGER := F) IS + BEGIN + IF CALL = 1 THEN + IF X = Y OR Y /= 2 THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 1" & + " X =" & INTEGER'IMAGE(X) & " Y =" & + INTEGER'IMAGE(Y)); + END IF; + ELSIF CALL = 2 THEN + IF X = Y OR + NOT ((X = 3 AND Y = 4) OR (X = 4 AND Y = 3)) THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - 2" & + " X =" & INTEGER'IMAGE(X) & " Y =" & + INTEGER'IMAGE(Y)); + END IF; + END IF; + END P; + + BEGIN + COMMENT ("FIRST CALL"); + P (1, 3); + COMMENT ("SECOND CALL"); + P(2); + END; + + RESULT; + + END C64202A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c650001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c650001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c650001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c650001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,412 ---- + -- C650001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for a function result type that is a return-by-reference + -- type, Program_Error is raised if the return expression is a name that + -- denotes an object view whose accessibility level is deeper than that + -- of the master that elaborated the function body. + -- + -- Check for cases where the result type is: + -- (a) A tagged limited type. + -- (b) A task type. + -- (c) A protected type. + -- (d) A composite type with a subcomponent of a + -- return-by-reference type (task type). + -- + -- TEST DESCRIPTION: + -- The accessibility level of the master that elaborates the body of a + -- return-by-reference function will always be less deep than that of + -- the function (which is itself a master). + -- + -- Thus, the return object may not be any of the following, since each + -- has an accessibility level at least as deep as that of the function: + -- + -- (1) An object declared local to the function. + -- (2) The result of a local function. + -- (3) A parameter of the function. + -- + -- Verify that Program_Error is raised within the return-by-reference + -- function if the return object is any of (1)-(3) above, for various + -- subsets of the return types (a)-(d) above. Include cases where (1)-(3) + -- are operands of parenthesized expressions. + -- + -- Verify that no exception is raised if the return object is any of the + -- following: + -- + -- (4) An object declared at a less deep level than that of the + -- master that elaborated the function body. + -- (5) The result of a function declared at the same level as the + -- original function (assuming the new function is also legal). + -- (6) A parameter of the master that elaborated the function body. + -- + -- For (5), pass the new function as an actual via an access-to- + -- subprogram parameter of the original function. Check for cases where + -- the new function does and does not raise an exception. + -- + -- Since the functions to be tested cannot be part of an assignment + -- statement (since they return values of a limited type), pass each + -- function result as an actual parameter to a dummy procedure, e.g., + -- + -- Dummy_Proc ( Function_Call ); + -- + -- + -- CHANGE HISTORY: + -- 03 May 95 SAIC Initial prerelease version. + -- 08 Feb 99 RLB Removed subcase with two errors. + -- + --! + + package C650001_0 is + + type Tagged_Limited is tagged limited record + C: String (1 .. 10); + end record; + + task type Task_Type; + + protected type Protected_Type is + procedure Op; + end Protected_Type; + + type Task_Array is array (1 .. 10) of Task_Type; + + type Variant_Record (Toggle: Boolean) is record + case Toggle is + when True => + T: Task_Type; -- Return-by-reference component. + when False => + I: Integer; -- Non-return-by-reference component. + end case; + end record; + + -- Limited type even though variant contains no limited components: + type Non_Task_Variant is new Variant_Record (Toggle => False); + + end C650001_0; + + + --==================================================================-- + + + package body C650001_0 is + + task body Task_Type is + begin + null; + end Task_Type; + + protected body Protected_Type is + procedure Op is + begin + null; + end Op; + end Protected_Type; + + end C650001_0; + + + --==================================================================-- + + + with C650001_0; + package C650001_1 is + + type TC_Result_Kind is (OK, P_E, O_E); + + procedure TC_Display_Results (Actual : in TC_Result_Kind; + Expected: in TC_Result_Kind; + Message : in String); + + -- Dummy procedures: + + procedure Check_Tagged (P: C650001_0.Tagged_Limited); + procedure Check_Task (P: C650001_0.Task_Type); + procedure Check_Protected (P: C650001_0.Protected_Type); + procedure Check_Composite (P: C650001_0.Non_Task_Variant); + + end C650001_1; + + + --==================================================================-- + + + with Report; + package body C650001_1 is + + procedure TC_Display_Results (Actual : in TC_Result_Kind; + Expected: in TC_Result_Kind; + Message : in String) is + begin + if Actual /= Expected then + case Actual is + when OK => + Report.Failed ("No exception raised: " & Message); + when P_E => + Report.Failed ("Program_Error raised: " & Message); + when O_E => + Report.Failed ("Unexpected exception raised: " & Message); + end case; + end if; + end TC_Display_Results; + + + procedure Check_Tagged (P: C650001_0.Tagged_Limited) is + begin + null; + end; + + procedure Check_Task (P: C650001_0.Task_Type) is + begin + null; + end; + + procedure Check_Protected (P: C650001_0.Protected_Type) is + begin + null; + end; + + procedure Check_Composite (P: C650001_0.Non_Task_Variant) is + begin + null; + end; + + end C650001_1; + + + + --==================================================================-- + + + with C650001_0; + with C650001_1; + + with Report; + procedure C650001 is + begin + + Report.Test ("C650001", "Check that, for a function result type that " & + "is a return-by-reference type, Program_Error is raised " & + "if the return expression is a name that denotes an " & + "object view whose accessibility level is deeper than " & + "that of the master that elaborated the function body"); + + + + SUBTEST1: + declare + + Result: C650001_1.TC_Result_Kind; + PO : C650001_0.Protected_Type; + + function Return_Prot (P: C650001_0.Protected_Type) + return C650001_0.Protected_Type is + begin + Result := C650001_1.OK; + return P; -- Formal parameter (3). + exception + when Program_Error => + Result := C650001_1.P_E; -- Expected result. + return PO; + when others => + Result := C650001_1.O_E; + return PO; + end Return_Prot; + + begin -- SUBTEST1. + C650001_1.Check_Protected ( Return_Prot(PO) ); + C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #1"); + exception + when others => + Report.Failed ("SUBTEST #1: Unexpected exception in outer block"); + end SUBTEST1; + + + + SUBTEST2: + declare + + Result: C650001_1.TC_Result_Kind; + Comp : C650001_0.Non_Task_Variant; + + function Return_Composite return C650001_0.Non_Task_Variant is + Local: C650001_0.Non_Task_Variant; + begin + Result := C650001_1.OK; + return (Local); -- Parenthesized local object (1). + exception + when Program_Error => + Result := C650001_1.P_E; -- Expected result. + return Comp; + when others => + Result := C650001_1.O_E; + return Comp; + end Return_Composite; + + begin -- SUBTEST2. + C650001_1.Check_Composite ( Return_Composite ); + C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #2"); + exception + when others => + Report.Failed ("SUBTEST #2: Unexpected exception in outer block"); + end SUBTEST2; + + + + SUBTEST3: + declare + + Result: C650001_1.TC_Result_Kind; + Tsk : C650001_0.Task_Type; + TskArr: C650001_0.Task_Array; + + function Return_Task (P: C650001_0.Task_Array) + return C650001_0.Task_Type is + + function Inner return C650001_0.Task_Type is + begin + return P(P'First); -- OK: should not raise exception (6). + exception + when Program_Error => + Report.Failed ("SUBTEST #3: Program_Error incorrectly " & + "raised within function Inner"); + return Tsk; + when others => + Report.Failed ("SUBTEST #3: Unexpected exception " & + "raised within function Inner"); + return Tsk; + end Inner; + + begin -- Return_Task. + Result := C650001_1.OK; + return Inner; -- Call to local function (2). + exception + when Program_Error => + Result := C650001_1.P_E; -- Expected result. + return Tsk; + when others => + Result := C650001_1.O_E; + return Tsk; + end Return_Task; + + begin -- SUBTEST3. + C650001_1.Check_Task ( Return_Task(TskArr) ); + C650001_1.TC_Display_Results (Result, C650001_1.P_E, "SUBTEST #3"); + exception + when others => + Report.Failed ("SUBTEST #3: Unexpected exception in outer block"); + end SUBTEST3; + + + + SUBTEST4: + declare + + Result: C650001_1.TC_Result_Kind; + TagLim: C650001_0.Tagged_Limited; + + function Return_TagLim (P: C650001_0.Tagged_Limited'Class) + return C650001_0.Tagged_Limited is + begin + Result := C650001_1.OK; + return C650001_0.Tagged_Limited(P); -- Conversion of formal param (3). + exception + when Program_Error => + Result := C650001_1.P_E; -- Expected result. + return TagLim; + when others => + Result := C650001_1.O_E; + return TagLim; + end Return_TagLim; + + begin -- SUBTEST4. + C650001_1.Check_Tagged ( Return_TagLim(TagLim) ); + C650001_1.TC_Display_Results (Result, C650001_1.P_E, + "SUBTEST #4 (root type)"); + exception + when others => + Report.Failed ("SUBTEST #4: Unexpected exception in outer block"); + end SUBTEST4; + + + + SUBTEST5: + declare + Tsk : C650001_0.Task_Type; + begin -- SUBTEST5. + + declare + Result: C650001_1.TC_Result_Kind; + + type AccToFunc is access function return C650001_0.Task_Type; + + function Return_Global return C650001_0.Task_Type is + begin + return Tsk; -- OK: should not raise exception (4). + end Return_Global; + + function Return_Local return C650001_0.Task_Type is + Local : C650001_0.Task_Type; + begin + return Local; -- Propagate Program_Error. + end Return_Local; + + + function Return_Func (P: AccToFunc) return C650001_0.Task_Type is + begin + Result := C650001_1.OK; + return P.all; -- Function call (5). + exception + when Program_Error => + Result := C650001_1.P_E; + return Tsk; + when others => + Result := C650001_1.O_E; + return Tsk; + end Return_Func; + + RG : AccToFunc := Return_Global'Access; + RL : AccToFunc := Return_Local'Access; + + begin + C650001_1.Check_Task ( Return_Func(RG) ); + C650001_1.TC_Display_Results (Result, C650001_1.OK, + "SUBTEST #5 (global task)"); + + C650001_1.Check_Task ( Return_Func(RL) ); + C650001_1.TC_Display_Results (Result, C650001_1.P_E, + "SUBTEST #5 (local task)"); + exception + when others => + Report.Failed ("SUBTEST #5: Unexpected exception in outer block"); + end; + + end SUBTEST5; + + + + Report.Result; + + end C650001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c65003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c65003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c65003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c65003a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C65003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES + -- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED. + + -- THIS LACK OF AN EXECUTABLE RETURN IS DETECTABLE AT COMPILE TIME IN + -- THIS TEST. + + -- JBG 10/14/83 + -- SPS 2/22/84 + + WITH REPORT; USE REPORT; + PROCEDURE C65003A IS + + EXCEPTION_RAISED : BOOLEAN := FALSE; + FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS + BEGIN + IF FALSE THEN + RETURN 5; + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY - " & + "RETURN_IN_EXCEPTION"); + EXCEPTION_RAISED := TRUE; + RETURN 5; + END RETURN_IN_EXCEPTION; + + FUNCTION NO_RETURN RETURN INTEGER IS + NO_RETURN_EXCEPTION : EXCEPTION; + BEGIN + RAISE NO_RETURN_EXCEPTION; + RETURN 5; + EXCEPTION + WHEN NO_RETURN_EXCEPTION => + NULL; + END NO_RETURN; + + BEGIN + + TEST ("C65003A", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " & + "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " & + "STATEMENT"); + + BEGIN + + IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN + IF NOT EXCEPTION_RAISED THEN + FAILED ("PROGRAM_ERROR NOT RAISED - " & + "RETURN_IN_EXCEPTION"); + END IF; + END IF; + + EXCEPTION + + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL " & + "- RETURN_IN_EXCEPTION"); + + END; + + + BEGIN + + IF NO_RETURN = NO_RETURN THEN + FAILED ("PROGRAM_ERROR NOT RAISED - NO_RETURN"); + END IF; + + EXCEPTION + + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED WHEN NO RETURN IN " & + "EXCEPTION HANDLER"); + END; + + RESULT; + + END C65003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c65003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c65003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c65003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c65003b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C65003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF NO RETURN STATEMENT IS EXECUTED, A FUNCTION RAISES + -- PROGRAM_ERROR. DETERMINE WHERE THE EXCEPTION IS RAISED. + + -- THIS LACK OF AN EXECUTABLE RETURN IS NOT DETECTABLE AT COMPILE TIME. + + -- JBG 10/14/83 + -- SPS 2/22/84 + + WITH REPORT; USE REPORT; + PROCEDURE C65003B IS + + EXCEPTION_RAISED : BOOLEAN := FALSE; + + FUNCTION RETURN_IN_EXCEPTION RETURN INTEGER IS + BEGIN + WHILE NOT EQUAL (1, 1) LOOP + RETURN 5; + END LOOP; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED IN FUNCTION BODY"); + EXCEPTION_RAISED := TRUE; + RETURN 5; + END RETURN_IN_EXCEPTION; + + BEGIN + + TEST ("C65003B", "CHECK THAT PROGRAM_ERROR IS RAISED IF A " & + "FUNCTION RETURNS WITHOUT EXECUTING A RETURN " & + "STATEMENT"); + + BEGIN + + IF RETURN_IN_EXCEPTION = RETURN_IN_EXCEPTION THEN + IF NOT EXCEPTION_RAISED THEN + FAILED ("PROGRAM_ERROR NOT RAISED"); + END IF; + END IF; + + EXCEPTION + + WHEN PROGRAM_ERROR => + COMMENT ("PROGRAM_ERROR RAISED AT POINT OF CALL"); + + END; + + RESULT; + + END C65003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C66002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (A) ONE SUBPROGRAM IS A FUNCTION; THE OTHER IS A PROCEDURE. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + -- SPS 11/2/82 + + WITH REPORT; + PROCEDURE C66002A IS + + USE REPORT; + + BEGIN + TEST ("C66002A", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- ONE SUBPROGRAM IS A PROCEDURE; THE OTHER IS + -- A FUNCTION. BOTH PARAMETERIZED AND PARAMETERLESS + -- SUBPROGRAMS ARE TESTED. + + DECLARE + I, J, K : INTEGER := 0; + S : STRING (1..2) := "12"; + + PROCEDURE P1 (I1, I2 : INTEGER) IS + BEGIN + S(1) := 'A'; + END P1; + + FUNCTION P1 (I1, I2 : INTEGER) RETURN INTEGER IS + BEGIN + S(2) := 'B'; + RETURN I1; -- RETURNED VALUE IS IRRELEVENT. + END P1; + + PROCEDURE P2 IS + BEGIN + S(1) := 'C'; + END P2; + + FUNCTION P2 RETURN INTEGER IS + BEGIN + S(2) := 'D'; + RETURN I; -- RETURNED VALUE IS IRRELEVENT. + END P2; + + BEGIN + P1 (I, J); + K := P1 (I, J); + + IF S /= "AB" THEN + FAILED ("PARAMETERIZED OVERLOADED " & + "SUBPROGRAMS, ONE A PROCEDURE AND " & + "THE OTHER A FUNCTION, CAUSED " & + "CONFUSION"); + END IF; + + S := "12"; + P2; + K := P2 ; + + IF S /= "CD" THEN + FAILED ("PARAMETERLESS OVERLOADED " & + "SUBPROGRAMS, ONE A PROCEDURE AND " & + "THE OTHER A FUNCTION, CAUSED " & + "CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + + END C66002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C66002C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (C) ONE SUBPROGRAM HAS ONE LESS PARAMETER THAN THE OTHER. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + + WITH REPORT; + PROCEDURE C66002C IS + + USE REPORT; + + BEGIN + TEST ("C66002C", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- ONE PROCEDURE HAS ONE MORE PARAMETER + -- THAN THE OTHER. THIS IS TESTED IN THE + -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT + -- VALUE, AND THE CASE IN WHICH IT DOES NOT. + + DECLARE + I, J : INTEGER := 0; + B : BOOLEAN := TRUE; + S : STRING (1..2) := "12"; + + PROCEDURE P1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN) IS + BEGIN + S(1) := 'A'; + END P1; + + PROCEDURE P1 (I1, I2 : INTEGER) IS + BEGIN + S(2) := 'B'; + END P1; + + PROCEDURE P2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0) IS + BEGIN + S(1) := 'C'; + END P2; + + PROCEDURE P2 (B1 : IN OUT BOOLEAN) IS + BEGIN + S(2) := 'D'; + END P2; + + BEGIN + P1 (I, J, B); + P1 (I, J); + + IF S /= "AB" THEN + FAILED ("PROCEDURES DIFFERING ONLY IN " & + "NUMBER OF PARAMETERS (NO DEFAULTS) " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + P2 (B, I); + -- NOTE THAT A CALL TO P2 WITH ONLY + -- ONE PARAMETER IS AMBIGUOUS. + + IF S /= "C2" THEN + FAILED ("PROCEDURES DIFFERING ONLY IN " & + "EXISTENCE OF ONE PARAMETER (WITH " & + "DEFAULT) CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + + END C66002C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C66002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (D) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT + -- OF THE CORRESPONDING ONE. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + + WITH REPORT; + PROCEDURE C66002D IS + + USE REPORT; + + BEGIN + TEST ("C66002D", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- THE BASE TYPE OF ONE PARAMETER IS + -- DIFFERENT FROM THAT OF THE CORRESPONDING + -- ONE. + + DECLARE + I, J, K : INTEGER := 0; + B : BOOLEAN; + S : STRING (1..2) := "12"; + + PROCEDURE P (I1 : INTEGER; BI : OUT BOOLEAN; + I2 : IN OUT INTEGER) IS + BEGIN + S(1) := 'A'; + BI := TRUE; -- THIS VALUE IS IRRELEVENT. + END P; + + PROCEDURE P (I1 : INTEGER; BI : OUT INTEGER; + I2 : IN OUT INTEGER) IS + BEGIN + S(2) := 'B'; + BI := 0; -- THIS VALUE IS IRRELEVENT. + END P; + + BEGIN + P (I, B, K); + P (I, J, K); + + IF S /= "AB" THEN + FAILED ("PROCEDURES DIFFERING ONLY BY " & + "THE BASE TYPE OF A PARAMETER " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + + END C66002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C66002E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (E) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE + -- PART, THE OTHER IN AN INNER PART, AND THE PARAMETERS ARE + -- ORDERED DIFFERENTLY. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + + WITH REPORT; + PROCEDURE C66002E IS + + USE REPORT; + + BEGIN + TEST ("C66002E", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- ONE SUBPROGRAM IS DECLARED IN AN OUTER + -- DECLARATIVE PART, THE OTHER IN AN INNER + -- PART, AND THE PARAMETERS ARE ORDERED + -- DIFFERENTLY. + + DECLARE + S : STRING (1..2) := "12"; + + PROCEDURE P (I1 : INTEGER; I2 : IN OUT INTEGER; + B1 : BOOLEAN) IS + BEGIN + S(1) := 'A'; + END P; + + BEGIN + DECLARE + I : INTEGER := 0; + + PROCEDURE P (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER) IS + BEGIN + S(2) := 'B'; + END P; + + BEGIN + P (5, I, TRUE); + P (TRUE, 5, I); + -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS + -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS. + + IF S /= "AB" THEN + FAILED ("PROCEDURES IN " & + "ENCLOSING-ENCLOSED SCOPES " & + "DIFFERING ONLY IN PARAMETER " & + "TYPE ORDER CAUSED CONFUSION"); + END IF; + END; + END; + + -------------------------------------------------- + + RESULT; + + END C66002E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C66002F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (F) ONE SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART, + -- THE OTHER IN AN INNER PART, AND ONE HAS ONE MORE PARAMETER + -- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + + WITH REPORT; + PROCEDURE C66002F IS + + USE REPORT; + + BEGIN + TEST ("C66002F", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- ONE SUBPROGRAM IS IN AN OUTER DECLARATIVE + -- PART, THE OTHER IN AN INNER PART, AND ONE + -- HAS ONE MORE PARAMETER (WITH A DEFAULT + -- VALUE) THAN THE OTHER. + + BF : + DECLARE + S : STRING (1..3) := "123"; + + PROCEDURE P (I1, I2, I3 : INTEGER := 1) IS + C : CONSTANT STRING := "CXA"; + BEGIN + S(I3) := C(I3); + END P; + + PROCEDURE ENCLOSE IS + + PROCEDURE P (I1, I2 : INTEGER := 1) IS + BEGIN + S(2) := 'B'; + END P; + + BEGIN -- ENCLOSE + P (1, 2, 3); + ENCLOSE.P (1, 2); -- NOTE THAT THESE CALLS + BF.P (1, 2); -- MUST BE DISAMBIGUATED. + + IF S /= "CBA" THEN + FAILED ("PROCEDURES IN ENCLOSING-" & + "ENCLOSED SCOPES DIFFERING " & + "ONLY IN EXISTENCE OF ONE " & + "DEFAULT-VALUED PARAMETER CAUSED " & + "CONFUSION"); + END IF; + END ENCLOSE; + + BEGIN + ENCLOSE; + END BF; + + -------------------------------------------------- + + RESULT; + + END C66002F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c66002g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c66002g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C66002G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (G) THE RESULT TYPE OF TWO FUNCTION DECLARATIONS IS DIFFERENT. + + -- CVP 5/4/81 + -- JRK 5/8/81 + -- NL 10/13/81 + -- SPS 10/26/82 + + WITH REPORT; + PROCEDURE C66002G IS + + USE REPORT; + + BEGIN + TEST ("C66002G", "SUBPROGRAM OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- THE RESULT TYPES OF TWO FUNCTION + -- DECLARATIONS ARE DIFFERENT. + + DECLARE + I : INTEGER; + B : BOOLEAN; + S : STRING (1..2) := "12"; + + FUNCTION F RETURN INTEGER IS + BEGIN + S(1) := 'A'; + RETURN IDENT_INT (0); -- THIS VALUE IS IRRELEVENT. + END F; + + FUNCTION F RETURN BOOLEAN IS + BEGIN + S(2) := 'B'; + RETURN IDENT_BOOL (TRUE); -- THIS VALUE IS IRRELEVANT. + END F; + + BEGIN + I := F; + B := F; + + IF S /= "AB" THEN + FAILED ("FUNCTIONS DIFFERING ONLY IN " & + "BASE TYPE OF RETURNED VALUE " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + + END C66002G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,426 ---- + -- C67002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED) + -- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS. + -- SUBTESTS ARE: + -- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=", + -- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-", + -- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS. + -- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY, + -- WITH ONE PARAMETER. + + -- CVP 5/7/81 + -- JRK 6/1/81 + -- CPP 6/25/84 + + WITH REPORT; + PROCEDURE C67002A IS + + USE REPORT; + + BEGIN + TEST ("C67002A", "USE OF OPERATOR SYMBOLS IN " & + "(OVERLOADED) FUNCTION SPECIFICATIONS"); + + ------------------------------------------------- + + DECLARE -- (A) + PACKAGE EQU IS + TYPE LP IS LIMITED PRIVATE; + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN; + PRIVATE + TYPE LP IS NEW INTEGER; + END EQU; + USE EQU; + + LP1, LP2 : LP; + + PACKAGE BODY EQU IS + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS + BEGIN + RETURN LPA > LPB; + END "="; + BEGIN + LP1 := LP (IDENT_INT (7)); + LP2 := LP (IDENT_INT (8)); + END EQU; + + BEGIN -- (A) + IF (LP1 = LP2) OR NOT (LP2 = LP1) OR + (LP1 = LP1) OR (LP2 /= LP1) THEN + FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE"); + END IF; + END; -- (A) + + ------------------------------------------------- + + DECLARE -- (B) + FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "AND"; + + BEGIN -- (B) + IF (IDENT_INT (10) AND 1) /= 'G' OR + (5 AND 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE"); + END IF; + END; -- (B) + + ------------------------------------------------- + + DECLARE -- (C) + FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "OR"; + + BEGIN -- (C) + IF (IDENT_INT (10) OR 1) /= 'G' OR + (5 OR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (C) + + ------------------------------------------------- + + DECLARE -- (D) + FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "XOR"; + + BEGIN -- (D) + IF (IDENT_INT (10) XOR 1) /= 'G' OR + (5 XOR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (D) + + ------------------------------------------------- + + DECLARE -- (E) + FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "<"; + + BEGIN -- (E) + IF (IDENT_INT (10) < 1) /= 'G' OR + (5 < 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE"); + END IF; + END; -- (E) + + ------------------------------------------------- + + DECLARE -- (F) + FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "<="; + + BEGIN -- (F) + IF (IDENT_INT (10) <= 1) /= 'G' OR + (5 <= 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE"); + END IF; + END; -- (F) + + ------------------------------------------------- + + DECLARE -- (G) + FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END ">"; + + BEGIN -- (G) + IF (IDENT_INT (10) > 1) /= 'G' OR + (5 > 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE"); + END IF; + END; -- (G) + + ------------------------------------------------- + + DECLARE -- (H) + FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END ">="; + + BEGIN -- (H) + IF (IDENT_INT (10) >= 1) /= 'G' OR + (5 >= 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE"); + END IF; + END; -- (H) + + ------------------------------------------------- + + DECLARE -- (I) + FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "&"; + + BEGIN -- (I) + IF (IDENT_INT (10) & 1) /= 'G' OR + (5 & 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE"); + END IF; + END; -- (I) + + ------------------------------------------------- + + DECLARE -- (J) + FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "*"; + + BEGIN -- (J) + IF (IDENT_INT (10) * 1) /= 'G' OR + (5 * 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE"); + END IF; + END; -- (J) + + ------------------------------------------------- + + DECLARE -- (K) + FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "/"; + + BEGIN -- (K) + IF (IDENT_INT (10) / 1) /= 'G' OR + (5 / 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE"); + END IF; + END; -- (K) + + ------------------------------------------------- + + DECLARE -- (L) + FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "MOD"; + + BEGIN -- (L) + IF (IDENT_INT (10) MOD 1) /= 'G' OR + (5 MOD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE"); + END IF; + END; -- (L) + + ------------------------------------------------- + + DECLARE -- (M) + FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "REM"; + + BEGIN -- (M) + IF (IDENT_INT (10) REM 1) /= 'G' OR + (5 REM 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE"); + END IF; + END; -- (M) + + ------------------------------------------------- + + DECLARE -- (N) + FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "**"; + + BEGIN -- (N) + IF (IDENT_INT (10) ** 1) /= 'G' OR + (5 ** 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE"); + END IF; + END; -- (N) + + ------------------------------------------------- + + DECLARE -- (O) + FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "+"; + + BEGIN -- (O) + IF (IDENT_INT (10) + 1) /= 'G' OR + (5 + 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE"); + END IF; + END; -- (O) + + ------------------------------------------------- + + DECLARE -- (P) + FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "-"; + + BEGIN -- (P) + IF (IDENT_INT (10) - 1) /= 'G' OR + (5 - 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE"); + END IF; + END; -- (P) + + ------------------------------------------------- + + DECLARE -- (Q) + FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "+"; + + BEGIN -- (Q) + IF (+ IDENT_INT(25) /= 'P') OR + (+ (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""+"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (Q) + + ------------------------------------------------- + + DECLARE -- (R) + FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "-"; + + BEGIN -- (R) + IF (- IDENT_INT(25) /= 'P') OR + (- (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""-"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (R) + + ------------------------------------------------- + + DECLARE -- (S) + FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "NOT"; + + BEGIN -- (S) + IF (NOT IDENT_INT(25) /= 'P') OR + (NOT (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""NOT"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (S) + + ------------------------------------------------- + + DECLARE -- (T) + FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "ABS"; + + BEGIN -- (T) + IF (ABS IDENT_INT(25) /= 'P') OR + (ABS (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""ABS"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (T) + + ------------------------------------------------- + + RESULT; + END C67002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- C67002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED) + -- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS. + -- THIS TEST CHECKS THE CASE OF CERTAIN OPERATOR SYMBOLS. + -- SUBTESTS ARE: + -- (A) THROUGH (E): "AND", "OR", "XOR", "MOD", "REM" + -- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS. + -- (F) AND (G): "NOT" AND "ABS", RESPECTIVELY, + -- WITH ONE PARAMETER. + + -- CPP 6/26/84 + + WITH REPORT; + PROCEDURE C67002B IS + + USE REPORT; + + BEGIN + TEST ("C67002B", "USE OF OPERATOR SYMBOLS IN " & + "(OVERLOADED) FUNCTION SPECIFICATIONS"); + + ------------------------------------------------- + + DECLARE -- (A) + FUNCTION "And" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "And"; + + BEGIN -- (A) + IF (IDENT_INT (10) AND 1) /= 'G' OR + (5 AnD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""And"" OPERATOR DEFECTIVE"); + END IF; + END; -- (A) + + ------------------------------------------------- + + DECLARE -- (B) + FUNCTION "or" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "or"; + + BEGIN -- (B) + IF (IDENT_INT (10) Or 1) /= 'G' OR + (5 OR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""or"" OPERATOR DEFECTIVE"); + END IF; + END; -- (B) + + ------------------------------------------------- + + DECLARE -- (C) + FUNCTION "xOR" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "xOR"; + + BEGIN -- (C) + IF (IDENT_INT (10) XoR 1) /= 'G' OR + (5 xOR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""xOR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (C) + + ------------------------------------------------- + + DECLARE -- (D) + FUNCTION "mOd" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "mOd"; + + BEGIN -- (D) + IF (IDENT_INT (10) MoD 1) /= 'G' OR + (5 moD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""mOd"" OPERATOR DEFECTIVE"); + END IF; + END; -- (D) + + ------------------------------------------------- + + DECLARE -- (E) + FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END "REM"; + + BEGIN -- (E) + IF (IDENT_INT (10) rem 1) /= 'G' OR + (5 Rem 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE"); + END IF; + END; -- (E) + + ------------------------------------------------- + + DECLARE -- (F) + FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "NOT"; + + BEGIN -- (F) + IF (Not IDENT_INT(25) /= 'P') OR + (noT (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""NOT"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (F) + + ------------------------------------------------- + + DECLARE -- (G) + FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT (0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END "ABS"; + + BEGIN -- (G) + IF (abs IDENT_INT(25) /= 'P') OR + (Abs (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""ABS"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (T) + + ------------------------------------------------- + + RESULT; + END C67002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,548 ---- + -- C67002C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED) + -- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS. + -- THIS TEST CHECKS FORMAL SUBPROGRAM PARAMETERS. + -- SUBTESTS ARE: + -- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=", + -- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-", + -- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS. + -- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY, + -- WITH ONE PARAMETER. + + -- CPP 6/26/84 + + WITH REPORT; USE REPORT; + PROCEDURE C67002C IS + + FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END TWO_PARAMS; + + FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT(0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END ONE_PARAM; + + BEGIN + TEST ("C67002C", "USE OF OPERATOR SYMBOLS IN " & + "(OVERLOADED) FUNCTION SPECIFICATIONS"); + + ------------------------------------------------- + + DECLARE -- (A) + + PACKAGE EQU IS + TYPE LP IS LIMITED PRIVATE; + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN; + PRIVATE + TYPE LP IS NEW INTEGER; + END EQU; + USE EQU; + + LP1, LP2 : LP; + + PACKAGE BODY EQU IS + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS + BEGIN + RETURN LPA > LPB; + END "="; + BEGIN + LP1 := LP (IDENT_INT (7)); + LP2 := LP (IDENT_INT (8)); + END EQU; + + GENERIC + WITH FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (LP1 = LP2) OR NOT (LP2 = LP1) OR + (LP1 = LP1) OR (LP2 /= LP1) THEN + FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE EQUAL IS NEW PKG ("=" => EQU."="); + + BEGIN -- (A) + NULL; + END; -- (A) + + ------------------------------------------------- + + DECLARE -- (B) + + GENERIC + WITH FUNCTION "AND" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) AND 1) /= 'G' OR + (5 AND 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("AND" => TWO_PARAMS); + + BEGIN -- (B) + NULL; + END; -- (B) + + ------------------------------------------------- + + DECLARE -- (C) + + GENERIC + WITH FUNCTION "OR" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) OR 1) /= 'G' OR + (5 OR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("OR" => TWO_PARAMS); + + BEGIN -- (C) + NULL; + END; -- (C) + + ------------------------------------------------- + + DECLARE -- (D) + + GENERIC + WITH FUNCTION "XOR" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) XOR 1) /= 'G' OR + (5 XOR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("XOR" => TWO_PARAMS); + + BEGIN -- (D) + NULL; + END; -- (D) + + ------------------------------------------------- + + DECLARE -- (E) + + GENERIC + WITH FUNCTION "<" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) < 1) /= 'G' OR + (5 < 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("<" => TWO_PARAMS); + + BEGIN -- (E) + NULL; + END; -- (E) + + ------------------------------------------------- + + DECLARE -- (F) + + GENERIC + WITH FUNCTION "<=" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) <= 1) /= 'G' OR + (5 <= 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("<=" => TWO_PARAMS); + + BEGIN -- (F) + NULL; + END; -- (F) + + ------------------------------------------------- + + DECLARE -- (G) + + GENERIC + WITH FUNCTION ">" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) > 1) /= 'G' OR + (5 > 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG (">" => TWO_PARAMS); + + BEGIN -- (G) + NULL; + END; -- (G) + + ------------------------------------------------- + + DECLARE -- (H) + + GENERIC + WITH FUNCTION ">=" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) >= 1) /= 'G' OR + (5 >= 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG (">=" => TWO_PARAMS); + + BEGIN -- (H) + NULL; + END; -- (H) + + ------------------------------------------------- + + DECLARE -- (I) + + GENERIC + WITH FUNCTION "&" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) & 1) /= 'G' OR + (5 & 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("&" => TWO_PARAMS); + + BEGIN -- (I) + NULL; + END; -- (I) + + ------------------------------------------------- + + DECLARE -- (J) + + GENERIC + WITH FUNCTION "*" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) * 1) /= 'G' OR + (5 * 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("*" => TWO_PARAMS); + + BEGIN -- (J) + NULL; + END; -- (J) + + ------------------------------------------------- + + DECLARE -- (K) + + GENERIC + WITH FUNCTION "/" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) / 1) /= 'G' OR + (5 / 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("/" => TWO_PARAMS); + + BEGIN -- (K) + NULL; + END; -- (K) + + ------------------------------------------------- + + DECLARE -- (L) + + GENERIC + WITH FUNCTION "MOD" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) MOD 1) /= 'G' OR + (5 MOD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("MOD" => TWO_PARAMS); + + BEGIN -- (L) + NULL; + END; -- (L) + + ------------------------------------------------- + + DECLARE -- (M) + + GENERIC + WITH FUNCTION "REM" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) REM 1) /= 'G' OR + (5 REM 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("REM" => TWO_PARAMS); + + BEGIN -- (M) + NULL; + END; -- (M) + + ------------------------------------------------- + + DECLARE -- (N) + + GENERIC + WITH FUNCTION "**" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) ** 1) /= 'G' OR + (5 ** 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("**" => TWO_PARAMS); + + BEGIN -- (N) + NULL; + END; -- (N) + + ------------------------------------------------- + + DECLARE -- (O) + + GENERIC + WITH FUNCTION "+" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) + 1) /= 'G' OR + (5 + 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("+" => TWO_PARAMS); + + BEGIN -- (O) + NULL; + END; -- (O) + + ------------------------------------------------- + + DECLARE -- (P) + + GENERIC + WITH FUNCTION "-" (I1, I2 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (IDENT_INT (10) - 1) /= 'G' OR + (5 - 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("-" => TWO_PARAMS); + + BEGIN -- (P) + NULL; + END; -- (P) + + ------------------------------------------------- + + DECLARE -- (Q) + + GENERIC + WITH FUNCTION "+" (I1 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (+ IDENT_INT(25) /= 'P') OR + (+ (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""+"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("+" => ONE_PARAM); + + BEGIN -- (Q) + NULL; + END; -- (Q) + + ------------------------------------------------- + + DECLARE -- (R) + + GENERIC + WITH FUNCTION "-" (I1 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (- IDENT_INT(25) /= 'P') OR + (- (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""-"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("-" => ONE_PARAM); + + BEGIN -- (R) + NULL; + END; -- (R) + + ------------------------------------------------- + + DECLARE -- (S) + + GENERIC + WITH FUNCTION "NOT" (I1 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (NOT IDENT_INT(25) /= 'P') OR + (NOT (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""NOT"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("NOT" => ONE_PARAM); + + BEGIN -- (S) + NULL; + END; -- (S) + + ------------------------------------------------- + + DECLARE -- (T) + + GENERIC + WITH FUNCTION "ABS" (I1 : INTEGER) RETURN CHARACTER; + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF (ABS IDENT_INT(25) /= 'P') OR + (ABS (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""ABS"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG ("ABS" => ONE_PARAM); + + BEGIN -- (T) + NULL; + END; -- (T) + + ------------------------------------------------- + + RESULT; + END C67002C; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,354 ---- + -- C67002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED) + -- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS. + -- THIS TEST CHECKS GENERIC INSTANTIATIONS FOR THESE FUNCTIONS. + -- SUBTESTS ARE: + -- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=", + -- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-", + -- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS. + -- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY, + -- WITH ONE PARAMETER. + + -- CPP 6/25/84 + + WITH REPORT; USE REPORT; + PROCEDURE C67002D IS + + GENERIC + TYPE ELEMENT IS (<>); + FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER; + FUNCTION TWO_PARAMS (I1, I2 : ELEMENT) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END TWO_PARAMS; + + GENERIC + TYPE ELEMENT IS (<>); + FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER; + FUNCTION ONE_PARAM (I1 : ELEMENT) RETURN CHARACTER IS + BEGIN + IF I1 < ELEMENT'VAL(IDENT_INT(0)) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END ONE_PARAM; + + BEGIN + TEST ("C67002D", "USE OF OPERATOR SYMBOLS IN " & + "(OVERLOADED) FUNCTION SPECIFICATIONS"); + + ------------------------------------------------- + + DECLARE -- (A) + GENERIC + TYPE LP IS LIMITED PRIVATE; + WITH FUNCTION ">" (L, R : LP) RETURN BOOLEAN IS <>; + PACKAGE PKG IS + LP1, LP2 : LP; + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN; + END PKG; + + PACKAGE BODY PKG IS + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS + BEGIN + RETURN LPA > LPB; + END "="; + END PKG; + + BEGIN -- (A) + DECLARE + PACKAGE PACK IS NEW PKG (LP => INTEGER); + USE PACK; + FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN + RENAMES PACK."="; + BEGIN + LP1 := IDENT_INT(7); + LP2 := IDENT_INT(8); + IF (LP1 = LP2) OR NOT (LP2 = LP1) OR + (LP1 = LP1) OR (LP2 /= LP1) THEN + FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE"); + END IF; + END; + END; -- (A) + + ------------------------------------------------- + + DECLARE -- (B) + FUNCTION "AND" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (B) + IF (IDENT_INT (10) AND 1) /= 'G' OR + (5 AND 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE"); + END IF; + END; -- (B) + + ------------------------------------------------- + + DECLARE -- (C) + FUNCTION "OR" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (C) + IF (IDENT_INT (10) OR 1) /= 'G' OR + (5 OR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (C) + + ------------------------------------------------- + + DECLARE -- (D) + FUNCTION "XOR" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (D) + IF (IDENT_INT (10) XOR 1) /= 'G' OR + (5 XOR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (D) + + ------------------------------------------------- + + DECLARE -- (E) + FUNCTION "<" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (E) + IF (IDENT_INT (10) < 1) /= 'G' OR + (5 < 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE"); + END IF; + END; -- (E) + + ------------------------------------------------- + + DECLARE -- (F) + FUNCTION "<=" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (F) + IF (IDENT_INT (10) <= 1) /= 'G' OR + (5 <= 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE"); + END IF; + END; -- (F) + + ------------------------------------------------- + + DECLARE -- (G) + FUNCTION ">" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (G) + IF (IDENT_INT (10) > 1) /= 'G' OR + (5 > 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE"); + END IF; + END; -- (G) + + ------------------------------------------------- + + DECLARE -- (H) + FUNCTION ">=" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (H) + IF (IDENT_INT (10) >= 1) /= 'G' OR + (5 >= 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE"); + END IF; + END; -- (H) + + ------------------------------------------------- + + DECLARE -- (I) + FUNCTION "&" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (I) + IF (IDENT_INT (10) & 1) /= 'G' OR + (5 & 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE"); + END IF; + END; -- (I) + + ------------------------------------------------- + + DECLARE -- (J) + FUNCTION "*" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (J) + IF (IDENT_INT (10) * 1) /= 'G' OR + (5 * 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE"); + END IF; + END; -- (J) + + ------------------------------------------------- + + DECLARE -- (K) + FUNCTION "/" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (K) + IF (IDENT_INT (10) / 1) /= 'G' OR + (5 / 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE"); + END IF; + END; -- (K) + + ------------------------------------------------- + + DECLARE -- (L) + FUNCTION "MOD" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (L) + IF (IDENT_INT (10) MOD 1) /= 'G' OR + (5 MOD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE"); + END IF; + END; -- (L) + + ------------------------------------------------- + + DECLARE -- (M) + FUNCTION "REM" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (M) + IF (IDENT_INT (10) REM 1) /= 'G' OR + (5 REM 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE"); + END IF; + END; -- (M) + + ------------------------------------------------- + + DECLARE -- (N) + FUNCTION "**" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (N) + IF (IDENT_INT (10) ** 1) /= 'G' OR + (5 ** 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE"); + END IF; + END; -- (N) + + ------------------------------------------------- + + DECLARE -- (O) + FUNCTION "+" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (O) + IF (IDENT_INT (10) + 1) /= 'G' OR + (5 + 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE"); + END IF; + END; -- (O) + + ------------------------------------------------- + + DECLARE -- (P) + FUNCTION "-" IS NEW TWO_PARAMS + (ELEMENT => INTEGER); + + BEGIN -- (P) + IF (IDENT_INT (10) - 1) /= 'G' OR + (5 - 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE"); + END IF; + END; -- (P) + + ------------------------------------------------- + + DECLARE -- (Q) + FUNCTION "+" IS NEW ONE_PARAM + (ELEMENT => INTEGER); + + BEGIN -- (Q) + IF (+ IDENT_INT(25) /= 'P') OR + (+ (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""+"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (Q) + + ------------------------------------------------- + + DECLARE -- (R) + FUNCTION "-" IS NEW ONE_PARAM + (ELEMENT => INTEGER); + + BEGIN -- (R) + IF (- IDENT_INT(25) /= 'P') OR + (- (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""-"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (R) + + ------------------------------------------------- + + DECLARE -- (S) + FUNCTION "NOT" IS NEW ONE_PARAM + (ELEMENT => INTEGER); + + BEGIN -- (S) + IF (NOT IDENT_INT(25) /= 'P') OR + (NOT (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""NOT"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (S) + + ------------------------------------------------- + + DECLARE -- (T) + FUNCTION "ABS" IS NEW ONE_PARAM + (ELEMENT => INTEGER); + + BEGIN -- (T) + IF (ABS IDENT_INT(25) /= 'P') OR + (ABS (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""ABS"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (T) + + ------------------------------------------------- + + RESULT; + END C67002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67002e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67002e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,348 ---- + -- C67002E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL OPERATOR SYMBOLS CAN BE USED IN (OVERLOADED) + -- FUNCTION SPECIFICATIONS WITH THE REQUIRED NUMBER OF PARAMETERS. + -- THIS TEST CHECKS RENAMING DECLARATIONS FOR THESE FUNCTIONS. + -- SUBTESTS ARE: + -- (A) THROUGH (P): "=", "AND", "OR", "XOR", "<", "<=", + -- ">", ">=", "&", "*", "/", "MOD", "REM", "**", "+", "-", + -- RESPECTIVELY. ALL OF THESE HAVE TWO PARAMETERS. + -- (Q), (R), (S), AND (T): "+", "-", "NOT", "ABS", RESPECTIVELY, + -- WITH ONE PARAMETER. + + -- CPP 6/26/84 + + WITH REPORT; USE REPORT; + PROCEDURE C67002E IS + + FUNCTION TWO_PARAMS (I1, I2 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 > I2 THEN + RETURN 'G'; + ELSE RETURN 'L'; + END IF; + END TWO_PARAMS; + + FUNCTION ONE_PARAM (I1 : INTEGER) RETURN CHARACTER IS + BEGIN + IF I1 < IDENT_INT(0) THEN + RETURN 'N'; + ELSE RETURN 'P'; + END IF; + END ONE_PARAM; + + BEGIN + TEST ("C67002E", "USE OF OPERATOR SYMBOLS IN " & + "(OVERLOADED) FUNCTION SPECIFICATIONS"); + + ------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN; + PRIVATE + TYPE LP IS NEW INTEGER; + END PKG; + USE PKG; + + LP1, LP2 : LP; + + FUNCTION "=" (LPA, LPB : LP) + RETURN BOOLEAN RENAMES PKG."="; + + PACKAGE BODY PKG IS + FUNCTION "=" (LPA, LPB : LP) RETURN BOOLEAN IS + BEGIN + RETURN LPA > LPB; + END "="; + BEGIN + LP1 := LP (IDENT_INT (7)); + LP2 := LP (IDENT_INT (8)); + END PKG; + + BEGIN -- (A) + IF (LP1 = LP2) OR NOT (LP2 = LP1) OR + (LP1 = LP1) OR (LP2 /= LP1) THEN + FAILED ("OVERLOADING OF ""="" OPERATOR DEFECTIVE"); + END IF; + END; -- (A) + + ------------------------------------------------- + + DECLARE -- (B) + FUNCTION "AND" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (B) + IF (IDENT_INT (10) AND 1) /= 'G' OR + (5 AND 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""AND"" OPERATOR DEFECTIVE"); + END IF; + END; -- (B) + + ------------------------------------------------- + + DECLARE -- (C) + FUNCTION "OR" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (C) + IF (IDENT_INT (10) OR 1) /= 'G' OR + (5 OR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""OR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (C) + + ------------------------------------------------- + + DECLARE -- (D) + FUNCTION "XOR" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (D) + IF (IDENT_INT (10) XOR 1) /= 'G' OR + (5 XOR 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""XOR"" OPERATOR DEFECTIVE"); + END IF; + END; -- (D) + + ------------------------------------------------- + + DECLARE -- (E) + FUNCTION "<" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (E) + IF (IDENT_INT (10) < 1) /= 'G' OR + (5 < 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<"" OPERATOR DEFECTIVE"); + END IF; + END; -- (E) + + ------------------------------------------------- + + DECLARE -- (F) + FUNCTION "<=" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (F) + IF (IDENT_INT (10) <= 1) /= 'G' OR + (5 <= 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""<="" OPERATOR DEFECTIVE"); + END IF; + END; -- (F) + + ------------------------------------------------- + + DECLARE -- (G) + FUNCTION ">" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (G) + IF (IDENT_INT (10) > 1) /= 'G' OR + (5 > 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">"" OPERATOR DEFECTIVE"); + END IF; + END; -- (G) + + ------------------------------------------------- + + DECLARE -- (H) + FUNCTION ">=" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (H) + IF (IDENT_INT (10) >= 1) /= 'G' OR + (5 >= 10) /= 'L' THEN + FAILED ("OVERLOADING OF "">="" OPERATOR DEFECTIVE"); + END IF; + END; -- (H) + + ------------------------------------------------- + + DECLARE -- (I) + FUNCTION "&" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (I) + IF (IDENT_INT (10) & 1) /= 'G' OR + (5 & 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""&"" OPERATOR DEFECTIVE"); + END IF; + END; -- (I) + + ------------------------------------------------- + + DECLARE -- (J) + FUNCTION "*" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (J) + IF (IDENT_INT (10) * 1) /= 'G' OR + (5 * 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""*"" OPERATOR DEFECTIVE"); + END IF; + END; -- (J) + + ------------------------------------------------- + + DECLARE -- (K) + FUNCTION "/" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (K) + IF (IDENT_INT (10) / 1) /= 'G' OR + (5 / 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""/"" OPERATOR DEFECTIVE"); + END IF; + END; -- (K) + + ------------------------------------------------- + + DECLARE -- (L) + FUNCTION "MOD" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (L) + IF (IDENT_INT (10) MOD 1) /= 'G' OR + (5 MOD 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""MOD"" OPERATOR DEFECTIVE"); + END IF; + END; -- (L) + + ------------------------------------------------- + + DECLARE -- (M) + FUNCTION "REM" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (M) + IF (IDENT_INT (10) REM 1) /= 'G' OR + (5 REM 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""REM"" OPERATOR DEFECTIVE"); + END IF; + END; -- (M) + + ------------------------------------------------- + + DECLARE -- (N) + FUNCTION "**" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (N) + IF (IDENT_INT (10) ** 1) /= 'G' OR + (5 ** 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""**"" OPERATOR DEFECTIVE"); + END IF; + END; -- (N) + + ------------------------------------------------- + + DECLARE -- (O) + FUNCTION "+" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (O) + IF (IDENT_INT (10) + 1) /= 'G' OR + (5 + 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""+"" OPERATOR DEFECTIVE"); + END IF; + END; -- (O) + + ------------------------------------------------- + + DECLARE -- (P) + FUNCTION "-" (I1, I2 : INTEGER) + RETURN CHARACTER RENAMES TWO_PARAMS; + + BEGIN -- (P) + IF (IDENT_INT (10) - 1) /= 'G' OR + (5 - 10) /= 'L' THEN + FAILED ("OVERLOADING OF ""-"" OPERATOR DEFECTIVE"); + END IF; + END; -- (P) + + ------------------------------------------------- + + DECLARE -- (Q) + FUNCTION "+" (I1 : INTEGER) + RETURN CHARACTER RENAMES ONE_PARAM; + + BEGIN -- (Q) + IF (+ IDENT_INT(25) /= 'P') OR + (+ (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""+"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (Q) + + ------------------------------------------------- + + DECLARE -- (R) + FUNCTION "-" (I1 : INTEGER) + RETURN CHARACTER RENAMES ONE_PARAM; + + BEGIN -- (R) + IF (- IDENT_INT(25) /= 'P') OR + (- (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""-"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (R) + + ------------------------------------------------- + + DECLARE -- (S) + FUNCTION "NOT" (I1 : INTEGER) + RETURN CHARACTER RENAMES ONE_PARAM; + + BEGIN -- (S) + IF (NOT IDENT_INT(25) /= 'P') OR + (NOT (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""NOT"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (S) + + ------------------------------------------------- + + DECLARE -- (T) + FUNCTION "ABS" (I1 : INTEGER) + RETURN CHARACTER RENAMES ONE_PARAM; + + BEGIN -- (T) + IF (ABS IDENT_INT(25) /= 'P') OR + (ABS (0-25) /= 'N') THEN + FAILED ("OVERLOADING OF ""ABS"" " & + "OPERATOR (ONE OPERAND) DEFECTIVE"); + END IF; + END; -- (T) + + ------------------------------------------------- + + RESULT; + END C67002E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67003f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67003f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67003f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67003f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,319 ---- + -- C67003F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE PREDEFINED OPERATORS FOR THE PREDEFINED TYPES CAN BE + -- REDEFINED. + -- CHECK THAT THE REDEFINED OPERATOR IS INVOKED WHEN INFIX OR PREFIX + -- NOTATION IS USED. + + -- HISTORY: + -- WMC 03/21/92 TEST CREATED FROM CONSOLIDATION OF C67003[A-E].ADA + + + WITH REPORT; + + PROCEDURE C67003F IS + + USE REPORT; + + BEGIN + + TEST ("C67003F", "CHECK THAT REDEFINITION OF " & + "OPERATORS FOR PREDEFINED TYPES WORKS"); + + DECLARE -- INTEGER OPERATORS. + + -- INTEGER INFIX OPERATORS. + + FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= Y THEN + RETURN 1; + ELSE RETURN 0; + END IF; + END "*"; + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= Y THEN + RETURN 2; + ELSE RETURN 0; + END IF; + END "+"; + + FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= Y THEN + RETURN 3; + ELSE RETURN 0; + END IF; + END "REM"; + + -- INTEGER PREFIX OPERATORS. + + FUNCTION "+" (X : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= 0 THEN + RETURN 4; + ELSE RETURN 0; + END IF; + END "+"; + + FUNCTION "ABS" (X : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= 0 THEN + RETURN 5; + ELSE RETURN 0; + END IF; + END "ABS"; + + -- INTEGER RELATIONAL OPERATOR. + + FUNCTION "<" (X, Y : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END "<"; + + BEGIN + + IF IDENT_INT (3) * IDENT_INT (5) /= 1 THEN + FAILED ("REDEFINITION OF INTEGER ""*"" IS DEFECTIVE"); + END IF; + + IF IDENT_INT (1) + IDENT_INT (30) /= 2 THEN + FAILED ("REDEFINITION OF INTEGER ""+"" IS DEFECTIVE"); + END IF; + + IF IDENT_INT (7) REM IDENT_INT (8) /= 3 THEN + FAILED ("REDEFINITION OF ""REM"" IS DEFECTIVE"); + END IF; + + IF + (IDENT_INT (10)) /= 4 THEN + FAILED ("REDEFINITION OF INTEGER UNARY ""+"" IS DEFECTIVE"); + END IF; + + IF ABS (IDENT_INT (2)) /= 5 THEN + FAILED ("REDEFINITION OF INTEGER ""ABS"" IS DEFECTIVE"); + END IF; + + IF IDENT_INT (7) < IDENT_INT (8) THEN + FAILED ("REDEFINITION OF INTEGER ""<"" IS DEFECTIVE"); + END IF; + + END; + + DECLARE -- FLOAT OPERATORS. + + -- NOTE THAT ALL LITERAL VALUES USED SHOULD BE + -- REPRESENTABLE EXACTLY. + + FUNCTION IDENT_FLOAT (X : FLOAT) RETURN FLOAT IS + I : INTEGER := INTEGER (X); + BEGIN + IF EQUAL (I, I) THEN -- ALWAYS EQUAL. + RETURN X; + END IF; + RETURN 0.0; + END IDENT_FLOAT; + + -- FLOAT INFIX OPERATORS. + + FUNCTION "-" (X, Y : FLOAT) RETURN FLOAT IS + BEGIN + IF X /= Y THEN + RETURN 1.0; + ELSE RETURN 0.0; + END IF; + END "-"; + + FUNCTION "/" (X, Y : FLOAT) RETURN FLOAT IS + BEGIN + IF X /= Y THEN + RETURN 2.0; + ELSE RETURN 0.0; + END IF; + END "/"; + + FUNCTION "**" (X : FLOAT; Y : INTEGER) RETURN FLOAT IS + BEGIN + IF INTEGER (X) /= Y THEN + RETURN 3.0; + ELSE RETURN 0.0; + END IF; + END "**"; + + -- FLOAT PREFIX OPERATOR. + + FUNCTION "-" (X : FLOAT) RETURN FLOAT IS + BEGIN + IF X /= 0.0 THEN + RETURN 4.0; + ELSE RETURN 0.0; + END IF; + END "-"; + + -- FLOAT RELATIONAL OPERATOR. + + FUNCTION "<=" (X, Y : FLOAT) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END "<="; + + BEGIN + + IF IDENT_FLOAT (50.0) - IDENT_FLOAT (100.0) /= 1.0 THEN + FAILED ("REDEFINITION OF FLOAT ""-"" IS DEFECTIVE"); + END IF; + + IF IDENT_FLOAT (5.0) / IDENT_FLOAT (1.0) /= 2.0 THEN + FAILED ("REDEFINITION OF FLOAT ""/"" IS DEFECTIVE"); + END IF; + + IF IDENT_FLOAT (3.0) ** IDENT_INT (2) /= 3.0 THEN + FAILED ("REDEFINITION OF FLOAT ""**"" IS DEFECTIVE"); + END IF; + + IF -(IDENT_FLOAT (5.0)) /= 4.0 THEN + FAILED ("REDEFINITION OF FLOAT UNARY ""-"" IS DEFECTIVE"); + END IF; + + IF IDENT_FLOAT (1.0) <= IDENT_FLOAT (5.0) THEN + FAILED ("REDEFINITION OF FLOAT ""<="" IS DEFECTIVE"); + END IF; + + END; + + DECLARE -- BOOLEAN OPERATORS. + + -- BOOLEAN LOGICAL OPERATORS. + + FUNCTION "AND" (X, Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + IF X AND THEN Y THEN + RETURN FALSE; + ELSE RETURN TRUE; + END IF; + END "AND"; + + FUNCTION "XOR" (X, Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END "XOR"; + + -- BOOLEAN RELATIONAL OPERATOR. + + FUNCTION ">" (X, Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END ">"; + + BEGIN + + IF IDENT_BOOL (TRUE) AND IDENT_BOOL (TRUE) THEN + FAILED ("REDEFINITION OF ""AND"" IS DEFECTIVE"); + END IF; + + IF IDENT_BOOL (TRUE) XOR IDENT_BOOL (FALSE) THEN + FAILED ("REDEFINITION OF ""XOR"" IS DEFECTIVE"); + END IF; + + IF IDENT_BOOL (TRUE) > IDENT_BOOL (FALSE) THEN + FAILED ("REDEFINITION OF BOOLEAN "">"" IS DEFECTIVE"); + END IF; + + END; + + DECLARE -- STRING OPERATORS. + + S1 : STRING (1..2) := "A" & IDENT_CHAR ('B'); + S2 : STRING (1..2) := "C" & IDENT_CHAR ('D'); + + FUNCTION "&" (X, Y : STRING) RETURN STRING IS + Z : STRING (1 .. X'LENGTH + Y'LENGTH); + BEGIN + Z (1 .. Y'LENGTH) := Y; + Z (Y'LENGTH + 1 .. Z'LAST) := X; + RETURN Z; + END "&"; + + FUNCTION "&" (X : CHARACTER; Y : STRING) RETURN STRING IS + Z : STRING (1 .. Y'LENGTH + 1); + BEGIN + Z (1 .. Y'LENGTH) := Y; + Z (Z'LAST) := X; + RETURN Z; + END "&"; + + -- STRING RELATIONAL OPERATOR. + + FUNCTION ">=" (X, Y : STRING) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END ">="; + + BEGIN + + IF S1 & S2 /= "CDAB" THEN + FAILED ("BAD REDEFINITION OF ""&"" (S,S)"); + END IF; + + IF IDENT_CHAR ('C') & S1 /= "ABC" THEN + FAILED ("BAD REDEFINITION OF ""&"" (C,S)"); + END IF; + + IF S2 >= S1 THEN + FAILED ("BAD REDEFINITION OF STRING "">="""); + END IF; + + END; + + DECLARE -- CHARACTER OPERATORS. + + -- CHARACTER RELATIONAL OPERATORS. + + FUNCTION ">" (X, Y : CHARACTER) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END ">"; + + FUNCTION "<=" (X, Y : CHARACTER) RETURN BOOLEAN IS + BEGIN + RETURN X = Y; + END "<="; + + BEGIN + + IF IDENT_CHAR ('C') > IDENT_CHAR ('B') THEN + FAILED ("REDEFINITION OF CHARACTER "">"" IS DEFECTIVE"); + END IF; + + IF IDENT_CHAR ('A') <= IDENT_CHAR ('E') THEN + FAILED ("REDEFINITION OF CHARACTER ""<="" IS DEFECTIVE"); + END IF; + + END; + + RESULT; + + END C67003F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C67005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK IF A RENAMING DECLARATION DECLARES AN EQUALITY OPERATOR, THE + -- TYPES OF THE PARAMETERS NEED NOT BE LIMITED TYPES. + + -- JBG 9/28/83 + + WITH REPORT; USE REPORT; + PROCEDURE C67005A IS + BEGIN + TEST ("C67005A", "CHECK THAT AN EQUALITY OPERATOR DECLARED BY " & + "A RENAMING DECLARATION NEED NOT HAVE " & + "PARAMETERS OF A LIMITED TYPE"); + DECLARE + GENERIC + TYPE LP IS LIMITED PRIVATE; + WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN; + PACKAGE EQUALITY_OPERATOR IS + FUNCTION "=" (L, R : LP) RETURN BOOLEAN; + END EQUALITY_OPERATOR; + + PACKAGE BODY EQUALITY_OPERATOR IS + FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL(L, R); + END "="; + END EQUALITY_OPERATOR; + + PACKAGE POLAR_COORDINATES IS + TYPE POLAR_COORD IS + RECORD + R : INTEGER; + THETA : INTEGER; + END RECORD; + FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN; + PACKAGE POLAR_EQUAL IS NEW EQUALITY_OPERATOR + (POLAR_COORD, EQUAL); + FUNCTION "=" (L, R : POLAR_COORD) RETURN BOOLEAN + RENAMES POLAR_EQUAL."="; + END POLAR_COORDINATES; + + PACKAGE BODY POLAR_COORDINATES IS + FUNCTION EQUAL (L, R : POLAR_COORD) RETURN BOOLEAN IS + BEGIN + RETURN (L.THETA MOD 360) = (R.THETA MOD 360) AND + L.R = R.R; + END EQUAL; + END POLAR_COORDINATES; + + USE POLAR_COORDINATES; + + PACKAGE VARIABLES IS + P270 : POLAR_COORD := (R => 3, THETA => 270); + P360 : POLAR_COORD := (R => 3, THETA => IDENT_INT(360)); + END VARIABLES; + + USE VARIABLES; + + BEGIN + + IF P270 /= (3, -90) THEN + FAILED ("INCORRECT INEQUALITY OPERATOR"); + END IF; + + IF P360 = (3, 0) THEN + NULL; + ELSE + FAILED ("INCORRECT EQUALITY OPERATOR"); + END IF; + + RESULT; + + END; + END C67005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C67005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF EQUALITY IS REDEFINED FOR A SCALAR TYPE, CASE + -- STATEMENTS STILL USE THE PREDEFINED EQUALITY OPERATION. + + -- JBG 9/28/83 + + WITH REPORT; USE REPORT; + PROCEDURE C67005B IS + + GENERIC + TYPE LP IS LIMITED PRIVATE; + WITH FUNCTION EQUAL (L, R : LP) RETURN BOOLEAN; + PACKAGE EQUALITY_OPERATOR IS + FUNCTION "=" (L, R : LP) RETURN BOOLEAN; + END EQUALITY_OPERATOR; + + PACKAGE BODY EQUALITY_OPERATOR IS + FUNCTION "=" (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL(L, R); + END "="; + END EQUALITY_OPERATOR; + + BEGIN + TEST ("C67005B", "CHECK THAT REDEFINING EQUALITY FOR A " & + "SCALAR TYPE DOES NOT AFFECT CASE STATEMENTS"); + + DECLARE + TYPE MY IS NEW INTEGER; + CHECK : MY; + + VAR : INTEGER RANGE 1..3 := 3; + + PACKAGE INTEGER_EQUALS IS + FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN; + PACKAGE INTEGER_EQUAL IS NEW EQUALITY_OPERATOR + (INTEGER, EQUAL); + END INTEGER_EQUALS; + + FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES + INTEGER_EQUALS.INTEGER_EQUAL."="; + + PACKAGE BODY INTEGER_EQUALS IS + FUNCTION EQUAL (L, R : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END EQUAL; + END INTEGER_EQUALS; + + BEGIN + + IF VAR = 3 THEN + FAILED ("DID NOT USE REDEFINED '=' - 1"); + END IF; + + IF VAR /= 3 THEN + NULL; + ELSE + FAILED ("DID NOT USE REDEFINED '/=' - 1"); + END IF; + + IF VAR = IDENT_INT(3) THEN + FAILED ("DID NOT USE REDEFINED '=' - 2"); + END IF; + + IF VAR /= IDENT_INT(3) THEN + NULL; + ELSE + FAILED ("DID NOT USE REDEFINED '/=' - 2"); + END IF; + + CHECK := MY(IDENT_INT(0)); + IF CHECK /= 0 THEN + FAILED ("USING WRONG EQUALITY FOR DERIVED TYPE"); + END IF; + + CASE VAR IS + WHEN 1..3 => CHECK := MY(IDENT_INT(1)); + WHEN OTHERS => NULL; + END CASE; + + IF CHECK /= 1 THEN + FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 1"); + END IF; + + CASE IDENT_INT(VAR) IS + WHEN 1 => CHECK := 4; + WHEN 2 => CHECK := 5; + WHEN 3 => CHECK := 6; + WHEN OTHERS => CHECK := 7; + END CASE; + + IF CHECK /= 6 THEN + FAILED ("DID NOT USE PREDEFINED EQUALS IN CASE - 2"); + END IF; + + END; + + RESULT; + + END C67005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C67005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DECLARATION OF "=" NEED NOT HAVE PARAMETERS + -- OF A LIMITED TYPE IN A RENAMING DECLARATION. THIS TEST CHECKS + -- ACCESS TYPES. + + -- BRYCE BARDIN (HUGHES AIRCRAFT) 7/2/84 + -- CPP 7/12/84 + + WITH REPORT; USE REPORT; + PROCEDURE C67005C IS + + GENERIC + TYPE T IS LIMITED PRIVATE; + WITH FUNCTION EQUAL (LEFT, RIGHT : T) RETURN BOOLEAN IS <>; + PACKAGE EQUALITY IS + FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN; + -- PRAGMA INLINE ("="); + END EQUALITY; + + PACKAGE BODY EQUALITY IS + FUNCTION "=" (LEFT, RIGHT : T) RETURN BOOLEAN IS + BEGIN + RETURN EQUAL (LEFT, RIGHT); + END "="; + END EQUALITY; + + PACKAGE STARTER IS + TYPE INT IS PRIVATE; + FUNCTION VALUE_OF (I : INTEGER) RETURN INT; + FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN; + PRIVATE + TYPE INT IS ACCESS INTEGER; + END STARTER; + + PACKAGE BODY STARTER IS + FUNCTION VALUE_OF (I : INTEGER) RETURN INT IS + BEGIN + RETURN NEW INTEGER'(I); + END VALUE_OF; + + FUNCTION EQUAL (LEFT, RIGHT : INT) RETURN BOOLEAN IS + BEGIN + RETURN LEFT.ALL = RIGHT.ALL; + END EQUAL; + END STARTER; + + PACKAGE ABSTRACTION IS + TYPE INT IS NEW STARTER.INT; + PACKAGE INT_EQUALITY IS NEW EQUALITY (INT, EQUAL); + FUNCTION "=" (LEFT, RIGHT : INT) RETURN BOOLEAN + RENAMES INT_EQUALITY."="; + END ABSTRACTION; + USE ABSTRACTION; + + BEGIN + + TEST ("C67005C", "RENAMING OF EQUALITY OPERATOR WITH " & + "NON-LIMITED PARAMETERS"); + + DECLARE + + I : INT := VALUE_OF(1); + J : INT := VALUE_OF(0); + + PROCEDURE CHECK (B : BOOLEAN) IS + BEGIN + IF I = J AND B THEN + COMMENT ("I = J"); + ELSIF I /= J AND NOT B THEN + COMMENT ("I /= J"); + ELSE + FAILED ("WRONG ""="" OPERATOR"); + END IF; + END CHECK; + + BEGIN + + CHECK(FALSE); + I := VALUE_OF(0); + CHECK(TRUE); + + RESULT; + + END; + + END C67005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c6/c67005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c6/c67005d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- C67005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EQUALITY CAN BE REDEFINED FOR AN ARBITRARY TYPE BY USING A + -- SEQUENCE OF RENAMING DECLARATIONS. + + -- JBG 9/11/84 + + WITH REPORT; USE REPORT; + PROCEDURE C67005D IS + + FUNCTION MY_EQUALS (L, R : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END MY_EQUALS; + + GENERIC + TYPE LP IS LIMITED PRIVATE; + WITH FUNCTION "=" (L, R : LP) RETURN BOOLEAN; + PACKAGE EQUALITY_OPERATOR IS + PACKAGE INNER IS + FUNCTION "=" (L, R : LP) RETURN BOOLEAN RENAMES + EQUALITY_OPERATOR."="; + END INNER; + END EQUALITY_OPERATOR; + + BEGIN + TEST ("C67005D", "CHECK REDEFINITION OF ""="" BY RENAMING"); + + DECLARE + + CHK1 : BOOLEAN := 3 = IDENT_INT(3); -- PREDEFINED "=" + + -- REDEFINE INTEGER "=". + + PACKAGE INT_EQUALITY IS NEW + EQUALITY_OPERATOR (INTEGER, MY_EQUALS); + FUNCTION "=" (L, R : INTEGER) RETURN BOOLEAN RENAMES + INT_EQUALITY.INNER."="; + + CHK2 : BOOLEAN := 3 = IDENT_INT(3); -- REDEFINED "=". + + BEGIN + + IF NOT CHK1 THEN + FAILED ("PREDEFINED ""="" NOT USED"); + END IF; + + IF CHK2 THEN + FAILED ("REDEFINED ""="" NOT USED"); + END IF; + + END; + + RESULT; + + END C67005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c72001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c72001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c72001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c72001b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C72001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A PACKAGE BODY CAN BE PROVIDED FOR A PACKAGE SPECIFICATION + -- THAT DOES NOT CONTAIN ANY SUBPROGRAM OR TASK DECLARATIONS AND THAT + -- STATEMENTS WITHIN THE PACKAGE BODIES CAN BE USED TO INITIALIZE + -- VARIABLES VISIBLE WITHIN THE PACKAGE BODY. + + -- RM 04/30/81 + -- RM 05/07/81 (TO INCORPORATE OLD TEST OBJECTIVE 7.1/T1 ) + -- ABW 6/10/82 + -- SPS 11/4/82 + -- JBG 9/15/83 + + WITH REPORT; + PROCEDURE C72001B IS + + USE REPORT; + + BEGIN + + TEST( "C72001B" , "CHECK: PACKAGE BODIES CAN INITIALIZE VISIBLE" & + " VARIABLES" ); + + DECLARE + + + PACKAGE P5 IS + + A : CHARACTER := 'B'; + B : BOOLEAN := FALSE; + + PACKAGE P6 IS + I : INTEGER := IDENT_INT(6); + END P6; + + END P5; + + + PACKAGE BODY P5 IS + PACKAGE BODY P6 IS + BEGIN + A := 'C'; + I := 17; + B := IDENT_BOOL(TRUE); + END P6; + BEGIN + A := 'A'; + END P5; + + + USE P5; + USE P6; + + BEGIN + + IF A /= 'A' THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 1"); + END IF; + + IF B /= TRUE THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 2"); + END IF; + + IF I /= 17 THEN + FAILED ("INITIALIZATIONS NOT CORRECT - 3"); + END IF; + + END; + + + RESULT; + + + END C72001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c72002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c72002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c72002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c72002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- C72002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE SPECIFICATION ARE + -- ELABORATED IN THE ORDER DECLARED. + + -- HISTORY: + -- DHH 03/09/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C72002A IS + + A : INTEGER := 0; + TYPE ORDER_ARRAY IS ARRAY(1 .. 14) OF INTEGER; + OBJECT_ARRAY : ORDER_ARRAY; + TYPE REAL IS DIGITS 4; + TYPE ENUM IS (RED,YELLOW,BLUE); + + TYPE ARR IS ARRAY(1 ..2) OF BOOLEAN; + D : ARR := (TRUE, TRUE); + E : ARR := (FALSE, FALSE); + + TYPE REC IS + RECORD + I : INTEGER; + END RECORD; + B : REC := (I => IDENT_INT(1)); + C : REC := (I => IDENT_INT(2)); + + FUNCTION GIVEN_ORDER(X : INTEGER) RETURN INTEGER IS + Y : INTEGER; + BEGIN + Y := X + 1; + RETURN Y; + END GIVEN_ORDER; + + FUNCTION BOOL(X : INTEGER) RETURN BOOLEAN IS + BEGIN + IF X = IDENT_INT(1) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN TRUE; + ELSIF X = IDENT_INT(8) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN FALSE; + END IF; + END BOOL; + + FUNCTION INT(X : INTEGER) RETURN INTEGER IS + BEGIN + IF X = IDENT_INT(2) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN IDENT_INT(1); + ELSIF X = IDENT_INT(9) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN IDENT_INT(2); + END IF; + END INT; + + FUNCTION FLOAT(X : INTEGER) RETURN REAL IS + BEGIN + IF X = IDENT_INT(3) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 1.0; + ELSIF X = IDENT_INT(10) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 2.0; + END IF; + END FLOAT; + + FUNCTION CHAR(X : INTEGER) RETURN CHARACTER IS + BEGIN + IF X = IDENT_INT(4) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 'A'; + ELSIF X = IDENT_INT(11) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN 'Z'; + END IF; + END CHAR; + + FUNCTION ENUMR(X : INTEGER) RETURN ENUM IS + BEGIN + IF X = IDENT_INT(5) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN RED; + ELSIF X = IDENT_INT(12) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN YELLOW; + END IF; + END ENUMR; + + FUNCTION ARRY(X : INTEGER) RETURN ARR IS + BEGIN + IF X = IDENT_INT(6) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN D; + ELSIF X = IDENT_INT(13) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN E; + END IF; + END ARRY; + + FUNCTION RECOR(X : INTEGER) RETURN REC IS + BEGIN + IF X = IDENT_INT(7) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN B; + ELSIF X = IDENT_INT(14) THEN + A := GIVEN_ORDER(A); + OBJECT_ARRAY(X) := A; + RETURN C; + END IF; + END RECOR; + + PACKAGE PACK IS + A : BOOLEAN := BOOL(1); + B : INTEGER := INT(2); + C : REAL := FLOAT(3); + D : CHARACTER := CHAR(4); + E : ENUM := ENUMR(5); + F : ARR := ARRY(6); + G : REC := RECOR(7); + H : BOOLEAN := BOOL(8); + I : INTEGER := INT(9); + J : REAL := FLOAT(10); + K : CHARACTER := CHAR(11); + L : ENUM := ENUMR(12); + M : ARR := ARRY(13); + N : REC := RECOR(14); + END PACK; + + BEGIN + TEST("C72002A", "CHECK THAT THE DECLARATIVE ITEMS IN A PACKAGE " & + "SPECIFICATION ARE ELABORATED IN THE ORDER " & + "DECLARED"); + + IF OBJECT_ARRAY(1) /= IDENT_INT(1) THEN + FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(2) /= IDENT_INT(2) THEN + FAILED("INTEGER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(3) /= IDENT_INT(3) THEN + FAILED("REAL 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(4) /= IDENT_INT(4) THEN + FAILED("CHARACTER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(5) /= IDENT_INT(5) THEN + FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(6) /= IDENT_INT(6) THEN + FAILED("ARRAY 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(7) /= IDENT_INT(7) THEN + FAILED("RECORD 1 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(8) /= IDENT_INT(8) THEN + FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(9) /= IDENT_INT(9) THEN + FAILED("INTEGER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(10) /= IDENT_INT(10) THEN + FAILED("REAL 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(11) /= IDENT_INT(11) THEN + FAILED("CHARACTER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(12) /= IDENT_INT(12) THEN + FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(13) /= IDENT_INT(13) THEN + FAILED("ARRAY 2 ELABORATED OUT OF ORDER"); + END IF; + + IF OBJECT_ARRAY(14) /= IDENT_INT(14) THEN + FAILED("RECORD 2 ELABORATED OUT OF ORDER"); + END IF; + + RESULT; + END C72002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,437 ---- + -- C730001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the full view of a private extension may be derived + -- indirectly from the ancestor type (i.e., the parent type of the full + -- type may be any descendant of the ancestor type). Check that, for + -- a primitive subprogram of the private extension that is inherited from + -- the ancestor type and not overridden, the formal parameter names and + -- default expressions come from the corresponding primitive subprogram + -- of the ancestor type, while the body comes from that of the parent + -- type. Check both dispatching and non-dispatching cases. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package P is + -- type Ancestor is tagged ... + -- procedure Op (P1: Ancestor; P2: Boolean := True); + -- end P; + -- + -- with P; + -- package Q is + -- type Derived is new P.Ancestor with ... + -- procedure Op (X: Ancestor; Y: Boolean := False); + -- end Q; + -- + -- with P, Q; + -- package R is + -- type Priv_Ext is new P.Ancestor with private; -- (A) + -- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True); + -- -- But body executed is that of Q.Op. + -- private + -- type Priv_Ext is new Q.Derived with record ... -- (B) + -- end R; + -- + -- The ancestor type in (A) differs from the parent type in (B); the + -- parent of the full type is descended from the ancestor type of the + -- private extension. For a call to Op (from outside the scope of the + -- full view) with an operand of type Priv_Ext, the formal parameter + -- names and default expression come from that of P.Op (the ancestor + -- type's version), but the body executed will be that of + -- Q.Op (the parent type's version) + -- + -- One half of the test mirrors the above template, where an inherited + -- subprogram (Set_Display) is called using the formal parameter + -- name (C) and default parameter expression of the ancestor type's + -- version (type Clock), but the version of the body executed is from + -- the parent type. + -- + -- The test also includes an examination of the dynamic evaluation + -- case, where correct body associations are required through dispatching + -- calls. As described for the non-dispatching case above, the formal + -- parameter name and default values of the ancestor type's (Phone) + -- version of the inherited subprogram (Answer) are used in the + -- dispatching call, but the body executed is from the parent type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C730001_0 is + + type Display_Kind is (None, Analog, Digital); + type Illumination_Type is (None, Light, Phosphorescence); + type Capability_Type is (Available, In_Use, Call_Waiting, Conference); + type Indicator_Type is (None, Light, Bell, Buzzer, Click, Modem); + + type Clock is abstract tagged record -- ancestor type associated + Display : Display_Kind := None; -- with non-dispatching case. + Illumination : Illumination_Type := None; + end record; + + type Phone is tagged record -- ancestor type associated + Status : Capability_Type := Available; -- with dispatching case. + Indicator : Indicator_Type := None; + end record; + + -- The Set_Display procedure for type Clock implements a basic, no-frills + -- clock display. + procedure Set_Display (C : in out Clock; + Disp: in Display_Kind := Digital); + + -- The Answer procedure for type Phone implements a phone status change + -- operation. + procedure Answer (The_Phone : in out Phone; + Ind : in Indicator_Type := Light); + -- ...Other general clock and/or phone operations (not specified in this + -- test scenario). + + end C730001_0; + + + --==================================================================-- + + + package body C730001_0 is + + procedure Set_Display (C : in out Clock; + Disp: in Display_Kind := Digital) is + begin + C.Display := Disp; + C.Illumination := Light; + end Set_Display; + + procedure Answer (The_Phone : in out Phone; + Ind : in Indicator_Type := Light) is + begin + The_Phone.Status := In_Use; + The_Phone.Indicator := Ind; + end Answer; + + end C730001_0; + + + --==================================================================-- + + + with C730001_0; use C730001_0; + package C730001_1 is + + type Power_Supply_Type is (Spring, Battery, AC_Current); + type Speaker_Type is (None, Present, Adjustable, Stereo); + + type Wall_Clock is new Clock with record + Power_Source : Power_Supply_Type := Spring; + end record; + + type Office_Phone is new Phone with record + Speaker : Speaker_Type := Present; + end record; + + -- Note: Both procedures below, parameter names and defaults differ from + -- parent's version. + + -- The Set_Display procedure for type Wall_Clock improves upon the + -- basic Set_Display procedure of type Clock. + + procedure Set_Display (WC: in out Wall_Clock; + D : in Display_Kind := Analog); + + procedure Answer (OP : in out Office_Phone; + OI : in Indicator_Type := Buzzer); + + -- ...Other wall clock and/or Office_Phone operations (not specified in + -- this test scenario). + + end C730001_1; + + + --==================================================================-- + + + package body C730001_1 is + + -- Note: This body is the one that should be executed in the test block + -- below, not the version of the body corresponding to type Clock. + + procedure Set_Display (WC: in out Wall_Clock; + D : in Display_Kind := Analog) is + begin + WC.Display := D; + WC.Illumination := Phosphorescence; + end Set_Display; + + + procedure Answer (OP : in out Office_Phone; + OI : in Indicator_Type := Buzzer) is + begin + OP.Status := Call_Waiting; + OP.Indicator := OI; + end Answer; + + end C730001_1; + + + --==================================================================-- + + + with C730001_0; use C730001_0; + with C730001_1; use C730001_1; + package C730001_2 is + + type Alarm_Type is (Buzzer, Radio, Both); + type Video_Type is (None, TV_Monitor, Wall_Projection); + + type Alarm_Clock is new Clock with private; + -- Inherits proc Set_Display (C : in out Clock; + -- Disp: in Display_Kind := Digital); -- (A) + -- + -- Would also inherit other general clock operations (if present). + + + type Conference_Room_Phone is new Office_Phone with record + Display : Video_Type := TV_Monitor; + end record; + + procedure Answer (CP : in out Conference_Room_Phone; + CI : in Indicator_Type := Modem); + + + function TC_Get_Display (C: Alarm_Clock) return Display_Kind; + function TC_Get_Display_Illumination (C: Alarm_Clock) + return Illumination_Type; + + private + + -- ...however, certain of the wall clock's operations (Set_Display, in + -- this example) improve on the implementations provided for the general + -- clock. We want to call the improved implementations, so we + -- derive from Wall_Clock in the private part. + + type Alarm_Clock is new Wall_Clock with record + Alarm : Alarm_Type := Buzzer; + end record; + + -- Inherits proc Set_Display (WC: in out Wall_Clock; + -- D : in Display_Kind := Analog); -- (B) + + -- The implicit Set_Display at (B) overrides the implicit Set_Display at + -- (A), but only within the scope of the full view. + -- + -- Outside the scope of the full view, only (A) is visible, so calls + -- from outside the scope will get the formal parameter names and default + -- from (A). Both inside and outside the scope, however, the body executed + -- will be that corresponding to Set_Display of the parent type. + + end C730001_2; + + + --==================================================================-- + + + package body C730001_2 is + + procedure Answer (CP : in out Conference_Room_Phone; + CI : in Indicator_Type := Modem)is + begin + CP.Status := Conference; + CP.Indicator := CI; + end Answer; + + + function TC_Get_Display (C: Alarm_Clock) return Display_Kind is + begin + return C.Display; + end TC_Get_Display; + + + function TC_Get_Display_Illumination (C: Alarm_Clock) + return Illumination_Type is + begin + return C.Illumination; + end TC_Get_Display_Illumination; + + end C730001_2; + + + --==================================================================-- + + + with C730001_0; use C730001_0; + with C730001_1; use C730001_1; + with C730001_2; use C730001_2; + + package C730001_3 is + + -- Types extended from the ancestor (Phone) type in the specification. + + type Secure_Phone_Type is new Phone with private; + type Auditorium_Phone_Type is new Phone with private; + -- Inherit versions of Answer from ancestor (Phone). + + function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type; + function TC_Get_Indicator (P : Phone'Class) return Indicator_Type; + + private + + -- Types extended from descendents of Phone_Type in the private part. + + type Secure_Phone_Type is new Office_Phone with record + Scrambled_Communication : Boolean := True; + end record; + + type Auditorium_Phone_Type is new Conference_Room_Phone with record + Volume_Control : Boolean := True; + end record; + + end C730001_3; + + --==================================================================-- + + package body C730001_3 is + + function TC_Get_Phone_Status (P : Phone'Class) return Capability_Type is + begin + return P.Status; + end TC_Get_Phone_Status; + + function TC_Get_Indicator (P : Phone'Class) return Indicator_Type is + begin + return P.Indicator; + end TC_Get_Indicator; + + end C730001_3; + + --==================================================================-- + + with C730001_0; use C730001_0; + with C730001_1; use C730001_1; + with C730001_2; use C730001_2; + with C730001_3; use C730001_3; + + with Report; + + procedure C730001 is + begin + + Report.Test ("C730001","Check that the full view of a private extension " & + "may be derived indirectly from the ancestor " & + "type. Check that, for a primitive subprogram " & + "of the private extension that is inherited from " & + "the ancestor type and not overridden, the " & + "formal parameter names and default expressions " & + "come from the corresponding primitive " & + "subprogram of the ancestor type, while the body " & + "comes from that of the parent type"); + + Test_Block: + declare + + Alarm : Alarm_Clock; + Hot_Line : Secure_Phone_Type; + TeleConference_Phone : Auditorium_Phone_Type; + + begin + + -- Evaluate non-dispatching case: + + -- Call Set_Display using formal parameter name from + -- C730001_0.Set_Display. + -- Give no 2nd parameter so that default expression must be used. + + Set_Display (C => Alarm); + + -- The value of the Display component should equal Digital, which is + -- the default value from the ancestor's version of Set_Display, + -- and not the default value from the parent's version of Set_Display. + + if TC_Get_Display (Alarm) /= Digital then + Report.Failed ("Default expression for ancestor op not used " & + "in non-dispatching case"); + end if; + + -- However, the value of the Illumination component should equal + -- Phosphorescence, which is assigned in the parent type's version of + -- the body of Set_Display. + + if TC_Get_Display_Illumination (Alarm) /= Phosphorescence then + Report.Failed ("Wrong body was executed in non-dispatching case"); + end if; + + + -- Evaluate dispatching case: + declare + + Hot_Line : Secure_Phone_Type; + TeleConference_Phone : Auditorium_Phone_Type; + + procedure Answer_The_Phone (P : in out Phone'Class) is + begin + -- Give no 2nd parameter so that default expression must be used. + Answer (P); + end Answer_The_Phone; + + begin + + Answer_The_Phone (Hot_Line); + Answer_The_Phone (TeleConference_Phone); + + -- The value of the Indicator field shold equal "Light", the default + -- value from the ancestor's version of Answer, and not the default + -- from either of the parent versions of Answer. + + if TC_Get_Indicator(Hot_Line) /= Light or + TC_Get_Indicator(TeleConference_Phone) /= Light + then + Report.Failed("Default expression from ancestor operation " & + "not used in dispatching case"); + end if; + + -- However, the value of the Status component should equal + -- Call_Waiting or Conference respectively, based on the assignment + -- in the parent type's version of the body of Answer. + + if TC_Get_Phone_Status(Hot_Line) /= Call_Waiting then + Report.Failed("Wrong body executed in dispatching case - 1"); + end if; + + if TC_Get_Phone_Status(TeleConference_Phone) /= Conference then + Report.Failed("Wrong body executed in dispatching case - 2"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end C730001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730002.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,383 ---- + -- C730002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the full view of a private extension may be derived + -- indirectly from the ancestor type (i.e., the parent type of the full + -- type may be any descendant of the ancestor type). Check that, for + -- a primitive subprogram of the private extension that is inherited from + -- the ancestor type and not overridden, the formal parameter names and + -- default expressions come from the corresponding primitive subprogram + -- of the ancestor type, while the body comes from that of the parent + -- type. + -- Check for a case where the parent type is derived from the ancestor + -- type through a series of types produced by generic instantiations. + -- Examine both the static and dynamic binding cases. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package P is + -- type Ancestor is tagged ... + -- procedure Op (P1: Ancestor; P2: Boolean := True); + -- end P; + -- + -- with P; + -- generic + -- type T is new P.Ancestor with private; + -- package Gen1 is + -- type Enhanced is new T with private; + -- procedure Op (A: Enhanced; B: Boolean := True); + -- -- other specific procedures... + -- private + -- type Enhanced is new T with ... + -- end Gen1; + -- + -- with P, Gen1; + -- package N is new Gen1 (P.Ancestor); + -- + -- with N; + -- generic + -- type T is new N.Enhanced with private; + -- package Gen2 is + -- type Enhanced_Again is new T with private; + -- procedure Op (X: Enhanced_Again; Y: Boolean := False); + -- -- other specific procedures... + -- private + -- type Enhanced_Again is new T with ... + -- end Gen2; + -- + -- with N, Gen2; + -- package Q is new Gen2 (N.Enhanced); + -- + -- with P, Q; + -- package R is + -- type Priv_Ext is new P.Ancestor with private; -- (A) + -- -- Inherits procedure Op (P1: Priv_Ext; P2: Boolean := True); + -- -- But body executed is that of Q.Op. + -- private + -- type Priv_Ext is new Q.Enhanced_Again with record ... -- (B) + -- end R; + -- + -- The ancestor type in (A) differs from the parent type in (B); the + -- parent of the full type is descended from the ancestor type of the + -- private extension, in this case through a series of types produced + -- by generic instantiations. Gen1 redefines the implementation of Op + -- for any type that has one. N is an instance of Gen1 for the ancestor + -- type. Gen2 again redefines the implementation of Op for any type that + -- has one. Q is an instance of Gen2 for the extension of the P.Ancestor + -- declared in N. Both N and Q could define other operations which we + -- don't want to be available in R. For a call to Op (from outside the + -- scope of the full view) with an operand of type R.Priv_Ext, the body + -- executed will be that of Q.Op (the parent type's version), but the + -- formal parameter names and default expression come from that of P.Op + -- (the ancestor type's version). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 97 CTA.PWB Added elaboration pragmas. + --! + + package C730002_0 is + + type Hours_Type is range 0..1000; + type Personnel_Type is range 0..10; + type Specialist_ID is (Manny, Moe, Jack, Curly, Joe, Larry); + + type Engine_Type is tagged record + Ave_Repair_Time : Hours_Type := 0; -- Default init. for + Personnel_Required : Personnel_Type := 0; -- component fields. + Specialist : Specialist_ID := Manny; + end record; + + procedure Routine_Maintenance (Engine : in out Engine_Type ; + Specialist : in Specialist_ID := Moe); + + -- The Routine_Maintenance procedure implements the processing required + -- for an engine. + + end C730002_0; + + --==================================================================-- + + package body C730002_0 is + + procedure Routine_Maintenance (Engine : in out Engine_Type ; + Specialist : in Specialist_ID := Moe) is + begin + Engine.Ave_Repair_Time := 3; + Engine.Personnel_Required := 1; + Engine.Specialist := Specialist; + end Routine_Maintenance; + + end C730002_0; + + --==================================================================-- + + with C730002_0; use C730002_0; + generic + type T is new C730002_0.Engine_Type with private; + package C730002_1 is + + -- This generic package contains types/procedures specific to engines + -- of the diesel variety. + + type Repair_Facility_Type is (On_Site, Repair_Shop, Factory); + + type Diesel_Series is new T with private; + + procedure Routine_Maintenance (Eng : in out Diesel_Series; + Spec_Req : in Specialist_ID := Jack); + + -- Other diesel specific operations... (not required in this test). + + private + + type Diesel_Series is new T with record + Repair_Facility_Required : Repair_Facility_Type := On_Site; + end record; + + end C730002_1; + + --==================================================================-- + + package body C730002_1 is + + procedure Routine_Maintenance (Eng : in out Diesel_Series; + Spec_Req : in Specialist_ID := Jack) is + begin + Eng.Ave_Repair_Time := 6; + Eng.Personnel_Required := 2; + Eng.Specialist := Spec_Req; + Eng.Repair_Facility_Required := On_Site; + end Routine_Maintenance; + + end C730002_1; + + --==================================================================-- + + with C730002_0; + with C730002_1; + pragma Elaborate (C730002_1); + package C730002_2 is new C730002_1 (C730002_0.Engine_Type); + + --==================================================================-- + + with C730002_0; use C730002_0; + with C730002_2; use C730002_2; + generic + type T is new C730002_2.Diesel_Series with private; + package C730002_3 is + + type Time_Of_Operation_Type is range 0..100_000; + + type Electric_Series is new T with private; + + procedure Routine_Maintenance (E : in out Electric_Series; + SR : in Specialist_ID := Curly); + + -- Other electric specific operations... (not required in this test). + + private + + type Electric_Series is new T with record + Mean_Time_Between_Repair : Time_Of_Operation_Type := 0; + end record; + + end C730002_3; + + --==================================================================-- + + package body C730002_3 is + + procedure Routine_Maintenance (E : in out Electric_Series; + SR : in Specialist_ID := Curly) is + begin + E.Ave_Repair_Time := 9; + E.Personnel_Required := 3; + E.Specialist := SR; + E.Mean_Time_Between_Repair := 1000; + end Routine_Maintenance; + + end C730002_3; + + --==================================================================-- + + with C730002_2; + with C730002_3; + pragma Elaborate (C730002_3); + package C730002_4 is new C730002_3 (C730002_2.Diesel_Series); + + --==================================================================-- + + with C730002_0; use C730002_0; + with C730002_4; use C730002_4; + + package C730002_5 is + + type Inspection_Type is (AAA, MIL_STD, NRC); + + type Nuclear_Series is new Engine_Type with private; -- (A) + + -- Inherits procedure Routine_Maintenance from ancestor; does not override. + -- (Engine : in out Nuclear_Series; + -- Specialist : in Specialist_ID := Moe); + -- But body executed will be that of C730002_4.Routine_Maintenance, + -- the parent type. + + function TC_Specialist (E : Nuclear_Series) return Specialist_ID; + function TC_Personnel_Required (E : Nuclear_Series) return Personnel_Type; + function TC_Time_Required (E : Nuclear_Series) return Hours_Type; + + -- Dispatching subprogram. + procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class); + + private + + type Nuclear_Series is new Electric_Series with record -- (B) + Inspector_Rep : Inspection_Type := NRC; + end record; + + -- The ancestor type is used in the type extension (A), while the parent + -- of the full type (B) is a descendent of the ancestor type, through a + -- series of types produced by generic instantiation. + + end C730002_5; + + --==================================================================-- + + package body C730002_5 is + + function TC_Specialist (E : Nuclear_Series) return Specialist_ID is + begin + return E.Specialist; + end TC_Specialist; + + function TC_Personnel_Required (E : Nuclear_Series) + return Personnel_Type is + begin + return E.Personnel_Required; + end TC_Personnel_Required; + + function TC_Time_Required (E : Nuclear_Series) return Hours_Type is + begin + return E.Ave_Repair_Time; + end TC_Time_Required; + + -- Dispatching subprogram. + procedure Maintain_The_Engine (The_Engine : in out Engine_Type'Class) is + begin + Routine_Maintenance (The_Engine); + end Maintain_The_Engine; + + + end C730002_5; + + --==================================================================-- + + with Report; + with C730002_0; use C730002_0; + with C730002_2; use C730002_2; + with C730002_4; use C730002_4; + with C730002_5; use C730002_5; + + procedure C730002 is + begin + + Report.Test ("C730002", "Check that the full view of a private " & + "extension may be derived indirectly from " & + "the ancestor type. Check for a case where " & + "the parent type is derived from the ancestor " & + "type through a series of types produced by " & + "generic instantiations"); + + Test_Block: + declare + Nuclear_Drive : Nuclear_Series; + Warp_Drive : Nuclear_Series; + begin + + -- Non-Dispatching Case: + -- Call Routine_Maintenance using formal parameter name from + -- C730002_0.Routine_Maintenance (ancestor version). + -- Give no second parameter so that the default expression must be + -- used. + + Routine_Maintenance (Engine => Nuclear_Drive); + + -- The value of the Specialist component should equal "Moe", + -- which is the default value from the ancestor's version of + -- Routine_Maintenance, and not the default value from the parent's + -- version of Routine_Maintenance. + + if TC_Specialist (Nuclear_Drive) /= Moe then + Report.Failed + ("Default expression for ancestor op not used " & + " - non-dispatching case"); + end if; + + -- However the value of the Ave_Repair_Time and Personnel_Required + -- components should be those assigned in the parent type's version + -- of the body of Routine_Maintenance. + -- Note: Only components associated with the ancestor type are + -- evaluated for the purposes of this test. + + if TC_Personnel_Required (Nuclear_Drive) /= 3 or + TC_Time_Required (Nuclear_Drive) /= 9 + then + Report.Failed("Wrong body was executed - non-dispatching case"); + end if; + + -- Dispatching Case: + -- Use a dispatching subprogram to ensure that the correct body is + -- used at runtime. + + Maintain_The_Engine (Warp_Drive); + + -- The resulting assignments to the fields of the Warp_Drive variable + -- should be the same as those of the Nuclear_Drive above, indicating + -- that the body of the parent version of the inherited subprogram + -- was used. + + if TC_Specialist (Warp_Drive) /= Moe then + Report.Failed + ("Default expression for ancestor op not used - dispatching case"); + end if; + + if TC_Personnel_Required (Nuclear_Drive) /= 3 or + TC_Time_Required (Nuclear_Drive) /= 9 + then + Report.Failed("Wrong body was executed - dispatching case"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end C730002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730003.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,283 ---- + -- C730003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the characteristics of a type derived from a private + -- extension (outside the scope of the full view) are those defined by + -- the partial view of the private extension. + -- In particular, check that a component of the derived type may be + -- explicitly declared with the same name as a component declared for + -- the full view of the private extension. + -- Check that a component defined in the private extension of a type + -- may be updated through a view conversion of a type derived from + -- the type. + -- + -- TEST DESCRIPTION: + -- Consider: + -- + -- package Parent is + -- type T is tagged record + -- ... + -- end record; + -- + -- type DT is new T with private; + -- procedure Op1 (P: in out DT); + -- + -- private + -- type DT is new T with record + -- Y: ...; -- (A) + -- end record; + -- end Parent; + -- + -- package body Parent is + -- function Op1 (P: in DT) return ... is + -- begin + -- return P.Y; + -- end Op1; + -- end Parent; + -- + -- package Unrelated is + -- type Intermediate is new DT with record + -- Y: ...; -- Note: same name as component of -- (B) + -- -- parent's full view. + -- end record; + -- end Unrelated; + -- + -- package Parent.Child is + -- type DDT is new Intermediate with null record; + -- -- Implicit declared Op1 (P.DDT); -- (C) + -- + -- procedure Op2 (P: in out DDT); + -- end Parent.Child; + -- + -- package body Parent.Child is + -- procedure Op2 (P: in out DDT) is + -- Obj : DT renames DT(P); + -- begin + -- ... + -- P.Y := ...; -- Updates DDT's Y. -- (D) + -- DT(P).Y := ...; -- Updates DT's Y. -- (E) + -- Obj.Y := ...; -- Updates DT's Y. -- (F) + -- end Op2; + -- end Parent.Child; + -- + -- Types DT and DDT both declare a component Y at (A) and (B), + -- respectively. The component Y of the full view of DT is not visible + -- at the place where DDT is declared. Therefore, it is invisible for + -- all views of DDT (although it still exists for objects of DDT), and + -- it is legal to declare another component for DDT with the same name. + -- + -- DDT inherits the primitive subprogram Op1 from DT at (C). Op1 returns + -- the component Y; for calls with an operand of type DDT, Op1 returns + -- the Y inherited from DT, not the new Y explicitly declared for DDT, + -- even though the inherited Y is not visible for any view of DDT. + -- + -- Within the body of Op2, the assignment statement at (D) updates the + -- Y explicitly declared for DDT. At (E) and (F), however, a view + -- conversion denotes a new view of P as an object of type DT, which + -- enables access to the Y from the full view of DT. Thus, the + -- assignment statements at (E) and (F) update the (invisible) Y from DT. + -- + -- Note that the above analysis would be wrong if the new component Y + -- were declared directly in Child. In that case, the two same-named + -- components would be illegal -- see AI-150. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 1994 SAIC ACVC 2.0 + -- 29 JUN 1999 RAD Declare same-named component in an + -- unrelated package -- see AI-150. + -- + --! + + package C730003_0 is + + type Suit_Kind is (Clubs, Diamonds, Hearts, Spades); + type Face_Kind is (Up, Down); + + type Playing_Card is tagged record + Face: Face_Kind; + Suit: Suit_Kind; + end record; + + procedure Turn_Over_Card (Card : in out Playing_Card); + + type Disp_Card is new Playing_Card with private; + + subtype ASCII_Representation is Natural range 1..14; + + function Get_Private_View (A_Card : Disp_Card) return ASCII_Representation; + + private + + type Disp_Card is new Playing_Card with record + View: ASCII_Representation; -- (A) + end record; + + end C730003_0; + + --==================================================================-- + + package body C730003_0 is + + procedure Turn_Over_Card (Card: in out Playing_Card) is + begin + Card.Face := Up; + end Turn_Over_Card; + + function Get_Private_View (A_Card : Disp_Card) + return ASCII_Representation is + begin + return A_Card.View; + end Get_Private_View; + + end C730003_0; + + --==================================================================-- + + with C730003_0; use C730003_0; + package C730003_1 is + + subtype Graphic_Representation is String (1 .. 2); + + type Graphic_Card is new Disp_Card with record + View : Graphic_Representation; -- (B) + -- "Duplicate" component field name. + end record; + + end C730003_1; + + --==================================================================-- + + with C730003_1; use C730003_1; + package C730003_0.C730003_2 is + + Queen_Of_Spades : constant C730003_0.ASCII_Representation := 12; + Ace_Of_Hearts : constant String := "AH"; + Close_To_The_Vest : constant C730003_0.ASCII_Representation := 14; + Read_Em_And_Weep : constant String := "AA"; + + type Graphic_Card is new C730003_1.Graphic_Card with null record; + + -- Implicit function Get_Private_View -- (C) + -- (A_Card : Graphic_Card) return C730003_0.ASCII_Representation; + + function Get_View (Card : Graphic_Card) return String; + procedure Update_View (Card : in out Graphic_Card); + procedure Hide_From_View (Card : in out Graphic_Card); + + end C730003_0.C730003_2; + + --==================================================================-- + + package body C730003_0.C730003_2 is + + function Get_View (Card : Graphic_Card) return String is + begin + return Card.View; + end Get_View; + + procedure Update_View (Card : in out Graphic_Card) is + ASCII_View : Disp_Card renames Disp_Card(Card); -- View conversion. + begin + ASCII_View.View := Queen_Of_Spades; -- (F) + -- Assignment to "hidden" field. + Card.View := Ace_Of_Hearts; -- (D) + -- Assignment to Graphic_Card declared field. + end Update_View; + + procedure Hide_From_View (Card : in out Graphic_Card) is + begin + -- Update both of Card's View components. + Disp_Card(Card).View := Close_To_The_Vest; -- (E) + -- Assignment to "hidden" field. + Card.View := Read_Em_And_Weep; -- (D) + -- Assignment to Graphic_Card declared field. + end Hide_From_View; + + end C730003_0.C730003_2; + + --==================================================================-- + + with C730003_0; + with C730003_0.C730003_2; + with Report; + + procedure C730003 is + begin + + Report.Test ("C730003", "Check that the characteristics of a type " & + "derived from a private extension (outside " & + "the scope of the full view) are those " & + "defined by the partial view of the private " & + "extension"); + + Check_Your_Cards: + declare + use C730003_0; + use C730003_0.C730003_2; + + Top_Card_On_The_Deck : Graphic_Card; + + begin + + -- Update value in the components of the card. There are two + -- component fields named View, although one is not visible for + -- any view of a Graphic_Card. + + Update_View(Top_Card_On_The_Deck); + + -- Verify that both "View" components of the card have been updated. + + if Get_View(Top_Card_On_The_Deck) /= Ace_Of_Hearts then + Report.Failed ("Incorrect value in visible component - 1"); + end if; + + if Get_Private_View(Top_Card_On_The_Deck) /= Queen_Of_Spades + then + Report.Failed ("Incorrect value in non-visible component - 1"); + end if; + + -- Again, update the components of the card (to blank values). + + Hide_From_View(Top_Card_On_The_Deck); + + -- Verify that both components have been updated. + + if Get_View(Top_Card_On_The_Deck) /= Read_Em_And_Weep then + Report.Failed ("Incorrect value in visible component - 2"); + end if; + + if Get_Private_View(Top_Card_On_The_Deck) /= Close_To_The_Vest + then + Report.Failed ("Incorrect value in non-visible component - 2"); + end if; + + exception + when others => Report.Failed("Exception raised in test block"); + end Check_Your_Cards; + + Report.Result; + + end C730003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730004.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,327 ---- + -- C730004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a type declared in a package, descendants of the package + -- use the full view of type. Specifically check that full view of the + -- limited type is visible only in private descendants (children) and in + -- the private parts and bodies of public descendants (children). + -- Check that a limited type may be used as an out parameter outside + -- the package that defines the type. + -- + -- TEST DESCRIPTION: + -- This test defines a parent package containing limited private type + -- definitions. Children packages are defined (one public, one private) + -- that use the nonlimited full view of the types defined in the private + -- part of the parent specification. + -- The main declares a procedure with an out parameter that was defined + -- as limited in the specification of the parent package. + -- + -- + -- CHANGE HISTORY: + -- 15 Sep 95 SAIC Initial prerelease version. + -- 23 Apr 96 SAIC Added prefix for parameter in Call_Modify_File. + -- 02 Nov 96 SAIC ACVC 2.1: Modified prologue and Test.Report. + -- + --! + + package C730004_0 is + + -- Full views of File_Descriptor, File_Mode, File_Name, and File_Type are + -- are nonlimited. + + type File_Descriptor is limited private; + + type File_Mode is limited private; + + Active_Mode : constant File_Mode; + + type File_Name is limited private; + + type File_Type is limited private; + + function Next_Available_File return File_Descriptor; + + private + + type File_Descriptor is new Integer; + + Null_File : constant File_Descriptor := 0; + First_File : constant File_Descriptor := 1; + + type File_Mode is + (Read_Only, Write_Only, Read_Write, Archived, Corrupt, Lost); + + Default_Mode : constant File_Mode := Read_Only; + Active_Mode : constant File_Mode := Read_Write; + + type File_Name is array (1 .. 6) of Character; + + Null_String : File_Name := " "; + String1 : File_Name := "ACVC "; + String2 : File_Name := " 1995"; + + type File_Type is + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + Name : File_Name := Null_String; + end record; + + end C730004_0; + + --=================================================================-- + + package body C730004_0 is + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); -- Type conversion. + end Next_Available_File; + + end C730004_0; + + --=================================================================-- + + private + package C730004_0.C730004_1 is -- private child + + -- Since full view of the nontagged File_Name is nonlimited in the parent + -- package, it is not limited in the private child, so concatenation is + -- available. + + System_File_Name : constant File_Name + := String1(1..4) & String2(5..6); + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private child, so a default expression + -- is available. + + function New_File_Validated (File : File_Type + := (Descriptor => First_File, + Mode => Active_Mode, + Name => System_File_Name)) + return Boolean; + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private child, so initialization + -- expression in an object declaration is available. + + System_File : File_Type + := (Null_File, Read_Only, System_File_Name); + + + end C730004_0.C730004_1; + + --=================================================================-- + + package body C730004_0.C730004_1 is + + function New_File_Validated (File : File_Type + := (Descriptor => First_File, + Mode => Active_Mode, + Name => System_File_Name)) + return Boolean is + Result : Boolean := False; + begin + if (File.Descriptor > System_File.Descriptor) and + (File.Mode in Read_Only .. Read_Write) and (File.Name = "ACVC95") + then + Result := True; + end if; + + return (Result); + + end New_File_Validated; + + end C730004_0.C730004_1; + + --=================================================================-- + + package C730004_0.C730004_2 is -- public child + + -- File_Type is limited here. + + procedure Create_File (File : out File_Type); + + procedure Modify_File (File : out File_Type); + + type File_Dir is limited private; + + -- The following three validation functions provide the capability to + -- check the limited private types defined in the parent and the + -- private child package from within the client program. + + function Validate_Create (File : in File_Type) return Boolean; + + function Validate_Modification (File : in File_Type) + return Boolean; + + function Validate_Dir (Dir : in File_Dir) return Boolean; + + private + + -- Since full view of the nontagged File_Type is nonlimited in the parent + -- package, it is not limited in the private part of the public child, so + -- aggregates are available. + + Child_File : File_Type + := File_Type'(Descriptor => Null_File, + Mode => Write_Only, + Name => String2); + + -- Since full view of the nontagged component File_Type is nonlimited in + -- the parent package, it is not limited in the private part of the public + -- child, so default expressions are available. + + type File_Dir is + record + Comp : File_Type := Child_File; + end record; + + end C730004_0.C730004_2; + + --=================================================================-- + + with C730004_0.C730004_1; + + package body C730004_0.C730004_2 is + + procedure Create_File (File : out File_Type) is + New_File : File_Type; + + begin + New_File.Descriptor := Next_Available_File; + New_File.Mode := Default_Mode; + New_File.Name := C730004_0.C730004_1.System_File_Name; + + if C730004_0.C730004_1.New_File_Validated (New_File) then + File := New_File; + else + File := (Null_File, Lost, "MISSED"); + end if; + + end Create_File; + + -------------------------------------------------------------- + procedure Modify_File (File : out File_Type) is + begin + File.Descriptor := Next_Available_File; + File.Mode := Active_Mode; + File.Name := String1; + end Modify_File; + + -------------------------------------------------------------- + function Validate_Create (File : in File_Type) return Boolean is + begin + if ((File.Descriptor /= Child_File.Descriptor) and + (File.Mode = Read_Only) and (File.Name = "ACVC95")) + then + return True; + else + return False; + end if; + end Validate_Create; + + ------------------------------------------------------------------------ + function Validate_Modification (File : in File_Type) + return Boolean is + begin + if ((File.Descriptor /= C730004_0.C730004_1.System_File.Descriptor) and + (File.Mode = Read_Write) and (File.Name = "ACVC ")) + then + return True; + else + return False; + end if; + end Validate_Modification; + + ------------------------------------------------------------------------ + function Validate_Dir (Dir : in File_Dir) return Boolean is + begin + if ((Dir.Comp.Descriptor = C730004_0.C730004_1.System_File.Descriptor) + and (Dir.Comp.Mode = Write_Only) and (Dir.Comp.Name = String2)) + then + return True; + else + return False; + end if; + end Validate_Dir; + + end C730004_0.C730004_2; + + --=================================================================-- + + with C730004_0.C730004_2; + with Report; + + procedure C730004 is + + package File renames C730004_0; + package File_Ops renames C730004_0.C730004_2; + + Validation_File : File.File_Type; + + Validation_Dir : File_Ops.File_Dir; + + ------------------------------------------------------------------------ + -- Limited File_Type is allowed as an out parameter outside package File. + + procedure Call_Modify_File (Modified_File : out File.File_Type) is + begin + File_Ops.Modify_File (Modified_File); + end Call_Modify_File; + + begin + + Report.Test ("C730004", "Check that for a type declared in a package, " & + "descendants of the package use the full view " & + "of the type. Specifically check that full " & + "view of the limited type is visible only in " & + "private children and in the private parts and " & + "bodies of public children"); + + File_Ops.Create_File (Validation_File); + + if not File_Ops.Validate_Create (Validation_File) then + Report.Failed ("Incorrect creation of file"); + end if; + + Call_Modify_File (Validation_File); + + if not File_Ops.Validate_Modification (Validation_File) then + Report.Failed ("Incorrect modification of file"); + end if; + + if not File_Ops.Validate_Dir (Validation_Dir) then + Report.Failed ("Incorrect creation of directory"); + end if; + + Report.Result; + + end C730004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c73002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c73002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c73002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c73002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C73002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE STATEMENTS IN A PACKAGE BODY ARE EXECUTED AFTER THE + -- ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY). + + + -- RM 05/15/81 + -- JBG 9/21/83 + + WITH REPORT; + PROCEDURE C73002A IS + + USE REPORT; + + BEGIN + + TEST( "C73002A" , "CHECK: EXECUTION OF STATEMENTS IN A PACKAGE " & + "BODY FOLLOWS ELABORATION OF THE DECLARATIONS"); + + DECLARE + + PACKAGE P1 IS + + A : INTEGER := IDENT_INT(7); + + PACKAGE P2 IS + B : INTEGER := IDENT_INT(11); + END P2; + + END P1; + + + PACKAGE BODY P1 IS -- A AA B BB + + AA : INTEGER := IDENT_INT(7); -- 7 7 11 (11) + + PACKAGE BODY P2 IS + BB : INTEGER := IDENT_INT(11);-- 7 11 11 + BEGIN + + B := 2*B ; -- 7 7 22 11 + BB := 2*BB; -- 7 7 22 22 + A := 5*A ; -- 35 7 22 22 + AA := 2*AA; -- 35 14 22 22 + + IF BB /= 22 OR + AA /= 14 OR + A /= 35 OR + B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 1" ); + END IF; + + END P2; + + BEGIN + + A := A + 20; -- 55 14 22 22 + AA := AA + 20; -- 55 34 22 22 + + IF AA /= 34 OR + A /= 55 OR + P2.B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 2" ); + END IF; + + END P1; + + + USE P1; + USE P2; + + BEGIN + + IF A /= 55 OR + B /= 22 + THEN + FAILED( "ASSIGNED VALUES INCORRECT - 3" ); + END IF; + + END; + + + RESULT; + + + END C73002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730a01.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- C730A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a tagged type declared in a package specification + -- may be passed as a generic formal (tagged) private type to a generic + -- package declaration. Check that the formal type may be extended with + -- a private extension in the generic package. + -- + -- Check that, in the instance, the private extension inherits the + -- user-defined primitive subprograms of the tagged actual. + -- + -- TEST DESCRIPTION: + -- Declare a tagged type and an associated primitive subprogram in a + -- package specification (foundation code). Declare a generic package + -- which takes a tagged type as a formal parameter, and then extends + -- it with a private extension (foundation code). + -- + -- Instantiate the generic package with the tagged type from the first + -- package (the "generic" extension should now have inherited + -- the primitive subprogram of the tagged type from the first + -- package). + -- + -- In the main program, call the primitive subprogram inherited by the + -- "generic" extension, and verify the correctness of the components. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F730A000.A + -- F730A001.A + -- => C730A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with F730A001; -- Book definitions. + package C730A01_0 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + end C730A01_0; + + + --==================================================================-- + + + + + --==================================================================-- + + + -- Library-level instantiation. Actual parameter is tagged record. + + with F730A001; -- Book definitions. + with F730A000; -- Singly-linked list abstraction. + package C730A01_1 is new F730A000 (Parent_Type => F730A001.Book_Type); + + + --==================================================================-- + + + with Report; + + with F730A001; -- Book definitions. + with C730A01_0; -- Raw book data. + with C730A01_1; -- Instance. + + use F730A001; -- Primitive operations of Book_Type directly visible. + use C730A01_1; -- Operations inherited by Node_Type directly visible. + + procedure C730A01 is + + + List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C730A01_0.Data_List; + Head : in out Priv_Node_Ptr) is + + Book : Priv_Node_Type; -- Object of extended type. + Book_Ptr : Priv_Node_Ptr; + + begin + for I in C730A01_0.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call inherited + -- operation. + Book_Ptr := new Priv_Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + Book1_Ptr : Priv_Node_Ptr; + Book2_Ptr : Priv_Node_Ptr; + Book3_Ptr : Priv_Node_Ptr; + begin + Remove (List_Of_Books, Book1_Ptr); + Remove (List_Of_Books, Book2_Ptr); + Remove (List_Of_Books, Book3_Ptr); + return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited + Book1_Ptr.Author.all /= "Joyce, James" or -- components + Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still + Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible in + Book3_Ptr.Title.all /= "Wuthering Heights" or -- private + Book3_Ptr.Author.all /= "Bronte, Emily"); -- extension. + + end Bad_List_Contents; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C730A01", "Inheritance of primitive operations: private " & + "extension of formal tagged private type; actual is " & + "an ultimate ancestor type"); + + -- Create linked list using inherited operation: + Create_List (C730A01_0.Title_List, C730A01_0.Author_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operation"); + end if; + + Report.Result; + + end C730A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c730a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c730a02.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,252 ---- + -- C730A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private extension (declared in a package specification) of + -- a tagged type (declared in a different package specification) may be + -- passed as a generic formal (tagged) private type to a generic package + -- declaration. Check that the formal type may be further extended with a + -- private extension in the generic package. + -- + -- Check that the (visible) components inherited by the "generic" + -- extension are visible outside the generic package. + -- + -- Check that, in the instance, the private extension inherits the + -- user-defined primitive subprograms of the tagged actual, including + -- those inherited by the actual from its parent. + -- + -- TEST DESCRIPTION: + -- Declare a tagged type and an associated primitive subprogram in a + -- package specification (foundation code). Declare a private extension + -- of the tagged type and an associated primitive subprogram in a second + -- package specification. Declare a generic package which takes a tagged + -- type as a formal parameter, and then extends it with a private + -- extension (foundation code). + -- + -- Instantiate the generic package with the private extension from the + -- second package (the "generic" extension should now have inherited + -- the primitive subprograms of the private extension from the second + -- package). + -- + -- In the main program, call the primitive subprograms inherited by the + -- "generic" extension. There are two: (1) Create_Book, declared for + -- the root tagged type in the first package (inherited by the private + -- extension of the second package, and then in turn by the "generic" + -- extension), and (2) Update_Pages, declared for the private extension + -- in the second package. Verify the correctness of the components. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- F730A000.A + -- F730A001.A + -- => C730A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with F730A001; -- Book definitions. + package C730A02_0 is -- Extended book abstraction. + + + type Detailed_Book_Type is new F730A001.Book_Type -- Private ext. + with private; -- of root tagged + -- type. + + -- Inherits Create_Book from Book_Type. + + procedure Update_Pages (Book : in out Detailed_Book_Type; -- Primitive op. + Pages : in Natural); -- of extension. + + + -- The following function is needed to verify the value of the + -- extension's private component. It will be inherited by extensions + -- of Detailed_Book_Type. + + function Get_Pages (Book : in Detailed_Book_Type) return Natural; + + private + + type Detailed_Book_Type is new F730A001.Book_Type with record + Pages : Natural; + end record; + + end C730A02_0; + + + --==================================================================-- + + + package body C730A02_0 is + + + procedure Update_Pages (Book : in out Detailed_Book_Type; + Pages : in Natural) is + begin + Book.Pages := Pages; + end Update_Pages; + + + function Get_Pages (Book : in Detailed_Book_Type) return Natural is + begin + return (Book.Pages); + end Get_Pages; + + + end C730A02_0; + + + --==================================================================-- + + + with F730A001; -- Book definitions. + package C730A02_1 is -- Raw data to be used in creating book elements. + + + Book_Count : constant := 3; + + subtype Number_Of_Books is Integer range 1 .. Book_Count; + + type Data_List is array (Number_Of_Books) of F730A001.Text_Ptr; + type Page_Counts is array (Number_Of_Books) of Natural; + + Title_List : Data_List := (new String'("Wuthering Heights"), + new String'("Heart of Darkness"), + new String'("Ulysses")); + + Author_List : Data_List := (new String'("Bronte, Emily"), + new String'("Conrad, Joseph"), + new String'("Joyce, James")); + + Page_List : Page_Counts := (237, 215, 456); + + end C730A02_1; + + + -- No body for C730A02_1. + + + --==================================================================-- + + + -- Library-level instantiation. Actual parameter is private extension. + + with C730A02_0; -- Extended book abstraction. + with F730A000; -- Singly-linked list abstraction. + package C730A02_2 is new F730A000 + (Parent_Type => C730A02_0.Detailed_Book_Type); + + + --==================================================================-- + + + with Report; + + with C730A02_0; -- Extended book abstraction. + with C730A02_1; -- Raw book data. + with C730A02_2; -- Instance. + + use C730A02_0; -- Primitive operations of Detailed_Book_Type directly visible. + use C730A02_2; -- Operations inherited by Priv_Node_Type directly visible. + + procedure C730A02 is + + + List_Of_Books : Priv_Node_Ptr := null; -- Head of linked list of books. + + + --========================================================-- + + + procedure Create_List (Title, Author : in C730A02_1.Data_List; + Pages : in C730A02_1.Page_Counts; + Head : in out Priv_Node_Ptr) is + + Book : Priv_Node_Type; -- Object of extended type. + Book_Ptr : Priv_Node_Ptr; + + begin + for I in C730A02_1.Number_Of_Books loop + Create_Book (Title (I), Author (I), Book); -- Call twice-inherited + -- operation. + Update_Pages (Book, Pages (I)); -- Call inherited op. + Book_Ptr := new Priv_Node_Type'(Book); + Add (Book_Ptr, Head); + end loop; + end Create_List; + + + --========================================================-- + + + function Bad_List_Contents return Boolean is + Book1_Ptr : Priv_Node_Ptr; + Book2_Ptr : Priv_Node_Ptr; + Book3_Ptr : Priv_Node_Ptr; + begin + + Remove (List_Of_Books, Book1_Ptr); + Remove (List_Of_Books, Book2_Ptr); + Remove (List_Of_Books, Book3_Ptr); + + return (Book1_Ptr.Title.all /= "Ulysses" or -- Inherited + Book1_Ptr.Author.all /= "Joyce, James" or -- components + Book2_Ptr.Title.all /= "Heart of Darkness" or -- should still + Book2_Ptr.Author.all /= "Conrad, Joseph" or -- be visible + Book3_Ptr.Title.all /= "Wuthering Heights" or -- in private + Book3_Ptr.Author.all /= "Bronte, Emily" or -- "generic" + -- extension. + -- Call inherited operations using dereferenced pointers. + Get_Pages (Book1_Ptr.all) /= 456 or + Get_Pages (Book2_Ptr.all) /= 215 or + Get_Pages (Book3_Ptr.all) /= 237); + + end Bad_List_Contents; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C730A02", "Inheritance of primitive operations: private " & + "extension of formal tagged private type; actual is " & + "a private extension"); + + -- Create linked list using inherited operation: + Create_List (C730A02_1.Title_List, C730A02_1.Author_List, + C730A02_1.Page_List, List_Of_Books); + + -- Verify results: + if Bad_List_Contents then + Report.Failed ("Wrong values after call to inherited operations"); + end if; + + Report.Result; + + end C730A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c731001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c731001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c731001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c731001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,407 ---- + -- C731001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check that inherited operations can be overridden, even when they are + -- inherited in a body. + -- The test cases here are inspired by the AARM examples given in + -- the discussion of AARM-7.3.1(7.a-7.v). + -- This discussion was confirmed by AI95-00035. + -- + -- TEST DESCRIPTION + -- See AARM-7.3.1. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 23 SEP 1999 RLB Improved comments, renamed, issued. + -- 20 AUG 2001 RLB Corrected 'verbose' flag. + -- + --! + + with Report; use Report; pragma Elaborate_All(Report); + package C731001_1 is + pragma Elaborate_Body; + private + procedure Check_String(X, Y: String); + function Check_String(X, Y: String) return String; + -- This one is a function, so we can call it in package specs. + end C731001_1; + + package body C731001_1 is + + Verbose: Boolean := False; + + procedure Check_String(X, Y: String) is + begin + if Verbose then + Comment("""" & X & """ = """ & Y & """?"); + end if; + if X /= Y then + Failed("""" & X & """ should be """ & Y & """"); + end if; + end Check_String; + + function Check_String(X, Y: String) return String is + begin + Check_String(X, Y); + return X; + end Check_String; + + end C731001_1; + + private package C731001_1.Parent is + + procedure Call_Main; + + type Root is tagged null record; + subtype Renames_Root is Root; + subtype Root_Class is Renames_Root'Class; + function Make return Root; + function Op1(X: Root) return String; + function Call_Op2(X: Root'Class) return String; + private + function Op2(X: Root) return String; + end C731001_1.Parent; + + procedure C731001_1.Parent.Main; + + with C731001_1.Parent.Main; + package body C731001_1.Parent is + + procedure Call_Main is + begin + Main; + end Call_Main; + + function Make return Root is + Result: Root; + begin + return Result; + end Make; + + function Op1(X: Root) return String is + begin + return "Parent.Op1 body"; + end Op1; + + function Op2(X: Root) return String is + begin + return "Parent.Op2 body"; + end Op2; + + function Call_Op2(X: Root'Class) return String is + begin + return Op2(X); + end Call_Op2; + + begin + + Check_String(Op1(Root'(Make)), "Parent.Op1 body"); + Check_String(Op1(Root_Class(Root'(Make))), "Parent.Op1 body"); + + Check_String(Op2(Root'(Make)), "Parent.Op2 body"); + Check_String(Op2(Root_Class(Root'(Make))), "Parent.Op2 body"); + + end C731001_1.Parent; + + with C731001_1.Parent; use C731001_1.Parent; + private package C731001_1.Unrelated is + + type T2 is new Root with null record; + subtype T2_Class is T2'Class; + function Make return T2; + function Op2(X: T2) return String; + end C731001_1.Unrelated; + + with C731001_1.Parent; use C731001_1.Parent; + pragma Elaborate(C731001_1.Parent); + package body C731001_1.Unrelated is + + function Make return T2 is + Result: T2; + begin + return Result; + end Make; + + function Op2(X: T2) return String is + begin + return "Unrelated.Op2 body"; + end Op2; + begin + + Check_String(Op1(T2'(Make)), "Parent.Op1 body"); + Check_String(Op1(T2_Class(T2'(Make))), "Parent.Op1 body"); + Check_String(Op1(Root_Class(T2'(Make))), "Parent.Op1 body"); + + Check_String(Op2(T2'(Make)), "Unrelated.Op2 body"); + Check_String(Op2(T2_Class(T2'(Make))), "Unrelated.Op2 body"); + Check_String(Call_Op2(T2'(Make)), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Class(T2'(Make))), "Parent.Op2 body"); + Check_String(Call_Op2(Root_Class(T2'(Make))), "Parent.Op2 body"); + + end C731001_1.Unrelated; + + package C731001_1.Parent.Child is + pragma Elaborate_Body; + + type T3 is new Root with null record; + subtype T3_Class is T3'Class; + function Make return T3; + + T3_Obj: T3; + T3_Class_Obj: T3_Class := T3_Obj; + T3_Root_Class_Obj: Root_Class := T3_Obj; + + X3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + package Nested is + type T4 is new Root with null record; + subtype T4_Class is T4'Class; + function Make return T4; + + T4_Obj: T4; + T4_Class_Obj: T4_Class := T4_Obj; + T4_Root_Class_Obj: Root_Class := T4_Obj; + + X4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + private + + XX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end Nested; + + use Nested; + + XXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + private + + XX3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + XXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end C731001_1.Parent.Child; + + with C731001_1.Unrelated; use C731001_1.Unrelated; + pragma Elaborate(C731001_1.Unrelated); + package body C731001_1.Parent.Child is + + XXX3: constant String := + Check_String(Op1(T3_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T3_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + XXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + function Make return T3 is + Result: T3; + begin + return Result; + end Make; + + package body Nested is + function Make return T4 is + Result: T4; + begin + return Result; + end Make; + + XXXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end Nested; + + type T5 is new T2 with null record; + subtype T5_Class is T5'Class; + function Make return T5; + + function Make return T5 is + Result: T5; + begin + return Result; + end Make; + + XXXXXXX4: constant String := + Check_String(Op1(T4_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body") & + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body") & + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body") & + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body") & + + Check_String(Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + end C731001_1.Parent.Child; + + procedure C731001_1.Main; + + with C731001_1.Parent; + procedure C731001_1.Main is + begin + C731001_1.Parent.Call_Main; + end C731001_1.Main; + + with C731001_1.Parent.Child; + use C731001_1.Parent; + use C731001_1.Parent.Child; + use C731001_1.Parent.Child.Nested; + with C731001_1.Unrelated; use C731001_1.Unrelated; + procedure C731001_1.Parent.Main is + + Root_Obj: Root := Make; + Root_Class_Obj: Root_Class := Root'(Make); + + T2_Obj: T2 := Make; + T2_Class_Obj: T2_Class := T2_Obj; + T2_Root_Class_Obj: Root_Class := T2_Class_Obj; + + T3_Obj: T3 := Make; + T3_Class_Obj: T3_Class := T3_Obj; + T3_Root_Class_Obj: Root_Class := T3_Obj; + + T4_Obj: T4 := Make; + T4_Class_Obj: T4_Class := T4_Obj; + T4_Root_Class_Obj: Root_Class := T4_Obj; + + begin + Test("C731001_1", "Check that inherited operations can be overridden, even" + & " when they are inherited in a body"); + + Check_String(Op1(Root_Obj), "Parent.Op1 body"); + Check_String(Op1(Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(Root_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T2_Obj), "Parent.Op1 body"); + Check_String(Op1(T2_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T2_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Op2(T2_Obj), "Unrelated.Op2 body"); + Check_String(Op2(T2_Class_Obj), "Unrelated.Op2 body"); + Check_String(Call_Op2(T2_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T2_Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T3_Obj), "Parent.Op1 body"); + Check_String(Op1(T3_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T3_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(T3_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T3_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T3_Root_Class_Obj), "Parent.Op2 body"); + + Check_String(Op1(T4_Obj), "Parent.Op1 body"); + Check_String(Op1(T4_Class_Obj), "Parent.Op1 body"); + Check_String(Op1(T4_Root_Class_Obj), "Parent.Op1 body"); + + Check_String(Call_Op2(T4_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T4_Class_Obj), "Parent.Op2 body"); + Check_String(Call_Op2(T4_Root_Class_Obj), "Parent.Op2 body"); + + Result; + end C731001_1.Parent.Main; + + with C731001_1.Main; + procedure C731001 is + begin + C731001_1.Main; + end C731001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74004a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,375 ---- + -- C74004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OPERATIONS DEPENDING ON THE FULL DECLARATION OF A + -- PRIVATE TYPE ARE AVAILABLE WITHIN THE PACKAGE BODY. + + -- HISTORY: + -- BCB 04/05/88 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C74004A IS + + PACKAGE P IS + TYPE PR IS PRIVATE; + TYPE ARR1 IS LIMITED PRIVATE; + TYPE ARR2 IS PRIVATE; + TYPE REC (D : INTEGER) IS PRIVATE; + TYPE ACC IS PRIVATE; + TYPE TSK IS LIMITED PRIVATE; + TYPE FLT IS LIMITED PRIVATE; + TYPE FIX IS LIMITED PRIVATE; + + TASK TYPE T IS + ENTRY ONE(V : IN OUT INTEGER); + END T; + + PROCEDURE CHECK (V : ARR2); + PRIVATE + TYPE PR IS NEW INTEGER; + + TYPE ARR1 IS ARRAY(1..5) OF INTEGER; + + TYPE ARR2 IS ARRAY(1..5) OF BOOLEAN; + + TYPE REC (D : INTEGER) IS RECORD + COMP1 : INTEGER; + COMP2 : BOOLEAN; + END RECORD; + + TYPE ACC IS ACCESS INTEGER; + + TYPE TSK IS NEW T; + + TYPE FLT IS DIGITS 5; + + TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0; + END P; + + PACKAGE BODY P IS + X1, X2, X3 : PR; + BOOL : BOOLEAN := IDENT_BOOL(FALSE); + VAL : INTEGER := IDENT_INT(0); + FVAL : FLOAT := 0.0; + ST : STRING(1..2); + O1 : ARR1 := (1,2,3,4,5); + Y1 : ARR2 := (FALSE,TRUE,FALSE,TRUE,FALSE); + Y2 : ARR2 := (OTHERS => TRUE); + Y3 : ARR2 := (OTHERS => FALSE); + Z1 : REC(0) := (0,1,FALSE); + W1, W2 : ACC := NEW INTEGER'(0); + V1 : TSK; + + TASK BODY T IS + BEGIN + ACCEPT ONE(V : IN OUT INTEGER) DO + V := IDENT_INT(10); + END ONE; + END T; + + PROCEDURE CHECK (V : ARR2) IS + BEGIN + IF V /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER VALUE PASSED AS AGGREGATE"); + END IF; + END CHECK; + BEGIN + TEST ("C74004A", "CHECK THAT OPERATIONS DEPENDING ON THE " & + "FULL DECLARATION OF A PRIVATE TYPE ARE " & + "AVAILABLE WITHIN THE PACKAGE BODY"); + + X1 := 10; + X2 := 5; + + X3 := X1 + X2; + + IF X3 /= 15 THEN + FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR"); + END IF; + + X3 := X1 - X2; + + IF X3 /= 5 THEN + FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR"); + END IF; + + X3 := X1 * X2; + + IF X3 /= 50 THEN + FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR"); + END IF; + + X3 := X1 / X2; + + IF X3 /= 2 THEN + FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR"); + END IF; + + X3 := X1 ** 2; + + IF X3 /= 100 THEN + FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR"); + END IF; + + BOOL := X1 < X2; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR"); + END IF; + + BOOL := X1 > X2; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR"); + END IF; + + BOOL := X1 <= X2; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " & + "OPERATOR"); + END IF; + + BOOL := X1 >= X2; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " & + "TO OPERATOR"); + END IF; + + X3 := X1 MOD X2; + + IF X3 /= 0 THEN + FAILED ("IMPROPER RESULT FROM MOD OPERATOR"); + END IF; + + X3 := X1 REM X2; + + IF X3 /= 0 THEN + FAILED ("IMPROPER RESULT FROM REM OPERATOR"); + END IF; + + X3 := ABS(X1); + + IF X3 /= 10 THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 1"); + END IF; + + X1 := -10; + + X3 := ABS(X1); + + IF X3 /= 10 THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR - 2"); + END IF; + + X3 := PR'BASE'FIRST; + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'BASE'FIRST"); + END IF; + + X3 := PR'FIRST; + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'FIRST"); + END IF; + + VAL := PR'WIDTH; + + IF NOT EQUAL(VAL,INTEGER'WIDTH) THEN + FAILED ("IMPROPER RESULT FROM 'WIDTH"); + END IF; + + VAL := PR'POS(X3); + + IF NOT EQUAL(VAL,INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'POS"); + END IF; + + X3 := PR'VAL(VAL); + + IF X3 /= PR(INTEGER'FIRST) THEN + FAILED ("IMPROPER RESULT FROM 'VAL"); + END IF; + + X3 := PR'SUCC(X2); + + IF X3 /= 6 THEN + FAILED ("IMPROPER RESULT FROM 'SUCC"); + END IF; + + X3 := PR'PRED(X2); + + IF X3 /= 4 THEN + FAILED ("IMPROPER RESULT FROM 'PRED"); + END IF; + + ST := PR'IMAGE(X3); + + IF ST /= INTEGER'IMAGE(INTEGER(X3)) THEN + FAILED ("IMPROPER RESULT FROM 'IMAGE"); + END IF; + + X3 := PR'VALUE(ST); + + IF X3 /= PR(INTEGER'VALUE(ST)) THEN + FAILED ("IMPROPER RESULT FROM 'VALUE"); + END IF; + + CHECK ((TRUE,FALSE,TRUE,FALSE,TRUE)); + + IF O1(2) /= IDENT_INT(2) THEN + FAILED ("IMPROPER VALUE FROM INDEXING"); + END IF; + + IF O1(2..4) /= (2,3,4) THEN + FAILED ("IMPROPER VALUES FROM SLICING"); + END IF; + + IF VAL IN O1'RANGE THEN + FAILED ("IMPROPER RESULT FROM 'RANGE"); + END IF; + + VAL := O1'LENGTH; + + IF NOT EQUAL(VAL,5) THEN + FAILED ("IMPROPER RESULT FROM 'LENGTH"); + END IF; + + Y3 := Y1(1..2) & Y2(3..5); + + IF Y3 /= (FALSE,TRUE,TRUE,TRUE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM CATENATION"); + END IF; + + Y3 := NOT Y1; + + IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM NOT OPERATOR"); + END IF; + + Y3 := Y1 AND Y2; + + IF Y3 /= (FALSE,TRUE,FALSE,TRUE,FALSE) THEN + FAILED ("IMPROPER RESULT FROM AND OPERATOR"); + END IF; + + Y3 := Y1 OR Y2; + + IF Y3 /= (TRUE,TRUE,TRUE,TRUE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM OR OPERATOR"); + END IF; + + Y3 := Y1 XOR Y2; + + IF Y3 /= (TRUE,FALSE,TRUE,FALSE,TRUE) THEN + FAILED ("IMPROPER RESULT FROM XOR OPERATOR"); + END IF; + + VAL := Z1.COMP1; + + IF NOT EQUAL(VAL,1) THEN + FAILED ("IMPROPER RESULT FROM SELECTION OF RECORD " & + "COMPONENTS"); + END IF; + + W1 := NEW INTEGER'(0); + + IF NOT EQUAL(W1.ALL,0) THEN + FAILED ("IMPROPER RESULT FROM ALLOCATION"); + END IF; + + W1 := NULL; + + IF W1 /= NULL THEN + FAILED ("IMPROPER RESULT FROM NULL LITERAL"); + END IF; + + VAL := W2.ALL; + + IF NOT EQUAL(VAL,0) THEN + FAILED ("IMPROPER RESULT FROM SELECTED COMPONENT"); + END IF; + + BOOL := V1'CALLABLE; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM 'CALLABLE"); + END IF; + + BOOL := V1'TERMINATED; + + IF BOOL THEN + FAILED ("IMPROPER RESULT FROM 'TERMINATED"); + END IF; + + V1.ONE(VAL); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("IMPROPER RESULT RETURNED FROM ENTRY SELECTION"); + END IF; + + IF NOT (FLT(1.0) IN FLT) THEN + FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION"); + END IF; + + VAL := FLT'DIGITS; + + IF NOT EQUAL(VAL,5) THEN + FAILED ("IMPROPER RESULT FROM 'DIGITS"); + END IF; + + BOOL := FLT'MACHINE_ROUNDS; + + BOOL := FLT'MACHINE_OVERFLOWS; + + VAL := FLT'MACHINE_RADIX; + + VAL := FLT'MACHINE_MANTISSA; + + VAL := FLT'MACHINE_EMAX; + + VAL := FLT'MACHINE_EMIN; + + FVAL := FIX'DELTA; + + IF FVAL /= 2.0**(-1) THEN + FAILED ("IMPROPER RESULT FROM 'DELTA"); + END IF; + + VAL := FIX'FORE; + + VAL := FIX'AFT; + + END P; + + USE P; + + BEGIN + RESULT; + END C74004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74203a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,263 ---- + -- C74203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, AND EXPLICIT + -- CONVERSION ARE AVAILABLE FOR LIMITED AND NON-LIMITED PRIVATE + -- TYPES. INCLUDE TYPES WITH DISCRIMINANTS AND TYPES + -- WITH LIMITED COMPONENTS. + + -- HISTORY: + -- BCB 03/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74203A IS + + PACKAGE PP IS + TYPE LIM IS LIMITED PRIVATE; + PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER); + + TYPE A IS PRIVATE; + SUBTYPE SUBA IS A; + A1 : CONSTANT A; + + TYPE B IS LIMITED PRIVATE; + B1 : CONSTANT B; + + TYPE C IS PRIVATE; + C1 : CONSTANT C; + + TYPE D IS LIMITED PRIVATE; + D1 : CONSTANT D; + + TYPE E (DISC1 : INTEGER := 5) IS PRIVATE; + SUBTYPE SUBE IS E; + E1 : CONSTANT E; + + TYPE F (DISC2 : INTEGER := 15) IS LIMITED PRIVATE; + F1 : CONSTANT F; + + TYPE G (DISC3 : INTEGER) IS PRIVATE; + G1 : CONSTANT G; + + TYPE H (DISC4 : INTEGER) IS LIMITED PRIVATE; + H1 : CONSTANT H; + + TYPE I IS RECORD + COMPI : LIM; + END RECORD; + SUBTYPE SUBI IS I; + + TYPE J IS ARRAY(1..5) OF LIM; + SUBTYPE SUBJ IS J; + + TYPE S1 IS (VINCE, TOM, PHIL, JODIE, ROSA, TERESA); + TYPE S2 IS (THIS, THAT, THESE, THOSE, THEM); + TYPE S3 IS RANGE 1 .. 100; + TYPE S4 IS RANGE 1 .. 100; + PRIVATE + TYPE LIM IS RANGE 1 .. 100; + + TYPE A IS (RED, BLUE, GREEN, YELLOW, BLACK, WHITE); + A1 : CONSTANT A := BLUE; + + TYPE B IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + B1 : CONSTANT B := THREE; + + TYPE C IS RANGE 1 .. 100; + C1 : CONSTANT C := 50; + + TYPE D IS RANGE 1 .. 100; + D1 : CONSTANT D := 50; + + TYPE E (DISC1 : INTEGER := 5) IS RECORD + COMPE : S1; + END RECORD; + E1 : CONSTANT E := (DISC1 => 5, COMPE => TOM); + + TYPE F (DISC2 : INTEGER := 15) IS RECORD + COMPF : S2; + END RECORD; + F1 : CONSTANT F := (DISC2 => 15, COMPF => THAT); + + TYPE G (DISC3 : INTEGER) IS RECORD + COMPG : S3; + END RECORD; + G1 : CONSTANT G := (DISC3 => 25, COMPG => 50); + + TYPE H (DISC4 : INTEGER) IS RECORD + COMPH : S4; + END RECORD; + H1 : CONSTANT H := (DISC4 => 30, COMPH => 50); + END PP; + + USE PP; + + AVAR : SUBA := A1; + EVAR : SUBE := E1; + + IVAR : SUBI; + JVAR : SUBJ; + + PACKAGE BODY PP IS + PROCEDURE INIT (Z1 : OUT LIM; Z2 : INTEGER) IS + BEGIN + Z1 := LIM (Z2); + END INIT; + BEGIN + NULL; + END PP; + + PROCEDURE QUAL_PRIV (W : A) IS + BEGIN + NULL; + END QUAL_PRIV; + + PROCEDURE QUAL_LIM_PRIV (X : B) IS + BEGIN + NULL; + END QUAL_LIM_PRIV; + + PROCEDURE EXPL_CONV_PRIV_1 (Y : C) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_1; + + PROCEDURE EXPL_CONV_LIM_PRIV_1 (Z : D) IS + BEGIN + NULL; + END EXPL_CONV_LIM_PRIV_1; + + PROCEDURE EXPL_CONV_PRIV_2 (Y2 : G) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_2; + + PROCEDURE EXPL_CONV_LIM_PRIV_2 (Z2 : H) IS + BEGIN + NULL; + END EXPL_CONV_LIM_PRIV_2; + + PROCEDURE EXPL_CONV_PRIV_3 (Y3 : I) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_3; + + PROCEDURE EXPL_CONV_PRIV_4 (Y4 : J) IS + BEGIN + NULL; + END EXPL_CONV_PRIV_4; + + BEGIN + TEST ("C74203A", "CHECK THAT MEMBERSHIP TESTS, QUALIFICATION, " & + "AND EXPLICIT CONVERSION ARE AVAILABLE FOR " & + "LIMITED AND NON-LIMITED PRIVATE TYPES. " & + "INCLUDE TYPES WITH DISCRIMINANTS AND " & + "TYPES WITH LIMITED COMPONENTS"); + + INIT (IVAR.COMPI, 50); + + FOR K IN IDENT_INT (1) .. IDENT_INT (5) LOOP + INIT (JVAR(K), 25); + END LOOP; + + IF NOT (AVAR IN A) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 1"); + END IF; + + IF (AVAR NOT IN A) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 1"); + END IF; + + IF NOT (B1 IN B) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "LIMITED PRIVATE TYPE - 1"); + END IF; + + IF (B1 NOT IN B) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "LIMITED PRIVATE TYPE - 1"); + END IF; + + QUAL_PRIV (A'(AVAR)); + + QUAL_LIM_PRIV (B'(B1)); + + EXPL_CONV_PRIV_1 (C(C1)); + + EXPL_CONV_LIM_PRIV_1 (D(D1)); + + IF NOT (EVAR IN E) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 2"); + END IF; + + IF (EVAR NOT IN E) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 2"); + END IF; + + IF NOT (F1 IN F) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "LIMITED PRIVATE TYPE - 2"); + END IF; + + IF (F1 NOT IN F) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "LIMITED PRIVATE TYPE - 2"); + END IF; + + EXPL_CONV_PRIV_2 (G(G1)); + + EXPL_CONV_LIM_PRIV_2 (H(H1)); + + IF NOT (IVAR IN I) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 3"); + END IF; + + IF (IVAR NOT IN I) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 3"); + END IF; + + EXPL_CONV_PRIV_3 (I(IVAR)); + + IF NOT (JVAR IN J) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'IN' FOR " & + "PRIVATE TYPE - 4"); + END IF; + + IF (JVAR NOT IN J) THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST 'NOT IN' FOR " & + "PRIVATE TYPE - 4"); + END IF; + + EXPL_CONV_PRIV_4 (J(JVAR)); + + RESULT; + END C74203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74206a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- C74206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE PACKAGE AS A + -- PRIVATE TYPE AND CONTAINS A COMPONENT OF THE PRIVATE TYPE, OPERATIONS + -- OF THE COMPOSITE TYPE WHICH DO NOT DEPEND ON CHARACTERISTICS OF THE + -- PRIVATE TYPE ARE AVAILABLE AFTER THE FULL DECLARATION OF THE PRIVATE + -- TYPE, BUT BEFORE THE EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE + -- DECLARATION OF THE COMPOSITE TYPE THAT IS AFTER THE FULL DECLARATION + -- OF THE PRIVATE TYPE. IN PARTICULAR, CHECK FOR THE FOLLOWING : + + -- 'FIRST, 'LAST, 'RANGE, AND 'LENGTH FOR ARRAY TYPES + -- SELECTED COMPONENTS FOR DISCRIMINANTS AND COMPONENTS OF RECORDS + -- INDEXED COMPONENTS AND SLICES FOR ARRAYS + + -- DSJ 5/5/83 + -- JBG 3/8/84 + + WITH REPORT; + PROCEDURE C74206A IS + + USE REPORT; + + BEGIN + + TEST("C74206A", "CHECK THAT ADDITIONAL OPERATIONS FOR " + & "COMPOSITE TYPES OF PRIVATE TYPES ARE " + & "AVAILABLE AT THE EARLIEST PLACE AFTER THE " + & "FULL DECLARATION OF THE PRIVATE TYPE EVEN " + & "IF BEFORE THE EARLIEST PLACE WITHIN THE " + & "IMMEDIATE SCOPE OF THE COMPOSITE TYPE"); + + DECLARE + + PACKAGE PACK1 IS + TYPE P1 IS PRIVATE; + TYPE LP1 IS LIMITED PRIVATE; + + PACKAGE PACK_LP IS + TYPE LP_ARR IS ARRAY (1 .. 2) OF LP1; + TYPE LP_REC (D : INTEGER) IS + RECORD + C1, C2 : LP1; + END RECORD; + END PACK_LP; + + PACKAGE PACK2 IS + TYPE ARR IS ARRAY ( 1 .. 2 ) OF P1; + TYPE REC (D : INTEGER) IS + RECORD + C1, C2 : P1; + END RECORD; + END PACK2; + PRIVATE + TYPE P1 IS NEW BOOLEAN; + TYPE LP1 IS NEW BOOLEAN; + END PACK1; + + PACKAGE BODY PACK1 IS + + USE PACK_LP; + USE PACK2; + + A1 : ARR; + L1 : LP_ARR; + + N1 : INTEGER := ARR'FIRST; -- LEGAL + N2 : INTEGER := ARR'LAST; -- LEGAL + N3 : INTEGER := A1'LENGTH; -- LEGAL + N4 : INTEGER := LP_ARR'FIRST; -- LEGAL + N5 : INTEGER := LP_ARR'LAST; -- LEGAL + N6 : INTEGER := L1'LENGTH; -- LEGAL + B1 : BOOLEAN := 1 IN ARR'RANGE; -- LEGAL + B2 : BOOLEAN := 5 IN LP_ARR'RANGE; -- LEGAL + + N7 : INTEGER := A1(1)'SIZE; -- LEGAL: A1(1) + N8 : INTEGER := L1(2)'SIZE; -- LEGAL: L1(2) + + R1 : REC(1); + Q1 : LP_REC(1); + + K1 : INTEGER := R1.D'SIZE; -- LEGAL: R1.D + K2 : INTEGER := R1.C1'SIZE; -- LEGAL: R1.C1 + K3 : INTEGER := Q1.D'SIZE; -- LEGAL: Q1.D + K4 : INTEGER := Q1.C2'SIZE; -- LEGAL: Q1.C2 + + BEGIN + + IF N1 /= 1 OR N4 /= 1 THEN + FAILED ("WRONG VALUE FOR 'FIRST"); + END IF; + + IF N2 /= 2 OR N5 /= 2 THEN + FAILED ("WRONG VALUE FOR 'LAST"); + END IF; + + IF N3 /= 2 OR N6 /= 2 THEN + FAILED ("WRONG VALUE FOR 'LENGTH"); + END IF; + + IF B1 /= TRUE OR B2 /= FALSE THEN + FAILED ("INCORRECT RANGE TEST"); + END IF; + + IF N7 /= N8 THEN + FAILED ("INCORRECT INDEXED COMPONENTS"); + END IF; + + IF K1 /= K3 OR K2 /= K4 THEN + FAILED ("INCORRECT COMPONENT SELECTION"); + END IF; + + END PACK1; + + BEGIN + + NULL; + + END; + + RESULT; + + END C74206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74207b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74207b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74207b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74207b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C74207B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'CONSTRAINED CAN BE APPLIED AFTER THE FULL DECLARATION OF + -- A PRIVATE TYPE THAT IS DERIVED FROM A PRIVATE TYPE. + + -- BHS 6/18/84 + + WITH REPORT; + USE REPORT; + PROCEDURE C74207B IS + BEGIN + TEST ("C74207B", "AFTER THE FULL DECLARATION OF A PRIVATE " & + "TYPE DERIVED FROM A PRIVATE TYPE, " & + "'CONSTRAINED MAY BE APPLIED"); + + DECLARE + PACKAGE P1 IS + TYPE PREC (D : INTEGER) IS PRIVATE; + TYPE P IS PRIVATE; + PRIVATE + TYPE PREC (D : INTEGER) IS RECORD + NULL; + END RECORD; + TYPE P IS NEW INTEGER; + END P1; + + PACKAGE P2 IS + TYPE LP1 IS LIMITED PRIVATE; + TYPE LP2 IS LIMITED PRIVATE; + PRIVATE + TYPE LP1 IS NEW P1.PREC(3); + TYPE LP2 IS NEW P1.P; + B1 : BOOLEAN := LP1'CONSTRAINED; + B2 : BOOLEAN := LP2'CONSTRAINED; + END P2; + + PACKAGE BODY P2 IS + BEGIN + IF NOT IDENT_BOOL(B1) THEN + FAILED ("WRONG VALUE FOR LP1'CONSTRAINED"); + END IF; + IF NOT IDENT_BOOL(B2) THEN + FAILED ("WRONG VALUE FOR LP2'CONSTRAINED"); + END IF; + END P2; + + BEGIN + NULL; + END; + + RESULT; + + END C74207B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74208a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74208a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74208a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74208a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C74208A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'SIZE AND 'ADDRESS FOR OBJECTS OF LIMITED AND + -- NON-LIMITED TYPES ARE AVAILABLE BOTH INSIDE AND OUTSIDE THE + -- PACKAGE DECLARING THE TYPES. + + -- HISTORY: + -- BCB 03/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE C74208A IS + + PACKAGE P IS + TYPE T IS PRIVATE; + TYPE U IS LIMITED PRIVATE; + PRIVATE + TYPE T IS RANGE 1 .. 100; + TYPE U IS RANGE 1 .. 100; + END P; + + A : P.T; + B : P.U; + ASIZE, BSIZE : INTEGER; + AADDRESS, BADDRESS : ADDRESS; + + FUNCTION IDENT_ADR(X : ADDRESS) RETURN ADDRESS IS + Y : P.T; + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Y'ADDRESS; + END IDENT_ADR; + + PACKAGE BODY P IS + X : T; + Y : U; + XSIZE, YSIZE : INTEGER; + XADDRESS, YADDRESS : ADDRESS; + BEGIN + TEST ("C74208A", "CHECK THAT 'SIZE AND 'ADDRESS FOR " & + "OBJECTS OF LIMITED AND NON-LIMITED TYPES " & + "ARE AVAILABLE BOTH INSIDE AND OUTSIDE " & + "THE PACKAGE DECLARING THE TYPES"); + + XSIZE := X'SIZE; + YSIZE := Y'SIZE; + XADDRESS := X'ADDRESS; + YADDRESS := Y'ADDRESS; + + IF NOT EQUAL(XSIZE,X'SIZE) THEN + FAILED ("IMPROPER VALUE FOR X'SIZE"); + END IF; + + IF XADDRESS /= IDENT_ADR(X'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR X'ADDRESS"); + END IF; + + IF NOT EQUAL(YSIZE,Y'SIZE) THEN + FAILED ("IMPROPER VALUE FOR Y'SIZE"); + END IF; + + IF YADDRESS /= IDENT_ADR(Y'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR Y'ADDRESS"); + END IF; + END P; + + BEGIN + ASIZE := A'SIZE; + BSIZE := B'SIZE; + AADDRESS := A'ADDRESS; + BADDRESS := B'ADDRESS; + + IF NOT EQUAL(ASIZE,A'SIZE) THEN + FAILED ("IMPROPER VALUE FOR A'SIZE"); + END IF; + + IF AADDRESS /= IDENT_ADR(A'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR A'ADDRESS"); + END IF; + + IF NOT EQUAL(BSIZE,B'SIZE) THEN + FAILED ("IMPROPER VALUE FOR B'SIZE"); + END IF; + + IF BADDRESS /= IDENT_ADR(B'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR B'ADDRESS"); + END IF; + + RESULT; + END C74208A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74208b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74208b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74208b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74208b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C74208B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT 'CONSTRAINED FOR OBJECTS OF A PRIVATE TYPE WITH + -- VISIBLE DISCRIMINANTS IS AVAILABLE OUTSIDE THE PACKAGE DECLARING + -- THE TYPE AND IS AVAILABLE BEFORE AND AFTER THE FULL DECLARATION. + + -- HISTORY: + -- BCB 07/14/88 CREATED ORIGINAL TEST. + -- GJD 11/15/95 MOVED REC2_VAR OUT OF P DUE TO ADA 95 FREEZING RULES. + + WITH REPORT; USE REPORT; + + PROCEDURE C74208B IS + + PACKAGE P IS + TYPE REC (D : INTEGER := 0) IS PRIVATE; + R1 : CONSTANT REC; + TYPE REC2 IS RECORD + COMP : BOOLEAN := R1'CONSTRAINED; + END RECORD; + PRIVATE + TYPE REC (D : INTEGER := 0) IS RECORD + NULL; + END RECORD; + R1 : CONSTANT REC := (D => 5); + R2 : REC := (D => 0); + R2A : REC(3); + R2CON : CONSTANT REC := (D => 3); + C : BOOLEAN := R2'CONSTRAINED; + D : BOOLEAN := R2A'CONSTRAINED; + E : BOOLEAN := R2CON'CONSTRAINED; + END P; + + REC2_VAR : P.REC2; + + R3 : P.REC(0); + R3A : P.REC; + + A : BOOLEAN := R3'CONSTRAINED; + B : BOOLEAN := R3A'CONSTRAINED; + + PACKAGE BODY P IS + BEGIN + TEST ("C74208B", "CHECK THAT 'CONSTRAINED FOR OBJECTS OF A " & + "PRIVATE TYPE WITH VISIBLE DISCRIMINANTS " & + "IS AVAILABLE OUTSIDE THE PACKAGE " & + "DECLARING THE TYPE AND IS AVAILABLE " & + "BEFORE AND AFTER THE FULL DECLARATION"); + + IF NOT REC2_VAR.COMP THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED BEFORE THE " & + "FULL DECLARATION OF THE PRIVATE TYPE"); + END IF; + + IF C THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 1"); + END IF; + + IF NOT D THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 2"); + END IF; + + IF NOT E THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED AFTER THE " & + "FULL DECLARATION OF THE PRIVATE TYPE - 3"); + END IF; + END P; + + BEGIN + IF NOT A THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " & + "PACKAGE DECLARING THE PRIVATE TYPE - 1"); + END IF; + + IF B THEN + FAILED ("IMPROPER VALUE FOR 'CONSTRAINED OUTSIDE THE " & + "PACKAGE DECLARING THE PRIVATE TYPE - 2"); + END IF; + + RESULT; + END C74208B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74209a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74209a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74209a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74209a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- C74209A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OUTSIDE A PACKAGE WHICH DEFINES PRIVATE TYPES AND LIMITED + -- PRIVATE TYPES IT IS POSSIBLE TO DECLARE SUBPROGRAMS WHICH USE + -- THOSE TYPES AS TYPES FOR PARAMETERS (OF ANY MODE EXCEPT OUT FOR A + -- LIMITED TYPE) OR AS THE TYPE FOR THE RESULT (FOR FUNCTION + -- SUBPROGRAMS). + + -- RM 07/14/81 + + + WITH REPORT; + PROCEDURE C74209A IS + + USE REPORT; + + BEGIN + + TEST( "C74209A" , "CHECK THAT PROCEDURE SIGNATURES CAN USE " & + "PRIVATE TYPES" ); + + DECLARE + + PACKAGE PACK IS + + TYPE LIM_PRIV IS LIMITED PRIVATE; + TYPE PRIV IS PRIVATE; + PRIV_CONST_IN : CONSTANT PRIV; + PRIV_CONST_OUT : CONSTANT PRIV; + FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV; + FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN ; + PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV ); + + PRIVATE + + TYPE LIM_PRIV IS NEW INTEGER; + TYPE PRIV IS NEW STRING( 1..5 ); + PRIV_CONST_IN : CONSTANT PRIV := "ABCDE"; + PRIV_CONST_OUT : CONSTANT PRIV := "FGHIJ"; + + END PACK; + + + PRIV_VAR_1 , PRIV_VAR_2 : PACK.PRIV; + LIM_PRIV_VAR_1 , LIM_PRIV_VAR_2 : PACK.LIM_PRIV; + + + USE PACK; + + + PACKAGE BODY PACK IS + + FUNCTION PACKAGED( X: IN INTEGER ) RETURN LIM_PRIV IS + BEGIN + RETURN LIM_PRIV(X); + END PACKAGED; + + FUNCTION EQUALS( X , Y : LIM_PRIV ) RETURN BOOLEAN IS + BEGIN + RETURN X = Y ; + END EQUALS; + + PROCEDURE ASSIGN( X : IN LIM_PRIV; Y : OUT LIM_PRIV) IS + BEGIN + Y := X; + END ASSIGN; + + END PACK; + + + PROCEDURE PROC1( X : IN OUT PACK.PRIV; + Y : IN PACK.PRIV := PACK.PRIV_CONST_IN; + Z : OUT PACK.PRIV; + U : PACK.PRIV ) IS + BEGIN + + IF X /= PACK.PRIV_CONST_IN OR + Y /= PACK.PRIV_CONST_IN OR + U /= PACK.PRIV_CONST_IN + THEN + FAILED( "WRONG INPUT VALUES - PROC1" ); + END IF; + + X := PACK.PRIV_CONST_OUT; + Z := PACK.PRIV_CONST_OUT; + + END PROC1; + + + PROCEDURE PROC2( X : IN OUT LIM_PRIV; + Y : IN LIM_PRIV; + Z : IN OUT LIM_PRIV; + U : LIM_PRIV ) IS + BEGIN + + IF NOT(EQUALS( X , PACKAGED(17) )) OR + NOT(EQUALS( Y , PACKAGED(17) )) OR + NOT(EQUALS( U , PACKAGED(17) )) + THEN + FAILED( "WRONG INPUT VALUES - PROC2" ); + END IF; + + ASSIGN( PACKAGED(13) , X ); + ASSIGN( PACKAGED(13) , Z ); + + END PROC2; + + + FUNCTION FUNC1( Y : IN PRIV := PRIV_CONST_IN; + U : PRIV ) RETURN PRIV IS + BEGIN + + IF Y /= PRIV_CONST_IN OR + U /= PRIV_CONST_IN + THEN + FAILED( "WRONG INPUT VALUES - FUNC1" ); + END IF; + + RETURN PRIV_CONST_OUT; + + END FUNC1; + + + FUNCTION FUNC2( Y : IN LIM_PRIV; + U : LIM_PRIV ) RETURN LIM_PRIV IS + BEGIN + + IF NOT(EQUALS( Y , PACKAGED(17) )) OR + NOT(EQUALS( U , PACKAGED(17) )) + THEN + FAILED( "WRONG INPUT VALUES - FUNC2" ); + END IF; + + RETURN PACKAGED(13); + + END FUNC2; + + + BEGIN + + -------------------------------------------------------------- + + PRIV_VAR_1 := PRIV_CONST_IN; + PRIV_VAR_2 := PRIV_CONST_IN; + + PROC1( PRIV_VAR_1 , Z => PRIV_VAR_2 , U => PRIV_CONST_IN ); + + IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT OR + PRIV_VAR_2 /= PACK.PRIV_CONST_OUT + THEN + FAILED( "WRONG OUTPUT VALUES - PROC1" ); + END IF; + + -------------------------------------------------------------- + + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 ); + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 ); + + PROC2( LIM_PRIV_VAR_1 , PACKAGED(17) , + LIM_PRIV_VAR_2 , PACKAGED(17) ); + + IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) OR + NOT(EQUALS( LIM_PRIV_VAR_2 , PACKAGED(13) )) + THEN + FAILED( "WRONG OUTPUT VALUES - PROC2" ); + END IF; + + -------------------------------------------------------------- + + PRIV_VAR_1 := PRIV_CONST_IN; + PRIV_VAR_2 := PRIV_CONST_IN; + + PRIV_VAR_1 := + FUNC1( PRIV_VAR_1 , U => PRIV_CONST_IN ); + + IF PRIV_VAR_1 /= PACK.PRIV_CONST_OUT + THEN + FAILED( "WRONG OUTPUT VALUES - FUNC1" ); + END IF; + + -------------------------------------------------------------- + + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_1 ); + ASSIGN( PACKAGED(17) , LIM_PRIV_VAR_2 ); + + ASSIGN( FUNC2( LIM_PRIV_VAR_1 , PACKAGED(17)) , + LIM_PRIV_VAR_1 ); + + IF NOT(EQUALS( LIM_PRIV_VAR_1 , PACKAGED(13) )) + THEN + FAILED( "WRONG OUTPUT VALUES - FUNC2" ); + END IF; + + -------------------------------------------------------------- + + END; + + + RESULT; + + + END C74209A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74210a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74210a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74210a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74210a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C74210A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OPERATOR SYMBOLS OVERLOADED IN A PACKAGE ARE + -- USED AND DERIVED IN PREFERENCE TO THOSE OF THE PARENT OF A DERIVED + -- PRIVATE TYPE. + + -- CHECK THAT OPERATOR DEFINITIONS FOR A PRIVATE TYPE MAY BE + -- OVERLOADED OUTSIDE THE PACKAGE. + + -- CHECK THAT EQUALITY CAN BE DEFINED FOR LIMITED TYPES AND COMPOSITE + -- TYPES WITH LIMITED COMPONENTS. + + -- DAT 5/11/81 + + WITH REPORT; USE REPORT; + + PROCEDURE C74210A IS + BEGIN + TEST ("C74210A", "OVERLOADED OPERATORS FOR PRIVATE TYPES"); + + DECLARE + PACKAGE P IS + TYPE T IS PRIVATE; + FUNCTION "+" (X, Y : T) RETURN T; + ONE, TWO : CONSTANT T; + + TYPE L IS LIMITED PRIVATE; + TYPE A IS ARRAY (0 .. 0) OF L; + TYPE R IS RECORD + C : L; + END RECORD; + FUNCTION "=" (X, Y : L) RETURN BOOLEAN; + PRIVATE + TYPE T IS NEW INTEGER; + ONE : CONSTANT T := T(IDENT_INT(1)); + TWO : CONSTANT T := T(IDENT_INT(2)); + TYPE L IS (ENUM); + END P; + USE P; + + VR : R; + VA : A; + + PACKAGE BODY P IS + FUNCTION "+" (X, Y : T) RETURN T IS + BEGIN + RETURN 1; + END "+"; + + FUNCTION "=" (X, Y : L) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END "="; + BEGIN + VR := (C => ENUM); + VA := (0 => VR.C); + END P; + BEGIN + IF ONE + TWO /= ONE THEN + FAILED ("WRONG ""+"" OPERATOR"); + END IF; + + DECLARE + TYPE NEW_T IS NEW T; + + FUNCTION "=" (X, Y : A) RETURN BOOLEAN; + FUNCTION "=" (X, Y : R) RETURN BOOLEAN; + + FUNCTION "+" (X, Y : T) RETURN T IS + BEGIN + RETURN TWO; + END "+"; + + FUNCTION "=" (X, Y : A) RETURN BOOLEAN IS + BEGIN + RETURN X(0) = Y(0); + END "="; + + FUNCTION "=" (X, Y : R) RETURN BOOLEAN IS + BEGIN + RETURN X.C = Y.C; + END "="; + BEGIN + IF ONE + TWO /= TWO THEN + FAILED ("WRONG DERIVED ""+"" OPERATOR"); + END IF; + + IF VR = VR OR VA = VA THEN + FAILED ("CANNOT OVERLOAD ""="" CORRECTLY"); + END IF; + END; + END; + + RESULT; + END C74210A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74211a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74211a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74211a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74211a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C74211A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WITHIN THE PACKAGE SPECIFICATION AND BODY, ANY EXPLICIT + -- DECLARATIONS OF OPERATORS AND SUBPROGRAMS HIDE ANY OPERATIONS WHICH + -- ARE IMPLICITLY DECLARED AT THE POINT OF THE FULL DECLARATION, + -- REGARDLESS OF THE ORDER OF OCCURENCE OF THE DECLARATIONS. + + -- CHECK THAT IMPLICITLY DECLARED DERIVED SUBPROGRAMS HIDE IMPLICITLY + -- DECLARED PREDEFINED OPERATORS, REGARDLESS OF THE ORDER OF OCCURENCE + -- OF THE DECLARATIONS. + + -- DSJ 4/28/83 + -- JBG 9/23/83 + + -- A) EXPLICIT DECLARATION HIDES LATER IMPLICIT DECL OF PREDEFINED OP. + -- B) " " " LATER " " " DERIVED OP. + -- C) " " " EARLIER " " " PREDEFINED OP. + -- D) " " " EARLIER " " " DERIVED OP. + + WITH REPORT; + PROCEDURE C74211A IS + + USE REPORT; + + BEGIN + + TEST ("C74211A", "CHECK THAT HIDING OF IMPLICITLY DECLARED " & + "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " & + "CORRECTLY REGARDLESS OF ORDER OF DECL'S"); + + DECLARE + + PACKAGE P1 IS + TYPE T1 IS RANGE 1 .. 50; + C1 : CONSTANT T1 := T1(IDENT_INT(2)); + D1 : CONSTANT T1 := C1 + C1; -- PREDEFINED "+" + FUNCTION "+" (L, R : T1) RETURN T1; -- C) FOR "+". + FUNCTION "-" (L, R : T1) RETURN T1; -- C) FOR "-". + FUNCTION "/" (L, R : T1) RETURN T1; + END P1; + + USE P1; + + PACKAGE BODY P1 IS + A,B : T1 := 3; + + FUNCTION "+" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN 1; + ELSE RETURN 2; + END IF; + END "+"; + + FUNCTION "-" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN 3; + ELSE RETURN 4; + END IF; + END "-"; + + FUNCTION "/" (L, R : T1) RETURN T1 IS + BEGIN + IF L = R THEN + RETURN T1(IDENT_INT(INTEGER(L))); + ELSE + RETURN T1(IDENT_INT(50)); + END IF; + END "/"; + + BEGIN + IF D1 /= 4 THEN + FAILED ("WRONG PREDEFINED OPERATION - '+' "); + END IF; + + IF D1 + C1 /= 2 THEN + FAILED ("IMPLICIT '+' NOT HIDDEN BY EXPLICIT '+'"); + END IF; + + IF A + B /= 1 THEN + FAILED ("IMPLICIT DECLARATION NOT HIDDEN " & + "BY EXPLICIT DECLARATION - '+' "); + END IF; + + IF A - B /= 3 THEN + FAILED ("IMPLICIT DECLARATION NOT HIDDEN " & + "BY EXPLICIT DECLARATION - '-' "); + END IF; + + IF A * B /= 9 THEN + FAILED ("WRONG PREDEFINED OPERATION - '*' "); + END IF; + + IF B / A /= T1(IDENT_INT(3)) THEN + FAILED ("NOT REDEFINED '/' "); + END IF; + END P1; + + PACKAGE P2 IS + TYPE T2 IS PRIVATE; + X , Y : CONSTANT T2; + FUNCTION "+" (L, R : T2) RETURN T2; -- B) + FUNCTION "*" (L, R : T2) RETURN T2; -- A) + PRIVATE + TYPE T2 IS NEW T1; -- B) +; A) * + Z : T2 := T2(IDENT_INT(3))/4; -- Z = 50 USING + -- DERIVED / + FUNCTION "/" (L, R : T2) RETURN T2; -- D) FOR / + X , Y : CONSTANT T2 := 3; + END P2; + + PACKAGE BODY P2 IS + FUNCTION "+" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(5)); + ELSE RETURN T2(IDENT_INT(6)); + END IF; + END "+"; + + FUNCTION "*" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(7)); + ELSE RETURN T2(IDENT_INT(8)); + END IF; + END "*"; + + FUNCTION "/" (L, R : T2) RETURN T2 IS + BEGIN + IF L = R THEN + RETURN T2(IDENT_INT(9)); + ELSE RETURN T2(IDENT_INT(10)); + END IF; + END "/"; + BEGIN + IF X + Y /= 5 THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '+' "); + END IF; + + IF Y - X /= 3 THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '-' "); + END IF; + + IF X * Y /= 7 THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '*' "); + END IF; + + IF Y / X /= T2(IDENT_INT(9)) THEN + FAILED ("DERIVED OPERATOR NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '/' "); + END IF; + + IF Z /= 50 THEN + FAILED ("DERIVED OPERATOR HIDDEN PREMATURELY " & + " BY REDECLARED OPERATOR"); + END IF; + + END P2; + + BEGIN + + NULL; + + END; + + RESULT; + + END C74211A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74211b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74211b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74211b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74211b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C74211B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IMPLICITLY DECLARED INEQUALITY WHICH ACCOMPANIES AN + -- EXPLICIT DECLARATION OF EQUALITY HIDES OTHER IMPLICITLY DECLARED + -- HOMOGRAPHS, AND THAT DERIVED INEQUALITY HIDES PREDEFINED INEQUALITY. + + -- DSJ 4/29/83 + -- JBG 9/23/83 + + WITH REPORT; + PROCEDURE C74211B IS + + USE REPORT; + + BEGIN + + TEST( "C74211B", "CHECK THAT HIDING OF IMPLICITLY DECLARED " & + "OPERATORS AND DERIVED SUBPROGRAMS IS DONE " & + "CORRECTLY REGARDLESS OF ORDER OF DECL'S"); + + DECLARE + + PACKAGE P1 IS + TYPE LT1 IS LIMITED PRIVATE; + FUNCTION "="(L, R : LT1) RETURN BOOLEAN; + FUNCTION LT1_VALUE_2 RETURN LT1; + FUNCTION LT1_VALUE_4 RETURN LT1; + TYPE LT2 IS LIMITED PRIVATE; + PRIVATE + TYPE LT1 IS RANGE 1 .. 10; + TYPE LT2 IS RANGE 1 .. 10; + END P1; + + USE P1; + + PACKAGE P2 IS + TYPE LT3 IS LIMITED PRIVATE; + TYPE LT4 IS NEW LT1; + PRIVATE + FUNCTION "=" (L, R : LT3) RETURN BOOLEAN; + TYPE LT3 IS NEW LT1; + END P2; + + USE P2; + + PACKAGE BODY P1 IS + A , B : CONSTANT LT1 := 4; + C , D : CONSTANT LT2 := 6; + + FUNCTION "=" (L, R : LT1) RETURN BOOLEAN IS + BEGIN + RETURN INTEGER(L) /= INTEGER(R); + END "="; + + FUNCTION LT1_VALUE_2 RETURN LT1 IS + BEGIN + RETURN 2; + END LT1_VALUE_2; + + FUNCTION LT1_VALUE_4 RETURN LT1 IS + BEGIN + RETURN 4; + END LT1_VALUE_4; + + BEGIN + IF A = B THEN + FAILED ("PREDEFINED EQUALITY NOT HIDDEN BY " & + "EXPLICIT DECLARATION - LT1"); + END IF; + + IF C /= D THEN + FAILED ("WRONG PREDEFINED OPERATION - T2"); + END IF; + END P1; + + PACKAGE BODY P2 IS + FUNCTION U RETURN LT3 IS + BEGIN + RETURN LT1_VALUE_2; + END U; + + FUNCTION V RETURN LT3 IS + BEGIN + RETURN LT1_VALUE_4; + END V; + + FUNCTION W RETURN LT4 IS + BEGIN + RETURN LT1_VALUE_2; + END W; + + FUNCTION X RETURN LT4 IS + BEGIN + RETURN LT1_VALUE_4; + END X; + + FUNCTION "=" (L, R : LT3) RETURN BOOLEAN IS + BEGIN + RETURN NOT (LT1(L) = LT1(R)); + END "="; + + BEGIN + IF NOT (U /= V) THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "IMPLICITLY DECLARED INEQUALITY " & + "FROM EXPLICITLY DECLARED EQUALITY"); + END IF; + + IF NOT (LT3(W) = U) THEN + FAILED ("DERIVED SUBPROGRAM NOT HIDDEN BY " & + "EXPLICIT DECLARATION - '=' "); + END IF; + + IF W /= X THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '/=' "); + END IF; + + IF NOT ( X = W ) THEN + FAILED ("PREDEFINED OPERATOR NOT HIDDEN BY " & + "DERIVED SUBPROGRAM - '=' "); + END IF; + + END P2; + + BEGIN + + NULL; + + END; + + RESULT; + + END C74211B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74302a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74302a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74302a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74302a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C74302A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR DEFERRED CONSTANT + -- DECLARATIONS, EVEN IF THE FULL DECLARATIONS ARE GIVEN INDIVIDUALLY. + + -- CHECK THAT MULTIPLE DECLARATIONS MAY BE USED FOR THE FULL + -- DECLARATIONS, EVEN IF THE DEFERRED CONSTANT DECLARATIONS ARE GIVEN + -- INDIVIDUALLY. + + + -- DSJ 5/09/83 + -- SPS 10/24/83 + -- EG 12/19/83 + -- JRK 12/20/83 + + -- DTN 11/19/91 DELETED SUBPART (C). + + WITH REPORT; + PROCEDURE C74302A IS + + USE REPORT; + + BEGIN + + TEST("C74302A", "CHECK THAT MULTIPLE DECLARATIONS MAY BE USED " & + "FOR DEFERRED CONSTANT DECLARATIONS"); + + DECLARE + + PACKAGE PACK1 IS + + TYPE T IS PRIVATE; + + B, E : CONSTANT T; + + F : CONSTANT T; + PRIVATE + + TYPE T IS NEW INTEGER; + + E : CONSTANT T := T(IDENT_INT(4)); + + B, F : CONSTANT T := T(IDENT_INT(2)); + + END PACK1; + + USE PACK1; + + BEGIN + + IF B/=F THEN + FAILED("VALUES OF DEFERRED CONSTANTS B AND F NOT EQUAL"); + END IF; + + END; + + RESULT; + + END C74302A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74302b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74302b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74302b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74302b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,308 ---- + -- C74302B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN THE FULL DECLARATION OF A DEFERRED CONSTANT IS + -- GIVEN AS A MULTIPLE DECLARATION, THE INITIALIZATION EXPRESSION + -- IS EVALUATED ONCE FOR EACH DEFERRED CONSTANT. (USE ENUMERATION, + -- INTEGER, FIXED POINT, FLOATING POINT, ARRAY, RECORD (INCLUDING + -- USE OF DEFAULT EXPRESSIONS FOR COMPONENTS), ACCESS, AND PRIVATE + -- TYPES AS FULL DECLARATION OF PRIVATE TYPE) + + -- HISTORY: + -- BCB 07/25/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74302B IS + + TYPE ARR_RAN IS RANGE 1..2; + + BUMP : INTEGER := IDENT_INT(0); + + GENERIC + TYPE DT IS (<>); + FUNCTION F1 RETURN DT; + + GENERIC + TYPE FE IS DELTA <>; + FUNCTION F2 RETURN FE; + + GENERIC + TYPE FLE IS DIGITS <>; + FUNCTION F3 RETURN FLE; + + GENERIC + TYPE CA IS ARRAY(ARR_RAN) OF INTEGER; + FUNCTION F4 RETURN CA; + + GENERIC + TYPE GP IS LIMITED PRIVATE; + FUNCTION F5 (V : GP) RETURN GP; + + GENERIC + TYPE GP1 IS LIMITED PRIVATE; + FUNCTION F6 (V1 : GP1) RETURN GP1; + + GENERIC + TYPE AC IS ACCESS INTEGER; + FUNCTION F7 RETURN AC; + + GENERIC + TYPE PP IS PRIVATE; + FUNCTION F8 (P1 : PP) RETURN PP; + + FUNCTION F1 RETURN DT IS + BEGIN + BUMP := BUMP + 1; + RETURN DT'VAL(BUMP); + END F1; + + FUNCTION F2 RETURN FE IS + BEGIN + BUMP := BUMP + 1; + RETURN FE(BUMP); + END F2; + + FUNCTION F3 RETURN FLE IS + BEGIN + BUMP := BUMP + 1; + RETURN FLE(BUMP); + END F3; + + FUNCTION F4 RETURN CA IS + BEGIN + BUMP := BUMP + 1; + RETURN ((BUMP,BUMP-1)); + END F4; + + FUNCTION F5 (V : GP) RETURN GP IS + BEGIN + BUMP := BUMP + 1; + RETURN V; + END F5; + + FUNCTION F6 (V1 : GP1) RETURN GP1 IS + BEGIN + BUMP := BUMP + 1; + RETURN V1; + END F6; + + FUNCTION F7 RETURN AC IS + VAR : AC; + BEGIN + BUMP := BUMP + 1; + VAR := NEW INTEGER'(BUMP); + RETURN VAR; + END F7; + + FUNCTION F8 (P1 : PP) RETURN PP IS + BEGIN + BUMP := BUMP + 1; + RETURN P1; + END F8; + + PACKAGE PACK IS + TYPE SP IS PRIVATE; + CONS : CONSTANT SP; + PRIVATE + TYPE SP IS RANGE 1 .. 100; + CONS : CONSTANT SP := 50; + END PACK; + + USE PACK; + + PACKAGE P IS + TYPE INT IS PRIVATE; + TYPE ENUM IS PRIVATE; + TYPE FIX IS PRIVATE; + TYPE FLT IS PRIVATE; + TYPE CON_ARR IS PRIVATE; + TYPE REC IS PRIVATE; + TYPE REC1 IS PRIVATE; + TYPE ACC IS PRIVATE; + TYPE PRIV IS PRIVATE; + + GENERIC + TYPE LP IS PRIVATE; + FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN; + + I1, I2, I3, I4 : CONSTANT INT; + E1, E2, E3, E4 : CONSTANT ENUM; + FI1, FI2, FI3, FI4 : CONSTANT FIX; + FL1, FL2, FL3, FL4 : CONSTANT FLT; + CA1, CA2, CA3, CA4 : CONSTANT CON_ARR; + R1, R2, R3, R4 : CONSTANT REC; + R1A, R2A, R3A, R4A : CONSTANT REC1; + A1, A2, A3, A4 : CONSTANT ACC; + PR1, PR2, PR3, PR4 : CONSTANT PRIV; + PRIVATE + TYPE INT IS RANGE 1 .. 100; + + TYPE ENUM IS (ONE,TWO,THREE,FOUR,FIVE,SIX,SEVEN,EIGHT,NINE); + + TYPE FIX IS DELTA 2.0**(-1) RANGE -100.0 .. 100.0; + + TYPE FLT IS DIGITS 5 RANGE -100.0 .. 100.0; + + TYPE CON_ARR IS ARRAY(ARR_RAN) OF INTEGER; + + TYPE REC IS RECORD + COMP1 : INTEGER; + COMP2 : INTEGER; + COMP3 : BOOLEAN; + END RECORD; + + TYPE REC1 IS RECORD + COMP1 : INTEGER := 10; + COMP2 : INTEGER := 20; + COMP3 : BOOLEAN := FALSE; + END RECORD; + + TYPE ACC IS ACCESS INTEGER; + + TYPE PRIV IS NEW SP; + + FUNCTION DDT IS NEW F1 (INT); + FUNCTION EDT IS NEW F1 (ENUM); + FUNCTION FDT IS NEW F2 (FIX); + FUNCTION FLDT IS NEW F3 (FLT); + FUNCTION CADT IS NEW F4 (CON_ARR); + FUNCTION RDT IS NEW F5 (REC); + FUNCTION R1DT IS NEW F6 (REC1); + FUNCTION ADT IS NEW F7 (ACC); + FUNCTION PDT IS NEW F8 (PRIV); + + REC_OBJ : REC := (1,2,TRUE); + REC1_OBJ : REC1 := (3,4,FALSE); + + I1, I2, I3, I4 : CONSTANT INT := DDT; + E1, E2, E3, E4 : CONSTANT ENUM := EDT; + FI1, FI2, FI3, FI4 : CONSTANT FIX := FDT; + FL1, FL2, FL3, FL4 : CONSTANT FLT := FLDT; + CA1, CA2, CA3, CA4 : CONSTANT CON_ARR := CADT; + R1, R2, R3, R4 : CONSTANT REC := RDT(REC_OBJ); + R1A, R2A, R3A, R4A : CONSTANT REC1 := R1DT(REC1_OBJ); + A1, A2, A3, A4 : CONSTANT ACC := ADT; + PR1, PR2, PR3, PR4 : CONSTANT PRIV := PDT(PRIV(CONS)); + END P; + + PACKAGE BODY P IS + AVAR1 : ACC := NEW INTEGER'(29); + AVAR2 : ACC := NEW INTEGER'(30); + AVAR3 : ACC := NEW INTEGER'(31); + AVAR4 : ACC := NEW INTEGER'(32); + + FUNCTION GEN_EQUAL (Z1, Z2 : LP) RETURN BOOLEAN IS + BEGIN + RETURN Z1 = Z2; + END GEN_EQUAL; + + FUNCTION INT_EQUAL IS NEW GEN_EQUAL (INT); + FUNCTION ENUM_EQUAL IS NEW GEN_EQUAL (ENUM); + FUNCTION FIX_EQUAL IS NEW GEN_EQUAL (FIX); + FUNCTION FLT_EQUAL IS NEW GEN_EQUAL (FLT); + FUNCTION ARR_EQUAL IS NEW GEN_EQUAL (CON_ARR); + FUNCTION REC_EQUAL IS NEW GEN_EQUAL (REC); + FUNCTION REC1_EQUAL IS NEW GEN_EQUAL (REC1); + FUNCTION ACC_EQUAL IS NEW GEN_EQUAL (INTEGER); + FUNCTION PRIV_EQUAL IS NEW GEN_EQUAL (PRIV); + BEGIN + TEST ("C74302B", "CHECK THAT WHEN THE FULL DECLARATION OF " & + "A DEFERRED CONSTANT IS GIVEN AS A " & + "MULTIPLE DECLARATION, THE INITIALIZATION " & + "EXPRESSION IS EVALUATED ONCE FOR EACH " & + "DEFERRED CONSTANT"); + + IF NOT EQUAL(BUMP,36) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED CONSTANTS IN A MULIPLE DECLARATION"); + END IF; + + IF NOT INT_EQUAL(I1,1) OR NOT INT_EQUAL(I2,2) OR + NOT INT_EQUAL(I3,3) OR NOT INT_EQUAL(I4,4) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED INTEGER CONSTANTS"); + END IF; + + IF NOT ENUM_EQUAL(E1,SIX) OR NOT ENUM_EQUAL(E2,SEVEN) OR + NOT ENUM_EQUAL(E3,EIGHT) OR NOT ENUM_EQUAL(E4,NINE) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ENUMERATION CONSTANTS"); + END IF; + + IF NOT FIX_EQUAL(FI1,9.0) OR NOT FIX_EQUAL(FI2,10.0) OR + NOT FIX_EQUAL(FI3,11.0) OR NOT FIX_EQUAL(FI4,12.0) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED FIXED POINT CONSTANTS"); + END IF; + + IF NOT FLT_EQUAL(FL1,13.0) OR NOT FLT_EQUAL(FL2,14.0) OR + NOT FLT_EQUAL(FL3,15.0) OR NOT FLT_EQUAL(FL4,16.0) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED FLOATING POINT CONSTANTS"); + END IF; + + IF NOT ARR_EQUAL(CA1,(17,16)) OR NOT ARR_EQUAL(CA2,(18,17)) + OR NOT ARR_EQUAL(CA3,(19,18)) OR NOT ARR_EQUAL(CA4,(20,19)) + THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ARRAY CONSTANTS"); + END IF; + + IF NOT REC_EQUAL(R1,REC_OBJ) OR NOT REC_EQUAL(R2,REC_OBJ) + OR NOT REC_EQUAL(R3,REC_OBJ) OR NOT REC_EQUAL(R4,REC_OBJ) + THEN FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED RECORD CONSTANTS"); + END IF; + + IF NOT REC1_EQUAL(R1A,REC1_OBJ) OR NOT REC1_EQUAL(R2A, + REC1_OBJ) OR NOT REC1_EQUAL(R3A,REC1_OBJ) OR NOT + REC1_EQUAL(R4A,REC1_OBJ) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED RECORD CONSTANTS WITH DEFAULT " & + "EXPRESSIONS"); + END IF; + + IF NOT ACC_EQUAL(A1.ALL,AVAR1.ALL) OR NOT ACC_EQUAL(A2.ALL, + AVAR2.ALL) OR NOT ACC_EQUAL(A3.ALL,AVAR3.ALL) OR NOT + ACC_EQUAL(A4.ALL,AVAR4.ALL) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED ACCESS CONSTANTS"); + END IF; + + IF NOT PRIV_EQUAL(PR1,PRIV(CONS)) OR NOT PRIV_EQUAL(PR2, + PRIV(CONS)) OR NOT PRIV_EQUAL(PR3,PRIV(CONS)) OR NOT + PRIV_EQUAL(PR4,PRIV(CONS)) THEN + FAILED ("IMPROPER RESULTS FROM INITIALIZATION OF " & + "DEFERRED PRIVATE CONSTANTS"); + END IF; + + RESULT; + END P; + + USE P; + + BEGIN + NULL; + END C74302B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74305a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- C74305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT + -- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA- + -- LIZATION FOR A COMPONENT (NON GENERIC CASE). + + -- DAT 4/06/81 + -- RM 5/21/81 + -- SPS 8/23/82 + -- SPS 2/10/83 + -- SPS 10/20/83 + -- EG 12/20/83 + -- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY. + + WITH REPORT; + + PROCEDURE C74305A IS + + USE REPORT; + + PACKAGE PK IS + TYPE T1 IS PRIVATE; + TYPE T2 IS PRIVATE; + C1 : CONSTANT T1; -- OK. + + PROCEDURE P1 (P : T1 := C1); -- OK. + + TYPE R1 IS RECORD + C : T1 := C1; -- OK. + END RECORD; + PRIVATE + PROCEDURE PROC2 (P : T1 := C1); -- OK. + + TYPE R2 IS RECORD + C : T1 := C1; -- OK. + D : INTEGER := C1'SIZE; -- OK. + END RECORD; + + FUNCTION F1 (P : T1) RETURN T1; + + TYPE T1 IS NEW INTEGER; + TYPE T2 IS ARRAY (1..2) OF INTEGER; -- OK. + + FUNCTION F2 (P : T1) RETURN T1; + + PROCEDURE P3 (P : T1 := C1+1); -- OK. + + PROCEDURE P4 (P : T1 := F1(C1)); + + TYPE R5 IS RECORD + C : T1 := F2(C1); + END RECORD; + + PROCEDURE P5 (P : T1 := C1+2) RENAMES P3; + + TYPE R3 IS RECORD + C : T1 := C1; -- OK. + END RECORD; + + C1 : CONSTANT T1 := 1; -- OK. + C2 : CONSTANT T2 := (1,1); -- OK. + END PK; + + USE PK; + + PACKAGE BODY PK IS + + R11 : R1; + + PROCEDURE P1 (P : T1 := C1) IS + BEGIN + IF ( P /= 1 ) THEN + FAILED ("PARAMETER DEFAULT OF P1 NOT PROPERLY " & + "INITIALIZED"); + END IF; + END P1; + + PROCEDURE PROC2 (P : T1 := C1) IS + BEGIN NULL; END PROC2; + + PROCEDURE P3 (P : T1 := C1+1) IS + BEGIN + IF ( P /= 3 ) THEN + FAILED ("PARAMETER DEFAULT OF P5 NOT PROPERLY " & + "INITIALIZED"); + END IF; + END P3; + + FUNCTION F1 (P : T1) RETURN T1 IS + BEGIN + RETURN P+10; + END F1; + + PROCEDURE P4 (P : T1 := F1(C1)) IS + BEGIN + IF ( P /= 11 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED"); + END IF; + END P4; + + FUNCTION F2 (P : T1) RETURN T1 IS + BEGIN + RETURN P+20; + END F2; + + BEGIN -- PK BODY. + + DECLARE + + R55 : R5; + + BEGIN + TEST ("C74305A","CHECK THAT A DEFERRED CONSTANT CAN " & + "BE USED AS A DEFAULT INITIALIZATION " & + "FOR A PARAMETER OR AS A DEFAULT " & + "INITIALIZATION FOR A COMPONENT (NON " & + "GENERIC CASE)"); + + IF ( R11.C /= 1 ) THEN + FAILED ("RECORD R11 NOT PROPERLY INITIALIZED"); + END IF; + + P4; + + IF ( R55.C /= 21 ) THEN + FAILED ("RECORD R55 NOT PROPERLY INITIALIZED"); + END IF; + + P5; + END; + END PK; + + BEGIN + + P1; + + RESULT; + END C74305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74305b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74305b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74305b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74305b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C74305B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DEFERRED CONSTANT CAN BE USED AS A DEFAULT + -- INITIALIZATION FOR A PARAMETER OR AS A DEFAULT INITIA- + -- LIZATION FOR A COMPONENT (GENERIC CASE). + + -- EG 12/20/83 + + WITH REPORT; + + PROCEDURE C74305B IS + + USE REPORT; + + PACKAGE PK IS + TYPE TD IS PRIVATE; + CD : CONSTANT TD; + DD : CONSTANT TD; + + GENERIC + TYPE T1 IS PRIVATE; + C1 : T1; + WITH PROCEDURE P2 (A1 : T1 := C1; A2 : TD := CD); + PROCEDURE P1 (A1 : TD := CD); + + PRIVATE + TYPE TD IS NEW INTEGER; + CD : CONSTANT TD := 2; + DD : CONSTANT TD := 3; + END PK; + + USE PK; + + PACKAGE BODY PK IS + + PROCEDURE P1 (A1 : TD := CD) IS + BEGIN + IF ( A1 /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (1)"); + END IF; + P2; + END P1; + + PROCEDURE P3 (X : TD := DD; Y : TD := DD) IS + BEGIN + IF ( X /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (2)"); + END IF; + IF ( Y /= 2 ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (3)"); + END IF; + END P3; + + PROCEDURE P4 IS NEW P1 (TD,CD,P3); + + BEGIN + TEST ("C74305B","CHECK THAT A DEFERRED CONSTANT CAN BE " & + "USED AS A DEFAULT INITIALIZATION FOR A " & + "PARAMETER OR AS A DEFAULT INITIALIZATION " & + "FOR A COMPONENT (GENERIC CASE)"); + P4; + END PK; + + PROCEDURE P5 (X : TD := DD; Y : TD := DD) IS + BEGIN + IF ( X /= CD ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (4)"); + END IF; + IF ( Y /= CD ) THEN + FAILED ("WRONG ACTUAL PARAMETER RECEIVED (5)"); + END IF; + END P5; + + PROCEDURE P6 IS NEW P1 (TD,CD,P5); + + BEGIN + P6; + RESULT; + END C74305B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74306a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74306a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74306a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74306a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,279 ---- + -- C74306A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- AFTER THE FULL DECLARATION OF A DEFERRED CONSTANT, THE VALUE OF + -- THE CONSTANT MAY BE USED IN ANY EXPRESSION, PARTICULARLY + -- EXPRESSIONS IN WHICH THE USE WOULD BE ILLEGAL BEFORE THE FULL + -- DECLARATION. + + -- HISTORY: + -- BCB 03/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74306A IS + + GENERIC + TYPE GENERAL_PURPOSE IS LIMITED PRIVATE; + Y : IN OUT GENERAL_PURPOSE; + FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE; + + FUNCTION IDENT (X : GENERAL_PURPOSE) RETURN GENERAL_PURPOSE IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Y; + END IDENT; + + PACKAGE P IS + TYPE T IS PRIVATE; + C : CONSTANT T; + PRIVATE + TYPE T IS RANGE 1 .. 100; + + TYPE A IS ARRAY(1..2) OF T; + + TYPE B IS ARRAY(INTEGER RANGE <>) OF T; + + TYPE D (DISC : T) IS RECORD + NULL; + END RECORD; + + C : CONSTANT T := 50; + + PARAM : T := 99; + + FUNCTION IDENT_T IS NEW IDENT (T, PARAM); + + FUNCTION F (X : T := C) RETURN T; + + SUBTYPE RAN IS T RANGE 1 .. C; + + SUBTYPE IND IS B(1..INTEGER(C)); + + SUBTYPE DIS IS D (DISC => C); + + OBJ : T := C; + + CON : CONSTANT T := C; + + ARR : A := (5, C); + + PAR : T := IDENT_T (C); + + RANOBJ : T RANGE 1 .. C := C; + + INDOBJ : B(1..INTEGER(C)); + + DIS_VAL : DIS; + + REN : T RENAMES C; + + GENERIC + FOR_PAR : T := C; + PACKAGE GENPACK IS + VAL : T; + END GENPACK; + + GENERIC + IN_PAR : IN T; + PACKAGE NEWPACK IS + IN_VAL : T; + END NEWPACK; + END P; + + USE P; + + PACKAGE BODY P IS + TYPE A1 IS ARRAY(1..2) OF T; + + TYPE B1 IS ARRAY(INTEGER RANGE <>) OF T; + + TYPE D1 (DISC1 : T) IS RECORD + NULL; + END RECORD; + + SUBTYPE RAN1 IS T RANGE 1 .. C; + + SUBTYPE IND1 IS B1(1..INTEGER(C)); + + SUBTYPE DIS1 IS D1 (DISC1 => C); + + OBJ1 : T := C; + + FUNCVAR : T; + + CON1 : CONSTANT T := C; + + ARR1 : A1 := (5, C); + + PAR1 : T := IDENT_T (C); + + RANOBJ1 : T RANGE 1 .. C := C; + + INDOBJ1 : B1(1..INTEGER(C)); + + DIS_VAL1 : DIS1; + + REN1 : T RENAMES C; + + FUNCTION F (X : T := C) RETURN T IS + BEGIN + RETURN C; + END F; + + PACKAGE BODY GENPACK IS + BEGIN + VAL := FOR_PAR; + END GENPACK; + + PACKAGE BODY NEWPACK IS + BEGIN + IN_VAL := IN_PAR; + END NEWPACK; + + PACKAGE PACK IS NEW GENPACK (FOR_PAR => C); + + PACKAGE NPACK IS NEW NEWPACK (IN_PAR => C); + BEGIN + TEST ("C74306A", "AFTER THE FULL DECLARATION OF A DEFERRED " & + "CONSTANT, THE VALUE OF THE CONSTANT MAY " & + "BE USED IN ANY EXPRESSION, PARTICULARLY " & + "EXPRESSIONS IN WHICH THE USE WOULD BE " & + "ILLEGAL BEFORE THE FULL DECLARATION"); + + IF OBJ /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR OBJ"); + END IF; + + IF CON /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR CON"); + END IF; + + IF ARR /= (IDENT_T(5), IDENT_T(50)) THEN + FAILED ("IMPROPER VALUES FOR ARR"); + END IF; + + IF PAR /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PAR"); + END IF; + + IF OBJ1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR OBJ1"); + END IF; + + IF CON1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR CON1"); + END IF; + + IF ARR1 /= (IDENT_T(5), IDENT_T(50)) THEN + FAILED ("IMPROPER VALUES FOR ARR1"); + END IF; + + IF PAR1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PAR1"); + END IF; + + IF PACK.VAL /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR PACK.VAL"); + END IF; + + IF NPACK.IN_VAL /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR NPACK.IN_VAL"); + END IF; + + IF RAN'LAST /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RAN'LAST"); + END IF; + + IF RANOBJ /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RANOBJ"); + END IF; + + IF IND'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR IND'LAST"); + END IF; + + IF INDOBJ'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR INDOBJ'LAST"); + END IF; + + IF DIS_VAL.DISC /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR DIS_VAL.DISC"); + END IF; + + IF REN /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR REN"); + END IF; + + IF RAN1'LAST /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RAN1'LAST"); + END IF; + + IF RANOBJ1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR RANOBJ1"); + END IF; + + IF IND1'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR IND1'LAST"); + END IF; + + IF INDOBJ1'LAST /= IDENT_INT(50) THEN + FAILED ("IMPROPER VALUE FOR INDOBJ1'LAST"); + END IF; + + IF DIS_VAL1.DISC1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR DIS_VAL1.DISC1"); + END IF; + + IF REN1 /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR REN1"); + END IF; + + FUNCVAR := F(C); + + IF FUNCVAR /= IDENT_T(50) THEN + FAILED ("IMPROPER VALUE FOR FUNCVAR"); + END IF; + + RESULT; + END P; + + BEGIN + DECLARE + TYPE ARR IS ARRAY(1..2) OF T; + + VAL1 : T := C; + + VAL2 : ARR := (C, C); + + VAL3 : T RENAMES C; + BEGIN + NULL; + END; + + NULL; + END C74306A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74307a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74307a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74307a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74307a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- C74307A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXPLICIT CONSTRAINT MAY BE GIVEN IN THE SUBTYPE + -- INDICATION OF THE FULL DECLARATION OF A DEFERRED CONSTANT. + + -- HISTORY: + -- BCB 03/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74307A IS + + PACKAGE P IS + TYPE T (D : INTEGER) IS PRIVATE; + C : CONSTANT T; + PRIVATE + TYPE T (D : INTEGER) IS RECORD + NULL; + END RECORD; + C : CONSTANT T(2) := (D => 2); + END P; + + USE P; + + BEGIN + TEST ("C74307A", "CHECK THAT AN EXPLICIT CONSTRAINT MAY BE " & + "GIVEN IN THE SUBTYPE INDICATION OF THE FULL " & + "DECLARATION OF A DEFERRED CONSTANT"); + + IF C.D /= 2 THEN + FAILED ("IMPROPER RESULTS FOR C.D"); + END IF; + + RESULT; + END C74307A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C74401D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN OUT PARAMETER HAVING A LIMITED TYPE IS ALLOWED FOR + -- FORMAL SUBPROGRAM PARAMETERS. (ONLY THE CASE OF PRACTICAL INTEREST, + -- NAMELY, LIMITED PRIVATE TYPES, IS CHECKED HERE.) + + -- CHECK THAT AN OUT PARAMETER IN A RENAMING DECLARATION CAN HAVE A + -- LIMITED PRIVATE TYPE WHEN IT RENAMES A GENERIC FORMAL SUBPROGRAM. + + -- JBG 5/1/85 + + WITH REPORT; USE REPORT; + PROCEDURE C74401D IS + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE P1 (X : OUT LP); + PROCEDURE P2 (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + VAL2 : CONSTANT LP; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + VAL2 : CONSTANT LP := LP(IDENT_INT(-3)); + END P; + + PACKAGE BODY P IS + PROCEDURE P1 (X : OUT LP) IS + BEGIN + X := 3; + END P1; + + PROCEDURE P2 (X : OUT LP) IS + BEGIN + X := -3; + END P2; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + END P; + + GENERIC + WITH PROCEDURE P3 (Y : OUT P.LP); + TYPE GLP IS LIMITED PRIVATE; + WITH PROCEDURE P4 (Y : OUT GLP); + VAL_P3 : IN OUT P.LP; + VAL_P4 : IN OUT GLP; + PACKAGE GPACK IS + PROCEDURE RENAMED (X : OUT GLP) RENAMES P4; -- OK. RENAMING. + END GPACK; + + PACKAGE BODY GPACK IS + BEGIN + P3 (VAL_P3); + P4 (VAL_P4); + END GPACK; + + BEGIN + + TEST ("C74401D", "CHECK THAT GENERIC FORMAL SUBPROGRAMS CAN HAVE "& + "LIMITED PRIVATE OUT PARAMETERS"); + + DECLARE + VAR1 : P.LP; + VAR2 : P.LP; + PACKAGE PACK IS NEW GPACK (P.P1, P.LP, P.P2, VAR1, VAR2); + BEGIN + IF NOT P.EQ (VAR1, P.VAL1) THEN + FAILED ("P1 INVOCATION INCORRECT"); + END IF; + + IF NOT P.EQ (VAR2, P.VAL2) THEN + FAILED ("P2 INVOCATION INCORRECT"); + END IF; + + P.P1 (VAR2); -- RESET VALUE OF VAR2. + PACK.RENAMED (VAR2); + + IF NOT P.EQ (VAR2, P.VAL2) THEN + FAILED ("RENAMED INVOCATION INCORRECT"); + END IF; + END; + + RESULT; + + END C74401D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- C74401E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE + -- DECLARED IN A PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES + -- NESTED IN A VISIBLE PART. + + -- CHECK THAT A RENAMING DECLARATION CAN RENAME A PROCEDURE DECLARED + -- WITH AN OUT PARAMETER. + + -- JBG 5/1/85 + + WITH REPORT; USE REPORT; + PROCEDURE C74401E IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE P20 (X : OUT LP); -- OK. + PROCEDURE RESET (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + PROCEDURE NEST1 (X : OUT LP); + PRIVATE + PROCEDURE NEST2 (X : OUT LP); + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + PROCEDURE P20 (X : OUT LP) IS + BEGIN + X := 3; + END P20; + + PROCEDURE RESET (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(0)); + END RESET; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + PROCEDURE NEST1 (X : OUT LP) IS + BEGIN + X := 3; + END NEST1; + + PROCEDURE NEST2 (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(3)); + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20; -- OK: + -- RENAMING. + END PKG1; + + BEGIN + + TEST ("C74401E", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.RESET (VAR); + PKG.P20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG.NESTED.NEST1 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("NESTED CALL NOT CORRECT"); + END IF; + + RESULT; + + END C74401E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401k.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C74401K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OUT PARAMETERS OF AN ENTRY DECLARATION CAN HAVE A LIMITED + -- PRIVATE TYPE IF THE ENTRY DECLARATION OCCURS IN THE VISIBLE PART OF A + -- PACKAGE SPECIFICATION, INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE + -- PART. + + -- CHECK THAT A RENAMING DECLARATION CAN RENAME AN ENTRY DECLARED + -- WITH AN OUT PARAMETER. + + -- JBG 5/1/85 + + WITH REPORT; USE REPORT; + PROCEDURE C74401K IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + TASK P20 IS + ENTRY TP20 (X : OUT LP); -- OK. + ENTRY RESET (X : OUT LP); + END P20; + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + TASK NEST1 IS + ENTRY TNEST1 (X : OUT LP); + END NEST1; + PRIVATE + TASK NEST2 IS + ENTRY TNEST2 (X : OUT LP); + END NEST2; + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + TASK BODY P20 IS + BEGIN + LOOP + SELECT + ACCEPT TP20 (X : OUT LP) DO + X := 3; + END TP20; + OR + ACCEPT RESET (X : OUT LP) DO + X := 0; + END RESET; + OR + TERMINATE; + END SELECT; + END LOOP; + END P20; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + TASK BODY NEST1 IS + BEGIN + ACCEPT TNEST1 (X : OUT LP) DO + X := 3; + END TNEST1; + END NEST1; + + TASK BODY NEST2 IS + BEGIN + NULL; + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES PKG.P20.TP20; -- OK: + -- RENAMING. + END PKG1; + + BEGIN + + TEST ("C74401K", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.P20.RESET (VAR); + PKG.P20.TP20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.P20.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + PKG.P20.RESET (VAR); + PKG.NESTED.NEST1.TNEST1 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("NESTED CALL NOT CORRECT"); + END IF; + + RESULT; + + END C74401K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74401q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74401q.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- C74401Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OUT PARAMETERS HAVING A LIMITED PRIVATE TYPE CAN BE + -- DECLARED FOR A GENERIC SUBPROGRAM IN A PACKAGE SPECIFICATION, + -- INCLUDING WITHIN PACKAGES NESTED IN A VISIBLE PART. + + -- JBG 5/1/85 + + WITH REPORT; USE REPORT; + PROCEDURE C74401Q IS + + PACKAGE PKG IS + TYPE LP IS LIMITED PRIVATE; + + GENERIC + PROCEDURE P20 (X : OUT LP); -- OK. + PROCEDURE RESET (X : OUT LP); + FUNCTION EQ (L, R : LP) RETURN BOOLEAN; + VAL1 : CONSTANT LP; + + PACKAGE NESTED IS + GENERIC + PROCEDURE NEST1 (X : OUT LP); + PRIVATE + GENERIC + PROCEDURE NEST2 (X : OUT LP); + END NESTED; + PRIVATE + TYPE LP IS NEW INTEGER; + VAL1 : CONSTANT LP := LP(IDENT_INT(3)); + END PKG; + + VAR : PKG.LP; + + PACKAGE BODY PKG IS + PROCEDURE P20 (X : OUT LP) IS + BEGIN + X := 3; + END P20; + + PROCEDURE RESET (X : OUT LP) IS + BEGIN + X := 0; + END RESET; + + FUNCTION EQ (L, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN L = R; + END EQ; + + PACKAGE BODY NESTED IS + PROCEDURE NEST1 (X : OUT LP) IS + BEGIN + X := 3; + END NEST1; + + PROCEDURE NEST2 (X : OUT LP) IS + BEGIN + X := LP(IDENT_INT(3)); + END NEST2; + END NESTED; + BEGIN + VAR := LP(IDENT_INT(0)); + END PKG; + + PACKAGE INSTANCES IS + PROCEDURE NP20 IS NEW PKG.P20; + PROCEDURE NNEST1 IS NEW PKG.NESTED.NEST1; + END INSTANCES; + USE INSTANCES; + + PACKAGE PKG1 IS + PROCEDURE P21 (X : OUT PKG.LP) RENAMES INSTANCES.NP20; + END PKG1; + + BEGIN + + TEST ("C74401Q", "CHECK THAT A PROCEDURE CAN HAVE AN OUT " & + "PARAMETER WITH A LIMITED PRIVATE TYPE"); + + PKG.RESET (VAR); + NP20 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("DIRECT CALL NOT CORRECT"); + END IF; + + PKG.RESET (VAR); + PKG1.P21 (VAR); + + IF NOT PKG.EQ (VAR, PKG.VAL1) THEN + FAILED ("RENAMED CALL NOT CORRECT"); + END IF; + + RESULT; + + END C74401Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74402a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- C74402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED TYPE MAY HAVE A + -- DEFAULT EXPRESSION, EVEN IF THE SUBPROGRAM IS DECLARED OUTSIDE + -- THE PACKAGE THAT DECLARES THE LIMITED TYPE. + -- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.) + + -- DSJ 5/6/83 + -- SPS 10/24/83 + + WITH REPORT; + PROCEDURE C74402A IS + + USE REPORT; + + BEGIN + + TEST("C74402A", "CHECK THAT A SUBPROGRAM PARAMETER OF A LIMITED " & + "TYPE MAY HAVE A DEFAULT EXPRESSION, EVEN IF " & + "THE SUBPROGRAM IS DECLARED OUTSIDE THE PACKAGE " & + "THAT DECLARES THE LIMITED TYPE"); + + DECLARE + + PACKAGE PACK1 IS + + TYPE LP1 IS LIMITED PRIVATE; + TYPE LP2 IS ARRAY (1 .. 2) OF LP1; + TYPE LP3 IS + RECORD + C1, C2 : LP2; + END RECORD; + + FUNCTION F1 RETURN LP1; + FUNCTION F2 RETURN LP2; + FUNCTION F3 RETURN LP3; + + PROCEDURE G1 (X : LP1 := F1); -- LEGAL + PROCEDURE G2 (X : LP2 := F2); -- LEGAL + PROCEDURE G3 (X : LP3 := F3); -- LEGAL + + PRIVATE + + TYPE LP1 IS NEW INTEGER; + + END PACK1; + + PACKAGE BODY PACK1 IS + + FUNCTION F1 RETURN LP1 IS + BEGIN + RETURN LP1'(1); + END F1; + + FUNCTION F2 RETURN LP2 IS + BEGIN + RETURN LP2'(2,3); + END F2; + + FUNCTION F3 RETURN LP3 IS + BEGIN + RETURN LP3'((4,5),(6,7)); + END F3; + + PROCEDURE G1 (X : LP1 := F1) IS + BEGIN + IF X /= LP1'(1) THEN + FAILED("WRONG DEFAULT VALUE - LP1"); + END IF; + END G1; + + PROCEDURE G2 (X : LP2 := F2) IS + BEGIN + IF X /= LP2'(2,3) THEN + FAILED("WRONG DEFAULT VALUE - LP2"); + END IF; + END G2; + + PROCEDURE G3 (X : LP3 := F3) IS + BEGIN + IF X /= LP3'((4,5),(6,7)) THEN + FAILED("WRONG DEFAULT VALUE - LP3"); + END IF; + END G3; + + BEGIN + + G1; -- LEGAL, DEFAULT USED + G2; -- LEGAL, DEFAULT USED + G3; -- LEGAL, DEFAULT USED + + G1(F1); -- LEGAL + G2(F2); -- LEGAL + G3(F3); -- LEGAL + + END PACK1; + + USE PACK1; + + PROCEDURE G4 (X : LP1 := F1) IS + BEGIN + G1; -- LEGAL, DEFAULT USED + G1(X); + END G4; + + PROCEDURE G5 (X : LP2 := F2) IS + BEGIN + G2; -- LEGAL, DEFAULT USED + G2(X); + END G5; + + PROCEDURE G6 (X : LP3 := F3) IS + BEGIN + G3; -- DEFAULT USED + G3(X); + END G6; + + BEGIN + + G4; -- LEGAL, DEFAULT USED + G5; -- LEGAL, DEFAULT USED + G6; -- LEGAL, DEFAULT USED + + G4(F1); -- LEGAL + G5(F2); -- LEGAL + G6(F3); -- LEGAL + + END; + + RESULT; + + END C74402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74402b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74402b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74402b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74402b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C74402B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INITIALIZATION OF IN PARAMETERS THAT ARE OF + -- LIMITED PRIVATE TYPE IS PERMITTED. + -- (SEE ALSO 6.4.2/T1 FOR TESTS OF OTHER LIMITED TYPES.) + + -- DAS 1/21/81 + -- ABW 6/30/82 + -- BHS 7/10/84 + + WITH REPORT; + PROCEDURE C74402B IS + + USE REPORT; + + BEGIN + + TEST( "C74402B" , "CHECK THAT INITIALIZATION OF IN PARAMETERS " & + "OF LIMITED PRIVATE TYPE IS PERMITTED" ); + + DECLARE + + PACKAGE PKG IS + + TYPE LPTYPE IS LIMITED PRIVATE; + CLP : CONSTANT LPTYPE; + XLP : CONSTANT LPTYPE; + FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN; + FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN; + + PRIVATE + + TYPE LPTYPE IS NEW INTEGER RANGE 0..127; + CLP : CONSTANT LPTYPE := 127; + XLP : CONSTANT LPTYPE := 0; + + END; + + PACKAGE BODY PKG IS + + FUNCTION EQCLP (L : IN LPTYPE) RETURN BOOLEAN IS + BEGIN + RETURN (L = CLP); + END EQCLP; + + FUNCTION EQXLP (L : IN LPTYPE) RETURN BOOLEAN IS + BEGIN + RETURN (L = XLP); + END EQXLP; + + END PKG; + + USE PKG; + + PROCEDURE PROC1 (Y : IN LPTYPE := CLP) IS + BEGIN + IF (EQCLP (Y)) THEN + FAILED( "LIMITED PRIVATE NOT PASSED, " & + "DEFAULT CLP EMPLOYED" ); + ELSIF (NOT EQXLP (Y)) THEN + FAILED( "NO LIMITED PRIVATE FOUND" ); + END IF; + END PROC1; + + PROCEDURE PROC2 (Y : IN LPTYPE := CLP) IS + BEGIN + IF (NOT EQCLP(Y)) THEN + FAILED( "DEFAULT NOT EMPLOYED" ); + END IF; + END PROC2; + + BEGIN + + PROC1(XLP); + PROC2; + + END; + + RESULT; + + END C74402B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74406a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74406a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74406a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74406a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C74406A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FULL DECLARATION OF A LIMITED PRIVATE TYPE CAN + -- DECLARE A TASK TYPE, A TYPE DERIVED FROM A LIMITED PRIVATE TYPE, + -- AND A COMPOSITE TYPE WITH A COMPONENT OF A LIMITED TYPE. + + -- HISTORY: + -- BCB 03/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74406A IS + + PACKAGE TP IS + TYPE T IS LIMITED PRIVATE; + PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER); + FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN; + PRIVATE + TYPE T IS RANGE 1 .. 100; + END TP; + + PACKAGE BODY TP IS + PROCEDURE INIT (Z1 : OUT T; Z2 : INTEGER) IS + BEGIN + Z1 := T (Z2); + END INIT; + + FUNCTION EQUAL_T (ONE, TWO : T) RETURN BOOLEAN IS + BEGIN + IF EQUAL(3,3) THEN + RETURN ONE = TWO; + ELSE + RETURN ONE /= TWO; + END IF; + END EQUAL_T; + BEGIN + NULL; + END TP; + + USE TP; + + PACKAGE P IS + TYPE T1 IS LIMITED PRIVATE; + TYPE T2 IS LIMITED PRIVATE; + TYPE T3 IS LIMITED PRIVATE; + TYPE T4 IS LIMITED PRIVATE; + PRIVATE + TASK TYPE T1 IS + ENTRY HERE(VAL1 : IN OUT INTEGER); + END T1; + + TYPE T2 IS NEW T; + + TYPE T3 IS RECORD + INT : T; + END RECORD; + + TYPE T4 IS ARRAY(1..5) OF T; + END P; + + PACKAGE BODY P IS + X1 : T1; + X3 : T3; + X4 : T4; + VAR : INTEGER := 25; + + TASK BODY T1 IS + BEGIN + ACCEPT HERE(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 2; + END HERE; + END T1; + + BEGIN + TEST ("C74406A", "CHECK THAT THE FULL DECLARATION OF A " & + "LIMITED PRIVATE TYPE CAN DECLARE A TASK " & + "TYPE, A TYPE DERIVED FROM A LIMITED " & + "PRIVATE TYPE, AND A COMPOSITE TYPE WITH " & + "A COMPONENT OF A LIMITED TYPE"); + + X1.HERE(VAR); + + IF NOT EQUAL(VAR,IDENT_INT(50)) THEN + FAILED ("IMPROPER VALUE FOR VAL"); + END IF; + + INIT (X3.INT, 50); + + IF X3.INT NOT IN T THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + INIT (X4(3), 17); + + IF NOT EQUAL_T(T'(X4(3)),T(X4(3))) THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION AND " & + "EXPLICIT CONVERSION"); + END IF; + + RESULT; + END P; + + USE P; + + BEGIN + NULL; + END C74406A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74407b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74407b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74407b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74407b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C74407B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A LIMITED PRIVATE TYPE, THAT PRE-DEFINED EQUALITY AND + -- ASSIGNMENT ARE DEFINED AND AVAILABLE WITHIN THE PRIVATE PART AND + -- THE BODY OF A PACKAGE, AFTER THE FULL DECLARATION, IF THE FULL + -- DECLARATION IS NOT LIMITED. + + -- HISTORY: + -- BCB 07/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C74407B IS + + PACKAGE PP IS + TYPE PRIV IS PRIVATE; + C1 : CONSTANT PRIV; + C2 : CONSTANT PRIV; + PRIVATE + TYPE PRIV IS (ONE, TWO, THREE, FOUR, FIVE, SIX); + C1 : CONSTANT PRIV := ONE; + C2 : CONSTANT PRIV := TWO; + END PP; + + USE PP; + + PACKAGE P IS + TYPE INT IS LIMITED PRIVATE; + TYPE COMP IS LIMITED PRIVATE; + TYPE DER IS LIMITED PRIVATE; + PRIVATE + TYPE INT IS RANGE 1 .. 100; + TYPE COMP IS ARRAY(1..5) OF INTEGER; + TYPE DER IS NEW PRIV; + D, E : INT := 10; + F : INT := 20; + CONS_INT1 : CONSTANT INT := 30; + G : BOOLEAN := D = E; + H : BOOLEAN := D /= F; + CONS_BOOL1 : CONSTANT BOOLEAN := D = E; + CONS_BOOL2 : CONSTANT BOOLEAN := D /= F; + I : COMP := (1,2,3,4,5); + CONS_COMP1 : CONSTANT COMP := (6,7,8,9,10); + J : DER := DER(C1); + CONS_DER1 : CONSTANT DER := DER(C2); + END P; + + PACKAGE BODY P IS + A, B, C : INT; + X, Y, Z : COMP; + L, M, N : DER; + CONS_INT2 : CONSTANT INT := 10; + CONS_COMP2 : CONSTANT COMP := (1,2,3,4,5); + CONS_DER2 : CONSTANT DER := DER(C1); + BEGIN + TEST ("C74407B", "CHECK, FOR A LIMITED PRIVATE TYPE, THAT " & + "PRE-DEFINED EQUALITY AND ASSIGNMENT ARE " & + "DEFINED AND AVAILABLE WITHIN THE PRIVATE " & + "PART AND THE BODY OF A PACKAGE, AFTER " & + "THE FULL DECLARATION, IF THE FULL " & + "DECLARATION IS NOT LIMITED"); + + A := 10; + + B := 10; + + C := 20; + + IF A = C THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 1"); + END IF; + + IF A /= B THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 1"); + END IF; + + IF CONS_INT2 = C THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 2"); + END IF; + + IF CONS_INT2 /= B THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 2"); + END IF; + + IF NOT G THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 1"); + END IF; + + IF NOT H THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 1"); + END IF; + + IF NOT CONS_BOOL1 THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 2"); + END IF; + + IF NOT CONS_BOOL2 THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PRIVATE PART OF THE " & + "PACKAGE - 2"); + END IF; + + X := (1,2,3,4,5); + + Y := (1,2,3,4,5); + + Z := (5,4,3,2,1); + + IF X = Z THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 3"); + END IF; + + IF X /= Y THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 3"); + END IF; + + IF CONS_COMP2 = Z THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 4"); + END IF; + + IF CONS_COMP2 /= Y THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 4"); + END IF; + + L := DER(C1); + + M := DER(C1); + + N := DER(C2); + + IF L = N THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 5"); + END IF; + + IF L /= M THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 5"); + END IF; + + IF CONS_DER2 = N THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED EQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 6"); + END IF; + + IF CONS_DER2 /= M THEN + FAILED ("IMPROPER RESULT FROM PRE-DEFINED INEQUALITY " & + "OPERATION WITHIN THE PACKAGE BODY - 6"); + END IF; + + RESULT; + END P; + + USE P; + + BEGIN + NULL; + END C74407B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74409b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74409b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c74409b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c74409b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C74409B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A COMPOSITE TYPE IS DECLARED IN THE SAME PACKAGE + -- AS A LIMITED PRIVATE TYPE AND HAS A COMPONENT OF THAT TYPE, + -- THE COMPOSITE TYPE IS TREATED AS A LIMITED TYPE UNTIL THE + -- EARLIEST PLACE WITHIN THE IMMEDIATE SCOPE OF THE DECLARATION + -- OF THE COMPOSITE TYPE AND AFTER THE FULL DECLARATION OF THE + -- LIMITED PRIVATE TYPE + + -- DSJ 5/5/83 + -- JBG 9/23/83 + + WITH REPORT; + PROCEDURE C74409B IS + + USE REPORT; + + BEGIN + + TEST("C74409B", "CHECK THAT A COMPOSITE TYPE WITH A LIMITED " & + "PRIVATE COMPONENT IS TREATED AS A LIMITED " & + "TYPE UNTIL ASSIGNMENT AND EQUALITY ARE BOTH " & + "AVAILABLE FOR THE COMPOSITE TYPE"); + + DECLARE + + PACKAGE P IS + TYPE LP IS LIMITED PRIVATE; + PACKAGE Q IS + TYPE LP_ARRAY IS ARRAY (1 .. 2) OF LP; + END Q; + PRIVATE + TYPE LP IS NEW INTEGER; + END P; + + PACKAGE BODY P IS + USE Q; + FUNCTION "=" (L,R : LP_ARRAY) RETURN BOOLEAN IS -- LEGAL + BEGIN + RETURN TRUE; + END; + + GENERIC + TYPE T IS PRIVATE; -- NOTE: NOT LIMITED PRIVATE + C, D : T; + PACKAGE A IS + -- IRRELEVANT DETAILS + END A; + + PACKAGE BODY A IS + BEGIN + IF C = D THEN + FAILED ("USED WRONG EQUALITY OPERATOR"); + END IF; + END A; + + PACKAGE BODY Q IS + PACKAGE ANOTHER_NEW_A IS + NEW A (LP_ARRAY, (2,3), (4,5)); -- LEGAL + END Q; + END P; + + BEGIN + + NULL; + + END; + + RESULT; + + END C74409B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,390 ---- + -- C760001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Initialize is called for objects and components of + -- a controlled type when the objects and components are not + -- assigned explicit initial values. Check this for "simple" controlled + -- objects, controlled record components and arrays with controlled + -- components. + -- + -- Check that if an explicit initial value is assigned to an object + -- or component of a controlled type then Initialize is not called. + -- + -- TEST DESCRIPTION: + -- This test derives a type for Ada.Finalization.Controlled, and + -- overrides the Initialize and Adjust operations for the type. The + -- intent of the type is that it should carry incremental values + -- indicating the ordering of events with respect to these (and default + -- initialization) operations. The body of the test uses these values + -- to determine that the implicit calls to these subprograms happen + -- (or don't) at the appropriate times. + -- + -- The test further derives types from this "root" type, which are the + -- actual types used in the test. One of the types is "simply" derived + -- from the "root" type, the other contains a component of the first + -- type, thus nesting a controlled object as a record component in + -- controlled objects. + -- + -- The main program declares objects of these types and checks the + -- values of the components to ascertain that they have been touched + -- as expected. + -- + -- Note that Finalization procedures are provided. This test does not + -- test that the calls to Finalization are made correctly. The + -- Finalization procedures are provided to catch an implementation that + -- calls Finalization at an incorrect time. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Oct 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + ---------------------------------------------------------------- C760001_0 + + with Ada.Finalization; + package C760001_0 is + subtype Unique_ID is Natural; + function Unique_Value return Unique_ID; + -- increments each time it's called + + function Most_Recent_Unique_Value return Unique_ID; + -- returns the same value as the most recent call to Unique_Value + + type Root_Controlled is new Ada.Finalization.Controlled with record + My_ID : Unique_ID := Unique_Value; + My_Init_ID : Unique_ID := Unique_ID'First; + My_Adj_ID : Unique_ID := Unique_ID'First; + end record; + + procedure Initialize( R: in out Root_Controlled ); + procedure Adjust ( R: in out Root_Controlled ); + + TC_Initialize_Calls_Is_Failing : Boolean := False; + + end C760001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760001_0 is + + Global_Unique_Counter : Unique_ID := 0; + + function Unique_Value return Unique_ID is + begin + Global_Unique_Counter := Global_Unique_Counter +1; + return Global_Unique_Counter; + end Unique_Value; + + function Most_Recent_Unique_Value return Unique_ID is + begin + return Global_Unique_Counter; + end Most_Recent_Unique_Value; + + procedure Initialize( R: in out Root_Controlled ) is + begin + if TC_Initialize_Calls_Is_Failing then + Report.Failed("Initialized incorrectly called"); + end if; + R.My_Init_ID := Unique_Value; + end Initialize; + + procedure Adjust( R: in out Root_Controlled ) is + begin + R.My_Adj_ID := Unique_Value; + end Adjust; + + end C760001_0; + + ---------------------------------------------------------------- C760001_1 + + with Ada.Finalization; + with C760001_0; + package C760001_1 is + + type Proc_ID is (None, Init, Adj, Fin); + + type Test_Controlled is new C760001_0.Root_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Controlled ); + procedure Adjust ( TC: in out Test_Controlled ); + procedure Finalize ( TC: in out Test_Controlled ); + + type Nested_Controlled is new C760001_0.Root_Controlled with record + Nested : C760001_0.Root_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Controlled ); + procedure Adjust ( TC: in out Nested_Controlled ); + procedure Finalize ( TC: in out Nested_Controlled ); + + end C760001_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760001_1 is + + procedure Initialize( TC: in out Test_Controlled ) is + begin + if TC.Last_Proc_Called /= None then + Report.Failed("Initialize for Test_Controlled"); + end if; + TC.Last_Proc_Called := Init; + C760001_0.Initialize(C760001_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760001_0.Adjust(C760001_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Controlled ) is + begin + if TC.Last_Proc_Called /= None then + Report.Failed("Initialize for Nested_Controlled"); + end if; + TC.Last_Proc_Called := Init; + C760001_0.Initialize(C760001_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760001_0.Adjust(C760001_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + end C760001_1; + + ---------------------------------------------------------------- C760001 + + with Report; + with TCTouch; + with C760001_0; + with C760001_1; + with Ada.Finalization; + procedure C760001 is + + use type C760001_1.Proc_ID; + + -- in the first test, test the simple case. Check that a controlled object + -- causes a call to the procedure Initialize. + -- Also check that assignment causes a call to Adjust. + + procedure Check_Simple_Objects is + S,T : C760001_1.Test_Controlled; + begin + TCTouch.Assert(S.My_ID < S.My_Init_ID,"Default before dispatch"); + TCTouch.Assert((S.Last_Proc_Called = C760001_1.Init) and + (T.Last_Proc_Called = C760001_1.Init), + "Initialize for simple object"); + S := T; + TCTouch.Assert((S.Last_Proc_Called = C760001_1.Adj), + "Adjust for simple object"); + TCTouch.Assert((S.My_ID = T.My_ID), + "Simple object My_ID's don't match"); + TCTouch.Assert((S.My_Init_ID = T.My_Init_ID), + "Simple object My_Init_ID's don't match"); + TCTouch.Assert((S.My_Adj_ID > T.My_Adj_ID), + "Simple object My_Adj_ID's in wrong order"); + end Check_Simple_Objects; + + -- in the second test, test a more complex case, check that a controlled + -- component of a controlled object gets processed correctly + + procedure Check_Nested_Objects is + NO1 : C760001_1.Nested_Controlled; + begin + TCTouch.Assert((NO1.My_ID < NO1.My_Init_Id), + "Default value order incorrect"); + TCTouch.Assert((NO1.My_Init_Id > NO1.Nested.My_Init_ID), + "Initialization call order incorrect"); + end Check_Nested_Objects; + + -- check that objects assigned an initial value at declaration are Adjusted + -- and NOT Initialized + + procedure Check_Objects_With_Initial_Values is + + TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; + + A: C760001_1.Test_Controlled := + ( Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_1.None); + + B: C760001_1.Nested_Controlled := + ( Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_0.Root_Controlled(A), + C760001_1.None); + + begin + -- the implementation may or may not call Adjust for the values + -- assigned into A and B, + -- but should NOT call Initialize. + -- if the value used in the aggregate is overwritten by Initialize, + -- this indicates failure + TCTouch.Assert(A.My_Init_Id = TC_Now, + "Initialize was called for A with initial value"); + TCTouch.Assert(B.My_Init_Id = TC_Now, + "Initialize was called for B with initial value"); + TCTouch.Assert(B.Nested.My_Init_ID = TC_Now, + "Initialize was called for B.Nested initial value"); + end Check_Objects_With_Initial_Values; + + procedure Check_Array_Case is + type Array_Simple is array(1..4) of C760001_1.Test_Controlled; + type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; + + Simple_Array_Default : Array_Simple; + + Nested_Array_Default : Array_Nested; + + TC_A_Bit_Later : C760001_0.Unique_ID; + + begin + TC_A_Bit_Later := C760001_0.Unique_Value; + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Default(N).Last_Proc_Called + = C760001_1.Init, + "Initialize for array initial value"); + + TCTouch.Assert( (Simple_Array_Default(N).My_Init_ID + > C760001_0.Unique_ID'First) + and (Simple_Array_Default(N).My_Init_ID + < TC_A_Bit_Later), + "Initialize timing for simple array"); + + TCTouch.Assert( (Nested_Array_Default(N).My_Init_ID + > C760001_0.Unique_ID'First) + and (Nested_Array_Default(N).My_Init_ID + < TC_A_Bit_Later), + "Initialize timing for container array"); + + TCTouch.Assert(Nested_Array_Default(N).Last_Proc_Called + = C760001_1.Init, + "Initialize for nested array (outer) initial value"); + + TCTouch.Assert( (Nested_Array_Default(N).Nested.My_Init_ID + > C760001_0.Unique_ID'First) + and (Nested_Array_Default(N).Nested.My_Init_ID + < Nested_Array_Default(N).My_Init_ID), + "Initialize timing for array content"); + end loop; + end Check_Array_Case; + + procedure Check_Array_Case_With_Initial_Values is + + TC_Now : constant C760001_0.Unique_ID := C760001_0.Unique_Value; + + type Array_Simple is array(1..4) of C760001_1.Test_Controlled; + type Array_Nested is array(1..4) of C760001_1.Nested_Controlled; + + Simple_Array_Explicit : Array_Simple := ( 1..4 => ( + Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + C760001_1.None ) ); + + A : constant C760001_0.Root_Controlled := + ( Ada.Finalization.Controlled + with others => TC_Now); + + Nested_Array_Explicit : Array_Nested := ( 1..4 => ( + Ada.Finalization.Controlled + with TC_Now, + TC_Now, + TC_Now, + A, + C760001_1.None ) ); + + begin + -- the implementation may or may not call Adjust for the values + -- assigned into Simple_Array_Explicit and Nested_Array_Explicit, + -- but should NOT call Initialize. + -- if the value used in the aggregate is overwritten by Initialize, + -- this indicates failure + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Explicit(N).My_Init_ID + = TC_Now, + "Initialize was called for array with initial value"); + TCTouch.Assert(Nested_Array_Explicit(N).My_Init_ID + = TC_Now, + "Initialize was called for nested array (outer) with initial value"); + TCTouch.Assert(Nested_Array_Explicit(N).Nested.My_Init_ID = TC_Now, + "Initialize was called for nested array (inner) with initial value"); + end loop; + end Check_Array_Case_With_Initial_Values; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("C760001", "Check that Initialize is called for objects " & + "and components of a controlled type when the " & + "objects and components are not assigned " & + "explicit initial values. Check that if an " & + "explicit initial value is assigned to an " & + "object or component of a controlled type " & + "then Initialize is not called" ); + + Check_Simple_Objects; + + Check_Nested_Objects; + + Check_Array_Case; + + C760001_0.TC_Initialize_Calls_Is_Failing := True; + + Check_Objects_With_Initial_Values; + + Check_Array_Case_With_Initial_Values; + + Report.Result; + + end C760001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760002.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,489 ---- + -- C760002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that assignment to an object of a (non-limited) controlled + -- type causes the Adjust operation of the type to be called. + -- Check that Adjust is called after copying the value of the + -- source expression to the target object. + -- + -- Check that Adjust is called for all controlled components when + -- the containing object is assigned. (Test this for the cases + -- where the type of the containing object is controlled and + -- noncontrolled; test this for initialization as well as + -- assignment statements.) + -- + -- Check that for an object of a controlled type with controlled + -- components, Adjust for each of the components is called before + -- the containing object is adjusted. + -- + -- Check that an Adjust procedure for a Limited_Controlled type is + -- not called by the implementation. + -- + -- TEST DESCRIPTION: + -- This test is loosely "derived" from C760001. + -- + -- Visit Tags: + -- D - Default value at declaration + -- d - Default value at declaration, limited root + -- I - initialize at root controlled + -- i - initialize at root limited controlled + -- A - adjust at root controlled + -- X,Y,Z,x,y,z - used in test body + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Correct test assertion logic for Sinister case + -- + --! + + ---------------------------------------------------------------- C760002_0 + + with Ada.Finalization; + package C760002_0 is + subtype Unique_ID is Natural; + function Unique_Value return Unique_ID; + -- increments each time it's called + + function Most_Recent_Unique_Value return Unique_ID; + -- returns the same value as the most recent call to Unique_Value + + type Root is tagged record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; -- Default + end record; + + procedure Initialize( R: in out Root ); + procedure Adjust ( R: in out Root ); + + type Root_Controlled is new Ada.Finalization.Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'D'; ---------------------------------------- D + end record; + + procedure Initialize( R: in out Root_Controlled ); + procedure Adjust ( R: in out Root_Controlled ); + + type Root_Limited_Controlled is + new Ada.Finalization.Limited_Controlled with record + My_ID : Unique_ID := Unique_Value; + Visit_Tag : Character := 'd'; ---------------------------------------- d + end record; + + procedure Initialize( R: in out Root_Limited_Controlled ); + procedure Adjust ( R: in out Root_Limited_Controlled ); + + end C760002_0; + + with Report; + package body C760002_0 is + + Global_Unique_Counter : Unique_ID := 0; + + function Unique_Value return Unique_ID is + begin + Global_Unique_Counter := Global_Unique_Counter +1; + return Global_Unique_Counter; + end Unique_Value; + + function Most_Recent_Unique_Value return Unique_ID is + begin + return Global_Unique_Counter; + end Most_Recent_Unique_Value; + + procedure Initialize( R: in out Root ) is + begin + Report.Failed("Initialize called for Non_Controlled type"); + end Initialize; + + procedure Adjust ( R: in out Root ) is + begin + Report.Failed("Adjust called for Non_Controlled type"); + end Adjust; + + procedure Initialize( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'I'; --------------------------------------------------- I + end Initialize; + + procedure Adjust( R: in out Root_Controlled ) is + begin + R.Visit_Tag := 'A'; --------------------------------------------------- A + end Adjust; + + procedure Initialize( R: in out Root_Limited_Controlled ) is + begin + R.Visit_Tag := 'i'; --------------------------------------------------- i + end Initialize; + + procedure Adjust( R: in out Root_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Limited_Controlled type"); + end Adjust; + + end C760002_0; + + ---------------------------------------------------------------- C760002_1 + + with Ada.Finalization; + with C760002_0; + package C760002_1 is + + type Proc_ID is (None, Init, Adj, Fin); + + type Test_Controlled is new C760002_0.Root_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Controlled ); + procedure Adjust ( TC: in out Test_Controlled ); + procedure Finalize ( TC: in out Test_Controlled ); + + type Nested_Controlled is new C760002_0.Root_Controlled with record + Nested : C760002_0.Root_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Controlled ); + procedure Adjust ( TC: in out Nested_Controlled ); + procedure Finalize ( TC: in out Nested_Controlled ); + + type Test_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Test_Limited_Controlled ); + procedure Adjust ( TC: in out Test_Limited_Controlled ); + procedure Finalize ( TC: in out Test_Limited_Controlled ); + + type Nested_Limited_Controlled is + new C760002_0.Root_Limited_Controlled with record + Nested : C760002_0.Root_Limited_Controlled; + Last_Proc_Called: Proc_ID := None; + end record; + + procedure Initialize( TC: in out Nested_Limited_Controlled ); + procedure Adjust ( TC: in out Nested_Limited_Controlled ); + procedure Finalize ( TC: in out Nested_Limited_Controlled ); + + end C760002_1; + + with Report; + package body C760002_1 is + + procedure Initialize( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Test_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Adj; + C760002_0.Adjust(C760002_0.Root_Controlled(TC)); + end Adjust; + + procedure Finalize ( TC: in out Nested_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Test_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Test_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Test_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + procedure Initialize( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Init; + C760002_0.Initialize(C760002_0.Root_Limited_Controlled(TC)); + end Initialize; + + procedure Adjust ( TC: in out Nested_Limited_Controlled ) is + begin + Report.Failed("Adjust called for Nested_Limited_Controlled"); + end Adjust; + + procedure Finalize ( TC: in out Nested_Limited_Controlled ) is + begin + TC.Last_Proc_Called := Fin; + end Finalize; + + end C760002_1; + + ---------------------------------------------------------------- C760002 + + with Report; + with TCTouch; + with C760002_0; + with C760002_1; + with Ada.Finalization; + procedure C760002 is + + use type C760002_1.Proc_ID; + + -- in the first test, test the simple cases. + -- Also check that assignment causes a call to Adjust for a controlled + -- object. Check that assignment of a non-controlled object does not call + -- an Adjust procedure. + + procedure Check_Simple_Objects is + + A,B : C760002_0.Root; + S,T : C760002_1.Test_Controlled; + Q : C760002_1.Test_Limited_Controlled; -- Adjust call shouldn't happen + begin + + S := T; + + TCTouch.Assert((S.Last_Proc_Called = C760002_1.Adj), + "Adjust for simple object"); + TCTouch.Assert((S.My_ID = T.My_ID), + "Assignment failed for simple object"); + + -- Check that adjust was called + TCTouch.Assert((S.Visit_Tag = 'A'), "Adjust timing incorrect"); + + -- Check that Adjust has not been called + TCTouch.Assert_Not((T.Visit_Tag = 'A'), "Adjust incorrectly called"); + + -- Check that Adjust does not get called + A.My_ID := A.My_ID +1; + B := A; -- see: Adjust: Report.Failed + + end Check_Simple_Objects; + + -- in the second test, test a more complex case, check that a controlled + -- component of a controlled object gets processed correctly + + procedure Check_Nested_Objects is + NO1 : C760002_1.Nested_Controlled; + NO2 : C760002_1.Nested_Controlled := NO1; + + begin + + -- NO2 should be flagged with adjust markers + TCTouch.Assert((NO2.Last_Proc_Called = C760002_1.Adj), + "Adjust not called for NO2 enclosure declaration"); + TCTouch.Assert((NO2.Nested.Visit_Tag = 'A'), + "Adjust not called for NO2 enclosed declaration"); + + NO2.Visit_Tag := 'x'; + NO2.Nested.Visit_Tag := 'y'; + + NO1 := NO2; + + -- NO1 should be flagged with adjust markers + TCTouch.Assert((NO1.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosure declaration"); + TCTouch.Assert((NO1.Nested.Visit_Tag = 'A'), + "Adjust not called for NO1 enclosed declaration"); + + end Check_Nested_Objects; + + procedure Check_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Controlled; + type Array_Nested is array(1..4) of C760002_1.Nested_Controlled; + + Left,Right : Array_Simple; + Overlap : Array_Simple := Left; + + Sinister,Dexter : Array_Nested; + Underlap : Array_Nested := Sinister; + + Now : Natural; + + begin + + -- get a current unique value since initializations + Now := C760002_0.Unique_Value; + + -- check results of declarations + for N in 1..4 loop + TCTouch.Assert(Left(N).My_Id < Now, + "Initialize for array initial value"); + TCTouch.Assert(Overlap(N).My_Id < Now, + "Adjust for nested array (outer) initial value"); + TCTouch.Assert(Sinister(N).Nested.My_Id < Now, + "Initialize for nested array (inner) initial value"); + TCTouch.Assert(Sinister(N).My_Id < Sinister(N).Nested.My_Id, + "Initialize for enclosure should be after enclosed"); + TCTouch.Assert(Overlap(N).Visit_Tag = 'A',"Adjust at declaration"); + TCTouch.Assert(Underlap(N).Nested.Visit_Tag = 'A', + "Adjust at declaration, nested object"); + end loop; + + -- set visit tags + for O in 1..4 loop + Overlap(O).Visit_Tag := 'X'; + Underlap(O).Visit_Tag := 'Y'; + Underlap(O).Nested.Visit_Tag := 'y'; + end loop; + + -- check that overlapping assignments don't cause odd grief + Overlap(1..3) := Overlap(2..4); + Underlap(2..4) := Underlap(1..3); + + for M in 2..3 loop + TCTouch.Assert(Overlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for overlap"); + TCTouch.Assert(Overlap(M).Visit_Tag = 'A', + "Adjust for overlap ID"); + TCTouch.Assert(Underlap(M).Last_Proc_Called = C760002_1.Adj, + "Adjust for Underlap"); + TCTouch.Assert(Underlap(M).Nested.Visit_Tag = 'A', + "Adjust for Underlaps nested ID"); + end loop; + + end Check_Array_Case; + + procedure Check_Access_Case is + type TC_Ref is access C760002_1.Test_Controlled; + type NC_Ref is access C760002_1.Nested_Controlled; + type TL_Ref is access C760002_1.Test_Limited_Controlled; + type NL_Ref is access C760002_1.Nested_Limited_Controlled; + + A,B : TC_Ref; + C,D : NC_Ref; + E : TL_Ref; + F : NL_Ref; + + begin + + A := new C760002_1.Test_Controlled; + B := new C760002_1.Test_Controlled'( A.all ); + + C := new C760002_1.Nested_Controlled; + D := new C760002_1.Nested_Controlled'( C.all ); + + E := new C760002_1.Test_Limited_Controlled; + F := new C760002_1.Nested_Limited_Controlled; + + TCTouch.Assert(A.Visit_Tag = 'I',"TC Allocation"); + TCTouch.Assert(B.Visit_Tag = 'A',"TC Allocation, with value"); + + TCTouch.Assert(C.Visit_Tag = 'I',"NC Allocation"); + TCTouch.Assert(C.Nested.Visit_Tag = 'I',"NC Allocation, Nested"); + TCTouch.Assert(D.Visit_Tag = 'A',"NC Allocation, with value"); + TCTouch.Assert(D.Nested.Visit_Tag = 'A', + "NC Allocation, Nested, with value"); + + TCTouch.Assert(E.Visit_Tag = 'i',"TL Allocation"); + TCTouch.Assert(F.Visit_Tag = 'i',"NL Allocation"); + + A.all := B.all; + C.all := D.all; + + TCTouch.Assert(A.Visit_Tag = 'A',"TC Assignment"); + TCTouch.Assert(C.Visit_Tag = 'A',"NC Assignment"); + TCTouch.Assert(C.Nested.Visit_Tag = 'A',"NC Assignment, Nested"); + + end Check_Access_Case; + + procedure Check_Access_Limited_Array_Case is + type Array_Simple is array(1..4) of C760002_1.Test_Limited_Controlled; + type AS_Ref is access Array_Simple; + type Array_Nested is array(1..4) of C760002_1.Nested_Limited_Controlled; + type AN_Ref is access Array_Nested; + + Simple_Array_Limited : AS_Ref; + + Nested_Array_Limited : AN_Ref; + + begin + + Simple_Array_Limited := new Array_Simple; + + Nested_Array_Limited := new Array_Nested; + + for N in 1..4 loop + TCTouch.Assert(Simple_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for array initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Last_Proc_Called + = C760002_1.Init, + "Initialize for nested array (outer) initial value"); + TCTouch.Assert(Nested_Array_Limited(N).Nested.Visit_Tag = 'i', + "Initialize for nested array (inner) initial value"); + end loop; + end Check_Access_Limited_Array_Case; + + begin -- Main test procedure. + + Report.Test ("C760002", "Check that assignment causes the Adjust " & + "operation of the type to be called. Check " & + "that Adjust is called after copying the " & + "value of the source expression to the target " & + "object. Check that Adjust is called for all " & + "controlled components when the containing " & + "object is assigned. Check that Adjust is " & + "called for components before the containing " & + "object is adjusted. Check that Adjust is not " & + "called for a Limited_Controlled type by the " & + "implementation" ); + + Check_Simple_Objects; + + Check_Nested_Objects; + + Check_Array_Case; + + Check_Access_Case; + + Check_Access_Limited_Array_Case; + + Report.Result; + + end C760002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760007.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,247 ---- + -- C760007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Adjust is called for the execution of a return + -- statement for a function returning a result of a (non-limited) + -- controlled type. + -- + -- Check that Adjust is called when evaluating an aggregate + -- component association for a controlled component. + -- + -- Check that Adjust is called for the assignment of the ancestor + -- expression of an extension aggregate when the type of the + -- aggregate is controlled. + -- + -- TEST DESCRIPTION: + -- A type is derived from Ada.Finalization.Controlled; the dispatching + -- procedure Adjust is defined for the new type. Structures and + -- subprograms to model the test objectives are used to check that + -- Adjust is called at the right time. For the sake of simplicity, + -- globally accessible data is used to check that the calls are made. + -- + -- + -- CHANGE HISTORY: + -- 06 DEC 94 SAIC ACVC 2.0 + -- 14 OCT 95 SAIC Update and repair for ACVC 2.0.1 + -- 05 APR 96 SAIC Add RM reference + -- 06 NOV 96 SAIC Reduce adjust requirement + -- 25 NOV 97 EDS Allowed zero calls to adjust at line 144 + --! + + ---------------------------------------------------------------- C760007_0 + + with Ada.Finalization; + package C760007_0 is + + type Controlled is new Ada.Finalization.Controlled with record + TC_ID : Natural := Natural'Last; + end record; + procedure Adjust( Object: in out Controlled ); + + type Structure is record + Controlled_Component : Controlled; + end record; + + type Child is new Controlled with record + TC_XX : Natural := Natural'Last; + end record; + procedure Adjust( Object: in out Child ); + + Adjust_Count : Natural := 0; + Child_Adjust_Count : Natural := 0; + + end C760007_0; + + package body C760007_0 is + + procedure Adjust( Object: in out Controlled ) is + begin + Adjust_Count := Adjust_Count +1; + end Adjust; + + procedure Adjust( Object: in out Child ) is + begin + Child_Adjust_Count := Child_Adjust_Count +1; + end Adjust; + + end C760007_0; + + ------------------------------------------------------------------ C760007 + + with Report; + with C760007_0; + procedure C760007 is + + procedure Check_Adjust_Count(Message: String; + Min: Natural := 1; + Max: Natural := 2) is + begin + + -- in order to allow for the anonymous objects referred to in + -- the reference manual, the check for calls to Adjust must be + -- in a range. This number must then be further adjusted + -- to allow for the optimization that does not call for an adjust + -- of an aggregate initial value built directly in the object + + if C760007_0.Adjust_Count not in Min..Max then + Report.Failed(Message + & " = " & Natural'Image(C760007_0.Adjust_Count)); + end if; + C760007_0.Adjust_Count := 0; + end Check_Adjust_Count; + + procedure Check_Child_Adjust_Count(Message: String; + Min: Natural := 1; + Max: Natural := 2) is + begin + -- ditto above + + if C760007_0.Child_Adjust_Count not in Min..Max then + Report.Failed(Message + & " = " & Natural'Image(C760007_0.Child_Adjust_Count)); + end if; + C760007_0.Child_Adjust_Count := 0; + end Check_Child_Adjust_Count; + + Object : C760007_0.Controlled; + + -- Check that Adjust is called for the execution of a return + -- statement for a function returning a result of a (non-limited) + -- controlled type or a result of a noncontrolled type with + -- controlled components. + + procedure Subtest_1 is + function Create return C760007_0.Controlled is + New_Object : C760007_0.Controlled; + begin + return New_Object; + end Create; + + procedure Examine( Thing : in C760007_0.Controlled ) is + begin + Check_Adjust_Count("Function call passed as parameter",0); + end Examine; + + begin + -- this assignment must call Adjust: + -- 1: on the value resulting from the function + -- ** unless this is optimized out by building the result directly + -- in the target object. + -- 2: on Object once it's been assigned + -- may call adjust + -- 1: for a anonymous object created in the evaluation of the function + -- 2: for a anonymous object created in the assignment operation + + Object := Create; + + Check_Adjust_Count("Function call",1,4); + + Examine( Create ); + + end Subtest_1; + + -- Check that Adjust is called when evaluating an aggregate + -- component association for a controlled component. + + procedure Subtest_2 is + S : C760007_0.Structure; + + procedure Examine( Thing : in C760007_0.Structure ) is + begin + Check_Adjust_Count("Aggregate passed as parameter"); + end Examine; + + begin + -- this assignment must call Adjust: + -- 1: on the value resulting from the aggregate + -- ** unless this is optimized out by building the result directly + -- in the target object. + -- 2: on Object once it's been assigned + -- may call adjust + -- 1: for a anonymous object created in the evaluation of the aggregate + -- 2: for a anonymous object created in the assignment operation + S := ( Controlled_Component => Object ); + Check_Adjust_Count("Aggregate and Assignment", 1, 4); + + Examine( C760007_0.Structure'(Controlled_Component => Object) ); + end Subtest_2; + + -- Check that Adjust is called for the assignment of the ancestor + -- expression of an extension aggregate when the type of the + -- aggregate is controlled. + + procedure Subtest_3 is + Bambino : C760007_0.Child; + + procedure Examine( Thing : in C760007_0.Child ) is + begin + Check_Adjust_Count("Extension aggregate as parameter (ancestor)", 0, 2); + Check_Child_Adjust_Count("Extension aggregate as parameter", 0, 4); + end Examine; + + begin + -- implementation permissions make all of the following calls to adjust + -- optional: + -- these assignments may call Adjust: + -- 1: on the value resulting from the aggregate + -- 2: on Object once it's been assigned + -- 3: for a anonymous object created in the evaluation of the aggregate + -- 4: for a anonymous object created in the assignment operation + Bambino := ( Object with TC_XX => 10 ); + Check_Adjust_Count("Ancestor (expression) part of aggregate", 0, 2); + Check_Child_Adjust_Count("Child aggregate assignment 1", 0, 4 ); + + Bambino := ( C760007_0.Controlled with TC_XX => 11 ); + Check_Adjust_Count("Ancestor (subtype_mark) part of aggregate", 0, 2); + Check_Child_Adjust_Count("Child aggregate assignment 2", 0, 4 ); + + Examine( ( Object with TC_XX => 21 ) ); + + Examine( ( C760007_0.Controlled with TC_XX => 37 ) ); + + end Subtest_3; + + begin -- Main test procedure. + + Report.Test ("C760007", "Check that Adjust is called for the " & + "execution of a return statement for a " & + "function returning a result containing a " & + "controlled type. Check that Adjust is " & + "called when evaluating an aggregate " & + "component association for a controlled " & + "component. " & + "Check that Adjust is called for the " & + "assignment of the ancestor expression of an " & + "extension aggregate when the type of the " & + "aggregate is controlled" ); + + Subtest_1; + Subtest_2; + Subtest_3; + + Report.Result; + + end C760007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760009.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,533 ---- + -- C760009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for an extension_aggregate whose ancestor_part is a + -- subtype_mark (i.e. Typemark'( Subtype with Field => x, etc.) ) + -- Initialize is called on all controlled subcomponents of the + -- ancestor part; if the type of the ancestor part is itself controlled, + -- the Initialize procedure of the ancestor type is called, unless that + -- Initialize procedure is abstract. + -- + -- Check that the utilization of a controlled type for a generic actual + -- parameter supports the correct behavior in the instantiated package. + -- + -- TEST DESCRIPTION: + -- Declares a generic package instantiated to check that controlled + -- types are not impacted by the "generic boundary." + -- This instance is then used to perform the tests of various + -- aggregate formations of the controlled type. After each operation + -- in the main program that should cause implicit calls, the "state" of + -- the software is checked. The "state" of the software is maintained in + -- several variables which count the calls to the Initialize, Adjust and + -- Finalize procedures in each context. Given the nature of the + -- language rules, the test specifies a minimum number of times that + -- these subprograms should have been called. The test also checks cases + -- where the subprograms should not have been called. + -- + -- As per the example in AARM 7.6(11a..d);6.0, the distinctions between + -- the presence/absence of default values is tested. + -- + -- DATA STRUCTURES + -- + -- C760009_3.Master_Control is derived from + -- C760009_2.Control is derived from + -- Ada.Finalization.Controlled + -- + -- C760009_1.Simple_Control is derived from + -- Ada.Finalization.Controlled + -- + -- C760009_3.Master_Control contains + -- Standard.Integer + -- + -- C760009_2.Control contains + -- C760009_1.Simple_Control (default value) + -- C760009_1.Simple_Control (default initialized) + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 SAIC Initial version + -- 19 FEB 96 SAIC Fixed elaboration Initialize count + -- 14 NOV 96 SAIC Allowed for 7.6(21) optimizations + -- 13 FEB 97 PWB.CTA Initialized counters at lines 127-129 + -- 26 JUN 98 EDS Added pragma Elaborate_Body to C760009_0 + -- to avoid possible instantiation error + --! + + ---------------------------------------------------------------- C760009_0 + + with Ada.Finalization; + generic + + type Private_Formal is private; + + with procedure TC_Validate( APF: in out Private_Formal ); + + package C760009_0 is -- Check_1 + + pragma Elaborate_Body; + procedure TC_Check_1( APF: in Private_Formal ); + procedure TC_Check_2( APF: out Private_Formal ); + procedure TC_Check_3( APF: in out Private_Formal ); + + end C760009_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760009_0 is -- Check_1 + + procedure TC_Check_1( APF: in Private_Formal ) is + Local : Private_Formal; + begin + Local := APF; + TC_Validate( Local ); + end TC_Check_1; + + procedure TC_Check_2( APF: out Private_Formal ) is + Local : Private_Formal; -- initialized by virtue of actual being + -- Controlled + begin + APF := Local; + TC_Validate( APF ); + end TC_Check_2; + + procedure TC_Check_3( APF: in out Private_Formal ) is + Local : Private_Formal; + begin + Local := APF; + TC_Validate( Local ); + end TC_Check_3; + + end C760009_0; + + ---------------------------------------------------------------- C760009_1 + + with Ada.Finalization; + package C760009_1 is + + Initialize_Called : Natural := 0; + Adjust_Called : Natural := 0; + Finalize_Called : Natural := 0; + + procedure Reset_Counters; + + type Simple_Control is new Ada.Finalization.Controlled with private; + + procedure Initialize( AV: in out Simple_Control ); + procedure Adjust ( AV: in out Simple_Control ); + procedure Finalize ( AV: in out Simple_Control ); + procedure Validate ( AV: in out Simple_Control ); + + function Item( AV: Simple_Control'Class ) return String; + + Empty : constant Simple_Control; + + procedure TC_Trace( Message: String ); + + private + type Simple_Control is new Ada.Finalization.Controlled with record + Item: Natural; + end record; + + Empty : constant Simple_Control := ( Ada.Finalization.Controlled with 0 ); + + end C760009_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760009_1 is + + -- Maintenance_Mode and TC_Trace are for the test writers and compiler + -- developers to get more information from this test as it executes. + -- Maintenance_Mode is always False for validation purposes. + + Maintenance_Mode : constant Boolean := False; + + procedure TC_Trace( Message: String ) is + begin + if Maintenance_Mode then + Report.Comment( Message ); + end if; + end TC_Trace; + + procedure Reset_Counters is + begin + Initialize_Called := 0; + Adjust_Called := 0; + Finalize_Called := 0; + end Reset_Counters; + + Master_Count : Natural := 100; -- Help distinguish values + + procedure Initialize( AV: in out Simple_Control ) is + begin + Initialize_Called := Initialize_Called +1; + AV.Item := Master_Count; + Master_Count := Master_Count +100; + TC_Trace( "Initialize _1.Simple_Control" ); + end Initialize; + + procedure Adjust ( AV: in out Simple_Control ) is + begin + Adjust_Called := Adjust_Called +1; + AV.Item := AV.Item +1; + TC_Trace( "Adjust _1.Simple_Control" ); + end Adjust; + + procedure Finalize ( AV: in out Simple_Control ) is + begin + Finalize_Called := Finalize_Called +1; + AV.Item := AV.Item +1; + TC_Trace( "Finalize _1.Simple_Control" ); + end Finalize; + + procedure Validate ( AV: in out Simple_Control ) is + begin + Report.Failed("Attempt to Validate at Simple_Control level"); + end Validate; + + function Item( AV: Simple_Control'Class ) return String is + begin + return Natural'Image(AV.Item); + end Item; + + end C760009_1; + + ---------------------------------------------------------------- C760009_2 + + with C760009_1; + with Ada.Finalization; + package C760009_2 is + + type Control is new Ada.Finalization.Controlled with record + Element_1 : C760009_1.Simple_Control; + Element_2 : C760009_1.Simple_Control := C760009_1.Empty; + end record; + + procedure Initialize( AV: in out Control ); + procedure Finalize ( AV: in out Control ); + + Initialized : Natural := 0; + Finalized : Natural := 0; + + end C760009_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C760009_2 is + + procedure Initialize( AV: in out Control ) is + begin + Initialized := Initialized +1; + C760009_1.TC_Trace( "Initialize _2.Control" ); + end Initialize; + + procedure Finalize ( AV: in out Control ) is + begin + Finalized := Finalized +1; + C760009_1.TC_Trace( "Finalize _2.Control" ); + end Finalize; + + end C760009_2; + + ---------------------------------------------------------------- C760009_3 + + with C760009_0; + with C760009_2; + package C760009_3 is + + type Master_Control is new C760009_2.Control with record + Data: Integer; + end record; + + procedure Initialize( AC: in out Master_Control ); + -- calls C760009_2.Initialize + -- embedded data causes 1 call to C760009_1.Initialize + + -- Adjusting operation will + -- make 1 call to C760009_2.Adjust + -- make 2 call to C760009_1.Adjust + + -- Finalize operation will + -- make 1 call to C760009_2.Finalize + -- make 2 call to C760009_1.Finalize + + procedure Validate( AC: in out Master_Control ); + + package Check_1 is + new C760009_0(Master_Control, Validate); + + end C760009_3; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with C760009_1; + package body C760009_3 is + + procedure Initialize( AC: in out Master_Control ) is + begin + AC.Data := 42; + C760009_2.Initialize(C760009_2.Control(AC)); + C760009_1.TC_Trace( "Initialize Master_Control" ); + end Initialize; + + procedure Validate( AC: in out Master_Control ) is + begin + if AC.Data not in 0..1000 then + Report.Failed("C760009_3.Control did not Initialize" ); + end if; + end Validate; + + end C760009_3; + + --------------------------------------------------------------------- C760009 + + with Report; + with C760009_1; + with C760009_2; + with C760009_3; + procedure C760009 is + + -- Comment following declaration indicates expected calls in the order: + -- Initialize of a C760009_2 value + -- Finalize of a C760009_2 value + -- Initialize of a C760009_1 value + -- Adjust of a C760009_1 value + -- Finalize of a C760009_1 value + + Global_Control : C760009_3.Master_Control; + -- 1, 0, 1, 1, 0 + + Parent_Control : C760009_2.Control; + -- 1, 0, 1, 1, 0 + + -- Global_Control is a derived tagged type, the parent type + -- of Master_Control, Control, is derived from Controlled, and contains + -- two components of a Controlled type, Simple_Control. One of these + -- components has a default value, the other does not. + + procedure Fail( Which: String; Expect, Got: Natural ) is + begin + Report.Failed(Which & " Expected" & Natural'Image(Expect) + & " got" & Natural'Image(Got) ); + end Fail; + + procedure Master_Assertion( Layer_2_Inits : Natural; + Layer_2_Finals : Natural; + Layer_1_Inits : Natural; + Layer_1_Adjs : Natural; + Layer_1_Finals : Natural; + Failing_Message : String ) is + + begin + + + + if C760009_2.Initialized /= Layer_2_Inits then + Fail("C760009_2.Initialize " & Failing_Message, + Layer_2_Inits, C760009_2.Initialized ); + end if; + + if C760009_2.Finalized not in Layer_2_Finals..Layer_2_Finals*2 then + Fail("C760009_2.Finalize " & Failing_Message, + Layer_2_Finals, C760009_2.Finalized ); + end if; + + if C760009_1.Initialize_Called /= Layer_1_Inits then + Fail("C760009_1.Initialize " & Failing_Message, + Layer_1_Inits, + C760009_1.Initialize_Called ); + end if; + + if C760009_1.Adjust_Called not in Layer_1_Adjs..Layer_1_Adjs*2 then + Fail("C760009_1.Adjust " & Failing_Message, + Layer_1_Adjs, C760009_1.Adjust_Called ); + end if; + + if C760009_1.Finalize_Called not in Layer_1_Finals..Layer_1_Finals*2 then + Fail("C760009_1.Finalize " & Failing_Message, + Layer_1_Finals, C760009_1.Finalize_Called ); + end if; + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + end Master_Assertion; + + procedure Lesser_Assertion( Layer_2_Inits : Natural; + Layer_2_Finals : Natural; + Layer_1_Inits : Natural; + Layer_1_Adjs : Natural; + Layer_1_Finals : Natural; + Failing_Message : String ) is + begin + + + if C760009_2.Initialized > Layer_2_Inits then + Fail("C760009_2.Initialize " & Failing_Message, + Layer_2_Inits, C760009_2.Initialized ); + end if; + + if C760009_2.Finalized < Layer_2_Inits + or C760009_2.Finalized > Layer_2_Finals*2 then + Fail("C760009_2.Finalize " & Failing_Message, + Layer_2_Finals, C760009_2.Finalized ); + end if; + + if C760009_1.Initialize_Called > Layer_1_Inits then + Fail("C760009_1.Initialize " & Failing_Message, + Layer_1_Inits, + C760009_1.Initialize_Called ); + end if; + + if C760009_1.Adjust_Called > Layer_1_Adjs*2 then + Fail("C760009_1.Adjust " & Failing_Message, + Layer_1_Adjs, C760009_1.Adjust_Called ); + end if; + + if C760009_1.Finalize_Called < Layer_1_Inits + or C760009_1.Finalize_Called > Layer_1_Finals*2 then + Fail("C760009_1.Finalize " & Failing_Message, + Layer_1_Finals, C760009_1.Finalize_Called ); + end if; + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + end Lesser_Assertion; + + begin -- Main test procedure. + + Report.Test ("C760009", "Check that for an extension_aggregate whose " & + "ancestor_part is a subtype_mark, Initialize " & + "is called on all controlled subcomponents of " & + "the ancestor part. Also check that the " & + "utilization of a controlled type for a generic " & + "actual parameter supports the correct behavior " & + "in the instantiated software" ); + + C760009_1.TC_Trace( "=====> Case 0 <=====" ); + + C760009_1.Reset_Counters; + C760009_2.Initialized := 0; + C760009_2.Finalized := 0; + + C760009_3.Validate( Global_Control ); -- check that it Initialized correctly + + C760009_1.TC_Trace( "=====> Case 1 <=====" ); + + C760009_3.Check_1.TC_Check_1( ( C760009_2.Control with Data => 1 ) ); + Lesser_Assertion( 2, 3, 2, 3, 6, "Check_1.TC_Check_1" ); + -- | | | | + Finalize 2 embedded in aggregate + -- | | | | + Finalize 2 at assignment in TC_Check_1 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 caused by assignment in TC_Check_1 + -- | | | + Adjust at declaration in TC_Check_1 + -- | | + Initialize at declaration in TC_Check_1 + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- | + Finalize of aggregate object + -- + Initialize of aggregate object + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 2 <=====" ); + + C760009_3.Check_1.TC_Check_2( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_2" ); + -- | | | | + Finalize 2 at assignment in TC_Check_2 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 caused by assignment in TC_Check_2 + -- | | | + Adjust at declaration in TC_Check_2 + -- | | + Initialize at declaration in TC_Check_2 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 3 <=====" ); + + Global_Control := ( C760009_2.Control with Data => 2 ); + Lesser_Assertion( 1, 1, 1, 3, 2, "Aggregate -> object" ); + -- | | | | + Finalize 2 by assignment + -- | | | + Adjust 2 caused by assignment + -- | | | + Adjust in aggregate creation + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- + Initialize of aggregate object + + + C760009_1.TC_Trace( "=====> Case 4 <=====" ); + + C760009_3.Check_1.TC_Check_3( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3" ); + -- | | | | + Finalize 2 at assignment in TC_Check_3 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 at assignment in TC_Check_3 + -- | | | + Adjust in local variable creation + -- | | + Initialize of local variable in TC_Check_3 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + C760009_1.TC_Trace( "=====> Case 5 <=====" ); + + Global_Control := ( Parent_Control with Data => 3 ); + Lesser_Assertion( 1, 1, 1, 3, 2, "Object Aggregate -> object" ); + -- | | | | + Finalize 2 by assignment + -- | | | + Adjust 2 caused by assignment + -- | | | + Adjust in aggregate creation + -- | | + Initialize of aggregate object + -- | + Finalize of assignment target + -- + Initialize of aggregate object + + + + C760009_1.TC_Trace( "=====> Case 6 <=====" ); + + -- perform this check a second time to make sure nothing is "remembered" + + C760009_3.Check_1.TC_Check_3( Global_Control ); + Master_Assertion( 1, 2, 1, 3, 4, "Check_1.TC_Check_3 second time" ); + -- | | | | + Finalize 2 at assignment in TC_Check_3 + -- | | | | + Finalize 2 embedded in local variable + -- | | | + Adjust 2 at assignment in TC_Check_3 + -- | | | + Adjust in local variable creation + -- | | + Initialize of local variable in TC_Check_3 + -- | + Finalize of assignment target + -- | + Finalize of local variable + -- + Initialize of local variable + + + Report.Result; + + end C760009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760010.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,418 ---- + -- C760010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that explicit calls to Initialize, Adjust and Finalize + -- procedures that raise exceptions propagate the exception raised, + -- not Program_Error. Check this for both a user defined exception + -- and a language defined exception. Check that implicit calls to + -- initialize procedures that raise an exception propagate the + -- exception raised, not Program_Error; + -- + -- Check that the utilization of a controlled type as the actual for + -- a generic formal tagged private parameter supports the correct + -- behavior in the instantiated software. + -- + -- TEST DESCRIPTION: + -- Declares a generic package instantiated to check that controlled + -- types are not impacted by the "generic boundary." + -- This instance is then used to perform the tests of various calls to + -- the procedures. After each operation in the main program that should + -- cause implicit calls where an exception is raised, the program handles + -- Program_Error. After each explicit call, the program handles the + -- Expected_Error. Handlers for the opposite exception are provided to + -- catch the obvious failure modes. The predefined exception + -- Tasking_Error is used to be certain that some other reason has not + -- raised a predefined exception. + -- + -- + -- DATA STRUCTURES + -- + -- C760010_1.Simple_Control is derived from + -- Ada.Finalization.Controlled + -- + -- C760010_2.Embedded_Derived is derived from C760010_1.Simple_Control + -- by way of generic instantiation + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 SAIC Initial version + -- 23 APR 96 SAIC Fix visibility problem for 2.1 + -- 14 NOV 96 SAIC Revisit for 2.1 release + -- 26 JUN 98 EDS Added pragma Elaborate_Body to + -- package C760010_0.Check_Formal_Tagged + -- to avoid possible instantiation error + --! + + ---------------------------------------------------------------- C760010_0 + + package C760010_0 is + + User_Defined_Exception : exception; + + type Actions is ( No_Action, + Init_Raise_User_Defined, Init_Raise_Standard, + Adj_Raise_User_Defined, Adj_Raise_Standard, + Fin_Raise_User_Defined, Fin_Raise_Standard ); + + Action : Actions := No_Action; + + function Unique return Natural; + + end C760010_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C760010_0 is + + Value : Natural := 101; + + function Unique return Natural is + begin + Value := Value +1; + return Value; + end Unique; + + end C760010_0; + + ---------------------------------------------------------------- C760010_0 + ------------------------------------------------------ Check_Formal_Tagged + + generic + + type Formal_Tagged is tagged private; + + package C760010_0.Check_Formal_Tagged is + + pragma Elaborate_Body; + + type Embedded_Derived is new Formal_Tagged with record + TC_Meaningless_Value : Natural := Unique; + end record; + + procedure Initialize( ED: in out Embedded_Derived ); + procedure Adjust ( ED: in out Embedded_Derived ); + procedure Finalize ( ED: in out Embedded_Derived ); + + end C760010_0.Check_Formal_Tagged; + + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760010_0.Check_Formal_Tagged is + + + procedure Initialize( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Init_Raise_User_Defined => raise User_Defined_Exception; + when Init_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Initialize; + + procedure Adjust ( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Adj_Raise_User_Defined => raise User_Defined_Exception; + when Adj_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Adjust; + + procedure Finalize ( ED: in out Embedded_Derived ) is + begin + ED.TC_Meaningless_Value := Unique; + case Action is + when Fin_Raise_User_Defined => raise User_Defined_Exception; + when Fin_Raise_Standard => raise Tasking_Error; + when others => null; + end case; + end Finalize; + + end C760010_0.Check_Formal_Tagged; + + ---------------------------------------------------------------- C760010_1 + + with Ada.Finalization; + package C760010_1 is + + procedure Check_Counters(Init,Adj,Fin : Natural; Message: String); + procedure Reset_Counters; + + type Simple_Control is new Ada.Finalization.Controlled with record + Item: Integer; + end record; + procedure Initialize( AV: in out Simple_Control ); + procedure Adjust ( AV: in out Simple_Control ); + procedure Finalize ( AV: in out Simple_Control ); + + end C760010_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760010_1 is + + Initialize_Called : Natural; + Adjust_Called : Natural; + Finalize_Called : Natural; + + procedure Check_Counters(Init,Adj,Fin : Natural; Message: String) is + begin + if Init /= Initialize_Called then + Report.Failed("Initialize mismatch " & Message); + end if; + if Adj /= Adjust_Called then + Report.Failed("Adjust mismatch " & Message); + end if; + if Fin /= Finalize_Called then + Report.Failed("Finalize mismatch " & Message); + end if; + end Check_Counters; + + procedure Reset_Counters is + begin + Initialize_Called := 0; + Adjust_Called := 0; + Finalize_Called := 0; + end Reset_Counters; + + procedure Initialize( AV: in out Simple_Control ) is + begin + Initialize_Called := Initialize_Called +1; + AV.Item := 0; + end Initialize; + + procedure Adjust ( AV: in out Simple_Control ) is + begin + Adjust_Called := Adjust_Called +1; + AV.Item := AV.Item +1; + end Adjust; + + procedure Finalize ( AV: in out Simple_Control ) is + begin + Finalize_Called := Finalize_Called +1; + AV.Item := AV.Item +1; + end Finalize; + + end C760010_1; + + ---------------------------------------------------------------- C760010_2 + + with C760010_0.Check_Formal_Tagged; + with C760010_1; + package C760010_2 is + new C760010_0.Check_Formal_Tagged(C760010_1.Simple_Control); + + --------------------------------------------------------------------------- + + with Report; + with C760010_0; + with C760010_1; + with C760010_2; + procedure C760010 is + + use type C760010_0.Actions; + + procedure Case_Failure(Message: String) is + begin + Report.Failed(Message & " for case " + & C760010_0.Actions'Image(C760010_0.Action) ); + end Case_Failure; + + procedure Check_Implicit_Initialize is + Item : C760010_2.Embedded_Derived; -- exception here propagates to + Gadget : C760010_2.Embedded_Derived; -- caller + begin + if C760010_0.Action + in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard + then + Case_Failure("Anticipated exception at implicit init"); + end if; + begin + Item := Gadget; -- exception here handled locally + if C760010_0.Action in C760010_0.Adj_Raise_User_Defined + .. C760010_0.Fin_Raise_Standard then + Case_Failure ("Anticipated exception at assignment"); + end if; + exception + when Program_Error => + if C760010_0.Action not in C760010_0.Adj_Raise_User_Defined + .. C760010_0.Fin_Raise_Standard then + Report.Failed("Program_Error in Check_Implicit_Initialize"); + end if; + when Tasking_Error => + Report.Failed("Tasking_Error in Check_Implicit_Initialize"); + when C760010_0.User_Defined_Exception => + Report.Failed("User_Error in Check_Implicit_Initialize"); + when others => + Report.Failed("Wrong exception Check_Implicit_Initialize"); + end; + end Check_Implicit_Initialize; + + --------------------------------------------------------------------------- + + Global_Item : C760010_2.Embedded_Derived; + + --------------------------------------------------------------------------- + + procedure Check_Explicit_Initialize is + begin + begin + C760010_2.Initialize( Global_Item ); + if C760010_0.Action + in C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard + then + Case_Failure("Anticipated exception at explicit init"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Initialize"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Init_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Initialize"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Init_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Initialize"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Initialize"); + end; + end Check_Explicit_Initialize; + + --------------------------------------------------------------------------- + + procedure Check_Explicit_Adjust is + begin + begin + C760010_2.Adjust( Global_Item ); + if C760010_0.Action + in C760010_0.Adj_Raise_User_Defined..C760010_0.Adj_Raise_Standard + then + Case_Failure("Anticipated exception at explicit Adjust"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Adjust"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Adj_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Adjust"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Adj_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Adjust"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Adjust"); + end; + end Check_Explicit_Adjust; + + --------------------------------------------------------------------------- + + procedure Check_Explicit_Finalize is + begin + begin + C760010_2.Finalize( Global_Item ); + if C760010_0.Action + in C760010_0.Fin_Raise_User_Defined..C760010_0.Fin_Raise_Standard + then + Case_Failure("Anticipated exception at explicit Finalize"); + end if; + exception + when Program_Error => + Report.Failed("Program_Error in Check_Explicit_Finalize"); + when Tasking_Error => + if C760010_0.Action /= C760010_0.Fin_Raise_Standard then + Report.Failed("Tasking_Error in Check_Explicit_Finalize"); + end if; + when C760010_0.User_Defined_Exception => + if C760010_0.Action /= C760010_0.Fin_Raise_User_Defined then + Report.Failed("User_Error in Check_Explicit_Finalize"); + end if; + when others => + Report.Failed("Wrong exception in Check_Explicit_Finalize"); + end; + end Check_Explicit_Finalize; + + --------------------------------------------------------------------------- + + begin -- Main test procedure. + + Report.Test ("C760010", "Check that explicit calls to finalization " & + "procedures that raise exceptions propagate " & + "the exception raised. Check the utilization " & + "of a controlled type as the actual for a " & + "generic formal tagged private parameter" ); + + for Act in C760010_0.Actions loop + C760010_1.Reset_Counters; + C760010_0.Action := Act; + + begin + Check_Implicit_Initialize; + if Act in + C760010_0.Init_Raise_User_Defined..C760010_0.Init_Raise_Standard then + Case_Failure("No exception at Check_Implicit_Initialize"); + end if; + exception + when Tasking_Error => + if Act /= C760010_0.Init_Raise_Standard then + Case_Failure("Tasking_Error at Check_Implicit_Initialize"); + end if; + when C760010_0.User_Defined_Exception => + if Act /= C760010_0.Init_Raise_User_Defined then + Case_Failure("User_Error at Check_Implicit_Initialize"); + end if; + when Program_Error => + -- If finalize raises an exception, all other object are finalized + -- first and Program_Error is raised upon leaving the master scope. + -- 7.6.1:14 + if Act not in C760010_0.Fin_Raise_User_Defined.. + C760010_0.Fin_Raise_Standard then + Case_Failure("Program_Error at Check_Implicit_Initialize"); + end if; + when others => + Case_Failure("Wrong exception at Check_Implicit_Initialize"); + end; + + Check_Explicit_Initialize; + Check_Explicit_Adjust; + Check_Explicit_Finalize; + + C760010_1.Check_Counters(0,0,0, C760010_0.Actions'Image(Act)); + + end loop; + + -- Set to No_Action to avoid exception in finalizing Global_Item + C760010_0.Action := C760010_0.No_Action; + + Report.Result; + + end C760010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760011.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,291 ---- + -- C760011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the anonymous objects of a controlled type associated with + -- function results and aggregates are finalized no later than the + -- end of the innermost enclosing declarative_item or statement. Also + -- check this for function calls and aggregates of a noncontrolled type + -- with controlled components. + -- + -- TEST DESCRIPTION: + -- This test defines a controlled type with a discriminant, the + -- discriminant is use as an index into a global table to indicate that + -- the object has been finalized. The controlled type is used as the + -- component of a non-controlled type, and the non-controlled type is + -- used for the same set of tests. Following is a table of the tests + -- performed and their associated tag character. + -- + -- 7.6(21) allows for the optimizations that remove these temporary + -- objects from ever existing. As such this test checks that in the + -- case the object was initialized (the only access we have to + -- determining if it ever existed) it must subsequently be finalized. + -- + -- CASE TABLE: + -- A - aggregate test, controlled + -- B - aggregate test, controlled + -- C - aggregate test, non_controlled + -- D - function test, controlled + -- E - function test, non_controlled + -- F - formal parameter function test, controlled + -- G - formal parameter aggregate test, controlled + -- H - formal parameter function test, non_controlled + -- I - formal parameter aggregate test, non_controlled + -- + -- X - scratch object, not consequential to the objective + -- Y - scratch object, not consequential to the objective + -- Z - scratch object, not consequential to the objective + -- + -- + -- CHANGE HISTORY: + -- 22 MAY 95 SAIC Initial version + -- 24 APR 96 SAIC Minor doc fixes, visibility patch + -- 14 NOV 96 SAIC Revised for release 2.1 + -- + --! + + ------------------------------------------------------------------- C760011_0 + + with Ada.Finalization; + package C760011_0 is + type Tracking_Array is array(Character range 'A'..'Z') of Boolean; + + Initialized : Tracking_Array := (others => False); + Finalized : Tracking_Array := (others => False); + + type Controlled_Type(Tag : Character) is + new Ada.Finalization.Controlled with record + TC_Component : String(1..4) := "ACVC"; + end record; + procedure Initialize( It: in out Controlled_Type ); + procedure Finalize ( It: in out Controlled_Type ); + function Create(With_Tag: Character) return Controlled_Type; + + type Non_Controlled(Tag : Character := 'Y') is record + Controlled_Component : Controlled_Type(Tag); + end record; + procedure Initialize( It: in out Non_Controlled ); + procedure Finalize ( It: in out Non_Controlled ); + function Create(With_Tag: Character) return Non_Controlled; + + Under_Debug : constant Boolean := False; -- construction lines + + end C760011_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body C760011_0 is + + procedure Initialize( It: in out Controlled_Type ) is + begin + It.TC_Component := (others => It.Tag); + if It.Tag in Tracking_Array'Range then + Initialized(It.Tag) := True; + end if; + if Under_Debug then + Report.Comment("Initializing Tag: " & It.Tag ); + end if; + end Initialize; + + procedure Finalize( It: in out Controlled_Type ) is + begin + if Under_Debug then + Report.Comment("Finalizing for Tag: " & It.Tag ); + end if; + if It.Tag in Finalized'Range then + Finalized(It.Tag) := True; + end if; + end Finalize; + + function Create(With_Tag: Character) return Controlled_Type is + begin + return Controlled_Type'(Ada.Finalization.Controlled + with Tag => With_Tag, + TC_Component => "*CON" ); + end Create; + + procedure Initialize( It: in out Non_Controlled ) is + begin + Report.Failed("Called Initialize for Non_Controlled"); + end Initialize; + + procedure Finalize( It: in out Non_Controlled ) is + begin + Report.Failed("Called Finalize for Non_Controlled"); + end Finalize; + + function Create(With_Tag: Character) return Non_Controlled is + begin + return Non_Controlled'(Tag => With_Tag, Controlled_Component => ( + Ada.Finalization.Controlled + with Tag => With_Tag, + TC_Component => "#NON" ) ); + end Create; + + end C760011_0; + + --------------------------------------------------------------------- C760011 + + with Report; + with TCTouch; + with C760011_0; + with Ada.Finalization; -- needed to be able to create extension aggregates + procedure C760011 is + + use type C760011_0.Controlled_Type; + use type C760011_0.Controlled_Type'Class; + use type C760011_0.Non_Controlled; + + subtype AFC is Ada.Finalization.Controlled; + + procedure Check_Result( Tag : Character; Message : String ) is + -- make allowance for 7.6(21) optimizations + begin + if C760011_0.Initialized(Tag) then + TCTouch.Assert(C760011_0.Finalized(Tag),Message); + elsif C760011_0.Under_Debug then + Report.Comment("Optimized away: " & Tag ); + end if; + end Check_Result; + + procedure Subtest_1 is + + + procedure Subtest_1_Local_1 is + An_Object : C760011_0.Controlled_Type'Class + := C760011_0.Controlled_Type'(AFC with 'X', "ONE*"); + -- initialize An_Object + begin + if C760011_0.Controlled_Type(An_Object) + = C760011_0.Controlled_Type'(AFC with 'A', "ONE*") then + Report.Failed("Comparison bad"); -- A = X !!! + end if; + end Subtest_1_Local_1; + -- An_Object must be Finalized by this point. + + procedure Subtest_1_Local_2 is + An_Object : C760011_0.Controlled_Type('B'); + begin + An_Object := (AFC with 'B', "TWO!" ); + if Report.Ident_Char(An_Object.Tag) /= 'B' then + Report.Failed("Subtest_1_Local_2 Optimization Foil: Bad Data!"); + end if; + exception + when others => Report.Failed("Bad controlled assignment"); + end Subtest_1_Local_2; + -- An_Object must be Finalized by this point. + + procedure Subtest_1_Local_3 is + An_Object : C760011_0.Non_Controlled('C'); + begin + TCTouch.Assert_Not(C760011_0.Finalized('C'), + "Non_Controlled declaration C"); + An_Object := C760011_0.Non_Controlled'('C', Controlled_Component + => (AFC with 'C', "TEE!")); + if Report.Ident_Char(An_Object.Tag) /= 'C' then + Report.Failed("Subtest_1_Local_3 Optimization Foil: Bad Data!"); + end if; + end Subtest_1_Local_3; + -- Only controlled components of An_Object must be finalized; it is an + -- error to call Finalize for An_Object + + begin + Subtest_1_Local_1; + Check_Result( 'A', "Aggregate in subprogram 1" ); + + Subtest_1_Local_2; + Check_Result( 'B', "Aggregate in subprogram 2" ); + + Subtest_1_Local_3; + Check_Result( 'C', "Embedded aggregate in subprogram 3" ); + end Subtest_1; + + + procedure Subtest_2 is + -- using 'Z' for both evades order issues + Con_Object : C760011_0.Controlled_Type('Z'); + Non_Object : C760011_0.Non_Controlled('Z'); + begin + if Report.Ident_Bool( Con_Object = C760011_0.Create('D') ) then + Report.Failed("Con_Object catastrophe"); + end if; + -- Controlled function result should be finalized by now + Check_Result( 'D', "Function Result" ); + + if Report.Ident_Bool( Non_Object = C760011_0.Create('E') ) then + Report.Failed("Non_Object catastrophe"); + end if; + -- Controlled component of function result should be finalized by now + Check_Result( 'E', "Function Result" ); + end Subtest_2; + + + procedure Subtest_3(Con : in C760011_0.Controlled_Type) is + begin + if Con.Tag not in 'F'..'G' then + Report.Failed("Bad value passed to subtest 3 " & Con.Tag & ' ' + & Report.Ident_Str(Con.TC_Component)); + end if; + end Subtest_3; + + + procedure Subtest_4(Non : in C760011_0.Non_Controlled) is + begin + if Non.Tag not in 'H'..'I' then + Report.Failed("Bad value passed to subtest 4 " + & Non.Tag & ' ' + & Report.Ident_Str(Non.Controlled_Component.TC_Component)); + end if; + end Subtest_4; + + + begin -- Main test procedure. + + Report.Test ("C760011", "Check that anonymous objects of controlled " & + "types or types containing controlled types " & + "are finalized no later than the end of the " & + "innermost enclosing declarative_item or " & + "statement" ); + + Subtest_1; + + Subtest_2; + + Subtest_3(C760011_0.Create('F')); + Check_Result( 'F', "Function as formal F" ); + + Subtest_3(C760011_0.Controlled_Type'(AFC with 'G',"GIGI")); + Check_Result( 'G', "Aggregate as formal G" ); + + Subtest_4(C760011_0.Create('H')); + Check_Result( 'H', "Function as formal H" ); + + Subtest_4(C760011_0.Non_Controlled'('I', (AFC with 'I',"IAGO"))); + Check_Result( 'I', "Aggregate as formal I" ); + + Report.Result; + + end C760011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760012.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- C760012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that record components that have per-object access discriminant + -- constraints are initialized in the order of their component + -- declarations, and after any components that are not so constrained. + -- + -- Check that record components that have per-object access discriminant + -- constraints are finalized in the reverse order of their component + -- declarations, and before any components that are not so constrained. + -- + -- TEST DESCRIPTION: + -- The type List_Item is the "container" type. It holds two fields that + -- have per-object access discriminant constraints, and two fields that + -- are not discriminated. These four fields are all controlled types. + -- A fifth field is a pointer used to maintain a linked list of these + -- data objects. Each component is of a unique type which allows for + -- the test to simply track the order of initialization and finalization. + -- + -- The types and their purpose are: + -- Constrained_First - a controlled discriminated type + -- Constrained_Second - a controlled discriminated type + -- Simple_First - a controlled type with no discriminant + -- Simple_Second - a controlled type with no discriminant + -- + -- The required order of operations: + -- Initialize + -- ( Simple_First | Simple_Second ) -- no "internal order" required + -- Constrained_First + -- Constrained_Second + -- Finalize + -- Constrained_Second + -- Constrained_First + -- ( Simple_First | Simple_Second ) -- must be inverse of init. + -- + -- + -- CHANGE HISTORY: + -- 23 MAY 95 SAIC Initial version + -- 02 MAY 96 SAIC Reorganized for 2.1 + -- 05 DEC 96 SAIC Simplified for 2.1; added init/fin ordering check + -- 31 DEC 97 EDS Remove references to and uses of + -- Initialization_Sequence + --! + + ---------------------------------------------------------------- C760012_0 + + with Ada.Finalization; + with Ada.Unchecked_Deallocation; + package C760012_0 is + + type List_Item; + + type List is access all List_Item; + + package Firsts is -- distinguish first from second + type Constrained_First(Container : access List_Item) is + new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize( T : in out Constrained_First ); + procedure Finalize ( T : in out Constrained_First ); + + type Simple_First is new Ada.Finalization.Controlled with + record + My_Init_Seq_Number : Natural; + end record; + procedure Initialize( T : in out Simple_First ); + procedure Finalize ( T : in out Simple_First ); + + end Firsts; + + type Constrained_Second(Container : access List_Item) is + new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize( T : in out Constrained_Second ); + procedure Finalize ( T : in out Constrained_Second ); + + type Simple_Second is new Ada.Finalization.Controlled with + record + My_Init_Seq_Number : Natural; + end record; + procedure Initialize( T : in out Simple_Second ); + procedure Finalize ( T : in out Simple_Second ); + + -- by 3.8(18);6.0 the following type contains components constrained + -- by per-object expressions + + + type List_Item is new Ada.Finalization.Limited_Controlled + with record + ContentA : Firsts.Constrained_First( List_Item'Access ); -- C S + SimpleA : Firsts.Simple_First; -- A T + SimpleB : Simple_Second; -- A T + ContentB : Constrained_Second( List_Item'Access ); -- D R + Next : List; -- | | + end record; -- | | + procedure Initialize( L : in out List_Item ); ------------------+ | + procedure Finalize ( L : in out List_Item ); --------------------+ + + -- the tags are the same for SimpleA and SimpleB due to the fact that + -- the language does not specify an ordering with respect to this + -- component pair. 7.6(12) does specify the rest of the ordering. + + procedure Deallocate is new Ada.Unchecked_Deallocation(List_Item,List); + + end C760012_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C760012_0 is + + package body Firsts is + + procedure Initialize( T : in out Constrained_First ) is + begin + TCTouch.Touch('C'); ----------------------------------------------- C + end Initialize; + + procedure Finalize ( T : in out Constrained_First ) is + begin + TCTouch.Touch('S'); ----------------------------------------------- S + end Finalize; + + procedure Initialize( T : in out Simple_First ) is + begin + T.My_Init_Seq_Number := 0; + TCTouch.Touch('A'); ----------------------------------------------- A + end Initialize; + + procedure Finalize ( T : in out Simple_First ) is + begin + TCTouch.Touch('T'); ----------------------------------------------- T + end Finalize; + + end Firsts; + + procedure Initialize( T : in out Constrained_Second ) is + begin + TCTouch.Touch('D'); ------------------------------------------------- D + end Initialize; + + procedure Finalize ( T : in out Constrained_Second ) is + begin + TCTouch.Touch('R'); ------------------------------------------------- R + end Finalize; + + + procedure Initialize( T : in out Simple_Second ) is + begin + T.My_Init_Seq_Number := 0; + TCTouch.Touch('A'); ------------------------------------------------- A + end Initialize; + + procedure Finalize ( T : in out Simple_Second ) is + begin + TCTouch.Touch('T'); ------------------------------------------------- T + end Finalize; + + procedure Initialize( L : in out List_Item ) is + begin + TCTouch.Touch('F'); ------------------------------------------------- F + end Initialize; + + procedure Finalize ( L : in out List_Item ) is + begin + TCTouch.Touch('Q'); ------------------------------------------------- Q + end Finalize; + + end C760012_0; + + --------------------------------------------------------------------- C760012 + + with Report; + with TCTouch; + with C760012_0; + procedure C760012 is + + use type C760012_0.List; + + procedure Subtest_1 is + -- by 3.8(18);6.0 One_Of_Them is constrained by per-object constraints + -- 7.6.1(9);6.0 dictates the order of finalization of the components + + One_Of_Them : C760012_0.List_Item; + begin + if One_Of_Them.Next /= null then -- just to hold the subtest in place + Report.Failed("No default value for Next"); + end if; + end Subtest_1; + + List : C760012_0.List; + + procedure Subtest_2 is + begin + + List := new C760012_0.List_Item; + + List.Next := new C760012_0.List_Item; + + end Subtest_2; + + procedure Subtest_3 is + begin + + C760012_0.Deallocate( List.Next ); + + C760012_0.Deallocate( List ); + + end Subtest_3; + + begin -- Main test procedure. + + Report.Test ("C760012", "Check that record components that have " & + "per-object access discriminant constraints " & + "are initialized in the order of their " & + "component declarations, and after any " & + "components that are not so constrained. " & + "Check that record components that have " & + "per-object access discriminant constraints " & + "are finalized in the reverse order of their " & + "component declarations, and before any " & + "components that are not so constrained" ); + + Subtest_1; + TCTouch.Validate("AACDFQRSTT", "One object"); + + Subtest_2; + TCTouch.Validate("AACDFAACDF", "Two objects dynamically allocated"); + + Subtest_3; + TCTouch.Validate("QRSTTQRSTT", "Two objects deallocated"); + + Report.Result; + + end C760012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c760013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c760013.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C760013.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Initialize is not called for default-initialized subcomponents + -- of the ancestor type of an extension aggregate. (Defect Report + -- 8652/0021, Technical Corrigendum 7.6(11/1)). + -- + -- CHANGE HISTORY: + -- 25 JAN 2001 PHL Initial version. + -- 29 JUN 2001 RLB Reformatted for ACATS. + -- + --! + with Ada.Finalization; + use Ada.Finalization; + package C760013_0 is + + type Ctrl1 is new Controlled with + record + C : Integer := 0; + end record; + type Ctrl2 is new Controlled with + record + C : Integer := 0; + end record; + + procedure Initialize (Obj1 : in out Ctrl1); + procedure Initialize (Obj2 : in out Ctrl2); + + end C760013_0; + + with Report; + use Report; + package body C760013_0 is + + procedure Initialize (Obj1 : in out Ctrl1) is + begin + Obj1.C := Ident_Int (47); + end Initialize; + + procedure Initialize (Obj2 : in out Ctrl2) is + begin + Failed ("Initialize called for type Ctrl2"); + end Initialize; + + end C760013_0; + + with Ada.Finalization; + with C760013_0; + use C760013_0; + with Report; + use Report; + procedure C760013 is + + type T is tagged + record + C1 : Ctrl1; + C2 : Ctrl2 := (Ada.Finalization.Controlled with + C => Ident_Int (23)); + end record; + + type Nt is new T with + record + C3 : Float; + end record; + + X : Nt; + + begin + Test ("C760013", + "Check that Initialize is not called for " & + "default-initialized subcomponents of the ancestor type of an " & + "extension aggregate"); + + X := (T with C3 => 5.0); + + if X.C1.C /= Ident_Int (47) then + Failed ("Initialize not called for type Ctrl1"); + end if; + if X.C2.C /= Ident_Int (23) then + Failed ("Initial value not assigned for type Ctrl2"); + end if; + + Result; + end C760013; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C761001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that controlled objects declared immediately within a library + -- package are finalized following the completion of the environment + -- task (and prior to termination of the program). + -- + -- TEST DESCRIPTION: + -- This test derives a type from Ada.Finalization.Controlled, and + -- declares an object of that type in the body of a library package. + -- The dispatching procedure Finalize is redefined for the derived + -- type to perform a check that it has been called only once, and in + -- turn calls Report.Result. This test may fail by not calling + -- Report.Result. This test may also fail by calling Report.Result + -- twice, the first call will report a false pass. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Nov 95 SAIC Updated for ACVC 2.0.1 + -- + --! + + with Ada.Finalization; + package C761001_0 is + + type Global is new Ada.Finalization.Controlled with null record; + procedure Finalize( It: in out Global ); + + end C761001_0; + + package C761001_1 is + + task Library_Task is + entry Never_Called; + end Library_Task; + + end C761001_1; + + with Report; + with C761001_1; + package body C761001_0 is + + My_Object : Global; + + Done : Boolean := False; + + procedure Finalize( It: in out Global ) is + begin + if not C761001_1.Library_Task'Terminated then + Report.Failed("Library task not terminated before finalize"); + end if; + if Done then -- checking included "just in case" + Report.Comment("Test FAILED, even if previously reporting passed"); + Report.Failed("Unwarranted multiple call to finalize"); + end if; + Report.Result; + Done := True; + end Finalize; + + end C761001_0; + + with Report; + package body C761001_1 is + + task body Library_Task is + begin + if Report.Ident_Int( 1 ) /= 1 then + Report.Failed( "Baseline failure in Library_Task"); + end if; + end Library_Task; + + end C761001_1; + + with Report; + with C761001_0; + + procedure C761001 is + + begin -- Main test procedure. + + Report.Test ("C761001", "Check that controlled objects declared " + & "immediately within a library package are " + & "finalized following the completion of the " + & "environment task (and prior to termination " + & "of the program)"); + + -- note that if the test DOES call report twice, the first will report a + -- false pass, the second call will correctly fail the test. + + -- not calling Report.Result; + -- Result is called as part of the finalization of C761001_0.My_Object. + + end C761001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761002.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- C761002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that objects of a controlled type that are created + -- by an allocator are finalized at the appropriate time. In + -- particular, check that such objects are not finalized due to + -- completion of the master in which they were allocated if the + -- corresponding access type is declared outside of that master. + -- + -- Check that Unchecked_Deallocation of a controlled + -- object causes finalization of that object. + -- + -- TEST DESCRIPTION: + -- This test derives a type from Ada.Finalization.Controlled, and + -- declares access types to that type in various scope scenarios. + -- The dispatching procedure Finalize is redefined for the derived + -- type to perform a check that it has been called at the + -- correct time. This is accomplished using a global variable + -- which indicates what state the software is currently + -- executing. The test utilizes the TCTouch facilities to + -- verify that Finalize is called the correct number of times, at + -- the correct times. Several calls are made to validate passing + -- the null string to check that Finalize has NOT been called at + -- that point. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Finalization; + package C761002_0 is + type Global is new Ada.Finalization.Controlled with null record; + procedure Finalize( It: in out Global ); + + type Second is new Ada.Finalization.Limited_Controlled with null record; + procedure Finalize( It: in out Second ); + end C761002_0; + + with Report; + with TCTouch; + package body C761002_0 is + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch('F'); ------------------------------------------------- F + end Finalize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch('S'); ------------------------------------------------- S + end Finalize; + end C761002_0; + + with Report; + with TCTouch; + with C761002_0; + with Unchecked_Deallocation; + procedure C761002 is + + -- check the straightforward case + procedure Subtest_1 is + type Access_1 is access C761002_0.Global; + V1 : Access_1; + procedure Allocate is + V2 : Access_1; + begin + V2 := new C761002_0.Global; + V1 := V2; -- "dead" assignment must not be optimized away due to + -- finalization "side effects", many more of these follow + end Allocate; + begin + Allocate; + -- no calls to Finalize should have occurred at this point + TCTouch.Validate("","Allocated nested, retained"); + end Subtest_1; + + -- check Unchecked_Deallocation + procedure Subtest_2 is + type Access_2 is access C761002_0.Global; + procedure Free is + new Unchecked_Deallocation(C761002_0.Global, Access_2); + V1 : Access_2; + V2 : Access_2; + + procedure Allocate is + begin + V1 := new C761002_0.Global; + V2 := new C761002_0.Global; + end Allocate; + + begin + Allocate; + -- no calls to Finalize should have occurred at this point. + TCTouch.Validate("","Allocated nested, non-local"); + + Free(V1); -- instance of Unchecked_Deallocation + -- should cause the finalization of V1.all + TCTouch.Validate("F","Unchecked Deallocation"); + end Subtest_2; -- leaving this scope should cause the finalization of V2.all + + -- check various master-exit scenarios + -- the "Fake" parameters are used to avoid unwanted optimizations + procedure Subtest_3 is + procedure With_Local_Block is + type Access_3 is access C761002_0.Global; + V1 : Access_3; + begin + declare + V2 : Access_3 := new C761002_0.Global; + begin + V1 := V2; + end; + TCTouch.Validate("","Local Block, normal exit"); + -- the allocated object should be finalized on leaving this scope + end With_Local_Block; + + procedure With_Local_Block_Return(Fake: Integer) is + type Access_4 is access C761002_0.Global; + V1 : Access_4 := new C761002_0.Global; + begin + if Fake = 0 then + declare + V2 : Access_4; + begin + V2 := new C761002_0.Global; + return; -- the two allocated objects should be finalized + end; -- upon leaving this scope + else + V1 := null; + end if; + end With_Local_Block_Return; + + procedure With_Goto(Fake: Integer) is + type Access_5 is access C761002_0.Global; + V1 : Access_5 := new C761002_0.Global; + V2 : Access_5; + V3 : Access_5; + begin + if Fake = 0 then + declare + type Access_6 is access C761002_0.Second; + V6 : Access_6; + begin + V6 := new C761002_0.Second; + goto check; + end; + else + V2 := V1; + end if; + V3 := V2; + <> + TCTouch.Validate("S","goto past master end"); + end With_Goto; + + begin + With_Local_Block; + TCTouch.Validate("F","Local Block, normal exit, after master"); + + With_Local_Block_Return( Report.Ident_Int(0) ); + TCTouch.Validate("FF","Local Block, return from block"); + + With_Goto( Report.Ident_Int(0) ); + TCTouch.Validate("F","With Goto"); + + end Subtest_3; + + procedure Subtest_4 is + + Oops : exception; + + procedure Alley( Fake: Integer ) is + type Access_1 is access C761002_0.Global; + V1 : Access_1; + begin + V1 := new C761002_0.Global; + if Fake = 1 then + raise Oops; + end if; + V1 := null; + end Alley; + + begin + Catch: begin + Alley( Report.Ident_Int(1) ); + exception + when Oops => TCTouch.Validate("F","leaving via exception"); + when others => Report.Failed("Wrong exception"); + end Catch; + end Subtest_4; + + begin -- Main test procedure. + + Report.Test ("C761002", "Check that objects of a controlled type created " + & "by an allocator are finalized appropriately. " + & "Check that Unchecked_Deallocation of a " + & "controlled object causes finalization " + & "of that object" ); + + Subtest_1; + -- leaving the scope of the access type should finalize the + -- collection + TCTouch.Validate("F","Allocated nested, Subtest 1"); + + Subtest_2; + -- Unchecked_Deallocation already finalized one of the two + -- objects allocated, the other should be the only one finalized + -- at leaving the scope of the access type. + TCTouch.Validate("F","Allocated non-local"); + + Subtest_3; + -- there should be no remaining finalizations from this subtest + TCTouch.Validate("","Localized objects"); + + Subtest_4; + -- there should be no remaining finalizations from this subtest + TCTouch.Validate("","Exception testing"); + + Report.Result; + + end C761002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761003.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,447 ---- + -- C761003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an object of a controlled type is finalized when the + -- enclosing master is complete. + -- Check this for controlled types where the derived type has a + -- discriminant. + -- Check this for subprograms of abstract types derived from the + -- types in Ada.Finalization. + -- + -- Check that finalization of controlled objects is + -- performed in the correct order. In particular, check that if + -- multiple objects of controlled types are declared immediately + -- within the same declarative part then type are finalized in the + -- reverse order of their creation. + -- + -- TEST DESCRIPTION: + -- This test checks these conditions for subprograms and + -- block statements; both variables and constants of controlled + -- types; cases of a controlled component of a record type, as + -- well as an array with controlled components. + -- + -- The base controlled types used for the test are defined + -- with a character discriminant. The initialize procedure for + -- the types will record the order of creation in a globally + -- accessible array, the finalize procedure for the types will call + -- TCTouch with that tag character. The test can then check that + -- the order of finalization is indeed the reverse of the order of + -- creation (assuming that the implementation calls Initialize in + -- the order that the objects are created). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 95 SAIC ACVC 2.0.1 + -- + --! + + ------------------------------------------------------------ C761003_Support + + package C761003_Support is + + function Pick_Char return Character; + -- successive calls to Pick_Char return distinct characters which may + -- be assigned to objects to track an order sequence. These characters + -- are then used in calls to TCTouch.Touch. + + procedure Validate(Initcount : Natural; + Testnumber : Natural; + Check_Order : Boolean := True); + -- does a little extra processing prior to calling TCTouch.Validate, + -- specifically, it reverses the stored string of characters, and checks + -- for a correct count. + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + + end C761003_Support; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body C761003_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + begin + for SI in reverse S'Range loop + T(S'Last - SI + 1) := S(SI); + end loop; + return T; + end Invert; + + procedure Validate(Initcount : Natural; + Testnumber : Natural; + Check_Order : Boolean := True) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Got" & Natural'Image(Inits_Called) & " inits, expected" + & Natural'Image(Initcount) & ", Subtest " & Number); + TCTouch.Flush; + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, Order_Meaningful => Check_Order ); + end if; + Inits_Called := 0; -- reset for the next batch + end Validate; + + end C761003_Support; + + ------------------------------------------------------------------ C761003_0 + + with Ada.Finalization; + package C761003_0 is + + type Global(Tag: Character) is new Ada.Finalization.Controlled + with null record; + + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + Null_Global : Global('1') := (Ada.Finalization.Controlled with Tag => '1'); + + type Second(Tag: Character) is new Ada.Finalization.Limited_Controlled + with null record; + + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + + end C761003_0; + + ------------------------------------------------------------------ C761003_1 + + with Ada.Finalization; + package C761003_1 is + + type Global is abstract new Ada.Finalization.Controlled with record + Tag: Character; + end record; + + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + type Second is abstract new Ada.Finalization.Limited_Controlled with record + Tag: Character; + end record; + + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + + end C761003_1; + + ------------------------------------------------------------------ C761003_2 + + with C761003_1; + package C761003_2 is + + type Global is new C761003_1.Global with null record; + -- inherits Initialize and Finalize + + type Second is new C761003_1.Second with null record; + -- inherits Initialize and Finalize + + end C761003_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_0 + + with TCTouch; + with C761003_Support; + package body C761003_0 is + + package Sup renames C761003_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + end C761003_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- C761003_1 + + with TCTouch; + with C761003_Support; + package body C761003_1 is + + package Sup renames C761003_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + end C761003_1; + + -------------------------------------------------------------------- C761003 + + with Report; + with TCTouch; + with C761003_0; + with C761003_2; + with C761003_Support; + procedure C761003 is + + package Sup renames C761003_Support; + + ---------------------------------------------------------------- Subtest_1 + + Subtest_1_Inits_Expected : constant := 5; -- includes 1 previous + + procedure Subtest_1 is + + -- the constant will take its constraint from the value. + -- must be declared first to be finalized last (and take the + -- initialize from before calling subtest_1) + Item_1 : constant C761003_0.Global := C761003_0.Null_Global; + + -- Item_2, declared second, should be finalized second to last. + Item_2 : C761003_0.Global(Sup.Pick_Char); + + -- Item_3 and Item_4 will be created in the order of the + -- list. + Item_3, Item_4 : C761003_0.Global(Sup.Pick_Char); + + -- Item_5 will be finalized first. + Item_5 : C761003_0.Second(Sup.Pick_Char); + + begin + if Item_3.Tag >= Item_4.Tag then + Report.Failed("Controlled objects created by list in wrong order"); + end if; + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 1 body"); + end Subtest_1; + + ---------------------------------------------------------------- Subtest_2 + + -- These declarations should cause calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. Note that for these objects, the + -- Initialize and Finalize are visible only by inheritance. + + Subtest_2_Inits_Expected : constant := 4; + + procedure Subtest_2 is + + Item_1 : C761003_2.Global; + Item_2, Item_3 : C761003_2.Global; + Item_4 : C761003_2.Second; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 2 body"); + end Subtest_2; + + ---------------------------------------------------------------- Subtest_3 + + -- Test for controlled objects embedded in arrays. Using structures + -- that will cause a checkable order. + + Subtest_3_Inits_Expected : constant := 8; + + procedure Subtest_3 is + + type Global_List is array(Natural range <>) + of C761003_0.Global(Sup.Pick_Char); + + Items : Global_List(1..4); -- components have the same tag + + type Second_List is array(Natural range <>) + of C761003_0.Second(Sup.Pick_Char); + + Second_Items : Second_List(1..4); -- components have the same tag, + -- distinct from the tag used in Items + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 3 body"); + end Subtest_3; + + ---------------------------------------------------------------- Subtest_4 + + -- These declarations should cause dispatching calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + + Subtest_4_Inits_Expected : constant := 2; + + procedure Subtest_4 is + + type Global_Rec is record + Item1: C761003_0.Global(Sup.Pick_Char); + end record; + + type Second_Rec is record + Item2: C761003_2.Second; + end record; + + G : Global_Rec; + S : Second_Rec; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 4 body"); + end Subtest_4; + + ---------------------------------------------------------------- Subtest_5 + + -- Test for controlled objects embedded in arrays. In these cases, the + -- order of the finalization of the components is not defined by the + -- language. + + Subtest_5_Inits_Expected : constant := 8; + + procedure Subtest_5 is + + + type Another_Global_List is array(Natural range <>) + of C761003_2.Global; + + More_Items : Another_Global_List(1..4); + + type Another_Second_List is array(Natural range <>) + of C761003_2.Second; + + Second_More_Items : Another_Second_List(1..4); + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 5 body"); + end Subtest_5; + + ---------------------------------------------------------------- Subtest_6 + + -- These declarations should cause dispatching calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + + Subtest_6_Inits_Expected : constant := 2; + + procedure Subtest_6 is + + type Global_Rec is record + Item2: C761003_2.Global; + end record; + + type Second_Rec is record + Item1: C761003_0.Second(Sup.Pick_Char); + end record; + + G : Global_Rec; + S : Second_Rec; + + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 6 body"); + end Subtest_6; + + begin -- Main test procedure. + + Report.Test ("C761003", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + -- adjust for optional adjusts and initializes for C761003_0.Null_Global + TCTouch.Flush; -- clear the optional adjust + if Sup.Inits_Called /= 1 then + -- C761003_0.Null_Global did not get "initialized" + C761003_0.Initialize(C761003_0.Null_Global); -- prime the pump + end if; + + Subtest_1; + Sup.Validate(Subtest_1_Inits_Expected, 1); + + Subtest_2; + Sup.Validate(Subtest_2_Inits_Expected, 2); + + Subtest_3; + Sup.Validate(Subtest_3_Inits_Expected, 3); + + Subtest_4; + Sup.Validate(Subtest_4_Inits_Expected, 4); + + Subtest_5; + Sup.Validate(Subtest_5_Inits_Expected, 5, Check_Order => False); + + Subtest_6; + Sup.Validate(Subtest_6_Inits_Expected, 6); + + Report.Result; + + end C761003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761004.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,305 ---- + -- C761004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an object of a controlled type is finalized with the + -- enclosing master is complete. + -- Check that finalization occurs in the case where the master is + -- left by a transfer of control. + -- Specifically check for types where the derived types do not have + -- discriminants. + -- + -- Check that finalization of controlled objects is + -- performed in the correct order. In particular, check that if + -- multiple objects of controlled types are declared immediately + -- within the same declarative part then they are finalized in the + -- reverse order of their creation. + -- + -- TEST DESCRIPTION: + -- This test checks these conditions for subprograms and + -- block statements; both variables and constants of controlled + -- types; cases of a controlled component of a record type, as + -- well as an array with controlled components. + -- + -- The base controlled types used for the test are defined + -- with a character discriminant. The initialize procedure for + -- the types will record the order of creation in a globally + -- accessible array, the finalize procedure for the types will call + -- TCTouch with that tag character. The test can then check that + -- the order of finalization is indeed the reverse of the order of + -- creation (assuming that the implementation calls Initialize in + -- the order that the objects are created). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Nov 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + package C761004_Support is + + function Pick_Char return Character; + -- successive calls to Pick_Char return distinct characters which may + -- be assigned to objects to track an order sequence. These characters + -- are then used in calls to TCTouch.Touch. + + procedure Validate(Initcount: Natural; Testnumber:Natural); + -- does a little extra processing prior to calling TCTouch.Validate, + -- specifically, it reverses the stored string of characters, and checks + -- for a correct count. + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + + end C761004_Support; + + with Report; + with TCTouch; + package body C761004_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + TI: Positive := 1; + begin + for SI in reverse S'Range loop + T(TI) := S(SI); + TI := TI +1; + end loop; + return T; + end Invert; + + procedure Validate(Initcount: Natural; Testnumber:Natural) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Wrong number of inits, Subtest " & Number); + TCTouch.Flush; + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, True); + end if; + end Validate; + + end C761004_Support; + + ----------------------------------------------------------------- C761004_0 + + with Ada.Finalization; + package C761004_0 is + type Global is new Ada.Finalization.Controlled with record + Tag : Character; + end record; + procedure Initialize( It: in out Global ); + procedure Finalize ( It: in out Global ); + + type Second is new Ada.Finalization.Limited_Controlled with record + Tag : Character; + end record; + procedure Initialize( It: in out Second ); + procedure Finalize ( It: in out Second ); + + end C761004_0; + + with TCTouch; + with C761004_Support; + package body C761004_0 is + + package Sup renames C761004_Support; + + procedure Initialize( It: in out Global ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Global ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + + procedure Initialize( It: in out Second ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Second ) is + begin + TCTouch.Touch(It.Tag); --------------------------------------------- Tag + end Finalize; + end C761004_0; + + ------------------------------------------------------------------- C761004 + + with Report; + with TCTouch; + with C761004_0; + with C761004_Support; + with Ada.Finalization; -- needed to be able to create extension aggregates + procedure C761004 is + + Verbose : constant Boolean := False; + + package Sup renames C761004_Support; + + -- Subtest 1, general case. Check that several objects declared in a + -- subprogram are created, and finalized in opposite order. + + Subtest_1_Expected_Inits : constant := 3; + + procedure Subtest_1 is + Item_1 : C761004_0.Global; + Item_2, Item_3 : C761004_0.Global; + begin + if Item_2.Tag = Item_3.Tag then -- not germane to the test + Report.Failed("Duplicate tag");-- but helps prevent code elimination + end if; + end Subtest_1; + + -- Subtest 2, extension of the general case. Check that several objects + -- created identically on the stack (via a recursive procedure) are + -- finalized in the opposite order of their creation. + Subtest_2_Expected_Inits : constant := 12; + User_Exception : exception; + + procedure Subtest_2 is + + Item_1 : C761004_0.Global; + + -- combine recursion and exit by exception: + + procedure Nested(Recurs: Natural) is + Item_3 : C761004_0.Global; + begin + if Verbose then + Report.Comment("going in: " & Item_3.Tag); + end if; + if Recurs = 1 then + raise User_Exception; + else + Nested(Recurs -1); + end if; + end Nested; + + Item_2 : C761004_0.Global; + + begin + Nested(10); + end Subtest_2; + + -- subtest 3, check the case of objects embedded in structures: + -- an array + -- a record + Subtest_3_Expected_Inits : constant := 3; + procedure Subtest_3 is + type G_List is array(Positive range <>) of C761004_0.Global; + type Pandoras_Box is record + G : G_List(1..1); + end record; + + procedure Nested(Recursions: Natural) is + Merlin : Pandoras_Box; + begin + if Recursions > 1 then + Nested(Recursions-1); + else + TCTouch.Validate("","Final Nested call"); + end if; + end Nested; + + begin + Nested(3); + end Subtest_3; + + -- subtest 4, check the case of objects embedded in structures: + -- an array + -- a record + Subtest_4_Expected_Inits : constant := 3; + procedure Subtest_4 is + type S_List is array(Positive range <>) of C761004_0.Second; + type Pandoras_Box is record + S : S_List(1..1); + end record; + + procedure Nested(Recursions: Natural) is + Merlin : Pandoras_Box; + begin + if Recursions > 1 then + Nested(Recursions-1); + else + TCTouch.Validate("","Final Nested call"); + end if; + end Nested; + + begin + Nested(3); + end Subtest_4; + + begin -- Main test procedure. + + Report.Test ("C761004", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + Subtest_1; + Sup.Validate(Subtest_1_Expected_Inits,1); + + Subtest_2_Frame: begin + Sup.Inits_Called := 0; + Subtest_2; + exception + when User_Exception => null; + when others => Report.Failed("Wrong Exception, Subtest 2"); + end Subtest_2_Frame; + Sup.Validate(Subtest_2_Expected_Inits,2); + + Sup.Inits_Called := 0; + Subtest_3; + Sup.Validate(Subtest_3_Expected_Inits,3); + + Sup.Inits_Called := 0; + Subtest_4; + Sup.Validate(Subtest_4_Expected_Inits,4); + + Report.Result; + + end C761004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761005.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,288 ---- + -- C761005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that deriving abstract types from the types in Ada.Finalization + -- does not negatively impact the implicit operations. + -- Check that an object of a controlled type is finalized when the + -- enclosing master is complete. + -- Check that finalization occurs in the case where the master is + -- left by a transfer of control. + -- Check this for controlled types where the derived type has a + -- discriminant. + -- Check this for cases where the type is defined as private, + -- and the full type is derived from the types in Ada.Finalization. + -- + -- Check that finalization of controlled objects is + -- performed in the correct order. In particular, check that if + -- multiple objects of controlled types are declared immediately + -- within the same declarative part then type are finalized in the + -- reverse order of their creation. + -- + -- TEST DESCRIPTION: + -- This test checks these conditions for subprograms and + -- block statements; both variables and constants of controlled + -- types; cases of a controlled component of a record type, as + -- well as an array with controlled components. + -- + -- The base controlled types used for the test are defined + -- with a character discriminant. The initialize procedure for + -- the types will record the order of creation in a globally + -- accessible array, the finalize procedure for the types will call + -- TCTouch with that tag character. The test can then check that + -- the order of finalization is indeed the reverse of the order of + -- creation (assuming that the implementation calls Initialize in + -- the order that the objects are created). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Oct 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + package C761005_Support is + + function Pick_Char return Character; + procedure Validate(Initcount: Natural; Testnumber:Natural); + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + + end C761005_Support; + + with Report; + with TCTouch; + package body C761005_Support is + type Pick_Rotation is mod 52; + type Pick_String is array(Pick_Rotation) of Character; + + From : constant Pick_String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + & "abcdefghijklmnopqrstuvwxyz"; + Recent_Pick : Pick_Rotation := Pick_Rotation'Last; + + function Pick_Char return Character is + begin + Recent_Pick := Recent_Pick +1; + return From(Recent_Pick); + end Pick_Char; + + function Invert(S:String) return String is + T: String(1..S'Length); + TI: Positive := 1; + begin + for SI in reverse S'Range loop + T(TI) := S(SI); + TI := TI +1; + end loop; + return T; + end Invert; + + procedure Validate(Initcount: Natural; Testnumber:Natural) is + Number : constant String := Natural'Image(Testnumber); + begin + if Inits_Called /= Initcount then + Report.Failed("Wrong number of inits, Subtest " & Number); + else + TCTouch.Validate( + Invert(Inits_Order(1..Inits_Called)), + "Subtest " & Number, True); + end if; + Inits_Called := 0; + end Validate; + + end C761005_Support; + + ----------------------------------------------------------------------------- + with Ada.Finalization; + package C761005_0 is + type Final_Root(Tag: Character) is private; + + type Ltd_Final_Root(Tag: Character) is limited private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + private + type Final_Root(Tag: Character) is new Ada.Finalization.Controlled + with null record; + procedure Initialize( It: in out Final_Root ); + procedure Finalize ( It: in out Final_Root ); + + type Ltd_Final_Root(Tag: Character) is new + Ada.Finalization.Limited_Controlled + with null record; + procedure Initialize( It: in out Ltd_Final_Root ); + procedure Finalize ( It: in out Ltd_Final_Root ); + end C761005_0; + + ----------------------------------------------------------------------------- + with Ada.Finalization; + package C761005_1 is + type Final_Abstract is abstract tagged private; + + type Ltd_Final_Abstract_Child is abstract tagged limited private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + + private + type Final_Abstract is abstract new Ada.Finalization.Controlled with record + Tag: Character; + end record; + procedure Initialize( It: in out Final_Abstract ); + procedure Finalize ( It: in out Final_Abstract ); + + type Ltd_Final_Abstract_Child is + abstract new Ada.Finalization.Limited_Controlled with record + Tag: Character; + end record; + procedure Initialize( It: in out Ltd_Final_Abstract_Child ); + procedure Finalize ( It: in out Ltd_Final_Abstract_Child ); + + end C761005_1; + + ----------------------------------------------------------------------------- + with C761005_1; + package C761005_2 is + + type Final_Child is new C761005_1.Final_Abstract with null record; + type Ltd_Final_Child is + new C761005_1.Ltd_Final_Abstract_Child with null record; + + end C761005_2; + + ----------------------------------------------------------------------------- + with Report; + with TCTouch; + with C761005_Support; + package body C761005_0 is + + package Sup renames C761005_Support; + + procedure Initialize( It: in out Final_Root ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Final_Root ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + + procedure Initialize( It: in out Ltd_Final_Root ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Ltd_Final_Root ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + end C761005_0; + + ----------------------------------------------------------------------------- + with Report; + with TCTouch; + with C761005_Support; + package body C761005_1 is + + package Sup renames C761005_Support; + + procedure Initialize( It: in out Final_Abstract ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Final_Abstract ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + + procedure Initialize( It: in out Ltd_Final_Abstract_Child ) is + begin + Sup.Inits_Called := Sup.Inits_Called +1; + It.Tag := Sup.Pick_Char; + Sup.Inits_Order(Sup.Inits_Called) := It.Tag; + end Initialize; + + procedure Finalize( It: in out Ltd_Final_Abstract_Child ) is + begin + TCTouch.Touch(It.Tag); + end Finalize; + end C761005_1; + + ----------------------------------------------------------------------------- + with Report; + with TCTouch; + with C761005_0; + with C761005_2; + with C761005_Support; + procedure C761005 is + + package Sup renames C761005_Support; + + Subtest_1_Inits_Expected : constant := 4; + procedure Subtest_1 is + Item_1 : C761005_0.Final_Root(Sup.Pick_Char); + Item_2, Item_3 : C761005_0.Final_Root(Sup.Pick_Char); + Item_4 : C761005_0.Ltd_Final_Root(Sup.Pick_Char); + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 1 body"); + end Subtest_1; + + -- These declarations should cause calls to initialize and + -- finalize. The expected operations are the subprograms associated + -- with the abstract types. + Subtest_2_Inits_Expected : constant := 4; + procedure Subtest_2 is + Item_1 : C761005_2.Final_Child; + Item_2, Item_3 : C761005_2.Final_Child; + Item_4 : C761005_2.Ltd_Final_Child; + begin + -- check that nothing has happened yet! + TCTouch.Validate("","Subtest 2 body"); + end Subtest_2; + + begin -- Main test procedure. + + Report.Test ("C761005", "Check that an object of a controlled type " + & "is finalized when the enclosing master is " + & "complete, left by a transfer of control, " + & "and performed in the correct order" ); + + Subtest_1; + Sup.Validate(Subtest_1_Inits_Expected,1); + + Subtest_2; + Sup.Validate(Subtest_2_Inits_Expected,2); + + Report.Result; + + end C761005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761006.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,425 ---- + -- C761006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Program_Error is raised when: + -- * an exception is raised if Finalize invoked as part of an + -- assignment operation; or + -- * an exception is raised if Adjust invoked as part of an assignment + -- operation, after any other adjustment due to be performed are + -- performed; or + -- * an exception is raised if Finalize invoked as part of a call on + -- Unchecked_Deallocation, after any other finalizations to be + -- performed are performed. + -- + -- TEST DESCRIPTION: + -- This test defines these four controlled types: + -- Good + -- Bad_Initialize + -- Bad_Adjust + -- Bad_Finalize + -- The type name conveys the associated failure. The operations in type + -- good will "touch" the boolean array indicating correct path + -- utilization for the purposes of checking "other are + -- performed", where ::= initialization, adjusting, and + -- finalization + -- + -- + -- + -- CHANGE HISTORY: + -- 12 APR 94 SAIC Initial version + -- 02 MAY 96 SAIC Visibility fixed for 2.1 + -- 13 FEB 97 PWB.CTA Corrected value of Events_Occurring at line 286 + -- 01 DEC 97 EDS Made correction wrt RM 7.6(21) + -- 16 MAR 01 RLB Corrected Adjust cases to avoid problems with + -- RM 7.6.1(16/1) from Technical Corrigendum 1. + -- + --! + + ------------------------------------------------------------- C761006_Support + + package C761006_Support is + + type Events is ( Good_Initialize, Good_Adjust, Good_Finalize ); + + type Event_Array is array(Events) of Boolean; + + Events_Occurring : Event_Array := (others => False); + + Propagating_Exception : exception; + + procedure Raise_Propagating_Exception(Do_It: Boolean); + + function Unique_Value return Natural; + + end C761006_Support; + + ------------------------------------------------------------- C761006_Support + + with Report; + package body C761006_Support is + + procedure Raise_Propagating_Exception(Do_It: Boolean) is + begin + if Report.Ident_Bool(Do_It) then + raise Propagating_Exception; + end if; + end Raise_Propagating_Exception; + + Seed : Natural := 0; + + function Unique_Value return Natural is + begin + Seed := Seed +1; + return Seed; + end Unique_Value; + + end C761006_Support; + + ------------------------------------------------------------------- C761006_0 + + with Ada.Finalization; + with C761006_Support; + package C761006_0 is + + type Good is new Ada.Finalization.Controlled + with record + Initialized : Boolean := False; + Adjusted : Boolean := False; + Unique : Natural := C761006_Support.Unique_Value; + end record; + + procedure Initialize( It: in out Good ); + procedure Adjust ( It: in out Good ); + procedure Finalize ( It: in out Good ); + + type Bad_Initialize is private; + + type Bad_Adjust is private; + + type Bad_Finalize is private; + + Inits_Order : String(1..255); + Inits_Called : Natural := 0; + private + type Bad_Initialize is new Ada.Finalization.Controlled + with null record; + procedure Initialize( It: in out Bad_Initialize ); + + type Bad_Adjust is new Ada.Finalization.Controlled + with null record; + procedure Adjust ( It: in out Bad_Adjust ); + + type Bad_Finalize is + new Ada.Finalization.Controlled with null record; + procedure Finalize ( It: in out Bad_Finalize ); + end C761006_0; + + ------------------------------------------------------------------- C761006_1 + + with Ada.Finalization; + with C761006_0; + package C761006_1 is + + type Init_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Init_Fails : C761006_0.Bad_Initialize; + end record; + + type Adj_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Adj_Fails : C761006_0.Bad_Adjust; + end record; + + type Fin_Check_Root is new Ada.Finalization.Controlled with record + Good_Component : C761006_0.Good; + Fin_Fails : C761006_0.Bad_Finalize; + end record; + + end C761006_1; + + ------------------------------------------------------------------- C761006_2 + + with C761006_1; + package C761006_2 is + + type Init_Check is new C761006_1.Init_Check_Root with null record; + type Adj_Check is new C761006_1.Adj_Check_Root with null record; + type Fin_Check is new C761006_1.Fin_Check_Root with null record; + + end C761006_2; + + ------------------------------------------------------------------- C761006_0 + + with Report; + with C761006_Support; + package body C761006_0 is + + package Sup renames C761006_Support; + + procedure Initialize( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Initialize ) := True; + It.Initialized := True; + end Initialize; + + procedure Adjust ( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Adjust ) := True; + It.Adjusted := True; + It.Unique := C761006_Support.Unique_Value; + end Adjust; + + procedure Finalize ( It: in out Good ) is + begin + Sup.Events_Occurring( Sup.Good_Finalize ) := True; + end Finalize; + + procedure Initialize( It: in out Bad_Initialize ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Initialize; + + procedure Adjust( It: in out Bad_Adjust ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Adjust; + + procedure Finalize( It: in out Bad_Finalize ) is + begin + Sup.Raise_Propagating_Exception(Report.Ident_Bool(True)); + end Finalize; + + end C761006_0; + + --------------------------------------------------------------------- C761006 + + with Report; + with C761006_0; + with C761006_2; + with C761006_Support; + with Ada.Exceptions; + with Ada.Finalization; + with Unchecked_Deallocation; + procedure C761006 is + + package Sup renames C761006_Support; + use type Sup.Event_Array; + + type Procedure_Handle is access procedure; + + type Test_ID is ( Simple, Initialize, Adjust, Finalize ); + + Sub_Tests : array(Test_ID) of Procedure_Handle; + + procedure Simple_Test is + A_Good_Object : C761006_0.Good; -- should call Initialize + begin + if not A_Good_Object.Initialized then + Report.Failed("Good object not initialized"); + end if; + + -- should call Adjust + A_Good_Object := ( Ada.Finalization.Controlled + with Unique => 0, others => False ); + if not A_Good_Object.Adjusted then + Report.Failed("Good object not adjusted"); + end if; + + -- should call Finalize before end of scope + end Simple_Test; + + procedure Initialize_Test is + begin + declare + This_Object_Fails_In_Initialize : C761006_2.Init_Check; + begin + Report.Failed("Exception in Initialize did not occur"); + exception + when others => + Report.Failed("Initialize caused exception at wrong lex"); + end; + + Report.Failed("Error in execution sequence"); + + exception + when Sup.Propagating_Exception => -- this is correct + if not Sup.Events_Occurring(Sup.Good_Initialize) then + Report.Failed("Initialization of Good Component did not occur"); + end if; + end Initialize_Test; + + procedure Adjust_Test is + This_Object_OK : C761006_2.Adj_Check; + This_Object_Target : C761006_2.Adj_Check; + begin + + Check_Adjust_Due_To_Assignment: begin + This_Object_Target := This_Object_OK; + Report.Failed("Adjust did not propagate any exception"); + exception + when Program_Error => -- expected case + if not This_Object_Target.Good_Component.Adjusted then + Report.Failed("other adjustment not performed"); + end if; + when others => + Report.Failed("Adjust propagated wrong exception"); + end Check_Adjust_Due_To_Assignment; + + C761006_Support.Events_Occurring := (True, False, False); + + Check_Adjust_Due_To_Initial_Assignment: declare + Another_Target : C761006_2.Adj_Check := This_Object_OK; + begin + Report.Failed("Adjust did not propagate any exception"); + exception + when others => Report.Failed("Adjust caused exception at wrong lex"); + end Check_Adjust_Due_To_Initial_Assignment; + + exception + when Program_Error => -- expected case + if Sup.Events_Occurring(Sup.Good_Finalize) /= + Sup.Events_Occurring(Sup.Good_Adjust) then + -- RM 7.6.1(16/1) says that the good Adjust may or may not + -- be performed; but if it is, then the Finalize must be + -- performed; and if it is not, then the Finalize must not + -- performed. + if Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Good adjust not performed with bad adjust, " & + "but good finalize was"); + else + Report.Failed("Good adjust performed with bad adjust, " & + "but good finalize was not"); + end if; + end if; + when others => + Report.Failed("Adjust propagated wrong exception"); + end Adjust_Test; + + procedure Finalize_Test is + + Fin_Not_Perf : constant String := "other finalizations not performed"; + + procedure Finalize_15 is + Item : C761006_2.Fin_Check; + Target : C761006_2.Fin_Check; + begin + + Item := Target; + -- finalization of Item should cause PE + -- ARM7.6:21 allows the implementation to omit the assignment of the + -- value into an anonymous object, which is the point at which Adjust + -- is normally called. However, this would result in Program_Error's + -- being raised before the call to Adjust, with the consequence that + -- Adjust is never called. + + exception + when Program_Error => -- expected case + if not Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Assignment: " & Fin_Not_Perf); + end if; + when others => + Report.Failed("Other exception in Finalize_15"); + + -- finalization of Item/Target should cause PE + end Finalize_15; + + -- check failure in finalize due to Unchecked_Deallocation + + type Shark is access C761006_2.Fin_Check; + + procedure Catch is + new Unchecked_Deallocation( C761006_2.Fin_Check, Shark ); + + procedure Finalize_17 is + White : Shark := new C761006_2.Fin_Check; + begin + Catch( White ); + exception + when Program_Error => + if not Sup.Events_Occurring(Sup.Good_Finalize) then + Report.Failed("Unchecked_Deallocation: " & Fin_Not_Perf); + end if; + end Finalize_17; + + begin + + Exception_In_Finalization: begin + Finalize_15; + exception + when Program_Error => null; -- anticipated + end Exception_In_Finalization; + + Use_Of_Unchecked_Deallocation: begin + Finalize_17; + exception + when others => + Report.Failed("Unchecked_Deallocation check, unwanted exception"); + end Use_Of_Unchecked_Deallocation; + + end Finalize_Test; + + begin -- Main test procedure. + + Report.Test ("C761006", "Check that exceptions raised in Initialize, " & + "Adjust and Finalize are processed correctly" ); + + Sub_Tests := (Simple_Test'Access, Initialize_Test'Access, + Adjust_Test'Access, Finalize_Test'Access); + + for Test in Sub_Tests'Range loop + begin + + Sup.Events_Occurring := (others => False); + + Sub_Tests(Test).all; + + case Test is + when Simple | Adjust => + if Sup.Events_Occurring /= Sup.Event_Array ' ( others => True ) then + Report.Failed ( "Other operation missing in " & + Test_ID'Image ( Test ) ); + end if; + when Initialize => + null; + when Finalize => + -- Note that for Good_Adjust, we may get either True or False + if Sup.Events_Occurring ( Sup.Good_Initialize ) = False or + Sup.Events_Occurring ( Sup.Good_Finalize ) = False + then + Report.Failed ( "Other operation missing in " & + Test_ID'Image ( Test ) ); + end if; + end case; + + exception + when How: others => Report.Failed( Ada.Exceptions.Exception_Name( How ) + & " from " & Test_ID'Image( Test ) ); + end; + end loop; + + Report.Result; + + end C761006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761007.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,419 ---- + -- C761007.A + -- + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a finalize procedure invoked by a transfer of control + -- due to selection of a terminate alternative attempts to propagate an + -- exception, the exception is ignored, but any other finalizations due + -- to be performed are performed. + -- + -- + -- TEST DESCRIPTION: + -- This test declares a nested controlled data type, and embeds an object + -- of that type within a protected type. Objects of the protected type + -- are created and destroyed, and the actions of the embedded controlled + -- object are checked. The container controlled type causes an exception + -- as the last part of it's finalization operation. + -- + -- This test utilizes several tasks to accomplish the objective. The + -- tasks contain delays to ensure that the expected order of processing + -- is indeed accomplished. + -- + -- Subtest 1: + -- local task object runs to normal completion + -- + -- Subtest 2: + -- local task aborts a nested task to cause finalization + -- + -- Subtest 3: + -- local task sleeps long enough to allow procedure started + -- asynchronously to go into infinite loop. Procedure is then aborted + -- via ATC, causing finalization of objects. + -- + -- Subtest 4: + -- local task object takes terminate alternative, causing finalization + -- + -- + -- CHANGE HISTORY: + -- 06 JUN 95 SAIC Initial version + -- 05 APR 96 SAIC Documentation changes + -- 03 MAR 97 PWB.CTA Allowed two finalization orders for ATC test + -- 02 DEC 97 EDS Remove duplicate characters from check string. + --! + + ---------------------------------------------------------------- C761007_0 + + with Ada.Finalization; + package C761007_0 is + + type Internal is new Ada.Finalization.Controlled + with record + Effect : Character; + end record; + + procedure Finalize( I: in out Internal ); + + Side_Effect : String(1..80); -- way bigger than needed + Side_Effect_Finger : Natural := 0; + + end C761007_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C761007_0 is + + procedure Finalize( I : in out Internal ) is + Previous_Side_Effect : Boolean := False; + begin + -- look to see if this character has been finalized yet + for SEI in 1..Side_Effect_Finger loop + Previous_Side_Effect := Previous_Side_Effect + or Side_Effect(Side_Effect_Finger) = I.Effect; + end loop; + + -- if not, then tack it on to the string, and touch the character + if not Previous_Side_Effect then + Side_Effect_Finger := Side_Effect_Finger +1; + Side_Effect(Side_Effect_Finger) := I.Effect; + TCTouch.Touch(I.Effect); + end if; + + end Finalize; + + end C761007_0; + + ---------------------------------------------------------------- C761007_1 + + with C761007_0; + with Ada.Finalization; + package C761007_1 is + + type Container is new Ada.Finalization.Controlled + with record + Effect : Character; + Content : C761007_0.Internal; + end record; + + procedure Finalize( C: in out Container ); + + Side_Effect : String(1..80); -- way bigger than needed + Side_Effect_Finger : Natural := 0; + + This_Exception_Is_Supposed_To_Be_Ignored : exception; + + end C761007_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body C761007_1 is + + procedure Finalize( C: in out Container ) is + Previous_Side_Effect : Boolean := False; + begin + -- look to see if this character has been finalized yet + for SEI in 1..Side_Effect_Finger loop + Previous_Side_Effect := Previous_Side_Effect + or Side_Effect(Side_Effect_Finger) = C.Effect; + end loop; + + -- if not, then tack it on to the string, and touch the character + if not Previous_Side_Effect then + Side_Effect_Finger := Side_Effect_Finger +1; + Side_Effect(Side_Effect_Finger) := C.Effect; + TCTouch.Touch(C.Effect); + end if; + + raise This_Exception_Is_Supposed_To_Be_Ignored; + + end Finalize; + + end C761007_1; + + ---------------------------------------------------------------- C761007_2 + with C761007_1; + package C761007_2 is + + protected type Prot_W_Fin_Obj is + procedure Set_Effects( Container, Filling: Character ); + private + The_Data_Under_Test : C761007_1.Container; + -- finalization for this will occur when the Prot_W_Fin_Obj object + -- "goes out of existence" for whatever reason. + end Prot_W_Fin_Obj; + + end C761007_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body C761007_2 is + + protected body Prot_W_Fin_Obj is + procedure Set_Effects( Container, Filling: Character ) is + begin + The_Data_Under_Test.Effect := Container; -- A, etc. + The_Data_Under_Test.Content.Effect := Filling; -- B, etc. + end Set_Effects; + end Prot_W_Fin_Obj; + + end C761007_2; + + ------------------------------------------------------------------ C761007 + + with Report; + with Impdef; + with TCTouch; + with C761007_0; + with C761007_1; + with C761007_2; + procedure C761007 is + + task type Subtests( Outer, Inner : Character) is + entry Ready; + entry Complete; + end Subtests; + + task body Subtests is + Local_Prot_W_Fin_Obj : C761007_2.Prot_W_Fin_Obj; + begin + Local_Prot_W_Fin_Obj.Set_Effects( Outer, Inner ); + + accept Ready; + + select + accept Complete; + or terminate; -- used in Subtest 4 + end select; + exception + -- the exception caused by the finalization of Local_Prot_W_Fin_Obj + -- should never be visible to this scope. + when others => Report.Failed("Exception in a Subtest object " + & Outer & Inner); + end Subtests; + + procedure Subtest_1 is + -- check the case where "nothing special" happens. + + This_Subtest : Subtests( 'A', 'B' ); + begin + + This_Subtest.Ready; + This_Subtest.Complete; + + while not This_Subtest'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + -- in the finalization of This_Subtest, the controlled object embedded in + -- the Prot_W_Fin_Obj will finalize. An exception is raised in the + -- container object, after "touching" it's tag character. + -- The finalization of the contained controlled object must be performed. + + + TCTouch.Validate( "AB", "Item embedded in task" ); + + + exception + when others => Report.Failed("Undesirable exception in Subtest_1"); + + end Subtest_1; + + procedure Subtest_2 is + -- check for explicit abort + + task Subtest_Task is + entry Complete; + end Subtest_Task; + + task body Subtest_Task is + + task Nesting; + task body Nesting is + Deep_Nesting : Subtests( 'E', 'F' ); + begin + if Report.Ident_Bool( True ) then + -- controlled objects have been created in the elaboration of + -- Deep_Nesting. Deep_Nesting must call the Set_Effects operation + -- in the Prot_W_Fin_Obj, and then hang waiting for the Complete + -- entry call. + Deep_Nesting.Ready; + abort Deep_Nesting; + else + Report.Failed("Dead code in Nesting"); + end if; + exception + when others => Report.Failed("Exception in Subtest_Task.Nesting"); + end Nesting; + + Local_2 : C761007_2.Prot_W_Fin_Obj; + + begin + -- Nesting has activated at this point, which implies the activation + -- of Deep_Nesting as well. + + Local_2.Set_Effects( 'C', 'D' ); + + -- wait for Nesting to terminate + + while not Nesting'Terminated loop + delay Impdef.Clear_Ready_Queue; + end loop; + + accept Complete; + + exception + when others => Report.Failed("Exception in Subtest_Task"); + end Subtest_Task; + + begin + + -- wait for everything in Subtest_Task to happen + Subtest_Task.Complete; + + while not Subtest_Task'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + TCTouch.Validate( "EFCD", "Aborted nested task" ); + + exception + when others => Report.Failed("Undesirable exception in Subtest_2"); + end Subtest_2; + + procedure Subtest_3 is + -- check abort caused by asynchronous transfer of control + + task Subtest_3_Task is + entry Complete; + end Subtest_3_Task; + + procedure Check_Atc_Operation is + Check_Atc : C761007_2.Prot_W_Fin_Obj; + begin + + Check_Atc.Set_Effects( 'G', 'H' ); + + + while Report.Ident_Bool( True ) loop -- wait to be aborted + if Report.Ident_Bool( True ) then + Impdef.Exceed_Time_Slice; + delay Impdef.Switch_To_New_Task; + else + Report.Failed("Optimization prevention"); + end if; + end loop; + + Report.Failed("Check_Atc_Operation loop completed"); + + end Check_Atc_Operation; + + task body Subtest_3_Task is + task Nesting is + entry Complete; + end Nesting; + + task body Nesting is + Nesting_3 : C761007_2.Prot_W_Fin_Obj; + begin + Nesting_3.Set_Effects( 'G', 'H' ); + + -- give Check_Atc_Operation sufficient time to perform it's + -- Set_Effects on it's local Prot_W_Fin_Obj object + delay Impdef.Clear_Ready_Queue; + + accept Complete; + exception + when others => Report.Failed("Exception in Subtest_3_Task.Nesting"); + end Nesting; + + Local_3 : C761007_2.Prot_W_Fin_Obj; + + begin -- Subtest_3_Task + + Local_3.Set_Effects( 'I', 'J' ); + + select + Nesting.Complete; + then abort ---------------------------------------------------- cause KL + Check_ATC_Operation; + end select; + + accept Complete; + + exception + when others => Report.Failed("Exception in Subtest_3_Task"); + end Subtest_3_Task; + + begin -- Subtest_3 + Subtest_3_Task.Complete; + + while not Subtest_3_Task'Terminated loop -- wait for finalization + delay Impdef.Clear_Ready_Queue; + end loop; + + TCTouch.Validate( "GHIJ", "Asynchronously aborted operation" ); + + exception + when others => Report.Failed("Undesirable exception in Subtest_3"); + end Subtest_3; + + procedure Subtest_4 is + -- check the case where transfer is caused by terminate alternative + -- highly similar to Subtest_1 + + This_Subtest : Subtests( 'M', 'N' ); + begin + + This_Subtest.Ready; + -- don't call This_Subtest.Complete; + + exception + when others => Report.Failed("Undesirable exception in Subtest_4"); + + end Subtest_4; + + begin -- Main test procedure. + + Report.Test ("C761007", "Check that if a finalize procedure invoked by " & + "a transfer of control or selection of a " & + "terminate alternative attempts to propagate " & + "an exception, the exception is ignored, but " & + "any other finalizations due to be performed " & + "are performed" ); + + Subtest_1; -- checks internal + + Subtest_2; -- checks internal + + Subtest_3; -- checks internal + + Subtest_4; + TCTouch.Validate( "MN", "transfer due to terminate alternative" ); + + Report.Result; + + end C761007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761010.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,447 ---- + -- C761010.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check the requirements of the new 7.6(17.1/1) from Technical + -- Corrigendum 1 (originally discussed as AI95-00083). + -- This new paragraph requires that the initialization of an object with + -- an aggregate does not involve calls to Adjust. + -- + -- TEST DESCRIPTION + -- We include several cases of initialization: + -- - Explicit initialization of an object declared by an + -- object declaration. + -- - Explicit initialization of a heap object. + -- - Default initialization of a record component. + -- - Initialization of a formal parameter during a call. + -- - Initialization of a formal parameter during a call with + -- a defaulted parameter. + -- - Lots of nested records, arrays, and pointers. + -- In this test, Initialize should never be called, because we + -- never declare a default-initialized controlled object (although + -- we do declare default-initialized records containing controlled + -- objects, with default expressions for the components). + -- Adjust should never be called, because every initialization + -- is via an aggregate. Finalize is called, because the objects + -- themselves need to be finalized. + -- Thus, Initialize and Adjust call Failed. + -- In some of the cases, these procedures will not yet be elaborated, + -- anyway. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 23 SEP 1999 RLB Improved comments, renamed, issued. + -- 10 APR 2000 RLB Corrected errors in comments and text, fixed + -- discriminant error. Fixed so that Report.Test + -- is called before any Report.Failed call. Added + -- a marker so that the failed subtest can be + -- determined. + -- 26 APR 2000 RAD Try to defeat optimizations. + -- 04 AUG 2000 RLB Corrected error in Check_Equal. + -- 18 AUG 2000 RLB Removed dubious main subprogram renames (see AI-172). + -- 19 JUL 2002 RLB Fixed to avoid calling comment after Report.Result. + -- + --! + + with Ada; use Ada; + with Report; use Report; pragma Elaborate_All(Report); + with Ada.Finalization; + package C761010_1 is + pragma Elaborate_Body; + function Square(X: Integer) return Integer; + private + type TC_Control is new Ada.Finalization.Limited_Controlled with null record; + procedure Initialize (Object : in out TC_Control); + procedure Finalize (Object : in out TC_Control); + TC_Finalize_Called : Boolean := False; + end C761010_1; + + package body C761010_1 is + function Square(X: Integer) return Integer is + begin + return X**2; + end Square; + + procedure Initialize (Object : in out TC_Control) is + begin + Test("C761010_1", + "Check that Adjust is not called" + & " when aggregates are used to initialize objects"); + end Initialize; + + procedure Finalize (Object : in out TC_Control) is + begin + if not TC_Finalize_Called then + Failed("Var_Strings Finalize never called"); + end if; + Result; + end Finalize; + + TC_Test : TC_Control; -- Starts test; finalization ends test. + end C761010_1; + + with Ada.Finalization; + package C761010_1.Var_Strings is + type Var_String(<>) is private; + + Some_String: constant Var_String; + + function "=" (X, Y: Var_String) return Boolean; + + procedure Check_Equal(X, Y: Var_String); + -- Calls to this are used to defeat optimizations + -- that might otherwise defeat the purpose of the + -- test. I'm talking about the optimization of removing + -- unused controlled objects. + + private + + type String_Ptr is access constant String; + + type Var_String(Length: Natural) is new Finalization.Controlled with + record + Comp_1: String_Ptr := new String'(2..Square(Length)-1 => 'x'); + Comp_2: String_Ptr(1..Length) := null; + Comp_3: String(Length..Length) := (others => '.'); + TC_Lab: Character := '1'; + end record; + procedure Initialize(X: in out Var_String); + procedure Adjust(X: in out Var_String); + procedure Finalize(X: in out Var_String); + + Some_String: constant Var_String + := (Finalization.Controlled with Length => 1, + Comp_1 => null, + Comp_2 => null, + Comp_3 => "x", + TC_Lab => 'A'); + + Another_String: constant Var_String + := (Finalization.Controlled with Length => 10, + Comp_1 => Some_String.Comp_2, + Comp_2 => new String'("1234567890"), + Comp_3 => "x", + TC_Lab => 'B'); + + end C761010_1.Var_Strings; + + package C761010_1.Var_Strings.Types is + + type Ptr is access all Var_String; + Ptr_Const: constant Ptr; + + type Ptr_Arr is array(Positive range <>) of Ptr; + Ptr_Arr_Const: constant Ptr_Arr; + + type Ptr_Rec(N_Strings: Natural) is + record + Ptrs: Ptr_Arr(1..N_Strings); + end record; + Ptr_Rec_Const: constant Ptr_Rec; + + private + + Ptr_Const: constant Ptr := new Var_String' + (Finalization.Controlled with + Length => 1, + Comp_1 => null, + Comp_2 => null, + Comp_3 => (others => ' '), + TC_Lab => 'C'); + + Ptr_Arr_Const: constant Ptr_Arr := + (1 => new Var_String' + (Finalization.Controlled with + Length => 1, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'D')); + + Ptr_Rec_Var: Ptr_Rec := + (3, + (1..2 => null, + 3 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'E'))); + + Ptr_Rec_Const: constant Ptr_Rec := + (3, + (1..2 => null, + 3 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'F'))); + + type Arr is array(Positive range <>) of Var_String(Length => 2); + + Arr_Var: Arr := + (1 => (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'G')); + + type Rec(N_Strings: Natural) is + record + Ptrs: Ptr_Rec(N_Strings); + Strings: Arr(1..N_Strings) := + (others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'H')); + end record; + + Default_Init_Rec_Var: Rec(N_Strings => 10); + Empty_Default_Init_Rec_Var: Rec(N_Strings => 0); + + Rec_Var: Rec(N_Strings => 2) := + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'J'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'K'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'L'))); + + procedure Check_Equal(X, Y: Rec); + + end C761010_1.Var_Strings.Types; + + package body C761010_1.Var_Strings.Types is + + -- Check that parameter passing doesn't create new objects, + -- and therefore doesn't need extra Adjusts or Finalizes. + + procedure Check_Equal(X, Y: Rec) is + -- We assume that the arguments should be equal. + -- But we cannot assume that pointer values are the same. + begin + if X.N_Strings /= Y.N_Strings then + Failed("Records should be equal (1)"); + else + for I in 1 .. X.N_Strings loop + if X.Ptrs.Ptrs(I) /= Y.Ptrs.Ptrs(I) then + if X.Ptrs.Ptrs(I) = null or else + Y.Ptrs.Ptrs(I) = null or else + X.Ptrs.Ptrs(I).all /= Y.Ptrs.Ptrs(I).all then + Failed("Records should be equal (2)"); + end if; + end if; + if X.Strings(I) /= Y.Strings(I) then + Failed("Records should be equal (3)"); + end if; + end loop; + end if; + end Check_Equal; + + procedure My_Check_Equal + (X: Rec := Rec_Var; + Y: Rec := + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'M'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'N'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'O')))) + renames Check_Equal; + begin + + My_Check_Equal; + + Check_Equal(Rec_Var, + (N_Strings => 2, + Ptrs => + (2, + (1..1 => null, + 2 => new Var_String' + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'P'))), + Strings => + (1 => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'Q'), + others => + (Finalization.Controlled with + Length => 2, + Comp_1 => new String'("abcdefghij"), + Comp_2 => null, + Comp_3 => (2..2 => ' '), + TC_Lab => 'R')))); + + -- Use the objects to avoid optimizations. + + Check_Equal(Ptr_Const.all, Ptr_Const.all); + Check_Equal(Ptr_Arr_Const(1).all, Ptr_Arr_Const(1).all); + Check_Equal(Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all, + Ptr_Rec_Const.Ptrs(Ptr_Rec_Const.N_Strings).all); + Check_Equal(Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all, + Ptr_Rec_Var.Ptrs(Ptr_Rec_Var.N_Strings).all); + + if Report.Equal (3, 2) then + -- Can't get here. + Check_Equal (Arr_Var(1), Default_Init_Rec_Var.Strings(1)); + Check_Equal (Arr_Var(1), Empty_Default_Init_Rec_Var.Strings(1)); + end if; + + end C761010_1.Var_Strings.Types; + + with C761010_1.Var_Strings; + with C761010_1.Var_Strings.Types; + procedure C761010_1.Main is + begin + -- Report.Test is called by the elaboration of C761010_1, and + -- Report.Result is called by the finalization of C761010_1. + -- This will happen before any objects are created, and after any + -- are finalized. + null; + end C761010_1.Main; + + with C761010_1.Main; + procedure C761010 is + begin + C761010_1.Main; + end C761010; + + package body C761010_1.Var_Strings is + + Some_Error: exception; + + procedure Initialize(X: in out Var_String) is + begin + Failed("Initialize should never be called"); + raise Some_Error; + end Initialize; + + procedure Adjust(X: in out Var_String) is + begin + Failed("Adjust should never be called - case " & X.TC_Lab); + raise Some_Error; + end Adjust; + + procedure Finalize(X: in out Var_String) is + begin + Comment("Finalize called - case " & X.TC_Lab); + C761010_1.TC_Finalize_Called := True; + end Finalize; + + function "=" (X, Y: Var_String) return Boolean is + -- Don't check the TC_Lab component, but do check the contents of the + -- access values. + begin + if X.Length /= Y.Length then + return False; + end if; + if X.Comp_3 /= Y.Comp_3 then + return False; + end if; + if X.Comp_1 /= Y.Comp_1 then + -- Still OK if the values are the same. + if X.Comp_1 = null or else + Y.Comp_1 = null or else + X.Comp_1.all /= Y.Comp_1.all then + return False; + --else OK. + end if; + end if; + if X.Comp_2 /= Y.Comp_2 then + -- Still OK if the values are the same. + if X.Comp_2 = null or else + Y.Comp_2 = null or else + X.Comp_2.all /= Y.Comp_2.all then + return False; + end if; + end if; + return True; + end "="; + + procedure Check_Equal(X, Y: Var_String) is + begin + if X /= Y then + Failed("Check_Equal of Var_String"); + end if; + end Check_Equal; + + begin + Check_Equal(Another_String, Another_String); + end C761010_1.Var_Strings; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761011.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,410 ---- + -- C761011.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a Finalize propagates an exception, other Finalizes due + -- to be performed are performed. + -- Case 1: A Finalize invoked due to the end of execution of + -- a master. (Defect Report 8652/0023, as reflected in Technical + -- Corrigendum 1). + -- Case 2: A Finalize invoked due to finalization of an anonymous + -- object. (Defect Report 8652/0023, as reflected in Technical + -- Corrigendum 1). + -- Case 3: A Finalize invoked due to the transfer of control + -- due to an exit statement. + -- Case 4: A Finalize invoked due to the transfer of control + -- due to a goto statement. + -- Case 5: A Finalize invoked due to the transfer of control + -- due to a return statement. + -- Case 6: A Finalize invoked due to the transfer of control + -- due to raises an exception. + -- + -- + -- CHANGE HISTORY: + -- 29 JAN 2001 PHL Initial version + -- 15 MAR 2001 RLB Readied for release; added optimization blockers. + -- Added test cases for paragraphs 18 and 19 of the + -- standard (the previous tests were withdrawn). + -- + --! + with Ada.Finalization; + use Ada.Finalization; + package C761011_0 is + + type Ctrl (D : Boolean) is new Ada.Finalization.Controlled with + record + Finalized : Boolean := False; + case D is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + function Create (Id : Integer) return Ctrl; + procedure Finalize (Obj : in out Ctrl); + function Was_Finalized (Id : Integer) return Boolean; + procedure Use_It (Obj : in Ctrl); + -- Use Obj to prevent optimization. + + end C761011_0; + + with Report; + use Report; + package body C761011_0 is + + User_Error : exception; + + Finalize_Called : array (0 .. 50) of Boolean := (others => False); + + function Create (Id : Integer) return Ctrl is + Obj : Ctrl (Boolean'Val (Id mod Ident_Int (2))); + begin + case Obj.D is + when False => + Obj.C1 := Ident_Int (Id); + when True => + Obj.C2 := Float (Ident_Int (Id + Ident_Int (Id))); + end case; + return Obj; + end Create; + + procedure Finalize (Obj : in out Ctrl) is + begin + if not Obj.Finalized then + Obj.Finalized := True; + if Obj.D then + if Integer (Obj.C2 / 2.0) mod Ident_Int (10) = + Ident_Int (3) then + raise User_Error; + else + Finalize_Called (Integer (Obj.C2) / 2) := True; + end if; + else + if Obj.C1 mod Ident_Int (10) = Ident_Int (0) then + raise Tasking_Error; + else + Finalize_Called (Obj.C1) := True; + end if; + end if; + end if; + end Finalize; + + function Was_Finalized (Id : Integer) return Boolean is + begin + return Finalize_Called (Ident_Int (Id)); + end Was_Finalized; + + procedure Use_It (Obj : in Ctrl) is + -- Use Obj to prevent optimization. + begin + case Obj.D is + when True => + if not Equal (Boolean'Pos(Obj.Finalized), + Boolean'Pos(Obj.Finalized)) then + Failed ("Identity check - 1"); + end if; + when False => + if not Equal (Obj.C1, Obj.C1) then + Failed ("Identity check - 2"); + end if; + end case; + end Use_It; + + end C761011_0; + + with Ada.Exceptions; + use Ada.Exceptions; + with Ada.Finalization; + with C761011_0; + use C761011_0; + with Report; + use Report; + procedure C761011 is + begin + Test + ("C761011", + " Check that if a finalize propagates an exception, other finalizes " & + "due to be performed are performed"); + + Normal: -- Case 1 + begin + declare + Obj1 : Ctrl := Create (Ident_Int (1)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (2)); + Obj3 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int + (3))); -- Finalization: User_Error + Obj4 : Ctrl := Create (Ident_Int (4)); + begin + Comment ("Finalization of normal object"); + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + end; + Failed ("No exception raised by finalization of normal object"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (1)) or + not Was_Finalized (Ident_Int (2)) or + not Was_Finalized (Ident_Int (4)) then + Failed ("Missing finalizations - 1"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 1"); + end Normal; + + Anon: -- Case 2 + begin + declare + Obj1 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (5))); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (6)); + Obj3 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (7))); + Obj4 : Ctrl := Create (Ident_Int (8)); + begin + Comment ("Finalization of anonymous object"); + + -- The finalization of the anonymous object below will raise + -- Tasking_Error. + if Create (Ident_Int (10)).C1 /= Ident_Int (10) then + Failed ("Incorrect construction of an anonymous object"); + end if; + Failed ("Anonymous object not finalized at the end of the " & + "enclosing statement"); + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + end; + Failed ("No exception raised by finalization of an anonymous " & + "object of a function"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (5)) or + not Was_Finalized (Ident_Int (6)) or + not Was_Finalized (Ident_Int (7)) or + not Was_Finalized (Ident_Int (8)) then + Failed ("Missing finalizations - 2"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 2"); + end Anon; + + An_Exit: -- Case 3 + begin + for Counter in 1 .. 4 loop + declare + Obj1 : Ctrl := Create (Ident_Int (11)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (12)); + Obj3 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float ( + Ident_Int(13))); -- Finalization: User_Error + Obj4 : Ctrl := Create (Ident_Int (14)); + begin + Comment ("Finalization because of exit of loop"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + exit when not Ident_Bool (Obj2.D); + + Failed ("Exit not taken"); + end; + end loop; + Failed ("No exception raised by finalization on exit"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (11)) or + not Was_Finalized (Ident_Int (12)) or + not Was_Finalized (Ident_Int (14)) then + Failed ("Missing finalizations - 3"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 3"); + end An_Exit; + + A_Goto: -- Case 4 + begin + declare + Obj1 : Ctrl := Create (Ident_Int (15)); + Obj2 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (0)); + -- Finalization: Tasking_Error + Obj3 : Ctrl := Create (Ident_Int (16)); + Obj4 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (17))); + begin + Comment ("Finalization because of goto statement"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + if Ident_Bool (Obj4.D) then + goto Continue; + end if; + + Failed ("Goto not taken"); + end; + <> + Failed ("No exception raised by finalization on goto"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (15)) or + not Was_Finalized (Ident_Int (16)) or + not Was_Finalized (Ident_Int (17)) then + Failed ("Missing finalizations - 4"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 4"); + end A_Goto; + + A_Return: -- Case 5 + declare + procedure Do_Something is + Obj1 : Ctrl := Create (Ident_Int (18)); + Obj2 : Ctrl := (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float (Ident_Int (19))); + Obj3 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (20)); + -- Finalization: Tasking_Error + begin + Comment ("Finalization because of return statement"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + + if not Ident_Bool (Obj3.D) then + return; + end if; + + Failed ("Return not taken"); + end Do_Something; + begin + Do_Something; + Failed ("No exception raised by finalization on return statement"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (18)) or + not Was_Finalized (Ident_Int (19)) then + Failed ("Missing finalizations - 5"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 5"); + end A_Return; + + Except: -- Case 6 + declare + Funky_Error : exception; + + procedure Do_Something is + Obj1 : Ctrl := + (Ada.Finalization.Controlled with + D => True, + Finalized => Ident_Bool (False), + C2 => 2.0 * Float ( + Ident_Int(23))); -- Finalization: User_Error + Obj2 : Ctrl := Create (Ident_Int (24)); + Obj3 : Ctrl := Create (Ident_Int (25)); + Obj4 : constant Ctrl := (Ada.Finalization.Controlled with + D => False, + Finalized => Ident_Bool (False), + C1 => Ident_Int (26)); + begin + Comment ("Finalization because of exception propagation"); + + Use_It (Obj1); -- Prevent optimization of Objects. + Use_It (Obj2); -- (Critical if AI-147 is adopted.) + Use_It (Obj3); + Use_It (Obj4); + + if not Ident_Bool (Obj4.D) then + raise Funky_Error; + end if; + + Failed ("Exception not raised"); + end Do_Something; + begin + Do_Something; + Failed ("No exception raised by finalization on exception " & + "propagation"); + exception + when Program_Error => + if not Was_Finalized (Ident_Int (24)) or + not Was_Finalized (Ident_Int (25)) or + not Was_Finalized (Ident_Int (26)) then + Failed ("Missing finalizations - 6"); + end if; + when Funky_Error => + Failed ("Wrong exception propagated"); + -- Should be Program_Error (7.6.1(19)). + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Message (E) & " - 6"); + end Except; + + Result; + end C761011; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c7/c761012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c7/c761012.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C761012.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an anonymous object is finalized with its enclosing master if + -- a transfer of control or exception occurs prior to performing its normal + -- finalization. (Defect Report 8652/0023, as reflected in + -- Technical Corrigendum 1, RM95 7.6.1(13.1/1)). + -- + -- CHANGE HISTORY: + -- 29 JAN 2001 PHL Initial version. + -- 5 DEC 2001 RLB Reformatted for ACATS. + -- + --! + with Ada.Finalization; + use Ada.Finalization; + package C761012_0 is + + type Ctrl (D : Boolean) is new Controlled with + record + case D is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + function Create return Ctrl; + procedure Finalize (Obj : in out Ctrl); + function Finalize_Was_Called return Boolean; + + end C761012_0; + + with Report; + use Report; + package body C761012_0 is + + Finalization_Flag : Boolean := False; + + function Create return Ctrl is + Obj : Ctrl (Ident_Bool (True)); + begin + Obj.C2 := 3.0; + return Obj; + end Create; + + procedure Finalize (Obj : in out Ctrl) is + begin + Finalization_Flag := True; + end Finalize; + + function Finalize_Was_Called return Boolean is + begin + if Finalization_Flag then + Finalization_Flag := False; + return True; + else + return False; + end if; + end Finalize_Was_Called; + + end C761012_0; + + with Ada.Exceptions; + use Ada.Exceptions; + with C761012_0; + use C761012_0; + with Report; + use Report; + procedure C761012 is + begin + Test ("C761012", + "Check that an anonymous object is finalized with its enclosing " & + "master if a transfer of control or exception occurs prior to " & + "performing its normal finalization"); + + Excep: + begin + + declare + I : Integer := Create.C1; -- Raises Constraint_Error + begin + Failed + ("Improper component selection did not raise Constraint_Error, I =" & + Integer'Image (I)); + exception + when Constraint_Error => + Failed ("Constraint_Error caught by the wrong handler"); + end; + + Failed ("Transfer of control did not happen correctly"); + + exception + when Constraint_Error => + if not Finalize_Was_Called then + Failed ("Finalize wasn't called when the master was left " & + "- Constraint_Error"); + end if; + when E: others => + Failed ("Exception " & Exception_Name (E) & + " raised - " & Exception_Information (E)); + end Excep; + + Transfer: + declare + Finalize_Was_Called_Before_Leaving_Exit : Boolean; + begin + + begin + loop + exit when Create.C2 = 3.0; + end loop; + Finalize_Was_Called_Before_Leaving_Exit := Finalize_Was_Called; + if Finalize_Was_Called_Before_Leaving_Exit then + Comment ("Finalize called before the transfer of control"); + end if; + end; + + if not Finalize_Was_Called and then + not Finalize_Was_Called_Before_Leaving_Exit then + Failed ("Finalize wasn't called when the master was left " & + "- transfer of control"); + end if; + end Transfer; + + Result; + end C761012; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83007a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C83007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FORMAL PARAMETER OF A SUBPROGRAM DECLARED BY A + -- RENAMING DECLARATION CAN HAVE THE SAME IDENTIFIER AS A + -- DECLARATION IN THE BODY OF THE RENAMED SUBPROGRAM. + + -- HISTORY: + -- VCL 02/18/88 CREATED ORIGINAL TEST. + + + WITH REPORT; USE REPORT; + PROCEDURE C83007A IS + BEGIN + TEST ("C83007A", "A FORMAL PARAMETER OF A SUBPROGRAM DECLARED " & + "BY A RENAMING DECLARATION CAN HAVE THE SAME " & + "IDENTIFIER AS A DECLARATION IN THE BODY OF " & + "THE RENAMED SUBPROGRAM"); + DECLARE + PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING); + + PROCEDURE R (D1 : INTEGER; + D2 : FLOAT; + D3 : STRING) RENAMES P; + + PROCEDURE P (ONE : INTEGER; TWO : FLOAT; THREE : STRING) IS + TYPE D1 IS RANGE 1..10; + I : D1 := D1(IDENT_INT (7)); + + D2 : FLOAT; + + FUNCTION D3 RETURN STRING IS + BEGIN + RETURN "D3"; + END D3; + + FUNCTION IDENT_FLOAT (VAL : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN VAL; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLOAT; + + BEGIN + IF ONE /= 5 THEN + FAILED ("INCORRECT VALUE FOR PARAMETER ONE"); + END IF; + IF TWO /= 4.5 THEN + FAILED ("INCORRECT VALUE FOR PARAMETER TWO"); + END IF; + IF THREE /= "R1" THEN + FAILED ("INCORRECT VALUE FOR PARAMETER THREE"); + END IF; + + IF I /= 7 THEN + FAILED ("INCORRECT VALUE FOR OBJECT I"); + END IF; + D2 := IDENT_FLOAT (3.5); + IF D2 /= 3.5 THEN + FAILED ("INCORRECT VALUE FOR OBJECT D2"); + END IF; + IF D3 /= "D3" THEN + FAILED ("INCORRECT VALUE FOR FUNCTION D3"); + END IF; + END P; + BEGIN + R (D1=>5, D2=>4.5, D3=>"R1"); + END; + + RESULT; + END C83007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83012d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83012d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83012d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83012d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C83012D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WITHIN A GENERIC PACKAGE INSTANTIATION, A DECLARATION + -- HAVING THE SAME IDENTIFIER AS THE PACKAGE IS VISIBLE BY + -- SELECTION. + + -- HISTORY: + -- JET 08/11/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83012D IS + + PACKAGE PACK IS + SUBTYPE PACK1 IS INTEGER; + PACK2 : INTEGER := 2; + END PACK; + + TYPE REC IS RECORD + PACK3 : INTEGER; + PACK4 : INTEGER; + END RECORD; + + R : REC := (PACK3 => 3, PACK4 => 1); + + GENERIC + TYPE T IS RANGE <>; + PACKAGE GEN1 IS + J : INTEGER := IDENT_INT(1); + END GEN1; + + GENERIC + I : INTEGER; + PACKAGE GEN2 IS + J : INTEGER := IDENT_INT(I); + END GEN2; + + GENERIC + R : REC; + PACKAGE GEN3 IS + J : INTEGER := IDENT_INT(R.PACK4); + END GEN3; + + GENERIC + PACK6 : INTEGER; + PACKAGE GEN4 IS + J : INTEGER := IDENT_INT(PACK6); + END GEN4; + + FUNCTION FUNC (PACK5: INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(PACK5); + END FUNC; + + PACKAGE PACK1 IS NEW GEN1(PACK.PACK1); + PACKAGE PACK2 IS NEW GEN2(PACK.PACK2); + PACKAGE PACK3 IS NEW GEN2(R.PACK3); + PACKAGE PACK4 IS NEW GEN3((1, PACK4 => 4)); + PACKAGE PACK5 IS NEW GEN2(FUNC(PACK5 => 5)); + PACKAGE PACK6 IS NEW GEN4(PACK6 => 6); + + BEGIN + TEST ("C83012D", "CHECK THAT WITHIN A GENERIC PACKAGE " & + "INSTANTIATION, A DECLARATION HAVING THE SAME " & + "IDENTIFIER AS THE PACKAGE IS VISIBLE BY " & + "SELECTION"); + + IF PACK1.J /= 1 THEN + FAILED ("INCORRECT VALUE OF PACK1.J"); + END IF; + + IF PACK2.J /= 2 THEN + FAILED ("INCORRECT VALUE OF PACK2.J"); + END IF; + + IF PACK3.J /= 3 THEN + FAILED ("INCORRECT VALUE OF PACK3.J"); + END IF; + + IF PACK4.J /= 4 THEN + FAILED ("INCORRECT VALUE OF PACK4.J"); + END IF; + + IF PACK5.J /= 5 THEN + FAILED ("INCORRECT VALUE OF PACK5.J"); + END IF; + + IF PACK6.J /= 6 THEN + FAILED ("INCORRECT VALUE OF PACK6.J"); + END IF; + + RESULT; + + END C83012D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- C83022A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY + -- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE + -- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE + -- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE + -- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAH DECLARATION. + + -- HISTORY: + -- TBN 08/01/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83022A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83022A", "CHECK THAT A DECLARATION IN A SUBPROGRAM " & + "FORMAL PART OR BODY HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- SUBPROGRAM DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END INNER; + + BEGIN -- ONE + INNER (A); + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- FORMAL PARAMETER OF SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + BEGIN -- TWO + INNER (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- AFTER THE SPECIFICATION OF SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + + FUNCTION INNER (X : INTEGER) RETURN INTEGER; + + B : INTEGER := A; + + FUNCTION INNER (X : INTEGER) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + IF THREE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + IF THREE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER; + + BEGIN -- THREE + IF INNER(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + FOUR: + DECLARE -- RENAMING DECLARATION. + A : INTEGER := IDENT_INT(2); + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER); + + PROCEDURE INNER (Z : IN INTEGER := A; + A : IN OUT INTEGER) RENAMES TEMPLATE; + + B : INTEGER := A; + OBJ : INTEGER := 5; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS + BEGIN -- TEMPLATE + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 30"); + END IF; + IF Y /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 31"); + END IF; + Y := IDENT_INT(2 * X); + IF FOUR.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " & + "32"); + END IF; + END TEMPLATE; + + BEGIN -- FOUR + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32"); + END IF; + INNER (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 33"); + END IF; + END FOUR; + + FIVE: + DECLARE -- GENERIC FORMAL SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE INNER (X : IN OUT INTEGER); + + GENERIC + WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>; + PACKAGE P IS + PAC_VAR : INTEGER := 1; + END P; + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41"); + END IF; + IF FIVE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42"); + END IF; + IF FIVE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43"); + END IF; + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 45"); + END IF; + IF EQUAL(1,1) THEN + X := A; + ELSE + X := FIVE.A; + END IF; + END INNER; + + PACKAGE BODY P IS + BEGIN + SUBPR (A); + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 46"); + END IF; + IF PAC_VAR /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR PAC_VAR - 47"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (INNER); + + BEGIN -- FIVE + NULL; + END FIVE; + + SIX: + DECLARE -- GENERIC INSTANTIATION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER); + + PROCEDURE INNER (X : IN INTEGER := SIX.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -50"); + END IF; + IF SIX.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 51"); + END IF; + IF SIX.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 52"); + END IF; + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 53"); + END IF; + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 54"); + END IF; + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PROCEDURE SUBPR IS NEW INNER; + + BEGIN -- SIX + SUBPR (A => OBJ); + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 55"); + END IF; + END SIX; + + SEVEN: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS + BEGIN + X := INTEGER(F); + END INNER; + + BEGIN + FLO := 6.25; + INNER (OBJ, FLO); + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END SEVEN; + + + RESULT; + END C83022A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022g0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C83022G0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY + -- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE + -- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE + -- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE + -- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED + -- SEPARATELY AS A SUBUNIT. + + -- SEPARATE FILES ARE: + -- C83022G0M.ADA - (THIS FILE) MAIN PROGRAM. + -- C83022G1.ADA -- SUBPROGRAM BODIES. + + -- HISTORY: + -- BCB 08/26/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C83022G0M IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + OBJ : INTEGER := IDENT_INT(3); + + FLO : FLOAT := 5.0; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER); + + PROCEDURE INNER4 (Z : IN INTEGER := A; + A : IN OUT INTEGER) RENAMES TEMPLATE; + + PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER2 (X : IN INTEGER := A; + A : IN OUT INTEGER) IS SEPARATE; + + FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS SEPARATE; + + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER5 (X : IN OUT INTEGER) IS SEPARATE; + + GENERIC + WITH PROCEDURE SUBPR (Y : IN OUT INTEGER) IS <>; + PACKAGE P IS + PAC_VAR : INTEGER := 1; + END P; + + PACKAGE BODY P IS + BEGIN + SUBPR (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 1"); + END IF; + + IF PAC_VAR /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR PAC_VAR - 2"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (INNER5); + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS SEPARATE; + + BEGIN + TEST ("C83022G", "CHECK THAT A DECLARATION IN A SUBPROGRAM " & + "FORMAL PART OR BODY HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + A := IDENT_INT(2); + B := A; + + INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 3"); + END IF; + + A := IDENT_INT(2); + + INNER2 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 4"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF INNER3(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 5"); + END IF; + + A := IDENT_INT(2); + + B := A; + OBJ := 5; + + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 6"); + END IF; + + INNER4 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 7"); + END IF; + + OBJ := 1; + + FLO := 6.25; + + INNER6 (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 8"); + END IF; + + RESULT; + END C83022G0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83022g1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C83022G1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A SUBPROGRAM FORMAL PART OR BODY + -- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE + -- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE + -- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE + -- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION, IF THE SUBPROGRAM BODY IS COMPILED + -- SEPARATELY AS A SUBUNIT. + + -- HISTORY: + -- BCB 08/26/88 CREATED ORIGINAL TEST. + + SEPARATE (C83022G0M) + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83022G0M.A; + END IF; + END INNER; + + SEPARATE (C83022G0M) + PROCEDURE INNER2 (X : IN INTEGER := C83022G0M.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER2; + + SEPARATE (C83022G0M) + FUNCTION INNER3 (X : INTEGER) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER3; + + SEPARATE (C83022G0M) + PROCEDURE TEMPLATE (X : IN INTEGER := A; + Y : IN OUT INTEGER) IS + BEGIN -- TEMPLATE + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 30"); + END IF; + + IF Y /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VARIABLE - 31"); + END IF; + + Y := IDENT_INT(2 * X); + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR OUTER HOMOGRAPH - " & + "32"); + END IF; + END TEMPLATE; + + SEPARATE (C83022G0M) + PROCEDURE INNER5 (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 41"); + END IF; + + IF C83022G0M.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 42"); + END IF; + + IF C83022G0M.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 43"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 44"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 45"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83022G0M.A; + END IF; + END INNER5; + + SEPARATE (C83022G0M) + PROCEDURE INNER6 (X : IN OUT INTEGER; F : IN FLOAT) IS + BEGIN + X := INTEGER(F); + END INNER6; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83023a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83023a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83023a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83023a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + -- C83023A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A DECLARATIVE REGION OF A TASK + -- HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE + -- OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH DECLARATIVE + -- REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH AND THE + -- OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 08/29/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83023A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83023A", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION OF A TASK HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + TASK BODY INNER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" & + " - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" & + " - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " & + "- 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE " & + "- 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END HERE; + END INNER; + + BEGIN -- ONE + INNER.HERE(A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- AFTER THE SPECIFICATION OF TASK. + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + A : INTEGER := IDENT_INT(2); + + B : INTEGER := A; + + TASK BODY INNER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH" & + " - 10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH" & + " - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE " & + "- 12"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE " & + "- 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END HERE; + END INNER; + + BEGIN -- TWO + INNER.HERE(A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + TASK INNER IS + ENTRY HERE (X : IN OUT INTEGER); + END INNER; + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + TASK BODY INNER IS + F : FLOAT := 6.25; + BEGIN + ACCEPT HERE (X : IN OUT INTEGER) DO + X := INTEGER(F); + END HERE; + END INNER; + + BEGIN + INNER.HERE (OBJ); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20"); + END IF; + END THREE; + + RESULT; + END C83023A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + -- C83024A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A DECLARATIVE REGION FOR A GENERIC + -- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK + -- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH + -- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH + -- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAH DECLARATION. + + -- HISTORY: + -- BCB 08/30/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C83024A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83024A", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION FOR A GENERIC PACKAGE HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + X : IN INTEGER := A; + A : IN OUT INTEGER; + PACKAGE INNER IS + C : INTEGER := A; + END INNER; + + PACKAGE BODY INNER IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (A => OBJ); + + BEGIN -- ONE + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END ONE; + + TWO: + DECLARE -- AFTER THE SPECIFICATION OF PACKAGE. + A : INTEGER := IDENT_INT(2); + + GENERIC + X : IN OUT INTEGER; + PACKAGE INNER IS + A : INTEGER := IDENT_INT(3); + END INNER; + + B : INTEGER := A; + + PACKAGE BODY INNER IS + C : INTEGER := TWO.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (A); + + BEGIN -- TWO + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 6.25; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + GENERIC + X : IN OUT INTEGER; + F : IN FLOAT; + PACKAGE INNER IS + END INNER; + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PACKAGE BODY INNER IS + BEGIN + X := INTEGER(F); + END INNER; + + PACKAGE NEW_INNER IS NEW INNER (OBJ, FLO); + + BEGIN + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END THREE; + + RESULT; + END C83024A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024e0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C83024E0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC + -- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK + -- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH + -- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH + -- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY + -- COMPILED, BUT NOT AS A SUBUNIT. + + -- HISTORY: + -- BCB 08/30/88 CREATED ORIGINAL TEST. + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION C83024E_GEN_FUN RETURN T; + + FUNCTION C83024E_GEN_FUN RETURN T IS + BEGIN + RETURN X; + END C83024E_GEN_FUN; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE(REPORT); + PACKAGE C83024E_P1 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN OUT INTEGER; + PACKAGE C83024E_PACK1 IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + END C83024E_PACK1; + END C83024E_P1; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE(REPORT); + PACKAGE C83024E_P2 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN INTEGER := A; + A : IN OUT INTEGER; + PACKAGE C83024E_PACK2 IS + C : INTEGER := A; + END C83024E_PACK2; + END C83024E_P2; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE(REPORT); + PACKAGE C83024E_P3 IS + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + PROCEDURE REQUIRE_BODY; + + GENERIC + X : IN OUT INTEGER; + PACKAGE C83024E_PACK3 IS + END C83024E_PACK3; + END C83024E_P3; + + WITH REPORT; USE REPORT; + WITH C83024E_GEN_FUN; + PRAGMA ELABORATE(REPORT,C83024E_GEN_FUN); + PACKAGE C83024E_P4 IS + OBJ : INTEGER := IDENT_INT(1); + FLO : FLOAT := 6.25; + + PROCEDURE REQUIRE_BODY; + + FUNCTION F IS NEW C83024E_GEN_FUN (INTEGER, OBJ); + FUNCTION F IS NEW C83024E_GEN_FUN (FLOAT, FLO); + + GENERIC + X : IN OUT INTEGER; + F : IN FLOAT; + PACKAGE C83024E_PACK4 IS + END C83024E_PACK4; + END C83024E_P4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83024e1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,220 ---- + -- C83024E1M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC + -- PACKAGE HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK + -- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH + -- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH + -- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION, IF THE GENERIC PACKAGE BODY IS SEPARATELY + -- COMPILED, BUT NOT AS A SUBUNIT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT SEPARATE + -- COMPILATIONS OF GENERIC SPECIFICATIONS AND BODIES. + + -- SEPARATE FILES ARE: + -- C83024E0.ADA -- GENERIC PACKAGE SPECIFICATIONS. + -- C83024E1M.ADA - (THIS FILE) GENERIC PACKAGE BODIES AND + -- MAIN PROGRAM. + + -- HISTORY: + -- BCB 08/30/88 CREATED ORIGINAL TEST. + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + PACKAGE BODY C83024E_P1 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK1 IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83024E_P1.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83024E_P1.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83024E_P1.A; + END IF; + END C83024E_PACK1; + END C83024E_P1; + + PACKAGE BODY C83024E_P2 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK2 IS + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF C83024E_P2.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83024E_P2.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END C83024E_PACK2; + END C83024E_P2; + + PACKAGE BODY C83024E_P3 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK3 IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83024E_P3.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83024E_P3.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + NULL; + END IF; + END C83024E_PACK3; + END C83024E_P3; + + PACKAGE BODY C83024E_P4 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY C83024E_PACK4 IS + BEGIN + X := INTEGER(F); + END C83024E_PACK4; + END C83024E_P4; + + WITH REPORT; USE REPORT; + WITH C83024E_P1; WITH C83024E_P2; + WITH C83024E_P3; WITH C83024E_P4; + USE C83024E_P1; USE C83024E_P2; + USE C83024E_P3; USE C83024E_P4; + PROCEDURE C83024E1M IS + + BEGIN + TEST ("C83024E", "CHECK THAT A DECLARATION IN THE DECLARATIVE " & + "REGION OF A GENERIC PACKAGE HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + DECLARE + PACKAGE NEW_C83024E_PACK1 IS NEW C83024E_PACK1 (C83024E_P1.A); + BEGIN + IF C83024E_P1.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK2 IS + NEW C83024E_PACK2 (A => C83024E_P2.OBJ); + BEGIN + IF C83024E_P2.OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK3 IS NEW C83024E_PACK3 (C83024E_P3.A); + BEGIN + IF C83024E_P3.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END; + + DECLARE + PACKAGE NEW_C83024E_PACK4 IS + NEW C83024E_PACK4 (C83024E_P4.OBJ, FLO); + BEGIN + IF C83024E_P4.OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 60"); + END IF; + END; + + RESULT; + END C83024E1M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83025a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83025a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83025a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83025a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,283 ---- + -- C83025A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN THE DECLARATIVE REGION OF A GENERIC + -- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK + -- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH + -- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH + -- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 08/31/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C83025A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83025A", "CHECK THAT A DECLARATION IN THE DECLARATIVE " & + "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE -- SUBPROGRAM DECLARATIVE REGION. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + GENERIC + PROCEDURE INNER (X : IN OUT INTEGER); + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := ONE.A; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- ONE + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- FORMAL PARAMETER OF GENERIC SUBPROGRAM. + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + GENERIC + PROCEDURE INNER (X : IN INTEGER := A; + A : IN OUT INTEGER); + + PROCEDURE INNER (X : IN INTEGER := TWO.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- TWO + NEW_INNER (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- AFTER THE SPECIFICATION OF GENERIC SUBPROGRAM. + GENERIC + A : INTEGER := IDENT_INT(3); + FUNCTION INNER (X : INTEGER) RETURN INTEGER; + + A : INTEGER := IDENT_INT(2); + + B : INTEGER := A; + + FUNCTION INNER (X : INTEGER) RETURN INTEGER IS + C : INTEGER := THREE.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF THREE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF THREE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER; + + FUNCTION NEW_INNER IS NEW INNER; + + BEGIN -- THREE + IF NEW_INNER(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + FOUR: + DECLARE + A : INTEGER := IDENT_INT(2); + + GENERIC + A : INTEGER; + B : INTEGER := A; + PROCEDURE INNER (X : IN OUT INTEGER); + + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := FOUR.A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30"); + END IF; + + IF B /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 31"); + END IF; + + IF FOUR.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 32"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 34"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := FOUR.A; + END IF; + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER (A => IDENT_INT(3)); + + BEGIN + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 35"); + END IF; + END FOUR; + + FIVE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + GENERIC + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER; F : IN FLOAT) IS + BEGIN + X := INTEGER(F); + END INNER; + + PROCEDURE NEW_INNER IS NEW INNER; + + BEGIN -- FIVE + FLO := 6.25; + + NEW_INNER (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 40"); + END IF; + END FIVE; + + RESULT; + END C83025A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83025c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83025c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83025c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83025c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,345 ---- + -- C83025C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A DECLARATIVE REGION OF A GENERIC + -- SUBPROGRAM HIDES AN OUTER DECLARATION OF A HOMOGRAPH. ALSO CHECK + -- THAT THE OUTER DECLARATION IS DIRECTLY VISIBLE IN BOTH + -- DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE INNER HOMOGRAPH + -- AND THE OUTER DECLARATION IS VISIBLE BY SELECTION AFTER THE INNER + -- HOMOGRAPH DECLARATION, IF THE GENERIC SUBPROGRAM BODY IS COMPILED + -- AS A SUBUNIT IN THE SAME COMPILATION. + + -- HISTORY: + -- BCB 09/01/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE(REPORT); + PACKAGE C83025C_PACK IS + Y : INTEGER := IDENT_INT(5); + Z : INTEGER := Y; + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + OBJ : INTEGER := IDENT_INT(3); + + FLO : FLOAT := 5.0; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR); + + EOBJ : ENUM := ONE; + + GENERIC + Y : FLOAT := 2.0; + PROCEDURE INNER (X : IN OUT INTEGER); + + GENERIC + Y : BOOLEAN := TRUE; + PROCEDURE INNER2 (X : IN INTEGER := A; + A : IN OUT INTEGER); + + GENERIC + Y : ENUM := ONE; + FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER; + + GENERIC + Y : ENUM; + FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER; + + GENERIC + Y : CHARACTER := 'A'; + PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y); + END C83025C_PACK; + + PACKAGE BODY C83025C_PACK IS + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + PROCEDURE INNER (X : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A; + A : IN OUT INTEGER) IS SEPARATE; + + FUNCTION INNER3 (X : INTEGER; + Z : ENUM := Y) RETURN INTEGER IS SEPARATE; + + FUNCTION INNER4 (X : INTEGER; + Z : ENUM := Y) RETURN INTEGER IS SEPARATE; + + PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y) IS SEPARATE; + END C83025C_PACK; + + SEPARATE (C83025C_PACK) + PROCEDURE INNER (X : IN OUT INTEGER) IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 5"); + END IF; + + IF Y /= 2.0 THEN + FAILED ("INCORRECT VALUE INNER HOMOGRAPH - 6"); + END IF; + + IF EQUAL(1,1) THEN + X := A; + ELSE + X := C83025C_PACK.A; + END IF; + END INNER; + + SEPARATE (C83025C_PACK) + PROCEDURE INNER2 (X : IN INTEGER := C83025C_PACK.A; + A : IN OUT INTEGER) IS + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF Y /= TRUE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 15"); + END IF; + + IF EQUAL(1,1) THEN + A := IDENT_INT(4); + ELSE + A := 1; + END IF; + END INNER2; + + SEPARATE (C83025C_PACK) + FUNCTION INNER3 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 20"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 21"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 22"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 24"); + END IF; + + IF Y /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 25"); + END IF; + + IF Z /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 26"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER3; + + SEPARATE (C83025C_PACK) + FUNCTION INNER4 (X : INTEGER; Z : ENUM := Y) RETURN INTEGER IS + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 30"); + END IF; + + IF C83025C_PACK.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 31"); + END IF; + + IF C83025C_PACK.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 32"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 33"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 34"); + END IF; + + IF Y /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 35"); + END IF; + + IF Z /= ONE THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 36"); + END IF; + + IF EQUAL(1,1) THEN + RETURN A; + ELSE + RETURN X; + END IF; + END INNER4; + + SEPARATE (C83025C_PACK) + PROCEDURE INNER5 (X : IN OUT INTEGER; F : IN FLOAT; + Z : CHARACTER := Y) IS + BEGIN + X := INTEGER(F); + + IF Y /= 'A' THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 40"); + END IF; + + IF Z /= 'A' THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 41"); + END IF; + END INNER5; + + WITH REPORT; USE REPORT; + WITH C83025C_PACK; USE C83025C_PACK; + PROCEDURE C83025C IS + + PROCEDURE NEW_INNER IS NEW INNER; + + PROCEDURE NEW_INNER2 IS NEW INNER2; + + FUNCTION NEW_INNER3 IS NEW INNER3; + + FUNCTION NEW_INNER4 IS NEW INNER4 (Y => EOBJ); + + PROCEDURE NEW_INNER5 IS NEW INNER5; + + BEGIN + TEST ("C83025C", "CHECK THAT A DECLARATION IN A DECLARATIVE " & + "REGION OF A GENERIC SUBPROGRAM HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + A := IDENT_INT(2); + B := A; + + NEW_INNER (A); + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 7"); + END IF; + + A := IDENT_INT(2); + + NEW_INNER2 (A => OBJ); + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 16"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF NEW_INNER3(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 27"); + END IF; + + A := IDENT_INT(2); + + B := A; + + IF NEW_INNER4(A) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 37"); + END IF; + + OBJ := 1; + + FLO := 6.25; + + NEW_INNER5 (OBJ, FLO); + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 42"); + END IF; + + IF Y /= 5 THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 50"); + END IF; + + IF Z /= 5 THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 51"); + END IF; + + RESULT; + END C83025C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83027a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83027a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83027a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83027a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- C83027A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A RECORD DECLARATION HIDES AN OUTER + -- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION + -- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE + -- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS + -- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 09/02/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83027A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83027A", "CHECK THAT A DECLARATION IN A RECORD " & + "DECLARATION HIDES AN OUTER DECLARATION OF " & + "A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + OBJ : INTEGER := IDENT_INT(3); + + TYPE INNER2 (A : INTEGER := IDENT_INT(3)) IS RECORD + C : INTEGER := ONE.A; + D : INTEGER := A; + END RECORD; + + E : INTEGER := A; + + RECVAR : INNER2; + + BEGIN -- ONE + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 1"); + END IF; + + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 2"); + END IF; + + IF E /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5"); + END IF; + + IF EQUAL(1,1) THEN + OBJ := RECVAR.A; + ELSE + OBJ := 1; + END IF; + + IF OBJ /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE + + GENERIC + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + PACKAGE P IS + TYPE INNER (C : INTEGER := A; + A : INTEGER := IDENT_INT(3)) IS RECORD + D : INTEGER := A; + END RECORD; + END P; + + PACKAGE BODY P IS + RECVAR : INNER; + BEGIN + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 10"); + END IF; + + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 14"); + END IF; + END P; + + PACKAGE PACK IS NEW P; + + BEGIN -- TWO + NULL; + END TWO; + + THREE: + DECLARE + A : INTEGER := IDENT_INT(2); + OBJ : INTEGER := IDENT_INT(3); + + TYPE INNER4 (C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + X : INTEGER := THREE.A) IS RECORD + D : INTEGER := A; + END RECORD; + + RECVAR : INNER4; + + BEGIN -- THREE + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 20"); + END IF; + + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 21"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 22"); + END IF; + + IF RECVAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 23"); + END IF; + + IF RECVAR.X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 24"); + END IF; + + IF EQUAL(1,1) THEN + OBJ := RECVAR.A; + ELSE + OBJ := 1; + END IF; + + IF OBJ /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 25"); + END IF; + END THREE; + + RESULT; + END C83027A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83027c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83027c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83027c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83027c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- C83027C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION WITHIN THE DISCRIMINANT PART OF A + -- PRIVATE TYPE DECLARATION, AN INCOMPLETE TYPE DECLARATION, AND A + -- GENERIC FORMAL TYPE DECLARATION HIDES AN OUTER DECLARATION OF A + -- HOMOGRAPH. ALSO, CHECK THAT THE OUTER DECLARATION IS DIRECTLY + -- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF THE + -- INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY SELECTION + -- AFTER THE INNER HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 09/06/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83027C IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83027C", "CHECK THAT A DECLARATION IN THE DISCRIMINANT " & + "PART OF A PRIVATE TYPE DECLARATION, AN " & + "INCOMPLETE TYPE DECLARATION, AND A GENERIC " & + "FORMAL TYPE DECLARATION HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + + D : INTEGER := IDENT_INT(2); + + G : INTEGER := IDENT_INT(2); + H : INTEGER := G; + + TYPE REC (Z : INTEGER) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE INNER3 (G : INTEGER) IS PRIVATE; + PACKAGE P_ONE IS + TYPE INNER (X : INTEGER := A; + A : INTEGER := IDENT_INT(3); + C : INTEGER := ONE.A) IS PRIVATE; + TYPE INNER2 (Y : INTEGER := D; + D : INTEGER := IDENT_INT(3); + F : INTEGER := ONE.D); + TYPE INNER2 (Y : INTEGER := D; + D : INTEGER := IDENT_INT(3); + F : INTEGER := ONE.D) IS RECORD + E : INTEGER := D; + END RECORD; + PRIVATE + TYPE INNER (X : INTEGER := A; + A : INTEGER := IDENT_INT(3); + C : INTEGER := ONE.A) IS RECORD + B : INTEGER := A; + END RECORD; + END P_ONE; + + PACKAGE BODY P_ONE IS + RECVAR : INNER; + RECVAR2 : INNER2; + RECVAR3 : INNER3(3); + BEGIN + IF RECVAR.A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF RECVAR.B /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 3"); + END IF; + + IF RECVAR.C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF RECVAR.X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 5"); + END IF; + + IF RECVAR2.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 6"); + END IF; + + IF D /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 7"); + END IF; + + IF RECVAR2.E /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 8"); + END IF; + + IF RECVAR2.F /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 9"); + END IF; + + IF RECVAR2.Y /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 10"); + END IF; + + IF RECVAR3.G /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 11"); + END IF; + + IF G /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 12"); + END IF; + + IF H /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 13"); + END IF; + END P_ONE; + + PACKAGE NEW_P_ONE IS NEW P_ONE (REC); + + BEGIN -- ONE + NULL; + END ONE; + + RESULT; + END C83027C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83028a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83028a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83028a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83028a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- C83028A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DECLARATION IN A BLOCK STATEMENT HIDES AN OUTER + -- DECLARATION OF A HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION + -- IS DIRECTLY VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE + -- DECLARATION OF THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS + -- VISIBLE BY SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 09/06/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83028A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83028A", "CHECK THAT A DECLARATION IN A BLOCK " & + "STATEMENT HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + + BEGIN -- ONE + DECLARE + C : INTEGER := A; + A : INTEGER := IDENT_INT(3); + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF EQUAL(1,1) THEN + ONE.A := A; + END IF; + END; + + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + OBJ : INTEGER := IDENT_INT(3); + + BEGIN -- TWO + DECLARE + X : INTEGER := A; + A : INTEGER := OBJ; + C : INTEGER := A; + BEGIN + IF A /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH -10"); + END IF; + + IF TWO.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 11"); + END IF; + + IF TWO.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 12"); + END IF; + + IF C /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 13"); + END IF; + + IF X /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE PASSED IN - 14"); + END IF; + + IF EQUAL(1,1) THEN + TWO.OBJ := IDENT_INT(4); + ELSE + TWO.OBJ := 1; + END IF; + END; + + IF OBJ /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 15"); + END IF; + END TWO; + + THREE: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + BEGIN + DECLARE + F : FLOAT := 6.25; + BEGIN + THREE.OBJ := INTEGER(F); + END; + + IF OBJ /= IDENT_INT(6) THEN + FAILED ("INCORRECT VALUE RETURNED FROM FUNCTION - 20"); + END IF; + END THREE; + + RESULT; + END C83028A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83029a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83029a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83029a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83029a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C83029A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A LOOP PARAMETER HIDES AN OUTER DECLARATION OF A + -- HOMOGRAPH. ALSO CHECK THAT THE OUTER DECLARATION IS DIRECTLY + -- VISIBLE IN BOTH DECLARATIVE REGIONS BEFORE THE DECLARATION OF + -- THE INNER HOMOGRAPH AND THE OUTER DECLARATION IS VISIBLE BY + -- SELECTION AFTER THE INNER HOMOGRAPH DECLARATION. + + -- HISTORY: + -- BCB 09/06/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83029A IS + + GENERIC + TYPE T IS PRIVATE; + X : T; + FUNCTION GEN_FUN RETURN T; + + FUNCTION GEN_FUN RETURN T IS + BEGIN + RETURN X; + END GEN_FUN; + + BEGIN + TEST ("C83029A", "CHECK THAT A LOOP PARAMETER HIDES AN OUTER " & + "DECLARATION OF A HOMOGRAPH"); + + ONE: + DECLARE + A : INTEGER := IDENT_INT(2); + B : INTEGER := A; + C : INTEGER; + + BEGIN -- ONE + + FOR A IN 1 .. 1 LOOP + C := A; + + IF A /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR INNER HOMOGRAPH - 1"); + END IF; + + IF ONE.A /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER HOMOGRAPH - 2"); + END IF; + + IF ONE.B /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR OUTER VARIABLE - 3"); + END IF; + + IF C /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE FOR INNER VARIABLE - 4"); + END IF; + + IF EQUAL(1,1) THEN + ONE.A := A; + END IF; + END LOOP; + + IF A /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE PASSED OUT - 6"); + END IF; + END ONE; + + TWO: + DECLARE -- OVERLOADING OF FUNCTIONS. + + OBJ : INTEGER := 1; + FLO : FLOAT := 5.0; + + FUNCTION F IS NEW GEN_FUN (INTEGER, OBJ); + + FUNCTION F IS NEW GEN_FUN (FLOAT, FLO); + + BEGIN + FOR F IN 1 .. 1 LOOP + OBJ := INTEGER(F); + END LOOP; + + IF OBJ /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE RETURNED - 10"); + END IF; + END TWO; + + RESULT; + END C83029A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83030a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83030a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83030a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83030a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- C83030A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY, NO SUBPROGRAM + -- DECLARED IN AN OUTER DECLARATIVE REGION IS HIDDEN (UNLESS THE + -- SUBPROGRAM IS A HOMOGRAPH OF THE GENERIC SUBPROGRAM). + + -- HISTORY: + -- TBN 08/03/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83030A IS + + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH1 : BOOLEAN := TRUE; + + PROCEDURE P IS + BEGIN + GLOBAL := IDENT_INT(1); + END P; + + PROCEDURE P (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END P; + + BEGIN + TEST ("C83030A", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY, " & + "NO SUBPROGRAM DECLARED IN AN OUTER " & + "DECLARATIVE REGION IS HIDDEN " & + "(UNLESS THE SUBPROGRAM IS A HOMOGRAPH OF THE " & + "GENERIC SUBPROGRAM)"); + + ONE: + DECLARE + GENERIC + PROCEDURE P; + + PROCEDURE P IS + A : INTEGER := IDENT_INT(2); + BEGIN + IF SWITCH1 THEN + SWITCH1 := FALSE; + P; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " & + "- 1"); + END IF; + END IF; + P(A); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2"); + END IF; + GLOBAL := IDENT_INT(3); + END P; + + PROCEDURE NEW_P IS NEW P; + + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST ONE"); + END IF; + NEW_P; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST ONE"); + END IF; + END ONE; + + + TWO: + DECLARE + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH : BOOLEAN := TRUE; + + GENERIC + TYPE T IS (<>); + PROCEDURE P (X : T); + + PROCEDURE P (X : T) IS + A : T := T'FIRST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + P (X); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL " & + "- 20"); + END IF; + GLOBAL := IDENT_INT(3); + ELSE + GLOBAL := IDENT_INT(2); + END IF; + END P; + + PROCEDURE NEW_P IS NEW P (INTEGER); + + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST TWO"); + END IF; + NEW_P (1); + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST TWO"); + END IF; + END TWO; + + + THREE: + DECLARE + SWITCH : BOOLEAN := TRUE; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END F; + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END F; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(X); + END F; + + BEGIN + DECLARE + GENERIC + FUNCTION F RETURN INTEGER; + + FUNCTION F RETURN INTEGER IS + A : INTEGER := INTEGER'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF F /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 30"); + END IF; + END IF; + IF F(A) /= IDENT_INT(INTEGER'LAST) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL " & + "- 31"); + END IF; + IF F THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL " & + "- 32"); + END IF; + RETURN IDENT_INT(3); + END F; + + FUNCTION NEW_F IS NEW F; + + BEGIN + IF NEW_F /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST THREE"); + END IF; + END; + END THREE; + + + FOUR: + DECLARE + SWITCH : BOOLEAN := TRUE; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END F; + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END F; + + BEGIN + DECLARE + GENERIC + TYPE T IS (<>); + FUNCTION F RETURN T; + + FUNCTION F RETURN T IS + A : T := T'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF F /= T'LAST THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 40"); + END IF; + RETURN T'FIRST; + ELSE + IF F THEN + FAILED ("INCORRECT VALUE FROM FUNCTION " & + "CALL - 41"); + END IF; + RETURN T'LAST; + END IF; + END F; + + FUNCTION NEW_F IS NEW F (INTEGER); + + BEGIN + IF NEW_F /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST FOUR"); + END IF; + END; + END FOUR; + + RESULT; + END C83030A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83030c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83030c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83030c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83030c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,263 ---- + -- C83030C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY COMPILED AS A SUBUNIT + -- IN THE SAME COMPILATION, NON-HOMOGRAPH SUBPROGRAMS DECLARED + -- OUTSIDE THE GENERIC UNIT, AND HAVING THE SAME IDENTIFIER, ARE NOT + -- HIDDEN. + + -- HISTORY: + -- JET 10/17/88 CREATED ORIGINAL TEST. + -- BCB 10/03/90 ADDED "PRAGMA ELABORATE (REPORT);". + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE C83030C_DECL1 IS + GLOBAL : INTEGER := IDENT_INT(INTEGER'FIRST); + SWITCH : BOOLEAN := TRUE; + + PROCEDURE C83030C_PROC1; + PROCEDURE C83030C_PROC1 (X : INTEGER); + PROCEDURE C83030C_PROC2; + PROCEDURE C83030C_PROC2 (X : INTEGER); + FUNCTION C83030C_FUNC3 RETURN INTEGER; + FUNCTION C83030C_FUNC3 RETURN BOOLEAN; + FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER; + FUNCTION C83030C_FUNC4 RETURN INTEGER; + FUNCTION C83030C_FUNC4 RETURN BOOLEAN; + END C83030C_DECL1; + + WITH REPORT; USE REPORT; + WITH C83030C_DECL1; USE C83030C_DECL1; + PACKAGE C83030C_DECL2 IS + GENERIC + PROCEDURE C83030C_PROC1; + + GENERIC + TYPE T IS (<>); + PROCEDURE C83030C_PROC2 (X : T); + + GENERIC + FUNCTION C83030C_FUNC3 RETURN INTEGER; + + GENERIC + TYPE T IS (<>); + FUNCTION C83030C_FUNC4 RETURN T; + END C83030C_DECL2; + + WITH REPORT; USE REPORT; + PACKAGE BODY C83030C_DECL1 IS + PROCEDURE C83030C_PROC1 IS + BEGIN + GLOBAL := IDENT_INT(1); + END C83030C_PROC1; + + PROCEDURE C83030C_PROC1 (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END C83030C_PROC1; + + PROCEDURE C83030C_PROC2 IS + BEGIN + GLOBAL := IDENT_INT(1); + END C83030C_PROC2; + + PROCEDURE C83030C_PROC2 (X : INTEGER) IS + BEGIN + GLOBAL := IDENT_INT(X); + END C83030C_PROC2; + + FUNCTION C83030C_FUNC3 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC3 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC3 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(X); + END C83030C_FUNC3; + + FUNCTION C83030C_FUNC4 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END C83030C_FUNC4; + + FUNCTION C83030C_FUNC4 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL(FALSE); + END C83030C_FUNC4; + END C83030C_DECL1; + + WITH REPORT; USE REPORT; + WITH C83030C_DECL1; USE C83030C_DECL1; + PACKAGE BODY C83030C_DECL2 IS + PROCEDURE C83030C_PROC1 IS SEPARATE; + PROCEDURE C83030C_PROC2 (X : T) IS SEPARATE; + FUNCTION C83030C_FUNC3 RETURN INTEGER IS SEPARATE; + FUNCTION C83030C_FUNC4 RETURN T IS SEPARATE; + END C83030C_DECL2; + + SEPARATE (C83030C_DECL2) + PROCEDURE C83030C_PROC1 IS + A : INTEGER := IDENT_INT(2); + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + C83030C_PROC1; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 1"); + END IF; + END IF; + C83030C_PROC1(A); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 2"); + END IF; + GLOBAL := IDENT_INT(3); + END C83030C_PROC1; + + SEPARATE (C83030C_DECL2) + PROCEDURE C83030C_PROC2 (X : T) IS + A : T := T'FIRST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + C83030C_PROC2 (X); + IF GLOBAL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE FOR PROCEDURE CALL - 20"); + END IF; + GLOBAL := IDENT_INT(3); + ELSE + GLOBAL := IDENT_INT(2); + END IF; + END C83030C_PROC2; + + SEPARATE (C83030C_DECL2) + FUNCTION C83030C_FUNC3 RETURN INTEGER IS + A : INTEGER := INTEGER'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF C83030C_FUNC3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 30"); + END IF; + END IF; + IF C83030C_FUNC3(A) /= IDENT_INT(INTEGER'LAST) THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 31"); + END IF; + IF C83030C_FUNC3 THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 32"); + END IF; + RETURN IDENT_INT(3); + END C83030C_FUNC3; + + SEPARATE (C83030C_DECL2) + FUNCTION C83030C_FUNC4 RETURN T IS + A : T := T'LAST; + BEGIN + IF SWITCH THEN + SWITCH := FALSE; + IF C83030C_FUNC4 /= T'LAST THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 40"); + END IF; + RETURN T'FIRST; + ELSE + IF C83030C_FUNC4 THEN + FAILED ("INCORRECT VALUE FROM FUNCTION CALL - 41"); + END IF; + RETURN T'LAST; + END IF; + END C83030C_FUNC4; + + WITH REPORT; USE REPORT; + WITH C83030C_DECL1, C83030C_DECL2; USE C83030C_DECL1, C83030C_DECL2; + PROCEDURE C83030C IS + BEGIN + TEST ("C83030C", "CHECK THAT WITHIN A GENERIC SUBPROGRAM BODY " & + "COMPILED AS A SUBUNIT IN THE SAME COMPILATION," & + " NON-HOMOGRAPH SUBPROGRAMS DECLARED OUTSIDE " & + "THE GENERIC UNIT, AND HAVING THE SAME " & + "IDENTIFIER, ARE NOT HIDDEN"); + + ONE: + DECLARE + PROCEDURE PROC1 IS NEW C83030C_DECL2.C83030C_PROC1; + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST ONE"); + END IF; + PROC1; + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST ONE"); + END IF; + + GLOBAL := IDENT_INT(INTEGER'FIRST); + SWITCH := TRUE; + END ONE; + + TWO: + DECLARE + PROCEDURE PROC2 IS NEW C83030C_DECL2.C83030C_PROC2(INTEGER); + BEGIN + IF GLOBAL /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR START OF TEST TWO"); + END IF; + PROC2 (1); + IF GLOBAL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST TWO"); + END IF; + + SWITCH := TRUE; + END TWO; + + THREE: + DECLARE + FUNCTION FUNC3 IS NEW C83030C_DECL2.C83030C_FUNC3; + BEGIN + IF FUNC3 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST THREE"); + END IF; + + SWITCH := TRUE; + END THREE; + + FOUR: + DECLARE + FUNCTION FUNC4 IS NEW C83030C_DECL2.C83030C_FUNC4 (INTEGER); + BEGIN + IF FUNC4 /= IDENT_INT(INTEGER'FIRST) THEN + FAILED ("INCORRECT VALUE FOR END OF TEST FOUR"); + END IF; + + GLOBAL := INTEGER'FIRST; + SWITCH := TRUE; + END FOUR; + + RESULT; + END C83030C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C83031A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR + -- AN ENUMERATION LITERAL IS HIDDEN BY A SUBPROGRAM DECLARATION OR + -- A RENAMING DECLARATION WHICH DECLARES A HOMOGRAPH OF THE + -- OPERATOR OR LITERAL. + + -- HISTORY: + -- VCL 08/10/88 CREATED ORIGINAL TEST. + -- JRL 03/20/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE C83031A IS + BEGIN + TEST ("C83031A", "AN IMPLICIT DECLARATION OF A PREDEFINED " & + "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " & + "BY A SUBPROGRAM DECLARATION OR A RENAMING " & + "DECLARATION WHICH DECLARES A HOMOGRAPH OF THE " & + "OPERATOR OR LITERAL"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + + M : INT := 3 * INT(IDENT_INT(3)); + N : INT := 4 + INT(IDENT_INT(4)); + + FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT; + TYPE INT2 IS PRIVATE; + FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2; + PRIVATE + FUNCTION "+" (LEFT, RIGHT : INT) RETURN INT + RENAMES "/" ; + + TYPE INT2 IS RANGE -20 .. 20; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT IS + BEGIN + RETURN LEFT / RIGHT; + END "*"; + + FUNCTION "+" (LEFT, RIGHT : INT2) RETURN INT2 IS + BEGIN + RETURN LEFT - RIGHT; + END "+"; + + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + + IF N /= 8 THEN + FAILED ("INCORRECT INITIAL VALUE FOR N - 1"); + END IF; + N := 2 + 2; + IF N /= INT(IDENT_INT (1)) THEN + FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " & + "EXPLICIT '+' OPERATOR - 1"); + END IF; + + DECLARE + Q : INT2 := 8 + 9; + BEGIN + IF Q /= -1 THEN + FAILED ("INCORRECT VALUE FOR Q"); + END IF; + END; + END P; + BEGIN + IF M /= 9 THEN + FAILED ("INCORRECT INITIAL VALUE FOR M - 2"); + END IF; + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 2"); + END IF; + + N := 2 + 2; + IF N /= INT(IDENT_INT (4)) THEN + FAILED ("INCORRECT VALUE FOR N AFTER CALL TO " & + "IMPLICIT '+' OPERATOR - 2"); + END IF; + + END; + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + FUNCTION E11 RETURN PRIV1; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + FUNCTION E12 RETURN PRIV1 RENAMES E13; + END P1; + USE P1; + + E13 : INTEGER := IDENT_INT (5); + + FUNCTION E12 RETURN ENUM1 RENAMES E11 ; + + FUNCTION CHECK (E: ENUM1) RETURN INTEGER IS + BEGIN + RETURN ENUM1'POS (E); + END CHECK; + + FUNCTION CHECK (E: INTEGER) RETURN INTEGER IS + BEGIN + RETURN INTEGER'POS (E); + END CHECK; + + PACKAGE BODY P1 IS + FUNCTION E11 RETURN PRIV1 IS + BEGIN + RETURN E13; + END E11; + BEGIN + IF PRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + + IF E12 /= PRIV1'LAST THEN + FAILED ("INCORRECT VALUE FOR E12 - 1"); + END IF; + END P1; + BEGIN + IF E12 /= ENUM1'FIRST THEN + FAILED ("INCORRECT VALUE FOR E12 - 2"); + END IF; + + IF CHECK (E13) /= 5 THEN + FAILED ("INCORRECT VALUE FOR E13"); + END IF; + END; + RESULT; + END C83031A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C83031C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR + -- ENUMERATION LITERAL IS HIDDEN BY A GENERIC INSTANTIATION WHICH + -- DECLARES A HOMOGRAPH OF THE OPERATOR OR LITERAL. + + -- HISTORY: + -- BCB 09/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83031C IS + + BEGIN + TEST ("C83031C", "CHECK THAT AN IMPLICIT DECLARATION OF A " & + "PREDEFINED OPERATOR OR ENUMERATION LITERAL IS " & + "HIDDEN BY A GENERIC INSTANTIATION WHICH " & + "DECLARES A HOMOGRAPH OF THE OPERATOR OR " & + "LITERAL"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + + GENERIC + TYPE X IS RANGE <>; + FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X; + END P; + USE P; + + PACKAGE BODY P IS + FUNCTION GEN_FUN (LEFT, RIGHT : X) RETURN X IS + BEGIN + RETURN LEFT / RIGHT; + END GEN_FUN; + + FUNCTION "*" IS NEW GEN_FUN (INT); + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + END P; + BEGIN + NULL; + END; + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + + GENERIC + TYPE X IS (<>); + FUNCTION GEN_FUN RETURN X; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + END P1; + USE P1; + + PACKAGE BODY P1 IS + FUNCTION GEN_FUN RETURN X IS + BEGIN + RETURN X'LAST; + END GEN_FUN; + + FUNCTION E11 IS NEW GEN_FUN (PRIV1); + BEGIN + IF PRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + END P1; + BEGIN + NULL; + END; + + RESULT; + END C83031C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83031e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83031e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C83031E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR IS + -- HIDDEN BY A GENERIC FORMAL SUBPROGRAM DECLARATION WHICH DECLARES + -- A HOMOGRAPH OF THE OPERATOR. + + -- HISTORY: + -- BCB 09/19/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C83031E IS + + BEGIN + TEST ("C83031E", "CHECK THAT AN IMPLICIT DECLARATION OF A " & + "PREDEFINED OPERATOR IS HIDDEN BY A GENERIC " & + "FORMAL SUBPROGRAM DECLARATION WHICH DECLARES " & + "A HOMOGRAPH OF THE OPERATOR"); + + DECLARE -- CHECK SUBPROGRAM DECLARATIONS OF OPERATORS + TYPE INT IS RANGE -20 .. 20; + + GENERIC + WITH FUNCTION "*" (LEFT, RIGHT : INT) RETURN INT; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + BEGIN + IF 2 * INT(IDENT_INT(2)) /= 1 THEN + FAILED ("INCORRECT VALUE RETURNED IN CALL TO " & + "EXPLICIT '*' OPERATOR - 1"); + END IF; + END P; + + FUNCTION MULT (X, Y : INT) RETURN INT IS + BEGIN + RETURN X / Y; + END MULT; + + PACKAGE NEW_P IS NEW P (MULT); + BEGIN + NULL; + END; + + RESULT; + END C83031E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83032a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83032a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83032a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83032a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C83032A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLICIT DECLARATION OF A PREDEFINED OPERATOR OR + -- AN ENUMERATION LITERAL IS HIDDEN BY A DERIVED SUBPROGRAM + -- HOMOGRAPH. + + -- HISTORY: + -- VCL 08/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C83032A IS + BEGIN + TEST ("C83032A", "AN IMPLICIT DECLARATION OF A PREDEFINED " & + "OPERATOR OR AN ENUMERATION LITERAL IS HIDDEN " & + "BY A DERIVED SUBPROGRAM HOMOGRAPH"); + + DECLARE -- CHECK PREDEFINED OPERATOR. + PACKAGE P IS + TYPE INT IS RANGE -20 .. 20; + FUNCTION "ABS" (X : INT) RETURN INT; + END P; + USE P; + + TYPE NINT IS NEW INT; + + I2 : NINT := -5; + + PACKAGE BODY P IS + I1 : NINT := 5; + + FUNCTION "ABS" (X : INT) RETURN INT IS + BEGIN + RETURN INT (- (ABS (INTEGER (X)))); + END "ABS"; + + BEGIN + IF "ABS"(I1) /= -5 THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 1"); + END IF; + + I1 := ABS (-10); + IF ABS I1 /= NINT(IDENT_INT (-10)) THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 2"); + END IF; + END P; + BEGIN + IF "ABS"(I2) /= -5 THEN + FAILED ("INCORRECT VALUE FOR 'I2' AFTER CALL " & + "TO DERIVED ""ABS"" - 1"); + END IF; + + I2 := ABS (10); + IF ABS I2 /= NINT (IDENT_INT (-10)) THEN + FAILED ("INCORRECT VALUE FOR 'I1' AFTER CALL " & + "TO DERIVED ""ABS"" - 2"); + END IF; + END; + + DECLARE -- CHECK ENUMERATION LITERALS. + + PACKAGE P1 IS + TYPE ENUM1 IS (E11, E12, E13); + TYPE PRIV1 IS PRIVATE; + FUNCTION E11 RETURN PRIV1; + PRIVATE + TYPE PRIV1 IS NEW ENUM1; + TYPE NPRIV1 IS NEW PRIV1; + END P1; + USE P1; + + PACKAGE BODY P1 IS + FUNCTION E11 RETURN PRIV1 IS + BEGIN + RETURN E13; + END E11; + BEGIN + IF NPRIV1'(E11) /= E13 THEN + FAILED ("INCORRECT VALUE FOR E11"); + END IF; + END P1; + + BEGIN + NULL; + END; + RESULT; + END C83032A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83033a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83033a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83033a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83033a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- C83033A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLICIT DECLARATION OF A BLOCK NAME, A LOOP NAME, + -- OR A STATEMENT LABEL HIDES THE DECLARATION OF AN ENUMERATION + -- LITERAL OR OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED TYPE + -- DEFINITION. + + -- HISTORY: + -- DHH 09/21/88 CREATED ORIGINAL TEST. + -- WMC 03/25/92 REMOVED TEST REDUNDANCIES. + + + WITH REPORT; USE REPORT; + PROCEDURE C83033A IS + + PACKAGE BASE_P IS + TYPE A IS (RED, BLUE, YELO); + FUNCTION RED(T : INTEGER; X : A) RETURN A; + FUNCTION BLUE(T : INTEGER; X : A) RETURN A; + END BASE_P; + + PACKAGE BODY BASE_P IS + FUNCTION RED(T : INTEGER; X : A) RETURN A IS + BEGIN + IF EQUAL(T, T) THEN + RETURN X; + ELSE + RETURN YELO; + END IF; + END RED; + + FUNCTION BLUE(T : INTEGER; X : A) RETURN A IS + BEGIN + IF EQUAL(T, T) THEN + RETURN X; + ELSE + RETURN YELO; + END IF; + END BLUE; + + END BASE_P; + BEGIN + TEST ("C83033A", "CHECK THAT AN IMPLICIT DECLARATION OF A BLOCK " & + "NAME, A LOOP NAME, OR A STATEMENT LABEL HIDES " & + "THE DECLARATION OF AN ENUMERATION LITERAL OR " & + "OF A DERIVED SUBPROGRAM DECLARED BY A DERIVED " & + "TYPE DEFINITION"); + + B1: + DECLARE + TYPE STMT2 IS NEW BASE_P.A; + BEGIN + + DECLARE + C, D : STMT2; + BEGIN + C := C83033A.B1.RED(3, C83033A.B1.RED); + D := C83033A.B1.RED; + + GOTO RED; -- DEMONSTRATES USE OF STATEMENT LABEL. + FAILED("STATEMENT LABEL - 1"); + + <> IF C /= D THEN + FAILED("STATEMENT LABEL - 2"); + END IF; + END; + END B1; + + B2: + DECLARE + TYPE STMT2 IS NEW BASE_P.A; + BEGIN + + DECLARE + A : STMT2 := BLUE; + B : STMT2 := BLUE(3, BLUE); + BEGIN + + BLUE: + FOR I IN 1 .. 1 LOOP + IF A /= B THEN + FAILED("LOOP NAME - 1"); + END IF; + EXIT BLUE; -- DEMONSTRATES USE OF LOOP LABEL. + FAILED("LOOP NAME - 2"); + END LOOP BLUE; + END; + END B2; + + B4: + DECLARE + PACKAGE P IS + GLOBAL : INTEGER := 1; + TYPE ENUM IS (GREEN, BLUE); + TYPE PRIV IS PRIVATE; + FUNCTION GREEN RETURN PRIV; + PRIVATE + TYPE PRIV IS NEW ENUM; + END P; + + PACKAGE BODY P IS + FUNCTION GREEN RETURN PRIV IS + BEGIN + GLOBAL := GLOBAL + 1; + RETURN BLUE; + END GREEN; + BEGIN + NULL; + END P; + USE P; + BEGIN + GREEN: + DECLARE + COLOR : PRIV := C83033A.B4.P.GREEN; + BEGIN + IF GREEN.COLOR /= C83033A.B4.P.GREEN OR ELSE GLOBAL /= 3 THEN + FAILED("BLOCK NAME"); + END IF; + END GREEN; + END B4; + + RESULT; + END C83033A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83051a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83051a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83051a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83051a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,397 ---- + -- C83051A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DECLARATIONS IN THE VISIBLE PART OF A PACKAGE NESTED + -- WITHIN THE VISIBLE PART OF A PACKAGE ARE VISIBLE BY SELECTION + -- FROM OUTSIDE THE OUTERMOST PACKAGE. + + -- HISTORY: + -- GMT 09/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE C83051A IS + + BEGIN + TEST ("C83051A", "CHECK THAT DECLARATIONS IN THE VISIBLE " & + "PART OF A PACKAGE NESTED WITHIN THE VISIBLE " & + "PART OF A PACKAGE ARE VISIBLE BY SELECTION " & + "FROM OUTSIDE THE OUTERMOST PACKAGE"); + A_BLOCK: + DECLARE + PACKAGE APACK IS + PACKAGE BPACK IS + TYPE T1 IS (RED,GREEN); + TYPE T2A IS ('A', 'B', 'C', 'D'); + TYPE T3 IS NEW BOOLEAN; + TYPE T4 IS NEW INTEGER RANGE -3 .. 8; + TYPE T5 IS DIGITS 5; + TYPE T67 IS DELTA 0.5 RANGE -2.0 .. 10.0; + TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3; + SUBTYPE T9B IS T9A (1..10); + TYPE T9C IS ACCESS T9B; + TYPE T10 IS PRIVATE; + V1 : T3 := FALSE; + ZERO : CONSTANT T4 := 0; + A_FLT : T5 := 3.0; + A_FIX : T67 := -1.0; + ARY : T9A(1..4) := (TRUE,TRUE,TRUE,FALSE); + P1 : T9C := NEW T9B'( 1..5 => T3'(TRUE), + 6..10 => T3'(FALSE) ); + C1 : CONSTANT T10; + + FUNCTION RET_T1 (X : T1) RETURN T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10; + + GENERIC + PROCEDURE DO_NOTHING (X : IN OUT T3); + PRIVATE + TYPE T10 IS NEW CHARACTER; + C1 : CONSTANT T10 := 'J'; + END BPACK; + END APACK; + + PACKAGE BODY APACK IS + PACKAGE BODY BPACK IS + FUNCTION RET_T1 (X : T1) RETURN T1 IS + BEGIN + IF X = RED THEN + RETURN GREEN; + ELSE + RETURN RED; + END IF; + END RET_T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS + BEGIN + RETURN T10(X); + END RET_CHAR; + + PROCEDURE DO_NOTHING (X : IN OUT T3) IS + BEGIN + IF X = TRUE THEN + X := FALSE; + ELSE + X := TRUE; + END IF; + END DO_NOTHING; + END BPACK; + END APACK; + + PROCEDURE NEW_DO_NOTHING IS NEW APACK.BPACK.DO_NOTHING; + + BEGIN + + -- A1: VISIBILITY FOR UNOVERLOADED ENUMERATION LITERALS + + IF APACK.BPACK.">"(APACK.BPACK.RED, APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR UNOVERLOADED ENUMERATION " & + "LITERAL BAD - A1"); + END IF; + + + -- A2: VISIBILITY FOR OVERLOADED + -- ENUMERATION CHARACTER LITERALS + + IF APACK.BPACK."<"(APACK.BPACK.T2A'(APACK.BPACK.'C'), + APACK.BPACK.T2A'(APACK.BPACK.'B')) THEN + FAILED ("VISIBILITY FOR OVERLOADED ENUMERATION " & + "LITERAL BAD - A2"); + END IF; + + + -- A3: VISIBILITY FOR A DERIVED BOOLEAN TYPE + + IF APACK.BPACK."<"(APACK.BPACK.T3'(APACK.BPACK.TRUE), + APACK.BPACK.FALSE) THEN + FAILED ("VISIBILITY FOR DERIVED BOOLEAN BAD - A3"); + END IF; + + + -- A4: VISIBILITY FOR AN INTEGER TYPE + + IF APACK.BPACK."/="(APACK.BPACK."MOD"(6,2),APACK.BPACK.ZERO) + THEN FAILED ("VISIBILITY FOR INTEGER TYPE BAD - A4"); + END IF; + + + -- A5: VISIBILITY FOR A FLOATING POINT TYPE + + IF APACK.BPACK.">"(APACK.BPACK.T5'(2.7),APACK.BPACK.A_FLT) + THEN FAILED ("VISIBILITY FOR FLOATING POINT BAD - A5"); + END IF; + + + -- A6: VISIBILITY FOR A FIXED POINT INVOLVING UNARY MINUS + + IF APACK.BPACK."<"(APACK.BPACK.A_FIX,APACK.BPACK.T67' + (APACK.BPACK."-"(1.5))) THEN + FAILED ("VISIBILITY FOR FIXED POINT WITH UNARY MINUS " & + "BAD - A6"); + END IF; + + + -- A7: VISIBILITY FOR A FIXED POINT DIVIDED BY INTEGER + + IF APACK.BPACK."/="(APACK.BPACK.T67(-0.5),APACK.BPACK."/" + (APACK.BPACK.A_FIX,2)) THEN + FAILED ("VISIBILITY FOR FIXED POINT DIVIDED BY " & + "INTEGER BAD - A7"); + END IF; + + + -- A8: VISIBILITY FOR ARRAY EQUALITY + + IF APACK.BPACK."/="(APACK.BPACK.ARY,(APACK.BPACK.T3(TRUE), + APACK.BPACK.T3(TRUE),APACK.BPACK.T3(TRUE), + APACK.BPACK.T3(FALSE))) THEN + FAILED ("VISIBILITY FOR ARRAY EQUALITY BAD - A8"); + END IF; + + + -- A9: VISIBILITY FOR ACCESS EQUALITY + + IF APACK.BPACK."/="(APACK.BPACK.P1(3), + APACK.BPACK.T3(IDENT_BOOL(TRUE))) + THEN FAILED ("VISIBILITY FOR ACCESS EQUALITY BAD - A9"); + END IF; + + + -- A10: VISIBILITY FOR PRIVATE TYPE + + IF APACK.BPACK."/="(APACK.BPACK.C1, + APACK.BPACK.RET_CHAR('J')) THEN + FAILED ("VISIBILITY FOR PRIVATE TYPE BAD - A10"); + END IF; + + + -- A11: VISIBILITY FOR DERIVED SUBPROGRAM + + IF APACK.BPACK."/="(APACK.BPACK.RET_T1(APACK.BPACK.RED), + APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR DERIVED SUBPROGRAM BAD - A11"); + END IF; + + -- A12: VISIBILITY FOR GENERIC SUBPROGRAM + + NEW_DO_NOTHING (APACK.BPACK.V1); + + IF APACK.BPACK."/="(APACK.BPACK.V1,APACK.BPACK.T3(TRUE)) THEN + FAILED ("VISIBILITY FOR GENERIC SUBPROGRAM BAD - A12"); + END IF; + + END A_BLOCK; + + B_BLOCK: + DECLARE + GENERIC + TYPE T1 IS (<>); + PACKAGE GENPACK IS + PACKAGE APACK IS + PACKAGE BPACK IS + TYPE T1 IS (ORANGE,GREEN); + TYPE T2A IS ('E', 'F', 'G'); + TYPE T3 IS NEW BOOLEAN; + TYPE T4 IS NEW INTEGER RANGE -3 .. 8; + TYPE T5 IS DIGITS 5; + TYPE T67 IS DELTA 0.5 RANGE -3.0 .. 25.0; + TYPE T9A IS ARRAY (INTEGER RANGE <>) OF T3; + SUBTYPE T9B IS T9A (2 .. 8); + TYPE T9C IS ACCESS T9B; + TYPE T10 IS PRIVATE; + V1 : T3 := TRUE; + SIX : T4 := 6; + B_FLT : T5 := 4.0; + ARY : T9A(1..4) := (TRUE,FALSE,TRUE,FALSE); + P1 : T9C := NEW T9B'( 2..4 => T3'(FALSE), + 5..8 => T3'(TRUE)); + K1 : CONSTANT T10; + + FUNCTION RET_T1 (X : T1) RETURN T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10; + + GENERIC + PROCEDURE DO_NOTHING (X : IN OUT T3); + PRIVATE + TYPE T10 IS NEW CHARACTER; + K1 : CONSTANT T10 := 'V'; + END BPACK; + END APACK; + END GENPACK; + + PACKAGE BODY GENPACK IS + PACKAGE BODY APACK IS + PACKAGE BODY BPACK IS + FUNCTION RET_T1 (X : T1) RETURN T1 IS + BEGIN + IF X = ORANGE THEN + RETURN GREEN; + ELSE + RETURN ORANGE; + END IF; + END RET_T1; + + FUNCTION RET_CHAR (X : CHARACTER) RETURN T10 IS + BEGIN + RETURN T10(X); + END RET_CHAR; + + PROCEDURE DO_NOTHING (X : IN OUT T3) IS + BEGIN + IF X = TRUE THEN + X := FALSE; + ELSE + X := TRUE; + END IF; + END DO_NOTHING; + END BPACK; + END APACK; + END GENPACK; + + PACKAGE MYPACK IS NEW GENPACK (T1 => INTEGER); + + PROCEDURE MY_DO_NOTHING IS NEW MYPACK.APACK.BPACK.DO_NOTHING; + + BEGIN + + -- B1: GENERIC INSTANCE OF UNOVERLOADED ENUMERATION LITERAL + + IF MYPACK.APACK.BPACK."<"(MYPACK.APACK.BPACK.GREEN, + MYPACK.APACK.BPACK.ORANGE) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " & + "UNOVERLOADED ENUMERATION LITERAL BAD - B1"); + END IF; + + + -- B2: GENERIC INSTANCE OF OVERLOADED ENUMERATION LITERAL + + IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T2A'(MYPACK. + APACK.BPACK.'F'),MYPACK.APACK.BPACK.T2A'(MYPACK.APACK. + BPACK.'G')) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF " & + "OVERLOADED ENUMERATION LITERAL BAD - B2"); + END IF; + + + -- B3: VISIBILITY FOR GENERIC INSTANCE OF DERIVED BOOLEAN + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."NOT"(MYPACK. + APACK.BPACK.T3'(MYPACK.APACK.BPACK.TRUE)),MYPACK.APACK. + BPACK.FALSE) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " & + "BOOLEAN BAD - B3"); + END IF; + + + -- B4: VISIBILITY FOR GENERIC INSTANCE OF DERIVED INTEGER + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."MOD"(MYPACK. + APACK.BPACK.SIX,2),0) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF INTEGER " & + "BAD - B4"); + END IF; + + + -- B5: VISIBILITY FOR GENERIC INSTANCE OF FLOATING POINT + + IF MYPACK.APACK.BPACK.">"(MYPACK.APACK.BPACK.T5'(1.9),MYPACK. + APACK.BPACK.B_FLT) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FLOATING " & + "POINT BAD - B5"); + END IF; + + + -- B6: VISIBILITY FOR GENERIC INSTANCE OF + -- FIXED POINT UNARY PLUS + + IF MYPACK.APACK.BPACK."<"(2.5,MYPACK.APACK.BPACK.T67'(MYPACK. + APACK.BPACK."+"(1.75))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " & + "POINT UNARY PLUS BAD - B6"); + END IF; + + + -- B7: VISIBILITY FOR GENERIC INSTANCE OF + -- FIXED POINT DIVIDED BY INTEGER + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK."/"(2.5,4), + 0.625) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF FIXED " & + "POINT DIVIDED BY INTEGER BAD - B7"); + END IF; + + + -- B8: VISIBILITY FOR GENERIC INSTANCE OF ARRAY EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.ARY,(MYPACK. + APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE),MYPACK. + APACK.BPACK.T3(TRUE),MYPACK.APACK.BPACK.T3(FALSE))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ARRAY " & + "EQUALITY BAD - B8"); + END IF; + + + -- B9: VISIBILITY FOR GENERIC INSTANCE OF ACCESS EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.P1(3),MYPACK. + APACK.BPACK.T3(IDENT_BOOL(FALSE))) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF ACCESS " & + "EQUALITY BAD - B9"); + END IF; + + + -- B10: VISIBILITY FOR GENERIC INSTANCE OF PRIVATE EQUALITY + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.K1,MYPACK.APACK. + BPACK.RET_CHAR('V')) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF PRIVATE " & + "EQUALITY BAD - B10"); + END IF; + + + -- B11: VISIBILITY FOR GENERIC INSTANCE OF DERIVED SUBPROGRAM + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.RET_T1(MYPACK. + APACK.BPACK.ORANGE),MYPACK.APACK.BPACK.GREEN) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF DERIVED " & + "SUBPROGRAM BAD - B11"); + END IF; + + -- B12: VISIBILITY FOR GENERIC INSTANCE OF GENERIC SUBPROGRAM + + MY_DO_NOTHING (MYPACK.APACK.BPACK.V1); + + IF MYPACK.APACK.BPACK."/="(MYPACK.APACK.BPACK.V1, + MYPACK.APACK.BPACK.T3(FALSE)) THEN + FAILED ("VISIBILITY FOR GENERIC INSTANCE OF GENERIC " & + "SUBPROGRAM BAD - B12"); + END IF; + + END B_BLOCK; + + RESULT; + END C83051A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83b02a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C83B02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NESTED LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS, + -- AND REFERENCES IN THE INNERMOST LOOP ARE ASSOCIATED WITH THE + -- INNERMOST PARAMETER, ETC. + + + -- RM 4 JUNE 1980 + + + WITH REPORT; + PROCEDURE C83B02A IS + + USE REPORT; + + I , J , K : INTEGER := 1 ; + + BEGIN + + TEST ( "C83B02A" , + "CHECK THAT NESTED LOOPS CAN HAVE IDENTICALLY NAMED" & + " PARAMETERS" ); + + -- I J K + FOR LOOP_PAR IN 2..2 LOOP + I := I * LOOP_PAR ; -- 2 1 1 + FOR LOOP_PAR IN 3..3 LOOP + I := I * LOOP_PAR ; -- 6 1 1 + FOR LOOP_PAR IN 5..5 LOOP + I := I * LOOP_PAR ; -- 30 1 1 + FOR SECOND_LOOP_PAR IN 7..7 LOOP + J := J * SECOND_LOOP_PAR ; -- 30 7 1 + FOR SECOND_LOOP_PAR IN 11..11 LOOP + J := J * SECOND_LOOP_PAR ;-- 30 77 1 + FOR SECOND_LOOP_PAR IN 13..13 LOOP + J := J * + SECOND_LOOP_PAR;-- 30 1001 1 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 5 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 25 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 125 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 375 + END LOOP; + K := K * LOOP_PAR ; -- 30 1001 750 + END LOOP; + + IF I /= 30 OR J /= 1001 OR K /= 750 THEN + FAILED ( "DID NOT ACCESS INNERMOST ENCLOSING IDENTICALLY " & + "NAMED LOOP PARAMETER IN NESTED LOOPS" ); + END IF; + + RESULT; + + END C83B02A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83b02b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C83B02B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED PARAMETERS, + -- AND REFERENCES IN EACH LOOP ARE ASSOCIATED WITH THAT LOOP'S + -- LOOP PARAMETER. (THIS IS PART B OF THE OBJECTIVE.) + -- CHECK ALSO THAT A LOOP PARAMETER CAN HAVE THE SAME IDENTIFIER + -- AS A VARIABLE DECLARED IN THE SCOPE IMMEDIATELY CONTAINING + -- THE LOOP. (THIS IS PART C OF THE OBJECTIVE.) + + + + -- RM 6 JUNE 1980 + + + WITH REPORT; + PROCEDURE C83B02B IS + + USE REPORT; + + I , J : INTEGER := 1 ; + + BEGIN + + TEST ( "C83B02B" , + "CHECK THAT NON-NESTED LOOPS CAN HAVE IDENTICALLY NAMED" & + " PARAMETERS" ); + + COMMENT ( "THE NAME MAY BE THE SAME AS THAT OF A VARIABLE" & + " KNOWN OUTSIDE THE LOOP" ); + + -- CHECK PART B OF THE OBJECTIVE + DECLARE + TYPE WEEKDAY IS ( MON , TUE , WED , THU , FRI ); + BEGIN + + FOR LOOP_PAR IN 3..3 LOOP + I := I * LOOP_PAR ; -- 3 + END LOOP; + + FOR LOOP_PAR IN FRI..FRI LOOP + I := I * WEEKDAY'POS(LOOP_PAR) ; -- 12 + END LOOP; + + FOR LOOP_PAR IN 7..7 LOOP + I := I * LOOP_PAR ; -- 84 + END LOOP; + + END; + + IF I /= 84 THEN + FAILED ("DID NOT ACCESS ENCLOSING IDENTICALLY NAMED " & + "LOOP PARAMETER IN NON-NESTED LOOPS"); + END IF; + + -- CHECK PART C OF THE OBJECTIVE + DECLARE + LOOP_PAR : INTEGER := 2 ; + BEGIN + + J := J * LOOP_PAR ; -- 2 + + FOR LOOP_PAR IN 3..3 LOOP + J := J * LOOP_PAR ; -- 6 + END LOOP; + + J := J * LOOP_PAR ; -- 12 + + FOR LOOP_PAR IN 5..5 LOOP + J := J * LOOP_PAR ; -- 60 + END LOOP; + + J := J * LOOP_PAR ; -- 120 + + FOR LOOP_PAR IN 7..7 LOOP + J := J * LOOP_PAR ; -- 840 + END LOOP; + + J := J * LOOP_PAR ; -- 1680 + + END; + + IF J /= 1680 THEN + FAILED ("DID NOT ACCESS IDENTICALLY NAMED LOOP PARAMETER " & + "INSIDE NON-NESTED LOOPS OR IDENTICALLY NAMED " & + "VARIABLE OUTSIDE LOOPS"); + END IF; + + RESULT; + + END C83B02B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e02a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C83E02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE + -- USED DIRECTLY IN A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT, + -- AND AN INDEX CONSTRAINT. + + -- RM 8 JULY 1980 + + + WITH REPORT; + PROCEDURE C83E02A IS + + USE REPORT; + + Z : INTEGER := 0 ; + + PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + X : INTEGER RANGE A+1..1+B ; + BEGIN + X := A + 1 ; + C := X * B + B * X * A ; -- 4*3+3*4*3=48 + END ; + + PROCEDURE P2 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + TYPE T (MAX : INTEGER) IS + RECORD + VALUE : INTEGER RANGE 1..3 ; + END RECORD ; + X : T(A); + BEGIN + X := ( MAX => 4 , VALUE => B ) ; -- ( 4 , 3 ) + C := 10*C + X.VALUE + 2 ; -- 10*48+3+2=485 + END ; + + FUNCTION F3 ( A , B : INTEGER ) RETURN INTEGER IS + TYPE TABLE IS ARRAY( A..B ) OF INTEGER ; + X : TABLE ; + Y : ARRAY( A..B ) OF INTEGER ; + BEGIN + X(A) := A ; -- 5 + Y(B) := B ; -- 6 + RETURN X(A)-Y(B)+4 ; -- 3 + END ; + + + BEGIN + + TEST( "C83E02A" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " & + " A FORMAL PARAMETER CAN BE USED DIRECTLY IN" & + " A RANGE CONSTRAINT, A DISCRIMINANT CONSTRAINT"& + ", AND AN INDEX CONSTRAINT" ) ; + + P1 ( 3 , 3 , Z ); -- Z BECOMES 48 + P2 ( 4 , F3( 5 , 6 ) , Z ); -- Z BECOMES 485 + + IF Z /= 485 THEN + FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" ); + END IF; + + RESULT; + + END C83E02A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e02b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- C83E02B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WITHIN THE BODY OF A SUBPROGRAM A FORMAL PARAMETER CAN BE + -- USED IN AN EXCEPTION HANDLER. + + -- RM 10 JULY 1980 + + + WITH REPORT; + PROCEDURE C83E02B IS + + USE REPORT; + + Z : INTEGER := 0 ; + + PROCEDURE P1 ( A , B : INTEGER; C : IN OUT INTEGER ) IS + E : EXCEPTION ; + BEGIN + RAISE E ; + FAILED( "FAILURE TO RAISE E " ); + EXCEPTION + WHEN E => + C := A + B ; + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + END ; + + + BEGIN + + TEST( "C83E02B" , "CHECK THAT WITHIN THE BODY OF A SUBPROGRAM " & + " A FORMAL PARAMETER CAN BE USED IN AN EXCEP" & + "TION HANDLER" ) ; + + P1 ( 3 , 14 , Z ); + + IF Z /= 17 THEN + FAILED( "ACCESSING ERROR OR COMPUTATION ERROR" ); + END IF; + + RESULT; + + END C83E02B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83e03a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C83E03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FORMAL PARAMETER IN A NAMED PARAMETER ASSOCIATION + -- IS NOT CONFUSED WITH AN ACTUAL PARAMETER IDENTIFIER HAVING THE + -- SAME SPELLING. + + + -- RM 23 JULY 1980 + + + WITH REPORT; + PROCEDURE C83E03A IS + + USE REPORT; + + P : INTEGER RANGE 1..23 := 17 ; + FLOW_INDEX : INTEGER := 0 ; + + BEGIN + + TEST( "C83E03A" , "CHECK THAT A FORMAL PARAMETER IN A NAMED" & + " PARAMETER ASSOCIATION IS NOT CONFUSED" & + " WITH AN ACTUAL PARAMETER HAVING THE" & + " SAME SPELLING" ); + + DECLARE + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PROCEDURE P1 ( P : INTEGER ) IS + BEGIN + IF P = 17 THEN BUMP ; END IF ; + END ; + + FUNCTION F1 ( P : INTEGER ) RETURN INTEGER IS + BEGIN + RETURN P ; + END ; + + BEGIN + + P1 ( P ); + P1 ( P => P ); + + IF F1 ( P + 1 ) = 17 + 1 THEN BUMP ; END IF; + IF F1 ( P => P + 1 ) = 17 + 1 THEN BUMP ; END IF; + + END ; + + IF FLOW_INDEX /= 4 THEN + FAILED( "INCORRECT ACCESSING OR INCORRECT FLOW" ); + END IF; + + RESULT; + + END C83E03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C83F01A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INSIDE A PACKAGE BODY, AN ATTEMPT TO REFERENCE AN IDENTI- + -- FIER DECLARED IN THE CORRESPONDING PACKAGE SPECIFICATION + -- IS SUCCESSFUL, EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE + -- ENVIRONMENT SURROUNDING THE PACKAGE BODY. + + -- NESTED PACKAGE BODIES ARE TESTED IN C83F01B , C83F01C , C83F01D + + + -- RM 05 AUGUST 1980 + -- JRK 13 NOV 1980 + + + WITH REPORT; + PROCEDURE C83F01A IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + + BEGIN + + TEST( "C83F01A" , "CHECK THAT INSIDE A PACKAGE BODY, " & + "AN ATTEMPT TO REFERENCE AN IDENTIFIER " & + "DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + COMMENT( "NESTED PACKAGE BODIES ARE TESTED IN C83F01B , -C , -D"); + + + DECLARE + + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 : BOOLEAN := TRUE ; + Y2 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + + Y1 , Y2 : INTEGER := 13 ; + + + PACKAGE BODY P IS + BEGIN + + X1 := X1 OR Y1 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + END P ; + + + BEGIN + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 13 OR + NOT P.X1 OR + P.Z /= 13 OR + P.Y2 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + END C83F01A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C83F01B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN ANOTHER PACKAGE BODY + -- AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE + -- CORRESPONDING PACKAGE SPECIFICATION + -- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE + -- OUTER PACKAGE (SPECIFICATION OR BODY) OR IN THE + -- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY. + + -- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F01C , + -- C83F01D . + + + -- RM 08 AUGUST 1980 + -- JRK 13 NOV 1980 + + + WITH REPORT; + PROCEDURE C83F01B IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + + BEGIN + + TEST( "C83F01B" , "CHECK THAT INSIDE A NESTED PACKAGE BODY" & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + COMMENT("SEPARATELY COMPILED PACKAGES ARE TESTED IN C83F01C, -D"); + + + DECLARE + + + Y1 , Y2 : INTEGER := 100 ; + + + PACKAGE OUTER IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + END OUTER ; + + + X2 : INTEGER := 100 ; + + + PACKAGE BODY OUTER IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS + + END P ; + + END OUTER ; + + + BEGIN + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 100 OR + NOT OUTER.P.X1 OR + OUTER.P.Z /= 13 OR + OUTER.P.Y2 /= 55 OR + OUTER.P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + END ; + + + RESULT; -- POSSIBLE ERROR DURING ELABORATION OF P + + END C83F01B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- C83F01C0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M + + -- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO + -- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M , + -- C83F01D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION + -- OF THE PACKAGE. THE BODY IS IN FILE C83F01C1. + + + -- RM 13 AUGUST 1980 + -- RM 22 AUGUST 1980 + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + + PACKAGE C83F01C0 IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 6 ; + Z : INTEGER := 7 ; + + END P ; + + PROCEDURE REQUIRE_BODY; + + END C83F01C0 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C83F01C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F01C2M + + -- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO + -- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F01D0M , + -- C83F01D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE. + + -- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME. + + + -- RM 13 AUGUST 1980 + -- RM 22 AUGUST 1980 + -- RM 28 AUGUST 1980 ('FAILED(.)' MOVED TO MAIN) + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + + PACKAGE BODY C83F01C0 IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER + -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK + -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE + -- PACKAGE WAS NOT ELABORATED). + + + END P ; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + END C83F01C0 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01c2.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C83F01C2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE + -- ( C83F01C0 ; SPECIFICATION IN C83F01C0.ADA , + -- BODY IN C83F01C1.ADA ) + + -- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED + -- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE + -- CORRESPONDING PACKAGE SPECIFICATION + -- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE + -- OUTER PACKAGE (SPECIFICATION OR BODY). + + -- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT + + + -- RM 11 AUGUST 1980 + -- RM 22 AUGUST 1980 + -- RM 29 AUGUST 1980 (MOVED 'FAILED(.)' FROM C83F01C1.ADA TO HERE) + + + WITH REPORT , C83F01C0 ; + PROCEDURE C83F01C2M IS + + USE REPORT , C83F01C0 ; + + BEGIN + + TEST( "C83F01C" , "CHECK THAT INSIDE A PACKAGE BODY" & + " NESTED WITHIN A SEPARATELY" & + " COMPILED PACKAGE BODY LIBRARY UNIT," & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE OUTER PACKAGE" & + " (SPECIFICATION OR BODY)" ) ; + + IF NOT P.X1 OR + P.Z /= 13 OR + P.Y2 /= 55 OR + P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + RESULT ; + + + END C83F01C2M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01d0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C83F01D0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT + -- ( C83F01D1.ADA ) + + -- CHECK THAT INSIDE A PACKAGE BODY NESTED WITHIN A SEPARATELY COMPILED + -- PACKAGE BODY AN ATTEMPT TO REFERENCE AN IDENTIFIER DECLARED IN THE + -- CORRESPONDING PACKAGE SPECIFICATION + -- IS SUCCESSFUL EVEN IF THE SAME IDENTIFIER IS DECLARED IN THE + -- OUTER PACKAGE (SPECIFICATION OR BODY). + + -- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT + + + -- RM 13 AUGUST 1980 + -- RM 29 AUGUST 1980 + -- JRK 13 NOV 1980 + + + WITH REPORT; + PROCEDURE C83F01D0M IS + + USE REPORT ; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + Y1 : INTEGER := 157 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + + PACKAGE C83F01D1 IS + + Y3 : INTEGER := 100 ; + + PACKAGE P IS + + X1 : BOOLEAN := FALSE ; + X2 : INTEGER RANGE 1..23 := 11 ; + Y1 , Y3 : BOOLEAN := TRUE ; + Y2 , Y4 : INTEGER := 5 ; + T1 : INTEGER := 23 ; + Z : INTEGER := 0 ; + + END P ; + + END C83F01D1 ; + + + Y2 : INTEGER := 200 ; + + + PACKAGE BODY C83F01D1 IS SEPARATE ; + + + BEGIN + + TEST( "C83F01D" , "CHECK THAT INSIDE A PACKAGE BODY" & + " NESTED WITHIN A SEPARATELY" & + " COMPILED PACKAGE BODY SUBUNIT," & + " AN ATTEMPT TO REFERENCE AN IDENTIFIER" & + " DECLARED IN THE CORRESPONDING PACKAGE SPECI" & + "FICATION IS SUCCESSFUL EVEN IF THE SAME IDEN" & + "TIFIER IS DECLARED IN THE OUTER PACKAGE" & + " (SPECIFICATION OR BODY)" ) ; + + IF X1 /= 17 OR + Z /= A OR + Y2 /= 200 OR + NOT C83F01D1.P.X1 OR + C83F01D1.P.Z /= 23 OR + C83F01D1.P.Y2 /= 55 OR + C83F01D1.P.Y4 /= 55 + THEN FAILED( "INCORRECT ACCESSING" ); + END IF; + + RESULT ; + + + END C83F01D0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f01d1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- C83F01D1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F01D0M + + + -- RM 13 AUGUST 1980 + -- RM 29 AUGUST 1980 + + + + SEPARATE (C83F01D0M) + PACKAGE BODY C83F01D1 IS + + Y4 : INTEGER := 200 ; + + PACKAGE BODY P IS + BEGIN + + X1 := NOT X1 AND Y1 AND Y3 ; + Z := Z + T1 ; + Y2 := X2 * Y2 ; + Y4 := X2 * Y4 ; + + -- ALL 4 ASSIGNMENTS ARE TESTED IN THE MAIN PROGRAM (RATHER + -- THAN HERE) TO PRECLUDE FALSE NEGATIVES (WHERE THE LACK + -- OF ELABORATION-TIME ERROR MESSAGES SIMPLY MEANS THAT THE + -- PACKAGE WAS NOT ELABORATED). + + -- INCORRECT INTERPRETATIONS IN THE FIRST TWO + -- ASSIGNMENTS MANIFEST THEMSELVES AT + -- COMPILE TIME AS TYPE ERRORS. + + END P ; + + END C83F01D1 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C83F03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INSIDE A PACKAGE BODY AN ATTEMPT TO PLACE AND REFERENCE + -- A LABEL IS SUCCESSFUL EVEN IF ITS IDENTIFIER IS DECLARED IN THE + -- ENVIRONMENT SURROUNDING THE PACKAGE BODY. + + -- NESTED PACKAGE BODIES ARE TESTED IN C83F03B , C83F03C , C83F03D + + + -- RM 03 SEPTEMBER 1980 + + + WITH REPORT; + PROCEDURE C83F03A IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + + BEGIN + + TEST( "C83F03A" , "CHECK THAT INSIDE A PACKAGE BODY " & + " AN ATTEMPT TO PLACE AND REFERENCE A LABEL" & + " IS SUCCESSFUL EVEN IF ITS IDEN" & + "TIFIER IS DECLARED IN THE ENVIRONMENT SURROUND"& + "ING THE PACKAGE BODY" ) ; + + + DECLARE + + + Y1 , Y2 : INTEGER := 13 ; + + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + + PACKAGE P IS + + AA : BOOLEAN := FALSE ; + + END P ; + + + PACKAGE BODY P IS + BEGIN + + GOTO X1 ; + + BUMP ; + BUMP ; + + <> BUMP ; GOTO X2 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO Y2 ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + + BEGIN + + IF FLOW_INDEX /= 6 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + END C83F03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- C83F03B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE ANOTHER PACKAGE BODY + -- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL + -- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY, TO AN IDENTI- + -- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION, + -- OR TO A LABEL IDENTIFIER OR OTHER IDENTIFIER IN THE + -- ENVIRONMENT SURROUNDING THE OUTER PACKAGE BODY. + + + -- INTERACTIONS WITH SEPARATE COMPILATION ARE TESTED IN C83F03C , + -- C83F03D . + + + -- RM 04 SEPTEMBER 1980 + + + WITH REPORT; + PROCEDURE C83F03B IS + + USE REPORT; + + X1 , X2 : INTEGER RANGE 1..23 := 17 ; + + TYPE T1 IS ( A , B , C) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + + BEGIN + + TEST( "C83F03B" , "CHECK THAT IF A PACKAGE BODY IS NESTED" & + " INSIDE ANOTHER PACKAGE BODY, THE INNER" & + " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" & + " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" & + " PACKAGE BODY, TO AN IDENTIFIER DECLARED IN" & + " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" & + "TION, OR TO A LABEL IDENTIFIER OR OTHER" & + " IDENTIFIER IN THE ENVIRONMENT SURROUNDING" & + " THE OUTER PACKAGE BODY" ) ; + + + DECLARE + + + Y1 , Y2 : INTEGER := 100 ; + + X2 : INTEGER := 100 ; + + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + + PACKAGE OUTER IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + PACKAGE P IS + AA : BOOLEAN := FALSE ; + END P ; + + END OUTER ; + + + PACKAGE BODY OUTER IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PACKAGE BODY P IS + BEGIN + + + GOTO X1 ; + + BUMP ; + BUMP ; + + <> BUMP ; GOTO X2 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO Y2 ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> BUMP ; GOTO T3 ; + BUMP ; + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> BUMP ; GOTO Y3 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + BEGIN + + << LABEL_IN_OUTER >> NULL ; + + END OUTER ; + + + BEGIN + + << LABEL_IN_MAIN >> + + IF FLOW_INDEX /= 12 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + END ; + + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + END C83F03B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- C83F03C0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M + + -- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO + -- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M , + -- C83F03D1 ). THE PRESENT FILE CONTAINS THE SPECIFICATION + -- OF THE PACKAGE. THE PACKAGE BODY IS IN C83F03C1.ADA . + + + -- RM 04 SEPTEMBER 1980 + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + + PACKAGE C83F03C0 IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + FLOW_INDEX : INTEGER := 0 ; + + PROCEDURE REQUIRE_BODY; + + PACKAGE P IS + + AA : BOOLEAN := FALSE ; + + END P ; + + END C83F03C0 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C83F03C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE FOR USE WITH C83F03C2M + + -- THIS PACKAGE IS A FULL-FLEDGED COMPILATION UNIT (AS OPPOSED TO + -- BEING A SUBUNIT; SUBUNITS ARE TESTED IN C83F03D0M , + -- C83F03D1 ). THE PRESENT FILE CONTAINS THE BODY OF THE PACKAGE. + + -- FOR THIS FILE, THE FILE NAME AND THE UNIT NAME ARE NOT THE SAME. + + + -- RM 05 SEPTEMBER 1980 + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + + PACKAGE BODY C83F03C0 IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY P IS + BEGIN + + GOTO T3 ; + + BUMP ; + BUMP ; + + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> BUMP ; GOTO Y3 ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + BEGIN + + << LABEL_IN_OUTER >> NULL ; + + END C83F03C0 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03c2.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C83F03C2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE + -- ( C83F03C0 ; SPECIFICATION IN C83F03C0.ADA , + -- BODY IN C83F03C1.ADA ) + + -- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED + -- PACKAGE BODY + -- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL + -- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI- + -- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION. + + -- CASE 1: PACKAGE IS A FULL-FLEDGED COMPILATION UNIT + + + -- RM 05 SEPTEMBER 1980 + + + WITH REPORT , C83F03C0 ; + PROCEDURE C83F03C2M IS + + USE REPORT , C83F03C0 ; + + BEGIN + + TEST( "C83F03C" , "CHECK THAT IF A PACKAGE BODY IS NESTED" & + " INSIDE A SEPARATELY COMPILED PACKAGE BODY" & + " LIBRARY UNIT, THE INNER" & + " PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER" & + " IDENTICAL TO A LABEL IDENTIFIER IN THE OUTER" & + " PACKAGE BODY OR TO AN IDENTIFIER DECLARED IN" & + " THE OUTER PACKAGE BODY OR IN ITS SPECIFICA" & + "TION" ) ; + + IF FLOW_INDEX /= 5 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + + END C83F03C2M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03d0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C83F03D0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MAIN PROGRAM REQUIRING A SEPARATELY COMPILED PACKAGE BODY SUBUNIT + -- ( C83F03D1.ADA ) + + -- CHECK THAT IF A PACKAGE BODY IS NESTED INSIDE A SEPARATELY COMPILED + -- PACKAGE BODY + -- THE INNER PACKAGE BODY CAN CONTAIN A LABEL IDENTIFIER IDENTICAL + -- TO A LABEL IDENTIFIER IN THE OUTER PACKAGE BODY OR TO AN IDENTI- + -- FIER DECLARED IN THE OUTER PACKAGE BODY OR IN ITS SPECIFICATION + -- OR IN ITS ENVIRONMENT. + + -- CASE 2: PACKAGE BODY IS A COMPILATION SUBUNIT + + + -- RM 08 SEPTEMBER 1980 + -- JRK 14 NOVEMBER 1980 + + + WITH REPORT; + PROCEDURE C83F03D0M IS + + USE REPORT ; + + X1 : INTEGER := 17 ; + + TYPE T1 IS ( A, B, C ) ; + + Z : T1 := A ; + + FLOW_INDEX : INTEGER := 0 ; + + + PACKAGE C83F03D1 IS + + Y3 : INTEGER := 100 ; + + TYPE T3 IS ( D , E , F ) ; + + PACKAGE P IS + AA : BOOLEAN := FALSE ; + END P ; + + END C83F03D1 ; + + + Y1 : INTEGER := 100 ; + + + PACKAGE BODY C83F03D1 IS SEPARATE ; + + + BEGIN + + TEST( "C83F03D" , "CHECK THE RECOGNITION OF LABELS IN NESTED" & + " PACKAGES SEPARATELY COMPILED AS SUBUNITS" ); + + << LABEL_IN_MAIN >> + + IF FLOW_INDEX /= 10 + THEN FAILED( "INCORRECT FLOW OF CONTROL" ); + END IF; + + RESULT; -- POSS. ERROR DURING ELABORATION OF P + + + END C83F03D0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c83f03d1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C83F03D1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATELY COMPILED PACKAGE BODY FOR USE WITH C83F03D0M + + + -- RM 08 SEPTEMBER 1980 + -- JRK 14 NOVEMBER 1980 + + + + SEPARATE (C83F03D0M) + PACKAGE BODY C83F03D1 IS + + Y4 : INTEGER := 200 ; + + TYPE T4 IS ( G , H , I ) ; + + PROCEDURE BUMP IS + BEGIN + FLOW_INDEX := FLOW_INDEX + 1 ; + END BUMP ; + + PACKAGE BODY P IS + BEGIN + + GOTO X1 ; + + BUMP ; + BUMP ; + + <> BUMP ; GOTO T3 ; + BUMP ; + <> BUMP ; GOTO Z ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_MAIN ; + BUMP ; + <> BUMP ; GOTO T1 ; + BUMP ; + <> BUMP ; GOTO Y1 ; + BUMP ; + <> BUMP ; GOTO T4 ; + BUMP ; + <> BUMP ; GOTO ENDING ; + BUMP ; + <> BUMP ; GOTO Y4 ; + BUMP ; + <> BUMP ; GOTO LABEL_IN_OUTER ; + BUMP ; + <> BUMP ; GOTO Y3 ; + BUMP ; + + << ENDING >> NULL; + + END P ; + + BEGIN + + << LABEL_IN_OUTER >> NULL ; + + END C83F03D1 ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c840001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c840001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c840001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c840001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- C840001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for the type determined by the subtype mark of a use type + -- clause, the declaration of each primitive operator is use-visible + -- within the scope of the clause, even if explicit operators with the + -- same names as the type's operators are declared for the subtype. Check + -- that a call to such an operator executes the body of the type's + -- operation. + -- + -- TEST DESCRIPTION: + -- A type may declare a primitive operator, and a subtype of that type + -- may overload the operator. If a use type clause names the subtype, + -- it is the primitive operator of the type (not the subtype) which + -- is made directly visible, and the primitive operator may be called + -- unambiguously. Such a call executes the body of the type's operation. + -- + -- In a package, declare a type for which a predefined operator is + -- overridden. In another package, declare a subtype of the type in the + -- previous package. Declare another version of the predefined operator + -- for the subtype. + -- + -- The main program declares objects of both the type and the explicit + -- subtype, and uses the "**" operator for both. In all cases, the + -- operator declared for the 1st subtype should be the one executed, + -- since it is the primitive operators of the *type* that are made + -- visible; the operators which were declared for the explicit subtype + -- are not primitive operators of the type, since they were declared in + -- a separate package from the original type. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 23 Sep 99 RLB Added test case where operator made visible is + -- not visible by selection (as in AI-00122). + -- + --! + + package C840001_0 is + -- Usage scenario: the predefined operators for a floating point type + -- are overridden in order to take advantage of improved algorithms. + + type Precision_Float is new Float range -100.0 .. 100.0; + -- Implicit: function "**" (Left: Precision_Float; Right: Integer'Base) + -- return Precision_Float; + + function "**" (Left: Precision_Float; Right: Integer'Base) + return Precision_Float; + -- Overrides predefined operator. + + function "+" (Right: Precision_Float) + return Precision_Float; + -- Overrides predefined operator. + + -- ... Other overridden operations. + + TC_Expected : constant Precision_Float := 68.0; + + end C840001_0; + + + --==================================================================-- + + package body C840001_0 is + + function "**" (Left: Precision_Float; Right: Integer'Base) + return Precision_Float is + begin + -- ... Utilize desired algorithm. + return (TC_Expected); -- Artificial for testing purposes. + end "**"; + + function "+" (Right: Precision_Float) + return Precision_Float is + -- Overrides predefined operator. + begin + return Right*2.0; + end "+"; + + end C840001_0; + + + --==================================================================-- + + -- Take advantage of some even better algorithms designed for positive + -- floating point values. + + with C840001_0; + package C840001_1 is + + subtype Precision_Pos_Float is C840001_0.Precision_Float + range 0.0 .. 100.0; + + -- This is not a new type, so it has no primitives of it own. However, it + -- can declare another version of the operator and call it as long as both it + -- and the corresponding operator of the 1st subtype are not directly visible + -- in the same place. + + function "**" (Left: Precision_Pos_Float; Right: Natural'Base) + return Precision_Pos_Float; -- Accepts only positive exponent. + + end C840001_1; + + + --==================================================================-- + + package body C840001_1 is + + function "**" (Left: Precision_Pos_Float; Right: Natural'Base) + return Precision_Pos_Float is + begin + -- ... Utilize some other algorithms. + return 57.0; -- Artificial for testing purposes. + end "**"; + + end C840001_1; + + + --==================================================================-- + + with Report; + with C840001_1; + procedure C840001_2 is + + -- Note that C840001_0 and it's contents is not visible in any form here. + + TC_Operand : C840001_1.Precision_Pos_Float := 41.0; + + TC_Operand2 : C840001_1.Precision_Pos_Float; + + use type C840001_1.Precision_Pos_Float; + -- Makes the operators of its parent type directly visible, even though + -- the parent type and operators are not otherwise visible at all. + + begin + + TC_Operand2 := +TC_Operand; -- Overridden operator is visible and called. + + if TC_Operand2 /= 82.0 then -- Predefined equality. + Report.Failed ("3rd test: type's overridden operation not called for " & + "operand of 1st subtype"); + end if; + if TC_Operand + 3.0 >= TC_Operand2 - 13.0 then -- Various predefined operators. + Report.Failed ("3rd test: wrong result from predefined operators"); + end if; + + end C840001_2; + + --==================================================================-- + + + with C840001_0; + with C840001_1; + with C840001_2; + + with Report; + + procedure C840001 is + + begin + Report.Test ("C840001", "Check that, for the type determined by the " & + "subtype mark of a use type clause, the declaration of " & + "each primitive operator is use-visible within the scope " & + "of the clause, even if explicit operators with the same " & + "names as the type's operators are declared for the subtype"); + + + Use_Type_Precision_Pos_Float: + declare + TC_Operand : C840001_0.Precision_Float + := C840001_0.Precision_Float(-2.0); + TC_Positive_Operand : C840001_1.Precision_Pos_Float := 6.0; + + TC_Actual_Type : C840001_0.Precision_Float; + TC_Actual_Subtype : C840001_1.Precision_Pos_Float; + + use type C840001_1.Precision_Pos_Float; + -- Both calls to "**" should return 68.0 (that is, Precision_Float's + -- operation should be called). + + begin + + TC_Actual_Type := TC_Operand**2; + + if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then + Report.Failed ("1st block: type's operation not called for " & + "operand of 1st subtype"); + end if; + + TC_Actual_Subtype := TC_Positive_Operand**2; + + if not (C840001_0."=" + (TC_Actual_Subtype, C840001_0.TC_Expected)) then + Report.Failed ("1st block: type's operation not called for " & + "operand of explicit subtype"); + end if; + + end Use_Type_Precision_Pos_Float; + + Use_Type_Precision_Float: + declare + TC_Operand : C840001_0.Precision_Float + := C840001_0.Precision_Float(4.0); + TC_Positive_Operand : C840001_1.Precision_Pos_Float := 7.0; + + TC_Actual_Type : C840001_0.Precision_Float; + TC_Actual_Subtype : C840001_1.Precision_Pos_Float; + + use type C840001_0.Precision_Float; + -- Again, both calls to "**" should return 68.0. + + begin + + TC_Actual_Type := TC_Operand**2; + + if C840001_0."/="(TC_Actual_Type, C840001_0.TC_Expected) then + Report.Failed ("2nd block: type's operation not called for " & + "operand of 1st subtype"); + end if; + + TC_Actual_Subtype := TC_Positive_Operand**2; + + if not C840001_0."=" (TC_Actual_Subtype, C840001_0.TC_Expected) then + Report.Failed ("2nd block: type's operation not called for " & + "operand of explicit subtype"); + end if; + + end Use_Type_Precision_Float; + + C840001_2; -- 3rd test. + + Report.Result; + + end C840001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84002a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C84002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT: + + -- A) IF A USE CLAUSE NAMES AN ENCLOSING PACKAGE, THE USE CLAUSE + -- HAS NO EFFECT. + + -- B) IF A DECLARATION IS DIRECTLY VISIBLE PRIOR TO THE OCCURRENCE + -- OF A USE CLAUSE, AND IS NOT IN THE SET OF POTENTIALLY + -- VISIBLE DECLARATIONS, IT REMAINS DIRECTLY VISIBLE AFTER THE + -- USE CLAUSE. + + -- C) IF A HOMOGRAPH FOR A POTENTIALLY VISIBLE SUBPROGRAM OR + -- OBJECT IS DECLARED AFTER A USE CLAUSE, THE POTENTIALLY + -- VISIBLE ENTITY IS NO LONGER VISIBLE. + + -- EG 02/16/84 + + WITH REPORT; + + PROCEDURE C84002A IS + + USE REPORT; + + BEGIN + + TEST("C84002A","CHECK THAT DECLARATIONS DIRECTLY VISIBLE PRIOR " & + "TO THE USE CLAUSE REMAIN VISIBLE AFTERWARDS"); + + BEGIN + + COMMENT ("CASE A : CHECK THAT IF A USE CLAUSE NAMES AN " & + "ENCLOSING PACKAGE, THE USE CLAUSE HAS NO EFFECT"); + + CASE_A : DECLARE + + PACKAGE P1 IS + X : FLOAT := 1.5; + END P1; + PACKAGE P2 IS + X : INTEGER := 15; + + USE P1; + USE P2; + + A : INTEGER := X; + END P2; + PACKAGE BODY P1 IS + BEGIN + NULL; + END P1; + PACKAGE BODY P2 IS + BEGIN + IF X /= IDENT_INT(15) OR X /= P2.X OR + A /= P2.X THEN + FAILED ("CASE A : USE CLAUSE HAS AN EFFECT"); + END IF; + END P2; + + BEGIN + + NULL; + + END CASE_A; + + COMMENT ("CASE B : CHECK THAT IF A DECLARATION IS DIRECTLY " & + "VISIBLE PRIOR TO THE OCCURRENCE OF A USE CLAUSE, " & + "AND IS NOT IN THE SET OF POTENTIALLY VISIBLE " & + "DECLARATIONS, IT REMAINS DIRECTLY VISIBLE"); + + CASE_B : BEGIN + + CASE_B1 : DECLARE + + PACKAGE P1 IS + Y : FLOAT := 1.5; + END P1; + PACKAGE P2 IS + X : INTEGER := 15; + + USE P1; + + A : INTEGER := X; + END P2; + + PACKAGE BODY P1 IS + BEGIN + NULL; + END P1; + PACKAGE BODY P2 IS + BEGIN + IF X /= IDENT_INT(15) OR X /= P2.X OR + A /= P2.X THEN + FAILED ("CASE B1 : DECLARATION NO " & + "LONGER DIRECTLY VISIBLE"); + END IF; + END P2; + + BEGIN + + NULL; + + END CASE_B1; + + CASE_B2 : DECLARE + + PROCEDURE PROC1 (X : STRING) IS + BEGIN + NULL; + END PROC1; + + PACKAGE P1 IS + PROCEDURE PROC1 (X : STRING); + END P1; + PACKAGE BODY P1 IS + PROCEDURE PROC1 (X : STRING) IS + BEGIN + FAILED ("CASE B2 : WRONG PROCEDURE " & + "DIRECTLY VISIBLE"); + END PROC1; + END P1; + + USE P1; + + BEGIN + + PROC1 ("ABC"); + + END CASE_B2; + + CASE_B3 : DECLARE + + PROCEDURE PROC1 (X : STRING) IS + BEGIN + NULL; + END PROC1; + + PACKAGE P1 IS + PROCEDURE PROC1 (Y : STRING); + END P1; + PACKAGE BODY P1 IS + PROCEDURE PROC1 (Y : STRING) IS + BEGIN + FAILED ("CASE B3 : WRONG PROCEDURE " & + "DIRECTLY VISIBLE"); + END PROC1; + END P1; + + USE P1; + + BEGIN + + PROC1 ("ABC"); + + END CASE_B3; + + END CASE_B; + + COMMENT ("CASE C : IF A HOMOGRAPH FOR A POTENTIALLY " & + "VISIBLE SUBPROGRAM OR OBJECT IS DECLARED AFTER " & + "A USE CLAUSE, THE POTENTIALLY VISIBLE ENTITY " & + "IS NO LONGER VISIBLE"); + + CASE_C : BEGIN + + CASE_C1 : DECLARE + + PACKAGE P1 IS + PROCEDURE PROC1 (X : FLOAT); + END P1; + + USE P1; + + PACKAGE BODY P1 IS + PROCEDURE PROC1 (X : FLOAT) IS + BEGIN + IF X = -1.5 THEN + FAILED ("CASE C1 : WRONG PROCEDURE" & + " CALLED (A)"); + ELSIF X /= 1.5 THEN + FAILED ("CASE C1 : WRONG VALUE " & + "PASSED (A)"); + END IF; + END PROC1; + BEGIN + NULL; + END P1; + + PROCEDURE PROC2 IS + BEGIN + PROC1 (1.5); + END PROC2; + + PROCEDURE PROC1 (X : FLOAT) IS + BEGIN + IF X = 1.5 THEN + FAILED ("CASE C1 : WRONG PROCEDURE" & + " CALLED (B)"); + ELSIF X /= -1.5 THEN + FAILED ("CASE C1 : WRONG VALUE " & + "PASSED (B)"); + END IF; + END PROC1; + + BEGIN + + PROC2; + PROC1 (-1.5); + + END CASE_C1; + + CASE_C2 : DECLARE + + PACKAGE P1 IS + X : INTEGER := 15; + END P1; + + USE P1; + + A : INTEGER := X; + + X : BOOLEAN := TRUE; + + B : BOOLEAN := X; + + BEGIN + + IF A /= IDENT_INT(15) THEN + FAILED ("CASE C2 : VARIABLE A DOES NOT " & + "CONTAIN THE CORRECT VALUE"); + END IF; + IF B /= IDENT_BOOL(TRUE) THEN + FAILED ("CASE C2 : VARIABLE B DOES NOT " & + "CONTAIN THE CORRECT VALUE"); + END IF; + + END CASE_C2; + + END CASE_C; + + END; + + RESULT; + + END C84002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84005a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C84005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT TWO POTENTIALLY VISIBLE HOMOGRAPHS OF A SUBPROGRAM + -- IDENTIFIER CAN BE MADE DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT + -- WHEN DIFFERENT FORMAL PARAMETER NAMES ARE USED THE SUBPROGRAMS + -- ARE REFERENCED CORRECTLY. + + -- HISTORY: + -- JET 03/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C84005A IS + + PACKAGE PACK1 IS + FUNCTION FUNK(A : INTEGER) RETURN INTEGER; + PROCEDURE PROK(A : INTEGER; B : OUT INTEGER); + END PACK1; + + PACKAGE PACK2 IS + FUNCTION FUNK(X : INTEGER) RETURN INTEGER; + PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER); + END PACK2; + + USE PACK1, PACK2; + VAR1, VAR2 : INTEGER; + + PACKAGE BODY PACK1 IS + FUNCTION FUNK(A : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL (A,A) THEN + RETURN (1); + ELSE + RETURN (0); + END IF; + END FUNK; + + PROCEDURE PROK(A : INTEGER; B : OUT INTEGER) IS + BEGIN + IF EQUAL (A,A) THEN + B := 1; + ELSE + B := 0; + END IF; + END PROK; + END PACK1; + + PACKAGE BODY PACK2 IS + FUNCTION FUNK(X : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL (X,X) THEN + RETURN (2); + ELSE + RETURN (0); + END IF; + END FUNK; + + PROCEDURE PROK(X : INTEGER; Y : OUT INTEGER) IS + BEGIN + IF EQUAL (X,X) THEN + Y := 2; + ELSE + Y := 0; + END IF; + END PROK; + END PACK2; + + BEGIN + TEST ("C84005A", "CHECK THAT TWO POTENTIALLY VISIBLE HOMOGRAPHS " & + "OF A SUBPROGRAM IDENTIFIER CAN BE MADE " & + "DIRECTLY VISIBLE BY A USE CLAUSE, AND THAT " & + "WHEN DIFFERENT FORMAL PARAMETER NAMES ARE " & + "USED, THE SUBPROGRAMS ARE REFERENCED CORRECTLY"); + + IF FUNK(A => 3) /= IDENT_INT(1) THEN + FAILED("PACK1.FUNK RETURNS INCORRECT RESULT"); + END IF; + + IF FUNK(X => 3) /= IDENT_INT(2) THEN + FAILED("PACK2.FUNK RETURNS INCORRECT RESULT"); + END IF; + + PROK(A => 3, B => VAR1); + PROK(X => 3, Y => VAR2); + + IF VAR1 /= IDENT_INT(1) THEN + FAILED("PACK1.PROK RETURNS INCORRECT RESULT"); + END IF; + + IF VAR2 /= IDENT_INT(2) THEN + FAILED("PACK2.PROK RETURNS INCORRECT RESULT"); + END IF; + + RESULT; + END C84005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84008a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C84008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAMES MADE VISIBLE BY A USE CLAUSE IN THE VISIBLE + -- PART OF A PACKAGE ARE VISIBLE IN THE PRIVATE PART AND BODY OF + -- THE PACKAGE. + + -- HISTORY: + -- JET 03/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C84008A IS + + PACKAGE PACK1 IS + TYPE A IS RANGE 0..100; + TYPE B IS RANGE -100..0; + END PACK1; + + PACKAGE PACK2 IS + USE PACK1; + TYPE C IS PRIVATE; + PROCEDURE PROC (X : OUT A; Y : OUT B); + PRIVATE + TYPE C IS NEW A RANGE 0..9; + END PACK2; + + VAR1 : PACK1.A; + VAR2 : PACK1.B; + + PACKAGE BODY PACK2 IS + PROCEDURE PROC (X : OUT A; Y : OUT B) IS + SUBTYPE D IS B RANGE -9..0; + BEGIN + IF EQUAL(3,3) THEN + X := A'(2); + Y := D'(-2); + ELSE + X := A'(0); + Y := D'(0); + END IF; + END PROC; + END PACK2; + + BEGIN + TEST ("C84008A", "CHECK THAT THE NAMES MADE VISIBLE BY A USE " & + "CLAUSE IN THE VISIBLE PART OF A PACKAGE ARE " & + "VISIBLE IN THE PRIVATE PART AND BODY OF " & + "THE PACKAGE"); + + PACK2.PROC (VAR1,VAR2); + + IF PACK1."/=" (VAR1, 2) THEN + FAILED("INCORRECT RETURN VALUE FOR VAR1"); + END IF; + + IF PACK1."/=" (VAR2, PACK1."-"(2)) THEN + FAILED("INCORRECT RETURN VALUE FOR VAR2"); + END IF; + + RESULT; + END C84008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c84009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c84009a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C84009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A USE CLAUSE MAKES AN IMPLICITLY OR EXPLICITLY + -- DECLARED OPERATOR DIRECTLY VISIBLE IF NO HOMOGRAPH OF THE + -- OPERATOR IS ALREADY DIRECTLY VISIBLE. + + -- HISTORY: + -- JET 03/10/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C84009A IS + + TYPE INT IS NEW INTEGER RANGE -100 .. 100; + + PACKAGE PACK IS + FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER; + FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT; + FUNCTION "-" (RIGHT : INT) RETURN INTEGER; + FUNCTION "+" (RIGHT : INT) RETURN INTEGER; + END PACK; + + FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN INTEGER'(1) + INTEGER(RIGHT); + END "+"; + + PACKAGE BODY PACK IS + FUNCTION "+" (LEFT : INTEGER; RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN LEFT + INTEGER(RIGHT); + END "+"; + + FUNCTION "-" (LEFT, RIGHT : INT) RETURN INT IS + BEGIN + FAILED ("BINARY ""-"" ALREADY VISIBLE FOR TYPE INT"); + RETURN LEFT + (-RIGHT); + END "-"; + + FUNCTION "-" (RIGHT : INT) RETURN INTEGER IS + BEGIN + RETURN INTEGER'(0) - INTEGER(RIGHT); + END "-"; + + FUNCTION "+" (RIGHT : INT) RETURN INTEGER IS + BEGIN + FAILED ("UNARY ""+"" ALREADY VISIBLE FOR TYPE INT"); + RETURN INTEGER'(0) + INTEGER(RIGHT); + END "+"; + END PACK; + + USE PACK; + + BEGIN + TEST ("C84009A", "CHECK THAT A USE CLAUSE MAKES AN IMPLICITLY " & + "OR EXPLICITLY DECLARED OPERATOR DIRECTLY " & + "VISIBLE IF NO HOMOGRAPH OF THE OPERATOR IS " & + "ALREADY DIRECTLY VISIBLE"); + + IF INTEGER'(10) + INT'(10) /= IDENT_INT(20) THEN + FAILED ("INCORRECT RESULT FROM BINARY ""+"""); + END IF; + + IF INT'(5) - INT'(3) /= INT'(2) THEN + FAILED ("INCORRECT RESULT FROM BINARY ""-"""); + END IF; + + IF -INT'(20) /= IDENT_INT(-INTEGER'(20)) THEN + FAILED ("INCORRECT RESULT FROM UNARY ""-"""); + END IF; + + IF +INT'(20) /= IDENT_INT(+INTEGER'(21)) THEN + FAILED ("INCORRECT RESULT FROM UNARY ""+"""); + END IF; + + RESULT; + END C84009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85004b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C85004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RENAMED CONSTANT OBJECT, "IN" PARAMETER OF A + -- SUBPROGRAM OR ENTRY, "IN" FORMAL GENERIC, RECORD DISCRIMINANT, + -- LOOP PARAMETER, DEFERRED CONSTANT, OR RENAMED CONSTANT HAS THE + -- CORRECT VALUE. + + -- HISTORY: + -- JET 07/25/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85004B IS + + TYPE A IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE P IS POSITIVE RANGE 1 .. 10; + + C1 : CONSTANT INTEGER := 1; + X1 : INTEGER RENAMES C1; + X2 : INTEGER RENAMES X1; + + TYPE REC (D : P := 1) IS + RECORD + I : A(1..D); + END RECORD; + TYPE ACCREC1 IS ACCESS REC; + TYPE ACCREC2 IS ACCESS REC(10); + + R1 : REC; + R2 : REC(10); + AR1 : ACCREC1 := NEW REC; + AR2 : ACCREC2 := NEW REC(10); + + X3 : P RENAMES R1.D; + X4 : P RENAMES R2.D; + X5 : P RENAMES AR1.D; + X6 : P RENAMES AR2.D; + + C2 : CONSTANT A(1..3) := (1, 2, 3); + X7 : INTEGER RENAMES C2(1); + + GENERIC + K1 : IN INTEGER; + PACKAGE GENPKG IS + TYPE K IS PRIVATE; + K2 : CONSTANT K; + PRIVATE + TYPE K IS RANGE 1..100; + K2 : CONSTANT K := 5; + END GENPKG; + + TASK FOOEY IS + ENTRY ENT1 (I : IN INTEGER); + END FOOEY; + + TASK BODY FOOEY IS + BEGIN + ACCEPT ENT1 (I : IN INTEGER) DO + DECLARE + TX1 : INTEGER RENAMES I; + BEGIN + IF TX1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE"); + END IF; + END; + END ENT1; + END FOOEY; + + PACKAGE BODY GENPKG IS + KX1 : INTEGER RENAMES K1; + KX2 : K RENAMES K2; + BEGIN + IF KX1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF KX1"); + END IF; + + IF KX2 /= K(IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF KX2"); + END IF; + END GENPKG; + + PROCEDURE PROC (I : IN INTEGER) IS + PX1 : INTEGER RENAMES I; + BEGIN + IF PX1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF PX1"); + END IF; + END PROC; + + PACKAGE PKG IS NEW GENPKG(4); + + BEGIN + TEST ("C85004B", "CHECK THAT A RENAMED CONSTANT OBJECT, 'IN' " & + "PARAMETER OF A SUBPROGRAM OR ENTRY, 'IN' FORMAL GENERIC, " & + "RECORD DISCRIMINANT, LOOP PARAMETER, DEFERRED CONSTANT, " & + "OR RENAMED CONSTANT HAS THE CORRECT VALUE"); + + FOOEY.ENT1(2); + + PROC(3); + + IF X1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X1"); + END IF; + + IF X2 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X2"); + END IF; + + IF X3 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X3"); + END IF; + + IF X4 /= IDENT_INT(10) THEN + FAILED ("INCORRECT VALUE OF X4"); + END IF; + + IF X5 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X5"); + END IF; + + IF X6 /= IDENT_INT(10) THEN + FAILED ("INCORRECT VALUE OF X6"); + END IF; + + IF X7 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF X7"); + END IF; + + FOR I IN 1..IDENT_INT(2) LOOP + DECLARE + X8 : INTEGER RENAMES I; + BEGIN + IF X8 /= IDENT_INT(I) THEN + FAILED ("INCORRECT VALUE OF X8"); + END IF; + END; + END LOOP; + + RESULT; + + END C85004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,391 ---- + -- C85005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE CREATED BY AN OBJECT DECLARATION CAN BE + -- RENAMED AND HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN + -- BE USED IN AN ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL + -- SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN + -- ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF + -- THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED + -- BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005A IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + K1 : INTEGER := 0; + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER); + END TASK2; + + I1 : INTEGER := 0; + A1 : ARRAY1(1..3) := (OTHERS => 0); + R1 : RECORD1(1) := (D => 1, FIELD1 => 0); + P1 : POINTER1 := NEW INTEGER'(0); + V1 : PACK1.PRIVY := PACK1.ZERO; + T1 : TASK1; + + XI1 : INTEGER RENAMES I1; + XA1 : ARRAY1 RENAMES A1; + XR1 : RECORD1 RENAMES R1; + XP1 : POINTER1 RENAMES P1; + XV1 : PACK1.PRIVY RENAMES V1; + XT1 : TASK1 RENAMES T1; + XK1 : INTEGER RENAMES PACK1.K1; + + I : INTEGER; + CHK_TASK : TASK2; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + GK1 : IN OUT INTEGER; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1; + PK1 : OUT INTEGER) IS + + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(P1.ALL + 1); + PV1 := PACK1.NEXT(V1); + PT1.NEXT; + PK1 := PACK1.K1 + 1; + END PROC1; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1+1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + GK1 := GK1 + 1; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER) DO + + TI1 := I1 + 1; + TA1 := (A1(1)+1, A1(2)+1, A1(3)+1); + TR1 := (D => 1, FIELD1 => R1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + TK1 := TK1 + 1; + END ENTRY1; + END TASK2; + + BEGIN + TEST ("C85005A", "CHECK THAT A VARIABLE CREATED BY AN OBJECT " & + "DECLARATION CAN BE RENAMED AND HAS THE " & + "CORRECT VALUE, AND THAT THE NEW NAME CAN " & + "BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (XI1, XA1, XR1, XP1, XV1, XT1, XK1); + BEGIN + NULL; + END; + + IF XI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XI1 (1)"); + END IF; + + IF XA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XA1 (1)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XR1 (1)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XP1 (1)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (1)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (1)"); + END IF; + + IF XK1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XK1 (1)"); + END IF; + + PROC1(XI1, XA1, XR1, XP1, XV1, XT1, XK1); + + IF XI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XI1 (2)"); + END IF; + + IF XA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XA1 (2)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XR1 (2)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XP1 (2)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XV1 (2)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XT1.VALU (2)"); + END IF; + + IF XK1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XK1 (2)"); + END IF; + + CHK_TASK.ENTRY1(XI1, XA1, XR1, XP1, XV1, XT1, XK1); + + IF XI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XI1 (3)"); + END IF; + + IF XA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XA1 (3)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XR1 (3)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XP1 (3)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (3)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (3)"); + END IF; + + IF XK1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XK1 (3)"); + END IF; + + XI1 := XI1 + 1; + XA1 := (XA1(1)+1, XA1(2)+1, XA1(3)+1); + XR1 := (D => 1, FIELD1 => XR1.FIELD1 + 1); + XP1 := NEW INTEGER'(XP1.ALL + 1); + XV1 := PACK1.NEXT(XV1); + XT1.NEXT; + XK1 := XK1 + 1; + + IF XI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XI1 (4)"); + END IF; + + IF XA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XA1 (4)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XR1 (4)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XP1 (4)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XV1 (4)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (4)"); + END IF; + + IF XK1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XK1 (4)"); + END IF; + + I1 := I1 + 1; + A1 := (A1(1)+1, A1(2)+1, A1(3)+1); + R1 := (D => 1, FIELD1 => R1.FIELD1 + 1); + P1 := NEW INTEGER'(P1.ALL + 1); + V1 := PACK1.NEXT(V1); + T1.NEXT; + PACK1.K1 := PACK1.K1 + 1; + + IF XI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XI1 (5)"); + END IF; + + IF XA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XA1 (5)"); + END IF; + + IF XR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XR1 (5)"); + END IF; + + IF XP1 /= IDENT(P1) OR XP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XP1 (5)"); + END IF; + + IF PACK1."/=" (XV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XV1 (5)"); + END IF; + + XT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XT1.VALU (5)"); + END IF; + + IF XK1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XK1 (5)"); + END IF; + + T1.STOP; + + RESULT; + END C85005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,366 ---- + -- C85005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM 'IN OUT' FORMAL + -- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT + -- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED + -- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, + -- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE + -- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS + -- REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005B IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + PROCEDURE PROC (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : IN OUT POINTER1; + PV1 : IN OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS + XPI1 : INTEGER RENAMES PI1; + XPA1 : ARRAY1 RENAMES PA1; + XPR1 : RECORD1 RENAMES PR1; + XPP1 : POINTER1 RENAMES PP1; + XPV1 : PACK1.PRIVY RENAMES PV1; + XPT1 : TASK1 RENAMES PT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END TASK2; + + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PPI1 : IN OUT INTEGER; PPA1 : IN OUT ARRAY1; + PPR1 : IN OUT RECORD1; PPP1 : OUT POINTER1; + PPV1 : OUT PACK1.PRIVY; + PPT1 : IN OUT TASK1) IS + BEGIN + PPI1 := PPI1 + 1; + PPA1 := (PPA1(1)+1, PPA1(2)+1, PPA1(3)+1); + PPR1 := (D => 1, FIELD1 => PPR1.FIELD1 + 1); + PPP1 := NEW INTEGER'(PP1.ALL + 1); + PPV1 := PACK1.NEXT(PV1); + PPT1.NEXT; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1) + DO + TI1 := PI1 + 1; + TA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + TR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK1 IS NEW GENERIC1 + (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + BEGIN + IF XPI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XPI1 (1)"); + END IF; + + IF XPA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (1)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (1)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XPP1 (1)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (1)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (1)"); + END IF; + + PROC1(XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + IF XPI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XPI1 (2)"); + END IF; + + IF XPA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (2)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (2)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XPP1 (2)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (2)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XPT1.VALU (2)"); + END IF; + + CHK_TASK.ENTRY1 (XPI1, XPA1, XPR1, XPP1, XPV1, XPT1); + + IF XPI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XPI1 (3)"); + END IF; + + IF XPA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (3)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (3)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XPP1 (3)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (3)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (3)"); + END IF; + + XPI1 := XPI1 + 1; + XPA1 := (XPA1(1)+1, XPA1(2)+1, XPA1(3)+1); + XPR1 := (D => 1, FIELD1 => XPR1.FIELD1 + 1); + XPP1 := NEW INTEGER'(XPP1.ALL + 1); + XPV1 := PACK1.NEXT(XPV1); + XPT1.NEXT; + + IF XPI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XPI1 (4)"); + END IF; + + IF XPA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (4)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (4)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XPP1 (4)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (4)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (4)"); + END IF; + + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(PP1.ALL + 1); + PV1 := PACK1.NEXT(PV1); + PT1.NEXT; + + IF XPI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XPI1 (5)"); + END IF; + + IF XPA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XPA1 (5)"); + END IF; + + IF XPR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XPR1 (5)"); + END IF; + + IF XPP1 /= IDENT(PP1) OR XPP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XPP1 (5)"); + END IF; + + IF PACK1."/=" (XPV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XPV1 (5)"); + END IF; + + XPT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XPT1.VALU (5)"); + END IF; + END PROC; + + BEGIN + TEST ("C85005B", "CHECK THAT A VARIABLE CREATED BY A SUBPROGRAM " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + PROC (DI1, DA1, DR1, DP1, DV1, DT1); + + DT1.STOP; + + RESULT; + END C85005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,416 ---- + -- C85005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE CREATED BY AN ENTRY 'IN OUT' FORMAL + -- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND THAT + -- THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND PASSED + -- ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' PARAMETER, + -- AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT WHEN THE + -- VALUE OF THE RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS + -- REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005C IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85005C", "CHECK THAT A VARIABLE CREATED BY AN ENTRY " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + TASK MAIN_TASK IS + ENTRY START (TI1 : IN OUT INTEGER; TA1 : IN OUT ARRAY1; + TR1 : IN OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END MAIN_TASK; + + TASK BODY MAIN_TASK IS + BEGIN + ACCEPT START (TI1: IN OUT INTEGER; TA1: IN OUT ARRAY1; + TR1: IN OUT RECORD1; TP1: IN OUT POINTER1; + TV1: IN OUT PACK1.PRIVY; + TT1: IN OUT TASK1) DO + DECLARE + XTI1 : INTEGER RENAMES TI1; + XTA1 : ARRAY1 RENAMES TA1; + XTR1 : RECORD1 RENAMES TR1; + XTP1 : POINTER1 RENAMES TP1; + XTV1 : PACK1.PRIVY RENAMES TV1; + XTT1 : TASK1 RENAMES TT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1); + END TASK2; + + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PTI1 : IN OUT INTEGER; + PTA1 : IN OUT ARRAY1; + PTR1 : IN OUT RECORD1; + PTP1 : OUT POINTER1; + PTV1 : OUT PACK1.PRIVY; + PTT1 : IN OUT TASK1) IS + BEGIN + PTI1 := PTI1 + 1; + PTA1 := (PTA1(1)+1, PTA1(2)+1, PTA1(3)+1); + PTR1 := (D => 1, + FIELD1 => PTR1.FIELD1 + 1); + PTP1 := NEW INTEGER'(TP1.ALL + 1); + PTV1 := PACK1.NEXT(TV1); + PTT1.NEXT; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TTI1 : OUT INTEGER; + TTA1 : OUT ARRAY1; + TTR1 : OUT RECORD1; + TTP1 : IN OUT POINTER1; + TTV1 : IN OUT PACK1.PRIVY; + TTT1 : IN OUT TASK1) + DO + TTI1 := TI1 + 1; + TTA1 := (TA1(1)+1, + TA1(2)+1, TA1(3)+1); + TTR1 := (D => 1, + FIELD1 => TR1.FIELD1 + 1); + TTP1 := NEW INTEGER'(TTP1.ALL + 1); + TTV1 := PACK1.NEXT(TTV1); + TTT1.NEXT; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK1 IS NEW GENERIC1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + BEGIN + IF XTI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTI1 (1)"); + END IF; + + IF XTA1 /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (1)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (1)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XTP1 (1)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.ONE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (1)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (1)"); + END IF; + + PROC1(XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTI1 (2)"); + END IF; + + IF XTA1 /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (2)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (2)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XTP1 (2)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.TWO)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (2)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM " & + "XTT1.VALU (2)"); + END IF; + + CHK_TASK.ENTRY1 + (XTI1, XTA1, XTR1, XTP1, XTV1, XTT1); + + IF XTI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTI1 (3)"); + END IF; + + IF XTA1 /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (3)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (3)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XTP1 (3)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.THREE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (3)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (3)"); + END IF; + + XTI1 := XTI1 + 1; + XTA1 := (XTA1(1)+1, XTA1(2)+1, XTA1(3)+1); + XTR1 := (D => 1, FIELD1 => XTR1.FIELD1 + 1); + XTP1 := NEW INTEGER'(XTP1.ALL + 1); + XTV1 := PACK1.NEXT(XTV1); + XTT1.NEXT; + + IF XTI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTI1 (4)"); + END IF; + + IF XTA1 /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (4)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (4)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XTP1 (4)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FOUR)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (4)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (4)"); + END IF; + + TI1 := TI1 + 1; + TA1 := (TA1(1)+1, TA1(2)+1, TA1(3)+1); + TR1 := (D => 1, FIELD1 => TR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + + IF XTI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTI1 (5)"); + END IF; + + IF XTA1 /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XTA1 (5)"); + END IF; + + IF XTR1 /= (D => 1, FIELD1 => IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XTR1 (5)"); + END IF; + + IF XTP1 /= IDENT(TP1) OR + XTP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XTP1 (5)"); + END IF; + + IF PACK1."/=" (XTV1, PACK1.IDENT(PACK1.FIVE)) + THEN + FAILED ("INCORRECT VALUE OF XTV1 (5)"); + END IF; + + XTT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XTT1.VALU (5)"); + END IF; + END; + END START; + END MAIN_TASK; + + BEGIN + MAIN_TASK.START (DI1, DA1, DR1, DP1, DV1, DT1); + END; + + DT1.STOP; + + RESULT; + END C85005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,378 ---- + -- C85005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE CREATED BY A GENERIC 'IN OUT' FORMAL + -- PARAMETER CAN BE RENAMED AND HAS THE CORRECT VALUE, AND + -- THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT AND + -- PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' + -- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, + -- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, + -- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005D IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + DI1 : INTEGER := 0; + DA1 : ARRAY1(1..3) := (OTHERS => 0); + DR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + DP1 : POINTER1 := NEW INTEGER'(0); + DV1 : PACK1.PRIVY := PACK1.ZERO; + DT1 : TASK1; + + I : INTEGER; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + XGI1 : INTEGER RENAMES GI1; + XGA1 : ARRAY1 RENAMES GA1; + XGR1 : RECORD1 RENAMES GR1; + XGP1 : POINTER1 RENAMES GP1; + XGV1 : PACK1.PRIVY RENAMES GV1; + XGT1 : TASK1 RENAMES GT1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1); + END TASK2; + + G_CHK_TASK : TASK2; + + GENERIC + GGI1 : IN OUT INTEGER; + GGA1 : IN OUT ARRAY1; + GGR1 : IN OUT RECORD1; + GGP1 : IN OUT POINTER1; + GGV1 : IN OUT PACK1.PRIVY; + GGT1 : IN OUT TASK1; + PACKAGE GENERIC2 IS + END GENERIC2; + + PACKAGE BODY GENERIC2 IS + BEGIN + GGI1 := GGI1 + 1; + GGA1 := (GGA1(1)+1, GGA1(2)+1, GGA1(3)+1); + GGR1 := (D => 1, FIELD1 => GGR1.FIELD1 + 1); + GGP1 := NEW INTEGER'(GGP1.ALL + 1); + GGV1 := PACK1.NEXT(GGV1); + GGT1.NEXT; + END GENERIC2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1) + DO + TI1 := GI1 + 1; + TA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + TR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1) IS + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(GP1.ALL + 1); + PV1 := PACK1.NEXT(GV1); + PT1.NEXT; + END PROC1; + + PACKAGE GENPACK2 IS NEW GENERIC2 + (XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + BEGIN + IF XGI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XGI1 (1)"); + END IF; + + IF XGA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (1)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (1)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XGP1 (1)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (1)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (1)"); + END IF; + + PROC1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + IF XGI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XGI1 (2)"); + END IF; + + IF XGA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (2)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (2)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XGP1 (2)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (2)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (2)"); + END IF; + + G_CHK_TASK.ENTRY1(XGI1, XGA1, XGR1, XGP1, XGV1, XGT1); + + IF XGI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XGI1 (3)"); + END IF; + + IF XGA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (3)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (3)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XGP1 (3)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (3)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (3)"); + END IF; + + XGI1 := XGI1 + 1; + XGA1 := (XGA1(1)+1, XGA1(2)+1, XGA1(3)+1); + XGR1 := (D => 1, FIELD1 => XGR1.FIELD1 + 1); + XGP1 := NEW INTEGER'(XGP1.ALL + 1); + XGV1 := PACK1.NEXT(XGV1); + XGT1.NEXT; + + IF XGI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XGI1 (4)"); + END IF; + + IF XGA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (4)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (4)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XGP1 (4)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (4)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (4)"); + END IF; + + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + + IF XGI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XGI1 (5)"); + END IF; + + IF XGA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XGA1 (5)"); + END IF; + + IF XGR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XGR1 (5)"); + END IF; + + IF XGP1 /= IDENT(GP1) OR XGP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XGP1 (5)"); + END IF; + + IF PACK1."/=" (XGV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XGV1 (5)"); + END IF; + + XGT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XGT1.VALU (5)"); + END IF; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85005D", "CHECK THAT A VARIABLE CREATED BY A GENERIC " & + "'IN OUT' FORMAL PARAMETER CAN BE RENAMED " & + "AND HAS THE CORRECT VALUE, AND THAT THE NEW " & + "NAME CAN BE USED IN AN ASSIGNMENT STATEMENT " & + "AND PASSED ON AS AN ACTUAL SUBPROGRAM OR " & + "ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN " & + "ACTUAL GENERIC 'IN OUT' PARAMETER, AND THAT " & + "WHEN THE VALUE OF THE RENAMED VARIABLE IS " & + "CHANGED, THE NEW VALUE IS REFLECTED BY THE " & + "VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (DI1, DA1, DR1, DP1, DV1, DT1); + BEGIN + NULL; + END; + + DT1.STOP; + + RESULT; + END C85005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,397 ---- + -- C85005E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR CAN BE RENAMED AND + -- HAS THE CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN + -- ASSIGNMENT STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR + -- ENTRY 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC + -- 'IN OUT' PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED + -- VARIABLE IS CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF + -- THE NEW NAME. + + -- HISTORY: + -- JET 03/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005E IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PACKACC IS ACCESS INTEGER; + AK1 : PACKACC := NEW INTEGER'(0); + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + GENERIC + GI1 : IN OUT INTEGER; + GA1 : IN OUT ARRAY1; + GR1 : IN OUT RECORD1; + GP1 : IN OUT POINTER1; + GV1 : IN OUT PACK1.PRIVY; + GT1 : IN OUT TASK1; + GK1 : IN OUT INTEGER; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GI1 := GI1 + 1; + GA1 := (GA1(1)+1, GA1(2)+1, GA1(3)+1); + GR1 := (D => 1, FIELD1 => GR1.FIELD1 + 1); + GP1 := NEW INTEGER'(GP1.ALL + 1); + GV1 := PACK1.NEXT(GV1); + GT1.NEXT; + GK1 := GK1 + 1; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85005E", "CHECK THAT A VARIABLE CREATED BY AN ALLOCATOR " & + "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " & + "THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT" & + " STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE " & + "IS REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TYPE ACCINT IS ACCESS INTEGER; + TYPE ACCARR IS ACCESS ARRAY1; + TYPE ACCREC IS ACCESS RECORD1; + TYPE ACCPTR IS ACCESS POINTER1; + TYPE ACCPVT IS ACCESS PACK1.PRIVY; + TYPE ACCTSK IS ACCESS TASK1; + + AI1 : ACCINT := NEW INTEGER'(0); + AA1 : ACCARR := NEW ARRAY1'(0, 0, 0); + AR1 : ACCREC := NEW RECORD1'(D => 1, FIELD1 => 0); + AP1 : ACCPTR := NEW POINTER1'(NEW INTEGER'(0)); + AV1 : ACCPVT := NEW PACK1.PRIVY'(PACK1.ZERO); + AT1 : ACCTSK := NEW TASK1; + + XAI1 : INTEGER RENAMES AI1.ALL; + XAA1 : ARRAY1 RENAMES AA1.ALL; + XAR1 : RECORD1 RENAMES AR1.ALL; + XAP1 : POINTER1 RENAMES AP1.ALL; + XAV1 : PACK1.PRIVY RENAMES AV1.ALL; + XAK1 : INTEGER RENAMES PACK1.AK1.ALL; + XAT1 : TASK1 RENAMES AT1.ALL; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; TK1 : IN OUT INTEGER); + END TASK2; + + I : INTEGER; + A_CHK_TASK : TASK2; + + PROCEDURE PROC1 (PI1 : IN OUT INTEGER; PA1 : IN OUT ARRAY1; + PR1 : IN OUT RECORD1; PP1 : OUT POINTER1; + PV1 : OUT PACK1.PRIVY; PT1 : IN OUT TASK1; + PK1 : OUT INTEGER) IS + + BEGIN + PI1 := PI1 + 1; + PA1 := (PA1(1)+1, PA1(2)+1, PA1(3)+1); + PR1 := (D => 1, FIELD1 => PR1.FIELD1 + 1); + PP1 := NEW INTEGER'(AP1.ALL.ALL + 1); + PV1 := PACK1.NEXT(AV1.ALL); + PT1.NEXT; + PK1 := PACK1.AK1.ALL + 1; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TI1 : OUT INTEGER; TA1 : OUT ARRAY1; + TR1 : OUT RECORD1; TP1 : IN OUT POINTER1; + TV1 : IN OUT PACK1.PRIVY; + TT1 : IN OUT TASK1; + TK1 : IN OUT INTEGER) DO + TI1 := AI1.ALL + 1; + TA1 := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + TR1 := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + TP1 := NEW INTEGER'(TP1.ALL + 1); + TV1 := PACK1.NEXT(TV1); + TT1.NEXT; + TK1 := TK1 + 1; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC1 (XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + BEGIN + IF XAI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1 (1)"); + END IF; + + IF XAA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (1)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (1)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1 (1)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (1)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (1)"); + END IF; + + IF XAK1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAK1 (1)"); + END IF; + + PROC1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1 (2)"); + END IF; + + IF XAA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (2)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (2)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1 (2)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (2)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (2)"); + END IF; + + IF XAK1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAK1 (2)"); + END IF; + + A_CHK_TASK.ENTRY1(XAI1, XAA1, XAR1, XAP1, XAV1, XAT1, XAK1); + + IF XAI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1 (3)"); + END IF; + + IF XAA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (3)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (3)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1 (3)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (3)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (3)"); + END IF; + + IF XAK1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAK1 (3)"); + END IF; + + XAI1 := XAI1 + 1; + XAA1 := (XAA1(1)+1, XAA1(2)+1, XAA1(3)+1); + XAR1 := (D => 1, FIELD1 => XAR1.FIELD1 + 1); + XAP1 := NEW INTEGER'(XAP1.ALL + 1); + XAV1 := PACK1.NEXT(XAV1); + XAT1.NEXT; + XAK1 := XAK1 + 1; + + IF XAI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1 (4)"); + END IF; + + IF XAA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (4)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (4)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1 (4)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (4)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (4)"); + END IF; + + IF XAK1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAK1 (4)"); + END IF; + + AI1.ALL := AI1.ALL + 1; + AA1.ALL := (AA1.ALL(1)+1, AA1.ALL(2)+1, AA1.ALL(3)+1); + AR1.ALL := (D => 1, FIELD1 => AR1.ALL.FIELD1 + 1); + AP1.ALL := NEW INTEGER'(AP1.ALL.ALL + 1); + AV1.ALL := PACK1.NEXT(AV1.ALL); + AT1.NEXT; + PACK1.AK1.ALL := PACK1.AK1.ALL + 1; + + IF XAI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1 (5)"); + END IF; + + IF XAA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1 (5)"); + END IF; + + IF XAR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1 (5)"); + END IF; + + IF XAP1 /= IDENT(AP1.ALL) OR XAP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1 (5)"); + END IF; + + IF PACK1."/=" (XAV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1 (5)"); + END IF; + + XAT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XAT1.VALU (5)"); + END IF; + + IF XAK1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAK1 (5)"); + END IF; + + AT1.STOP; + END; + + RESULT; + END C85005E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C85005F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR A RENAMED VARIABLE DESIGNATED BY AN ACCESS VALUE, + -- A CHANGE IN THE ACCESS VALUE DOES NOT AFFECT WHICH VARIABLE IS + -- DENOTED BY THE NEW NAME. + + -- HISTORY: + -- JET 07/26/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85005F IS + TYPE ACC IS ACCESS INTEGER; + + BUMP : INTEGER := 0; + + A : ACC := NULL; + + FUNCTION GET_POINTER RETURN ACC IS + BEGIN + BUMP := IDENT_INT(BUMP) + 1; + RETURN NEW INTEGER'(BUMP); + END GET_POINTER; + + BEGIN + TEST ("C85005F", "CHECK THAT, FOR A RENAMED VARIABLE DESIGNATED " & + "BY AN ACCESS VALUE, A CHANGE IN THE ACCESS " & + "VALUE DOES NOT AFFECT WHICH VARIABLE IS " & + "DENOTED BY THE NEW NAME"); + + A := GET_POINTER; + + DECLARE + X1 : INTEGER RENAMES A.ALL; + X2 : INTEGER RENAMES GET_POINTER.ALL; + BEGIN + A := GET_POINTER; + + IF X1 /= 1 THEN + FAILED("CHANGING ACCESS VALUE CHANGED RENAMED VARIABLE"); + END IF; + + IF X2 /= 2 THEN + FAILED("INCORRECT RESULT FROM FUNCTION AS PREFIX"); + END IF; + END; + + RESULT; + END C85005F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85005g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85005g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C85005G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED + -- IN THE RENAMING DECLARATION IS IGNORED, AND THE SUBTYPE + -- CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS USED INSTEAD. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- JET 07/26/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C85005G IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + I : INTEGER := IDENT_INT(INTEGER'LAST); + J : INT := IDENT_INT(INT'LAST); + + DG1 : INTEGER := IDENT_INT(INTEGER'LAST); + DG2 : INT := IDENT_INT(INT'LAST); + + XI : INT RENAMES I; + XJ : INTEGER RENAMES J; + + GENERIC + G1 : IN OUT INT; + G2 : IN OUT INTEGER; + PROCEDURE GEN; + + PROCEDURE GEN IS + XG1 : INT RENAMES G1; + XG2 : INTEGER RENAMES G2; + BEGIN + IF XG1 /= INTEGER'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G1"); + END IF; + + XG1 := IDENT_INT(INTEGER'FIRST); + + IF XG1 /= INTEGER'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G2"); + END IF; + + IF XG2 /= INT'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G3"); + END IF; + + XG2 := IDENT_INT(INT'FIRST); + + IF XG2 /= INT'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - G4"); + END IF; + + BEGIN + XG2 := IDENT_INT(INTEGER'LAST); + FAILED ("NO EXCEPTION RAISED BY XG2 := INTEGER'LAST"); + IF NOT EQUAL(XG2,XG2) THEN + COMMENT ("DON'T OPTIMIZE XG2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION (G)"); + END; + END GEN; + + PROCEDURE PROC IS NEW GEN(DG1, DG2); + + BEGIN + TEST ("C85005G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " & + "THE TYPE MARK USED IN THE RENAMING " & + "DECLARATION IS IGNORED, AND THE SUBTYPE " & + "CONSTRAINT ASSOCIATED WITH THE RENAMED " & + "VARIABLE IS USED INSTEAD"); + + IF XI /= INTEGER'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 1"); + END IF; + + XI := IDENT_INT(INTEGER'FIRST); + + IF XI /= INTEGER'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 2"); + END IF; + + IF XJ /= INT'LAST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 3"); + END IF; + + XJ := IDENT_INT(INT'FIRST); + + IF XJ /= INT'FIRST THEN + FAILED("INCORRECT VALUE OF RENAMING VARIABLE - 4"); + END IF; + + BEGIN + XJ := IDENT_INT(INTEGER'LAST); + FAILED ("NO EXCEPTION RAISED BY XJ := INTEGER'LAST"); + IF NOT EQUAL(XJ,XJ) THEN + COMMENT ("DON'T OPTIMIZE XJ"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 1"); + END; + + PROC; + + RESULT; + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION - 2"); + RESULT; + END C85005G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,681 ---- + -- C85006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN + -- OBJECT DECLARATION CAN BE RENAMED AND HAS THE CORRECT VALUE, + -- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT + -- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' + -- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, + -- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, + -- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006A IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK); + END TASK2; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + REC : REC_TYPE; + + AI1 : ARR_INT(1..8) := (OTHERS => 0); + AA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + AR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + AP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + AV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + AT1 : ARR_TSK(1..8); + + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + I : INTEGER; + CHK_TASK : TASK2; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, + FIELD1 => (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + BEGIN + TEST ("C85006A", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN OBJECT DECLARATION CAN BE " & + "RENAMED AND HAS THE CORRECT VALUE, AND THAT " & + "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " & + "STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK1 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + BEGIN + NULL; + END; + + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(2) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(3) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(4) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR XAP1(J).ALL /= IDENT_INT(5) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & INTEGER'IMAGE(J) & + ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + REC.RT1.STOP; + + FOR I IN AT1'RANGE LOOP + AT1(I).STOP; + END LOOP; + + RESULT; + END C85006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,699 ---- + -- C85006B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A COMPONENT OR SLICE OF A VARIABLE CREATED BY A + -- SUBPROGRAM 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE + -- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT + -- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' + -- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, + -- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, + -- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006B IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + PROCEDURE PROC (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK) IS + + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + I : INTEGER; + CHK_TASK : TASK2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => NEW INTEGER'(AP1(PAP1'FIRST).ALL+1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE GENPACK1 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + END PROC; + + BEGIN + TEST ("C85006B", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY A SUBPROGRAM 'IN OUT' FORMAL " & + "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " & + "VALUE, AND THAT THE NEW NAME CAN BE USED IN " & + "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " & + "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + PROC (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; + END C85006B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,778 ---- + -- C85006C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN ENTRY + -- 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE CORRECT + -- VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT + -- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY + -- 'IN OUT' OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' + -- PARAMETER, AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS + -- CHANGED, THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006C IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + I : INTEGER; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85006C", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN ENTRY 'IN OUT' FORMAL PARAMETER " & + "CAN BE RENAMED AND HAS THE CORRECT VALUE, AND " & + "THAT THE NEW NAME CAN BE USED IN AN ASSIGN" & + "MENT STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TASK MAIN_TASK IS + ENTRY START (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK); + END MAIN_TASK; + + TASK BODY MAIN_TASK IS + BEGIN + ACCEPT START (REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; AT1 : IN OUT ARR_TSK) + DO + DECLARE + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; + TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; + TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; + TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + CHK_TASK : TASK2; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; + TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; + TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; + TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, + REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; + PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; + PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; + PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; + PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; + PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; + PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => + PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1+1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + PACKAGE GENPACK2 IS NEW GENERIC1 + (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1), + IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & INTEGER'IMAGE(J) & + ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM " & + "XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2), + IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & INTEGER'IMAGE(J) & + ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1 + (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3), + IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, + FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => + (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, FIELD1 => + (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => + NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4), + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => + IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, + REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => + REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1(XAI1'RANGE) := (OTHERS => + AI1(XAI1'FIRST) + 1); + AA1(XAA1'RANGE) := (OTHERS => + (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1(XAR1'RANGE) := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1(XAP1'RANGE) := (OTHERS => + NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR + XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) + THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF " & + "XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5), + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => + IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), + PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE " & + "FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + END; + END START; + END MAIN_TASK; + + BEGIN + MAIN_TASK.START (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + END; + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; + END C85006C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,712 ---- + -- C85006D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A COMPONENT OR SLICE OF A VARIABLE CREATED BY A + -- GENERIC 'IN OUT' FORMAL PARAMETER CAN BE RENAMED AND HAS THE + -- CORRECT VALUE, AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT + -- STATEMENT AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' + -- OR 'OUT' PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, + -- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, + -- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006D IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + DREC : REC_TYPE; + + DAI1 : ARR_INT(1..8) := (OTHERS => 0); + DAA1 : ARR_ARR(1..8) := (OTHERS => (OTHERS => 0)); + DAR1 : ARR_REC(1..8) := (OTHERS => (D => 1, FIELD1 => 0)); + DAP1 : ARR_PTR(1..8) := (OTHERS => NEW INTEGER'(0)); + DAV1 : ARR_PVT(1..8) := (OTHERS => PACK1.ZERO); + DAT1 : ARR_TSK(1..8); + + GENERIC + REC : IN OUT REC_TYPE; + AI1 : IN OUT ARR_INT; + AA1 : IN OUT ARR_ARR; + AR1 : IN OUT ARR_REC; + AP1 : IN OUT ARR_PTR; + AV1 : IN OUT ARR_PVT; + AT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + XRI1 : INTEGER RENAMES REC.RI1; + XRA1 : ARRAY1 RENAMES REC.RA1; + XRR1 : RECORD1 RENAMES REC.RR1; + XRP1 : POINTER1 RENAMES REC.RP1; + XRV1 : PACK1.PRIVY RENAMES REC.RV1; + XRT1 : TASK1 RENAMES REC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + CHK_TASK : TASK2; + I : INTEGER; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC2 IS + END GENERIC2; + + PACKAGE BODY GENERIC2 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => + NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(REC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(REC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := REC.RI1 + 1; + TRA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL + 1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC2 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) + THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + REC.RI1 := REC.RI1 + 1; + REC.RA1 := (REC.RA1(1)+1, REC.RA1(2)+1, REC.RA1(3)+1); + REC.RR1 := (D => 1, FIELD1 => REC.RR1.FIELD1 + 1); + REC.RP1 := NEW INTEGER'(REC.RP1.ALL + 1); + REC.RV1 := PACK1.NEXT(REC.RV1); + REC.RT1.NEXT; + AI1 := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1 := (OTHERS => (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1 := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1 := (OTHERS => NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(REC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85006D", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY A GENERIC 'IN OUT' FORMAL " & + "PARAMETER CAN BE RENAMED AND HAS THE CORRECT " & + "VALUE, AND THAT THE NEW NAME CAN BE USED IN " & + "AN ASSIGNMENT STATEMENT AND PASSED ON AS AN " & + "ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + PACKAGE GENPACK IS NEW + GENERIC1 (DREC, DAI1, DAA1, DAR1, DAP1, DAV1, DAT1); + BEGIN + NULL; + END; + + DREC.RT1.STOP; + + FOR I IN DAT1'RANGE LOOP + DAT1(I).STOP; + END LOOP; + + RESULT; + END C85006D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,702 ---- + -- C85006E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A COMPONENT OR SLICE OF A VARIABLE CREATED BY AN + -- ALLOCATOR CAN BE RENAMED AND HAS THE CORRECT VALUE, + -- AND THAT THE NEW NAME CAN BE USED IN AN ASSIGNMENT STATEMENT + -- AND PASSED ON AS AN ACTUAL SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' + -- PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' PARAMETER, + -- AND THAT WHEN THE VALUE OF THE RENAMED VARIABLE IS CHANGED, + -- THE NEW VALUE IS REFLECTED BY THE VALUE OF THE NEW NAME. + + -- HISTORY: + -- JET 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006E IS + + TYPE ARRAY1 IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + TYPE RECORD1 (D : INTEGER) IS + RECORD + FIELD1 : INTEGER := 1; + END RECORD; + TYPE POINTER1 IS ACCESS INTEGER; + + PACKAGE PACK1 IS + TYPE PRIVY IS PRIVATE; + ZERO : CONSTANT PRIVY; + ONE : CONSTANT PRIVY; + TWO : CONSTANT PRIVY; + THREE : CONSTANT PRIVY; + FOUR : CONSTANT PRIVY; + FIVE : CONSTANT PRIVY; + FUNCTION IDENT (I : PRIVY) RETURN PRIVY; + FUNCTION NEXT (I : PRIVY) RETURN PRIVY; + PRIVATE + TYPE PRIVY IS RANGE 0..127; + ZERO : CONSTANT PRIVY := 0; + ONE : CONSTANT PRIVY := 1; + TWO : CONSTANT PRIVY := 2; + THREE : CONSTANT PRIVY := 3; + FOUR : CONSTANT PRIVY := 4; + FIVE : CONSTANT PRIVY := 5; + END PACK1; + + TASK TYPE TASK1 IS + ENTRY ASSIGN (J : IN INTEGER); + ENTRY VALU (J : OUT INTEGER); + ENTRY NEXT; + ENTRY STOP; + END TASK1; + + TYPE ARR_INT IS ARRAY(POSITIVE RANGE <>) OF INTEGER; + TYPE ARR_ARR IS ARRAY(POSITIVE RANGE <>) OF ARRAY1(1..3); + TYPE ARR_REC IS ARRAY(POSITIVE RANGE <>) OF RECORD1(1); + TYPE ARR_PTR IS ARRAY(POSITIVE RANGE <>) OF POINTER1; + TYPE ARR_PVT IS ARRAY(POSITIVE RANGE <>) OF PACK1.PRIVY; + TYPE ARR_TSK IS ARRAY(POSITIVE RANGE <>) OF TASK1; + + TYPE REC_TYPE IS RECORD + RI1 : INTEGER := 0; + RA1 : ARRAY1(1..3) := (OTHERS => 0); + RR1 : RECORD1(1) := (D => 1, FIELD1 => 0); + RP1 : POINTER1 := NEW INTEGER'(0); + RV1 : PACK1.PRIVY := PACK1.ZERO; + RT1 : TASK1; + END RECORD; + + GENERIC + GRI1 : IN OUT INTEGER; + GRA1 : IN OUT ARRAY1; + GRR1 : IN OUT RECORD1; + GRP1 : IN OUT POINTER1; + GRV1 : IN OUT PACK1.PRIVY; + GRT1 : IN OUT TASK1; + GAI1 : IN OUT ARR_INT; + GAA1 : IN OUT ARR_ARR; + GAR1 : IN OUT ARR_REC; + GAP1 : IN OUT ARR_PTR; + GAV1 : IN OUT ARR_PVT; + GAT1 : IN OUT ARR_TSK; + PACKAGE GENERIC1 IS + END GENERIC1; + + FUNCTION IDENT (P : POINTER1) RETURN POINTER1 IS + BEGIN + IF EQUAL (3,3) THEN + RETURN P; + ELSE + RETURN NULL; + END IF; + END IDENT; + + PACKAGE BODY PACK1 IS + FUNCTION IDENT (I : PRIVY) RETURN PRIVY IS + BEGIN + IF EQUAL(3,3) THEN + RETURN I; + ELSE + RETURN PRIVY'(0); + END IF; + END IDENT; + + FUNCTION NEXT (I : PRIVY) RETURN PRIVY IS + BEGIN + RETURN I+1; + END NEXT; + END PACK1; + + PACKAGE BODY GENERIC1 IS + BEGIN + GRI1 := GRI1 + 1; + GRA1 := (GRA1(1)+1, GRA1(2)+1, GRA1(3)+1); + GRR1 := (D => 1, FIELD1 => GRR1.FIELD1+1); + GRP1 := NEW INTEGER'(GRP1.ALL + 1); + GRV1 := PACK1.NEXT(GRV1); + GRT1.NEXT; + GAI1 := (OTHERS => GAI1(GAI1'FIRST) + 1); + GAA1 := (OTHERS => (OTHERS => GAA1(GAA1'FIRST)(1) + 1)); + GAR1 := (OTHERS => (D => 1, + FIELD1 => (GAR1(GAR1'FIRST).FIELD1 + 1))); + GAP1 := (OTHERS => NEW INTEGER'(GAP1(GAP1'FIRST).ALL + 1)); + FOR J IN GAV1'RANGE LOOP + GAV1(J) := PACK1.NEXT(GAV1(J)); + END LOOP; + FOR J IN GAT1'RANGE LOOP + GAT1(J).NEXT; + END LOOP; + END GENERIC1; + + TASK BODY TASK1 IS + TASK_VALUE : INTEGER := 0; + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ASSIGN (J : IN INTEGER) DO + TASK_VALUE := J; + END ASSIGN; + OR + ACCEPT VALU (J : OUT INTEGER) DO + J := TASK_VALUE; + END VALU; + OR + ACCEPT NEXT DO + TASK_VALUE := TASK_VALUE + 1; + END NEXT; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END TASK1; + + BEGIN + TEST ("C85006E", "CHECK THAT A COMPONENT OR SLICE OF A VARIABLE " & + "CREATED BY AN ALLOCATOR CAN BE " & + "RENAMED AND HAS THE CORRECT VALUE, AND THAT " & + "THE NEW NAME CAN BE USED IN AN ASSIGNMENT " & + "STATEMENT AND PASSED ON AS AN ACTUAL " & + "SUBPROGRAM OR ENTRY 'IN OUT' OR 'OUT' " & + "PARAMETER, AND AS AN ACTUAL GENERIC 'IN OUT' " & + "PARAMETER, AND THAT WHEN THE VALUE OF THE " & + "RENAMED VARIABLE IS CHANGED, THE NEW VALUE IS " & + "REFLECTED BY THE VALUE OF THE NEW NAME"); + + DECLARE + TYPE AREC_TYPE IS ACCESS REC_TYPE; + AREC : AREC_TYPE := NEW REC_TYPE; + + TYPE ACC_INT IS ACCESS ARR_INT; + TYPE ACC_ARR IS ACCESS ARR_ARR; + TYPE ACC_REC IS ACCESS ARR_REC; + TYPE ACC_PTR IS ACCESS ARR_PTR; + TYPE ACC_PVT IS ACCESS ARR_PVT; + TYPE ACC_TSK IS ACCESS ARR_TSK; + + AI1 : ACC_INT := NEW ARR_INT'(1..8 => 0); + AA1 : ACC_ARR := NEW ARR_ARR'(1..8 => (OTHERS => 0)); + AR1 : ACC_REC := NEW ARR_REC'(1..8 => (D => 1, FIELD1 => 0)); + AP1 : ACC_PTR := NEW ARR_PTR'(1..8 => NEW INTEGER'(0)); + AV1 : ACC_PVT := NEW ARR_PVT'(1..8 => PACK1.ZERO); + AT1 : ACC_TSK := NEW ARR_TSK(1..8); + + XRI1 : INTEGER RENAMES AREC.RI1; + XRA1 : ARRAY1 RENAMES AREC.RA1; + XRR1 : RECORD1 RENAMES AREC.RR1; + XRP1 : POINTER1 RENAMES AREC.RP1; + XRV1 : PACK1.PRIVY RENAMES AREC.RV1; + XRT1 : TASK1 RENAMES AREC.RT1; + XAI1 : ARR_INT RENAMES AI1(1..3); + XAA1 : ARR_ARR RENAMES AA1(2..4); + XAR1 : ARR_REC RENAMES AR1(3..5); + XAP1 : ARR_PTR RENAMES AP1(4..6); + XAV1 : ARR_PVT RENAMES AV1(5..7); + XAT1 : ARR_TSK RENAMES AT1(6..8); + + TASK TYPE TASK2 IS + ENTRY ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1 : IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK); + END TASK2; + + I : INTEGER; + CHK_TASK : TASK2; + + PROCEDURE PROC1 (PRI1 : IN OUT INTEGER; PRA1 : IN OUT ARRAY1; + PRR1 : IN OUT RECORD1; PRP1 : OUT POINTER1; + PRV1 : OUT PACK1.PRIVY; PRT1 : IN OUT TASK1; + PAI1 : IN OUT ARR_INT; PAA1 : IN OUT ARR_ARR; + PAR1 : IN OUT ARR_REC; PAP1 : OUT ARR_PTR; + PAV1 : OUT ARR_PVT; PAT1 : IN OUT ARR_TSK) IS + BEGIN + PRI1 := PRI1 + 1; + PRA1 := (PRA1(1)+1, PRA1(2)+1, PRA1(3)+1); + PRR1 := (D => 1, FIELD1 => PRR1.FIELD1 + 1); + PRP1 := NEW INTEGER'(AREC.RP1.ALL + 1); + PRV1 := PACK1.NEXT(AREC.RV1); + PRT1.NEXT; + PAI1 := (OTHERS => PAI1(PAI1'FIRST) + 1); + PAA1 := (OTHERS => (OTHERS => PAA1(PAA1'FIRST)(1) + 1)); + PAR1 := (OTHERS => (D => 1, FIELD1 => + (PAR1(PAR1'FIRST).FIELD1 + 1))); + PAP1 := (OTHERS => + NEW INTEGER'(AP1(PAP1'FIRST).ALL + 1)); + FOR J IN PAV1'RANGE LOOP + PAV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN PAT1'RANGE LOOP + PAT1(J).NEXT; + END LOOP; + END PROC1; + + TASK BODY TASK2 IS + BEGIN + ACCEPT ENTRY1 (TRI1 : OUT INTEGER; TRA1 : OUT ARRAY1; + TRR1 : OUT RECORD1; + TRP1 : IN OUT POINTER1; + TRV1 : IN OUT PACK1.PRIVY; + TRT1: IN OUT TASK1; + TAI1 : OUT ARR_INT; TAA1 : OUT ARR_ARR; + TAR1 : OUT ARR_REC; TAP1 : IN OUT ARR_PTR; + TAV1 : IN OUT ARR_PVT; + TAT1 : IN OUT ARR_TSK) + DO + TRI1 := AREC.RI1 + 1; + TRA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1, + AREC.RA1(3)+1); + TRR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1); + TRP1 := NEW INTEGER'(TRP1.ALL + 1); + TRV1 := PACK1.NEXT(TRV1); + TRT1.NEXT; + TAI1 := (OTHERS => AI1(TAI1'FIRST) + 1); + TAA1 := (OTHERS => (OTHERS => + AA1(TAA1'FIRST)(1) + 1)); + TAR1 := (OTHERS => (D => 1, FIELD1 => + (AR1(TAR1'FIRST).FIELD1 + 1))); + TAP1 := (OTHERS => + NEW INTEGER'(TAP1(TAP1'FIRST).ALL+1)); + FOR J IN TAV1'RANGE LOOP + TAV1(J) := PACK1.NEXT(TAV1(J)); + END LOOP; + FOR J IN TAT1'RANGE LOOP + TAT1(J).NEXT; + END LOOP; + END ENTRY1; + END TASK2; + + PACKAGE GENPACK2 IS NEW + GENERIC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + BEGIN + IF XRI1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRI1 (1)"); + END IF; + + IF XRA1 /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (1)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (1)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XRP1 (1)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (1)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (1)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(1),IDENT_INT(1),IDENT_INT(1)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(1)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(1) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.ONE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (1)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(1) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (1)"); + END IF; + END LOOP; + + PROC1 (XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRI1 (2)"); + END IF; + + IF XRA1 /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (2)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (2)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XRP1 (2)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (2)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XRT1.VALU (2)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(2),IDENT_INT(2),IDENT_INT(2)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(2)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(2) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.TWO)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (2)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(2) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (2)"); + END IF; + END LOOP; + + CHK_TASK.ENTRY1(XRI1, XRA1, XRR1, XRP1, XRV1, XRT1, + XAI1, XAA1, XAR1, XAP1, XAV1, XAT1); + + IF XRI1 /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRI1 (3)"); + END IF; + + IF XRA1 /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (3)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (3)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XRP1 (3)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (3)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (3)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(3),IDENT_INT(3),IDENT_INT(3)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(3)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(3) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.THREE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (3)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (3)"); + END IF; + END LOOP; + + XRI1 := XRI1 + 1; + XRA1 := (XRA1(1)+1, XRA1(2)+1, XRA1(3)+1); + XRR1 := (D => 1, FIELD1 => XRR1.FIELD1 + 1); + XRP1 := NEW INTEGER'(XRP1.ALL + 1); + XRV1 := PACK1.NEXT(XRV1); + XRT1.NEXT; + XAI1 := (OTHERS => XAI1(XAI1'FIRST) + 1); + XAA1 := (OTHERS => (OTHERS => XAA1(XAA1'FIRST)(1) + 1)); + XAR1 := (OTHERS => (D => 1, + FIELD1 => (XAR1(XAR1'FIRST).FIELD1 + 1))); + XAP1 := (OTHERS => NEW INTEGER'(XAP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + XAV1(J) := PACK1.NEXT(XAV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + XAT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRI1 (4)"); + END IF; + + IF XRA1 /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (4)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (4)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XRP1 (4)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (4)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (4)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(4),IDENT_INT(4),IDENT_INT(4)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(4)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(4) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FOUR)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (4)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (4)"); + END IF; + END LOOP; + + AREC.RI1 := AREC.RI1 + 1; + AREC.RA1 := (AREC.RA1(1)+1, AREC.RA1(2)+1, AREC.RA1(3)+1); + AREC.RR1 := (D => 1, FIELD1 => AREC.RR1.FIELD1 + 1); + AREC.RP1 := NEW INTEGER'(AREC.RP1.ALL + 1); + AREC.RV1 := PACK1.NEXT(AREC.RV1); + AREC.RT1.NEXT; + AI1(XAI1'RANGE) := (OTHERS => AI1(XAI1'FIRST) + 1); + AA1(XAA1'RANGE) := (OTHERS => + (OTHERS => AA1(XAA1'FIRST)(1) + 1)); + AR1(XAR1'RANGE) := (OTHERS => (D => 1, + FIELD1 => (AR1(XAR1'FIRST).FIELD1 + 1))); + AP1(XAP1'RANGE) := (OTHERS => + NEW INTEGER'(AP1(XAP1'FIRST).ALL + 1)); + FOR J IN XAV1'RANGE LOOP + AV1(J) := PACK1.NEXT(AV1(J)); + END LOOP; + FOR J IN XAT1'RANGE LOOP + AT1(J).NEXT; + END LOOP; + + IF XRI1 /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRI1 (5)"); + END IF; + + IF XRA1 /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRA1 (5)"); + END IF; + + IF XRR1 /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XRR1 (5)"); + END IF; + + IF XRP1 /= IDENT(AREC.RP1) OR XRP1.ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XRP1 (5)"); + END IF; + + IF PACK1."/=" (XRV1, PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XRV1 (5)"); + END IF; + + XRT1.VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE OF XRT1.VALU (5)"); + END IF; + + FOR J IN XAI1'RANGE LOOP + IF XAI1(J) /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAI1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAA1'RANGE LOOP + IF XAA1(J) /= (IDENT_INT(5),IDENT_INT(5),IDENT_INT(5)) + THEN + FAILED ("INCORRECT VALUE OF XAA1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAR1'RANGE LOOP + IF XAR1(J) /= (D => 1, FIELD1 => IDENT_INT(5)) THEN + FAILED ("INCORRECT VALUE OF XAR1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAP1'RANGE LOOP + IF XAP1(J) /= IDENT(AP1(J)) OR + XAP1(J).ALL /= IDENT_INT(5) THEN + FAILED ("INCORRECT VALUE OF XAP1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAV1'RANGE LOOP + IF PACK1."/=" (XAV1(J), PACK1.IDENT(PACK1.FIVE)) THEN + FAILED ("INCORRECT VALUE OF XAV1(" & + INTEGER'IMAGE(J) & ") (5)"); + END IF; + END LOOP; + + FOR J IN XAT1'RANGE LOOP + XAT1(J).VALU(I); + IF I /= IDENT_INT(5) THEN + FAILED ("INCORRECT RETURN VALUE FROM XAT1(" & + INTEGER'IMAGE(J) & ").VALU (5)"); + END IF; + END LOOP; + + AREC.RT1.STOP; + + FOR I IN AT1'RANGE LOOP + AT1(I).STOP; + END LOOP; + END; + + RESULT; + END C85006E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006f.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C85006F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RENAMED SLICE CAN BE SLICED AND INDEXED FOR PURPOSES + -- OF ASSIGNMENT AND TO READ THE VALUE. + + -- HISTORY: + -- JET 07/26/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006F IS + + S : STRING(1..30) := "IT WAS A DARK AND STORMY NIGHT"; + + ADJECTIVES : STRING RENAMES S(10..24); + + BEGIN + TEST ("C85006F", "CHECK THAT A RENAMED SLICE CAN BE SLICED AND " & + "INDEXED FOR PURPOSES OF ASSIGNMENT AND TO " & + "READ THE VALUE"); + + ADJECTIVES(19..24) := "STARRY"; + + IF ADJECTIVES /= IDENT_STR("DARK AND STARRY") THEN + FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (1)"); + END IF; + + IF S /= IDENT_STR("IT WAS A DARK AND STARRY NIGHT") THEN + FAILED ("INCORRECT VALUE OF ORIGINAL STRING (1)"); + END IF; + + ADJECTIVES(17) := '''; + + IF ADJECTIVES /= IDENT_STR("DARK AN' STARRY") THEN + FAILED ("INCORRECT VALUE OF SLICE AFTER ASSIGNMENT (2)"); + END IF; + + IF S /= IDENT_STR("IT WAS A DARK AN' STARRY NIGHT") THEN + FAILED ("INCORRECT VALUE OF ORIGINAL STRING (2)"); + END IF; + + IF ADJECTIVES(10..13) /= IDENT_STR("DARK") THEN + FAILED ("INCORRECT VALUE OF SLICE WHEN READING"); + END IF; + + RESULT; + + END C85006F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85006g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85006g.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C85006G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY THE TYPE MARK USED + -- IN THE SLICE RENAMING DECLARATION IS IGNORED, AND THAT THE + -- SUBTYPE CONSTRAINT ASSOCIATED WITH THE RENAMED VARIABLE IS + -- USED INSTEAD. + + -- HISTORY: + -- JET 07/26/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85006G IS + + SUBTYPE STR IS STRING(1..10); + + S : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT"); + T : STR := IDENT_STR("0123456789"); + + DG1 : STRING(1..30) := IDENT_STR("IT WAS A DARK AND STORMY NIGHT"); + DG2 : STR := IDENT_STR("0123456789"); + + XS : STR RENAMES S(10..24); + XT : STRING RENAMES T(1..5); + + GENERIC + G1 : IN OUT STR; + G2 : IN OUT STRING; + PACKAGE GEN IS + XG1 : STR RENAMES G1(10..24); + XG2 : STRING RENAMES G2(1..5); + END GEN; + + PACKAGE PACK IS NEW GEN(DG1, DG2); + USE PACK; + + BEGIN + TEST ("C85006G", "CHECK THAT ANY SUBTYPE CONSTRAINT IMPOSED BY " & + "THE TYPE MARK USED IN THE SLICE RENAMING " & + "DECLARATION IS IGNORED, AND THAT THE SUBTYPE " & + "CONSTRAINT ASSOCIATED WITH THE RENAMED " & + "VARIABLE IS USED INSTEAD"); + + IF XS'FIRST /= IDENT_INT(10) OR + XS'LAST /= IDENT_INT(24) OR + XS'LENGTH /= IDENT_INT(15) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 1"); + END IF; + + IF XS /= "DARK AND STORMY" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - 1"); + END IF; + + XS := IDENT_STR("STORMY AND DARK"); + + IF S /= "IT WAS A STORMY AND DARK NIGHT" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - 1"); + END IF; + + IF XT'FIRST /= IDENT_INT(1) OR + XT'LAST /= IDENT_INT(5) OR + XT'LENGTH /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - 2"); + END IF; + + IF XT /= "01234" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - 2"); + END IF; + + XT := IDENT_STR("43210"); + + IF T /= "4321056789" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - 2"); + END IF; + + IF XG1'FIRST /= IDENT_INT(10) OR + XG1'LAST /= IDENT_INT(24) OR + XG1'LENGTH /= IDENT_INT(15) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G1"); + END IF; + + IF XG1 /= "DARK AND STORMY" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - G1"); + END IF; + + XG1 := IDENT_STR("STORMY AND DARK"); + + IF DG1 /= "IT WAS A STORMY AND DARK NIGHT" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - G1"); + END IF; + + IF XG2'FIRST /= IDENT_INT(1) OR + XG2'LAST /= IDENT_INT(5) OR + XG2'LENGTH /= IDENT_INT(5) THEN + FAILED("INCORRECT VALUE OF SLICE ATTRIBUTES - G2"); + END IF; + + IF XG2 /= "01234" THEN + FAILED("INCORRECT VALUE OF RENAMING SLICE - G2"); + END IF; + + XG2 := IDENT_STR("43210"); + + IF DG2 /= "4321056789" THEN + FAILED("INCORRECT VALUE OF ORIGINAL STRING - G2"); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + END C85006G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85007a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- C85007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE DISCRIMINANTS OF A RENAMED OUT FORMAL PARAMETER, AS + -- WELL AS THE DISCRIMINANTS OF THE RENAMED SUBCOMPONENTS OF AN OUT + -- FORMAL PARAMETER, MAY BE READ INSIDE THE PROCEDURE. + + -- SPS 02/17/84 (SEE C62006A-B.ADA) + -- EG 02/21/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C85007A IS + + BEGIN + + TEST ("C85007A", "CHECK THAT THE DISCRIMINANTS OF A RENAMED OUT " & + "FORMAL PARAMETER CAN BE READ INSIDE THE PROCEDURE"); + + DECLARE + + TYPE R1 (D1 : INTEGER) IS RECORD + NULL; + END RECORD; + + TYPE R2 (D2 : POSITIVE) IS RECORD + C : R1 (2); + END RECORD; + + SUBTYPE R1_2 IS R1(2); + + R : R2 (5); + + PROCEDURE PROC (REC : OUT R2) IS + + REC1 : R2 RENAMES REC; + REC2 : R1_2 RENAMES REC.C; + REC3 : R2 RENAMES REC1; + REC4 : R1_2 RENAMES REC1.C; + REC5 : R1_2 RENAMES REC4; + + BEGIN + + IF REC1.D2 /= 5 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" & + " A RENAMED OUT PARAMETER"); + END IF; + + IF REC1.C.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF THE SUBCOMPONENT OF A RENAMED OUT " & + "PARAMETER"); + END IF; + + IF REC2.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAMED SUBCOMPONENT OF AN OUT " & + "PARAMETER"); + END IF; + + IF REC3.D2 /= 5 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT OF" & + " A RENAME OF A RENAMED OUT PARAMETER"); + END IF; + + IF REC3.C.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF THE SUBCOMPONENT OF A RENAME OF A " & + "RENAMED OUT PARAMETER"); + END IF; + + IF REC4.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAMED SUBCOMPONENT OF A RENAMED" & + " OUT PARAMETER"); + END IF; + + IF REC5.D1 /= 2 THEN + FAILED ("UNABLE TO CORRECTLY READ DISCRIMINANT " & + "OF A RENAME OF RENAMED SUBCOMPONENT OF" & + " A RENAMED OUT PARAMETER"); + END IF; + + END PROC; + + BEGIN + + PROC (R); + + END; + + RESULT; + + END C85007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85007e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85007e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85007e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85007e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C85007E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENAMED OUT PARAMETER, OUT PARAMETER COMPONENT, OR + -- OUT PARAMETER SLICE CAN BE ASSIGNED TO. + + -- EG 02/22/84 + + WITH REPORT; + + PROCEDURE C85007E IS + + USE REPORT; + + BEGIN + + TEST("C85007E","CHECK THAT A RENAMED OUT PARAMETER, PARAMETER " & + "COMPONENT, OR PARAMETER SLICE CAN BE ASSIGNED TO"); + + DECLARE + + TYPE AT1 IS ARRAY(1 .. 3) OF INTEGER; + TYPE RT (A : INTEGER) IS + RECORD + B : AT1; + C : INTEGER; + END RECORD; + + A1, B1 : INTEGER; + A2, B2 : AT1; + A3, B3 : RT(1); + + PROCEDURE PROC1 (A : OUT INTEGER; + B : OUT AT1; + C : OUT RT) IS + + AA : INTEGER RENAMES A; + BB : AT1 RENAMES B; + CC : RT RENAMES C; + + BEGIN + + AA := -1; + BB := (1 .. 3 => -2); + CC := (1, (2, 3, 4), 5); + + END PROC1; + + PROCEDURE PROC2 (X : OUT AT1; + Y : OUT INTEGER; + Z : OUT RT) IS + + XX : AT1 RENAMES X; + YY : INTEGER RENAMES Y; + ZZ : RT RENAMES Z; + + BEGIN + + PROC1 (YY, XX, ZZ); + + END PROC2; + + BEGIN + + PROC1 (A1, A2, A3); + IF A1 /= IDENT_INT(-1) OR A2 /= (1 .. 3 => IDENT_INT(-2)) OR + A3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN + FAILED ("CASE 1 : ERROR IN ASSIGNMENT"); + END IF; + + PROC2 (B2, B1, B3); + IF B1 /= IDENT_INT(-1) OR B2 /= (1 .. 3 => IDENT_INT(-2)) OR + B3 /= (1, (2, 3, 4), IDENT_INT(5)) THEN + FAILED ("CASE 2 : ERROR IN ASSIGNMENT"); + END IF; + + END; + + RESULT; + + END C85007E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85009a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C85009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PREDEFINED AND USER-DEFINED EXCEPTIONS CAN BE RENAMED + -- AND THAT HANDLERS REFERRING TO EITHER NAME ARE INVOKED WHEN THE + -- EXCEPTION IS RAISED, EVEN BY AN EXPLICIT 'RAISE' STATEMENT + -- REFERRING TO THE OTHER NAME. + + -- HISTORY: + -- JET 03/24/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85009A IS + + MY_EXCEPTION : EXCEPTION; + + MY_EXCEPTION2 : EXCEPTION RENAMES MY_EXCEPTION; + + CONSTRAINT_ERROR2 : EXCEPTION RENAMES CONSTRAINT_ERROR; + + I : INTEGER := 1; + + BEGIN + TEST ("C85009A", "CHECK THAT PREDEFINED AND USER-DEFINED " & + "EXCEPTIONS CAN BE RENAMED AND THAT HANDLERS " & + "REFERRING TO EITHER NAME ARE INVOKED WHEN " & + "THE EXCEPTION IS RAISED, EVEN BY AN EXPLICIT " & + "'RAISE' STATEMENT REFERRING TO THE OTHER NAME"); + + BEGIN + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION"); + END; + + BEGIN + RAISE MY_EXCEPTION2; + FAILED ("MY_EXCEPTION2 NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY MY_EXCEPTION2"); + END; + + DECLARE + TYPE COLORS IS (RED, BLUE, YELLOW); + E : COLORS := RED; + BEGIN + E := COLORS'PRED(E); + IF NOT EQUAL(COLORS'POS(E),COLORS'POS(E)) THEN + COMMENT("DON'T OPTIMIZE E"); + END IF; + FAILED ("CONSTRAINT_ERROR NOT RAISED BY PRED(RED)"); + EXCEPTION + WHEN CONSTRAINT_ERROR2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY PRED(RED)"); + END; + + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR2 => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR"); + END; + + BEGIN + RAISE CONSTRAINT_ERROR2; + FAILED ("CONSTRAINT_ERROR2 NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CONSTRAINT_ERROR2"); + END; + + RESULT; + END C85009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85011a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- C85011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PACKAGE CAN BE RENAMED AND THE NEW NAME CAN APPEAR + -- IN A RENAMING DECLARATION, AND THAT A 'USE' CLAUSE CAN REFER TO + -- THE PACKAGE BY EITHER NAME, INCLUDING RENAMINGS OF GENERIC AND + -- NONGENERIC PACKAGES INSIDE THEMSELVES. + + -- HISTORY: + -- JET 04/28/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85011A IS + + PACKAGE PACK1 IS + I : NATURAL := 0; + PACKAGE PACKA RENAMES PACK1; + END PACK1; + + GENERIC + TYPE T IS RANGE <>; + PACKAGE GPACK IS + J : T := T'FIRST; + PACKAGE PACKB RENAMES GPACK; + END GPACK; + + PACKAGE PACK2 IS NEW GPACK(NATURAL); + + PACKAGE PACK3 RENAMES PACK1; + PACKAGE PACK4 RENAMES PACK2; + PACKAGE PACK5 RENAMES PACK3; + PACKAGE PACK6 RENAMES PACK4; + + BEGIN + TEST ("C85011A", "CHECK THAT A PACKAGE CAN BE RENAMED AND THE " & + "NEW NAME CAN APPEAR IN A RENAMING " & + "DECLARATION, AND THAT A 'USE' CLAUSE CAN " & + "REFER TO THE PACKAGE BY EITHER NAME, " & + "INCLUDING RENAMINGS OF GENERIC AND NONGENERIC " & + "PACKAGES INSIDE THEMSELVES"); + + IF PACK1.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK1.I"); + END IF; + + IF PACK2.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK2.J"); + END IF; + + IF PACK3.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK3.I"); + END IF; + + IF PACK4.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK4.J"); + END IF; + + IF PACK5.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK5.I"); + END IF; + + IF PACK6.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK6.J"); + END IF; + + IF PACK1.PACKA.I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK1.PACKA.I"); + END IF; + + IF PACK2.PACKB.J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF PACK2.PACKB.J"); + END IF; + + DECLARE + USE PACK1, PACK2; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (1)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (1)"); + END IF; + END; + + DECLARE + USE PACK3, PACK4; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (2)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (2)"); + END IF; + END; + + DECLARE + USE PACK5, PACK6; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (3)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (3)"); + END IF; + END; + + DECLARE + USE PACK1.PACKA, PACK2.PACKB; + BEGIN + IF I /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I (4)"); + END IF; + + IF J /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF J (4)"); + END IF; + END; + + RESULT; + END C85011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85013a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85013a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85013a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85013a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- C85013A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT: + + -- A) A SUBPROGRAM OR ENTRY CAN BE RENAMED WITH: + -- A1) DIFFERENT PARAMETER NAMES; + -- A2) DIFFERENT DEFAULT VALUES; + -- A3) DIFFERENT PARAMETERS HAVING DEFAULT VALUES; + -- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME + -- IS USED IN A CALL. + + -- B) FORMAL PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN + -- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY. + + -- EG 02/22/84 + + WITH REPORT; + + PROCEDURE C85013A IS + + USE REPORT; + + BEGIN + + TEST("C85013A","CHECK THAT A SUBPROGRAM CAN BE RENAMED AND " & + "THAT THE NEW NAMES/DEFAULTS ARE USED WITH " & + "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED" & + " ENTITY"); + + DECLARE + + TYPE TA IS ARRAY(1 .. 5) OF INTEGER; + + FUNCTION PROC1 (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) RETURN INTEGER; + FUNCTION PROCA (C : INTEGER := 1; + D : TA := (1 .. 5 => 1)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCB (B : INTEGER := 1; + A : TA := (1 .. 5 => 1)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCC (A : INTEGER := 2; + B : TA := (1, 2, 3, 4, 5)) RETURN INTEGER + RENAMES PROC1; + FUNCTION PROCD (C : INTEGER := 2; + D : TA := (1, 2, 3, 4, 5))RETURN INTEGER + RENAMES PROC1; + + FUNCTION PROC1 (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) RETURN INTEGER IS + BEGIN + FOR I IN 1 .. 5 LOOP + IF A = B(I) THEN + RETURN I; + END IF; + END LOOP; + RETURN 0; + END PROC1; + + BEGIN + + IF PROC1 /= 1 THEN + FAILED ("CASE A : PARAMETERS NOT PROPERLY INITIALIZED"); + END IF; + IF PROC1(A => 2) /= 0 THEN + FAILED ("CASE A : INCORRECT RESULT"); + END IF; + IF PROCA /= 1 THEN + FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCA(D => (5, 4, 3, 2, 1)) /= 5 THEN + FAILED ("CASE A1 : INCORRECT RESULT"); + END IF; + IF PROCB /= 1 THEN + FAILED ("CASE A1 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCB(A => (5, 4, 3, 2, 1), B => 2) /= 4 THEN + FAILED ("CASE A1 : INCORRECT RESULT "); + END IF; + IF PROCC /= 2 THEN + FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCC(3) /= 3 THEN + FAILED ("CASE A2 : INCORRECT RESULT "); + END IF; + IF PROCD /= 2 THEN + FAILED ("CASE A2 : INCORRECT RESULT (DEFAULT)"); + END IF; + IF PROCD(4) /= 4 THEN + FAILED ("CASE A2 : INCORRECT RESULT "); + END IF; + + END; + + DECLARE + + TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE STA1 IS TA(1 .. 5); + SUBTYPE STA2 IS TA(11 .. 15); + + PROCEDURE PROC1 (A : STA1; + ID : STRING); + PROCEDURE PROC2 (A : STA2; + ID : STRING) RENAMES PROC1; + + PROCEDURE PROC1 (A : STA1; + ID : STRING) IS + BEGIN + IF A'FIRST /= IDENT_INT(1) THEN + FAILED ("CASE B : INCORRECT LOWER BOUND " & + "GENERATED BY " & ID); + END IF; + IF A'LAST /= IDENT_INT(5) THEN + FAILED ("CASE B : INCORRECT UPPER BOUND " & + "GENERATED BY " & ID); + END IF; + END PROC1; + + BEGIN + + PROC1 ((1, 2, 3, 4, 5),"PROC1"); + PROC2 ((6, 7, 8, 9, 10),"PROC2"); + + END; + + RESULT; + + END C85013A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C85014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NUMBER OF FORMAL PARAMETERS IS USED TO DETERMINE + -- WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED. + + -- HISTORY: + -- JET 03/24/88 CREATED ORIGINAL TEST. + -- BCB 04/18/90 CORRECTED ERROR MESSAGE FOR ENTRY2. + + WITH REPORT; USE REPORT; + PROCEDURE C85014A IS + + TASK TYPE T1 IS + ENTRY ENTER (I1: IN OUT INTEGER); + ENTRY STOP; + END T1; + + TASK TYPE T2 IS + ENTRY ENTER (I1, I2: IN OUT INTEGER); + ENTRY STOP; + END T2; + + TASK1 : T1; + TASK2 : T2; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN TASK1; + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN TASK2; + END F; + + PROCEDURE PROC (I1: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 1; + END PROC; + + PROCEDURE PROC (I1, I2: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 2; + I2 := I2 + 2; + END PROC; + + TASK BODY T1 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INTEGER) DO + I1 := I1 + 1; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1, I2 : IN OUT INTEGER) DO + I1 := I1 + 2; + I2 := I2 + 2; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T2; + + BEGIN + TEST ("C85014A", "CHECK THAT THE NUMBER OF FORMAL PARAMETERS IS " & + "USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY " & + "IS BEING RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC; + PROCEDURE PROC2 (J1, J2: IN OUT INTEGER) RENAMES PROC; + + PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER; + PROCEDURE ENTRY2 (J1, J2: IN OUT INTEGER) RENAMES F.ENTER; + + K1, K2 : INTEGER := 0; + BEGIN + PROC1(K1); + IF K1 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC1"); + END IF; + + ENTRY1(K2); + IF K2 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY1"); + END IF; + + PROC2(K1, K2); + IF K1 /= IDENT_INT(3) OR K2 /= IDENT_INT(3) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC2"); + END IF; + + ENTRY2(K1, K2); + IF K1 /= IDENT_INT(5) OR K2 /= IDENT_INT(5) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY2"); + END IF; + END; + + TASK1.STOP; + TASK2.STOP; + + RESULT; + END C85014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- C85014B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE BASE TYPE OF THE FORMAL PARAMETER AND THE RESULT + -- TYPE ARE USED TO DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING + -- RENAMED. + + -- HISTORY: + -- JET 03/24/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85014B IS + + TYPE INT IS NEW INTEGER; + SUBTYPE SUBINT0 IS INT RANGE 0..INT'LAST; + SUBTYPE SUBINT1 IS INT RANGE 1..INT'LAST; + + TASK TYPE T1 IS + ENTRY ENTER (I1: IN OUT INTEGER); + ENTRY STOP; + END T1; + + TASK TYPE T2 IS + ENTRY ENTER (I1: IN OUT INT); + ENTRY STOP; + END T2; + + TASK1 : T1; + TASK2 : T2; + + FUNCTION F RETURN T1 IS + BEGIN + RETURN TASK1; + END F; + + FUNCTION F RETURN T2 IS + BEGIN + RETURN TASK2; + END F; + + PROCEDURE PROC (I1: IN OUT INTEGER) IS + BEGIN + I1 := I1 + 1; + END PROC; + + PROCEDURE PROC (I1: IN OUT INT) IS + BEGIN + I1 := I1 + 2; + END PROC; + + FUNCTION FUNK (I1: INTEGER) RETURN INTEGER IS + BEGIN + RETURN I1 + 1; + END FUNK; + + FUNCTION FUNK (I1: INTEGER) RETURN INT IS + BEGIN + RETURN INT(I1) + 2; + END FUNK; + + FUNCTION FUNKX (N : NATURAL) RETURN POSITIVE IS + BEGIN + RETURN N + 1; + END FUNKX; + + FUNCTION FUNKX (N : SUBINT0) RETURN SUBINT1 IS + BEGIN + RETURN N + 2; + END FUNKX; + + TASK BODY T1 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INTEGER) DO + I1 := I1 + 1; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + ACCEPTING_ENTRIES : BOOLEAN := TRUE; + BEGIN + WHILE ACCEPTING_ENTRIES LOOP + SELECT + ACCEPT ENTER (I1 : IN OUT INT) DO + I1 := I1 + 2; + END ENTER; + OR + ACCEPT STOP DO + ACCEPTING_ENTRIES := FALSE; + END STOP; + END SELECT; + END LOOP; + END T2; + + BEGIN + TEST ("C85014B", "CHECK THAT THE BASE TYPE OF THE FORMAL " & + "PARAMETER AND THE RESULT TYPE ARE USED TO " & + "DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING " & + "RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: IN OUT INTEGER) RENAMES PROC; + PROCEDURE PROC2 (J1: IN OUT INT) RENAMES PROC; + + FUNCTION FUNK1 (J1: INTEGER) RETURN INTEGER RENAMES FUNK; + FUNCTION FUNK2 (J1: INTEGER) RETURN INT RENAMES FUNK; + + PROCEDURE ENTRY1 (J1: IN OUT INTEGER) RENAMES F.ENTER; + PROCEDURE ENTRY2 (J1: IN OUT INT) RENAMES F.ENTER; + + FUNCTION FUNK3 (J1: POSITIVE) RETURN NATURAL RENAMES FUNKX; + FUNCTION FUNK4 (J1: SUBINT1) RETURN SUBINT0 RENAMES FUNKX; + + K1 : INTEGER := 0; + K2 : INT := 0; + BEGIN + PROC1(K1); + IF K1 /= IDENT_INT(1) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC1"); + END IF; + + K1 := FUNK1(K1); + IF K1 /= IDENT_INT(2) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK1"); + END IF; + + ENTRY1(K1); + IF K1 /= IDENT_INT(3) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY1"); + END IF; + + K1 := FUNK3(K1); + IF K1 /= IDENT_INT(4) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK3"); + END IF; + + PROC2(K2); + IF INTEGER(K2) /= IDENT_INT(2) THEN + FAILED("INCORRECT RETURN VALUE FROM PROC2"); + END IF; + + K2 := FUNK2(INTEGER(K2)); + IF INTEGER(K2) /= IDENT_INT(4) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK2"); + END IF; + + ENTRY2(K2); + IF INTEGER(K2) /= IDENT_INT(6) THEN + FAILED("INCORRECT RETURN VALUE FROM ENTRY2"); + END IF; + + K2 := FUNK4(K2); + IF INTEGER(K2) /= IDENT_INT(8) THEN + FAILED("INCORRECT RETURN VALUE FROM FUNK4"); + END IF; + END; + + TASK1.STOP; + TASK2.STOP; + + RESULT; + END C85014B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85014c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85014c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C85014C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PRESENCE OR ABSENCE OF A RESULT TYPE IS USED TO + -- DETERMINE WHICH SUBPROGRAM OR ENTRY IS BEING RENAMED. + + -- HISTORY: + -- JET 03/24/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85014C IS + + I, J : INTEGER; + + TASK TYPE T IS + ENTRY Q (I1 : INTEGER); + END T; + + TASK0 : T; + + PACKAGE FUNC IS + FUNCTION Q (I1 : INTEGER) RETURN INTEGER; + FUNCTION FUNC RETURN T; + END FUNC; + USE FUNC; + + PROCEDURE PROC (I1: INTEGER) IS + BEGIN + I := I1; + END PROC; + + FUNCTION PROC (I1: INTEGER) RETURN INTEGER IS + BEGIN + I := I1 + 1; + RETURN 0; + END PROC; + + TASK BODY T IS + BEGIN + ACCEPT Q (I1 : INTEGER) DO + I := I1; + END Q; + END T; + + PACKAGE BODY FUNC IS + FUNCTION Q (I1 : INTEGER) RETURN INTEGER IS + BEGIN + I := I1 + 1; + RETURN 0; + END Q; + + FUNCTION FUNC RETURN T IS + BEGIN + RETURN TASK0; + END FUNC; + END FUNC; + + BEGIN + TEST ("C85014C", "CHECK THAT THE PRESENCE OR ABSENCE OF A " & + "RESULT TYPE IS USED TO DETERMINE WHICH " & + "SUBPROGRAM OR ENTRY IS BEING RENAMED"); + + DECLARE + PROCEDURE PROC1 (J1: INTEGER) RENAMES PROC; + + FUNCTION PROC2 (J1: INTEGER) RETURN INTEGER RENAMES PROC; + BEGIN + PROC1(1); + IF I /= IDENT_INT(1) THEN + FAILED("INCORRECT VALUE OF I AFTER PROC1"); + END IF; + + J := PROC2(1); + IF I /= IDENT_INT(2) THEN + FAILED("INCORRECT VALUE OF I AFTER PROC2"); + END IF; + END; + + DECLARE + PROCEDURE FUNC1 (J1 : INTEGER) RENAMES FUNC.FUNC.Q; + + FUNCTION FUNC2 (J1 : INTEGER) RETURN INTEGER RENAMES FUNC.Q; + BEGIN + FUNC1(1); + IF I /= IDENT_INT(1) THEN + FAILED("INCORRECT VALUE OF I AFTER FUNC1"); + END IF; + + J := FUNC2(1); + IF I /= IDENT_INT(2) THEN + FAILED("INCORRECT VALUE OF I AFTER FUNC2"); + END IF; + END; + + RESULT; + END C85014C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85017a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85017a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85017a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85017a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- C85017A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT RENAMING A PREDEFINED OPERATION WITH AN IDENTIFIER + -- AND THEN RENAMING THE IDENTIFIER AS AN OPERATOR SYMBOL ALLOWS THE + -- NEW NAME TO BE USED IN A STATIC EXPRESSION. + + -- HISTORY: + -- JET 03/24/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C85017A IS + + FUNCTION PLUS (L,R : INTEGER) RETURN INTEGER RENAMES "+"; + FUNCTION MINUS (L,R : INTEGER) RETURN INTEGER RENAMES "-"; + + FUNCTION "-" (L,R : INTEGER) RETURN INTEGER RENAMES PLUS; + FUNCTION "+" (L,R : INTEGER) RETURN INTEGER RENAMES MINUS; + + I1 : CONSTANT INTEGER := 10 + 10; + I2 : CONSTANT INTEGER := 10 - 10; + + TYPE INT IS RANGE I1 .. I2; + BEGIN + TEST("C85017A","CHECK THAT RENAMING A PREDEFINED OPERATION WITH " & + "AN IDENTIFIER AND THEN RENAMING THE IDENTIFIER " & + "AS AN OPERATOR SYMBOL ALLOWS THE NEW NAME TO BE " & + "USED IN A STATIC EXPRESSION"); + + IF I1 /= IDENT_INT(0) THEN + FAILED ("INCORRECT VALUE OF I1: " & INTEGER'IMAGE(I1)); + END IF; + + IF I2 /= IDENT_INT(20) THEN + FAILED ("INCORRECT VALUE OF I2: " & INTEGER'IMAGE(I2)); + END IF; + + RESULT; + END C85017A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85018a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85018a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85018a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85018a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- C85018A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ENTRY FAMILY MEMBER CAN BE RENAMED WITH: + -- 1) DIFFERENT PARAMETER NAMES; + -- 2) DIFFERENT DEFAULT VALUES; + -- AND THAT THE NEW NAMES/DEFAULTS ARE USED WHEN THE NEW NAME + -- IS USED IN A CALL. + + -- RJW 6/3/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C85018A IS + + BEGIN + + TEST( "C85018A", "CHECK THAT AN ENTRY FAMILY MEMBER CAN BE " & + "RENAMED AND THAT THE NEW NAMES/DEFAULTS ARE " & + "THOSE ASSOCIATED WITH THE RENAMED ENTITY" ); + + DECLARE + + RESULTS : INTEGER; + + TYPE TA IS ARRAY(1 .. 5) OF INTEGER; + + TASK T IS + ENTRY ENT1 (BOOLEAN) + (A : INTEGER := 1; B : TA := (1 .. 5 => 1)); + END T; + + PROCEDURE ENTA (C : INTEGER := 1; D : TA := (1 .. 5 => 1)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTB (B : INTEGER := 1; A : TA := (1 .. 5 => 1)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTC (A : INTEGER := 2; B : TA := (1, 2, 3, 4, 5)) + RENAMES T.ENT1 (TRUE); + + PROCEDURE ENTD (C : INTEGER := 2; D : TA := (1, 2, 3, 4, 5)) + RENAMES T.ENT1 (TRUE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (IDENT_BOOL (TRUE)) + (A : INTEGER := 1; + B : TA := (1 .. 5 => 1)) DO + IF A IN 1 .. 5 THEN + RESULTS := B(A); + ELSE + RESULTS := 0; + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + + T.ENT1 (TRUE); + IF RESULTS /= 1 THEN + FAILED ( "PARAMETERS NOT PROPERLY INITIALIZED" ); + END IF; + + T.ENT1 (TRUE) (A => 6); + IF RESULTS /= 0 THEN + FAILED ( "INCORRECT RESULTS" ); + END IF; + + ENTA; + IF RESULTS /= 1 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTA(D => (5, 4, 3, 2, 1)); + IF RESULTS /= 5 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS" ); + END IF; + + ENTB; + IF RESULTS /= 1 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTB(A => (5, 4, 3, 2, 1), B => 2); + IF RESULTS /= 4 THEN + FAILED ( "CASE 1 : INCORRECT RESULTS " ); + END IF; + + ENTC; + IF RESULTS /= 2 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTC(3); + IF RESULTS /= 3 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS " ); + END IF; + + ENTD; + IF RESULTS /= 2 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS (DEFAULT)" ); + END IF; + + ENTD(4); + IF RESULTS /= 4 THEN + FAILED ( "CASE 2 : INCORRECT RESULTS " ); + END IF; + + END; + RESULT; + + END C85018A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85018b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85018b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85018b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85018b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,288 ---- + -- C85018B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS RENAMED THE FORMAL + -- PARAMETER CONSTRAINTS FOR THE NEW NAME ARE IGNORED IN + -- FAVOR OF THE CONSTRAINTS ASSOCIATED WITH THE RENAMED ENTITY. + + -- HISTORY: + -- RJW 06/03/86 CREATED ORIGINAL TEST. + -- DHH 10/15/87 CORRECTED RANGE ERRORS. + -- GJD 11/15/95 REMOVED ADA 95 INCOMPATIBILITY (INDEX CONSTRAINT). + -- PWN 10/24/96 RESTORED CHECKS WITH ADA 95 RESULTS NOW EXPECTED. + -- PWN 12/11/96 ADJUSTED VALUES FOR ADA 95 COMPATIBILITY. + -- PWB.CTA 2/17/97 CHANGED CALL TO ENT2 TO NOT EXPECT EXCEPTION + + WITH REPORT; USE REPORT; + + PROCEDURE C85018B IS + + BEGIN + + TEST( "C85018B", "CHECK THAT WHEN AN ENTRY FAMILY MEMBER IS " & + "RENAMED THE FORMAL PARAMETER CONSTRAINTS " & + "FOR THE NEW NAME ARE IGNORED IN FAVOR OF " & + "THE CONSTRAINTS ASSOCIATED WITH THE RENAMED " & + "ENTITY" ); + + DECLARE + TYPE INT IS RANGE 1 .. 10; + SUBTYPE INT1 IS INT RANGE 1 .. 5; + SUBTYPE INT2 IS INT RANGE 6 .. 10; + + OBJ1 : INT1 := 5; + OBJ2 : INT2 := 6; + + SUBTYPE SHORTCHAR IS CHARACTER RANGE 'A' .. 'C'; + + TASK T IS + ENTRY ENT1 (SHORTCHAR) + (A : INT1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : INT2; OK : BOOLEAN) + RENAMES T.ENT1 ('C'); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 ('C') + (A : INT1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH INTEGER TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "INTEGER TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "INTEGER TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "INTEGER TYPE - 2" ); + END; + END; + + DECLARE + TYPE REAL IS DIGITS 3; + SUBTYPE REAL1 IS REAL RANGE -2.0 .. 0.0; + SUBTYPE REAL2 IS REAL RANGE 0.0 .. 2.0; + + OBJ1 : REAL1 := -0.25; + OBJ2 : REAL2 := 0.25; + + SUBTYPE SHORTINT IS INTEGER RANGE 9 .. 11; + + TASK T IS + ENTRY ENT1 (SHORTINT) + (A : REAL1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : REAL2; OK : BOOLEAN) + RENAMES T.ENT1 (10); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (10) + (A : REAL1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH FLOATING POINT " & + "TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FLOATING POINT " & + "TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FLOATING POINT " & + "TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, FALSE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FLOATING POINT " & + "TYPE - 2" ); + END; + END; + + DECLARE + TYPE COLOR IS (RED, YELLOW, BLUE, GREEN); + + TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0; + SUBTYPE FIXED1 IS FIXED RANGE 0.0 .. 0.5; + SUBTYPE FIXED2 IS FIXED RANGE -0.5 .. 0.0; + + OBJ1 : FIXED1 := 0.125; + OBJ2 : FIXED2 := -0.125; + + TASK T IS + ENTRY ENT1 (COLOR) + (A : FIXED1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : FIXED2; OK : BOOLEAN) + RENAMES T.ENT1 (BLUE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (BLUE) + (A : FIXED1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH FIXED POINT " & + "TYPE" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FIXED POINT " & + "TYPE" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FIXED POINT " & + "TYPE - 1" ); + END; + + BEGIN + ENT2 (OBJ2, FALSE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "FIXED POINT " & + "TYPE - 2" ); + END; + END; + + DECLARE + TYPE TA IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE STA1 IS TA(1 .. 5); + SUBTYPE STA2 IS TA(6 .. 10); + + OBJ1 : STA1 := (1, 2, 3, 4, 5); + OBJ2 : STA2 := (6, 7, 8, 9, 10); + + TASK T IS + ENTRY ENT1 (BOOLEAN) + (A : STA1; OK : BOOLEAN); + END T; + + PROCEDURE ENT2 (A : STA2; OK : BOOLEAN) + RENAMES T.ENT1 (FALSE); + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT ENT1 (FALSE) + (A : STA1; OK : BOOLEAN) DO + IF NOT OK THEN + FAILED ( "WRONG CALL EXECUTED " & + "WITH CONSTRAINED " & + "ARRAY" ); + END IF; + END; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + BEGIN + BEGIN + ENT2 (OBJ1, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "CONSTRAINED ARRAY" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "CONSTRAINED ARRAY - 1" ); + END; + + BEGIN + ENT2 (OBJ2, TRUE); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "CONSTRAINED ARRAY" ); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED WITH " & + "CONSTRAINED ARRAY - 2" ); + END; + END; + + RESULT; + + END C85018B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85019a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85019a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c85019a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c85019a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C85019A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CHARACTER OR OTHER ENUMERATION LITERAL MAY BE RENAMED + -- AS A FUNCTION. + + -- RJW 6/4/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C85019A IS + + BEGIN + + TEST( "C85019A", "CHECK THAT A CHARACTER OR OTHER ENUMERATION " & + "LITERAL MAY BE RENAMED AS A FUNCTION" ); + + DECLARE + FUNCTION SEA RETURN CHARACTER RENAMES 'C'; + + TYPE COLOR IS (RED, YELLOW, BLUE, GREEN); + + FUNCTION TEAL RETURN COLOR RENAMES BLUE; + + BEGIN + IF SEA /= 'C' THEN + FAILED ( "SEA IS NOT EQUAL TO 'C'" ); + END IF; + + IF TEAL /= BLUE THEN + FAILED ( "TEAL IS NOT EQUAL TO BLUE" ); + END IF; + + END; + + RESULT; + + END C85019A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854001.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,277 ---- + -- C854001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a subprogram declaration can be completed by a + -- subprogram renaming declaration. In particular, check that such a + -- renaming-as-body can be given in a package body to complete a + -- subprogram declared in the package specification. Check that calls + -- to the subprogram invoke the body of the renamed subprogram. Check + -- that a renaming allows a copy of an inherited or predefined subprogram + -- before overriding it later. Check that renaming a dispatching + -- operation calls the correct body in case of overriding. + -- + -- TEST DESCRIPTION: + -- This test declares a record type, an integer type, and a tagged type + -- with a set of operations in a package. A renaming of a predefined + -- equality operation of a tagged type is also defined in this package. + -- The predefined operation is overridden in the private part. In a + -- separate package, a subtype of the record type and integer type + -- are declared. Subset of the full set of operations for the record + -- and types is reexported using renamings-as-bodies. Other operations + -- are given explicit bodies. The test verifies that the appropriate + -- body is executed for each operation on the subtype. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 07 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + package C854001_0 is + + type Component is (Op_Of_Type, Op_Of_Subtype, Initial_Value); + + type Root is record + Called : Component := Op_Of_Subtype; + end record; + + procedure Root_Proc (P: in out Root); + procedure Over_Proc (P: in out Root); + + function Root_Func return Root; + function Over_Func return Root; + + type Short_Int is range 1 .. 98; + + function "+" (P1, P2 : Short_Int) return Short_Int; + function Name (P1, P2 : Short_Int) return Short_Int; + + type Tag_Type is tagged record + C : Component := Initial_Value; + end record; + -- Inherits predefined operator "=" and others. + + function Predefined_Equal (P1, P2 : Tag_Type) return Boolean + renames "="; + -- Renames predefined operator "=" before overriding. + + private + function "=" (P1, P2 : Tag_Type) + return Boolean; -- Overrides predefined operator "=". + + + end C854001_0; + + + --==================================================================-- + + + package body C854001_0 is + + procedure Root_Proc (P: in out Root) is + begin + P.Called := Initial_Value; + end Root_Proc; + + --------------------------------------- + procedure Over_Proc (P: in out Root) is + begin + P.Called := Op_Of_Type; + end Over_Proc; + + --------------------------------------- + function Root_Func return Root is + begin + return (Called => Op_Of_Type); + end Root_Func; + + --------------------------------------- + function Over_Func return Root is + begin + return (Called => Initial_Value); + end Over_Func; + + --------------------------------------- + function "+" (P1, P2 : Short_Int) return Short_Int is + begin + return 15; + end "+"; + + --------------------------------------- + function Name (P1, P2 : Short_Int) return Short_Int is + begin + return 47; + end Name; + + --------------------------------------- + function "=" (P1, P2 : Tag_Type) return Boolean is + begin + return False; + end "="; + + end C854001_0; + + --==================================================================-- + + + with C854001_0; + package C854001_1 is + + subtype Root_Subtype is C854001_0.Root; + subtype Short_Int_Subtype is C854001_0.Short_Int; + + procedure Ren_Proc (P: in out Root_Subtype); + procedure Same_Proc (P: in out Root_Subtype); + + function Ren_Func return Root_Subtype; + function Same_Func return Root_Subtype; + + function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; + function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype; + + function User_Defined_Equal (P1, P2 : C854001_0.Tag_Type) return Boolean + renames C854001_0."="; -- Executes body of the + -- overriding declaration in + -- the private part. + end C854001_1; + + + --==================================================================-- + + + with C854001_0; + package body C854001_1 is + + -- + -- Renaming-as-body for procedure: + -- + + procedure Ren_Proc (P: in out Root_Subtype) + renames C854001_0.Root_Proc; + procedure Same_Proc (P: in out Root_Subtype) + renames C854001_0.Over_Proc; + + -- + -- Renaming-as-body for function: + -- + + function Ren_Func return Root_Subtype renames C854001_0.Root_Func; + function Same_Func return Root_Subtype renames C854001_0.Over_Func; + + function Other_Name (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype + renames C854001_0."+"; + function "-" (P1, P2 : Short_Int_Subtype) return Short_Int_Subtype + renames C854001_0.Name; + + end C854001_1; + + + --==================================================================-- + + with C854001_0; + with C854001_1; -- Subtype and associated operations. + use C854001_1; + + with Report; + + procedure C854001 is + Operand1 : Root_Subtype; + Operand2 : Root_Subtype; + Operand3 : Root_Subtype; + Operand4 : Root_Subtype; + Operand5 : Short_Int_Subtype := 55; + Operand6 : Short_Int_Subtype := 46; + Operand7 : Short_Int_Subtype; + Operand8 : C854001_0.Tag_Type; -- Both Operand8 & Operand9 have + Operand9 : C854001_0.Tag_Type; -- the same default values. + + -- Direct visibility to operator symbols + use type C854001_0.Component; + use type C854001_0.Short_Int; + + begin + Report.Test ("C854001", "Check that a renaming-as-body can be given " & + "in a package body to complete a subprogram " & + "declared in the package specification. " & + "Check that calls to the subprogram invoke " & + "the body of the renamed subprogram"); + + -- + -- Only operations of the subtype are available. + -- + + Ren_Proc (Operand1); + if Operand1.Called /= C854001_0.Initial_Value then + Report.Failed ("Error calling procedure Ren_Proc"); + end if; + + --------------------------------------- + Same_Proc (Operand2); + if Operand2.Called /= C854001_0.Op_Of_Type then + Report.Failed ("Error calling procedure Same_Proc"); + end if; + + --------------------------------------- + Operand3 := Ren_Func; + if Operand3.Called /= C854001_0.Op_Of_Type then + Report.Failed ("Error calling function Ren_Func"); + end if; + + --------------------------------------- + Operand4 := Same_Func; + if Operand4.Called /= C854001_0.Initial_Value then + Report.Failed ("Error calling function Same_Func"); + end if; + + --------------------------------------- + Operand7 := C854001_1."-" (Operand5, Operand6); + if Operand7 /= 47 then + Report.Failed ("Error calling function & ""-"""); + end if; + + --------------------------------------- + Operand7 := Other_Name (Operand5, Operand6); + if Operand7 /= 15 then + Report.Failed ("Error calling function Other_Name"); + end if; + + --------------------------------------- + -- Executes body of the overriding declaration in the private part + -- of C854001_0. + if User_Defined_Equal (Operand8, Operand9) then + Report.Failed ("Error calling function User_Defined_Equal"); + end if; + + --------------------------------------- + -- Executes predefined operation. + if not C854001_0.Predefined_Equal (Operand8, Operand9) then + Report.Failed ("Error calling function Predefined_Equal"); + end if; + + Report.Result; + + end C854001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854002.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + -- C854002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check the requirements of the new 8.5.4(8.A) from Technical + -- Corrigendum 1 (originally discussed as AI95-00064). + -- This paragraph requires an elaboration check on renamings-as-body: + -- even if the body of the ultimately-called subprogram has been + -- elaborated, the check should fail if the renaming-as-body + -- itself has not yet been elaborated. + -- + -- TEST DESCRIPTION + -- We declare two functions F and G, and ensure that they are + -- elaborated before anything else, by using pragma Pure. Then we + -- declare two renamings-as-body: the renaming of F is direct, and + -- the renaming of G is via an access-to-function object. We call + -- the renamings during elaboration, and check that they raise + -- Program_Error. We then call them again after elaboration; this + -- time, they should work. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 23 SEP 1999 RLB Improved comments, renamed, issued. + -- 28 JUN 2002 RLB Added pragma Elaborate_All for Report. + --! + + package C854002_1 is + pragma Pure; + -- Empty. + end C854002_1; + + package C854002_1.Pure is + pragma Pure; + function F return String; + function G return String; + end C854002_1.Pure; + + with C854002_1.Pure; + package C854002_1.Renamings is + + F_Result: constant String := C854002_1.Pure.F; -- Make sure we can call F. + function Renamed_F return String; + + G_Result: constant String := C854002_1.Pure.G; + type String_Function is access function return String; + G_Pointer: String_Function := null; + -- Will be set to C854002_1.Pure.G'Access in the body. + function Renamed_G return String; + + end C854002_1.Renamings; + + package C854002_1.Caller is + + -- These procedures call the renamings; when called during elaboration, + -- we pass Should_Fail => True, which checks that Program_Error is + -- raised. Later, we use Should_Fail => False. + + procedure Call_Renamed_F(Should_Fail: Boolean); + procedure Call_Renamed_G(Should_Fail: Boolean); + + end C854002_1.Caller; + + with Report; use Report; pragma Elaborate_All (Report); + with C854002_1.Renamings; + package body C854002_1.Caller is + + Some_Error: exception; + + procedure Call_Renamed_F(Should_Fail: Boolean) is + begin + if Should_Fail then + begin + Failed(C854002_1.Renamings.Renamed_F); + raise Some_Error; + -- This raise statement is necessary, because the + -- Report package has a bug -- if Failed is called + -- before Test, then the failure is ignored, and the + -- test prints "PASSED". + -- Presumably, this raise statement will cause the + -- program to crash, thus avoiding the PASSED message. + exception + when Program_Error => + Comment("Program_Error -- OK"); + end; + else + if C854002_1.Renamings.F_Result /= C854002_1.Renamings.Renamed_F then + Failed("Bad result from renamed F"); + end if; + end if; + end Call_Renamed_F; + + procedure Call_Renamed_G(Should_Fail: Boolean) is + begin + if Should_Fail then + begin + Failed(C854002_1.Renamings.Renamed_G); + raise Some_Error; + exception + when Program_Error => + Comment("Program_Error -- OK"); + end; + else + if C854002_1.Renamings.G_Result /= C854002_1.Renamings.Renamed_G then + Failed("Bad result from renamed G"); + end if; + end if; + end Call_Renamed_G; + + begin + -- At this point, the bodies of Renamed_F and Renamed_G have not yet + -- been elaborated, so calling them should raise Program_Error: + Call_Renamed_F(Should_Fail => True); + Call_Renamed_G(Should_Fail => True); + end C854002_1.Caller; + + package body C854002_1.Pure is + + function F return String is + begin + return "This is function F"; + end F; + + function G return String is + begin + return "This is function G"; + end G; + + end C854002_1.Pure; + + with C854002_1.Pure; + with C854002_1.Caller; pragma Elaborate(C854002_1.Caller); + -- This pragma ensures that this package body (Renamings) + -- will be elaborated after Caller, so that when Caller calls + -- the renamings during its elaboration, the renamings will + -- not have been elaborated (although what the rename have been). + package body C854002_1.Renamings is + + function Renamed_F return String renames C854002_1.Pure.F; + + package Dummy is end; -- So we can insert statements here. + package body Dummy is + begin + G_Pointer := C854002_1.Pure.G'Access; + end Dummy; + + function Renamed_G return String renames G_Pointer.all; + + end C854002_1.Renamings; + + with Report; use Report; + with C854002_1.Caller; + procedure C854002 is + begin + Test("C854002", + "An elaboration check is performed for a call to a subprogram" + & " whose body is given as a renaming-as-body"); + + -- By the time we get here, all library units have been elaborated, + -- so the following calls should not raise Program_Error: + C854002_1.Caller.Call_Renamed_F(Should_Fail => False); + C854002_1.Caller.Call_Renamed_G(Should_Fail => False); + + Result; + end C854002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c854003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c854003.a 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C854003.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a renaming-as-body used before the subprogram is frozen only + -- requires mode conformance. (Defect Report 8652/0028, as reflected in + -- Technical Corrigendum 1, RM95 8.5.4(5/1)). + -- + -- CHANGE HISTORY: + -- 29 JAN 2001 PHL Initial version. + -- 5 DEC 2001 RLB Reformatted for ACATS. + -- + --! + with Report; + use Report; + procedure C854003 is + + package P is + type T is private; + C1 : constant T; + C2 : constant T; + private + type T is new Integer'Base; + C1 : constant T := T (Ident_Int (1)); + C2 : constant T := T (Ident_Int (1)); + end P; + + function Equals (X, Y : P.T) return Boolean; + function Equals (X, Y : P.T) return Boolean renames P."="; + + begin + Test ("C854003", + "Check that a renaming-as-body used before the subprogram " & + "is frozen only requires mode conformance"); + + if not Equals (P.C1, P.C2) then + Failed ("Equality returned an unexpected result"); + end if; + + Result; + end C854003; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86003a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C86003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'STANDARD' IS NOT TREATED AS A RESERVED WORD IN + -- SELECTED COMPONENT NAMES. + + -- RM 01/21/80 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + + WITH REPORT ; + PROCEDURE C86003A IS + + USE REPORT ; + + BEGIN + + TEST("C86003A" , "CHECK THAT 'STANDARD' IS NOT TREATED AS A" & + " RESERVED WORD IN SELECTED COMPONENT NAMES" ); + + DECLARE -- A + BEGIN + + DECLARE + + PACKAGE STANDARD IS + CHARACTER : BOOLEAN ; + TYPE INTEGER IS (FALSE, TRUE) ; + CONSTRAINT_ERROR : EXCEPTION ; + END STANDARD ; + + TYPE REC2 IS + RECORD + AA , BB : BOOLEAN := FALSE ; + END RECORD; + + TYPE REC1 IS + RECORD + STANDARD : REC2 ; + END RECORD; + + A : REC1 ; + TYPE ASI IS ACCESS STANDARD.INTEGER ; + VASI : ASI ; + VI : INTEGER RANGE 1 .. 10; -- THE "REAL" STANDARD + -- TYPE 'INTEGER' + + BEGIN + + VASI := NEW STANDARD.INTEGER'(STANDARD.FALSE); + STANDARD.CHARACTER := A.STANDARD.BB ; + + IF STANDARD.CHARACTER THEN FAILED( "RES. (VAR.)" ); + END IF; + + VI := IDENT_INT(11); -- TO CAUSE THE "REAL" + -- (PREDEFINED) CONSTRAINT_ERROR + -- EXCEPTION. + IF VI /= IDENT_INT(11) THEN + FAILED ("WRONG VALUE - V1"); + ELSE + FAILED ("OUT OF RANGE VALUE - V1"); + END IF; + EXCEPTION + + WHEN STANDARD.CONSTRAINT_ERROR => FAILED ("RES. (EXC.)"); + + WHEN CONSTRAINT_ERROR => NULL; + + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED - A"); + + END ; + + EXCEPTION + + WHEN OTHERS => FAILED( "EXCEPTION RAISED BY DECL. (A)" ); + + END ; -- A + + + DECLARE -- B + + TYPE REC IS + RECORD + INTEGER : BOOLEAN := FALSE ; + END RECORD; + + STANDARD : REC ; + + BEGIN + + IF STANDARD.INTEGER THEN FAILED( "RESERVED - REC.,INT."); + END IF; + + END ; -- B + + + RESULT ; + + + END C86003A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C86004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A LIBRARY SUBPROGRAM DECLARATION IS PRECEDED BY A + -- "WITH" CLAUSE FOR A GENERIC LIBRARY PROCEDURE M, THEN IN THE + -- BODY OF THE SUBPROGRAM, "STANDARD.M" IS A LEGAL NAME + -- FOR THE GENERIC PROCEDURE. + + -- HISTORY: + -- DHH 03/14/88 CREATED ORIGINAL TEST. + + -- BEGIN BUILDING LIBRARY PROCEDURES + + GENERIC + TYPE ITEM IS (<>); + PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM); + + PROCEDURE C86004A_SWAP(X,Y: IN OUT ITEM) IS + T : ITEM; + BEGIN + T := X; + X := Y; + Y := T; + END C86004A_SWAP; + + WITH C86004A_SWAP; WITH REPORT; USE REPORT; + PROCEDURE C86004A1 IS + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := IDENT_INT(10); + B : INT := IDENT_INT(0); + PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT); + BEGIN + SWITCH(A,B); + + IF A /= IDENT_INT(0) THEN + FAILED("STANDARD.GENERIC PROCEDURE - 1"); + END IF; + + IF B /= IDENT_INT(10) THEN + FAILED("STANDARD.GENERIC PROCEDURE - 2"); + END IF; + END C86004A1; + + WITH C86004A_SWAP; WITH REPORT; USE REPORT; + PROCEDURE C86004A2; + + PROCEDURE C86004A2 IS + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := IDENT_INT(10); + B : INT := IDENT_INT(0); + BEGIN + DECLARE + PROCEDURE SWITCH IS NEW STANDARD.C86004A_SWAP(INT); + BEGIN + SWITCH(A,B); + END; + IF A /= IDENT_INT(0) THEN + FAILED("STANDARD.GENERIC PROCEDURE - B-0"); + END IF; + IF B /= IDENT_INT(10) THEN + FAILED("STANDARD.GENERIC PROCEDURE - B-10"); + END IF; + END C86004A2; + + WITH C86004A1; WITH C86004A2; + WITH REPORT; USE REPORT; + PROCEDURE C86004A IS + BEGIN + TEST("C86004A", "CHECK THAT IF A LIBRARY SUBPROGRAM DECLARATION " & + "IS PRECEDED BY A ""WITH"" CLAUSE FOR A GENERIC " & + "LIBRARY PROCEDURE M, THEN IN THE BODY OF THE " & + "SUBPROGRAM, ""STANDARD.M"" IS A " & + "LEGAL NAME FOR THE GENERIC PROCEDURE"); + C86004A1; + C86004A2; + + RESULT; + END C86004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + -- C86004B0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- INDEPENDENT FUNCTION AND SUBPROGRAM SPECIFICATION FOR C86004B + -- TEST. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + FUNCTION C86004B0(X : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END C86004B0; + + WITH C86004B0; + WITH REPORT; USE REPORT; -- SPEC + PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4)); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- C86004B1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- LIBRARY SUBPROGRAM BODY FOR C86004B TEST. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + PROCEDURE C86004B1(INTGR : INTEGER := STANDARD.C86004B0(4)) IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := STANDARD.C86004B0(10); + B : INT := STANDARD.C86004B0(INTGR); + + BEGIN + TEST("C86004B", "CHECK THAT IF THE SPECIFICATION OF A LIBRARY " & + "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A LIBRARY " & + "SUBPROGRAM M, THEN IN THE FORMAL PART AND IN " & + "THE BODY (IN ANOTHER FILE), ""STANDARD.M"" IS " & + "A LEGAL NAME FOR THE SUBPROGRAM M"); + + IF B /= STANDARD.C86004B0(0) THEN + FAILED("STANDARD.SUBPROGRAM - B"); + END IF; + + IF A /= STANDARD.C86004B0(10) THEN + FAILED("STANDARD.SUBPROGRAM - A"); + END IF; + + RESULT; + END C86004B1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004b2.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,46 ---- + -- C86004B2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A + -- "WITH" CLAUSE FOR A LIBRARY SUBPROGRAM M, THEN IN THE FORMAL PART + -- AND IN THE BODY (IN ANOTHER FILE), "STANDARD.M" IS A LEGAL NAME + -- FOR THE SUBPROGRAM M. + + -- SEPARATE FILES ARE: + -- C86004B0 A LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM + -- SPECIFICATION. + -- C86004B1 A LIBRARY SUBPROGRAM BODY FOR THE C86004B0 + -- SPECIFICATION. + -- C86004B2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004B1. + + -- HISTORY: + -- DHH 08/15/88 CREATED ORIGINAL TEST. + + WITH C86004B1; + WITH REPORT; USE REPORT; + PROCEDURE C86004B2M IS + BEGIN + C86004B1(IDENT_INT(0)); + END C86004B2M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c0.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C86004C0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- INDEPENDENT GENERIC FUNCTION AND SUBPROGRAM FOR C86004C TEST. + + -- HISTORY: + -- DHH 09/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + GENERIC + FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER; + + FUNCTION C86004C0_GEN(X : INTEGER) RETURN INTEGER IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + ELSE + RETURN 0; + END IF; + END C86004C0_GEN; + + WITH C86004C0_GEN; + PRAGMA ELABORATE(C86004C0_GEN); + FUNCTION C86004C0 IS NEW C86004C0_GEN; + + WITH C86004C0; + WITH REPORT; USE REPORT; + PROCEDURE C86004C01(INTGR : INTEGER := STANDARD.C86004C0(4)) IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + A : INT := STANDARD.C86004C0(10); + B : INT := STANDARD.C86004C0(INTGR); + + PROCEDURE C86004C1 IS SEPARATE; + + BEGIN + C86004C1; + END; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c1.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- C86004C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- SUBUNIT FOR THE C86004C01 PARENT. + + -- HISTORY: + -- DHH 09/14/88 CREATED ORIGINAL TEST. + + SEPARATE (C86004C01) + PROCEDURE C86004C1 IS + BEGIN + TEST("C86004C", "CHECK THAT IF THE SPECIFICATION OF A " & + "SUBPROGRAM HAS A ""WITH"" CLAUSE FOR A GENERIC " & + "SUBPROGRAM INSTANTIANTION M, THEN IN THE " & + "FORMAL PART AND IN THE BODY (A SUBUNIT IN " & + "ANOTHER FILE), ""STANDARD.M"" IS " & + "A LEGAL NAME FOR THE SUBPROGRAM M"); + + IF B /= STANDARD.C86004C0(0) THEN + FAILED("STANDARD.SUBPROGRAM - B"); + END IF; + + IF A /= STANDARD.C86004C0(10) THEN + FAILED("STANDARD.SUBPROGRAM - A"); + END IF; + + RESULT; + END C86004C1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86004c2.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + -- C86004C2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF THE SPECIFICATION OF A LIBRARY SUBPROGRAM HAS A + -- "WITH" CLAUSE FOR A GENERIC SUBPROGRAM INSTANTIATION M, THEN IN + -- THE FORMAL PART AND IN THE BODY (A SUBUNIT IN ANOTHER FILE), + -- "STANDARD.M" IS A LEGAL NAME FOR THE SUBPROGRAM M. + + -- SEPARATE FILES ARE: + -- C86004C0 A GENERIC LIBRARY FUNCTION AND A LIBRARY SUBPROGRAM + -- DECLARING A SEPARATE SUBUNIT. + -- C86004C1 A SUBUNIT FOR THE C86004C0 PARENT. + -- C86004C2M MAIN PROCEDURE USING THE SUBPROGRAM OF C86004C0. + + -- HISTORY: + -- DHH 09/14/88 CREATED ORIGINAL TEST. + + WITH C86004C01; + WITH REPORT; USE REPORT; + PROCEDURE C86004C2M IS + BEGIN + C86004C01(IDENT_INT(0)); + END C86004C2M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86006i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86006i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86006i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86006i.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C86006I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE IDENTIFIERS "BOOLEAN, TRUE, AND FALSE" AND THE + -- IDENTIFIERS "INTEGER, NATURAL, AND POSITIVE" ARE DECLARED IN + -- THE PACKAGE "STANDARD", ALONG WITH THE OPERATORS OF THE TYPE + -- BOOLEAN AND THE TYPE INTEGER. + + -- HISTORY: + -- DTN 04/15/92 CONSOLIDATION OF C86006A AND C86006B. + + WITH REPORT; USE REPORT; + PROCEDURE C86006I IS + + ABOOL, BBOOL : STANDARD.BOOLEAN := STANDARD.FALSE; + CBOOL : STANDARD.BOOLEAN := STANDARD.TRUE; + INT1 : STANDARD.INTEGER := -2; + NAT1 : STANDARD.NATURAL := 0; + POS1, POS2 : STANDARD.POSITIVE := 2; + + BEGIN + + TEST("C86006I", "CHECK THAT THE IDENTIFIERS ""BOOLEAN, TRUE, AND " & + "FALSE"" AND THE IDENTIFIERS ""INTEGER, NATURAL, " & + "AND POSITIVE"" ARE DECLARED IN THE PACKAGE " & + """STANDARD"", ALONG WITH THE OPERATORS OF THE " & + "TYPE BOOLEAN AND THE TYPE INTEGER"); + + -- STANDARD.">" OPERATOR. + + IF STANDARD.">"(ABOOL,BBOOL) THEN + FAILED("STANDARD.> FAILED FOR BOOLEAN TYPE"); + END IF; + + IF STANDARD.">"(INT1,NAT1) THEN + FAILED("STANDARD.> FAILED FOR INTEGER-NATURAL TYPE"); + END IF; + + -- STANDARD."/=" OPERATOR. + + IF STANDARD."/="(ABOOL,BBOOL) THEN + FAILED("STANDARD./= FAILED FOR BOOLEAN TYPE"); + END IF; + + IF STANDARD."/="(POS1,POS2) THEN + FAILED("STANDARD./= FAILED FOR INTEGER-POSITIVE TYPE"); + END IF; + + -- STANDARD."AND" OPERATOR. + + IF STANDARD."AND"(CBOOL,ABOOL) THEN + FAILED("STANDARD.AND FAILED"); + END IF; + + -- STANDARD."-" BINARY OPERATOR. + + IF STANDARD."-"(INT1,POS1) /= IDENT_INT(-4) THEN + FAILED("STANDARD.- FAILED"); + END IF; + + -- STANDARD."-" UNARY OPERATOR. + + IF STANDARD."-"(INT1) /= IDENT_INT(2) THEN + FAILED("STANDARD.UNARY - FAILED"); + END IF; + + -- STANDARD."REM" OPERATOR. + + IF STANDARD."REM"(IDENT_INT(14),IDENT_INT(5)) /= IDENT_INT(4) THEN + FAILED("STANDARD.REM (++=+) FAILED"); + END IF; + + -- STANDARD."MOD" OPERATOR. + + IF STANDARD."MOD"(IDENT_INT(14),IDENT_INT(-5)) /= IDENT_INT(-1) THEN + FAILED("STANDARD.MOD (+-=-) FAILED"); + END IF; + + RESULT; + + END C86006I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c86007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c86007a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C86007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXPANDED NAME FOR AN ENTITY DECLARED IN THE VISIBLE + -- PART OF A LIBRARY PACKAGE CAN START WITH THE NAME "STANDARD". + + -- HISTORY: + -- DHH 03/15/88 CREATED ORIGINAL TEST. + -- RJW 10/26/89 ADDED "PRAGMA ELABORATE (REPORT);" + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE C86007A_PACK IS + SUBTYPE ITEM IS INTEGER RANGE 0 .. 10; + Y : STANDARD.C86007A_PACK.ITEM := IDENT_INT(5); + TYPE ACC IS ACCESS STANDARD.C86007A_PACK.ITEM; + PROCEDURE SWAP(X,Y: IN OUT ITEM); + PROCEDURE PROC; + END C86007A_PACK; + + PACKAGE BODY C86007A_PACK IS + PROCEDURE SWAP(X,Y: IN OUT STANDARD.C86007A_PACK.ITEM) IS + T : STANDARD.C86007A_PACK.ITEM; + BEGIN + T := X; + X := Y; + Y := T; + END SWAP; + + PROCEDURE PROC IS + X : STANDARD.C86007A_PACK.ITEM := IDENT_INT(10); + W : STANDARD.C86007A_PACK.ACC; + BEGIN + + W := NEW STANDARD.C86007A_PACK.ITEM; + W.ALL := X; + STANDARD.C86007A_PACK.SWAP(X, STANDARD.C86007A_PACK.Y); + IF STANDARD.C86007A_PACK.Y /= IDENT_INT(10) THEN + FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-10"); + END IF; + IF X /= IDENT_INT(5) THEN + FAILED("FAILED STANDARD.NAME CALL PROCEDURE - B-5"); + END IF; + END PROC; + END C86007A_PACK; + + WITH C86007A_PACK; WITH REPORT; USE REPORT; + PROCEDURE C86007A IS + BEGIN + TEST("C86007A", "CHECK THAT AN EXPANDED NAME FOR AN ENTITY " & + "DECLARED IN THE VISIBLE PART OF A LIBRARY " & + "PACKAGE CAN START WITH THE NAME ""STANDARD"""); + + STANDARD.C86007A_PACK.PROC; + + RESULT; + END C86007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87a05a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C87A05A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE + -- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION. + -- + -- PART 1 : CORRECT RESOLUTION IS INDEXED COMPONENT EXPRESSION + + -- TRH 13 JULY 82 + -- DSJ 09 JUNE 83 + + WITH REPORT; USE REPORT; + + PROCEDURE C87A05A IS + + OK : BOOLEAN := TRUE; + TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN; + + PROCEDURE P (ARG : BOOLEAN) IS -- THIS IS CORRECT P + BEGIN + OK := ARG; + END P; + + PROCEDURE P (ARG : CHARACTER) IS + BEGIN + OK := FALSE; + END P; + + FUNCTION Y RETURN VECTOR IS -- THIS IS CORRECT Y + BEGIN + RETURN (VECTOR'RANGE => TRUE); + END Y; + + FUNCTION Y (ARG : INTEGER) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y (ARG : CHARACTER) RETURN CHARACTER IS + BEGIN + OK := FALSE; + RETURN 'A'; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y RETURN BOOLEAN IS + BEGIN + OK := FALSE; + RETURN FALSE; + END Y; + + FUNCTION Y (ARG : CHARACTER := 'A') RETURN BOOLEAN IS + BEGIN + OK := FALSE; + RETURN FALSE; + END Y; + + FUNCTION Z RETURN INTEGER IS -- THIS IS CORRECT Z + BEGIN + RETURN 3; + END Z; + + FUNCTION Z RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 3.0; + END Z; + + BEGIN + TEST ("C87A05A","OVERLOADING RESOLUTION FOR DISTINGUISHING " & + "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE INDEXED " & + "COMPONENTS ARE CORRECT"); + + P (Y (Z) ); + + IF NOT OK THEN + FAILED ("RESOLUTION INCORRECT"); + END IF; + + RESULT; + END C87A05A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87a05b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C87A05B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FUNCTION CALLS AND INDEXED COMPONENT EXPRESSIONS CAN BE + -- DISTINGUISHED BY THE RULES OF OVERLOADING RESOLUTION. + -- + -- PART 2 : CORRECT RESOLUTION IS FUNCTION CALL + + -- TRH 15 JULY 82 + -- DSJ 09 JUNE 83 + + WITH REPORT; USE REPORT; + + PROCEDURE C87A05B IS + + OK : BOOLEAN := TRUE; + TYPE VECTOR IS ARRAY (1 .. 5) OF BOOLEAN; + + PROCEDURE P (ARG : CHARACTER := 'A') IS + BEGIN + OK := FALSE; + END P; + + PROCEDURE P IS + BEGIN + OK := FALSE; + END P; + + PROCEDURE P (ARG : INTEGER) IS -- THIS IS CORRECT P + BEGIN + OK := (ARG = 1); + END P; + + FUNCTION Y RETURN VECTOR IS + BEGIN + OK := FALSE; + RETURN (VECTOR'RANGE => TRUE); + END Y; + + FUNCTION Y RETURN CHARACTER IS + BEGIN + OK := FALSE; + RETURN 'A'; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN FLOAT IS + BEGIN + OK := FALSE; + RETURN 0.0; + END Y; + + FUNCTION Y (ARG : CHARACTER) RETURN INTEGER IS + BEGIN + OK := FALSE; + RETURN 0; + END Y; + + FUNCTION Y (ARG : FLOAT) RETURN INTEGER IS -- THIS IS CORRECT Y + BEGIN + RETURN 1; + END Y; + + FUNCTION Z RETURN INTEGER IS + BEGIN + OK := FALSE; + RETURN 3; + END Z; + + FUNCTION Z RETURN FLOAT IS -- THIS IS CORRECT Z + BEGIN + RETURN 3.0; + END Z; + + BEGIN + TEST ("C87A05B","OVERLOADING RESOLUTION FOR DISTINGUISHING " & + "FUNCTION CALLS FROM INDEXED COMPONENTS WHERE CORRECT " & + "RESOLUTION IS FUNCTION CALL"); + + P (Y (Z) ); + + IF NOT OK THEN + FAILED ("RESOLUTION INCORRECT"); + END IF; + + RESULT; + END C87A05B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b02a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C87B02A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A CONSTANT DECLARATION, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE CONSTANT'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 17 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B02A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B02A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN CONSTANT DECLARATIONS"); + DECLARE + + FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + I1 : CONSTANT INTEGER := F1 (0, 0); + W1 : CONSTANT WHOLE := F1 (0, 0); + C1 : CONSTANT CITRUS := F1 (0, 0); + H1 : CONSTANT HUE := F1 (0, 0); + + I2 : CONSTANT INTEGER := "*" (0, 0); + W2 : CONSTANT WHOLE := "*" (0, 0); + C2 : CONSTANT CITRUS := "*" (0, 0); + H2 : CONSTANT HUE := "*" (0, 0); + + I3 : CONSTANT INTEGER := (0 * 0); + W3 : CONSTANT WHOLE := (0 * 0); + C3 : CONSTANT CITRUS := (0 * 0); + H3 : CONSTANT HUE := (0 * 0); + + C4 : CONSTANT CITRUS := ORANGE; + H4 : CONSTANT HUE := ORANGE; + + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; + END C87B02A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b02b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C87B02B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A VARIABLE DECLARATION, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE VARIABLE'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 17 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B02B IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B02B","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN VARIABLE DECLARATIONS"); + DECLARE + + FUNCTION "REM" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "REM" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "REM" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "REM" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + + I2 : INTEGER := "REM" (0, 0); + W2 : WHOLE := "REM" (0, 0); + C2 : CITRUS := "REM" (0, 0); + H2 : HUE := "REM" (0, 0); + + I3 : INTEGER := (0 REM 0); + W3 : WHOLE := (0 REM 0); + C3 : CITRUS := (0 REM 0); + H3 : HUE := (0 REM 0); + + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; + END C87B02B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b03a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- C87B03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE EXPRESSION IN A NUMBER DECLARATION MUST BE EITHER OF THE TYPE + -- UNIVERSAL_INTEGER OR UNIVERSAL_REAL. + + -- TRH 16 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B03A IS + + BEGIN + TEST ("C87B03A","OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS"); + + DECLARE + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."-"; + + FUNCTION "+" (X, Y : FLOAT) RETURN FLOAT + RENAMES STANDARD."-"; + + I1 : CONSTANT := 1 + 1; + I2 : CONSTANT INTEGER := 1 + 1; + + R1 : CONSTANT := 1.0 + 1.0; + R2 : CONSTANT FLOAT := 1.0 + 1.0; + + BEGIN + IF I1 /= 2 OR I2 /= 0 OR + R1 /= 2.0 OR R2 /= 0.0 THEN + FAILED ("OVERLOADED EXPRESSIONS IN NUMBER DECLARATIONS" & + " RESOLVED INCORRECTLY"); + END IF; + END; + + RESULT; + END C87B03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C87B04A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS + -- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S + -- EXPLICIT TYPEMARK. + + -- TRH 28 JUNE 82 + -- JBG 3/8/84 + + WITH REPORT; USE REPORT; + PROCEDURE C87B04A IS + + TYPE AGE IS NEW INTEGER RANGE 1 .. 120; + TYPE BASE10 IS NEW INTEGER RANGE 0 .. 9; + + FUNCTION F1 RETURN AGE IS + BEGIN + RETURN 18; + END F1; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " & + "SUBTYPE INDICATION"); + RETURN 0; + END F1; + + FUNCTION "+" (X : INTEGER) RETURN BASE10 IS + BEGIN + RETURN 1; + END "+"; + + FUNCTION "+" (X : INTEGER) RETURN INTEGER IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RANGE CONSTRAINT OF " & + "SUBTYPE INDICATION"); + RETURN -X; + END "+"; + + BEGIN + TEST ("C87B04A","OVERLOADED EXPRESSIONS IN RANGE CONTRAINTS" & + " OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE MINOR IS AGE RANGE 1 .. F1; + + BEGIN + FOR I IN BASE10 RANGE +(INTEGER'(0)) .. 0 LOOP + FAILED ("RESOLUTION INCORRECT - SUBTYPE INDICATION " & + " IN LOOP CONSTRUCT"); + END LOOP; + END; + + RESULT; + END C87B04A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C87B04B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- IN AN ACCURACY CONSTRAINT OF A SUBTYPE INDICATION, THE + -- EXPRESSIONS FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE + -- WITH THE SUBTYPE'S EXPLICIT TYPEMARK. + + -- HISTORY: + -- TRH 06/29/82 CREATED ORIGINAL TEST. + -- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. CORRECTED + -- CONSTRAINT ERRORS. + -- KAS 11/24/95 DELETED SUBTYPE DIGITS CONSTRAINT + + WITH REPORT; USE REPORT; + + PROCEDURE C87B04B IS + + TYPE EXACT IS DIGITS 5 RANGE -1.0 .. 1.0; + TYPE HEX IS DELTA 2.0 ** (-4) RANGE -1.0 .. 1.0; + + FUNCTION F1 RETURN EXACT IS + BEGIN + RETURN 0.0; + END F1; + + FUNCTION F1 RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " & + "SUBTYPE INDICATION - F1"); + RETURN 0.0; + END F1; + + FUNCTION "+" (X : INTEGER) RETURN HEX IS + BEGIN + RETURN 0.0; + END "+"; + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - ACCURACY CONSTRAINT OF " & + "SUBTYPE INDICATION - +"); + RETURN 0.0; + END "+"; + + BEGIN + TEST ("C87B04B","OVERLOADED EXPRESSIONS IN ACCURACY CONTRAINTS" & + " OF FLOATING/FIXED POINT SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE CLOSE IS EXACT RANGE -1.0 .. F1; + SUBTYPE BIN IS HEX DELTA 2.0 ** (-1) RANGE "+" (0) .. 0.5; + + BEGIN + NULL; + END; + + RESULT; + END C87B04B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b04c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C87B04C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A RANGE CONSTRAINT OF A SUBTYPE INDICATION, THE EXPRESSIONS + -- FOR THE LOWER AND UPPER BOUNDS MUST BE COMPATIBLE WITH THE SUBTYPE'S + -- EXPLICIT TYPEMARK. + + -- TRH 29 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B04C IS + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + TYPE ORB IS (SUN, MOON, MARS, EARTH); + + TYPE GRADE IS ('A', 'B', 'C', 'D', 'F'); + TYPE VOWEL IS ('C', 'E', 'A', 'O', 'I', 'U', 'Y'); + + BEGIN + TEST ("C87B04C","OVERLOADED EXPRESSIONS IN RANGE CONSTRAINTS" & + " OF ENUMERATION SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE PASSING IS GRADE RANGE 'A' .. 'C'; + SUBTYPE DISTANT IS ORB RANGE SUN .. MARS; + + BEGIN + IF DISTANT'POS (DISTANT'FIRST) /= 0 OR + PASSING'POS (PASSING'FIRST) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " & + " ENUMERATION LITERALS"); + END IF; + END; + + RESULT; + END C87B04C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b05a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C87B05A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN AN INTEGER TYPE DEFINITION WITH A RANGE CONSTRAINT, THE BOUNDS + -- OF THE RANGE MUST BE OF SOME INTEGER TYPE. + + -- TRH 1 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B05A IS + + ERR : BOOLEAN := FALSE; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE AGE IS NEW INTEGER RANGE 0 .. 120; + + FUNCTION "+" (X : WHOLE) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 2.0; + END "+"; + + FUNCTION "-" (X : AGE) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN FALSE; + END "-"; + + BEGIN + TEST ("C87B05A","OVERLOADED EXPRESSIONS IN RANGE BOUNDS " & + " OF INTEGER TYPE DEFINITIONS"); + + DECLARE + TYPE ADULT IS RANGE 18 .. "+" (WHOLE'(120)); + TYPE MINOR IS RANGE "-" (AGE'(0)) .. "+" (WHOLE'(17)); + TYPE NEG10 IS RANGE "-" (AGE'(10)) .. "-" (AGE'(1)); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - INTEGER TYPE " & + "DEFINITIONS MUST HAVE INTEGER TYPE " & + "RANGE BOUNDS"); + END IF; + END; + + RESULT; + END C87B05A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b06a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C87B06A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR EACH INTEGER TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT + -- CONVERTS A UNIVERSAL INTEGER VALUE INTO THE CORRESPONDING VALUE + -- OF THE INTEGER TYPE. THIS TEST USES LITERALS AS UNIVERSAL INTEGER + -- VALUES. + + -- HISTORY: + -- TRH 08/11/82 CREATED ORIGINAL TEST. + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B06A IS + + TYPE MINOR IS NEW INTEGER RANGE 0 .. 17; + TYPE FIXED IS NEW DURATION; + TYPE REAL IS NEW FLOAT; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P (X : BOOLEAN) IS + BEGIN + ERR := TRUE; + END P; + PROCEDURE P (X : FIXED) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : REAL) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : FLOAT) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : STRING) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : MINOR) IS + BEGIN + NULL; + END P; + + BEGIN + TEST("C87B06A","OVERLOADING RESOLUTION WITH IMPLICIT CONVERSION " & + "OF UNIVERSAL INTEGER VALUES TO INTEGER VALUES. " & + "CONVERSIONS TO INTEGER VALUES EXISTS FOR ANY INTEGER TYPE"); + + P (2); + P (2 * 2 + 2); + + IF ERR THEN + FAILED("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL " & + " INTEGER VALUES TO INTEGER TYPE VALUES"); + END IF; + + RESULT; + END C87B06A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C87B07A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR THE ATTRIBUTE OF THE FORM T'POS (X), THE OPERAND X MUST + -- BE A VALUE OF TYPE T. THE RESULT IS OF TYPE UNIVERSAL_INTEGER. + + -- TRH 13 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B07A IS + + TYPE NATURAL IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE COLOR IS (BROWN, RED, WHITE); + TYPE SCHOOL IS (HARVARD, BROWN, YALE); + TYPE SUGAR IS (DEXTROSE, CANE, BROWN); + + FUNCTION "+" (X, Y : NATURAL) RETURN NATURAL + RENAMES "*"; + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "-"; + + BEGIN + TEST ("C87B07A","OVERLOADED OPERANDS TO THE 'POS' ATTRIBUTE"); + + IF NATURAL'POS (1 + 1) /= 1 OR COLOR'POS (BROWN) /= 0 OR + WHOLE'POS (1 + 1) /= 0 OR SCHOOL'POS (BROWN) /= 1 OR + INTEGER'POS (1 + 1) /= 2 OR SUGAR'POS (BROWN) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERAND TO 'POS' ATTRIBUTE"); + END IF; + + IF NATURAL'POS (3 + 3) + 1 /= 10 OR -- SECOND "+" IS UNIVERSAL. + WHOLE'POS (3 + 3) + 1 /= 1 OR -- SECOND "+" IS UNIVERSAL. + INTEGER'POS (3 + 3) + 1 /= 7 THEN -- SECOND "+" IS UNIVERSAL. + FAILED ("RESOLUTION INCORRECT - 'POS' ATTRIBUTE RETURNS " & + "A UNIVERSAL_INTEGER VALUE"); + END IF; + + RESULT; + END C87B07A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C87B07B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MAY + -- BE OF ANY INTEGER TYPE. THE RESULT IS OF TYPE T. + + -- TRH 15 SEPT 82 + -- DSJ 06 JUNE 83 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B07B IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE FLAG IS (PASS, FAIL); + + FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT + RENAMES "-"; + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("THE 'VAL' ATTRIBUTE TAKES AN OPERAND " & + "OF AN INTEGER TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (CHARACTER, '1', FAIL); + FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL); + FUNCTION F IS NEW F1 (FLOAT, 1.0, FAIL); + FUNCTION F IS NEW F1 (NEW_INT, 1, PASS); + + BEGIN + TEST ("C87B07B","OVERLOADED OPERANDS TO THE 'VAL' ATTRIBUTE"); + + IF (INTEGER'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 1"); + END IF; + + IF (INTEGER'VAL (3 + 3) + 1 /= 7) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 2"); + END IF; + + IF (NEW_INT'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 3"); + END IF; + + IF (NEW_INT'VAL (3 + 3) + 1 /= 5) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 4"); + END IF; + + IF (WHOLE'VAL (F) /= 1) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 5"); + END IF; + + IF (WHOLE'VAL (3 + 3) + 1 /= 6) THEN + FAILED ("RESOLUTION INCORRECT - THE 'VAL' ATTRIBUTE " & + "MUST RETURN A VALUE OF TYPE T - 6"); + END IF; + + RESULT; + END C87B07B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C87B07C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST + -- BE OF THE PREDEFINED TYPE STRING. THE RESULT IS OF TYPE T. + + -- TRH 13 SEPT 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B07C IS + + TYPE CHAR IS NEW CHARACTER; + TYPE LITS IS (' ', '+', '1'); + TYPE WORD IS ARRAY (POSITIVE RANGE 1..4) OF CHARACTER; + TYPE LINE IS ARRAY (POSITIVE RANGE 1..4) OF CHAR; + TYPE LIST IS ARRAY (POSITIVE RANGE 1..4) OF LITS; + TYPE STR IS ARRAY (POSITIVE RANGE 1..4) OF STRING (1 .. 1); + TYPE STR2 IS NEW STRING (1..4); + TYPE FLAG IS (PASS, FAIL); + SUBTYPE MY_STRING IS STRING (1..4); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("THE 'VALUE' ATTRIBUTE TAKES AN OPERAND" & + " OF THE TYPE PREDEFINED STRING"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (STR2, " +1 ", FAIL); + FUNCTION F IS NEW F1 (LIST, " +1 ", FAIL); + FUNCTION F IS NEW F1 (WORD, (' ', '+', '1', ' '), FAIL); + FUNCTION F IS NEW F1 (STR, (" ", "+", "1", " "), FAIL); + FUNCTION F IS NEW F1 (LINE, (' ', '+', '1', ' '), FAIL); + FUNCTION F IS NEW F1 (MY_STRING, " +1 ", PASS); + + BEGIN + TEST ("C87B07C","OVERLOADED OPERANDS TO THE 'VALUE' ATTRIBUTE"); + + DECLARE + TYPE INT IS NEW INTEGER; + FUNCTION "-" (X : INT) RETURN INT + RENAMES "+"; + + BEGIN + IF INT'VALUE (F) /= -1 THEN + FAILED ("THE ATTRIBUTE T'VALUE MUST RETURN A VALUE" & + " OF TYPE T"); + END IF; + END; + + RESULT; + END C87B07C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C87B07D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE ATTRIBUTES OF THE FORM T'SUCC (X) AND T'PRED (X) TAKE AN + -- OPERAND X OF TYPE T AND RETURN A VALUE OF TYPE T. + + -- TRH 15 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B07D IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + FUNCTION "+" (X, Y : NEW_INT) RETURN NEW_INT + RENAMES "-"; + + BEGIN + TEST ("C87B07D","OVERLOADED OPERANDS TO THE ATTRIBUTES " & + "'PRED' AND 'SUCC'"); + + IF INTEGER'SUCC (1 + 1) /= 3 OR INTEGER'SUCC (3 + 3) + 1 /= 8 OR + NEW_INT'SUCC (1 + 1) /= 1 OR NEW_INT'SUCC (3 + 3) + 1 /= 0 OR + WHOLE'SUCC (1 + 1) /= 2 OR WHOLE'SUCC (3 + 3) + 1 /= 10 OR + INTEGER'PRED (1 + 1) /= 1 OR INTEGER'PRED (3 + 3) + 1 /= 6 OR + NEW_INT'PRED (1 + 1) /= -1 OR NEW_INT'PRED (3 + 3) + 1 /= -2 OR + WHOLE'PRED (1 + 1) /= 0 OR WHOLE'PRED (3 + 3) + 1 /= 8 + THEN FAILED ("RESOLUTION INCORRECT FOR OPERAND OR RESULT OF" & + " THE 'PRED' OR 'SUCC' ATTRIBUTE"); + END IF; + + RESULT; + END C87B07D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b07e.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C87B07E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR THE ATTRIBUTE OF THE FORM T'IMAGE (X), THE OPERAND X MUST + -- BE OF TYPE T. THE RESULT IS OF THE PREDEFINED TYPE STRING. + + -- TRH 15 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B07E IS + + TYPE NEW_INT IS NEW INTEGER; + TYPE NUMBER IS NEW INTEGER; + TYPE NEW_STR IS NEW STRING; + + FUNCTION "+" (X : NEW_INT) RETURN NEW_INT + RENAMES "-"; + FUNCTION "-" (X : NUMBER) RETURN NUMBER + RENAMES "+"; + + PROCEDURE P (X : NEW_STR) IS + BEGIN + FAILED ("THE IMAGE ATTRIBUTE MUST RETURN A VALUE OF THE" & + " PREDEFINED TYPE STRING"); + END P; + + PROCEDURE P (X : STRING) IS + BEGIN + NULL; + END P; + + BEGIN + TEST ("C87B07E","OVERLOADED OPERANDS TO THE IMAGE ATTRIBUTE"); + + IF INTEGER'IMAGE (+12) & INTEGER'IMAGE (-12) & + NEW_INT'IMAGE (+12) & NEW_INT'IMAGE (-12) & + NUMBER'IMAGE (+12) & NUMBER'IMAGE (-12) /= + " 12-12-12-12 12 12" THEN + FAILED ("RESOLUTION INCORRECT FOR THE 'IMAGE' ATTRIBUTE"); + END IF; + + P (INTEGER'IMAGE (+1) & NEW_INT'IMAGE (+1) & NUMBER'IMAGE (-1)); + + RESULT; + END C87B07E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b08a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C87B08A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR EACH REAL TYPE, THERE EXISTS AN IMPLICIT CONVERSION THAT + -- CONVERTS A UNIVERSAL REAL VALUE INTO THE CORRESPONDING VALUE + -- OF THE REAL TYPE. THIS TEST USES LITERALS AS UNIVERSAL REAL + -- VALUES. + + -- TRH 16 AUG 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B08A IS + + TYPE FIXED IS DELTA 0.1 RANGE -2.0 .. 2.0; + TYPE FLT IS DIGITS 2 RANGE -2.0 .. 2.0; + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + STAT : IN FLAG; + PROCEDURE P1 (X : T); + + PROCEDURE P1 (X : T) IS + BEGIN + IF STAT = FAIL THEN + FAILED ("INCORRECT IMPLICIT CONVERSION FROM UNIVERSAL" & + " REAL VALUES TO REAL TYPE VALUES"); + END IF; + END P1; + + PROCEDURE P IS NEW P1 (INTEGER, FAIL); + PROCEDURE P IS NEW P1 (FLT, PASS); + PROCEDURE Q IS NEW P1 (FIXED, PASS); + PROCEDURE Q IS NEW P1 (BOOLEAN, FAIL); + PROCEDURE Q IS NEW P1 (CHARACTER, FAIL); + + BEGIN + TEST ("C87B08A","IMPLICIT CONVERSION OF UNIVERSAL REAL " & + "VALUES TO REAL VALUES EXISTS FOR ANY REAL TYPE"); + + P (0.0); + P (1.0 + 1.0); + Q (1.0); + Q (1.0 - 1.0); + + RESULT; + END C87B08A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b09a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- C87B09A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST + -- BE OF SOME INTEGER TYPE. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B09A IS + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGER TYPE"); + RETURN 2.0; + END "+"; + + BEGIN + TEST ("C87B09A","OVERLOADED DIGITS EXPRESSIONS IN " & + "FLOATING POINT TYPE DEFINITIONS"); + + DECLARE + TYPE EXACT IS DIGITS "+" (3); + TYPE CLOSE IS DIGITS "+" (1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; + END C87B09A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b09c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C87B09C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A FLOATING POINT TYPE DEFINITION, THE DIGITS EXPRESSION MUST + -- BE OF SOME INTEGRAL TYPE. SIMILARLY, THE DELTA EXPRESSION IN A + -- FIXED POINT TYPE DEFINITION MUST BE OF SOME REAL TYPE. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B09C IS + + FUNCTION "+" (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("DIGITS EXPRESSION MUST BE OF AN INTEGRAL TYPE"); + RETURN 2.0; + END "+"; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + + BEGIN + TEST ("C87B09C","OVERLOADED DIGITS/DELTA EXPRESSIONS IN " & + "REAL TYPE DEFINITIONS"); + + DECLARE + TYPE EXACT IS DIGITS "+" (4); + TYPE CENTI IS DELTA "+" (0.01) RANGE -2.0 .. 2.0; + TYPE CLOSE IS DIGITS "+" (2) RANGE -1.0 .. 1.0; + TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; + END C87B09C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b10a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C87B10A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A RANGE CONSTRAINT OF A FIXED POINT OR FLOATING POINT TYPE + -- DEFINITION, BOTH BOUNDS MUST BE OF SOME REAL TYPE, ALTHOUGH + -- THE TWO BOUNDS DO NOT HAVE TO BE OF THE SAME TYPE. + + -- TRH 7/28/82 + -- DSJ 6/10/83 + -- JBG 9/19/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B10A IS + + SUBTYPE DUR IS DURATION; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " & + "MUST HAVE REAL BOUNDS"); + RETURN -10; + END "+"; + + FUNCTION "+" (X, Y : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("RANGE CONSTRAINT FOR REAL TYPE DEFINITIONS " & + "MUST HAVE REAL BOUNDS"); + RETURN -10; + END "+"; + + BEGIN + TEST ("C87B10A","RANGE BOUNDS IN REAL TYPE DEFINITIONS MUST BE" & + " OF SOME (NOT NECESSARILY THE SAME) REAL TYPE"); + + DECLARE + TYPE R1 IS DIGITS 2 RANGE 0.0 .. 1.0 + FLOAT'(1.0); + TYPE R2 IS DELTA 0.1 RANGE FLOAT'(1.0) + 1.0 .. DUR'(2.0); + TYPE R3 IS DIGITS 2 RANGE +1.0 .. "+" (FLOAT'(2.0), 2.0); + TYPE R4 IS DELTA 0.1 RANGE 0.0 + FLOAT'(0.0) .. +1.0; + + + BEGIN + IF 2.0 NOT IN R1 OR -1.0 IN R2 OR + -1.0 IN R3 OR -0.9 IN R4 THEN + FAILED ("RANGE BOUNDS IN REAL TYPE DEFINITIONS DO NOT " + & "HAVE TO BE OF THE SAME REAL TYPE"); + END IF; + END; + + RESULT; + END C87B10A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b11a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- C87B11A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A FIXED POINT TYPE DEFINITION, THE DELTA EXPRESSION MUST + -- BE OF SOME REAL TYPE. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B11A IS + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + + BEGIN + TEST ("C87B11A","OVERLOADED DELTA EXPRESSIONS IN " & + "FIXED POINT TYPE DEFINITIONS"); + + DECLARE + TYPE SEMI IS DELTA "+" (0.5) RANGE -2.0 .. 2.0; + TYPE DECI IS DELTA "+" (0.1) RANGE -1.0 .. 1.0; + + BEGIN + NULL; + END; + + RESULT; + END C87B11A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b11b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- C87B11B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A SUBTYPE INDICATION, THE DELTA EXPRESSION FOR A FIXED POINT + -- NUMBER MUST BE OF SOME REAL TYPE. + + -- TRH 29 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B11B IS + + TYPE DELT3 IS DELTA 3.0 RANGE -30.0 .. 30.0; + + FUNCTION "+" (X : FLOAT) RETURN INTEGER IS + BEGIN + FAILED ("DELTA EXPRESSION MUST BE OF A REAL TYPE"); + RETURN 2; + END "+"; + + BEGIN + TEST ("C87B11B","OVERLOADED DELTA EXPRESSIONS IN " & + "FIXED POINT SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE DELT2 IS DELT3 DELTA "+"(6.0); + SUBTYPE DELT1 IS DELT3 DELTA "+"(10.0) RANGE -10.0 .. 10.0; + + BEGIN + NULL; + END; + + RESULT; + END C87B11B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b13a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C87B13A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE LOWER AND UPPER BOUNDS OF AN INDEX CONSTRAINT IN A CONSTRAINED + -- ARRAY TYPE DEFINITION MUST BE DISCRETE AND OF THE SAME TYPE. + + -- TRH 1 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B13A IS + + TYPE CENTI IS DELTA 0.01 RANGE -1.0 .. 1.0; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN CENTI IS + BEGIN + FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " & + " OF THE SAME TYPE"); + RETURN 0.0; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("INDEX CONSTRAINT BOUNDS MUST BE DISCRETE AND " & + " OF THE SAME TYPE"); + RETURN 1.0; + END F1; + + BEGIN + TEST ("C87B13A","OVERLOADED INDEX CONSTRAINTS IN " & + "CONSTRAINED ARRAY TYPE DEFINITIONS"); + + DECLARE + TYPE A1 IS ARRAY (F1 (1) .. F1 (1)) OF BOOLEAN; + TYPE A2 IS ARRAY (1 .. F1 (2)) OF BOOLEAN; + TYPE A3 IS ARRAY (F1 (1) .. 2) OF BOOLEAN; + + BEGIN + NULL; + END; + + RESULT; + END C87B13A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C87B14A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER + -- BOUNDS MUST BE OF THE INDEX BASE TYPE. + -- + -- TEST (A): INDEX CONSTRAINTS WITH OVERLOADED FUNCTIONS. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B14A IS + + SUBTYPE WHOLE IS INTEGER RANGE 0 .. INTEGER'LAST; + SUBTYPE BASE10 IS INTEGER RANGE 0 .. 9; + TYPE LIST IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + TYPE GRID IS ARRAY (INTEGER RANGE <>, INTEGER RANGE <>) OF BOOLEAN; + + FUNCTION F1 RETURN WHOLE IS + BEGIN + RETURN 1; + END F1; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END F1; + + FUNCTION F2 RETURN BASE10 IS + BEGIN + RETURN 2; + END F2; + + FUNCTION F2 RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END F2; + + BEGIN + TEST ("C87B14A","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE LIST1 IS LIST (1 .. F1); + SUBTYPE LIST2 IS LIST (F1 .. 1); + SUBTYPE LIST3 IS LIST (F2 .. F2); + SUBTYPE LIST4 IS LIST (F1 .. F2); + + SUBTYPE GRID1 IS GRID (1 .. F1, F1 .. 1); + SUBTYPE GRID2 IS GRID (F1 .. 2, 2 .. F2); + SUBTYPE GRID3 IS GRID (F1 .. F1, F2 .. F2); + SUBTYPE GRID4 IS GRID (F1 .. F2, 1 .. 2); + + BEGIN + NULL; + END; + + RESULT; + END C87B14A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C87B14B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER + -- BOUNDS MUST BE OF THE INDEX BASE TYPE. + -- + -- TEST (B): INDEX CONSTRAINTS WITH OVERLOADED OPERATOR SYMBOLS. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B14B IS + + SUBTYPE CHAR IS CHARACTER; + SUBTYPE VAR IS CHAR RANGE 'X' .. 'Z'; + SUBTYPE NOTE IS CHAR RANGE 'A' .. 'G'; + TYPE LIST IS ARRAY (CHAR RANGE <>) OF CHAR; + TYPE GRID IS ARRAY (CHAR RANGE <>, CHAR RANGE <>) OF CHAR; + + FUNCTION "*" (X, Y : INTEGER) RETURN VAR IS + BEGIN + RETURN 'X'; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END "*"; + + FUNCTION "+" (X, Y : INTEGER) RETURN NOTE IS + BEGIN + RETURN 'A'; + END "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END "+"; + + BEGIN + TEST ("C87B14B","OVERLOADED OPERATOR SYMBOLS IN INDEX " & + "CONSTRAINTS OF SUBTYPE INDICATIONS"); + + DECLARE + + SUBTYPE LIST1 IS LIST ('W' .. "*" (0, 0)); + SUBTYPE LIST2 IS LIST ("+" (0, 0) .. 'C'); + SUBTYPE LIST3 IS LIST ("+" (0, 0) .. "*" (0, 0)); + SUBTYPE LIST4 IS LIST ("*" (0, 0) .. "*" (0, 0)); + + SUBTYPE GRID1 IS GRID ('V' .. "*" (0, 0), "*" (0, 0) .. 'Y'); + SUBTYPE GRID2 IS GRID ("*" (0, 0) .. 'W', 'H' .. "+" (0, 0)); + SUBTYPE GRID3 IS GRID + ("*" (0, 0) .. "*" (0, 0), "+" (0, 0) .. "+" (0, 0)); + SUBTYPE GRID4 IS GRID ("+" (0, 0) .. "*" (0, 0),'L' .. 'N'); + + BEGIN + NULL; + END; + + RESULT; + END C87B14B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C87B14C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, THE LOWER AND UPPER + -- BOUNDS MUST BE OF THE INDEX BASE TYPE. + -- + -- TEST (C): INDEX CONSTRAINTS WITH OVERLOADED INFIX OPERATORS. + + -- TRH 30 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B14C IS + + TYPE DAY IS (MON, TUE, WED, THU, FRI, SAT, SUN); + TYPE LIST IS ARRAY (DAY RANGE <>) OF BOOLEAN; + TYPE GRID IS ARRAY (DAY RANGE <>, DAY RANGE <>) OF BOOLEAN; + SUBTYPE WEEKEND IS DAY RANGE SAT .. SUN; + SUBTYPE WEEKDAY IS DAY RANGE MON .. FRI; + + FUNCTION "*" (X, Y : INTEGER) RETURN WEEKDAY IS + BEGIN + RETURN MON; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN BOOLEAN IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN TRUE; + END "*"; + + FUNCTION "+" (X, Y : INTEGER) RETURN WEEKEND IS + BEGIN + RETURN SAT; + END "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("RESOLUTION INCORRECT - INDEX CONSTRAINTS " & + " IN SUBTYPE INDICATIONS"); + RETURN 2.0; + END "+"; + + BEGIN + TEST ("C87B14C","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS"); + + DECLARE + SUBTYPE LIST1 IS LIST (WED .. (0 + 0)); + SUBTYPE LIST2 IS LIST ( 0 * 0 .. TUE); + SUBTYPE LIST3 IS LIST ((0 + 0) .. (0 + 0)); + SUBTYPE LIST4 IS LIST ((0 * 0) .. (0 + 0)); + + SUBTYPE GRID1 IS GRID (MON .. (0 * 0), (0 * 0) .. TUE); + SUBTYPE GRID2 IS GRID ((0 * 0) .. WED, FRI .. (0 + 0)); + SUBTYPE GRID3 IS GRID + ((0 * 0) .. (0 * 0), (0 + 0) .. (0 + 0)); + SUBTYPE GRID4 IS GRID ((0 * 0) .. (0 + 0), TUE .. THU); + + BEGIN + NULL; + END; + + RESULT; + END C87B14C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b14d.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C87B14D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN SUBTYPE INDICATIONS WITH INDEX CONSTRAINTS, IF A BOUND IS OF + -- TYPE UNIVERSAL_INTEGER, IT IS IMPLICITLY CONVERTED TO THE + -- INDEX BASE TYPE. + + -- TRH 7 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B14D IS + + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE LIST IS ARRAY (WHOLE RANGE <>) OF BOOLEAN; + + BEGIN + TEST ("C87B14D","OVERLOADED EXPRESSIONS IN INDEX CONSTRAINTS " & + "OF SUBTYPE INDICATIONS WITH UNIVERSAL_INTEGER BOUNDS"); + + DECLARE + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + SUBTYPE LIST1 IS LIST (1 + 1 .. 1 + 1); + SUBTYPE LIST2 IS LIST (1 .. 3 + 3); + SUBTYPE LIST3 IS LIST (1 + 1 .. 2); + + BEGIN + IF LIST1'FIRST /= 1 OR LIST1'LAST /= 1 OR + LIST2'FIRST /= 1 OR LIST2'LAST /= 9 OR + LIST3'FIRST /= 1 OR LIST3'LAST /= 2 THEN + FAILED ("RESOLUTION INCORRECT - IMPLICIT CONVERSION " & + "OF UNIVERSAL_INTEGER TYPE TO INDEX CONSTRAINT " & + "BASE TYPE"); + END IF; + END; + + RESULT; + END C87B14D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b15a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C87B15A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE ARRAY ATTRIBUTES OF THE FORM: A'FIRST (N), A'LAST (N), + -- A'RANGE (N) AND A'LENGTH (N) MUST HAVE A PARAMETER (N) WHICH IS OF + -- THE TYPE UNIVERSAL_INTEGER. + + -- TRH 26 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B15A IS + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."*"; + + TYPE BOX IS ARRAY (0 .. 1, 3 .. 6, 5 .. 11) OF BOOLEAN; + B1 : BOX; + + BEGIN + TEST ("C87B15A","ARRAY ATTRIBUTES: FIRST (N), LAST (N), RANGE " & + "(N) AND LENGTH (N) TAKE UNIVERSAL_INTEGER OPERANDS"); + + IF BOX'FIRST (1 + 0) /= 0 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 1"); + END IF; + + IF B1'FIRST (1 + 1) /= 3 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 2"); + END IF; + + IF B1'FIRST (2 + 1) /= 5 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 3"); + END IF; + + IF BOX'LAST (0 + 1) /= 1 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 4"); + END IF; + + IF B1'LAST (1 + 1) /= 6 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 5"); + END IF; + + IF B1'LAST (1 + 2) /= 11 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 6"); + END IF; + + IF BOX'LENGTH (0 + 1) /= 2 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 7"); + END IF; + + IF B1'LENGTH (1 + 1) /= 4 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 8"); + END IF; + + IF B1'LENGTH (2 + 1) /= 7 THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 9"); + END IF; + + IF 1 NOT IN BOX'RANGE (0 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 10"); + END IF; + + IF 4 NOT IN B1'RANGE (1 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 11"); + END IF; + + IF 9 NOT IN B1'RANGE (2 + 1) THEN + FAILED ("ARRAY ATTRIBUTE OPERAND MUST BE OF TYPE " & + "UNIVERSAL_INTEGER - 12"); + END IF; + + RESULT; + END C87B15A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b16a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- C87B16A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR A DEFAULT RECORD COMPONENT, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE COMPONENTS'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 23 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B16A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B16A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT RECORD COMPONENTS"); + DECLARE + + FUNCTION "-" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "-" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "-" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "-" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TYPE REC IS + RECORD + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + + I2 : INTEGER := "-" (0, 0); + W2 : WHOLE := "-" (0, 0); + C2 : CITRUS := "-" (0, 0); + H2 : HUE := "-" (0, 0); + + I3 : INTEGER := (0 - 0); + W3 : WHOLE := (0 - 0); + C3 : CITRUS := (0 - 0); + H3 : HUE := (0 - 0); + + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + END RECORD; + + R1 : REC; + + BEGIN + IF R1.I1 /= -1 OR R1.W1 /= 0 OR + CITRUS'POS (R1.C1) /= 2 OR HUE'POS (R1.H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF R1.I2 /= -1 OR R1.W2 /= 0 OR + CITRUS'POS (R1.C2) /= 2 OR HUE'POS (R1.H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF R1.I3 /= -1 OR R1.W3 /= 0 OR + CITRUS'POS (R1.C3) /= 2 OR HUE'POS (R1.H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (R1.C4) /= 2 OR HUE'POS (R1.H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; + END C87B16A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b17a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C87B17A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- THE INITIALIZATION EXPRESSION FOR A DEFAULT DISCRIMINANT + -- IN A TYPE DECLARATION MUST MATCH THE DISCRIMINANT'S EXPLICIT + -- TYPEMARK. + -- + -- THE THREE KINDS OF TYPE DECLARATIONS TESTED HERE ARE: + -- + -- (A): RECORD TYPE. + -- (B): PRIVATE TYPE. + -- (C): INCOMPLETE RECORD TYPE. + + -- TRH 18 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B17A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B17A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT DISCRIMINANTS"); + + DECLARE + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "+" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "+" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TYPE REC1 (I1 : INTEGER := 0 + 0; H1 : HUE := F1 (0, 0) ) IS + RECORD + NULL; + END RECORD; + + PACKAGE PVT IS + TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 ) + IS PRIVATE; + PRIVATE + TYPE REC2 (H2 : HUE := ORANGE; W2 : WHOLE := 0 + 0 ) IS + RECORD + NULL; + END RECORD; + END PVT; + USE PVT; + + TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0)); + + TYPE LINK IS ACCESS REC3; + + TYPE REC3 (C1 : CITRUS := ORANGE; W1 : WHOLE := "+" (0, 0)) IS + RECORD + NULL; + END RECORD; + + R1 : REC1; + R2 : REC2; + R3 : REC3; + + BEGIN + IF R1.I1 /= -1 OR HUE'POS (R1.H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT FOR RECORD TYPES"); + END IF; + + IF HUE'POS (R2.H2) /= 1 OR R2.W2 /= 0 THEN + FAILED ("(B): RESOLUTION INCORRECT FOR PRIVATE TYPES"); + END IF; + + IF CITRUS'POS (R3.C1) /= 2 OR R3.W1 /= 0 THEN + FAILED ("(C): RESOLUTION INCORRECT FOR INCOMPLETE" & + " RECORD TYPES"); + END IF; + END; + + RESULT; + END C87B17A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b18a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C87B18A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE TYPES OF THE EXPRESSIONS IN A DISCRIMINANT CONSTRAINT IN + -- A SUBTYPE INDICATION MUST MATCH THE DISCRIMINANT'S EXPLICIT + -- TYPEMARK. + + -- TRH 1 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B18A IS + + ERR : BOOLEAN := FALSE; + + FUNCTION F1 RETURN INTEGER IS + BEGIN + RETURN 1; + END F1; + + FUNCTION F1 RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 0.0; + END F1; + + FUNCTION F2 RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F2; + + FUNCTION F2 RETURN STRING IS + BEGIN + ERR := TRUE; + RETURN "STRING"; + END F2; + + BEGIN + TEST ("C87B18A","OVERLOADED EXPRESSIONS IN DISCRIMINANT " & + "CONSTRAINTS"); + + DECLARE + TYPE REC (X : INTEGER := 0; Y : BOOLEAN := TRUE) IS + RECORD + NULL; + END RECORD; + + R1 : REC (F1, F2); + R2 : REC (Y => F2, X => F1); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - DISCRIMINANT " & + "CONSTRAINT MUST MATCH DISCRIMINANT TYPE"); + END IF; + END; + + RESULT; + END C87B18A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b18b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C87B18B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE EXPRESSION IN A NAMED OR POSITIONAL DISCRIMINANT ASSOCIATION + -- MUST MATCH THE TYPE OF THE CORRESPONDING DISCRIMINANT. + + -- TRH 9 AUG 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B18B IS + + TYPE REC (W, X : CHARACTER; Y, Z : BOOLEAN) IS + RECORD + NULL; + END RECORD; + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("DISCRIMINANT ASSOCIATION EXPRESSION MUST " & + "MATCH THE TYPE OF THE CORRESPONDING " & + "DISCRIMINANT"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', PASS); + + FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION G IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, PASS); + FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL); + + BEGIN + TEST ("C87B18B","OVERLOADED DISCRIMINANT ASSOCIATIONS"); + + DECLARE + SUBTYPE R1 IS REC (F, F, G, G); + SUBTYPE R2 IS REC (X => F, Y => G, Z => G, W => F); + SUBTYPE R3 IS REC (F, F, Z => G, Y => G); + + BEGIN + NULL; + END; + + RESULT; + END C87B18B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b19a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- C87B19A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- SIMPLE EXPRESSIONS AND RANGE BOUNDS OF VARIANT CHOICES MUST MATCH + -- THE TYPE OF THE DISCRIMINANT'S EXPLICIT TYPEMARK. + + --HISTORY: + -- DSJ 06/15/83 CREATED ORIGINAL TEST. + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B19A IS + + TYPE COLOR IS (YELLOW, RED, BLUE, GREEN, BROWN); + TYPE SCHOOL IS (YALE, HARVARD, PRINCETON, BROWN, STANFORD); + TYPE COOK IS (BROIL, BAKE, BROWN, TOAST, FRY); + TYPE MIXED IS (GREEN, BROWN, YALE, BAKE, BLUE, FRY); + + RATING : INTEGER := 0; + + FUNCTION OK RETURN BOOLEAN IS + BEGIN + RATING := RATING + 1; + RETURN FALSE; + END OK; + + FUNCTION ERR RETURN BOOLEAN IS + BEGIN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF DISCRIMINANT"); + RETURN FALSE; + END ERR; + + BEGIN + TEST ("C87B19A","OVERLOADED EXPRESSIONS AND RANGE BOUNDS" & + " OF VARIANT CHOICES"); + DECLARE + + TYPE REC (X : MIXED := BROWN) IS + RECORD + CASE X IS + WHEN GREEN .. BROWN => NULL; + WHEN BLUE => NULL; + WHEN FRY => NULL; + WHEN YALE => NULL; + WHEN OTHERS => NULL; + END CASE; + END RECORD; + + R1 : REC (X => FRY); + R2 : REC (X => BLUE); + R3 : REC (X => BAKE); + R4 : REC (X => YALE); + R5 : REC (X => BROWN); + R6 : REC (X => GREEN); + + BEGIN + IF MIXED'POS(R1.X) /= 5 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R1"); + END IF; + IF MIXED'POS(R2.X) /= 4 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R2"); + END IF; + IF MIXED'POS(R3.X) /= 3 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R3"); + END IF; + IF MIXED'POS(R4.X) /= 2 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R4"); + END IF; + IF MIXED'POS(R5.X) /= 1 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R5"); + END IF; + IF MIXED'POS(R6.X) /= 0 THEN + FAILED ("VARIANT CHOICES MUST MATCH TYPE OF " & + "DISCRIMINANT-R6"); + END IF; + + END; + + RESULT; + END C87B19A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b23a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C87B23A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR AN INDEXED COMPONENT OF AN ARRAY, THE PREFIX MUST BE + -- APPROPRIATE FOR AN ARRAY TYPE. EACH EXPRESSION FOR THE INDEXED + -- COMPONENT MUST BE OF THE TYPE OF THE CORRESPONDING INDEX AND + -- THERE MUST BE ONE SUCH EXPRESSION FOR EACH INDEX POSITION OF THE + -- ARRAY TYPE. + + -- TRH 15 SEPT 82 + -- DSJ 07 JUNE 83 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B23A IS + + SUBTYPE CHAR IS CHARACTER; + TYPE GRADE IS (A, B, C, D, F); + TYPE NOTE IS (A, B, C, D, E, F, G); + TYPE INT IS NEW INTEGER; + TYPE POS IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE NAT IS NEW POS; + TYPE BOOL IS NEW BOOLEAN; + TYPE BIT IS NEW BOOL; + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + TYPE NUM2 IS DIGITS(2); + TYPE NUM3 IS DIGITS(2); + TYPE NUM4 IS DIGITS(2); + + TYPE A1 IS ARRAY (POS'(1)..5, NOTE'(A)..D, BOOL'(FALSE)..TRUE) + OF FLOAT; + TYPE A2 IS ARRAY (INT'(1)..5, NOTE'(A)..D, BIT'(FALSE)..TRUE) + OF NUM2; + TYPE A3 IS ARRAY (POS'(1)..5, GRADE'(A)..D, BOOL'(FALSE)..TRUE) + OF NUM3; + TYPE A4 IS ARRAY (NAT'(1)..5, NOTE'(A)..D, LIT'(FALSE)..TRUE) + OF NUM4; + + OBJ1 : A1 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ2 : A2 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ3 : A3 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + OBJ4 : A4 := (OTHERS => (OTHERS => (OTHERS => 0.0))); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("PREFIX OR INDEX IS NOT APPROPRIATE FOR" & + " INDEXED COMPONENT"); + END IF; + RETURN ARG; + END F1; + + FUNCTION A IS NEW F1 (A1, OBJ1, PASS); + FUNCTION A IS NEW F1 (A2, OBJ2, FAIL); + FUNCTION A IS NEW F1 (A3, OBJ3, FAIL); + FUNCTION A IS NEW F1 (A4, OBJ4, FAIL); + + BEGIN + TEST ("C87B23A","OVERLOADED ARRAY INDEXES"); + + DECLARE + F1 : FLOAT := A (3, C, TRUE); + + BEGIN + NULL; + END; + + RESULT; + END C87B23A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b24a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C87B24A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- THE PREFIX OF A SLICE MUST BE APPROPRIATE FOR A ONE DIMENSIONAL + -- ARRAY TYPE. + + -- TRH 26 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B24A IS + + TYPE LIST IS ARRAY (1 .. 5) OF INTEGER; + TYPE GRID IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER; + TYPE CUBE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER; + TYPE HYPE IS ARRAY (1 .. 5, 1 .. 5, 1 .. 5, 1 .. 5) OF INTEGER; + TYPE FLAG IS (PASS, FAIL); + + L : LIST := (1 .. 5 => 0); + G : GRID := (1 .. 5 => (1 .. 5 => 0)); + C : CUBE := (1 .. 5 => (1 .. 5 => (1 .. 5 => 0))); + H : HYPE := (1 .. 5 => (1 .. 5 => (1 .. 5 => (1 .. 5 => 0)))); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("SLICE PREFIX MUST BE APPROPRIATE FOR ONE " & + "DIMENSIONAL ARRAY"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F2 IS NEW F1 (LIST, L, PASS); + FUNCTION F2 IS NEW F1 (GRID, G, FAIL); + FUNCTION F2 IS NEW F1 (CUBE, C, FAIL); + FUNCTION F2 IS NEW F1 (HYPE, H, FAIL); + + BEGIN + TEST ("C87B24A","OVERLOADED PREFIX FOR SLICE RESOLVED TO " & + "ONE DIMENSIONAL ARRAY TYPE"); + + DECLARE + S1 : INTEGER; + + BEGIN + S1 := F2 (2 .. 3)(2); + END; + + RESULT; + END C87B24A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b24b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C87B24B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- THE RANGE BOUNDS FOR A SLICE MUST BE DISCRETE AND OF THE SAME BASE + -- TYPE AS THE ARRAY INDEX. + + -- TRH 15 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B24B IS + + TYPE PIECE IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + PI : PIECE (1 .. 8) := (3, 1, 4, 1, 5, 9, 2, 6); + S1 : PIECE (1 .. 3); + S2 : PIECE (4 .. 8); + ERR : BOOLEAN := FALSE; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 0.0; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F2; + + FUNCTION F2 (X :INTEGER) RETURN CHARACTER IS + BEGIN + ERR := TRUE; + RETURN 'A'; + END F2; + + BEGIN + TEST ("C87B24B","OVERLOADING RESOLUTION OF RANGE " & + "CONSTRAINTS FOR SLICES"); + + DECLARE + FUNCTION "+" (X : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "+" (X : INTEGER) RETURN FLOAT + RENAMES F1; + + FUNCTION "-" (X : INTEGER) RETURN INTEGER + RENAMES F2; + + FUNCTION "-" (X : INTEGER) RETURN CHARACTER + RENAMES F2; + + BEGIN + S1 := PI ("+" (3) .. "-" (5)); + S1 := PI (F2 (2) .. "+" (4)); + S1 := PI ("-" (6) .. F1 (8)); + S1 := PI (F2 (1) .. F2 (3)); + S2 := PI (F2 (4) .. F1 (8)); + S2 := PI (2 .. "+" (6)); + S2 := PI (F1 (1) .. 5); + S2 := PI ("+" (3) .. "+" (7)); + + IF ERR THEN + FAILED (" OVERLOADING RESOLUTION INCORRECT FOR SLICES"); + END IF; + END; + + RESULT; + END C87B24B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b26b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C87B26B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE MAY BE + -- USED WITH THE DESIGNATED OBJECTS OF ACCESS VALUES RETURNED FROM + -- OVERLOADED FUNCTIONS, AND THAT EXPLICIT DEREFERENCING IS USED BY + -- OVERLOADING RESOLUTION TO RESOLVE THE PREFIXES OF THE ATTRIBUTES. + + -- DSJ 22 JUN 83 + -- JBG 11/22/83 + -- JBG 4/23/84 + -- JBG 5/25/85 + + WITH REPORT; WITH SYSTEM; + USE REPORT; USE SYSTEM; + + PROCEDURE C87B26B IS + + TYPE REC (D : INTEGER) IS + RECORD + C1, C2 : INTEGER; + END RECORD; + TYPE P_REC IS ACCESS REC; + + P_REC_OBJECT : P_REC := NEW REC'(1,1,1); + + TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT; + TASK TYPE TASK_TYPE IS + -- NOTHING AT ALL + END TASK_TYPE; + + TYPE P_TASK IS ACCESS TASK_TYPE; + + P_TASK_OBJECT : P_TASK; + + TASK BODY TASK_TYPE IS + BEGIN + NULL; + END TASK_TYPE; + + ------------------------------------------------------------ + + FUNCTION F RETURN REC IS + BEGIN + RETURN (0,0,0); + END F; + + FUNCTION F RETURN P_REC IS + BEGIN + RETURN P_REC_OBJECT; + END F; + + ------------------------------------------------------------ + + FUNCTION G RETURN TASK_TYPE IS + NEW_TASK : TASK_TYPE; + BEGIN + RETURN NEW_TASK; + END G; + + FUNCTION G RETURN P_TASK IS + BEGIN + RETURN P_TASK_OBJECT; + END G; + + ------------------------------------------------------------ + + BEGIN + + TEST("C87B26B","CHECK THAT EXPLICIT DEREFERENCING IN AN " & + "ATTRIBUTE PREFIX IS USED IN OVERLOADING RESOLUTION " & + "WITH 'ADDRESS, 'CONSTRAINED, 'SIZE, AND 'STORAGE_SIZE"); + + DECLARE + + A : ADDRESS; -- FOR 'ADDRESS OF RECORD + B : BOOLEAN; -- FOR 'CONSTRAINED OF RECORD + C : INTEGER; -- FOR 'SIZE OF RECORD + D : ADDRESS; -- FOR 'ADDRESS OF TASK + E : BIG_INT; -- FOR 'STORAGE_SIZE OF TASK + + BEGIN + + P_TASK_OBJECT := NEW TASK_TYPE; + A := F.ALL'ADDRESS; + B := F.ALL'CONSTRAINED; + C := F.ALL'SIZE; + D := G.ALL'ADDRESS; + E := G.ALL'STORAGE_SIZE; + + IF A /= P_REC_OBJECT.ALL'ADDRESS THEN + FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - REC"); + END IF; + + IF B /= P_REC_OBJECT.ALL'CONSTRAINED THEN + FAILED("INCORRECT RESOLUTION FOR 'CONSTRAINED"); + END IF; + + IF C /= P_REC_OBJECT.ALL'SIZE THEN + FAILED("INCORRECT RESOLUTION FOR 'SIZE"); + END IF; + + IF D /= P_TASK_OBJECT.ALL'ADDRESS THEN + FAILED("INCORRECT RESOLUTION FOR 'ADDRESS - TASK"); + END IF; + + IF E /= P_TASK_OBJECT.ALL'STORAGE_SIZE THEN + FAILED("INCORRECT RESOLUTION FOR 'STORAGE_SIZE"); + END IF; + + IF A = P_REC_OBJECT'ADDRESS THEN + FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - REC"); + END IF; + + IF C = P_REC_OBJECT'SIZE AND C /= P_REC_OBJECT.ALL'SIZE THEN + FAILED("INCORRECT DEREFERENCING FOR 'SIZE"); + END IF; + + IF D = P_TASK_OBJECT'ADDRESS THEN + FAILED("INCORRECT DEREFERENCING FOR 'ADDRESS - TASK"); + END IF; + + + END; + + RESULT; + + END C87B26B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b27a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C87B27A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE TYPE OF A STRING LITERAL MUST BE DETERMINED FROM THE FACT + -- THAT A STRING LITERAL IS A VALUE OF A ONE DIMENSIONAL ARRAY OF + -- CHARACTER COMPONENTS. + + -- TRH 18 AUG 82 + -- DSJ 07 JUN 83 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B27A IS + + TYPE ENUMLIT IS (A, B, C, D, E, F); + TYPE NEW_CHAR IS NEW CHARACTER RANGE 'G' .. 'Z'; + TYPE CHARS3 IS ('G','H','I','K','M','N','P','R','S','T'); + TYPE CHARS4 IS ('S','T','R','I','N','G','Z','A','P'); + TYPE NEW_STR IS ARRAY (A .. F) OF NEW_CHAR; + TYPE STRING3 IS ARRAY (11..16) OF CHARS3; + TYPE STRING4 IS ARRAY (21..26) OF CHARS4; + TYPE ENUM_VEC IS ARRAY (1 .. 6) OF ENUMLIT; + TYPE CHAR_GRID IS ARRAY (D .. F, 1 .. 3) OF NEW_CHAR; + TYPE STR_LIST IS ARRAY (1 .. 6) OF STRING (1 .. 1); + ERR : BOOLEAN := FALSE; + + PROCEDURE P (X : NEW_STR) IS + BEGIN + NULL; + END P; + + PROCEDURE P (X : ENUM_VEC) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : CHAR_GRID) IS + BEGIN + ERR := TRUE; + END P; + + PROCEDURE P (X : STR_LIST) IS + BEGIN + ERR := TRUE; + END P; + + BEGIN + TEST ("C87B27A","OVERLOADING RESOLUTION OF STRING LITERALS"); + + P ("STRING"); + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR STRING LITERALS"); + END IF; + + RESULT; + END C87B27A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b28a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C87B28A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE TYPE OF THE LITERAL "NULL" MUST BE DETERMINED FROM THE FACT + -- THAT "NULL" IS A VALUE OF AN ACCESS TYPE. + + -- TRH 13 AUG 82 + -- JRK 2/2/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B28A IS + + ERR : BOOLEAN := FALSE; + + TYPE A2 IS ACCESS BOOLEAN; + TYPE A3 IS ACCESS INTEGER; + TYPE A1 IS ACCESS A2; + + FUNCTION F RETURN A1 IS + BEGIN + RETURN NEW A2; + END F; + + FUNCTION F RETURN A2 IS + BEGIN + ERR := TRUE; + RETURN NEW BOOLEAN; + END F; + + FUNCTION F RETURN A3 IS + BEGIN + ERR := TRUE; + RETURN (NEW INTEGER); + END F; + + BEGIN + TEST ("C87B28A", "OVERLOADING OF THE ACCESS TYPE LITERAL 'NULL'"); + + F.ALL := NULL; + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR THE ACCESS TYPE LITERAL " & + "'NULL'"); + END IF; + + RESULT; + END C87B28A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b29a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C87B29A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- AGGREGATES CONTAINING A SINGLE COMPONENT ASSOCIATION MUST + -- USE ONLY NAMED NOTATION. + + -- TRH 4 AUG 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B29A IS + + TYPE VECTOR IS ARRAY (1 .. 1) OF INTEGER; + + TYPE REC IS + RECORD + X : INTEGER; + END RECORD; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P1 (X : INTEGER) IS + BEGIN + NULL; + END P1; + + PROCEDURE P1 (X : VECTOR) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : REC) IS + BEGIN + ERR := TRUE; + END P1; + + BEGIN + TEST ("C87B29A","AGGREGATES CONTAINING A SINGLE COMPONENT " & + "ASSOCIATION MUST USE NAMED NOTATION"); + + P1 ( (0) ); -- INTEGER PARAMETER, NOT AN AGGREGATE PARAMETER + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT - AGGREGATES WITH A SINGLE " & + "COMPONENT ASSOCIATION MUST USE NAMED NOTATION"); + END IF; + + RESULT; + END C87B29A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b30a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C87B30A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE EXPRESSION OF A COMPONENT ASSOCIATION MUST MATCH THE TYPE OF THE + -- ASSOCIATED RECORD COMPONENT. + + -- TRH 9 AUG 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B30A IS + + TYPE REC IS + RECORD + W, X : FLOAT; + Y, Z : INTEGER; + END RECORD; + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("COMPONENT ASSOCIATION EXPRESSION MUST MATCH " & + "RECORD COMPONENT TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL); + + FUNCTION G IS NEW F1 (FLOAT, 2.0, FAIL); + FUNCTION G IS NEW F1 (INTEGER, 5, PASS); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION G IS NEW F1 (CHARACTER, 'E', FAIL); + + BEGIN + TEST ("C87B30A","OVERLOADED EXPRESSIONS IN RECORD AGGREGATE " & + "COMPONENT ASSOCIATIONS"); + + DECLARE + R1 : REC := (F, F, G, G); + R2 : REC := (X => F, Y => G, Z => G, W => F); + R3 : REC := (F, F, Z => G, Y => G); + + BEGIN + NULL; + END; + + RESULT; + END C87B30A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b31a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- C87B31A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IF THE TYPE OF AN AGGREGATE IS A ONE-DIMENSIONAL ARRAY TYPE + -- THEN EACH CHOICE MUST SPECIFY VALUES OF THE INDEX TYPE, AND + -- THE EXPRESSION OF EACH COMPONENT ASSOCIATION MUST BE OF THE + -- COMPONENT TYPE. + + -- TRH 8 AUG 82 + -- DSJ 15 JUN 83 + -- JRK 2 FEB 84 + -- JBG 4/23/84 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B31A IS + + TYPE LETTER IS NEW CHARACTER RANGE 'A' .. 'Z'; + TYPE NOTE IS (A, B, C, D, E, F, G, H); + TYPE STR IS NEW STRING (1 .. 1); + TYPE BIT IS NEW BOOLEAN; + TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE BOOLEAN IS (FALSE, TRUE); + TYPE LIST IS ARRAY (CHARACTER RANGE <>) OF BIT; + TYPE FLAG IS (PASS, FAIL); + + SUBTYPE LIST_A IS LIST('A'..'A'); + SUBTYPE LIST_E IS LIST('E'..'E'); + SUBTYPE LIST_AE IS LIST('A'..'E'); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSIONS " & + "IN ARRAY AGGREGATES"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (YES, TRUE, FAIL); + FUNCTION F IS NEW F1 (NO, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, PASS); + + FUNCTION G IS NEW F1 (CHARACTER, 'A', PASS); + FUNCTION G IS NEW F1 (LETTER, 'A', FAIL); + FUNCTION G IS NEW F1 (STR, "A", FAIL); + + FUNCTION H IS NEW F1 (CHARACTER, 'E', PASS); + FUNCTION H IS NEW F1 (LETTER, 'E', FAIL); + FUNCTION H IS NEW F1 (STR, "E", FAIL); + + BEGIN + TEST ("C87B31A", "OVERLOADED EXPRESSIONS IN ARRAY AGGREGATES"); + + DECLARE + L1, L2 : LIST_A := (OTHERS => FALSE); + L3, L4 : LIST_E := (OTHERS => FALSE); + L5, L6 : LIST_AE := (OTHERS => FALSE); + L7, L8 : LIST_AE := (OTHERS => FALSE); + + BEGIN + L1 := ('A' => F); + L2 := ( G => F); + L3 := ('E' => F); + L4 := ( H => F); + L5 := ('A'..'E' => F); + L6 := (F,F,F,F,F); + L7 := (F,F,F, OTHERS => F); + L8 := LIST_AE'('E' => F, 'B' => F, OTHERS => F); + + IF L1 /= LIST_A'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L1"); + END IF; + IF L2 /= LIST_A'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L2"); + END IF; + IF L3 /= LIST_E'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L3"); + END IF; + IF L4 /= LIST_E'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L4"); + END IF; + IF L5 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L5"); + END IF; + IF L6 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L6"); + END IF; + IF L7 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L7"); + END IF; + IF L8 /= LIST_AE'(OTHERS => TRUE) THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED" & + " EXPRESSIONS IN ARRAY AGGREGATES - L8"); + END IF; + END; + + RESULT; + END C87B31A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b32a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,199 ---- + -- C87B32A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE FOLLOWING RULES: + + -- FOR ATTRIBUTES OF THE FORM: T'SUCC (X), T'PRED (X), T'POS (X), + -- AND T'IMAGE (X) , THE OPERAND X MUST BE OF TYPE T. + -- + -- FOR THE ATTRIBUTE OF THE FORM T'VAL (X), THE OPERAND X MUST BE + -- OF AN INTEGER TYPE. + -- + -- FOR THE ATTRIBUTE OF THE FORM T'VALUE (X), THE OPERAND X MUST + -- BE OF THE PREDEFINED TYPE STRING. + + -- TRH 13 SEPT 82 + -- JRK 12 JAN 84 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B32A IS + + TYPE COLOR IS (BROWN, RED, WHITE); + TYPE SCHOOL IS (HARVARD, BROWN, YALE); + TYPE COOK IS (SIMMER, SAUTE, BROWN, BOIL); + TYPE SUGAR IS (DEXTROSE, CANE, GLUCOSE, BROWN); + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE LIT_CHAR IS ('+', '-', '0', '1', '2', '3', '4', '5', '6', '7', + '8', '9'); + TYPE LIT_STRING IS ARRAY (POSITIVE RANGE <>) OF LIT_CHAR; + + FUNCTION "+" (X, Y : WHOLE) RETURN WHOLE + RENAMES "*"; + + FUNCTION F1 RETURN STRING IS + BEGIN + RETURN "+10"; + END F1; + + FUNCTION F1 RETURN LIT_STRING IS + BEGIN + FAILED ("THE VALUE ATTRIBUTE TAKES A PREDEFINED STRING " & + "OPERAND"); + RETURN "+3"; + END F1; + + FUNCTION F1 RETURN CHARACTER IS + BEGIN + FAILED ("THE VALUE ATTRIBUTE TAKES A STRING OPERAND"); + RETURN '2'; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN FLOAT IS + BEGIN + FAILED ("THE VAL ATTRIBUTE TAKES AN INTEGER TYPE OPERAND"); + RETURN 0.0; + END F2; + + FUNCTION F2 (X : INTEGER := 1) RETURN INTEGER IS + BEGIN + RETURN X; + END F2; + + BEGIN + TEST ("C87B32A","OVERLOADED OPERANDS FOR THE ATTRIBUTES " & + "T'PRED, T'SUCC, T'POS, T'VAL, T'IMAGE AND T'VALUE"); + + IF COLOR'POS (BROWN) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 1"); + END IF; + + IF SCHOOL'POS (BROWN) /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 2"); + END IF; + + IF COOK'POS (BROWN) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 3"); + END IF; + + IF SUGAR'POS (BROWN) /= 3 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 4"); + END IF; + + IF SCHOOL'PRED (BROWN) /= HARVARD THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 5"); + END IF; + + IF COOK'PRED (BROWN) /= SAUTE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 6"); + END IF; + + IF SUGAR'PRED (BROWN) /= GLUCOSE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 7"); + END IF; + + IF COLOR'SUCC (BROWN) /= RED THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 8"); + END IF; + + IF SCHOOL'SUCC (BROWN) /= YALE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 9"); + END IF; + + IF COOK'SUCC (BROWN) /= BOIL THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 10"); + END IF; + + IF COLOR'VAL (F2 (0)) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 11"); + END IF; + + IF SCHOOL'VAL (F2) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 12"); + END IF; + + IF COOK'VAL (F2 (2)) /= BROWN THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 13"); + END IF; + + IF SUGAR'VAL (F2) /= CANE THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 14"); + END IF; + + IF WHOLE'POS (1 + 1) /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 15"); + END IF; + + IF WHOLE'VAL (1 + 1) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 16"); + END IF; + + IF WHOLE'SUCC (1 + 1) /= 2 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 17"); + END IF; + + IF WHOLE'PRED (1 + 1) /= 0 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 18"); + END IF; + + IF WHOLE'VALUE ("+1") + 1 /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 19"); + END IF; + + IF WHOLE'IMAGE (1 + 1) /= " 1" THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 20"); + END IF; + + IF WHOLE'VALUE (F1) + 1 /= 10 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 21"); + END IF; + + IF WHOLE'VAL (1) + 1 /= 1 THEN + FAILED ("RESOLUTION INCORRECT FOR OPERANDS OF THE ATTRIBUTES" & + " PRED, SUCC, VAL, POS, IMAGE AND VALUE - 22"); + END IF; + + RESULT; + END C87B32A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b33a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C87B33A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE SHORT CIRCUIT CONTROL FORMS "AND THEN" AND "OR ELSE" ARE + -- DEFINED AS BINARY BOOLEAN OPERATORS WHICH RETURN A BOOLEAN VALUE + -- OF THE SAME TYPE AS THE OPERANDS. + + -- TRH 13 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B33A IS + + TYPE ON IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE OFF IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE YES IS NEW ON; + TYPE NO IS NEW OFF; + TYPE BIT IS NEW BOOLEAN; + TYPE FLAG IS (PASS, FAIL); + + TYPE BOOLEAN IS (FALSE, TRUE); -- STANDARD BOOLEAN HIDDEN. + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT " & + "CONTROL FORMS 'AND THEN' AND 'OR ELSE' "); + END IF; + RETURN ARG; + END F1; + + FUNCTION A IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION A IS NEW F1 (NO, FALSE, PASS); + FUNCTION A IS NEW F1 (ON, TRUE, FAIL); + FUNCTION A IS NEW F1 (YES, TRUE, FAIL); + FUNCTION B IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION B IS NEW F1 (NO, FALSE, FAIL); + FUNCTION B IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION B IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION C IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION C IS NEW F1 (YES, TRUE, PASS); + FUNCTION C IS NEW F1 (ON, TRUE, FAIL); + FUNCTION C IS NEW F1 (NO, FALSE, FAIL); + FUNCTION D IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION D IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION D IS NEW F1 (YES, TRUE, FAIL); + FUNCTION D IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION E IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION E IS NEW F1 (BIT, TRUE, PASS); + FUNCTION E IS NEW F1 (YES, TRUE, FAIL); + FUNCTION E IS NEW F1 (NO, FALSE, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, PASS); + FUNCTION F IS NEW F1 (ON, TRUE, FAIL); + FUNCTION F IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION G IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION G IS NEW F1 (BIT, FALSE, PASS); + FUNCTION G IS NEW F1 (NO, FALSE, FAIL); + FUNCTION G IS NEW F1 (YES, TRUE, FAIL); + FUNCTION H IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION H IS NEW F1 (BIT, FALSE, PASS); + FUNCTION H IS NEW F1 (OFF, FALSE, FAIL); + FUNCTION H IS NEW F1 (ON, TRUE, FAIL); + + BEGIN + TEST ("C87B33A","OVERLOADED OPERANDS FOR SHORT CIRCUIT CONTROL " & + "FORMS 'AND THEN' AND 'OR ELSE' "); + + IF (A AND THEN B) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - A&B"); + END IF; + + IF NOT (C OR ELSE D) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - C&D"); + END IF; + + IF NOT (E AND THEN F AND THEN E + AND THEN F AND THEN E AND THEN F) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - E&F"); + END IF; + + IF (G OR ELSE H OR ELSE G + OR ELSE H OR ELSE G OR ELSE H) THEN + FAILED ("RESOLUTION INCORRECT FOR SHORT CIRCUIT FORMS - G&H"); + END IF; + + RESULT; + END C87B33A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,68 ---- + -- C87B34A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE MEMBERSHIP TESTS "IN" AND "NOT IN" RESULT IN THE PREDEFINED + -- TYPE BOOLEAN. + + -- TRH 4 AUG 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B34A IS + + TYPE BIT IS NEW BOOLEAN; + TYPE FLAG IS NEW BOOLEAN; + + ERR : BOOLEAN := FALSE; + + PROCEDURE P1 (X : BIT) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : FLAG) IS + BEGIN + ERR := TRUE; + END P1; + + PROCEDURE P1 (X : BOOLEAN) IS + BEGIN + NULL; + END P1; + + BEGIN + TEST ("C87B34A","MEMBERSHIP TESTS 'IN' AND 'NOT IN' RETURN " & + "TYPE PREDEFINED BOOLEAN"); + + P1 (3 IN 1 .. 5); + P1 (3 NOT IN 1 .. 5); + + IF ERR THEN + FAILED ("MEMBERSHIP TESTS MUST RETURN PREDEFINED BOOLEAN TYPE"); + END IF; + + RESULT; + END C87B34A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C87B34B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- THE "IN" (OR MEMBERSHIP) OPERATOR OF THE FORM: X IN L .. R + -- REQUIRES THE OPERANDS X, L AND R TO BE OF THE SAME SCALAR TYPE. + + -- TRH 19 JULY 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B34B IS + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR 'IN' MEMBERSHIP TEST"); + END IF; + RETURN ARG; + END F1; + + FUNCTION X IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION L IS NEW F1 (FLOAT, -1.0, PASS); + FUNCTION R IS NEW F1 (FLOAT, 1.0, PASS); + FUNCTION X IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION L IS NEW F1 (INTEGER, 1, FAIL); + FUNCTION L IS NEW F1 (CHARACTER, 'A', FAIL); + FUNCTION R IS NEW F1 (CHARACTER, 'E', FAIL); + FUNCTION X IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION R IS NEW F1 (BOOLEAN, TRUE, FAIL); + + BEGIN + TEST ("C87B34B","OVERLOADED MEMBERSHIP OPERANDS"); + + IF X IN L .. R THEN + FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP OPERATOR"); + END IF; + + RESULT; + END C87B34B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b34c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C87B34C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- FOR A MEMBERSHIP RELATION WITH A TYPEMARK, THE TYPE OF THE + -- SIMPLE EXPRESSION MUST BE THE BASE TYPE OF THE TYPEMARK. + + -- TRH 15 SEPT 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B34C IS + + TYPE VOWEL IS (A, E, I, O, U, VOCALIC_Y); + TYPE ALPHA IS (A, 'A'); + TYPE GRADE IS (A, B, C, D, F); + SUBTYPE BAD_GRADE IS GRADE RANGE D .. F; + SUBTYPE PASSING IS GRADE RANGE A .. C; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + FAILED ("RESOLUTION INCORRECT - EXPRESSION IN MEMBER" & + "SHIP TEST WITH TYPEMARK MUST MATCH TYPEMARK"); + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (CHARACTER, 'A'); + FUNCTION F IS NEW F1 (DURATION, 1.0); + FUNCTION F IS NEW F1 (INTEGER, -10); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE); + FUNCTION F IS NEW F1 (FLOAT, 1.0); + FUNCTION F IS NEW F1 (VOWEL, A); + FUNCTION F IS NEW F1 (ALPHA, A); + + BEGIN + TEST ("C87B34C","OVERLOADED EXPRESSION IN MEMBERSHIP TEST " & + "WITH A TYPEMARK"); + + IF (F NOT IN GRADE) OR (F NOT IN BAD_GRADE) + OR (F IN PASSING) THEN + FAILED ("RESOLUTION INCORRECT FOR MEMBERSHIP TEST " & + "WITH TYPEMARK"); + END IF; + + RESULT; + + END C87B34C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b35c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C87B35C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE EXPONENT OPERAND OF A FLOATING POINT EXPONENTIATION MUST BE + -- OF THE TYPE PREDEFINED INTEGER. + + -- TRH 4 AUG 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B35C IS + + TYPE FIXED IS DELTA 0.01 RANGE 0.0 .. 4.0; + ERR : BOOLEAN := FALSE; + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN 1.0; + END F1; + + FUNCTION F1 (X : INTEGER) RETURN FIXED IS + BEGIN + ERR := TRUE; + RETURN 1.0; + END F1; + + BEGIN + TEST ("C87B35C","EXPONENT OPERAND FOR FLOATING POINT " & + "EXPONENTIATION MUST BE OF TYPE PREDEFINED INTEGER"); + + DECLARE + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES STANDARD."*"; + + BEGIN + IF ( FLOAT'(2.0) ** F1(3) /= 8.0 OR + FLOAT'(2.0) ** (3 + 1) /= 8.0 ) THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION " + & "MUST BE PREDEFINED INTEGER (A)"); + END IF; + IF ( 2.0 ** F1(3) /= FLOAT'(8.0) OR + 2.0 ** (3 + 1) /= FLOAT'(8.0) ) THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION" + & "MUST BE PREDEFINED INTEGER (B)"); + END IF; + IF ERR THEN + FAILED ("EXPONENT OF FLOATING POINT EXPONENTIATION" + & "MUST BE PREDEFINED INTEGER (C)"); + END IF; + END; + + RESULT; + END C87B35C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b38a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- C87B38A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + + -- IN A QUALIFIED EXPRESSION, THE OPERAND MUST HAVE THE SAME TYPE + -- AS THE BASE TYPE OF THE TYPEMARK. + + -- TRH 13 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B38A IS + + SUBTYPE BOOL IS BOOLEAN; + TYPE YES IS NEW BOOLEAN RANGE TRUE .. TRUE; + TYPE NO IS NEW BOOLEAN RANGE FALSE .. FALSE; + TYPE BIT IS NEW BOOLEAN; + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED " & + " OPERANDS OF QUALIFIED EXPRESSIONS"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (LIT, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, TRUE, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, PASS); + FUNCTION F IS NEW F1 (YES, TRUE, FAIL); + FUNCTION F IS NEW F1 (NO, FALSE, FAIL); + + BEGIN + TEST ("C87B38A","OVERLOADED OPERANDS IN QUALIFIED EXPRESSIONS "); + + DECLARE + B : BOOL; + + BEGIN + B := BOOL' (F); + B := BOOL' ((NOT F) OR ELSE (F AND THEN F)); + END; + + RESULT; + END C87B38A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b39a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C87B39A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT: + + -- A) AN OVERLOADED CALL CAN BE RESOLVED BECAUSE AN ALLOCATOR RETURNS + -- AN ACCESS TYPE WHOSE DESIGNATED TYPE IS THE TYPE REFERRED TO IN + -- THE ALLOCATOR. + -- + -- B) IF THE NAME OF THE DESIGNATED TYPE IN AN ALLOCATOR DOES NOT + -- UNIQUELY DETERMINE THE ACCESS TYPE OF AN ALLOCATOR, THE CONTEXT + -- MUST DETERMINE THE TYPE. + + -- JBG 1/30/84 + + WITH REPORT; USE REPORT; + PROCEDURE C87B39A IS + + TYPE S IS (M, F); + TYPE R (D : S) IS + RECORD NULL; END RECORD; + SUBTYPE M1 IS R(M); + SUBTYPE M2 IS R(M); + + TYPE ACC_M1 IS ACCESS M1; + TYPE ACC_M2 IS ACCESS M2; + TYPE ACC_BOOL IS ACCESS BOOLEAN; + TYPE ACC_ACC_M1 IS ACCESS ACC_M1; + + TYPE WHICH IS (IS_M1, IS_M2, IS_BOOL); + + PROCEDURE P (X : ACC_M1; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_M1 THEN + FAILED ("INCORRECT RESOLUTION -- ACC_M1"); + END IF; + END P; -- ACC_M1 + + PROCEDURE P (X : ACC_M2; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_M2 THEN + FAILED ("INCORRECT RESOLUTION -- ACC_M2"); + END IF; + END P; -- ACC_M2 + + PROCEDURE P (X : ACC_BOOL; RESOLUTION : WHICH) IS + BEGIN + IF RESOLUTION /= IS_BOOL THEN + FAILED ("INCORRECT RESOLUTION -- ACC_BOOL"); + END IF; + END P; -- ACC_BOOL + + PROCEDURE P (X : ACC_ACC_M1; RESOLUTION : WHICH) IS + BEGIN + FAILED ("INCORRECT RESOLUTION -- ACC_ACC_M1"); + END P; -- ACC_ACC_M1 + + PROCEDURE Q (X : ACC_M1) IS + BEGIN + NULL; + END Q; -- ACC_M1 + + PROCEDURE Q (X : ACC_BOOL) IS + BEGIN + FAILED ("INCORRECT RESOLUTION -- ACC_BOOL: Q"); + END Q; -- ACC_BOOL + + BEGIN + + TEST ("C87B39A", "OVERLOADING RESOLUTION FOR ALLOCATORS"); + + P (ACC_M1'(NEW R(M)), IS_M1); -- B + + P (ACC_M2'(NEW M1), IS_M2); -- B + + P (NEW BOOLEAN'(TRUE), IS_BOOL); -- A + + Q (NEW M2); -- A + Q (NEW M1); -- A + Q (NEW R(M)); -- A + Q (NEW R'(D => M)); -- A + + RESULT; + + END C87B39A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b40a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C87B40A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE FOLLOWING RULES: + -- + -- THE SAME OPERATIONS ARE PREDEFINED FOR THE TYPE UNIVERSAL_INTEGER + -- AS FOR ANY INTEGER TYPE. THE SAME OPERATIONS ARE PREDEFINED FOR THE + -- TYPE UNIVERSAL_REAL AS FOR ANY FLOATING POINT TYPE. IN ADDITION + -- THESE OPERATIONS INCLUDE THE FOLLOWING MULTIPLICATION AND DIVISION + -- OPERATORS: + -- + -- "*" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL + -- "*" (UNIVERSAL_INTEGER, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL + -- "*" (UNIVERSAL_REAL, UNIVERSAL_REAL) RETURN UNIVERSAL_REAL + -- "*" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER + -- "/" (UNIVERSAL_REAL, UNIVERSAL_INTEGER) RETURN UNIVERSAL_REAL + -- "**" (UNIVERSAL_INTEGER, INTEGER) RETURN UNIVERSAL_INTEGER + -- "**" (UNIVERSAL_REAL, INTEGER) RETURN UNIVERSAL_REAL + -- "MOD" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER + -- "DIV" (UNIVERSAL_INTEGER, UNIVERSAL_INTEGER) RETURN UNIVERSAL_INTEGER + -- "ABS" (UNIVERSAL_INTEGER) RETURN UNIVERSAL INTEGER + -- "ABS" (UNIVERSAL_REAL) RETURN UNIVERSAL_REAL + + -- TRH 15 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B40A IS + + ERR : BOOLEAN := FALSE; + B : ARRAY (1 .. 12) OF BOOLEAN := (1 .. 12 => TRUE); + + FUNCTION "-" (X : INTEGER) RETURN INTEGER + RENAMES STANDARD."+"; + + FUNCTION "+" (X : INTEGER) RETURN INTEGER IS + BEGIN + ERR := TRUE; + RETURN X; + END "+"; + + FUNCTION "+" (X : FLOAT) RETURN FLOAT IS + BEGIN + ERR := TRUE; + RETURN X; + END "+"; + + BEGIN + TEST ("C87B40A","OVERLOADING RESOLUTION OF UNIVERSAL " & + "EXPRESSIONS"); + + B(1) := 1.0 * (+1) IN 0.0 .. 0.0; -- 1.0 * 1 + B(2) := (+1) * 1.0 IN 0.0 .. 0.0; -- 1 * 1.0 + B(3) := 1.0 / (+1) IN 0.0 .. 0.0; -- 1.0 / 1 + B(4) := (+1) + (+1) <= (+1) - (+1); -- 1+1< 1 - 1 + B(5) := (+1) * (+1) > (+1) / (+1); -- 1*1 > 1/1 + B(6) := (+1) MOD (+1) /= (+1) REM (+1); -- 1 MOD 1 /= 1 REM 1 + + BEGIN + B(7) := (+2) ** (-2) < "-" (-1); -- 2**2 < 1 + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("INCORRECT RESOLUTION FOR INTEGER EXPONENT - 7"); + END; + + B(8) := (+1) REM (+1) > "ABS" (+1); -- 1 REM 1 > ABS 1 + B(9) := (+1.0) + (+1.0) <= (+1.0) - (+1.0); -- 2.0 <= 0.0 + B(10) := (+1.0) * (+1.0) > (+1.0) / (+1.0); -- 1.0 > 1.0 + B(11) := (+2.0) ** (-1) < "-" (-1.0); -- 2.0 < 1.0 + B(12) := (+2.0) ** (-1) <= "ABS" (+1.0); -- 2.0 <= 1.0 + + FOR I IN B'RANGE + LOOP + IF B(I) /= FALSE THEN + FAILED("RESOLUTION OR OPERATIONS INCORRECT FOR " + & "UNIVERSAL EXPRESSIONS - " & INTEGER'IMAGE(I) ); + END IF; + END LOOP; + + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR UNIVERSAL EXPRESSIONS"); + END IF; + + RESULT; + END C87B40A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b41a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C87B41A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE NAMED VARIABLE AND THE RIGHT HAND SIDE EXPRESSION + -- IN AN ASSIGNMENT STATEMENT MUST BE OF THE SAME TYPE. THIS TYPE + -- MUST NOT BE A LIMITED TYPE. + + -- TRH 15 SEPT 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B41A IS + + TYPE NOTE IS (A, B, C, D, E, F, G); + TYPE POSITIVE IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE ACC_CHAR IS ACCESS CHARACTER; + TYPE ACC_DUR IS ACCESS DURATION; + TYPE ACC_POS IS ACCESS POSITIVE; + TYPE ACC_INT IS ACCESS INTEGER; + TYPE ACC_BOOL IS ACCESS BOOLEAN; + TYPE ACC_STR IS ACCESS STRING; + TYPE ACC_FLT IS ACCESS FLOAT; + TYPE ACC_NOTE IS ACCESS NOTE; + + TYPE NEW_CHAR IS NEW CHARACTER; + TYPE NEW_DUR IS NEW DURATION; + TYPE NEW_POS IS NEW POSITIVE; + TYPE NEW_INT IS NEW INTEGER; + TYPE NEW_BOOL IS NEW BOOLEAN; + TYPE NEW_FLT IS NEW FLOAT; + TYPE NEW_NOTE IS NEW NOTE RANGE A .. F; + TASK TYPE T; + + TASK BODY T IS + BEGIN + NULL; + END T; + + FUNCTION G RETURN T IS + T1 : T; + BEGIN + FAILED ("LIMITED TYPES MAY NOT OCCUR IN ASSIGNMENT " & + "STATEMENTS"); + RETURN T1; + END G; + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + FAILED ("RESOLUTION INCORRECT - RIGHT HAND SIDE OF " & + "ASSIGNMENT STATEMENT MUST MATCH TYPE OF VARIABLE"); + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (ACC_CHAR, NEW CHARACTER); + FUNCTION F IS NEW F1 (ACC_DUR, NEW DURATION); + FUNCTION F IS NEW F1 (ACC_POS, NEW POSITIVE); + FUNCTION F IS NEW F1 (ACC_INT, NEW INTEGER); + FUNCTION F IS NEW F1 (ACC_BOOL, NEW BOOLEAN); + FUNCTION F IS NEW F1 (ACC_STR, NEW STRING(1..2) ); + FUNCTION F IS NEW F1 (ACC_FLT, NEW FLOAT); + + FUNCTION F RETURN ACC_NOTE IS + BEGIN + RETURN (NEW NOTE); + END F; + + FUNCTION G IS NEW F1 (NEW_CHAR, 'G'); + FUNCTION G IS NEW F1 (NEW_DUR, 1.0); + FUNCTION G IS NEW F1 (NEW_POS, +10); + FUNCTION G IS NEW F1 (NEW_INT, -10); + FUNCTION G IS NEW F1 (NEW_BOOL, TRUE); + FUNCTION G IS NEW F1 (NEW_FLT, 1.0); + FUNCTION G IS NEW F1 (NEW_NOTE, F); + + BEGIN + TEST ("C87B41A","OVERLOADED CONSTRUCTS ON BOTH SIDES OF THE " & + "ASSIGNMENT STATEMENT"); + + F.ALL := G; + + RESULT; + + END C87B41A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b42a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C87B42A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- A CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN TYPE. + + -- TRH 27 JULY 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B42A IS + + TYPE BIT IS NEW BOOLEAN; + TYPE BOOLEAN IS (FALSE, TRUE); + TYPE LIT IS (FALSE, TRUE); + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("CONDITIONAL EXPRESSION MUST BE OF A BOOLEAN" & + " TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (BOOLEAN, FALSE, FAIL); + FUNCTION F IS NEW F1 (BIT, FALSE, PASS); + FUNCTION F IS NEW F1 (LIT, FALSE, FAIL); + FUNCTION F IS NEW F1 (INTEGER, -11, FAIL); + FUNCTION F IS NEW F1 (FLOAT, +0.0, FAIL); + + BEGIN + TEST ("C87B42A","OVERLOADED CONDITIONAL EXPRESSIONS"); + + WHILE (F OR NOT F) + LOOP + IF (F OR ELSE NOT F) THEN + NULL; + END IF; + EXIT WHEN (F AND NOT F); + EXIT WHEN (F OR NOT F); + EXIT WHEN (F); + EXIT WHEN (NOT F); + END LOOP; + + RESULT; + END C87B42A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b43a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- C87B43A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A CASE STATEMENT, THE TYPE OF EACH CHOICE MUST MATCH THE TYPE + -- OF THE EXPRESSION. + + -- TRH 3 AUG 82 + -- DSJ 10 JUN 83 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B43A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER + RENAMES "*"; + + ERR : BOOLEAN := FALSE; + X : WHOLE := 6; + + BEGIN + TEST ("C87B43A","TYPE OF CASE CHOICE MUST MATCH TYPE OF " & + "EXPRESSION"); + + CASE X IS + WHEN (2 + 3) => ERR := TRUE; + WHEN (3 + 3) => NULL; + WHEN OTHERS => ERR := TRUE; + END CASE; + + IF ERR THEN + FAILED ("CASE STATEMENT CHOICE MUST MATCH TYPE OF EXPRESSION"); + END IF; + + RESULT; + END C87B43A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b44a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C87B44A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE TYPE OF THE EXPRESSION IN A RETURN STATEMENT MUST MATCH THE + -- EXPLICIT TYPEMARK IN THE RETURN CLAUSE OF THE FUNCTION'S + -- SPECIFICATION. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 25 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B44A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END "*"; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END "*"; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B44A","OVERLOADED EXPRESSIONS IN RETURN STATEMENTS"); + DECLARE + + FUNCTION F2 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN F1 (X, Y); + END F2; + + FUNCTION F2 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN "*" (X, Y); + END F2; + + FUNCTION F2 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN (X * Y); + END F2; + + FUNCTION F2 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F2; + + + BEGIN + IF INTEGER'(F2 (0, 0)) /= -1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF WHOLE'(F2 (0, 0)) /= 0 THEN + FAILED ("(B): RESOLUTION INCORRECT - OPERATOR SYMBOL"); + END IF; + + IF HUE'POS (F2 (0, 0)) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (F2 (0, 0)) /= 2 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION LITERAL"); + END IF; + END; + + RESULT; + END C87B44A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b45a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- C87B45A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR A DEFAULT SUBPROGRAM PARAMETER, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 24 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B45A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B45A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT SUBPROGRAM PARAMETERS"); + DECLARE + + FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + PROCEDURE P1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "/" (0, 0); + W2 : WHOLE := "/" (0, 0); + C2 : CITRUS := "/" (0, 0); + H2 : HUE := "/" (0, 0); + I3 : INTEGER := (0 / 0); + W3 : WHOLE := (0 / 0); + C3 : CITRUS := (0 / 0); + H3 : HUE := (0 / 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE) IS + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " & + "LITERAL"); + END IF; + END P1; + + BEGIN + P1; + END; + + RESULT; + END C87B45A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b45c.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- C87B45C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR A DEFAULT ENTRY PARAMETER, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 7 JULY 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B45C IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B45C","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT ENTRY PARAMETERS"); + DECLARE + + FUNCTION "*" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "*" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "*" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + TASK T1 IS + ENTRY E1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "*" (0, 0); + W2 : WHOLE := "*" (0, 0); + C2 : CITRUS := "*" (0, 0); + H2 : HUE := "*" (0, 0); + I3 : INTEGER := (0 * 0); + W3 : WHOLE := (0 * 0); + C3 : CITRUS := (0 * 0); + H3 : HUE := (0 * 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "*" (0, 0); + W2 : WHOLE := "*" (0, 0); + C2 : CITRUS := "*" (0, 0); + H2 : HUE := "*" (0, 0); + I3 : INTEGER := (0 * 0); + W3 : WHOLE := (0 * 0); + C3 : CITRUS := (0 * 0); + H3 : HUE := (0 * 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE) DO + + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX " & + "OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - " & + "ENUMERATION LITERAL"); + END IF; + + END E1; + END T1; + + BEGIN + T1.E1; + END; + + RESULT; + END C87B45C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b47a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C87B47A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- ACTUAL PARAMETERS MUST MATCH THE EXPLICIT TYPEMARK OF THE + -- PARAMETER. + + -- TRH 8 AUG 82 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B47A IS + + TYPE FLAG IS (PASS, FAIL); + + GENERIC + TYPE T IS PRIVATE; + ARG : IN T; + STAT : IN FLAG; + FUNCTION F1 RETURN T; + + FUNCTION F1 RETURN T IS + BEGIN + IF STAT = FAIL THEN + FAILED ("ACTUAL PARAMETER MUST MATCH PARAMETER TYPE"); + END IF; + RETURN ARG; + END F1; + + FUNCTION F IS NEW F1 (FLOAT, 2.0, PASS); + FUNCTION F IS NEW F1 (INTEGER, 5, FAIL); + FUNCTION F IS NEW F1 (BOOLEAN, TRUE, FAIL); + FUNCTION F IS NEW F1 (DURATION, 1.0, FAIL); + FUNCTION F IS NEW F1 (CHARACTER, 'E', FAIL); + + BEGIN + TEST ("C87B47A","OVERLOADED ACTUAL PARAMETERS"); + + DECLARE + PROCEDURE P (X : FLOAT) IS + BEGIN + NULL; + END P; + + BEGIN + P (F); + P (X => F); + END; + + RESULT; + END C87B47A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b48a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C87B48A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- NAMED ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS. + -- THIS TEST USES FUNCTIONS AND OPERATOR SYMBOLS ONLY. + + -- TRH 13 AUG 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B48A IS + + ERR, B1, B2 : BOOLEAN := FALSE; + + PACKAGE A IS + FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (X : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END A; + + PACKAGE BODY A IS + FUNCTION "-" (X : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT X; + END "-"; + END A; + + PACKAGE B IS + FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (Y : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END B; + + PACKAGE BODY B IS + FUNCTION "-" (Y : BOOLEAN) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN NOT Y; + END "-"; + END B; + + PACKAGE C IS + FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN; + FUNCTION TOGGLE (Z : BOOLEAN) RETURN BOOLEAN + RENAMES "-"; + END C; + + PACKAGE BODY C IS + FUNCTION "-" (Z : BOOLEAN) RETURN BOOLEAN IS + BEGIN + ERR := TRUE; + RETURN NOT Z; + END "-"; + END C; + + USE A, B, C; + + BEGIN + TEST ("C87B48A","RESOLUTION OF OVERLOADED SUBPROGRAMS BY NAMED " & + "ACTUAL PARAMETERS"); + + B1 := "-" (X => FALSE); + B2 := TOGGLE (X => FALSE); + + IF ERR OR ELSE NOT B1 OR ELSE NOT B2 THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUBPROGRAMS" & + " WITH NAMED ACTUAL PARAMETERS"); + END IF; + + RESULT; + END C87B48A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b48b.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C87B48B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- POSITIONAL ACTUAL PARAMETERS CAN RESOLVE OVERLOADING OF SUBPROGRAMS. + + -- TRH 16 AUG 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B48B IS + + TYPE FLAG IS (PASS, FAIL); + TYPE INT IS NEW INTEGER; + TYPE BIT IS NEW BOOLEAN; + TYPE WHL IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + + GENERIC + TYPE T1 IS PRIVATE; + TYPE T2 IS PRIVATE; + TYPE T3 IS PRIVATE; + TYPE T4 IS PRIVATE; + STAT : IN FLAG; + PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4); + + PROCEDURE P1 (W : T1; X : T2; Y : T3; Z : T4) IS + BEGIN + IF STAT = FAIL THEN + FAILED ("RESOLUTION INCORRECT FOR OVERLOADED SUB" & + "PROGRAMS WITH POSITIONAL ACTUAL PARAMETERS"); + END IF; + END P1; + + PROCEDURE P IS NEW P1 (WHL, INT, WHL, BIT, PASS); + PROCEDURE P IS NEW P1 (WHL, WHL, BIT, INT, FAIL); + PROCEDURE P IS NEW P1 (WHL, INT, BIT, WHL, FAIL); + PROCEDURE P IS NEW P1 (INT, BIT, WHL, WHL, FAIL); + PROCEDURE P IS NEW P1 (BIT, WHL, WHL, INT, FAIL); + PROCEDURE P IS NEW P1 (BIT, INT, WHL, WHL, FAIL); + + BEGIN + TEST ("C87B48B","OVERLOADING RESOLUTION OF SUBPROGRAMS WITH" & + " POSITIONAL ACTUAL PARAMETERS"); + + BEGIN + P (0, 0, 0, TRUE); + END; + + RESULT; + END C87B48B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b50a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- C87B50A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FUNCTION RENAMING DECLARATION CAN RESOLVE AND RENAME AN + -- OVERLOADED ENUMERATION LITERAL. + + -- GOM 11/29/84 + -- JWC 7/12/85 + -- PWB 03/06/86 CORRECTED ERROR: ADDED "USE" CLAUSE TO MAKE + -- "/=" VISIBLE. + + WITH REPORT; USE REPORT; + PROCEDURE C87B50A IS + + BEGIN + TEST ("C87B50A", "CHECK THAT A FUNCTION RENAMING DECLARATION " & + "CAN RESOLVE AND RENAME AN OVERLOADED " & + "ENUMERATION LITERAL"); + + DECLARE + + PACKAGE A IS + TYPE COLORS IS (RED,GREEN); + TYPE LIGHT IS (BLUE,RED); + END A; + + PACKAGE B IS + FUNCTION RED RETURN A.COLORS RENAMES A.RED; + FUNCTION GREEN RETURN A.COLORS RENAMES A.GREEN; + END B; + + USE A; -- TO MAKE /= VISIBLE. + + BEGIN + + IF (A.RED /= B.RED) OR (A.GREEN /= B.GREEN) THEN + FAILED ("RENAMED VALUES NOT EQUAL"); + END IF; + + END; + + RESULT; + END C87B50A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b54a.ada 2003-10-27 11:28:53.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C87B54A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- THE ARGUMENT OF THE DELAY STATEMENT IS OF THE PREDEFINED FIXED + -- POINT TYPE DURATION. + + -- TRH 7 SEPT 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B54A IS + + TYPE TEMPS IS NEW DURATION; + TYPE REAL IS NEW FLOAT; + TYPE TEMPUS IS DELTA 0.1 RANGE -1.0 .. 1.0; + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : TEMPS) RETURN TEMPS IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : REAL) RETURN REAL IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : TEMPUS) RETURN TEMPUS IS + BEGIN + ERR := TRUE; + RETURN X; + END F; + + FUNCTION F (X : DURATION) RETURN DURATION IS + BEGIN + RETURN X; + END F; + + BEGIN + TEST ("C87B54A","OVERLOADED EXPRESSION WITHIN DELAY STATEMENT"); + + DECLARE + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + DELAY F (0.0); + DELAY F (1.0); + DELAY F (-1.0); + END T; + + BEGIN + IF ERR THEN FAILED ("DELAY STATEMENT TAKES AN ARGUMENT OF " & + "THE PREDEFINED FIXED POINT TYPE " & + "DURATION"); + END IF; + END; + + RESULT; + END C87B54A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b57a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C87B57A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- FOR A DEFAULT GENERIC IN PARAMETER, THE TYPE OF THE INITIALIZATION + -- EXPRESSION MUST MATCH THE PARAMETERS'S EXPLICIT TYPEMARK. + -- + -- THE FOUR KINDS OF EXPRESSIONS TESTED HERE ARE: + -- + -- (A): A CALL TO AN OVERLOADED FUNCTION. + -- (B): AN OVERLOADED OPERATOR SYMBOL. + -- (C): AN OVERLOADED (INFIX) OPERATOR. + -- (D): AN OVERLOADED ENUMERATION LITERAL. + + -- TRH 25 JUNE 82 + + WITH REPORT; USE REPORT; + + PROCEDURE C87B57A IS + + TYPE WHOLE IS NEW INTEGER RANGE 0..INTEGER'LAST; + TYPE CITRUS IS (LEMON, LIME, ORANGE); + TYPE HUE IS (RED, ORANGE, YELLOW); + + FUNCTION F1 (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -1; + END F1; + + FUNCTION F1 (X, Y : WHOLE) RETURN WHOLE IS + BEGIN + RETURN 0; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN HUE IS + BEGIN + RETURN ORANGE; + END F1; + + FUNCTION F1 (X, Y : INTEGER) RETURN CITRUS IS + BEGIN + RETURN ORANGE; + END F1; + + BEGIN + TEST ("C87B57A","OVERLOADED INITIALIZATION EXPRESSIONS" & + " IN DEFAULT GENERIC IN PARAMETERS"); + DECLARE + + FUNCTION "/" (X, Y : INTEGER) RETURN INTEGER + RENAMES F1; + + FUNCTION "/" (X, Y : WHOLE) RETURN WHOLE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN HUE + RENAMES F1; + + FUNCTION "/" (X, Y : INTEGER) RETURN CITRUS + RENAMES F1; + + GENERIC + I1 : INTEGER := F1 (0, 0); + W1 : WHOLE := F1 (0, 0); + C1 : CITRUS := F1 (0, 0); + H1 : HUE := F1 (0, 0); + I2 : INTEGER := "/" (0, 0); + W2 : WHOLE := "/" (0, 0); + C2 : CITRUS := "/" (0, 0); + H2 : HUE := "/" (0, 0); + I3 : INTEGER := (0 / 0); + W3 : WHOLE := (0 / 0); + C3 : CITRUS := (0 / 0); + H3 : HUE := (0 / 0); + C4 : CITRUS := ORANGE; + H4 : HUE := ORANGE; + + PACKAGE P IS + END P; + + PACKAGE BODY P IS + BEGIN + IF I1 /= -1 OR W1 /= 0 OR + CITRUS'POS (C1) /= 2 OR HUE'POS (H1) /= 1 THEN + FAILED ("(A): RESOLUTION INCORRECT - FUNCTION CALL"); + END IF; + + IF I2 /= -1 OR W2 /= 0 OR + CITRUS'POS (C2) /= 2 OR HUE'POS (H2) /= 1 THEN + FAILED ("(B): RESOLUTION INCORRECT " & + "- OPERATOR SYMBOL"); + END IF; + + IF I3 /= -1 OR W3 /= 0 OR + CITRUS'POS (C3) /= 2 OR HUE'POS (H3) /= 1 THEN + FAILED ("(C): RESOLUTION INCORRECT - INFIX OPERATOR"); + END IF; + + IF CITRUS'POS (C4) /= 2 OR HUE'POS (H4) /= 1 THEN + FAILED ("(D): RESOLUTION INCORRECT - ENUMERATION " & + "LITERAL"); + END IF; + END P; + + PACKAGE P1 IS NEW P; + + BEGIN + NULL; + END; + + RESULT; + END C87B57A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- C87B62A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A LENGTH CLAUSE THAT SPECIFIES 'SIZE, + -- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. + + -- HISTORY: + -- TRH 09/08/82 CREATED ORIGINAL TEST. + -- PWB 02/19/85 ADDED COMMENTS CLARIFYING NON-APPLICABILITY; + -- DELETED TEXT NOT RELATED TO TEST OBJECTIVE. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B62A IS + + TYPE POS_INT IS RANGE 1 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + ERR : BOOLEAN := FALSE; + + FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END "+"; + + FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS + BEGIN + ERR := TRUE; + RETURN POS_INT (X); + END "+"; + + BEGIN + TEST ("C87B62A","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'SIZE"); + + DECLARE + TYPE DECEM IS NEW INTEGER RANGE 1 .. 10; + TYPE JUST_LIKE_DECEM IS NEW INTEGER RANGE 1 .. 10; + DECEM_SIZE : CONSTANT := JUST_LIKE_DECEM'SIZE; + TYPE CHECK IS NEW INTEGER RANGE 1 .. 10; + + FOR CHECK'SIZE USE DECEM_SIZE; + FOR DECEM'SIZE USE + DECEM_SIZE; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'SIZE"); + END IF; + END; + + RESULT; + END C87B62A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C87B62B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE, + -- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. + -- ACCESS TYPES ARE HERE; TASK TYPES ARE IN C87B62D.DEP. + + -- HISTORY: + -- TRH 09/08/82 CREATED ORIGINAL TEST. + -- EG 06/04/84 + -- PWB 01/19/86 CLARIFIED COMMENTS REGARDING NON-APPLICABILITY; + -- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE + -- MOVED TASK TYPES TO C87B62D.DEP. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B62B IS + + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9'; + TYPE BASE_5 IS ('0', '1', '2', '3', '4'); + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : INTEGER) RETURN NUMERAL IS + BEGIN + ERR := TRUE; + RETURN ('9'); + END F; + + FUNCTION F (X : INTEGER) RETURN BASE_5 IS + BEGIN + ERR := TRUE; + RETURN ('4'); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_INT IS + BEGIN + RETURN POS_INT (X); + END F; + + BEGIN + TEST ("C87B62B","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " & + "FOR ACCESS TYPES"); + + DECLARE + + TYPE DECEM IS NEW INTEGER RANGE 1 .. 10; + TYPE LINK IS ACCESS DECEM; + + TYPE JUST_LIKE_LINK IS ACCESS DECEM; + TYPE CHECK IS ACCESS DECEM; + + FOR CHECK'STORAGE_SIZE + USE 1024; + FOR LINK'STORAGE_SIZE USE F (1024); + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'STORAGE_SIZE"); + END IF; + END; + + RESULT; + END C87B62B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C87B62C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A LENGTH CLAUSE THAT SPECIFIES 'SMALL, THE EXPRESSION + -- MUST BE OF SOME REAL TYPE. + + -- HISTORY: + -- TRH 09/08/82 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO CLARIFY NON-APPLICABILITY; + -- REMOVED TEXT NOT RELATED TO TEST OBJECTIVE. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B62C IS + + TYPE POS_INT IS NEW INTEGER RANGE 1 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + ERR : BOOLEAN := FALSE; + + FUNCTION "+" (X : POS_INT) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END "+"; + + FUNCTION "+" (X : POS_FIX) RETURN POS_INT IS + BEGIN + ERR := TRUE; + RETURN POS_INT (X); + END "+"; + + BEGIN + TEST ("C87B62C","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'SMALL"); + + DECLARE + TYPE JUST_LIKE_FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0; + TYPE FIXED IS DELTA 0.1 RANGE -1.0 .. 1.0; + + FIKST_SMALL : CONSTANT := JUST_LIKE_FIXED'SMALL; + TYPE CHECK IS DELTA 0.1 RANGE -1.0 .. 1.0; + + FOR CHECK'SMALL USE FIKST_SMALL; + FOR FIXED'SMALL USE + FIKST_SMALL; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'SMALL"); + END IF; + END; + + RESULT; + END C87B62C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c8/c87b62d.tst 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C87B62D.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT OVERLOADING RESOLUTION USES THE RULE THAT: + -- + -- IN A LENGTH CLAUSE THAT SPECIFIES 'STORAGE_SIZE, + -- THE EXPRESSION MUST BE OF SOME INTEGER TYPE. + -- TASK TYPE IS HERE; ACCESS TYPE IS IN C87B62B.DEP. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- TRH 09/08/82 CREATED ORIGINAL TEST. + -- EG 06/04/84 + -- PWB 01/19/86 CREATED THIS TEST FILE FROM THE TASK TYPE PART + -- OF THE OLD C87B62B; + -- CLARIFIED COMMENTS REGARDING NON-APPLICABILITY. + -- BCB 01/04/88 MODIFIED HEADER. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'. + + WITH REPORT; USE REPORT; + + PROCEDURE C87B62D IS + + TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE POS_INT IS NEW INTEGER RANGE 0 .. INTEGER'LAST; + TYPE POS_FIX IS DELTA 0.1 RANGE 0.0 .. 10.0; + TYPE NUMERAL IS NEW CHARACTER RANGE '0' .. '9'; + TYPE BASE_5 IS ('0', '1', '2', '3', '4'); + ERR : BOOLEAN := FALSE; + + FUNCTION F (X : INTEGER) RETURN NUMERAL IS + BEGIN + ERR := TRUE; + RETURN ('9'); + END F; + + FUNCTION F (X : INTEGER) RETURN BASE_5 IS + BEGIN + ERR := TRUE; + RETURN ('4'); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_FIX IS + BEGIN + ERR := TRUE; + RETURN POS_FIX (X); + END F; + + FUNCTION F (X : INTEGER) RETURN POS_INT IS + BEGIN + RETURN POS_INT (X); + END F; + + BEGIN + TEST ("C87B62D","OVERLOADED EXPRESSION WITHIN LENGTH CLAUSE " & + "- SPECIFICATION OF ATTRIBUTE T'STORAGE_SIZE " & + "FOR TASK TYPES "); + + DECLARE + + TASK TYPE TSK1 IS + END TSK1; + + FOR TSK1'STORAGE_SIZE USE F (TASK_STORAGE_SIZE); + + TASK BODY TSK1 IS + BEGIN + NULL; + END TSK1; + + BEGIN + IF ERR THEN + FAILED ("RESOLUTION INCORRECT FOR EXPRESSION IN " & + "LENGTH CLAUSE USING 'STORAGE_SIZE"); + END IF; + END; + + RESULT; + END C87B62D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- C910001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that tasks may have discriminants. Specifically, check where + -- the subtype of the discriminant is a discrete subtype and where it is + -- an access subtype. Check the case where the default values of the + -- discriminants are used. + -- + -- TEST DESCRIPTION: + -- A task is defined with two discriminants, one a discrete subtype and + -- another that is an access subtype. Tasks are created with various + -- values for discriminants and code within the task checks that these + -- are passed in correctly. One instance of a default is used. The + -- values passed to the task as the discriminants are taken from an + -- array of test data and the values received are checked against the + -- same array. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + + procedure C910001 is + + + type App_Priority is range 1..10; + Default_Priority : App_Priority := 5; + + type Message_ID is range 1..10_000; + + type TC_Number_of_Messages is range 1..5; + + type TC_rec is record + TC_ID : Message_ID; + A_Priority : App_Priority; + TC_Checked : Boolean; + end record; + + -- This table is used to create the messages and to check them + TC_table : array (1..TC_Number_of_Messages'Last) of TC_Rec := + ( ( 10, 6, false ), + ( 20, 2, false ), + ( 30, 9, false ), + ( 40, 1, false ), + ( 50, Default_Priority, false ) ); + + begin -- C910001 + + Report.Test ("C910001", "Check that tasks may have discriminants"); + + + declare -- encapsulate the test + + type Transaction_Record is + record + ID : Message_ID; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + end record; + -- + type acc_Transaction_Record is access Transaction_Record; + + + task type Message_Task + (In_Message : acc_Transaction_Record := null; + In_Priority : App_Priority := Default_Priority) is + entry Start; + end Message_Task; + type acc_Message_Task is access Message_Task; + -- + -- + task body Message_Task is + This_Message : acc_Transaction_Record := In_Message; + This_Priority : App_Priority := In_Priority; + TC_Match_Found : Boolean := false; + begin + accept Start; + -- In the example envisioned this task would then queue itself + -- upon some Distributor task which would send it off (requeue) to + -- the message processing tasks according to the priority of the + -- message and the current load on the system. For the test we + -- just verify the data passed in as discriminants and exit the task + -- + -- Check for the special case of default discriminants + if This_Message = null then + -- The default In_Message has been passed, check that the + -- default priority was also passed + if This_Priority /= Default_Priority then + Report.Failed ("Incorrect Default Priority"); + end if; + if TC_Table (TC_Number_of_Messages'Last).TC_Checked then + Report.Failed ("Duplicate Default messages"); + else + -- Mark that default has been seen + TC_Table (TC_Number_of_Messages'Last).TC_Checked := True; + end if; + TC_Match_Found := true; + else + -- Check the data against the table + for i in TC_Number_of_Messages loop + if TC_Table(i).TC_ID = This_Message.ID then + -- this is the right slot in the table + if TC_Table(i).TC_checked then + -- Already checked + Report.Failed ("Duplicate Data"); + else + TC_Table(i).TC_checked := true; + end if; + TC_Match_Found := true; + if TC_Table(i).A_Priority /= This_Priority then + Report.Failed ("ID/Priority mismatch"); + end if; + exit; + end if; + end loop; + end if; + + if not TC_Match_Found then + Report.Failed ("No ID match in table"); + end if; + + -- Allow the task to terminate + + end Message_Task; + + + -- The Line Driver task accepts data from an external source and + -- builds them into a transaction record. It then generates a + -- message task. This message "contains" the record and is given + -- a priority according to the contents of the message. The priority + -- and transaction records are passed to the task as discriminants. + -- In this test we use a dummy record. Only the ID is of interest + -- so we pick that and the required priority from an array of + -- test data. We artificially limit the endless driver-loop to + -- the number of messages required for the test and add a special + -- case to check the defaults. + -- + task Driver_Task; + -- + task body Driver_Task is + begin + + -- Create all but one of the required tasks + -- + for i in 1..TC_Number_of_Messages'Last - 1 loop + declare + -- Create a record for the next message + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := + new Message_Task( Next_Transaction, + TC_Table(i).A_Priority ); + + begin + -- Artificially plug the ID with the next from the table + -- In reality the whole record would be built here + Next_Transaction.ID := TC_Table(i).TC_ID; + + -- Ensure the task does not start executing till the + -- transaction record is properly constructed + Next_Message_Task.Start; + + end; -- declare + end loop; + + -- For this subtest create one task with the default discriminants + -- + declare + + -- Create the task + Next_Message_Task : acc_Message_Task := new Message_Task; + + begin + + Next_Message_Task.Start; + + end; -- declare + + + end Driver_Task; + + begin + null; + end; -- encapsulation + + -- Now verify that all the tasks executed and checked in + for i in TC_Number_of_Messages loop + if not TC_Table(i).TC_Checked then + Report.Failed + ("Task" & integer'image(integer (i) ) & " did not verify"); + end if; + end loop; + Report.Result; + + end C910001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- C910002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the contents of a task object include the values + -- of its discriminants. + -- Check that selected_component notation can be used to + -- denote a discriminant of a task. + -- + -- TEST DESCRIPTION: + -- This test declares a task type that contains discriminants. + -- Objects of the task type are created with different values. + -- The task type has nested tasks that are used to check that + -- the discriminate values are the expected values. + -- Note that the names of the discriminants in the body of task + -- type DTT denote the current instance of the unit. + -- + -- + -- CHANGE HISTORY: + -- 12 OCT 95 SAIC Initial release for 2.1 + -- 8 MAY 96 SAIC Incorporated Reviewer comments. + -- + --! + + + with Report; + procedure C910002 is + Verbose : constant Boolean := False; + begin + Report.Test ("C910002", + "Check that selected_component notation can be" & + " used to access task discriminants"); + declare + + task type DTT + (IA, IB : Integer; + CA, CB : Character) is + entry Check_Values (First_Int : Integer; + First_Char : Character); + end DTT; + + task body DTT is + Int1 : Integer; + Char1 : Character; + + -- simple nested task to check the character values + task Check_Chars is + entry Start_Check; + end Check_Chars; + task body Check_Chars is + begin + accept Start_Check; + if DTT.CA /= Char1 or + DTT.CB /= Character'Succ (Char1) then + Report.Failed ("character check failed. Expected: '" & + Char1 & Character'Succ (Char1) & + "' but found '" & + DTT.CA & DTT.CB & "'"); + elsif Verbose then + Report.Comment ("char check for " & Char1); + end if; + exception + when others => Report.Failed ("exception in Check_Chars"); + end Check_Chars; + + -- use a discriminated task to check the integer values + task type Check_Ints (First : Integer); + task body Check_Ints is + begin + if DTT.IA /= Check_Ints.First or + IB /= First+1 then + Report.Failed ("integer check failed. Expected:" & + Integer'Image (Check_Ints.First) & + Integer'Image (First+1) & + " but found" & + Integer'Image (DTT.IA) & Integer'Image (IB) ); + elsif Verbose then + Report.Comment ("int check for" & Integer'Image (First)); + end if; + exception + when others => Report.Failed ("exception in Check_Ints"); + end Check_Ints; + begin + accept Check_Values (First_Int : Integer; + First_Char : Character) do + Int1 := First_Int; + Char1 := First_Char; + end Check_Values; + + -- kick off the character check + Check_Chars.Start_Check; + + -- do the integer check + declare + Int_Checker : Check_Ints (Int1); + begin + null; -- let task do its thing + end; + + -- do one test here too + if DTT.IA /= Int1 then + Report.Failed ("DTT check failed. Expected:" & + Integer'Image (Int1) & + " but found:" & + Integer'Image (DTT.IA)); + elsif Verbose then + Report.Comment ("DTT check for" & Integer'Image (Int1)); + end if; + exception + when others => Report.Failed ("exception in DTT"); + end DTT; + + T1a : DTT (1, 2, 'a', 'b'); + T9C : DTT (9, 10, 'C', 'D'); + begin -- test encapsulation + T1a.Check_Values (1, 'a'); + T9C.Check_Values (9, 'C'); + end; + + Report.Result; + end C910002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c910003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c910003.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + -- C910003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that task discriminants that have an access subtype may be + -- dereferenced. + -- + -- Note that discriminants in Ada 83 never can be dereferenced with + -- selection or indexing, as they cannot have an access type. + -- + -- TEST DESCRIPTION: + -- A protected object is defined to create a simple buffer. + -- Two task types are defined, one to put values into the buffer, + -- and one to remove them. The tasks are passed a buffer object as + -- a discriminant with an access subtype. The producer task type includes + -- a discriminant to determine the values to product. The consumer task + -- type includes a value to save the results. + -- Two producer and one consumer tasks are declared, and the results + -- are checked. + -- + -- CHANGE HISTORY: + -- 10 Mar 99 RLB Created test. + -- + --! + + package C910003_Pack is + + type Item_Type is range 1 .. 100; -- In a real application, this probably + -- would be a record type. + + type Item_Array is array (Positive range <>) of Item_Type; + + protected type Buffer is + entry Put (Item : in Item_Type); + entry Get (Item : out Item_Type); + function TC_Items_Buffered return Item_Array; + private + Saved_Item : Item_Type; + Empty : Boolean := True; + TC_Items : Item_Array (1 .. 10); + TC_Last : Natural := 0; + end Buffer; + + type Buffer_Access_Type is access Buffer; + + PRODUCE_COUNT : constant := 2; -- Number of items to produce. + + task type Producer (Buffer_Access : Buffer_Access_Type; + Start_At : Item_Type); + -- Produces PRODUCE_COUNT items. Starts when activated. + + type TC_Item_Array_Access_Type is access Item_Array (1 .. PRODUCE_COUNT*2); + + task type Consumer (Buffer_Access : Buffer_Access_Type; + Results : TC_Item_Array_Access_Type) is + -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when + -- activated. + entry Wait_until_Done; + end Consumer; + + end C910003_Pack; + + + with Report; + package body C910003_Pack is + + protected body Buffer is + entry Put (Item : in Item_Type) when Empty is + begin + Empty := False; + Saved_Item := Item; + TC_Last := TC_Last + 1; + TC_Items(TC_Last) := Item; + end Put; + + entry Get (Item : out Item_Type) when not Empty is + begin + Empty := True; + Item := Saved_Item; + end Get; + + function TC_Items_Buffered return Item_Array is + begin + return TC_Items(1..TC_Last); + end TC_Items_Buffered; + + end Buffer; + + + task body Producer is + -- Produces PRODUCE_COUNT items. Starts when activated. + begin + for I in 1 .. Report.Ident_Int(PRODUCE_COUNT) loop + Buffer_Access.Put (Start_At + (Item_Type(I)-1)*2); + end loop; + end Producer; + + + task body Consumer is + -- Stores PRODUCE_COUNT*2 items consumed in Results. Starts when + -- activated. + begin + for I in 1 .. Report.Ident_Int(PRODUCE_COUNT*2) loop + Buffer_Access.Get (Results (I)); + -- Buffer_Access and Results are both dereferenced. + end loop; + + -- Check the results (and function call with a prefix dereference). + if Results.all(Report.Ident_Int(1)) /= Buffer_Access.all.TC_Items_Buffered(Report.Ident_Int(1)) then + Report.Failed ("First item mismatch"); + end if; + if Results(Report.Ident_Int(2)) /= Buffer_Access.TC_Items_Buffered(Report.Ident_Int(2)) then + Report.Failed ("Second item mismatch"); + end if; + accept Wait_until_Done; -- Tell main that we're done. + end Consumer; + + end C910003_Pack; + + + with Report; + with C910003_Pack; + + procedure C910003 is + + begin -- C910003 + + Report.Test ("C910003", "Check that tasks discriminants of access types can be dereferenced"); + + + declare -- encapsulate the test + + Buffer_Access : C910003_Pack.Buffer_Access_Type := + new C910003_Pack.Buffer; + + TC_Results : C910003_Pack.TC_Item_Array_Access_Type := + new C910003_Pack.Item_Array (1 .. C910003_Pack.PRODUCE_COUNT*2); + + Producer_1 : C910003_Pack.Producer (Buffer_Access, 12); + Producer_2 : C910003_Pack.Producer (Buffer_Access, 23); + + Consumer : C910003_Pack.Consumer (Buffer_Access, TC_Results); + + use type C910003_Pack.Item_Array; -- For /=. + + begin + Consumer.Wait_until_Done; + if TC_Results.all /= Buffer_Access.TC_Items_Buffered then + Report.Failed ("Different items buffered than returned - Main"); + end if; + if (TC_Results.all /= (12, 14, 23, 25) and + TC_Results.all /= (12, 23, 14, 25) and + TC_Results.all /= (12, 23, 25, 14) and + TC_Results.all /= (23, 12, 14, 25) and + TC_Results.all /= (23, 12, 25, 14) and + TC_Results.all /= (23, 25, 12, 14)) then + -- Above are the only legal results. + Report.Failed ("Wrong results"); + end if; + end; -- encapsulation + + Report.Result; + + end C910003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91004b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C91004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN + -- BODY, REFERS TO THE EXECUTING TASK. + + -- TEST USING IDENTIFIER IN ABORT STATEMENT, AS AN EXPRESSION IN + -- A MEMBERSHIP TEST, AND THE PREFIX OF 'CALLABLE AND + -- 'TERMINATED. + + -- HISTORY: + -- WEI 3/ 4/82 CREATED ORIGINAL TEST. + -- RJW 11/13/87 RENAMED TEST FROM C910BDA.ADA. ADDED CHECKS FOR + -- MEMBERSHIP TEST, AND 'CALLABLE AND 'TERMINATED + -- ATTRIBUTES. + + WITH REPORT; USE REPORT; + PROCEDURE C91004B IS + + TYPE I0 IS RANGE 0..1; + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK TYPE TT1 IS + ENTRY E1 (P1 : IN I0; P2 : ARG); + ENTRY BYE; + END TT1; + + SUBTYPE SUB_TT1 IS TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + IF TT1 NOT IN SUB_TT1 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST"); + END IF; + + IF NOT TT1'CALLABLE THEN + FAILED ("INCORRECT RESULTS FOR 'CALLABLE"); + END IF; + + IF TT1'TERMINATED THEN + FAILED ("INCORRECT RESULTS FOR 'TERMINATED"); + END IF; + + ACCEPT E1 (P1 : IN I0; P2 : ARG) DO + IF P1 = 1 THEN + ABORT TT1; + ACCEPT BYE; -- WILL DEADLOCK IF NOT ABORTED. + END IF; + PSPY_NUMB (ARG (P2)); + END E1; + + END TT1; + + BEGIN + + TEST ("C91004B", "TASK IDENTIFIER IN OWN BODY"); + + BEGIN + OBJ_TT1 (1).E1 (1,1); + FAILED ("NO TASKING_ERROR RAISED"); + -- ABORT DURING RENDEVOUS RAISES TASKING ERROR + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END; + + OBJ_TT1 (2).E1 (0,2); + + IF SPYNUMB /= 2 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C91004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91004c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C91004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK (TYPE) IDENTIFIER, WHEN USED WITHIN ITS OWN BODY + -- REFERS TO THE EXECUTING TASK. + -- + -- TEST USING CONDITIONAL ENTRY CALL. + + -- WEI 3/ 4/82 + -- TLB 10/30/87 RENAMED FROM C910BDB.ADA. + + WITH REPORT; + USE REPORT; + PROCEDURE C91004C IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY BYE; + END TT1; + + OBJ_TT1 : ARRAY (NATURAL RANGE 1..2) OF TT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + + SELECT + TT1.E1; + ELSE + PSPY_NUMB (2); + END SELECT; + + ACCEPT BYE; + END TT1; + + BEGIN + + TEST ("C91004C", "TASK IDENTIFIER IN OWN BODY"); + OBJ_TT1 (1).E1; + OBJ_TT1 (1).BYE; + + IF SPYNUMB /=12 THEN + FAILED ("WRONG TASK OBJECT REFERENCED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + ABORT OBJ_TT1 (2); + + RESULT; + + END C91004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C91006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IN A TASK SPECIFICATION ENTRY DECLARATIONS ARE ELABORATED + -- WHEN THE SPECIFICATION IS ELABORATED, AND IN TEXTUAL ORDER. + + -- WEI 3/04/82 + -- BHS 7/13/84 + -- TBN 12/17/85 RENAMED FROM C910AHA-B.ADA; + -- ADDED DECLARATIONS OF FIRST AND LAST. + -- PWB 5/15/86 MOVED DECLARATIONS OF FIRST, TASK T1, AND LAST + -- INTO A DECLARE/BEGIN/END BLOCK. + + WITH REPORT; USE REPORT; + PROCEDURE C91006A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + INDEX : INTEGER RANGE 0..5 := 0; + SPYNUMB : STRING(1..5) := (1..5 => ' '); + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + TEMP : STRING(1..2); + BEGIN + TEMP := ARG'IMAGE(DIGT); + INDEX := INDEX + 1; + SPYNUMB(INDEX) := TEMP(2); + RETURN DIGT; + END FINIT_POS; + + BEGIN + TEST ("C91006A", "CHECK THAT IN A TASK SPEC, ELABORATION IS IN " & + "TEXTUAL ORDER"); + DECLARE + + FIRST : INTEGER := FINIT_POS (1); + + TASK T1 IS + ENTRY E2 (NATURAL RANGE 1 .. FINIT_POS (2)); + ENTRY E3 (NATURAL RANGE 1 .. FINIT_POS (3)); + ENTRY E4 (NATURAL RANGE 1 .. FINIT_POS (4)); + END T1; + + LAST : INTEGER := FINIT_POS (5); + + TASK BODY T1 IS + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END; + + IF SPYNUMB /= "12345" THEN + FAILED ("TASK SPEC T1 NOT ELABORATED IN TEXTUAL ORDER"); + COMMENT ("ACTUAL ORDER WAS: " & SPYNUMB); + END IF; + + RESULT; + + END C91006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c91007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c91007a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C91007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF THE ELABORATION OF AN ENTRY DECLARATION RAISES + -- "CONSTRAINT_ERROR", THEN NO TASKS ARE ACTIVATED, AND + -- "TASKING_ERROR" IS NOT RAISED. + + -- HISTORY: + -- LDC 06/17/88 CREATED ORGINAL TEST + + WITH REPORT; + USE REPORT; + + PROCEDURE C91007A IS + + TYPE ENUM IS (TERESA, BRIAN, PHIL, JOLEEN, LYNN, DOUG, JODIE, + VINCE, TOM, DAVE, JOHN, ROSA); + SUBTYPE ENUM_SUB IS ENUM RANGE BRIAN..LYNN; + + BEGIN + TEST("C91007A","IF THE ELABORATION OF AN ENTRY DECLARATION " & + "RAISES 'CONSTRAINT_ERROR', THEN NO TASKS ARE " & + "ACTIVATED, AND 'TASKING_ERROR' IS NOT RAISED"); + + BEGIN + DECLARE + TASK TYPE TSK1; + T1 : TSK1; + TASK BODY TSK1 IS + BEGIN + FAILED("TSK1 WAS ACTIVATED"); + END TSK1; + + + TASK TSK2 IS + ENTRY ENT(ENUM_SUB RANGE TERESA..LYNN); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + FAILED("TASK BODY WAS ACTIVATED"); + END TSK2; + + TASK TSK3; + TASK BODY TSK3 IS + BEGIN + FAILED("TSK3 WAS ACTIVATED"); + END TSK3; + + BEGIN + NULL; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR WAS RAISED IN THE " & + "BEGIN BLOCK"); + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR IN THE BEGIN BLOCK"); + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS RAISED IN " & + "THE BEGIN BLOCK"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR WAS RAISED INSTEAD OF " & + "CONSTRAINT_ERROR"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION WAS RAISED"); + END; + + RESULT; + + END C91007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92002a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C92002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENT TO A COMPONENT (FOR WHICH ASSIGNMENT IS + -- AVAILABLE) OF A RECORD CONTAINING A TASK IS AVAILABLE. + + -- JRK 9/17/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; USE REPORT; + PROCEDURE C92002A IS + + BEGIN + TEST ("C92002A", "CHECK THAT CAN ASSIGN TO ASSIGNABLE " & + "COMPONENTS OF RECORDS WITH TASK " & + "COMPONENTS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + I : INTEGER := 0; + T : TT; + J : INTEGER := 0; + END RECORD; + + R : RT; + + TASK BODY TT IS + BEGIN + NULL; + END TT; + + BEGIN + + R.I := IDENT_INT (7); + R.J := IDENT_INT (9); + + IF R.I /= 7 AND R.J /= 9 THEN + FAILED ("WRONG VALUE(S) WHEN ASSIGNING TO " & + "INTEGER COMPONENTS OF RECORDS WITH " & + "TASK COMPONENTS"); + END IF; + + END; + + RESULT; + END C92002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92003a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C92003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK CAN BE PASSED AS AN ACTUAL IN OR IN OUT PARAMETER + -- IN A SUBPROGRAM CALL AND THAT THE ACTUAL AND FORMAL PARAMETERS DENOTE + -- THE SAME TASK OBJECT. + + -- JRK 1/17/81 + -- TBN 12/19/85 ADDED IN OUT PARAMETER CASE. + -- PWB 8/04/86 ADDED CHECK THAT FORMAL AND ACTUAL PARAMETERS DENOTE + -- THE SAME TASK OBJECT. + + WITH REPORT; USE REPORT; + + PROCEDURE C92003A IS + + BEGIN + + TEST ("C92003A", "CHECK TASKS PASSED AS ACTUAL IN OR IN OUT " & + "PARAMETERS TO SUBPROGRAMS"); + + DECLARE + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + T, S : TT; + + TASK BODY TT IS + SOURCE : INTEGER; + BEGIN + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 1 THEN + FAILED ("EXPECTED 1, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 2 THEN + FAILED ("EXPECTED 2, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + SELECT + ACCEPT E (I : INTEGER) DO + SOURCE := I; + END E; + OR + TERMINATE; + END SELECT; + + IF SOURCE /= 3 THEN + FAILED ("EXPECTED 3, GOT " & INTEGER'IMAGE(SOURCE)); + END IF; + + END TT; + + PROCEDURE P (T : TT) IS + BEGIN + T.E(2); + END P; + + PROCEDURE Q (S : IN OUT TT) IS + BEGIN + S.E(2); + END Q; + + BEGIN + + T.E(1); -- FIRST CALL TO T.E + P(T); -- SECOND CALL TO T.E + T.E(3); -- THIRD CALL TO T.E + + S.E(1); -- FIRST CALL TO S.E + Q(S); -- SECOND CALL TO S.E + S.E(3); -- THIRD CALL TO S.E + + END; + + RESULT; + + END C92003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- C92005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR A NON-SINGLE TASK THE OBJECT VALUE IS SET DURING + -- ELABORATION OF THE CORRESPONDING OBJECT DECLARATION. + + -- WEI 3/ 4/82 + -- JBG 5/25/85 + -- PWB 2/3/86 CORRECTED TEST ERROR; ADDED 'USE' CLAUSE TO MAKE "/=" + -- FOR BIG_INT VISIBLE. + + WITH REPORT, SYSTEM; + USE REPORT; + PROCEDURE C92005A IS + BEGIN + + TEST ("C92005A", "TASK OBJECT VALUE DURING ELABORATION"); + + DECLARE + TASK TYPE TT1; + + OBJ_TT1 : TT1; + + PACKAGE PACK IS + TYPE BIG_INT IS RANGE 0 .. SYSTEM.MAX_INT; + I : BIG_INT; + END PACK; + + PACKAGE BODY PACK IS + BEGIN + I := OBJ_TT1'STORAGE_SIZE; -- O.K. + EXCEPTION + WHEN OTHERS => + FAILED ("TASK OBJECT RAISED EXCEPTION"); + END PACK; + + USE PACK; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + BEGIN + IF PACK.I /= OBJ_TT1'STORAGE_SIZE THEN + COMMENT ("STORAGE SIZE CHANGED AFTER TASK ACTIVATED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY STORAGE_SIZE"); + END; + + RESULT; + END C92005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92005b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C92005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR A TASK OBJECT CREATED BY AN ALLOCATOR THE + -- OBJECT VALUE IS SET DURING EXECUTION OF THE ALLOCATOR. + + -- WEI 3/ 4/82 + -- JBG 5/25/85 + + WITH REPORT; + USE REPORT; + WITH SYSTEM; + PROCEDURE C92005B IS + TYPE BIG_INT IS RANGE 0..SYSTEM.MAX_INT; + BEGIN + TEST ("C92005B", "TASK VALUE SET BY EXECUTION OF ALLOCATOR"); + + BLOCK: + DECLARE + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + + TASK BODY TT1 IS + BEGIN + NULL; + END TT1; + + PACKAGE PACK IS + END PACK; + + PACKAGE BODY PACK IS + POINTER_TT1 : ATT1 := NEW TT1; + I : BIG_INT := POINTER_TT1.ALL'STORAGE_SIZE; + BEGIN + IF NOT EQUAL(INTEGER(I), INTEGER(I)) THEN + FAILED ("UNEXPECTED PROBLEM"); + END IF; + END PACK; + BEGIN + NULL; + EXCEPTION + WHEN PROGRAM_ERROR | CONSTRAINT_ERROR => + FAILED ("TASK OBJECT VALUE NOT SET DURING " & + "EXECUTION OF ALLOCATOR"); + END BLOCK; + + RESULT; + + END C92005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c92006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c92006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C92006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASK OBJECTS CAN BE INTERCHANGED BY ASSIGNMENT OF + -- CORRESPONDING ACCESS TYPE OBJECTS. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C920BIA-B.ADA + + WITH REPORT; + USE REPORT; + PROCEDURE C92006A IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + POINTER_TT1_1, POINTER_TT1_2 : ATT1; + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + PROCEDURE PROC (P1, P2 : IN OUT ATT1) IS + -- SWAP TASK OBJECTS P1, P2. + SCRATCH : ATT1; + BEGIN + SCRATCH := P1; + P1 := P2; + P2 := SCRATCH; + + P1.E2; -- ENTRY2 SECOND OBJECT. + P2.E1; -- VICE VERSA. + + END PROC; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END TT1; + + BEGIN + + TEST ("C92006A", "INTERCHANGING TASK OBJECTS"); + POINTER_TT1_1 := NEW TT1; + POINTER_TT1_2 := NEW TT1; + + POINTER_TT1_2.ALL.E1; + PROC (POINTER_TT1_1, POINTER_TT1_2); + POINTER_TT1_2.E2; -- E2 OF FIRST OBJECT + -- EACH ENTRY OF EACH TASK OBJECT SHOULD HAVE BEEN CALLED. + + IF SPYNUMB /= 1212 THEN + FAILED ("FAILURE TO SWAP TASK OBJECTS " & + "IN PROCEDURE PROC"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C92006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c930001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c930001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c930001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c930001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- C930001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check when a dependent task and its master both + -- terminate as a result of a terminate alternative that + -- finalization is performed and that the finalization is + -- performed in the proper order. + -- + -- TEST DESCRIPTION: + -- A controlled type with finalization is used to determine + -- the order in which finalization occurs. The finalization + -- procedure records the identity of the object being + -- finalized. + -- Two tasks, one nested inside the other, both contain + -- objects of the above finalization type. These tasks + -- cooperatively terminate so the termination and finalization + -- order can be noted. + -- + -- + -- CHANGE HISTORY: + -- 08 Jan 96 SAIC ACVC 2.1 + -- 09 May 96 SAIC Addressed Reviewer comments. + -- + --! + + + with Ada.Finalization; + package C930001_0 is + Verbose : constant Boolean := False; + + type Ids is range 0..10; + Finalization_Order : array (Ids) of Ids := (Ids => 0); + Finalization_Cnt : Ids := 0; + + protected Note is + -- serializes concurrent access to Finalization_* above + procedure Done (Id : Ids); + end Note; + + -- Objects of the following type are used to note the order in + -- which finalization occurs. + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Id : Ids; + end record; + procedure Finalize (Object : in out Has_Finalization); + end C930001_0; + + + with Report; + package body C930001_0 is + + protected body Note is + procedure Done (Id : Ids) is + begin + Finalization_Cnt := Finalization_Cnt + 1; + Finalization_Order (Finalization_Cnt) := Id; + end Done; + end Note; + + procedure Finalize (Object : in out Has_Finalization) is + begin + Note.Done (Object.Id); + if Verbose then + Report.Comment ("in Finalize for" & Ids'Image (Object.Id)); + end if; + end Finalize; + end C930001_0; + + + with Report; + with ImpDef; + with C930001_0; use C930001_0; + procedure C930001 is + begin + + Report.Test ("C930001", "Check that dependent tasks are terminated" & + " before the remaining finalization"); + + declare + task Level_1; + task body Level_1 is + V1a : C930001_0.Has_Finalization; -------> 4 + task Level_2 is + entry Not_Taken; + end Level_2; + task body Level_2 is + V2 : C930001_0.Has_Finalization; -------> 2 + begin + V2.Id := 2; + C930001_0.Note.Done (1); -------> 1 + select + accept Not_Taken; + or + terminate; + -- cooperative termination at this point of + -- both tasks + end select; + end Level_2; + + -- 7.6.1(11) requires that V1b be finalized before V1a + V1b : C930001_0.Has_Finalization; -------> 3 + begin + V1a.Id := 4; + V1b.Id := 3; + end Level_1; + begin -- declare + while not Level_1'Terminated loop + delay ImpDef.Switch_To_New_Task; + end loop; + C930001_0.Note.Done (5); -------> 5 + + -- now check the order + for I in Ids range 1..5 loop + if Verbose then + Report.Comment (Ids'Image (I) & + Ids'Image (Finalization_Order (I))); + end if; + if Finalization_Order (I) /= I then + Report.Failed ("Finalization occurred out of order" & + " expected:" & + Ids'Image (I) & + " actual:" & + Ids'Image (Finalization_Order (I))); + end if; + end loop; + end; + + Report.Result; + end C930001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93001a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,296 ---- + -- C93001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DECLARED TASK OBJECTS ARE NOT ACTIVATED BEFORE + -- THE END OF THE DECLARATIVE PART. + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK OBJECT, IN A BLOCK. + -- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. + -- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. + -- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. + -- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + + -- THIS TEST ASSUMES THAT ACTIVATION IS A SEQUENTIAL STEP + -- IN THE FLOW OF CONTROL OF THE PARENT (AS IS REQUIRED BY THE + -- ADA RM). IF AN IMPLEMENTATION (ILLEGALLY) ACTIVATES A + -- TASK IN PARALLEL WITH ITS PARENT, THIS TEST + -- IS NOT GUARANTEED TO DETECT THE VIOLATION, DUE TO A + -- RACE CONDITION. + + -- JRK 9/23/81 + -- SPS 11/1/82 + -- SPS 11/21/82 + -- R.WILLIAMS 10/8/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK + -- COMPONENTS OF RECORD TYPES. + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93001A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + + BEGIN + TEST ("C93001A", "CHECK THAT DECLARED TASK OBJECTS ARE NOT " & + "ACTIVATED BEFORE THE END OF THE DECLARATIVE " & + + "PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + I : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I /= 0 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO SOON - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + I : INTEGER := GLOBAL; + BEGIN + IF I /= 0 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO SOON - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + PACKAGE P IS + + TYPE REC IS + RECORD + T : TT; + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : REC; + END RECORD; + R : RT; + I : INTEGER := GLOBAL; + END P; + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + N : P.REC; + T : TT; + M : INTEGER := GLOBAL; + END RECORD; + R : RT; + END Q; + + K : INTEGER := GLOBAL; + + PACKAGE BODY Q IS + BEGIN + IF R.M /= 0 OR R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD R NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.1)" ); + END IF; + END Q; + + BEGIN -- (C) + + IF P.R.M /= 0 OR P.R.N.N1 /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORDS NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (C.2)" ); + END IF; + + IF P.I /= 0 OR K /= 0 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO SOON - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + TYPE ACCI IS ACCESS INTEGER; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + A : ARR; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + RA1 : RAT; + PRIVATE + RA2 : RAT; + END P; + + PACKAGE BODY P IS + RA3 : RAT; + I : INTEGER := GLOBAL; + BEGIN + IF RA1.M.G /= GOOD OR RA1.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M.G /= GOOD OR RA2.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF RA3.M.G /= GOOD OR RA3.N.ALL /= 0 THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RA3 NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (D)" ); + END IF; + + IF I /= 0 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE SPEC OR BODY WAS ACTIVATED " & + "TOO SOON - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TYPE REC IS + RECORD + B : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + C :CHARACTER :=CHARACTER'VAL (GLOBAL); + END RECORD; + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : REC; + T : TT; + N : REC; + END RECORD; + AR : ARRAY (1..1) OF RT; + I : INTEGER := GLOBAL; + BEGIN + IF AR (1).M.B /= FALSE OR AR (1).M.C /= ASCII.NUL OR + AR (1).N.B /= FALSE OR AR (1).N.C /= ASCII.NUL THEN + FAILED ( "NON-TASK COMPONENTS OF RECORD RT NOT " & + "INITIALIZED BEFORE TASKS ACTIVATED " & + "- (E)" ); + END IF; + + IF I /= 0 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO SOON - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; + END C93001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93002a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,231 ---- + -- C93002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DECLARED TASK OBJECTS ARE ACTIVATED BEFORE EXECUTION + -- OF THE FIRST STATEMENT FOLLOWING THE DECLARATIVE PART. + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK OBJECT, IN A BLOCK. + -- (B) AN ARRAY OF TASK OBJECT, IN A FUNCTION. + -- (C) A RECORD OF TASK OBJECT, IN A PACKAGE SPECIFICATION. + -- (D) A RECORD OF ARRAY OF TASK OBJECT, IN A PACKAGE BODY. + -- (E) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + + -- JRK 9/28/81 + -- SPS 11/1/82 + -- SPS 11/21/82 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93002A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + + BEGIN + TEST ("C93002A", "CHECK THAT DECLARED TASK OBJECTS ARE " & + "ACTIVATED BEFORE EXECUTION OF THE FIRST " & + "STATEMENT FOLLOWING THE DECLARATIVE PART"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("A SIMPLE TASK OBJECT IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF TASK OBJECT IN A FUNCTION " & + "WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RT IS + RECORD + A : ARR; + END RECORD; + R : RT; + END P; + + PACKAGE BODY P IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C1)"); + END IF; + END P; + + BEGIN -- (C1) + + NULL; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J : INTEGER; + PRIVATE + TYPE RT IS + RECORD + T : TT; + END RECORD; + R : RT; + END Q; + + PACKAGE BODY Q IS + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF TASK OBJECT IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARR; + END RECORD; + END P; + + PACKAGE BODY P IS + RA : RAT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK OBJECT IN A " & + "PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + IF GLOBAL /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK OBJECT IN A " & + "TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; + END C93002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93003a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,351 ---- + -- C93003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ACTIVATION OF TASKS CREATED BY ALLOCATORS PRESENT IN A + -- DECLARATIVE PART TAKES PLACE DURING ELABORATION OF THE + -- CORRESPONDING DECLARATION. + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (B) AN ARRAY OF TASK ALLOCATOR, IN A FUNCTION. + -- (C) A RECORD OF TASK ALLOCATOR, IN A PACKAGE SPECIFICATION. + -- (D) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY. + -- (E) AN ARRAY OF RECORD OF TASK ALLOCATOR, IN A TASK BODY. + + -- JRK 9/28/81 + -- SPS 11/11/82 + -- SPS 11/21/82 + -- RJW 8/4/86 ADDED CHECKS ON INITIALIZATIONS OF NON-TASK COMPONENTS + -- OF RECORD TYPES. + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93003A IS + + GLOBAL : INTEGER; + + FUNCTION SIDE_EFFECT (I : INTEGER) RETURN INTEGER IS + BEGIN + GLOBAL := IDENT_INT (I); + RETURN 0; + END SIDE_EFFECT; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + I : INTEGER := SIDE_EFFECT (1); + BEGIN + NULL; + END TT; + + + BEGIN + TEST ("C93003A", "CHECK THAT ACTIVATION OF TASKS CREATED BY " & + "ALLOCATORS PRESENT IN A DECLARATIVE PART " & + "TAKES PLACE DURING ELABORATION OF THE " & + "CORRESPONDING DECLARATION"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + TYPE A IS ACCESS TT; + T1 : A := NEW TT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + T2 : A := NEW TT; + I2 : INTEGER := GLOBAL; + + BEGIN -- (A) + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A SIMPLE TASK ALLOCATOR IN A BLOCK WAS " & + "ACTIVATED TOO LATE - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + J : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE A_T IS ARRAY (1 .. 1) OF TT; + TYPE A IS ACCESS A_T; + A1 : A := NEW A_T; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + A2 : A := NEW A_T; + I2 : INTEGER := GLOBAL; + + BEGIN + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF TASK ALLOCATOR IN A " & + "FUNCTION WAS ACTIVATED TOO LATE - (B)"); + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + J := F ; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C1) + + PACKAGE P IS + + TYPE INTREC IS + RECORD + N1 : INTEGER := GLOBAL; + END RECORD; + + TYPE RT IS + RECORD + M : INTEGER := GLOBAL; + T : TT; + N : INTREC; + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END P; + + BEGIN -- (C1) + + IF P.R1.M /= 0 OR P.R1.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.R2.M /= 0 OR P.R2.N.N1 /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED - (C1)" ); + END IF; + + IF P.I1 /= 1 OR P.I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE - (C1)"); + END IF; + + END; -- (C1) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C2) + + PACKAGE Q IS + J1 : INTEGER; + PRIVATE + + TYPE GRADE IS (GOOD, FAIR, POOR); + + TYPE REC (G : GRADE) IS + RECORD + NULL; + END RECORD; + + TYPE ACCR IS ACCESS REC; + + TYPE ACCI IS ACCESS INTEGER; + + TYPE RT IS + RECORD + M : ACCR := NEW REC (GRADE'VAL (GLOBAL)); + T : TT; + N : ACCI := NEW INTEGER'(GLOBAL); + END RECORD; + + TYPE A IS ACCESS RT; + + R1 : A := NEW RT; + I1 : INTEGER := GLOBAL; + J2 : INTEGER := SIDE_EFFECT (0); + R2 : A := NEW RT; + I2 : INTEGER := GLOBAL; + + END Q; + + PACKAGE BODY Q IS + BEGIN + IF R1.M.G /= GOOD OR R1.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF R2.M.G /= GOOD OR R2.N.ALL /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD R2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (C2)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF TASK ALLOCATOR IN A PACKAGE " & + "SPECIFICATION WAS ACTIVATED TOO LATE " & + "- (C2)"); + END IF; + END Q; + + BEGIN -- (C2) + + NULL; + + END; -- (C2) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + PACKAGE P IS + + TYPE ARR IS ARRAY (1 .. 1) OF TT; + TYPE INTARR IS ARRAY (1 .. 1) OF INTEGER; + + TYPE RAT IS + RECORD + M : INTARR := (1 => GLOBAL); + A : ARR; + N : INTARR := (1 => GLOBAL); + END RECORD; + END P; + + PACKAGE BODY P IS + + TYPE A IS ACCESS RAT; + + RA1 : A := NEW RAT; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + RA2 : A := NEW RAT; + I2 : INTEGER := GLOBAL; + + BEGIN + IF RA1.M (1) /= 0 OR RA1.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF RA2.M (1) /= 0 OR RA2.N (1) /= 0 THEN + FAILED ("NON-TASK COMPONENTS OF RECORD RA2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (D)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("A RECORD OF ARRAY OF TASK ALLOCATOR IN " & + "A PACKAGE BODY WAS ACTIVATED " & + "TOO LATE - (D)"); + END IF; + END P; + + BEGIN -- (D) + + NULL; + + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + TYPE RT IS + RECORD + M : BOOLEAN := BOOLEAN'VAL (GLOBAL); + T : TT; + N : CHARACTER := CHARACTER'VAL (GLOBAL); + END RECORD; + + TYPE ART IS ARRAY (1 .. 1) OF RT; + TYPE A IS ACCESS ART; + + AR1 : A := NEW ART; + I1 : INTEGER := GLOBAL; + J : INTEGER := SIDE_EFFECT (0); + AR2 : A := NEW ART; + I2 : INTEGER := GLOBAL; + + BEGIN + IF AR1.ALL (1).M /= FALSE OR + AR1.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR1 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF AR2.ALL (1).M /= FALSE OR + AR2.ALL (1).N /= ASCII.NUL THEN + FAILED ("NON-TASK COMPONENTS OF RECORD AR2 NOT " & + "INITIALIZED BEFORE TASK ACTIVATED " & + "- (E)" ); + END IF; + + IF I1 /= 1 OR I2 /= 1 THEN + FAILED ("AN ARRAY OF RECORD OF TASK ALLOCATOR IN " & + "A TASK BODY WAS ACTIVATED TOO LATE - (E)"); + END IF; + END T; + + BEGIN -- (E) + + NULL; + + END; -- (E) + + -------------------------------------------------- + + RESULT; + END C93003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C93004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK BECOMES COMPLETED WHEN AN EXCEPTION OCCURS DURING + -- ITS ACTIVATION. + + -- WEI 3/ 4/82 + + WITH REPORT; + USE REPORT; + PROCEDURE C93004A IS + BEGIN + + TEST ("C93004A", "TASK COMPLETION CAUSED BY EXCEPTION"); + + BLOCK: + DECLARE + TYPE I0 IS RANGE 0..1; + + TASK T1 IS + ENTRY BYE; + END T1; + + TASK BODY T1 IS + SUBTYPE I1 IS I0 RANGE 0 .. 2; -- CONSTRAINT ERROR. + BEGIN + ACCEPT BYE; + END T1; + BEGIN + FAILED ("NO EXCEPTION RAISED"); + IF NOT T1'TERMINATED THEN + FAILED ("TASK NOT TERMINATED"); + T1.BYE; + END IF; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END BLOCK; + + RESULT; + + END C93004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C93004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A + -- TASK, OTHER TASKS ARE UNAFFECTED. + + -- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + + -- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE + -- TASKING_ERROR + + -- JEAN-PIERRE ROSEN 09-MAR-1984 + -- JBG 06/01/84 + -- JBG 05/23/85 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93004B IS + + BEGIN + TEST("C93004B", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..1) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS BEFORE + END START_T1; -- ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(1)).E; + FAILED ("RENDEZVOUS COMPLETED - T1BIS"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1BIS"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(1)).E; -- ARR_T2(1) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; + END C93004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C93004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A + -- TASK, OTHER TASKS ARE UNAFFECTED. + + -- IF SEVERAL TASKS FAIL THEIR ACTIVATION, ONLY ONE TASKING_ERROR IS + -- RAISED. + + -- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + + -- CHECK THAT TASKS WAITING ON ENTRIES OF SUCH TASKS RECEIVE + -- TASKING_ERROR + + -- JEAN-PIERRE ROSEN 09-MAR-1984 + -- JBG 06/01/84 + -- JBG 05/23/85 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93004C IS + + BEGIN + TEST("C93004C", "EXCEPTIONS DURING ACTIVATION"); + + DECLARE + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; + + END C93004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C93004D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A + -- TASK, OTHER TASKS ARE UNAFFECTED. + + -- THIS TEST CHECKS THE CASE IN WHICH SOME OF THE OTHER TASKS ARE + -- PERHAPS ACTIVATED BEFORE THE EXCEPTION OCCURS AND SOME TASKS ARE + -- PERHAPS ACTIVATED AFTER. + + -- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + + -- CHECK THAT TASKS WAITING FOR ENTRIES OF SUCH TASKS RECEIVE + -- TASKING_ERROR. + + -- R. WILLIAMS 8/6/86 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C93004D IS + + + BEGIN + TEST ( "C93004D", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING ACTIVATION OF A TASK, OTHER TASKS " & + "ARE NOT AFFECTED. IN THIS TEST, SOME OF THE " & + "TASKS ARE PERHAPS ACTIVATED BEFORE THE " & + "EXCEPTION OCCURS AND SOME PERHAPS AFTER" ); + + + DECLARE + + TASK T0 IS + ENTRY E; + END T0; + + TASK TYPE T1 IS + END T1; + + TASK TYPE T2 IS + ENTRY E; + END T2; + + ARR_T2: ARRAY(INTEGER RANGE 1..4) OF T2; + + TYPE AT1 IS ACCESS T1; + + TASK BODY T0 IS + BEGIN + ACCEPT E; + END T0; + + PACKAGE START_T1 IS -- THIS PACKAGE TO AVOID ACCESS + END START_T1; -- BEFORE ELABORATION ON T1. + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T1BIS TERMINATES. + TASK T1BIS IS + END T1BIS; + + TASK BODY T1BIS IS + BEGIN + ARR_T2(IDENT_INT(2)).E; + FAILED ("RENDEZVOUS COMPLETED - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T1BIS; + BEGIN + NULL; + END; + + ARR_T2(IDENT_INT(2)).E; -- ARR_T2(2) IS NOW + -- TERMINATED. + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY START_T1 IS + V_AT1 : AT1 := NEW T1; + END START_T1; + + TASK BODY T2 IS + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED("T2 ACTIVATED OK"); + END IF; + END T2; + + TASK T3 IS + ENTRY E; + END T3; + + TASK BODY T3 IS + BEGIN -- T3 MUST BE ACTIVATED OK. + ACCEPT E; + END T3; + + BEGIN -- T0, ARR_T2 (1 .. 4), T3 ACTIVATED HERE. + + FAILED ("TASKING_ERROR NOT RAISED IN MAIN"); + T3.E; -- CLEAN UP. + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + BEGIN + T3.E; + T0.E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("T0 OR T3 NOT ACTIVATED"); + END; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED IN MAIN"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-2"); + END; + + RESULT; + END C93004D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93004f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93004f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C93004F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED DURING THE ACTIVATION OF A + -- TASK, OTHER TASKS ARE UNAFFECTED. + + -- THE ENCLOSING BLOCK RECEIVES TASKING_ERROR. + + -- THIS TESTS CHECKS THE CASE IN WHICH THE TASKS ARE CREATED BY THE + -- ALLOCATION OF A RECORD OF TASKS OR AN ARRAY OF TASKS. + + -- R. WILLIAMS 8/7/86 + + WITH REPORT; USE REPORT; + + PROCEDURE C93004F IS + + BEGIN + TEST ( "C93004F", "CHECK THAT WHEN AN EXCEPTION IS RAISED " & + "DURING THE ACTIVATION OF A TASK, OTHER " & + "TASKS ARE UNAFFECTED. IN THIS TEST, THE " & + "TASKS ARE CREATED BY THE ALLOCATION OF A " & + "RECORD OR AN ARRAY OF TASKS" ); + + DECLARE + + TASK TYPE T IS + ENTRY E; + END T; + + TASK TYPE TT; + + TASK TYPE TX IS + ENTRY E; + END TX; + + TYPE REC IS + RECORD + TR : T; + END RECORD; + + TYPE ARR IS ARRAY (IDENT_INT (1) .. IDENT_INT (1)) OF T; + + TYPE RECX IS + RECORD + TTX1 : TX; + TTT : TT; + TTX2 : TX; + END RECORD; + + TYPE ACCR IS ACCESS REC; + AR : ACCR; + + TYPE ACCA IS ACCESS ARR; + AA : ACCA; + + TYPE ACCX IS ACCESS RECX; + AX : ACCX; + + TASK BODY T IS + BEGIN + ACCEPT E; + END T; + + TASK BODY TT IS + BEGIN + AR.TR.E; + EXCEPTION + WHEN OTHERS => + FAILED ( "TASK AR.TR NOT ACTIVE" ); + END TT; + + TASK BODY TX IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "TX ACTIVATED OK" ); + END IF; + END TX; + + BEGIN + AR := NEW REC; + AA := NEW ARR; + AX := NEW RECX; + + FAILED ( "TASKING_ERROR NOT RAISED IN MAIN" ); + + AA.ALL (1).E; -- CLEAN UP. + + EXCEPTION + WHEN TASKING_ERROR => + + BEGIN + AA.ALL (1).E; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "AA.ALL (1) NOT ACTIVATED" ); + END; + + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED IN MAIN" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + + END C93004F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- C93005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK + -- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + + -- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A + -- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + + -- JEAN-PIERRE ROSEN 3/9/84 + -- JBG 06/01/84 + -- JBG 05/23/85 + -- EG 10/29/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005A IS + + BEGIN + TEST("C93005A", "EXCEPTIONS RAISED IN A DECLARATIVE PART " & + "CONTAINING TASKS"); + + BEGIN + + DECLARE + TASK TYPE T1 IS -- CHECKS THAT T2 TERMINATES. + END T1; + + TYPE AT1 IS ACCESS T1; + + TASK T2 IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END T2; + + PACKAGE RAISE_IT IS + END RAISE_IT; + + TASK BODY T2 IS + BEGIN + FAILED ("T2 ACTIVATED"); + -- IN CASE OF FAILURE + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + TASK BODY T1 IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT T3 TERMINATES. + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T2.E; + FAILED ("RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - T3"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T3"); + END T3; + BEGIN + NULL; + END; + + T2.E; --T2 IS NOW TERMINATED + + FAILED ("RENDEZVOUS COMPLETED WITHOUT ERROR - T1"); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("ABNORMAL EXCEPTION - T1"); + END; + + PACKAGE BODY RAISE_IT IS + PT1 : AT1 := NEW T1; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR. + BEGIN + IF I /= IDENT_INT(2) OR I = IDENT_INT(1) + 1 THEN + FAILED ("PACKAGE DIDN'T RAISE EXCEPTION"); + END IF; + END RAISE_IT; + + BEGIN -- CAN'T LEAVE BLOCK UNTIL T1, T2, AND T3 ARE TERM. + FAILED ("EXCEPTION NOT RAISED"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN MAIN PROGRAM"); + WHEN OTHERS => + FAILED ("ABNORMAL EXCEPTION IN MAIN-1"); + END; + + RESULT; + + END C93005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,273 ---- + -- C93005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN EXCEPTION IS RAISED IN A DECLARATIVE PART, A TASK + -- DECLARED IN THE SAME DECLARATIVE PART BECOMES TERMINATED. + + -- CHECK THAT A TASK WAITING ON ENTRIES OF SUCH A + -- TERMINATED-BEFORE-ACTIVATION TASK RECEIVES TASKING_ERROR. + + -- THIS TEST CHECKS THE CASE IN WHICH SEVERAL TASKS ARE WAITING FOR + -- ACTIVATION WHEN THE EXCEPTION OCCURS. + + -- R. WILLIAMS 8/7/86 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE C93005B IS + + + BEGIN + TEST ( "C93005B", "CHECK THAT WHEN AN EXCEPTION IS RAISED IN A " & + "DECLARATIVE PART, A TASK DECLARED IN THE " & + "SAME DECLARATIVE PART BECOMES TERMINATED. " & + "IN THIS CASE, SEVERAL TASKS ARE WAITING FOR " & + "ACTIVATION WHEN THE EXCEPTION OCCURS" ); + + BEGIN + + DECLARE + TASK TYPE TA IS -- CHECKS THAT TX TERMINATES. + END TA; + + TYPE ATA IS ACCESS TA; + + TASK TYPE TB IS -- CHECKS THAT TY TERMINATES. + END TB; + + TYPE TBREC IS + RECORD + TTB: TB; + END RECORD; + + TASK TX IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TX; + + TASK BODY TA IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TAB + -- TERMINATES. + TASK TAB IS + END TAB; + + TASK BODY TAB IS + BEGIN + TX.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TAB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TAB" ); + END TAB; + BEGIN + NULL; + END; + + TX.E; --TX IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TA" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TA" ); + END TA; + + PACKAGE RAISE_IT IS + TASK TY IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TY; + END RAISE_IT; + + TASK BODY TB IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TBB + -- TERMINATES. + TASK TBB IS + END TBB; + + TASK BODY TBB IS + BEGIN + RAISE_IT.TY.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT ERROR - TBB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION " & + "- TBB" ); + END TBB; + BEGIN + NULL; + END; + + RAISE_IT.TY.E; -- TY IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT ERROR " & + "- TB" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TB" ); + END TB; + + PACKAGE START_TC IS END START_TC; + + TASK BODY TX IS + BEGIN + FAILED ( "TX ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TX; + + PACKAGE START_TZ IS + TASK TZ IS -- WILL NEVER BE ACTIVATED. + ENTRY E; + END TZ; + END START_TZ; + + PACKAGE BODY START_TC IS + TBREC1 : TBREC; -- CHECKS THAT TY TERMINATES. + + TASK TC IS -- CHECKS THAT TZ TERMINATES. + END TC; + + TASK BODY TC IS + BEGIN + DECLARE -- THIS BLOCK TO CHECK THAT TCB + -- TERMINATES. + + TASK TCB IS + END TCB; + + TASK BODY TCB IS + BEGIN + START_TZ.TZ.E; + FAILED ( "RENDEZVOUS COMPLETED " & + "WITHOUT " & + "ERROR - TCB" ); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL " & + "EXCEPTION - TCB" ); + END TCB; + BEGIN + NULL; + END; + + START_TZ.TZ.E; -- TZ IS NOW TERMINATED. + + FAILED ( "RENDEZVOUS COMPLETED WITHOUT " & + "ERROR - TC" ); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION - TC" ); + END TC; + END START_TC; -- TBREC1 AND TC ACTIVATED HERE. + + PACKAGE BODY RAISE_IT IS + NTA : ATA := NEW TA; -- NTA.ALL ACTIVATED HERE. + + TASK BODY TY IS + BEGIN + FAILED ( "TY ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TY; + + PACKAGE XCEPTION IS + I : POSITIVE := IDENT_INT (0); -- RAISE + -- CONSTRAINT_ERROR. + END XCEPTION; + + USE XCEPTION; + + BEGIN -- TY WOULD BE ACTIVATED HERE. + + IF I /= IDENT_INT (2) OR I = IDENT_INT (1) + 1 THEN + FAILED ( "PACKAGE DIDN'T RAISE EXCEPTION" ); + END IF; + END RAISE_IT; + + PACKAGE BODY START_TZ IS + TASK BODY TZ IS + BEGIN + FAILED ( "TZ ACTIVATED" ); + -- IN CASE OF FAILURE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + END TZ; + END START_TZ; -- TZ WOULD BE ACTIVATED HERE. + + BEGIN -- TX WOULD BE ACTIVATED HERE. + -- CAN'T LEAVE BLOCK UNTIL TA, TB, AND TC ARE TERM. + + FAILED ( "EXCEPTION NOT RAISED" ); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED ( "TASKING_ERROR IN MAIN PROGRAM" ); + WHEN OTHERS => + FAILED ( "ABNORMAL EXCEPTION IN MAIN" ); + END; + + RESULT; + + END C93005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- C93005C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 1: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE + -- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + + with Impdef; + + PACKAGE C93005C_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005C_PK1; + + + PACKAGE BODY C93005C_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005C_PK1; + + WITH REPORT, C93005C_PK1; + USE REPORT, C93005C_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005C IS + + + BEGIN + + TEST("C93005C", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 1: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); + B1: DECLARE + X : MNT; + BEGIN + B2: BEGIN + B3: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + M2 : ACC_MNT := NEW MNT; + + PACKAGE RAISES_EXCEPTION IS + T2 : UNACTIVATED; + M3 : ACC_MNT := NEW MNT; + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION + END RAISES_EXCEPTION; + USE RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B3; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("SUBTEST 1 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B2"); + END B2; + END B1; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,289 ---- + -- C93005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 2: TASKS IN DECLARATIVE PART OF A BLOCK AND PACKAGE + -- SPECIFICATION. THE TASKS DEPEND ON THE DECLARATIVE PART. + -- OTHER TASKS HAVE BEEN QUEUED ON THE TASKS' ENTRIES. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + -- ADDED PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + with Impdef; + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE C93005D_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005D_PK1; + + + PACKAGE BODY C93005D_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005D_PK1; + + WITH C93005D_PK1; USE C93005D_PK1; + PRAGMA ELABORATE (C93005D_PK1); + GENERIC + T1 : IN OUT UNACTIVATED; + PACKAGE C93005D_ENQUEUE IS + PROCEDURE REQUIRE_BODY; + END; + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C93005D_ENQUEUE IS + + TASK T3 IS + END T3; + + TASK BODY T3 IS + BEGIN + T1.E; + FAILED ("ENQUEUED CALLER DID NOT GET EXCEPTION"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED"); + END T3; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN -- T3 CALLS T1 HERE + DELAY 1.0 * Impdef.One_Second; -- ENSURE THAT T3 EXECUTES + END C93005D_ENQUEUE; + + WITH REPORT, C93005D_PK1, C93005D_ENQUEUE; + USE REPORT, C93005D_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005D IS + + + BEGIN + + TEST("C93005D", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 2: TASKS IN DECL PART OF A BLOCK AND A PACKAGE " & + "SPEC"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); + COMMENT(" OTHER TASKS HAVE BEEN ENQUEUED ON THE TASKS' ENTRIES"); + B21: DECLARE + X : MNT; + BEGIN + B22: BEGIN + B23: DECLARE + TYPE ACC_MNT IS ACCESS MNT; + T1 : UNACTIVATED; + Y : ACC_MNT := NEW MNT; + + PACKAGE HAS_UNACTIVATED IS + T2 : UNACTIVATED; + Z : ACC_MNT := NEW MNT; + PACKAGE ENQUEUE1 IS NEW C93005D_ENQUEUE(T1); + PACKAGE ENQUEUE2 IS NEW C93005D_ENQUEUE(T2); + I : POSITIVE := IDENT_INT(0); -- RAISE + -- CONSTRAINT_ERROR EXCEPTION. + -- TERMINATES T1 AND T2 AND INDIRECTLY THE 2 T3'S + END HAS_UNACTIVATED; + USE HAS_UNACTIVATED; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + IF EQUAL (I, I) THEN + FAILED ("EXCEPTION NOT RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B23; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 2 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B22"); + END B22; + END B21; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,247 ---- + -- C93005E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 3: TASKS IN PACKAGE SPECIFICATION. + -- THE TASKS DON'T DEPEND ON THE PACKAGE SPECIFICATION. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE C93005E_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005E_PK1; + + with Impdef; + PACKAGE BODY C93005E_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005E_PK1; + + WITH REPORT, C93005E_PK1; + USE REPORT, C93005E_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005E IS + + + BEGIN + + TEST("C93005E", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 3: TASK IN DECL PART OF PACKAGE SPEC"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); + B31: DECLARE + X : MNT; + BEGIN + B32: BEGIN + B33: DECLARE + PACKAGE RAISES_EXCEPTION IS + TYPE ACC_MNT IS ACCESS MNT; + Y : ACC_MNT := NEW MNT; + PTR : ACC_BAD_REC := NEW BAD_REC; + END RAISES_EXCEPTION; + BEGIN -- WOULD HAVE BEEN ACTIVATED HERE + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN WRONG SCOPE"); + END B33; + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT("SUBTEST 3 COMPLETED"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN B32"); + END B32; + END B31; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,255 ---- + -- C93005F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 4: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DEPEND ON THE + -- DECLARATIVE PART. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + -- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE C93005F_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005F_PK1; + + with Impdef; + PACKAGE BODY C93005F_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005F_PK1; + + WITH REPORT, C93005F_PK1; + USE REPORT, C93005F_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005F IS + + + BEGIN + + TEST("C93005F", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 4: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DEPEND ON THE DECLARATIVE PART"); + B41: DECLARE + X : MNT; + BEGIN + B42: DECLARE + TYPE LOCAL_ACC IS ACCESS BAD_REC; + Y : MNT; + PTR : LOCAL_ACC; + + TYPE ACC_MNT IS ACCESS MNT; + Z : ACC_MNT; + + BEGIN + Z := NEW MNT; + PTR := NEW BAD_REC; + IF PTR.I /= REPORT.IDENT_INT(0) THEN + FAILED ("EXCEPTION NOT RAISED, VALUE CHANGED"); + ELSE + FAILED ("EXCEPTION NOT RAISED, CONSTRAINT IGNORED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B42"); + END B42; + + COMMENT("SUBTEST 4: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B41; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- C93005G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 5: TASKS IN STATEMENT PART OF A BLOCK. THE TASKS DON'T DEPEND + -- ON THE DECLARATIVE PART. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE C93005G_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005G_PK1; + + with Impdef; + PACKAGE BODY C93005G_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005G_PK1; + + WITH REPORT, C93005G_PK1; + USE REPORT, C93005G_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005G IS + + + BEGIN + + TEST("C93005G", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 5: TASK IN STATEMENT PART OF BLOCK"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); + B51: DECLARE + X : MNT; + BEGIN + B52: DECLARE + Y : MNT; + PTR : ACC_BAD_REC; + BEGIN + PTR := NEW BAD_REC; + FAILED ("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION IN B52"); + END B52; + + COMMENT ("SUBTEST 5: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B51; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93005h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93005h.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- C93005H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF AN EXCEPTION IS RAISED IN A DECLARATIVE PART OR PACKAGE + -- SPECIFICATION, A TASK DECLARED IN THE SAME DECLARATIVE PART BECOMES + -- COMPLETED BEFORE IT HAS BEEN ACTIVATED; ANY TASKS AWAITING A + -- RENDEZVOUS WITH THE COMPLETED RECEIVE TASKING_ERROR. + + -- CASE 6: TASK IN STATEMENT PART OF PACKAGE AND THE TASKS DON'T DEPEND + -- ON THE PACKAGE SPECIFICATION. + + -- RAC 19-MAR-1985 + -- JBG 06/03/85 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PRAGMA ELABORATE (REPORT); + PACKAGE C93005H_PK1 IS + + -- THIS TYPE OF TASK IS ALWAYS UNACTIVATED. + TASK TYPE UNACTIVATED IS + ENTRY E; + END UNACTIVATED; + + TYPE ACC_UNACTIVATED IS ACCESS UNACTIVATED; + + TYPE BAD_REC IS + RECORD + T : UNACTIVATED; + I : POSITIVE := IDENT_INT(0); -- RAISE CONSTRAINT_ERROR. + END RECORD; + + TYPE ACC_BAD_REC IS ACCESS BAD_REC; + + + -- ******************************************* + -- DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + -- + -- THIS SET OF DECLARATIONS DEFINES A RECORD TYPE MNT (MUST NOT + -- TERMINATE). WHENEVER SUCH A RECORD IS DECLARED, A COUNT IS + -- INCREMENTED AND A TASK IS CREATED. THE TASK WILL DECREMENT THE + -- COUNT UNLESS IT IS INCORRECTLY AND PREMATURELY TERMINATED. + -- THE ROUTINE CHECK IS CALLED TO VERIFY WHETHER THE COUNT + -- HAS RETURNED TO 0 (ALL MNT TASKS GOT A CHANCE TO DO THEIR + -- DECREMENT). + + -- AN MNT TASK. SUCH TASKS MUST NOT BE TERMINATED + -- BY ANYONE BUT THEMSELVES. + -- + TASK TYPE MNT_TASK IS + END MNT_TASK; + + FUNCTION F RETURN INTEGER; + + -- THE RECORD THAT IS DECLARED TO HOLD AN MNT TASK + -- AND FORCE CALLING F BEFORE CREATING THE TASK. + -- F INCREMENTS THE COUNT, THE TASK DECREMENTS THE + -- COUNT. + -- + TYPE MNT IS + RECORD + DUMMY : INTEGER := F; + T : MNT_TASK; + END RECORD; + + PROCEDURE CHECK; + + + -- ******************************************* + -- END OF DEFINITIONS FOR MUST NOT BE TERMINATED TASKS + -- ******************************************* + + END C93005H_PK1; + + with Impdef; + PACKAGE BODY C93005H_PK1 IS + + -- THIS TASK IS CALLED IF AN UNACTIVATED TASK + -- IS EVER INCORRECTLY ACTIVATED. IT REPORTS FAILURE. + + TASK T IS + ENTRY E; + END; + + -- *********************************************** + -- START OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + -- COUNT OF TASKS THAT MUST NOT BE TERMINATED AND + -- ARE STILL ACTIVE. + + MNT_COUNT : INTEGER := 0; + + -- TASK TO SYNCHRONIZE THE MNT_COUNT VARIABLE + + TASK MNT_COUNTER IS + ENTRY INCR; + ENTRY DECR; + END MNT_COUNTER; + + -- SYNCHRONIZING TASK + + TASK BODY MNT_COUNTER IS + BEGIN + LOOP + SELECT + ACCEPT INCR DO + MNT_COUNT := MNT_COUNT +1; + END INCR; + + OR ACCEPT DECR DO + MNT_COUNT := MNT_COUNT -1; + END DECR; + + OR TERMINATE; + + END SELECT; + END LOOP; + END MNT_COUNTER; + + -- INCREMENT THE MNT_COUNT WHEN A TASK IS CREATED + -- + FUNCTION F RETURN INTEGER IS + BEGIN + MNT_COUNTER.INCR; + RETURN 0; + END F; + + -- CHECK THAT THE MUST NOT BE TERMINATED TASKS ARE + -- NOT YET TERMINATED AND THAT THE SYNCRHONIZING TASK + -- ITSELF IS NOT TERMINATED. + -- + PROCEDURE CHECK IS + BEGIN + IF MNT_COUNT /= 0 OR MNT_COUNTER'TERMINATED THEN + FAILED ("SOME MUST-NOT-TERMINATE TASK WAS PREMATURELY " & + "TERMINATED"); + END IF; + -- RESET THE COUNT FOR THE NEXT SUBTEST: + MNT_COUNT := 0; + END CHECK; + + -- A MUST NOT BE TERMINATED TASK. DELAY LONG ENOUGH + -- TO BE THE LAST TASK OF A SCOPE TO TERMINATE. THEN + -- DECREMENT THE COUNTER. + -- + TASK BODY MNT_TASK IS + BEGIN + DELAY 5.0 * Impdef.One_Second; + MNT_COUNTER.DECR; + END MNT_TASK; + + -- *********************************************** + -- END OF DEFINITIONS FOR MUST NOT TERMINATE TASKS + -- *********************************************** + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E DO + FAILED ("SOME TYPE U TASK WAS ACTIVATED"); + END E; + + OR TERMINATE; + END SELECT; + END LOOP; + END T; + + -- TASKS OF TYPE UNACTIVATED MUST NEVER BE ACTIVATED. + -- + TASK BODY UNACTIVATED IS + BEGIN + T.E; + END UNACTIVATED; + END C93005H_PK1; + + WITH REPORT, C93005H_PK1; + USE REPORT, C93005H_PK1; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C93005H IS + + + BEGIN + + TEST("C93005H", "TEST EXCEPTIONS TERMINATE NOT YET ACTIVATED " & + "TASKS"); + + COMMENT("SUBTEST 6: TASK IN STATEMENT PART OF PACKAGE"); + COMMENT(" THE TASKS DON'T DEPEND ON THE DECLARATIVE PART"); + B61: DECLARE + X : MNT; + + PACKAGE P IS + Y : MNT; + END P; + + PACKAGE BODY P IS + PTR : ACC_BAD_REC; + Z : MNT; + BEGIN + PTR := NEW BAD_REC; + FAILED("EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN P"); + END P; + + BEGIN + COMMENT ("SUBTEST 6: COMPLETED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + END B61; + + CHECK; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION NOT ABSORBED"); + RESULT; + END C93005H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- C93006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK OBJECT DECLARED IN A LIBRARY PACKAGE SPEC IS + -- ACTIVATED EVEN IF THE PACKAGE HAS NO BODY. + + -- JEAN-PIERRE ROSEN 16-MAR-1984 + -- JBG 6/1/84 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + PACKAGE C93006A0 IS + TASK TYPE TT IS + ENTRY E; + END; + END C93006A0; + + PACKAGE BODY C93006A0 IS + TASK BODY TT IS + BEGIN + ACCEPT E; + END; + END C93006A0; + + WITH C93006A0; USE C93006A0; + PRAGMA ELABORATE(C93006A0); + PACKAGE C93006A1 IS + T : TT; + END C93006A1; + + with Impdef; + WITH REPORT, C93006A1, SYSTEM; + USE REPORT, C93006A1, SYSTEM; + PROCEDURE C93006A IS + BEGIN + + TEST("C93006A", "CHECK ACTIVATION OF TASK DECLARED IN PACKAGE " & + "SPECIFICATION"); + + SELECT + T.E; + OR + DELAY 60.0 * Impdef.One_Second; + FAILED("RENDEZVOUS NOT ACCEPTED WITHIN 60 SECONDS"); + END SELECT; + + RESULT; + END C93006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93007a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C93007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE A TASK BEFORE ITS + -- BODY HAS BEEN ELABORATED, THE TASK IS COMPLETED AND "PROGRAM_ + -- ERROR" (RATHER THAN "TASKING_ERROR") IS RAISED. + + -- HISTORY: + -- DHH 03/16/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C93007A IS + + BEGIN + + TEST("C93007A", "CHECK THAT IF AN ATTEMPT IS MADE TO ACTIVATE " & + "A TASK BEFORE ITS BODY HAS BEEN ELABORATED, " & + "THE TASK IS COMPLETED AND ""PROGRAM_ERROR"" " & + "(RATHER THAN ""TASKING_ERROR"") IS RAISED"); + + DECLARE + TASK TYPE PROG_ERR IS + ENTRY START; + END PROG_ERR; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + PACKAGE P IS + OBJ : REC; + END P; + + PACKAGE BODY P IS + BEGIN + FAILED("EXCEPTION NOT RAISED - 1"); + OBJ.B.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + FAILED("EXCEPTION NOT RAISED - 2"); + OBJ.START; + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN TASKING_ERROR => + FAILED("ACCESS TASKING ERROR RAISED INCORRECTLY"); + WHEN OTHERS => + FAILED("ACCESS UNEXPECTED EXCEPTION RAISED"); + END; + + TASK BODY PROG_ERR IS + BEGIN + ACCEPT START DO + IF TRUE THEN + COMMENT("IRRELEVANT"); + END IF; + END START; + END PROG_ERR; + BEGIN + NULL; + END; -- DECLARE + + RESULT; + + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED("PROGRAM_ERROR RAISED AT INCORRECT POSITION"); + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + + END C93007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93008a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C93008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR A TASK CREATED BY AN OBJECT DECLARATION, EXECUTION + -- DOES NOT PROCEED IN PARALLEL WITH ACTIVATION. + + -- R.WILLIAMS 8/20/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C93008A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + TASK T IS + ENTRY FINIT_POS (DIGT : IN ARG); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT FINIT_POS (DIGT : IN ARG) DO + SPYNUMB := 10*SPYNUMB+DIGT; + END FINIT_POS; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + + TEST ("C93008A", "CHECK THAT EXECUTION DOES NOT PROCEED IN " & + "PARALLEL WITH ACTIVATION OF A TASK CREATED " & + "BY AN OBJECT DECLARATION"); + + BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK TT2; + + T1 : TT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(1); + END DUMMY; + BEGIN + NULL; + END TT1; + + TASK BODY TT2 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + T.FINIT_POS(2); + END DUMMY; + BEGIN + NULL; + END TT2; + + + BEGIN -- TASKS ACTIVATED NOW. + + IF SPYNUMB = 12 OR SPYNUMB = 21 THEN + NULL; + ELSE + FAILED ("TASKS NOT ACTIVATED PROPERLY - SPYNUMB HAS " & + "ACTUAL VALUE OF: " & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + + END C93008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c93008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c93008b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C93008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AFTER CREATION OF A TASK OBJECT BY AN ALLOCATOR, ANY + -- OPERATION INVOLVING THE RESULT DELIVERED BY THE ALLOCATOR IS + -- EXECUTED ONLY AFTER THE ACTIVATION OF THE TASK HAS COMPLETED. + + -- WEI 3/ 4/82 + -- TBN 12/20/85 RENAMED FROM C930AJA-B.ADA. ADDED DELAY STATEMENT + -- DURING TASK ACTIVATION. + -- RJW 4/11/86 ADDED PACKAGE DUMMY. + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C93008B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + BEGIN + + TEST ("C93008B", "USE OF RESULT AFTER CREATION OF " & + "A TASK BY ALLOCATOR"); + + BLOCK: + DECLARE + + TASK TYPE TT1; + + TYPE ATT1 IS ACCESS TT1; + TYPE ARRAY_ATT1 IS ARRAY (NATURAL RANGE 2 .. 3) OF ATT1; + MY_ARRAY : ARRAY_ATT1; + POINTER_TT1 : ATT1; + + TASK BODY TT1 IS + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + DELAY 2.0 * Impdef.One_Second; + DECLARE + IDUMMY1 : NATURAL := FINIT_POS (1); + BEGIN + NULL; + END; + END DUMMY; + BEGIN + NULL; + END TT1; + + BEGIN + + MY_ARRAY := (2 => NEW TT1, 3 => NULL); -- TASK ACTIVATED NOW. + POINTER_TT1 := MY_ARRAY (FINIT_POS (2)); + + MY_ARRAY (FINIT_POS (3)) := POINTER_TT1; + + IF SPYNUMB /= 123 THEN + IF SPYNUMB = 132 OR SPYNUMB = 13 OR + SPYNUMB = 12 OR SPYNUMB = 1 OR + SPYNUMB = 0 + THEN + FAILED ("TASK ACTIVATION RIGHT IN TIME, " & + "BUT OTHER ERROR"); + ELSE + FAILED ("RESULT OF ALLOCATOR ACCESSED BEFORE " & + "TASK ACTIVATION HAS COMPLETED"); + END IF; + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + END BLOCK; + + RESULT; + + END C93008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- C940001.A + -- + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a protected object provides coordinated access to + -- shared data. Check that it can be used to sequence a number of tasks. + -- Use the protected object to control a single token for which three + -- tasks compete. Check that only one task is running at a time and that + -- all tasks get a chance to run sometime. + -- + -- TEST DESCRIPTION: + -- Declare a protected type with two entries. A task may call the Take + -- entry to get a token which allows it to continue processing. If it + -- has the token, it may call the Give entry to return it. The tasks + -- implement a discipline whereby only the task with the token may be + -- active. The test does not require any specific order for the tasks + -- to run. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 07 Jul 96 SAIC Fixed spelling nits. + -- + --! + + package C940001_0 is + + type Token_Type is private; + True_Token : constant Token_Type; -- Create a deferred constant in order + -- to provide a component init for the + -- protected object + + protected type Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type); + entry Give (T : in out Token_Type); + private + Token : Token_Type := True_Token; + end Token_Mgr_Prot_Unit; + + function Init_Token return Token_Type; -- call to initialize an + -- object of Token_Type + function Token_Value (T : Token_Type) return Boolean; + -- call to inspect the value of an + -- object of Token_Type + private + type Token_Type is new boolean; + True_Token : constant Token_Type := true; + end C940001_0; + + --=================================================================-- + + package body C940001_0 is + protected body Token_Mgr_Prot_Unit is + entry Take (T : out Token_Type) when Token = true is + begin -- Calling task will Take the token, so + T := Token; -- check first that token_mgr owns the + Token := false; -- token to give, then give it to caller + end Take; + + entry Give (T : in out Token_Type) when Token = false is + begin -- Calling task will Give the token back, + if T = true then -- so first check that token_mgr does not + Token := T; -- own the token, then check that the task has + T := false; -- the token to give, then take it from the + end if; -- task + -- if caller does not own the token, then + end Give; -- it falls out of the entry body with no + end Token_Mgr_Prot_Unit; -- action + + function Init_Token return Token_Type is + begin + return false; + end Init_Token; + + function Token_Value (T : Token_Type) return Boolean is + begin + return Boolean (T); + end Token_Value; + + end C940001_0; + + --===============================================================-- + + with Report; + with ImpDef; + with C940001_0; + + procedure C940001 is + + type TC_Int_Type is range 0..2; + -- range is very narrow so that erroneous execution may + -- raise Constraint_Error + + type TC_Artifact_Type is record + TC_Int : TC_Int_Type := 1; + Number_of_Accesses : integer := 0; + end record; + + TC_Artifact : TC_Artifact_Type; + + Sequence_Mgr : C940001_0.Token_Mgr_Prot_Unit; + + procedure Bump (Item : in out TC_Int_Type) is + begin + Item := Item + 1; + exception + when Constraint_Error => + Report.Failed ("Incremented without corresponding decrement"); + when others => + Report.Failed ("Bump raised Unexpected Exception"); + end Bump; + + procedure Decrement (Item : in out TC_Int_Type) is + begin + Item := Item - 1; + exception + when Constraint_Error => + Report.Failed ("Decremented without corresponding increment"); + when others => + Report.Failed ("Decrement raised Unexpected Exception"); + end Decrement; + + --==============-- + + task type Network_Node_Type; + + task body Network_Node_Type is + + Slot_for_Token : C940001_0.Token_Type := C940001_0.Init_Token; + + begin + + -- Ask for token - if request is not granted, task will be queued + Sequence_Mgr.Take (Slot_for_Token); + + -- Task now has token and may perform its work + + --==========================-- + -- in this case, the work is to ensure that the test results + -- are the expected ones! + --==========================-- + Bump (TC_Artifact.TC_Int); -- increment when request is granted + TC_Artifact.Number_Of_Accesses := + TC_Artifact.Number_Of_Accesses + 1; + if not C940001_0.Token_Value ( Slot_for_Token) then + Report.Failed ("Incorrect results from entry Take"); + end if; + + -- give a chance for other tasks to (incorrectly) run + delay ImpDef.Minimum_Task_Switch; + + Decrement (TC_Artifact.TC_Int); -- prepare to return token + + -- Task has completed its work and will return token + + Sequence_Mgr.Give (Slot_for_Token); -- return token to sequence manager + + if c940001_0.Token_Value (Slot_for_Token) then + Report.Failed ("Incorrect results from entry Give"); + end if; + + exception + when others => Report.Failed ("Unexpected exception raised in task"); + + end Network_Node_Type; + + --==============-- + + begin + + Report.Test ("C940001", "Check that a protected object can control " & + "tasks by coordinating access to shared data"); + + declare + Node_1, Node_2, Node_3 : Network_Node_Type; + -- declare three tasks which will compete for + -- a single token, managed by Sequence Manager + + begin -- tasks start + null; + end; -- wait for all tasks to terminate before reporting result + + if TC_Artifact.Number_of_Accesses /= 3 then + Report.Failed ("Not all tasks got through"); + end if; + + Report.Result; + + end C940001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,309 ---- + -- C940002.A + -- + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a protected object provides coordinated access to shared + -- data. Check that it can implement a semaphore-like construct using a + -- parameterless procedure which allows a specific maximum number of tasks + -- to run and excludes all others + -- + -- TEST DESCRIPTION: + -- Implement a counting semaphore type that can be initialized to a + -- specific number of available resources. Declare an entry for + -- requesting a resource and a procedure for releasing it. Declare an + -- object of this type, initialized to two resources. Declare and start + -- three tasks each of which asks for a resource. Verify that only two + -- resources are granted and that the last task in is queued. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package C940002_0 is + -- Semaphores + + protected type Semaphore_Type (Resources_Available : Integer :=1) is + entry Request; + procedure Release; + function Available return Integer; + private + Currently_Available : Integer := Resources_Available; + end Semaphore_Type; + + Max_Resources : constant Integer := 2; + Resource : Semaphore_Type (Max_Resources); + + end C940002_0; + -- Semaphores; + + + --========================================================-- + + + package body C940002_0 is + -- Semaphores + + protected body Semaphore_Type is + + entry Request when Currently_Available >0 is -- when granted, secures + begin -- a resource + Currently_Available := Currently_Available - 1; + end Request; + + procedure Release is -- when called, releases + begin -- a resource + Currently_Available := Currently_Available + 1; + end Release; + + function Available return Integer is -- returns number of + begin -- available resources + return Currently_Available; + end Available; + + end Semaphore_Type; + + end C940002_0; + -- Semaphores; + + + --========================================================-- + + + package C940002_1 is + -- Task_Pkg + + task type Requesting_Task is + entry Done; -- call on Done instructs the task + end Requesting_Task; -- to release resource + + type Task_Ptr is access Requesting_Task; + + protected Counter is + procedure Increment; + procedure Decrement; + function Number return integer; + private + Count : Integer := 0; + end Counter; + + protected Hold_Lock is + procedure Lock; + procedure Unlock; + function Locked return Boolean; + private + Lock_State : Boolean := true; -- starts out locked + end Hold_Lock; + + + end C940002_1; + -- Task_Pkg + + + --========================================================-- + + + with Report; + with C940002_0; + -- Semaphores; + + package body C940002_1 is + -- Task_Pkg is + + protected body Counter is + + procedure Increment is + begin + Count := Count + 1; + end Increment; + + procedure Decrement is + begin + Count := Count - 1; + end Decrement; + + function Number return Integer is + begin + return Count; + end Number; + + end Counter; + + + protected body Hold_Lock is + + procedure Lock is + begin + Lock_State := true; + end Lock; + + procedure Unlock is + begin + Lock_State := false; + end Unlock; + + function Locked return Boolean is + begin + return Lock_State; + end Locked; + + end Hold_Lock; + + + task body Requesting_Task is + begin + C940002_0.Resource.Request; -- request a resource + -- if resource is not available, + -- task will be queued to wait + Counter.Increment; -- add to count of resources obtained + Hold_Lock.Unlock; -- and unlock Lock - system is stable; + -- status may now be queried + + accept Done do -- hold resource until Done is called + C940002_0.Resource.Release; -- release the resource and + Counter.Decrement; -- note release + end Done; + + exception + when others => Report.Failed ("Unexpected Exception in Requesting_Task"); + end Requesting_Task; + + end C940002_1; + -- Task_Pkg; + + + --========================================================-- + + + with Report; + with ImpDef; + with C940002_0, + -- Semaphores, + C940002_1; + -- Task_Pkg; + + procedure C940002 is + + package Semaphores renames C940002_0; + package Task_Pkg renames C940002_1; + + Ptr1, + Ptr2, + Ptr3 : Task_Pkg.Task_Ptr; + Num : Integer; + + procedure Spinlock is + begin + -- loop until unlocked + while Task_Pkg.Hold_Lock.Locked loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Task_Pkg.Hold_Lock.Lock; + end Spinlock; + + begin + + Report.Test ("C940002", "Check that a protected record can be used to " & + "control access to resources"); + + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Wrong initial conditions"); + end if; + + Ptr1 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- One resource assigned to task 1 + -- One resource still available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Ptr2 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be granted + Spinlock; -- ensure that task obtains resource + + -- Task 1 waiting for call to Done + -- Task 2 waiting for call to Done + -- Resources held by tasks 1 and 2 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + Ptr3 := new Task_Pkg.Requesting_Task; -- newly allocated task requests + -- resource; request for resource should + -- be denied and task queued to wait for + -- next available resource + + + Ptr1.all.Done; -- Task 1 releases resource and lock + -- Resource should be given to queued task + Spinlock; -- ensure that resource is released + + + -- Task 1 holds no resource + -- One resource still assigned to task 2 + -- One resource assigned to task 3 + -- No resources available + if (Task_Pkg.Counter.Number /= 2) + or (Semaphores.Resource.Available /= 0) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Ptr2.all.Done; -- Task 2 releases resource and lock + -- No outstanding request for resource + + -- Tasks 1 and 2 hold no resources + -- One resource assigned to task 3 + -- One resource available + if (Task_Pkg.Counter.Number /= 1) + or (Semaphores.Resource.Available /= 1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Ptr3.all.Done; -- Task 3 releases resource and lock + + -- All resources released + -- All tasks terminated (or close) + -- Two resources available + if (Task_Pkg.Counter.Number /=0) + or (Semaphores.Resource.Available /= 2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + Report.Result; + + end C940002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940004.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,416 ---- + -- C940004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that a protected record can be used to control access to + -- resources (data internal to the protected record). + -- + -- TEST DESCRIPTION: + -- Declare a resource descriptor tagged type. Extend the type and + -- use the extended type in a protected data structure. + -- Implement a binary semaphore type. Declare an entry for + -- requesting a specific resource and an procedure for releasing the + -- same resource. Declare an object of this (protected) type. + -- Declare and start three tasks each of which asks for a resource + -- when directed to. Verify that resources are properly allocated + -- and deallocated. + -- + -- + -- CHANGE HISTORY: + -- + -- 12 DEC 93 SAIC Initial PreRelease version + -- 23 JUL 95 SAIC Second PreRelease version + -- 16 OCT 95 SAIC ACVC 2.1 + -- 13 MAR 03 RLB Fixed race condition in test. + -- + --! + + package C940004_0 is + -- Resource_Pkg + + type ID_Type is new Integer range 0..10; + type User_Descriptor_Type is tagged record + Id : ID_Type := 0; + end record; + + end C940004_0; -- Resource_Pkg + + --============================-- + -- no body for C940004_0 + --=============================-- + + with C940004_0; -- Resource_Pkg + + -- This generic package implements a semaphore to control a single resource + + generic + + type Generic_Record_Type is new C940004_0.User_Descriptor_Type + with private; + + package C940004_1 is + -- Generic_Semaphore_Pkg + -- generic package extends the tagged formal generic + -- type with some implementation relevant details, and + -- it provides a semaphore with operations that work + -- on that type + type User_Rec_Type is new Generic_Record_Type with private; + + protected type Semaphore_Type is + function TC_Count return Integer; + entry Request (R : in out User_Rec_Type); + procedure Release (R : in out User_Rec_Type); + private + In_Use : Boolean := false; + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean; + + private + + type User_Rec_Type is new Generic_Record_Type with record + Access_To_Resource : boolean := false; + end record; + + end C940004_1; -- Generic_Semaphore_Pkg + + --===================================================-- + + package body C940004_1 is + -- Generic_Semaphore_Pkg + + protected body Semaphore_Type is + + function TC_Count return Integer is + begin + return Request'Count; + end TC_Count; + + entry Request (R : in out User_Rec_Type) + when not In_Use is + begin + In_Use := true; + R.Access_To_Resource := true; + end Request; + + procedure Release (R : in out User_Rec_Type) is + begin + In_Use := false; + R.Access_To_Resource := false; + end Release; + + end Semaphore_Type; + + function Has_Access (R : User_Rec_Type) return Boolean is + begin + return R.Access_To_Resource; + end Has_Access; + + end C940004_1; -- Generic_Semaphore_Pkg + + --=============================================-- + + with Report; + with C940004_0; -- Resource_Pkg, + with C940004_1; -- Generic_Semaphore_Pkg; + + package C940004_2 is + -- Printer_Mgr_Pkg + + -- Instantiate the generic to get code to manage a single printer; + -- User processes contend for the printer, asking for it by a call + -- to Request, and relinquishing it by a call to Release + + -- This package extends a tagged type to customize it for the printer + -- in question, then it uses the type to instantiate the generic and + -- declare a semaphore specific to the particular resource + + package Resource_Pkg renames C940004_0; + + type User_Desc_Type is new Resource_Pkg.User_Descriptor_Type with record + New_Details : Integer := 0; -- for example + end record; + + package Instantiation is new C940004_1 -- Generic_Semaphore_Pkg + (Generic_Record_Type => User_Desc_Type); + + Printer_Access_Mgr : Instantiation.Semaphore_Type; + + + end C940004_2; -- Printer_Mgr_Pkg + + --============================-- + -- no body for C940004_2 + --============================-- + + with C940004_0; -- Resource_Pkg, + with C940004_2; -- Printer_Mgr_Pkg; + + package C940004_3 is + -- User_Task_Pkg + + -- This package models user tasks that will request and release + -- the printer + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + + task type User_Task_Type (ID : Resource_Pkg.ID_Type) is + entry Get_Printer; -- instructs task to request resource + + entry Release_Printer -- instructs task to release printer + (Descriptor : in out Printer_Mgr_pkg.Instantiation.User_Rec_Type); + + --==================-- + -- Test management machinery + --==================-- + entry TC_Get_Descriptor -- returns descriptor + (Descriptor : out Printer_Mgr_Pkg.Instantiation.User_Rec_Type); + + end User_Task_Type; + + --==================-- + -- Test management machinery + --==================-- + TC_Times_Obtained : Integer := 0; + TC_Times_Released : Integer := 0; + + end C940004_3; -- User_Task_Pkg; + + --==============================================-- + + with Report; + with C940004_0; -- Resource_Pkg, + with C940004_2; -- Printer_Mgr_Pkg, + + package body C940004_3 is + -- User_Task_Pkg + + task body User_Task_Type is + D : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + begin + D.Id := ID; + ----------------------------------- + Main: + loop + select + accept Get_Printer; + Printer_Mgr_Pkg.Printer_Access_Mgr.Request (D); + -- request resource; if resource is not available, + -- task will be queued to wait + --===================-- + -- Test management machinery + --===================-- + TC_Times_Obtained := TC_Times_Obtained + 1; + -- when request granted, note it and post a message + + or + accept Release_Printer (Descriptor : in out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Printer_Mgr_Pkg.Printer_Access_Mgr.Release (D); + -- release the resource, note its release + TC_Times_Released := TC_Times_Released + 1; + Descriptor := D; + end Release_Printer; + exit Main; + + or + accept TC_Get_Descriptor (Descriptor : out + Printer_Mgr_Pkg.Instantiation.User_Rec_Type) do + + Descriptor := D; + end TC_Get_Descriptor; + + end select; + end loop main; + + exception + when others => Report.Failed ("exception raised in User_Task"); + end User_Task_Type; + + end C940004_3; -- User_Task_Pkg; + + --==========================================================-- + + with Report; + with ImpDef; + + with C940004_0; -- Resource_Pkg, + with C940004_2; -- Printer_Mgr_Pkg, + with C940004_3; -- User_Task_Pkg; + + procedure C940004 is + Verbose : constant Boolean := False; + package Resource_Pkg renames C940004_0; + package Printer_Mgr_Pkg renames C940004_2; + package User_Task_Pkg renames C940004_3; + + Task1 : User_Task_Pkg.User_Task_Type (1); + Task2 : User_Task_Pkg.User_Task_Type (2); + Task3 : User_Task_Pkg.User_Task_Type (3); + + User_Rec_1, + User_Rec_2, + User_Rec_3 : Printer_Mgr_Pkg.Instantiation.User_Rec_Type; + + begin + + Report.Test ("C940004", "Check that a protected record can be used to " & + "control access to resources"); + + if (User_Task_Pkg.TC_Times_Obtained /= 0) + or (User_Task_Pkg.TC_Times_Released /= 0) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Get_Printer; -- ask for resource + -- request for resource should be granted + Task1.TC_Get_Descriptor (User_Rec_1);-- wait here 'til task gets resource + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task queued to wait + + -- Task 1 still waiting to accept Release_Printer, still holds resource + -- Task 2 queued on Semaphore.Request + + -- Ensure that Task2 is queued before continuing to make checks and queue + -- Task3. We use a for loop here to avoid hangs in broken implementations. + for TC_Cnt in 1 .. 20 loop + exit when Printer_Mgr_Pkg.Printer_Access_Mgr.TC_Count >= 1; + delay Impdef.Minimum_Task_Switch; + end loop; + + if (User_Task_Pkg.TC_Times_Obtained /= 1) + or (User_Task_Pkg.TC_Times_Released /= 0) then + Report.Failed ("Resource assigned to task 2"); + end if; + + Task3.Get_Printer; -- ask for resource + -- request for resource should be denied + -- and task 3 queued on Semaphore.Request + + Task1.Release_Printer (User_Rec_1);-- task 1 releases resource + -- released resource should be given to + -- queued task 2. + + Task2.TC_Get_Descriptor (User_Rec_2);-- wait here for task 2 + + -- Task 1 has released resource and completed + -- Task 2 has seized the resource + -- Task 3 is queued on Semaphore.Request + + if (User_Task_Pkg.TC_Times_Obtained /= 2) + or (User_Task_Pkg.TC_Times_Released /= 1) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_1) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) then + Report.Failed ("Resource not properly released/assigned" & + " to task 2"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + end if; + end if; + + Task2.Release_Printer (User_Rec_2);-- task 2 releases resource + + -- task 3 is released from queue, and is given resource + + Task3.TC_Get_Descriptor (User_Rec_3);-- wait for task 3 + + if (User_Task_Pkg.TC_Times_Obtained /= 3) + or (User_Task_Pkg.TC_Times_Released /= 2) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_2) + or not Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released/assigned " & + "to task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + end if; + + Task3.Release_Printer (User_Rec_3);-- task 3 releases resource + + if (User_Task_Pkg.TC_Times_Obtained /=3) + or (User_Task_Pkg.TC_Times_Released /=3) + or Printer_Mgr_Pkg.Instantiation.Has_Access (User_Rec_3) then + Report.Failed ("Resource not properly released by task 3"); + if Verbose then + Report.Comment ("TC_Times_Obtained: " & + Integer'Image (User_Task_Pkg.TC_Times_Obtained)); + Report.Comment ("TC_Times_Released: " & + Integer'Image (User_Task_Pkg.TC_Times_Released)); + Report.Comment ("User 1 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_1))); + Report.Comment ("User 2 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_2))); + Report.Comment ("User 3 Has_Access:" & + Boolean'Image (Printer_Mgr_Pkg.Instantiation. + Has_Access (User_Rec_3))); + end if; + + end if; + + -- Ensure that all tasks have terminated before reporting the result + while not (Task1'terminated + and Task2'terminated + and Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C940004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940005.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,370 ---- + -- C940005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the body of a protected function can have internal calls + -- to other protected functions and that the body of a protected + -- procedure can have internal calls to protected procedures and to + -- protected functions. + -- + -- TEST DESCRIPTION: + -- Simulate a meter at a freeway on-ramp which, when real-time sensors + -- determine that the freeway is becoming saturated, triggers stop lights + -- which control the access of vehicles to prevent further saturation. + -- Each on-ramp is represented by a protected object - in this case only + -- one is shown (Test_Ramp). The routines to sample and alter the states + -- of the various sensors, to queue the vehicles on the meter and to + -- release them are all part of the protected object and can be shared + -- by various tasks. Apart from the function/procedure tests this example + -- has a mix of other tasking features. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Nov 95 SAIC Updated and fixed bugs ACVC 2.0.1 + -- + --! + + + with Report; + with ImpDef; + with Ada.Calendar; + + procedure C940005 is + + begin + + Report.Test ("C940005", "Check internal calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Multiplier : integer := 1; -- changed half way through + TC_Expected_Passage_Total : constant integer := 486; + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940006.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,223 ---- + -- C940006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the body of a protected function can have external calls + -- to other protected functions and that the body of a protected + -- procedure can have external calls to protected procedures and to + -- protected functions. + -- + -- TEST DESCRIPTION: + -- Use a subset of the simulation of the freeway on-ramp described in + -- c940005. In this case two protected objects are used but only a + -- minimum of routines are shown in each. Both objects are hard coded + -- and detail two adjacent on-ramps (Ramp_31 & Ramp_32) with routines in + -- each which use external calls to the other. + + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + + procedure C940006 is + + begin + + Report.Test ("C940006", "Check external calls of protected functions" & + " and procedures"); + + declare -- encapsulate the test + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + -- + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 3; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_31 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + function Freeway_Overload return Load_Factor; + procedure Downstream_Ramps; + function Get_DSR_Accumulate return Load_Factor; + + private + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + -- Accumulated load for next three downstream ramps + DSR_Accumulate : Load_Factor := Clear_Level; + + end Ramp_31; + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected Ramp_32 is + + function Local_Overload return Load_Factor; + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + + private + + Local_State : Load_Factor := Clear_Level; + + end Ramp_32; + --================================================================ + protected body Ramp_31 is + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload (Sensor_Level : Load_Factor) is + begin + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + null; --::::: (see Ramp_32 for this code) + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_32.Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + + -- return the summation of all the load factors + function Freeway_Overload return Load_Factor is + begin + return Local_Overload + -- + :::: others + + Next_Ramp_Overload; + end Freeway_Overload; + + -- Snapshot the states of the next three downstream ramps + procedure Downstream_Ramps is + begin + DSR_Accumulate := Ramp_32.Local_Overload; -- EXTERNAL FUNCTION + -- :::: + Ramp_33.Local_Overload -- FROM PROCEDURE + -- :::: + Ramp_34.Local_Overload + end Downstream_Ramps; + + -- Get last snapshot + function Get_DSR_Accumulate return Load_Factor is + begin + return DSR_Accumulate; + end Get_DSR_Accumulate; + + end Ramp_31; + --================================================================ + protected body Ramp_32 is + + function Local_Overload return Load_Factor is + begin + return Local_State; + end; + + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_31.Notify; + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + end Ramp_32; + --================================================================ + + + + begin -- declare + + -- Test driver. This is ALL test control code + -- Simulate calls to the protected functions and procedures + -- from without the protected object, these will, in turn make the + -- external calls. + + -- Check initial conditions, exercising the simple calls + if not (Ramp_31.Local_Overload = Clear_Level and + Ramp_31.Next_Ramp_Overload = Clear_Level and + Ramp_31.Freeway_Overload = Clear_Level) and + Ramp_32.Local_Overload = Clear_Level then + Report.Failed ("Initial Calls provided unexpected Results"); + end if; + + -- Simulate real-time sensors reporting overloads at a hardware level + Ramp_31.Set_Local_Overload (1); + Ramp_32.Set_Local_Overload (3); + + Ramp_31.Downstream_Ramps; -- take the current snapshot + + if not (Ramp_31.Local_Overload = Minimum_Level and + Ramp_31.Get_DSR_Accumulate = Moderate_Level and + Ramp_31.Freeway_Overload = Serious_Level) then + Report.Failed ("Secondary Calls provided unexpected Results"); + end if; + + end; -- declare + + Report.Result; + + end C940006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940007.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,427 ---- + -- C940007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the body of a protected function declared as an object of a + -- given type can have internal calls to other protected functions and + -- that a protected procedure in such an object can have internal calls + -- to protected procedures and to protected functions. + -- + -- TEST DESCRIPTION: + -- Simulate a meter at a freeway on-ramp which, when real-time sensors + -- determine that the freeway is becoming saturated, triggers stop lights + -- which control the access of vehicles to prevent further saturation. + -- Each on-ramp is represented by a protected object of the type Ramp. + -- The routines to sample and alter the states of the various sensors, to + -- queue the vehicles on the meter and to release them are all part of + -- the protected object and can be shared by various tasks. Apart from + -- the function/procedure tests this example has a mix of other tasking + -- features. In this test two objects representing two adjacent ramps + -- are created from the same type. The same "traffic" is simulated for + -- each ramp. The results should be identical. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Nov 95 SAIC Replaced shared global variable Pulse_Stop + -- with a protected object. + -- ACVC 2.0.1 + -- + --! + + + with Report; + with ImpDef; + with Ada.Calendar; + + + procedure C940007 is + + begin + + Report.Test ("C940007", "Check internal calls of protected functions" & + " and procedures in objects declared as a type"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + -- Weighted loads given to each Sample Point (pure weights, not levels) + Local_Overload_wt : constant Load_Factor := 1; + Next_Ramp_in_Overload_wt : constant Load_Factor := 1; + Ramp_Junction_in_Overload_wt : constant Load_Factor :=2; --higher wght + -- :::: other weighted loads + + TC_Expected_Passage_Total : integer := 486; + + + -- This is the time between synchronizing pulses to the ramps. + -- In reality one would expect a time of 5 to 10 seconds. In + -- the interests of speeding up the test suite a shorter time + -- is used + Pulse_Time_Delta : constant duration := ImpDef.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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940010.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,269 ---- + -- C940010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if an exception is raised during the execution of an + -- entry body it is propagated back to the caller + -- + -- TEST DESCRIPTION: + -- Use a small fragment of code from the simulation of a freeway meter + -- used in c940007. Create three individual tasks which will be queued on + -- the entry as the barrier is set. Release them one at a time. A + -- procedure which is called within the entry has been modified for this + -- test to raise a different exception for each pass through. Check that + -- all expected exceptions are raised and propagated. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with ImpDef; + + procedure C940010 is + + TC_Failed_1 : Boolean := false; + + begin + + Report.Test ("C940010", "Check that an exception raised in an entry " & + "body is propagated back to the caller"); + + declare -- encapsulate the test + + TC_Defined_Error : Exception; -- User defined exception + TC_Expected_Passage_Total : constant integer := 669; + TC_Int : constant integer := 5; + + -- Carrier tasks. One is created for each vehicle arriving at each ramp + task type Vehicle_31; -- For Ramp_31 + type acc_Vehicle_31 is access Vehicle_31; + + + --================================================================ + protected Ramp_31 is + + function Meter_in_Use_State return Boolean; + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + entry Wait_at_Meter; + procedure Pulse; + -- + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Current_Exception return integer; + + private + + Release_One_Vehicle : Boolean := false; + Meter_in_Use : Boolean := true; -- TC: set true for this test + -- + TC_Multiplier : integer := 1; + TC_Passage_Total : integer := 0; + -- Use this to cycle through the required exceptions + TC_Current_Exception : integer range 0..3 := 0; + + end Ramp_31; + --================================================================ + protected body Ramp_31 is + + + -- Trace the paths through the various routines by totaling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total+(Pass_Point*TC_Multiplier); + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Current_Exception return integer is + begin + return TC_Current_Exception; + end TC_Get_Current_Exception; + + + ----------------- + + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Simulate the effects of the regular signal pulse + procedure Pulse is + begin + Release_one_Vehicle := true; + end Pulse; + + -- Keep count of vehicles currently on meter queue - we can't use + -- the 'count because we need the outcall trigger + procedure Add_Meter_Queue is + begin + null; --::: stub + end Add_Meter_Queue; + + -- TC: This routine has been modified to raise the required + -- exceptions + procedure Subtract_Meter_Queue is + TC_Pass_Point1 : constant integer := 10; + TC_Pass_Point2 : constant integer := 20; + TC_Pass_Point3 : constant integer := 30; + TC_Pass_Point9 : constant integer := 1000; -- error + begin + -- Cycle through the required exceptions, one per call + TC_Current_Exception := TC_Current_Exception + 1; + case TC_Current_Exception is + when 1 => + TC_Passage (TC_Pass_Point1); -- note passage through here + raise Storage_Error; -- PREDEFINED EXCEPTION + when 2 => + TC_Passage (TC_Pass_Point2); -- note passage through here + raise TC_Defined_Error; -- USER DEFINED EXCEPTION + when 3 => + TC_Passage (TC_Pass_Point3); -- note passage through here + -- RUN TIME EXCEPTION (Constraint_Error) + -- Add the value 3 to 5 then try to assign it to an object + -- whose range is 0..3 - this causes the exception. + -- Disguise the values which cause the Constraint_Error + -- so that the optimizer will not eliminate this code + -- Note: the variable is checked at the end to ensure + -- that the actual assignment is attempted. Also note + -- the value remains at 3 as the assignment does not + -- take place. This is the value that is checked at + -- the end of the test. + -- Otherwise the optimizer could decide that the result + -- of the assignment was not used so why bother to do it? + TC_Current_Exception := + Report.Ident_Int (TC_Current_Exception) + + Report.Ident_Int (TC_Int); + when others => + -- Set flag for Report.Failed which cannot be called from + -- within a Protected Object + TC_Failed_1 := True; + end case; + + TC_Passage ( TC_Pass_Point9 ); -- note passage through here + end Subtract_Meter_Queue; + + -- Here each Vehicle task queues itself awaiting release + entry Wait_at_Meter when Release_One_Vehicle is + -- Example of entry with barriers and persistent signal + TC_Pass_Point : constant integer := 2; + begin + TC_Passage ( TC_Pass_Point ); -- note passage through here + Release_One_Vehicle := false; -- Consume the signal + -- Decrement number of vehicles on ramp + Subtract_Meter_Queue; -- Call procedure from within entry body + end Wait_at_Meter; + + end Ramp_31; + --================================================================ + + -- Carrier task. One is created for each vehicle arriving at Ramp_31 + task body Vehicle_31 is + TC_Pass_Point_1 : constant integer := 100; + TC_Pass_Point_2 : constant integer := 200; + TC_Pass_Point_3 : constant integer := 300; + begin + if Ramp_31.Meter_in_Use_State then + -- Increment count of number of vehicles on ramp + Ramp_31.Add_Meter_Queue; -- Call a protected procedure + -- which is also called from within + -- enter the meter queue + Ramp_31.Wait_at_Meter; -- Call a protected entry + Report.Failed ("Exception not propagated back"); + end if; + null; --:::: call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + exception + when Storage_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_1 ); -- note passage + when TC_Defined_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_2 ); -- note passage + when Constraint_Error => + Ramp_31.TC_Passage ( TC_Pass_Point_3 ); -- note passage + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle_31; + + -- Simulate the arrival of a vehicle at the Ramp_Receiver of Ramp_31 + -- and the generation of an accompanying carrier task + procedure New_Arrival_31 is + Next_Vehicle_Task_31: acc_Vehicle_31 := new Vehicle_31; + TC_Pass_Point : constant integer := 1; + begin + Ramp_31.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; --::: stub + end New_arrival_31; + + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Create three independent tasks which will queue themselves on the + -- entry. Each task will get a different exception + New_Arrival_31; + New_Arrival_31; + New_Arrival_31; + + delay ImpDef.Clear_Ready_Queue; + + -- Set the barrier condition of the entry true, releasing one task + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + Ramp_31.Pulse; + delay ImpDef.Clear_Ready_Queue; + + if (TC_Expected_Passage_Total /= Ramp_31.TC_Get_Passage_Total) or + -- Note: We are not really interested in this next check. It is + -- here to ensure the earlier statements which raised the + -- Constraint_Error are not optimized out + (Ramp_31.TC_Get_Current_Exception /= 3) then + Report.Failed ("Unexpected paths taken"); + end if; + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Bad path through Subtract_Meter_Queue"); + end if; + + Report.Result; + + end C940010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940011.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,175 ---- + -- C940011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in the body of a protected object created by the execution + -- of an allocator, external calls to other protected objects via + -- the access type are correctly performed + -- + -- TEST DESCRIPTION: + -- Use a subset of the simulation of the freeway on-ramp described in + -- c940005. In this case an array of access types is built with pointers + -- to successive ramps. The external calls within the protected + -- objects are made via the index into the array. Routines which refer + -- to the "previous" ramp and the "next" ramp are exercised. (Note: The + -- first and last ramps are assumed to be dummies and no first/last + -- condition code is included) + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + + + procedure C940011 is + + type Ramp; + type acc_Ramp is access Ramp; + + subtype Ramp_Index is integer range 1..4; + + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp is + + procedure Set_Index (Index : Ramp_Index); + procedure Set_Local_Overload (Sensor_Level : Load_Factor); + function Local_Overload return Load_Factor; + procedure Notify; + function Next_Ramp_Overload return Load_Factor; + + private + + This_Ramp : Ramp_Index; + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + + -- Build a set of Ramp objects and an array of pointers to them + -- + Ramp_Array : array (Ramp_Index) of acc_Ramp := (Ramp_Index => new Ramp); + + --================================================================ + protected body Ramp is + + procedure Set_Index (Index : Ramp_Index) is + begin + This_Ramp := Index; + end Set_Index; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + -- EXTERNAL CALL OF PROCEDURE FROM PROCEDURE + Ramp_Array(This_Ramp - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end Set_Local_Overload; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- EXTERNAL FUNCTION CALL FROM FUNCTION + -- Get next ramp's current state + return Ramp_Array(This_Ramp + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + + --================================================================ + + + begin + + + Report.Test ("C940011", "Protected Objects created by allocators: " & + "external calls via access types"); + + -- Initialize each Ramp + for i in Ramp_Index loop + Ramp_Array(i).Set_Index (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + Report.Result; + + end C940011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940012.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- C940012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a protected object can have discriminants + -- + -- TEST DESCRIPTION: + -- Use a subset of the simulation of the freeway on-ramp described in + -- c940005. In this case an array of access types is built with pointers + -- to successive ramps. Each ramp has its Ramp_Number specified by + -- discriminant and this corresponds to the index in the array. The test + -- checks that the ramp numbers are assigned as expected then uses calls + -- to procedures within the objects (ramps) to verify external calls to + -- ensure the structures are valid. The external references within the + -- protected objects are made via the index into the array. Routines + -- which refer to the "previous" ramp and the "next" ramp are exercised. + -- (Note: The first and last ramps are assumed to be dummies and no + -- first/last condition code is included) + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + + + procedure C940012 is + + type Ramp_Index is range 1..4; + + type Ramp; + type a_Ramp is access Ramp; + + Ramp_Array : array (Ramp_Index) of a_Ramp; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Moderate_Level : constant Load_Factor := 3; + + --================================================================ + -- Only the Routines that are used in this test are shown + -- + protected type Ramp (Ramp_In : Ramp_Index) is + + function Ramp_Number return Ramp_Index; + function Local_Overload return Load_Factor; + function Next_Ramp_Overload return Load_Factor; + procedure Set_Local_Overload(Sensor_Level : Load_Factor); + procedure Notify; + + private + + Next_Ramp_Alert : Boolean := false; -- Next Ramp is in trouble? + + -- Current state of the various Sample Points + Local_State : Load_Factor := Clear_Level; + + end Ramp; + --================================================================ + protected body Ramp is + + function Ramp_Number return Ramp_Index is + begin + return Ramp_In; + end Ramp_Number; + + -- These Set/Clear routines are triggered by real-time sensors that + -- reflect traffic state + procedure Set_Local_Overload(Sensor_Level : Load_Factor) is + begin + if Local_State = Clear_Level then + -- Notify "previous" ramp to check this one for current state. + -- Subsequent changes in state will not send an alert + -- When the situation clears another routine performs the + -- all_clear notification. (not shown) + Ramp_Array(Ramp_In - 1).Notify; -- index to previous ramp + end if; + Local_State := Sensor_Level; + null; --::::: Start local meter if not already started + end; + + function Local_Overload return Load_Factor is + begin + return Local_State; + end Local_Overload; + + -- This is notification from the next ramp that it is in + -- overload. With this provision we only need to sample the next + -- ramp during adverse conditions. + procedure Notify is + begin + Next_Ramp_Alert := true; + end Notify; + + function Next_Ramp_Overload return Load_Factor is + begin + if Next_Ramp_Alert then + -- Get next ramp's current state + return Ramp_Array(Ramp_In + 1).Local_Overload; + else + return Clear_Level; + end if; + end Next_Ramp_Overload; + end Ramp; + --================================================================ + + begin + + + Report.Test ("C940012", "Check that a protected object " & + "can have discriminants"); + + -- Build the ramps and populate the ramp array + for i in Ramp_Index loop + Ramp_Array(i) := new Ramp (i); + end loop; + + -- Test driver. This is ALL test control code + + -- Check the assignment of the index + for i in Ramp_Index loop + if Ramp_Array(i).Ramp_Number /= i then + Report.Failed ("Ramp_Number assignment incorrect"); + end if; + end loop; + + -- Simulate calls to the protected functions and procedures + -- external calls. (do not call the "dummy" end ramps) + + -- Simple Call + if Ramp_Array(2).Next_Ramp_Overload /= Clear_level then + Report.Failed ("Primary call incorrect"); + end if; + + -- Call which results in an external procedure call via the array + -- index from within the protected object + Ramp_Array(3).Set_Local_Overload (Moderate_Level); + + -- Call which results in an external function call via the array + -- index from within the protected object + if Ramp_Array(2).Next_Ramp_Overload /= Moderate_level then + Report.Failed ("Secondary call incorrect"); + end if; + + + Report.Result; + + end C940012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940013.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,379 ---- + -- C940013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that items queued on a protected entry are handled FIFO and that + -- the 'count attribute of that entry reflects the length of the queue. + -- + -- TEST DESCRIPTION: + -- Use a small subset of the freeway ramp simulation shown in other + -- tests. With the timing pulse off (which prevents items from being + -- removed from the queue) queue up a small number of calls. Start the + -- timing pulse and, at the first execution of the entry code, check the + -- 'count attribute. Empty the queue. Pass the items being removed from + -- the queue to the Ramp_Sensor_01 task; there check that the items are + -- arriving in FIFO order. Check the final 'count value + -- + -- Send another batch of items at a rate which will, if the delay timing + -- of the implementation is reasonable, cause the queue length to + -- fluctuate in both directions. Again check that all items arrive + -- FIFO. At the end check that the 'count returned to zero reflecting + -- the empty queue. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + with Ada.Calendar; + + procedure C940013 is + + TC_Failed_1 : Boolean := false; + + begin + + Report.Test ("C940013", "Check that queues on protected entries are " & + "handled FIFO and that 'count is correct"); + + declare -- encapsulate the test + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + -- Weighted load given to each potential problem area and accumulated + type Load_Factor is range 0..8; + Clear_Level : constant Load_Factor := 0; + Minimum_Level : constant Load_Factor := 1; + Moderate_Level : constant Load_Factor := 2; + Serious_Level : constant Load_Factor := 4; + Critical_Level : constant Load_Factor := 6; + + TC_Expected_Passage_Total : constant integer := 624; + + -- For this test give each vehicle an integer ID incremented + -- by one for each successive vehicle. In reality this would be + -- a more complex alpha-numeric ID assigned at pickup time. + type Vehicle_ID is range 1..5000; + Next_ID : Vehicle_ID := Vehicle_ID'first; + + -- In reality this would be about 5 seconds. The default value of + -- this constant in the implementation defined package is similar + -- but could, of course be considerably different - it would not + -- affect the test + -- + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + + task Pulse_Task; -- task to generate a pulse for each ramp + + -- Carrier task. One is created for each vehicle arriving at the ramp + task type Vehicle is + entry Get_ID (Input_ID : in Vehicle_ID); + end Vehicle; + type acc_Vehicle is access Vehicle; + + task Ramp_Sensor_01 is + entry Accept_Vehicle (Input_ID : in Vehicle_ID); + entry TC_First_Three_Handled; + entry TC_All_Done; + end Ramp_Sensor_01; + + protected Pulse_State is + procedure Start_Pulse; + procedure Stop_Pulse; + function Pulsing return Boolean; + private + State : Boolean := false; -- start test will pulse off + end Pulse_State; + + protected body Pulse_State is + + procedure Start_Pulse is + begin + State := true; + end Start_Pulse; + + procedure Stop_Pulse is + begin + State := false; + end Stop_Pulse; + + function Pulsing return Boolean is + begin + return State; + end Pulsing; + + end Pulse_State; + + --================================================================ + protected Test_Ramp is + + function Meter_in_use_State return Boolean; + procedure Time_Pulse_Received; + entry Wait_at_Meter; + procedure TC_Passage (Pass_Point : Integer); + function TC_Get_Passage_Total return integer; + function TC_Get_Count return integer; + + private + + Release_One_Vehicle : Boolean := false; + -- For this test have Meter_in_Use already set + Meter_in_Use : Boolean := true; + + TC_Wait_at_Meter_First : Boolean := true; + TC_Entry_Queue_Count : integer := 0; -- 'count of Wait_at_Meter + TC_Passage_Total : integer := 0; + TC_Pass_Point_WAM : integer := 23; + + end Test_Ramp; + --================================================================ + protected body Test_Ramp is + + -- External call for Meter_in_Use + function Meter_in_Use_State return Boolean is + begin + return Meter_in_Use; + end Meter_in_Use_State; + + -- Trace the paths through the various routines by totalling the + -- weighted call parameters + procedure TC_Passage (Pass_Point : Integer) is + begin + TC_Passage_Total := TC_Passage_Total + Pass_Point; + end TC_Passage; + + -- For the final check of the whole test + function TC_Get_Passage_Total return integer is + begin + return TC_Passage_Total; + end TC_Get_Passage_Total; + + function TC_Get_Count return integer is + begin + return TC_Entry_Queue_Count; + end TC_Get_Count; + + + -- Here each Vehicle task queues itself awaiting release + -- + entry Wait_at_Meter when Release_One_Vehicle is + -- EXAMPLE OF ENTRY WITH BARRIERS AND PERSISTENT SIGNAL + begin + -- + TC_Passage ( TC_Pass_Point_WAM ); -- note passage + -- For this test three vehicles are queued before the first + -- is released. If the queueing mechanism is working correctly + -- the first time we pass through here the entry'count should + -- reflect this + if TC_Wait_at_Meter_First then + if Wait_at_Meter'count /= 2 then + TC_Failed_1 := true; + end if; + TC_Wait_at_Meter_First := false; + end if; + TC_Entry_Queue_Count := Wait_at_Meter'count; -- note for later + + Release_One_Vehicle := false; -- Consume the signal + null; -- stub ::: Decrement count of number of vehicles on ramp + end Wait_at_Meter; + + + procedure Time_Pulse_Received is + Load : Load_factor := Minimum_Level; -- for this version of the + Freeway_Breakdown : Boolean := false; -- test, freeway is Minimum + begin + -- if broken down, no vehicles are released + if not Freeway_Breakdown then + if Load < Moderate_Level then + Release_One_Vehicle := true; + end if; + null; -- stub ::: If other levels, release every other + -- pulse, every third pulse etc. + end if; + end Time_Pulse_Received; + + end Test_Ramp; + --================================================================ + + -- Simulate the arrival of a vehicle at the Ramp_Receiver and the + -- generation of an accompanying carrier task + procedure New_Arrival is + Next_Vehicle_Task: acc_Vehicle := new Vehicle; + TC_Pass_Point : constant integer := 3; + begin + Next_ID := Next_ID + 1; + Next_Vehicle_Task.Get_ID(Next_ID); + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- Note passage through here + null; + end New_arrival; + + + -- Carrier task. One is created for each vehicle arriving at the ramp + task body Vehicle is + This_ID : Vehicle_ID; + TC_Pass_Point_2 : constant integer := 21; + begin + accept Get_ID (Input_ID : in Vehicle_ID) do + This_ID := Input_ID; + end Get_ID; + + if Test_Ramp.Meter_in_Use_State then + Test_Ramp.TC_Passage ( TC_Pass_Point_2 ); -- note passage + null; -- stub::: Increment count of number of vehicles on ramp + Test_Ramp.Wait_at_Meter; -- Queue on the meter entry + end if; + + -- Call to the first in the series of the Ramp_Sensors + -- this "passes" the vehicle from one sensor to the next + -- Each sensor will requeue the call to the next thus this + -- rendezvous will only be completed as the vehicle is released + -- by the last sensor on the ramp. + Ramp_Sensor_01.Accept_Vehicle (This_ID); + exception + when others => + Report.Failed ("Unexpected exception in Vehicle Task"); + end Vehicle; + + task body Ramp_Sensor_01 is + TC_Pass_Point : constant integer := 31; + This_ID : Vehicle_ID; + TC_Last_ID : Vehicle_ID := Vehicle_ID'first; + begin + loop + select + accept Accept_Vehicle (Input_ID : in Vehicle_ID) do + null; -- stub:::: match up with next Real-Time notification + -- from the sensor. Requeue to next ramp sensor + This_ID := Input_ID; + + -- The following is all Test_Control code + Test_Ramp.TC_Passage ( TC_Pass_Point ); -- note passage + -- The items arrive in the order they are taken from + -- the Wait_at_Meter entry queue + if ( This_ID - TC_Last_ID ) /= 1 then + -- The tasks are being queued (or unqueued) in the + -- wrong order + Report.Failed + ("Queueing on the Wait_at_Meter queue failed"); + end if; + TC_Last_ID := This_ID; -- for the next check + if TC_Last_ID = 4 then + -- rendezvous with the test driver + accept TC_First_Three_Handled; + elsif TC_Last_ID = 9 then + -- rendezvous with the test driver + accept TC_All_Done; + end if; + end Accept_Vehicle; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Ramp_Sensor_01"); + end Ramp_Sensor_01; + + + -- Task transmits a synchronizing "pulse" to all ramps + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + begin + While not Pulse_State.Pulsing loop + -- Starts up in the quiescent state + delay ImpDef.Minimum_Task_Switch; + end loop; + Pulse_Time := Ada.Calendar.Clock; + While Pulse_State.Pulsing loop + delay until Pulse_Time; + Test_Ramp. Time_Pulse_Received; -- Transmit pulse to test_ramp + -- :::::::::: and to all the other ramps + Pulse_Time := Pulse_Time + Pulse_Time_Delta; -- calculate next + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + begin -- declare + + -- Test driver. This is ALL test control code + + -- Arrange to queue three vehicles on the Wait_at_Meter queue. The + -- timing pulse is quiescent so the queue will build + for i in 1..3 loop + New_Arrival; + end loop; + + delay Pulse_Time_Delta; -- ensure all is settled + + Pulse_State.Start_Pulse; -- Start the timing pulse, the queue will + -- be serviced + + -- wait here until the first three are complete + Ramp_Sensor_01.TC_First_Three_Handled; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Intermediate Wait_at_Entry'count is incorrect"); + end if; + + -- generate new arrivals at a rate that will make the queue increase + -- and decrease "randomly" + for i in 1..5 loop + New_Arrival; + delay Pulse_Time_Delta/2; + end loop; + + -- wait here till all have been handled + Ramp_Sensor_01.TC_All_Done; + + if Test_Ramp.TC_Get_Count /= 0 then + Report.Failed ("Final Wait_at_Entry'count is incorrect"); + end if; + + Pulse_State.Stop_Pulse; -- finish test + + + if TC_Expected_Passage_Total /= Test_Ramp.TC_Get_Passage_Total then + Report.Failed ("Unexpected paths taken"); + end if; + + + end; -- declare + + if TC_Failed_1 then + Report.Failed ("Wait_at_Meter'count incorrect"); + end if; + + Report.Result; + + end C940013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940014.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,177 ---- + -- C940014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that as part of the finalization of a protected object + -- each call remaining on an entry queue of the objet is removed + -- from its queue and Program_Error is raised at the place of + -- the corresponding entry_call_statement. + -- + -- TEST DESCRIPTION: + -- The example in 9.4(20a-20f);6.0 demonstrates how to cause a + -- protected object to finalize while tasks are still waiting + -- on its entry queues. The first part of this test mirrors + -- that example. The second part of the test expands upon + -- the example code to add an object with finalization code + -- to the protected object. The finalization code should be + -- executed after Program_Error is raised in the callers left + -- on the entry queues. + -- + -- + -- CHANGE HISTORY: + -- 08 Jan 96 SAIC Initial Release for 2.1 + -- 10 Jul 96 SAIC Incorporated Reviewer comments to fix race + -- condition. + -- + --! + + + with Ada.Finalization; + package C940014_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); + end C940014_0; + + + with Report; + with ImpDef; + package body C940014_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; + end C940014_0; + + + + with Report; + with ImpDef; + with Ada.Finalization; + with C940014_0; + + procedure C940014 is + Verbose : constant Boolean := C940014_0.Verbose; + + begin + + Report.Test ("C940014", "Check that the finalization of a protected" & + " object results in program_error being raised" & + " at the point of the entry call statement for" & + " any tasks remaining on any entry queue"); + + First_Check: declare + -- example from ARM 9.4(20a-f);6.0 with minor mods + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- First_Check + begin + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in First_Check"); + exception + when Program_Error => + if Verbose then + Report.Comment ("ARM Example passed"); + end if; + when others => + Report.Failed ("wrong exception in First_Check"); + end; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + task T is + entry E; + end T; + task body T is + protected PO is + entry Ee; + private + Component : C940014_0.Has_Finalization; + end PO; + protected body PO is + entry Ee when Report.Ident_Bool (False) is + begin + null; + end Ee; + end PO; + begin + accept E do + requeue PO.Ee; + end E; + if Verbose then + Report.Comment ("task about to terminate"); + end if; + end T; + begin -- Second_Check + T.E; + delay ImpDef.Clear_Ready_Queue; + Report.Failed ("exception not raised in Second_Check"); + exception + when Program_Error => + if C940014_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization"); + elsif Verbose then + Report.Comment ("Second_Check passed"); + end if; + when others => + Report.Failed ("Wrong exception in Second_Check"); + end Second_Check; + + + Report.Result; + + end C940014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940015.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- C940015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that the component_declarations of a protected_operation + -- are elaborated in the proper order. + -- + -- TEST DESCRIPTION: + -- A discriminated protected object is declared with some + -- components that depend upon the discriminant and some that + -- do not depend upon the discriminant. All the components + -- are initialized with a function call. As a side-effect of + -- the function call the parameter passed to the function is + -- recorded in an elaboration order array. + -- Two objects of the protected type are declared. The + -- elaboration order is recorded and checked against the + -- expected order. + -- + -- + -- CHANGE HISTORY: + -- 09 Jan 96 SAIC Initial Version for 2.1 + -- 09 Jul 96 SAIC Addressed reviewer comments. + -- 13 Feb 97 PWB.CTA Removed doomed attempt to check per-object + -- constraint elaborations. + --! + + + with Report; + + procedure C940015 is + Verbose : constant Boolean := False; + Do_Display : Boolean := Verbose; + + type Index is range 0..10; + + type List is array (1..10) of Integer; + Last : Natural range 0 .. List'Last := 0; + E_List : List := (others => 0); + + function Elaborate (Id : Integer) return Index is + begin + Last := Last + 1; + E_List (Last) := Id; + if Verbose then + Report.Comment ("Elaborating" & Integer'Image (Id)); + end if; + return Index(Id mod 10); + end Elaborate; + + function Elaborate (Id, Per_Obj_Expr : Integer) return Index is + begin + return Elaborate (Id); + end Elaborate; + + begin + + Report.Test ("C940015", "Check that the component_declarations of a" & + " protected object are elaborated in the" & + " proper order"); + declare + -- an unprotected queue type + type Storage is array (Index range <>) of Integer; + type Queue (Size, Flag : Index := 1) is + record + Head : Index := 1; + Tail : Index := 1; + Count : Index := 0; + Buffer : Storage (1..Size); + end record; + + -- protected group of queues type + protected type Prot_Queues (Size : Index := Elaborate (104)) is + procedure Clear; + -- other needed procedures not provided at this time + private + -- elaborate at type elaboration + Fixed_Queue_1 : Queue (3, + Elaborate (105)); + -- elaborate at type elaboration + Fixed_Queue_2 : Queue (6, + Elaborate (107)); + end Prot_Queues; + protected body Prot_Queues is + procedure Clear is + begin + Fixed_Queue_1.Count := 0; + Fixed_Queue_1.Head := 1; + Fixed_Queue_1.Tail := 1; + Fixed_Queue_2.Count := 0; + Fixed_Queue_2.Head := 1; + Fixed_Queue_2.Tail := 1; + end Clear; + end Prot_Queues; + + PO1 : Prot_Queues(9); + PO2 : Prot_Queues; + + Expected_Elab_Order : List := ( + -- from the elaboration of the protected type Prot_Queues + 105, 107, + -- from the unconstrained object PO2 + 104, + others => 0); + begin + for I in List'Range loop + if E_List (I) /= Expected_Elab_Order (I) then + Report.Failed ("wrong elaboration order"); + Do_Display := True; + end if; + end loop; + if Do_Display then + Report.Comment ("Expected Actual"); + for I in List'Range loop + Report.Comment ( + Integer'Image (Expected_Elab_Order(I)) & + Integer'Image (E_List(I))); + end loop; + end if; + + -- make use of the protected objects + PO1.Clear; + PO2.Clear; + end; + + Report.Result; + + end C940015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940016.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,211 ---- + -- C940016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that an Unchecked_Deallocation of a protected object + -- performs the required finalization on the protected object. + -- + -- TEST DESCRIPTION: + -- Test that finalization takes place when an Unchecked_Deallocation + -- deallocates a protected object with queued callers. + -- Try protected objects that have no other finalization code and + -- protected objects with user defined finalization. + -- + -- + -- CHANGE HISTORY: + -- 16 Jan 96 SAIC ACVC 2.1 + -- 10 Jul 96 SAIC Fixed race condition noted by reviewers. + -- + --! + + + with Ada.Finalization; + package C940016_0 is + Verbose : constant Boolean := False; + Finalization_Occurred : Boolean := False; + + type Has_Finalization is new Ada.Finalization.Limited_Controlled with + record + Placeholder : Integer; + end record; + procedure Finalize (Object : in out Has_Finalization); + end C940016_0; + + + with Report; + with ImpDef; + package body C940016_0 is + procedure Finalize (Object : in out Has_Finalization) is + begin + delay ImpDef.Clear_Ready_Queue; + Finalization_Occurred := True; + if Verbose then + Report.Comment ("in Finalize"); + end if; + end Finalize; + end C940016_0; + + + + with Report; + with Ada.Finalization; + with C940016_0; + with Ada.Unchecked_Deallocation; + with ImpDef; + + procedure C940016 is + Verbose : constant Boolean := C940016_0.Verbose; + + begin + + Report.Test ("C940016", "Check that Unchecked_Deallocation of a" & + " protected object finalizes the" & + " protected object"); + + First_Check: declare + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task"); + exception + when Program_Error => + Ok := True; + if Verbose then + Report.Comment ("Blocker received Program_Error"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker"); + end Blocker; + + begin -- First_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + end First_Check; + + + Second_Check : declare + -- here we want to check that the raising of Program_Error + -- occurs before the other finalization actions. + protected type Semaphore is + entry Wait; + procedure Signal; + private + Count : Integer := 0; + Component : C940016_0.Has_Finalization; + end Semaphore; + protected body Semaphore is + entry Wait when Count > 0 is + begin + Count := Count - 1; + end Wait; + + procedure Signal is + begin + Count := Count + 1; + end Signal; + end Semaphore; + + type pSem is access Semaphore; + procedure Zap_Semaphore is new + Ada.Unchecked_Deallocation (Semaphore, pSem); + Sem_Ptr : pSem := new Semaphore; + + -- positive confirmation that Blocker got the exception + Ok : Boolean := False; + + task Blocker; + + task body Blocker is + begin + Sem_Ptr.Wait; + Report.Failed ("Program_Error not raised in waiting task 2"); + exception + when Program_Error => + Ok := True; + if C940016_0.Finalization_Occurred then + Report.Failed ("wrong order for finalization 2"); + elsif Verbose then + Report.Comment ("Blocker received Program_Error 2"); + end if; + when others => + Report.Failed ("Wrong exception in Blocker 2"); + end Blocker; + + begin -- Second_Check + -- wait for Blocker to get blocked on the semaphore + delay ImpDef.Clear_Ready_Queue; + Zap_Semaphore (Sem_Ptr); + -- make sure Blocker has time to complete + delay ImpDef.Clear_Ready_Queue * 2; + if not Ok then + Report.Failed ("finalization not properly performed 2"); + -- Blocker is probably hung so kill it + abort Blocker; + end if; + if not C940016_0.Finalization_Occurred then + Report.Failed ("user defined finalization didn't happen"); + end if; + end Second_Check; + + + Report.Result; + + end C940016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- C94001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY OBJECT + -- DECLARATIONS IS NOT TERMINATED UNTIL ALL DEPENDENT TASKS BECOME + -- TERMINATED. + -- SUBTESTS ARE: + -- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. + -- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. + -- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + + -- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + + -- JRK 10/2/81 + -- SPS 11/21/82 + -- JRK 11/29/82 + -- TBN 8/22/86 REVISED; ADDED CASES THAT EXIT BY RAISING AN + -- EXCEPTION. + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94001A IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + + BEGIN + TEST ("C94001A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(2)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(3)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + -------------------------------------------------- + + RESULT; + END C94001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,268 ---- + -- C94001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY AN OBJECT + -- DECLARATION OF LIMITED PRIVATE TYPE IS NOT TERMINATED UNTIL ALL + -- DEPENDENT TASKS BECOME TERMINATED. + -- SUBTESTS ARE: + -- (A, B) A SIMPLE TASK OBJECT, IN A BLOCK. + -- (C, D) AN ARRAY OF TASK OBJECT, IN A FUNCTION. + -- (E, F) AN ARRAY OF RECORD OF TASK OBJECT, IN A TASK BODY. + + -- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + + -- TBN 8/22/86 + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94001B IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TYPE TT IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER); + PRIVATE + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + END P; + + PACKAGE BODY P IS + + PROCEDURE CALL_ENTRY (A : TT; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + END P; + + USE P; + + + BEGIN + TEST ("C94001B", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY AN OBJECT DECLARATION OF LIMITED " & + "PRIVATE TYPE IS NOT TERMINATED UNTIL ALL " & + "DEPENDENT TASKS BECOME TERMINATED"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + CALL_ENTRY (T, IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + BEGIN -- (B) + DECLARE + T : TT; + BEGIN + CALL_ENTRY (T, IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(3)); + RETURN 0; + END F; + + BEGIN -- (C) + + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + CALL_ENTRY (A(1), IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F; + + BEGIN -- (D) + I := F; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(5)); + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60 * 60; -- ONE HOUR DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + CALL_ENTRY (AR(1).T, IDENT_INT(6)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 6"); + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN ONE " & + "HOUR - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; + END C94001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C94001C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A UNIT WITH INDIRECT DEPENDENT TASKS CREATED BY OBJECT + -- DECLARATIONS IS NOT TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS + -- BECOME TERMINATED. + -- SUBTESTS ARE: + -- (A, B) A BLOCK CONTAINING A SIMPLE TASK OBJECT, IN A BLOCK. + -- (C, D) A FUNCTION CONTAINING AN ARRAY OF TASK OBJECT, IN A + -- FUNCTION. + -- (E, F) A TASK CONTAINING AN ARRAY OF RECORD OF TASK OBJECT, + -- IN A TASK BODY. + -- CASES (B, D, F) EXIT BY RAISING AN EXCEPTION. + + -- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + + -- TBN 8/25/86 + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94001C IS + + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + + BEGIN + TEST ("C94001C", "CHECK THAT A UNIT WITH INDIRECT DEPENDENT " & + "TASKS CREATED BY OBJECT DECLARATIONS IS NOT " & + "TERMINATED UNTIL ALL INDIRECT DEPENDENT TASKS " & + "BECOME TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + + BEGIN -- (A) + + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(1)); + END; + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + + -------------------------------------------------- + + BEGIN -- (B) + GLOBAL := IDENT_INT (0); + + BEGIN + DECLARE + T : TT; + BEGIN + T.E (IDENT_INT(2)); + RAISE MY_EXCEPTION; + END; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 2"); + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(3)); + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (C) + OBJ_INT := F1; + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + OBJ_INT : INTEGER; + + FUNCTION F1 RETURN INTEGER IS + I : INTEGER; + + FUNCTION F2 RETURN INTEGER IS + A : ARRAY (1..1) OF TT; + BEGIN + A(1).E (IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 0; + END F2; + BEGIN + I := F2; + RETURN (0); + END F1; + + BEGIN -- (D) + GLOBAL := IDENT_INT (0); + OBJ_INT := F1; + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + DELAY_COUNT : INTEGER := 0; + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(5)); + END TSK; + + BEGIN + NULL; + END OUT_TSK; + + BEGIN -- (E) + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 5"); + ELSIF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 5"); + END IF; + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE + DELAY_COUNT : INTEGER := 0; + + TASK OUT_TSK; + + TASK BODY OUT_TSK IS + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE RT IS + RECORD + T : TT; + END RECORD; + AR : ARRAY (1..1) OF RT; + BEGIN + AR(1).T.E (IDENT_INT(6)); + RAISE MY_EXCEPTION; + END TSK; + + BEGIN + RAISE MY_EXCEPTION; + END OUT_TSK; + + BEGIN + WHILE NOT(OUT_TSK'TERMINATED) AND DELAY_COUNT < 60 LOOP + DELAY 1.0 * Impdef.One_Second; + DELAY_COUNT := DELAY_COUNT + 1; + END LOOP; + IF DELAY_COUNT = 60 THEN + FAILED ("OUT_TSK HAS NOT TERMINATED - 6"); + ELSIF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 6"); + END IF; + END; + + RESULT; + END C94001C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C94001E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY + -- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. + -- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. + -- VERSION WITH EXCEPTION HANDLER. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C940AGA-B.ADA + -- RLB 06/29/01 CORRECTED TO ALLOW AGGRESSIVE OPTIMIZATION. + + WITH REPORT; + USE REPORT; + PROCEDURE C94001E IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + BEGIN + + TEST ("C94001E", "TASK COMPLETION BY EXCEPTION"); + + BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + IF OBJ_I1 /= I1(IDENT_INT(0)) THEN + PSPY_NUMB (1); + ELSE + PSPY_NUMB (2); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("OTHER EXCEPTION RAISED"); + END T1; + + BEGIN + NULL; + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C94001E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- C94001F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK IS ALSO COMPLETED IF AN EXCEPTION IS RAISED BY + -- THE EXECUTION OF ITS SEQUENCE OF STATEMENTS. + -- THIS MUST HOLD FOR BOTH CASES WHERE A HANDLER IS PRESENT OR NOT. + -- VERSION WITHOUT EXCEPTION HANDLER. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C940AGB-B.ADA + + WITH REPORT; + USE REPORT; + PROCEDURE C94001F IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + BEGIN + + TEST ("C94001F", "TASK COMPLETION BY EXCEPTION -- NO HANDLER"); + + BLOCK: + DECLARE + + TASK T1; + + TASK BODY T1 IS + TYPE I1 IS RANGE 0 .. 1; + OBJ_I1 : I1; + BEGIN + OBJ_I1 := I1(IDENT_INT(2)); -- CONSTRAINT_ERROR. + PSPY_NUMB (1); + END T1; + + BEGIN + NULL; -- WAIT FOR TERMINATION. + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("PROPAGATED CONSTRAINT_ERROR OUT OF TASK"); + WHEN TASKING_ERROR => + FAILED ("RAISED TASKING_ERROR"); + WHEN OTHERS => + FAILED ("RAISED OTHER EXCEPTION"); + END BLOCK; + + IF SPYNUMB /= 0 THEN + FAILED ("TASK T1 NOT COMPLETED AFTER EXCEPTION IN SEQUENCE " & + "OF STATEMENTS"); + END IF; + + RESULT; + + END C94001F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94001g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94001g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C94001G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A COMPLETED TASK WITH DEPENDENT TASKS TERMINATES WHEN + -- A L L DEPENDENT TASKS HAVE TERMINATED. + + -- WEI 3/ 4/82 + -- JBG 4/2/84 + -- JWC 6/28/85 RENAMED FROM C940AIA-B.ADA + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C94001G IS + + PACKAGE SPY IS -- PROVIDE PROTECTED ACCESS TO SPYNUMB + SUBTYPE ARG IS NATURAL RANGE 0..9; + FUNCTION SPYNUMB RETURN NATURAL; -- READ + FUNCTION FINIT_POS (DIGT : IN ARG) RETURN NATURAL; -- WRITE + PROCEDURE PSPY_NUMB (DIGT : IN ARG); -- WRITE + END SPY; + + USE SPY; + + PACKAGE BODY SPY IS + + TASK GUARD IS + ENTRY READ (NUMB : OUT NATURAL); + ENTRY WRITE (NUMB : IN NATURAL); + END GUARD; + + TASK BODY GUARD IS + SPYNUMB : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT READ (NUMB : OUT NATURAL) DO + NUMB := SPYNUMB; + END READ; + OR ACCEPT WRITE (NUMB : IN NATURAL) DO + SPYNUMB := 10*SPYNUMB+NUMB; + END WRITE; + OR TERMINATE; + END SELECT; + END LOOP; + END GUARD; + + FUNCTION SPYNUMB RETURN NATURAL IS + TEMP : NATURAL; + BEGIN + GUARD.READ (TEMP); + RETURN TEMP; + END SPYNUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + GUARD.WRITE (DIGT); + RETURN DIGT; + END FINIT_POS; + + PROCEDURE PSPY_NUMB (DIGT : IN ARG) IS + BEGIN + GUARD.WRITE (DIGT); + END PSPY_NUMB; + END SPY; + + BEGIN + TEST ("C94001G", "TERMINATION WHEN ALL DEPENDENT TASKS " & + "HAVE TERMINATED"); + + BLOCK: + DECLARE + + TASK TYPE TT1; + + TASK BODY TT1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + END TT1; + + TASK T1 IS + END T1; + + TASK BODY T1 IS + OBJ_TT1_1, OBJ_TT1_2, OBJ_TT1_3 : TT1; + BEGIN + NULL; + END T1; + + BEGIN + NULL; + END BLOCK; -- WAIT HERE FOR TERMINATION. + + IF SPYNUMB /= 111 THEN + FAILED ("TASK T1 TERMINATED BEFORE " & + "ALL DEPENDENT TASKS HAVE TERMINATED"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C94001G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,331 ---- + -- C94002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A UNIT WITH DEPENDENT TASKS CREATED BY (LOCAL) + -- ALLOCATORS DOES NOT TERMINATE UNTIL ALL DEPENDENT TASKS ARE + -- TERMINATED. + -- SUBTESTS ARE: + -- (A, B) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (C, D) A RECORD OF TASK ALLOCATOR, IN A FUNCTION. + -- (E, F) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + + -- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + + -- JRK 10/2/81 + -- SPS 11/2/82 + -- SPS 11/21/82 + -- JRK 11/29/82 + -- TBN 8/25/86 REDUCED DELAYS; ADDED LIMITED PRIVATE TYPES; + -- INCLUDED EXITS BY RAISING AN EXCEPTION. + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94002A IS + + PACKAGE P IS + MY_EXCEPTION : EXCEPTION; + GLOBAL : INTEGER; + TASK TYPE T1 IS + ENTRY E (I : INTEGER); + END T1; + TYPE T2 IS LIMITED PRIVATE; + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER); + PRIVATE + TASK TYPE T2 IS + ENTRY E (I : INTEGER); + END T2; + END P; + + PACKAGE BODY P IS + TASK BODY T1 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER + -- PRIORITY AT THIS POINT, IT WILL + -- RECEIVE CONTROL AND TERMINATE IF + -- THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END T1; + + TASK BODY T2 IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 30.0 * Impdef.One_Second; + GLOBAL := LOCAL; + END T2; + + PROCEDURE CALL_ENTRY (A : T2; B : INTEGER) IS + BEGIN + A.E (B); + END CALL_ENTRY; + END P; + + USE P; + + + BEGIN + TEST ("C94002A", "CHECK THAT A UNIT WITH DEPENDENT TASKS " & + "CREATED BY (LOCAL) ALLOCATORS DOES NOT " & + "TERMINATE UNTIL ALL DEPENDENT TASKS " & + "ARE TERMINATED"); + + -------------------------------------------------- + GLOBAL := IDENT_INT (0); + BEGIN -- (A) + DECLARE + TYPE A_T IS ACCESS T1; + A : A_T; + BEGIN + IF EQUAL (3, 3) THEN + A := NEW T1; + A.ALL.E (IDENT_INT(1)); + RAISE MY_EXCEPTION; + END IF; + END; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 1"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 1"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; -- (A) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + TYPE A_T IS ACCESS T2; + A : A_T; + BEGIN -- (B) + IF EQUAL (3, 3) THEN + A := NEW T2; + CALL_ENTRY (A.ALL, IDENT_INT(2)); + END IF; + END; -- (B) + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - 2"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T1; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T.E (IDENT_INT(3)); + END LOOP; + RETURN 0; + END F; + BEGIN -- (C) + I := F; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 3"); + END IF; + END; -- (C) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (D) + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + TYPE RT; + TYPE ART IS ACCESS RT; + TYPE RT IS + RECORD + A : ART; + T : T2; + END RECORD; + LIST : ART; + TEMP : ART; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T, IDENT_INT(4)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + RETURN 0; + END F; + BEGIN -- (D) + I := F; + + FAILED ("MY_EXCEPTION WAS NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL /= 4 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; -- (D) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (E) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T1; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + LIST.T(1).E (IDENT_INT(5)); + IF EQUAL (3, 3) THEN + RAISE MY_EXCEPTION; + END IF; + END LOOP; + END TSK; + + BEGIN -- (E) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 5"); + END IF; + + IF GLOBAL /= 5 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 5"); + END IF; + + END; -- (E) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (F) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 5 * 60; -- FIVE MINUTE DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + TYPE ARR IS ARRAY (1..1) OF T2; + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + LIST : ARAT; + TEMP : ARAT; + BEGIN + FOR I IN 1 .. IDENT_INT (1) LOOP + TEMP := NEW RAT; + TEMP.A := LIST; + LIST := TEMP; + CALL_ENTRY (LIST.T(1), IDENT_INT(6)); + END LOOP; + END TSK; + + BEGIN -- (F) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK NOT TERMINATED WITHIN FIVE " & + "MINUTES - 6"); + END IF; + + IF GLOBAL /= 6 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - 6"); + END IF; + + END; -- (F) + + RESULT; + END C94002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,208 ---- + -- C94002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL ACCESS + -- TYPE MAY TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS TO + -- TERMINATE. + + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. + -- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + + -- JRK 10/8/81 + -- SPS 11/2/82 + -- SPS 11/21/82 + -- JRK 11/29/82 + -- TBN 1/20/86 REPLACED WITH C94006A-B.ADA AFTER LOWERING THE DELAY + -- VALUES, AND MODIFYING THE COMMENTS. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94002B IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + + BEGIN + TEST ("C94002B", "CHECK THAT A MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE MAY TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + END IF; + + A1.ALL.E; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + END IF; + + AR1.T.E; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + END IF; + + ARA1.T(1).E; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; + END C94002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C94002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK DOES N O T DEPEND ON A UNIT IF IT IS DESIGNATED + -- BY A LOCAL ACCESS VARIABLE (OF THIS UNIT) WHOSE TYPE IS DECLARED + -- OUTSIDE THIS UNIT. + + -- WEI 3/ 4/82 + -- JBG 2/20/84 + -- TBN 11/25/85 RENAMED FROM C940ACB-B.ADA. + + WITH REPORT; + USE REPORT; + PROCEDURE C94002D IS + + TASK TYPE TT1 IS + ENTRY E1; + ENTRY E2; + END TT1; + + TYPE ATT1 IS ACCESS TT1; + OUTER_TT1 : ATT1; + + TASK BODY TT1 IS + BEGIN + ACCEPT E1; + ACCEPT E2; + END TT1; + + BEGIN + TEST ("C94002D", "DEPENDENCY IS INDEPENDENT OF WHERE ACCESS " & + "VARIABLE IS DECLARED"); + + BLOCK1 : + DECLARE + POINTER_TT1 : ATT1 := NEW TT1; + BEGIN + OUTER_TT1 := POINTER_TT1; + POINTER_TT1.ALL.E1; + END BLOCK1; -- MAY DEADLOCK HERE IF INCORRECT DEPENDENCY + -- RULE IS IMPLEMENTED. + + IF OUTER_TT1.ALL'TERMINATED THEN + FAILED ("NON-DEPENDENT TASK IS TERMINATED " & + "IMMEDIATELY AFTER ENCLOSING UNIT HAS " & + "BEEN COMPLETED"); + END IF; + + OUTER_TT1.E2; -- RELEASE TASK + + RESULT; + + END C94002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- C94002E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL + -- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS + -- TO TERMINATE. + + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. + -- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + + -- JRK 10/8/81 + -- SPS 11/2/82 + -- SPS 11/21/82 + -- JRK 11/29/82 + -- TBN 1/20/86 RENAMED FROM C94006A-B.ADA. LOWERED THE DELAY VALUES + -- AND MODIFIED THE COMMENTS. + -- JRK 5/1/86 IMPROVED ERROR RECOVERY LOGIC. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94002E IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + + BEGIN + TEST ("C94002E", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; + END C94002E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,227 ---- + -- C94002F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL + -- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED TASKS + -- TO TERMINATE IF AN EXCEPTION IS RAISED AND HANDLED IN THE + -- NON-MASTER UNIT. + + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. + -- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY. + + -- TBN 1/20/86 + -- JRK 5/1/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION HANDLING. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94002F IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + + BEGIN + TEST ("C94002F", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED AND " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + END; + + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - (A)"); + ELSE A1.ALL.E; + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P (AR : OUT ART) IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + END P; + + BEGIN + P (AR1); + + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (B)"); + ELSE AR1.T.E; + END IF; + + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + --------------------------------------------------------------- + + RESULT; + END C94002F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94002g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94002g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- C94002G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES TASKS OF A GLOBAL + -- ACCESS TYPE, MUST TERMINATE WITHOUT WAITING FOR THE ALLOCATED + -- TASKS TO TERMINATE IF AN EXCEPTION IS RAISED BUT NOT HANDLED IN + -- THE NON-MASTER UNIT. + + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A BLOCK. + -- (B) A RECORD OF TASK ALLOCATOR, IN A SUBPROGRAM. + -- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A TASK BODY, NOT + -- DURING RENDEZVOUS. + -- (D) A LIMITED PRIVATE TASK ALLOCATOR, IN A TASK BODY, DURING + -- RENDEZVOUS. + + -- HISTORY: + -- TBN 01/20/86 CREATED ORIGINAL TEST. + -- JRK 05/01/86 IMPROVED ERROR RECOVERY. FIXED EXCEPTION + -- HANDLING. ADDED CASE (D). + -- BCB 09/24/87 ADDED A RETURN STATEMENT TO THE HANDLER FOR OTHERS + -- IN FUNCTION F, CASE B. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94002G IS + + MY_EXCEPTION : EXCEPTION; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + ACCEPT E; + ACCEPT E; + END TT; + + + BEGIN + TEST ("C94002G", "CHECK THAT A NON-MASTER UNIT, WHICH ALLOCATES " & + "TASKS OF A GLOBAL ACCESS TYPE, MUST TERMINATE " & + "WITHOUT WAITING FOR THE ALLOCATED TASKS TO " & + "TERMINATE IF AN EXCEPTION IS RAISED BUT NOT " & + "HANDLED IN THE NON-MASTER UNIT"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE A_T IS ACCESS TT; + A1 : A_T; + + BEGIN -- (A) + + DECLARE + A2 : A_T; + BEGIN + A2 := NEW TT; + A2.ALL.E; + A1 := A2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (A)"); + END; + + ABORT A1.ALL; + + EXCEPTION + WHEN MY_EXCEPTION => + IF A1.ALL'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED - " & + "(A)"); + ELSE A1.ALL.E; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (A)"); + IF A1 /= NULL THEN + ABORT A1.ALL; + END IF; + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + TYPE RT IS + RECORD + T : TT; + END RECORD; + TYPE ART IS ACCESS RT; + AR1 : ART; + + PROCEDURE P IS + AR2 : ART; + BEGIN + AR2 := NEW RT; + AR2.T.E; + AR1 := AR2; + RAISE MY_EXCEPTION; + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (B)"); + END P; + + BEGIN + P; + ABORT AR1.T; + RETURN 0; + EXCEPTION + WHEN MY_EXCEPTION => + IF AR1.T'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (B)"); + ELSE AR1.T.E; + END IF; + RETURN 0; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (B)"); + IF AR1 /= NULL THEN + ABORT AR1.T; + END IF; + RETURN 0; + END F; + + BEGIN -- (B) + + I := F; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + TYPE RAT; + TYPE ARAT IS ACCESS RAT; + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + A : ARAT; + T : ARR; + END RECORD; + ARA1 : ARAT; + + TASK TSK1 IS + ENTRY ENT1 (ARA : OUT ARAT); + END TSK1; + + TASK BODY TSK1 IS + ARA2 : ARAT; + BEGIN + ARA2 := NEW RAT; -- INITIATE TASK ARA2.T(1). + ARA2.T(1).E; + ACCEPT ENT1 (ARA : OUT ARAT) DO + ARA := ARA2; + END ENT1; + RAISE MY_EXCEPTION; -- NOT PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (C)"); + END TSK1; + + BEGIN + TSK1.ENT1 (ARA1); -- ARA1.T BECOMES ALIAS FOR ARA2.T. + + WHILE NOT TSK1'TERMINATED AND LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (C)"); + END IF; + + IF ARA1.T(1)'TERMINATED THEN + FAILED ("ALLOCATED TASK PREMATURELY TERMINATED " & + "- (C)"); + ELSE ARA1.T(1).E; + END IF; + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + LOOP_COUNT : INTEGER := 0; + CUT_OFF : CONSTANT := 60; -- DELAY. + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + + LOOP_COUNT1 : INTEGER := 0; + CUT_OFF1 : CONSTANT := 60; -- DELAY. + + PACKAGE PKG IS + TYPE LPT IS LIMITED PRIVATE; + PROCEDURE CALL (X : LPT); + PROCEDURE KILL (X : LPT); + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN; + PRIVATE + TYPE LPT IS NEW TT; + END PKG; + + USE PKG; + + TYPE ALPT IS ACCESS LPT; + ALP1 : ALPT; + + PACKAGE BODY PKG IS + PROCEDURE CALL (X : LPT) IS + BEGIN + X.E; + END CALL; + + PROCEDURE KILL (X : LPT) IS + BEGIN + ABORT X; + END KILL; + + FUNCTION TERMINATED (X : LPT) RETURN BOOLEAN IS + BEGIN + RETURN X'TERMINATED; + END TERMINATED; + END PKG; + + TASK TSK1 IS + ENTRY ENT1 (ALP : OUT ALPT); + ENTRY DIE; + END TSK1; + + TASK BODY TSK1 IS + ALP2 : ALPT; + BEGIN + ALP2 := NEW LPT; -- INITIATE TASK ALP2.ALL. + CALL (ALP2.ALL); + ACCEPT ENT1 (ALP : OUT ALPT) DO + ALP := ALP2; + END ENT1; + ACCEPT DIE DO + RAISE MY_EXCEPTION; -- PROPOGATED. + FAILED ("MY_EXCEPTION WAS NOT RAISED IN (D)"); + END DIE; + END TSK1; + + BEGIN + TSK1.ENT1 (ALP1); -- ALP1.ALL BECOMES ALIAS FOR ALP2.ALL. + TSK1.DIE; + FAILED ("MY_EXCEPTION WAS NOT PROPOGATED TO CALLING " & + "TASK - (D)"); + KILL (ALP1.ALL); + ABORT TSK1; + EXCEPTION + WHEN MY_EXCEPTION => + WHILE NOT TSK1'TERMINATED AND + LOOP_COUNT1 < CUT_OFF1 LOOP + DELAY 1.0 * Impdef.One_Second; + LOOP_COUNT1 := LOOP_COUNT1 + 1; + END LOOP; + + IF LOOP_COUNT1 >= CUT_OFF1 THEN + FAILED ("DEPENDENT TASK TSK1 NOT TERMINATED " & + "WITHIN ONE MINUTE - (D)"); + END IF; + + IF TERMINATED (ALP1.ALL) THEN + FAILED ("ALLOCATED TASK PREMATURELY " & + "TERMINATED - (D)"); + ELSE CALL (ALP1.ALL); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION IN (D)"); + IF ALP1 /= NULL THEN + KILL (ALP1.ALL); + END IF; + ABORT TSK1; + END TSK; + + BEGIN -- (D) + + WHILE NOT TSK'TERMINATED AND LOOP_COUNT < CUT_OFF LOOP + DELAY 2.0 * Impdef.One_Second; + LOOP_COUNT := LOOP_COUNT + 1; + END LOOP; + + IF LOOP_COUNT >= CUT_OFF THEN + FAILED ("DEPENDENT TASK TSK NOT TERMINATED WITHIN " & + "TWO MINUTES - (D)"); + END IF; + + END; -- (D) + + -------------------------------------------------- + + RESULT; + END C94002G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C94004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT + -- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY + -- MAIN PROGRAM TERMINATION. + + -- CASE A: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN + -- PROGRAM. + + -- JRK 10/8/81 + -- SPS 11/21/82 + -- JBG 12/6/84 + -- JRK 11/21/85 RENAMED FROM C94004A-B.ADA; REVISED ACCORDING TO + -- AI-00399. + -- JRK 10/24/86 RENAMED FROM E94004A-B.ADA; REVISED ACCORDING TO + -- REVISED AI-00399. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + PACKAGE C94004A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + END C94004A_PKG; + + with Impdef; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C94004A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + + END C94004A_PKG; + + WITH C94004A_PKG; USE C94004A_PKG; + PRAGMA ELABORATE (C94004A_PKG); + PACKAGE C94004A_TASK IS + T : TT; + END; + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH C94004A_TASK; + PROCEDURE C94004A IS + + + BEGIN + TEST ("C94004A", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004A_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004A_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + + END C94004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C94004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT + -- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY + -- MAIN PROGRAM TERMINATION. + + -- CASE B: ACCESS TO TASK TYPE DECLARED IN LIBRARY PACKAGE; TASK + -- ACTIVATED IN MAIN PROGRAM. + + -- JRK 10/8/81 + -- SPS 11/21/82 + -- JBG 12/6/84 + -- JRK 11/21/85 RENAMED FROM C94004B-B.ADA; REVISED ACCORDING TO + -- AI-00399. + -- JRK 10/24/86 RENAMED FROM E94004B-B.ADA; REVISED ACCORDING TO + -- REVISED AI-00399. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + PACKAGE C94004B_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + END C94004B_PKG; + + with Impdef; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C94004B_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + END TT; + + END C94004B_PKG; + + WITH C94004B_PKG; USE C94004B_PKG; + PRAGMA ELABORATE (C94004B_PKG); + PACKAGE C94004B_TASK IS + TYPE ACC_TASK IS ACCESS C94004B_PKG.TT; + END; + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH C94004B_TASK; WITH C94004B_PKG; + PROCEDURE C94004B IS + + T : C94004B_TASK.ACC_TASK; + + BEGIN + TEST ("C94004B", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T := NEW C94004B_PKG.TT; + T.E; -- ALLOW TASK TO PROCEED. + IF T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + + END C94004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94004c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94004c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C94004C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A MAIN PROGRAM TERMINATES WITHOUT WAITING FOR TASKS THAT + -- DEPEND ON A LIBRARY PACKAGE AND THAT SUCH TASKS ARE NOT TERMINATED BY + -- MAIN PROGRAM TERMINATION. + + -- CASE C: TASK OBJECT DECLARED IN LIBRARY PACKAGE USED BY MAIN PROGRAM + -- AND WAITING AT A SELECTIVE WAIT WITH TERMINATE. + + -- JRK 10/8/81 + -- SPS 11/21/82 + -- JBG 12/6/84 + -- JRK 11/21/85 RENAMED FROM C94004C-B.ADA; REVISED ACCORDING TO + -- AI-00399. + -- JRK 10/24/86 RENAMED FROM E94004C-B.ADA; REVISED ACCORDING TO + -- REVISED AI-00399. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + PACKAGE C94004C_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + END C94004C_PKG; + + with Impdef; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY C94004C_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (120); + BEGIN + ACCEPT E; + COMMENT ("DELAY LIBRARY TASK FOR TWO MINUTES"); + DELAY DURATION(I) * Impdef.One_Second; + -- MAIN PROGRAM SHOULD NOW BE TERMINATED. + RESULT; + -- USE LOOP FOR SELECTIVE WAIT WITH TERMINATE. + LOOP + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END LOOP; + -- FAILS IF JOB HANGS UP WITHOUT TERMINATING. + END TT; + + END C94004C_PKG; + + WITH C94004C_PKG; USE C94004C_PKG; + PRAGMA ELABORATE (C94004C_PKG); + PACKAGE C94004C_TASK IS + T : TT; + END; + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH C94004C_TASK; + PROCEDURE C94004C IS + + + BEGIN + TEST ("C94004C", "CHECK THAT A MAIN PROGRAM TERMINATES " & + "WITHOUT WAITING FOR TASKS THAT DEPEND " & + "ON A LIBRARY PACKAGE AND THAT SUCH TASKS " & + "CONTINUE TO EXECUTE"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + C94004C_TASK.T.E; -- ALLOW TASK TO PROCEED. + IF C94004C_TASK.T'TERMINATED THEN + FAILED ("LIBRARY DECLARED TASK PREMATURELY TERMINATED"); + END IF; + + -- RESULT PROCEDURE IS CALLED BY LIBRARY TASK. + + END C94004C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C94005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, A MAIN + -- PROGRAM THAT DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR + -- TERMINATION OF SUCH OBJECTS. + + -- THIS TEST CONTAINS RACE CONDITIONS. + + -- JRK 10/8/81 + -- SPS 11/21/82 + -- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005A_PKG. + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + + WITH SYSTEM; USE SYSTEM; + PACKAGE C94005A_PKG IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + END C94005A_PKG; + + with Impdef; + WITH REPORT; USE REPORT; + PACKAGE BODY C94005A_PKG IS + + TASK BODY TT IS + I : INTEGER := IDENT_INT (0); + BEGIN + ACCEPT E; + FOR J IN 1..60 LOOP + I := IDENT_INT (I); + DELAY 1.0 * Impdef.One_Second; + END LOOP; + RESULT; -- FAILURE IF THIS MESSAGE IS NOT WRITTEN. + END TT; + + END C94005A_PKG; + + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH C94005A_PKG; + PROCEDURE C94005A IS + + T : C94005A_PKG.TT; + + + BEGIN + TEST ("C94005A", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, A MAIN PROGRAM THAT " & + "DECLARES OBJECTS OF THAT TYPE DOES WAIT FOR " & + "TERMINATION OF SUCH OBJECTS"); + + COMMENT ("THE INVOKING SYSTEM'S JOB CONTROL LOG MUST BE " & + "EXAMINED TO SEE IF THIS TEST REALLY TERMINATES"); + + T.E; + + IF T'TERMINATED THEN + COMMENT ("TEST INCONCLUSIVE BECAUSE TASK T PREMATURELY " & + "TERMINATED"); + END IF; + + -- TASK T SHOULD WRITE THE RESULT MESSAGE. + + END C94005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94005b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- C94005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A TASK TYPE IS DECLARED IN A LIBRARY PACKAGE, ANY + -- BLOCKS, SUBPROGRAMS, OR TASKS THAT DECLARE OBJECTS OF THAT TYPE + -- DO WAIT FOR TERMINATION OF SUCH OBJECTS. + -- SUBTESTS ARE: + -- (A) IN A MAIN PROGRAM BLOCK. + -- (B) IN A LIBRARY FUNCTION. + -- (C) IN A MAIN PROGRAM TASK BODY. + + -- THIS TEST CONTAINS SHARED VARIABLES AND RACE CONDITIONS. + + -- JRK 10/8/81 + -- SPS 11/2/82 + -- SPS 11/21/82 + -- JWC 11/15/85 MADE THE LIBRARY PACKAGE NAME UNIQUE, C94005B_PKG. + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + + WITH SYSTEM; USE SYSTEM; + PACKAGE C94005B_PKG IS + + GLOBAL : INTEGER; + + TASK TYPE TT IS + ENTRY E (I : INTEGER); + END TT; + + END C94005B_PKG; + + with Impdef; + PACKAGE BODY C94005B_PKG IS + + TASK BODY TT IS + LOCAL : INTEGER; + BEGIN + ACCEPT E (I : INTEGER) DO + LOCAL := I; + END E; + DELAY 60.0 * Impdef.One_Second; -- SINCE THE PARENT UNIT HAS HIGHER PRIORITY + -- AT THIS POINT, IT WILL RECEIVE CONTROL AND + -- TERMINATE IF THE ERROR IS PRESENT. + GLOBAL := LOCAL; + END TT; + + END C94005B_PKG; + + + WITH REPORT; USE REPORT; + WITH C94005B_PKG; USE C94005B_PKG; + FUNCTION F RETURN INTEGER IS + + T : TT; + + BEGIN + + T.E (IDENT_INT(2)); + RETURN 0; + + END F; + + with Impdef; + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH C94005B_PKG; USE C94005B_PKG; + WITH F; + PROCEDURE C94005B IS + + + BEGIN + TEST ("C94005B", "CHECK THAT IF A TASK TYPE IS DECLARED IN A " & + "LIBRARY PACKAGE, ANY BLOCKS, SUBPROGRAMS, OR " & + "TASKS THAT DECLARE OBJECTS OF THAT TYPE DO " & + "WAIT FOR TERMINATION OF SUCH OBJECTS"); + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (A) + + T : TT; + + BEGIN -- (A) + + T.E (IDENT_INT(1)); + + END; -- (A) + + IF GLOBAL /= 1 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "BLOCK EXIT - (A)"); + END IF; + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (B) + + I : INTEGER; + + BEGIN -- (B) + + I := F ; + + IF GLOBAL /= 2 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "FUNCTION EXIT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------------- + + GLOBAL := IDENT_INT (0); + + DECLARE -- (C) + + TASK TSK IS + ENTRY ENT; + END TSK; + + TASK BODY TSK IS + T : TT; + BEGIN + T.E (IDENT_INT(3)); + END TSK; + + BEGIN -- (C) + + WHILE NOT TSK'TERMINATED LOOP + DELAY 0.1 * Impdef.One_Second; + END LOOP; + + IF GLOBAL /= 3 THEN + FAILED ("DEPENDENT TASK NOT TERMINATED BEFORE " & + "TASK EXIT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------------- + + RESULT; + END C94005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- C94006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DECLARATION THAT RENAMES A TASK DOES NOT CREATE A NEW + -- MASTER FOR THE TASK. + + -- TBN 9/17/86 + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94006A IS + + TASK TYPE TT IS + ENTRY E; + END TT; + + TASK BODY TT IS + BEGIN + SELECT + ACCEPT E; + OR + DELAY 30.0 * Impdef.One_Second; + END SELECT; + END TT; + + + BEGIN + TEST ("C94006A", "CHECK THAT A DECLARATION THAT RENAMES A TASK " & + "DOES NOT CREATE A NEW MASTER FOR THE TASK"); + + ------------------------------------------------------------------- + DECLARE + T1 : TT; + BEGIN + DECLARE + RENAME_TASK : TT RENAMES T1; + BEGIN + NULL; + END; + IF T1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 1"); + ELSE + T1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + T2 : TT; + + PACKAGE P IS + Q : TT RENAMES T2; + END P; + + PACKAGE BODY P IS + BEGIN + NULL; + END P; + + USE P; + BEGIN + IF Q'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 2"); + ELSE + Q.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P1 : ACC_TT; + BEGIN + DECLARE + RENAME_ACCESS : ACC_TT RENAMES P1; + BEGIN + RENAME_ACCESS := NEW TT; + END; + IF P1'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 3"); + ELSE + P1.E; + END IF; + END; + + ------------------------------------------------------------------- + + DECLARE + TYPE ACC_TT IS ACCESS TT; + P2 : ACC_TT; + + PACKAGE Q IS + RENAME_ACCESS : ACC_TT RENAMES P2; + END Q; + + PACKAGE BODY Q IS + BEGIN + RENAME_ACCESS := NEW TT; + END Q; + + USE Q; + BEGIN + IF RENAME_ACCESS'TERMINATED THEN + FAILED ("TASK DEPENDENT ON WRONG UNIT - 4"); + ELSE + RENAME_ACCESS.E; + END IF; + END; + + RESULT; + END C94006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94007a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,270 ---- + -- C94007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A TASK THAT IS DECLARED IN A NON-LIBRARY PACKAGE + -- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, + -- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, + -- OR TASK BODY. + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK OBJECT, IN A VISIBLE PART, IN A BLOCK. + -- (B) AN ARRAY OF TASK OBJECT, IN A PRIVATE PART, IN A FUNCTION. + -- (C) AN ARRAY OF RECORD OF TASK OBJECT, IN A PACKAGE BODY, + -- IN A TASK BODY. + + -- HISTORY: + -- JRK 10/13/81 + -- SPS 11/21/82 + -- DHH 09/07/88 REVISED HEADER, ADDED EXCEPTION HANDLERS ON OUTER + -- BLOCKS, AND ADDED CASE TO INSURE THAT LEAVING A + -- PACKAGE VIA AN EXCEPTION WOULD NOT ABORT TASKS. + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94007A IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + + BEGIN + TEST ("C94007A", "CHECK THAT A TASK THAT IS DECLARED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END T; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + A : ARRAY (1..1) OF TT; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - B"); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + AR : ARRAY (1..1) OF RT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - C"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + GLOBAL : INTEGER := IDENT_INT(5); + + BEGIN -- (D) + + DECLARE + + PACKAGE PKG IS + TASK T IS + ENTRY E; + END T; + + TASK T1 IS + END T1; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY T IS + BEGIN + ACCEPT E DO + RAISE CONSTRAINT_ERROR; + END E; + END T; + + TASK BODY T1 IS + BEGIN + DELAY 120.0 * Impdef.One_Second; + GLOBAL := IDENT_INT(1); + END T1; + + BEGIN + T.E; + + END PKG; + USE PKG; + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF GLOBAL /= IDENT_INT(1) THEN + FAILED("TASK NOT COMPLETED"); + END IF; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED - D"); + END; -- (D) + + RESULT; + END C94007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94007b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94007b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94007b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94007b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- C94007B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK THAT IS ALLOCATED IN A NON-LIBRARY PACKAGE + -- (SPECIFICATION OR BODY) DOES NOT "DEPEND" ON THE PACKAGE, + -- BUT ON THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM BODY, + -- OR TASK BODY. + -- SUBTESTS ARE: + -- (A) A SIMPLE TASK ALLOCATOR, IN A VISIBLE PART, IN A BLOCK. + -- (B) A RECORD OF TASK ALLOCATOR, IN A PRIVATE PART, IN A FUNCTION. + -- (C) A RECORD OF ARRAY OF TASK ALLOCATOR, IN A PACKAGE BODY, + -- IN A TASK BODY. + + -- JRK 10/16/81 + -- SPS 11/2/82 + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94007B IS + + TASK TYPE SYNC IS + ENTRY ID (C : CHARACTER); + ENTRY INNER; + ENTRY OUTER; + END SYNC; + + TASK BODY SYNC IS + ID_C : CHARACTER; + BEGIN + ACCEPT ID (C : CHARACTER) DO + ID_C := C; + END ID; + DELAY 1.0 * Impdef.One_Second; + SELECT + ACCEPT OUTER; + OR + DELAY 120.0 * Impdef.One_Second; + FAILED ("PROBABLY BLOCKED - (" & ID_C & ')'); + END SELECT; + ACCEPT INNER; + END SYNC; + + + BEGIN + TEST ("C94007B", "CHECK THAT A TASK THAT IS ALLOCATED IN A " & + "NON-LIBRARY PACKAGE (SPECIFICATION OR BODY) " & + "DOES NOT ""DEPEND"" ON THE PACKAGE, BUT ON " & + "THE INNERMOST ENCLOSING BLOCK, SUBPROGRAM " & + "BODY, OR TASK BODY"); + + -------------------------------------------------- + + DECLARE -- (A) + + S : SYNC; + + BEGIN -- (A) + + S.ID ('A'); + + DECLARE + + PACKAGE PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + TYPE A_T IS ACCESS TT; + A : A_T; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + A := NEW TT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + S : SYNC; + + I : INTEGER; + + FUNCTION F RETURN INTEGER IS + + PACKAGE PKG IS + PRIVATE + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE RT IS + RECORD + T : TT; + END RECORD; + + TYPE ART IS ACCESS RT; + + AR : ART; + END PKG; + + PACKAGE BODY PKG IS + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + AR := NEW RT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- F + + S.OUTER; + RETURN 0; + + EXCEPTION + WHEN TASKING_ERROR => RETURN 0; + END F; + + BEGIN -- (B) + + S.ID ('B'); + I := F ; + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + S : SYNC; + + BEGIN -- (C) + + S.ID ('C'); + + DECLARE + + TASK TSK IS + END TSK; + + TASK BODY TSK IS + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE ARR IS ARRAY (1..1) OF TT; + TYPE RAT IS + RECORD + T : ARR; + END RECORD; + + TYPE ARAT IS ACCESS RAT; + + ARA : ARAT; + + TASK BODY TT IS + BEGIN + S.INNER; -- PROBABLE INNER BLOCK POINT. + END TT; + BEGIN + ARA := NEW RAT; + END PKG; -- PROBABLE OUTER BLOCK POINT. + + BEGIN -- TSK + + S.OUTER; + + EXCEPTION + WHEN TASKING_ERROR => NULL; + END TSK; + + BEGIN + NULL; + END; + + END; -- (C) + + -------------------------------------------------- + + RESULT; + END C94007B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- C94008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE + -- DOES N O T TERMINATE WHILE THE UNIT THE TASK DEPENDS ON + -- HAS NOT COMPLETED ITS EXECUTION. + + -- WEI 3/ 4/82 + -- TBN 11/25/85 RENAMED FROM C940BAA-B.ADA. + + WITH REPORT; + USE REPORT; + PROCEDURE C94008A IS + BEGIN + TEST ("C94008A", "TERMINATION WHILE WAITING AT " & + "AN OPEN TERMINATE ALTERNATIVE"); + + BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END T1; + BEGIN -- BLOCK1 + IF T1'TERMINATED THEN + FAILED ("TASK T1 TERMINATED BEFORE OUTER UNIT HAS " & + "BEEN LEFT"); + END IF; + END BLOCK1; + + RESULT; + + END C94008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C94008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK WAITING AT AN OPEN TERMINATE ALTERNATIVE + -- DOES N O T TERMINATE UNTIL ALL OTHER TASKS DEPENDING ON THE SAME + -- UNIT EITHER ARE TERMINATED OR ARE WAITING AT AN OPEN TERMINATE. + + -- WEI 3/ 4/82 + -- TBN 11/25/85 RENAMED FROM C940BBA-B.ADA. + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C94008B IS + BEGIN + TEST ("C94008B", "TERMINATION WHILE WAITING AT AN OPEN TERMINATE"); + + BLOCK1 : + DECLARE + + TASK TYPE TT1 IS + ENTRY E1; + END TT1; + + NUMB_TT1 : CONSTANT NATURAL := 3; + DELAY_TIME : DURATION := 0.0; + ARRAY_TT1 : ARRAY (1 .. NUMB_TT1) OF TT1; + + TASK BODY TT1 IS + BEGIN + DELAY_TIME := DELAY_TIME + 1.0 * Impdef.One_Second; + DELAY DELAY_TIME; + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TOO EARLY TERMINATION OF " & + "TASK TT1 INDEX" & INTEGER'IMAGE(I)); + END IF; + END LOOP; + + SELECT + WHEN TRUE => TERMINATE; + OR WHEN FALSE => ACCEPT E1; + END SELECT; + END TT1; + + BEGIN -- BLOCK1. + FOR I IN 1 .. NUMB_TT1 + LOOP + IF ARRAY_TT1 (I)'TERMINATED THEN + FAILED ("TERMINATION BEFORE OUTER " & + "UNIT HAS BEEN LEFT OF TASK TT1 INDEX " & + INTEGER'IMAGE(I)); + END IF; + END LOOP; + END BLOCK1; + + RESULT; + + END C94008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,265 ---- + -- C94008C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SELECT WITH TERMINATE ALTERNATIVE WORKS CORRECTLY WITH + -- NESTED TASKS. + + -- THIS TEST CONTAINS RACE CONDITIONS AND USES A GENERIC INSTANCE THAT + -- CONTAINS TASKS. + + -- JEAN-PIERRE ROSEN 24 FEBRUARY 1984 + -- JRK 4/7/86 + -- JBG 8/29/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94008C IS + + + -- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES + GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; + PACKAGE SHARED IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; + END SHARED; + + PACKAGE BODY SHARED IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; + BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END SHARE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + + BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE + END SHARED; + + PACKAGE EVENTS IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); + END EVENTS; + + PACKAGE COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); + END COUNTER; + + PACKAGE BODY COUNTER IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; + END COUNTER; + + PACKAGE BODY EVENTS IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + + END EVENTS; + + USE EVENTS, COUNTER; + + PACKAGE TRACE IS NEW SHARED (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS NEW SHARED (INTEGER, INTEGER, 0); + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + + BEGIN -- C94008C + + TEST ("C94008C", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE"); + + DECLARE + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + + TASK T3 IS + ENTRY E3; + END T3; + + TASK BODY T3 IS + BEGIN + SELECT + ACCEPT E3; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + EVENT ('D'); + END T3; + + BEGIN -- T2 + + SELECT + ACCEPT E2; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 1 "); + END IF; + + EVENT ('C'); + T1.E1; + T3.E3; + END T2; + + BEGIN -- T1; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + EVENT ('B'); + TERMINATE_COUNT.SET (0); + T2.E2; + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + SELECT + ACCEPT E1; + OR TERMINATE; -- ONLY THIS ONE EVER CHOSEN. + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END T1; + + BEGIN + + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR T1, T2, AND T3 TO GET TO SELECT STMTS. + + IF TERMINATE_COUNT.GET /= 3 THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 3 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH - 2"); + END IF; + + EVENT ('A'); + T1.E1; + + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION IN MAIN BLOCK"); + END; + + IF TRACE.GET.TRACE /= "ABCD" THEN + FAILED ("INCORRECT ORDER OF EVENTS: " & TRACE.GET.TRACE); + END IF; + + RESULT; + END C94008C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94008d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94008d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,235 ---- + -- C94008D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK CORRECT OPERATION OF SELECT WITH TERMINATE ALTERNATIVE WHEN + -- EXECUTED FROM AN INNER BLOCK WITH OUTER DEPENDING TASKS. + + -- JEAN-PIERRE ROSEN 03-MAR-84 + -- JRK 4/7/86 + -- JBG 9/4/86 ELIMINATED SHARED VARIABLES; ADDED GENERIC UNIT/SUBUNIT + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + -- GENERIC UNIT FOR DOING UPDATES OF SHARED VARIABLES + GENERIC + TYPE HOLDER_TYPE IS PRIVATE; + TYPE VALUE_TYPE IS PRIVATE; + INITIAL_VALUE : HOLDER_TYPE; + WITH PROCEDURE SET (HOLDER : OUT HOLDER_TYPE; + VALUE : IN HOLDER_TYPE) IS <>; + WITH PROCEDURE UPDATE (HOLDER : IN OUT HOLDER_TYPE; + VALUE : IN VALUE_TYPE) IS <>; + PACKAGE SHARED_C94008D IS + PROCEDURE SET (VALUE : IN HOLDER_TYPE); + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE); + FUNCTION GET RETURN HOLDER_TYPE; + END SHARED_C94008D; + + PACKAGE BODY SHARED_C94008D IS + TASK SHARE IS + ENTRY SET (VALUE : IN HOLDER_TYPE); + ENTRY UPDATE (VALUE : IN VALUE_TYPE); + ENTRY READ (VALUE : OUT HOLDER_TYPE); + END SHARE; + + TASK BODY SHARE IS SEPARATE; + + PROCEDURE SET (VALUE : IN HOLDER_TYPE) IS + BEGIN + SHARE.SET (VALUE); + END SET; + + PROCEDURE UPDATE (VALUE : IN VALUE_TYPE) IS + BEGIN + SHARE.UPDATE (VALUE); + END UPDATE; + + FUNCTION GET RETURN HOLDER_TYPE IS + VALUE : HOLDER_TYPE; + BEGIN + SHARE.READ (VALUE); + RETURN VALUE; + END GET; + + BEGIN + SHARE.SET (INITIAL_VALUE); -- SET INITIAL VALUE + END SHARED_C94008D; + + PACKAGE EVENTS_C94008D IS + + TYPE EVENT_TYPE IS + RECORD + TRACE : STRING (1..4) := "...."; + LENGTH : NATURAL := 0; + END RECORD; + + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER); + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE); + END EVENTS_C94008D; + + PACKAGE COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER); + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER); + END COUNTER_C94008D; + + PACKAGE BODY COUNTER_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAR + VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT INTEGER; VAL : INTEGER) IS + BEGIN + VAR := VAL; + END SET; + END COUNTER_C94008D; + + PACKAGE BODY EVENTS_C94008D IS + PROCEDURE UPDATE (VAR : IN OUT EVENT_TYPE; VAL : CHARACTER) IS + BEGIN + VAR.LENGTH := VAR.LENGTH + 1; + VAR.TRACE(VAR.LENGTH) := VAL; + END UPDATE; + + PROCEDURE SET (VAR : OUT EVENT_TYPE; VAL : EVENT_TYPE) IS + BEGIN + VAR := VAL; + END SET; + + END EVENTS_C94008D; + + SEPARATE (SHARED_C94008D) + TASK BODY SHARE IS + VARIABLE : HOLDER_TYPE; + BEGIN + LOOP + SELECT + ACCEPT SET (VALUE : IN HOLDER_TYPE) DO + SHARED_C94008D.SET (VARIABLE, VALUE); + END SET; + OR + ACCEPT UPDATE (VALUE : IN VALUE_TYPE) DO + SHARED_C94008D.UPDATE (VARIABLE, VALUE); + END UPDATE; + OR + ACCEPT READ (VALUE : OUT HOLDER_TYPE) DO + VALUE := VARIABLE; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END SHARE; + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + WITH SHARED_C94008D, COUNTER_C94008D, EVENTS_C94008D; + USE COUNTER_C94008D, EVENTS_C94008D; + PROCEDURE C94008D IS + + PACKAGE TRACE IS + NEW SHARED_C94008D (EVENT_TYPE, CHARACTER, ("....", 0)); + PACKAGE TERMINATE_COUNT IS + NEW SHARED_C94008D (INTEGER, INTEGER, 0); + + PROCEDURE EVENT (VAR : CHARACTER) RENAMES TRACE.UPDATE; + + FUNCTION ENTER_TERMINATE RETURN BOOLEAN IS + BEGIN + TERMINATE_COUNT.UPDATE (1); + RETURN TRUE; + END ENTER_TERMINATE; + + BEGIN + TEST ("C94008D", "CHECK CORRECT OPERATION OF SELECT WITH " & + "TERMINATE ALTERNATIVE FROM AN INNER BLOCK"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DECLARE + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + IF TERMINATE_COUNT.GET /= 1 THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF TERMINATE_COUNT.GET /= 1 THEN + FAILED ("30 SECOND DELAY NOT ENOUGH"); + END IF; + + IF T1'TERMINATED OR NOT T1'CALLABLE THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + + EVENT ('A'); + + SELECT + ACCEPT E2; + OR TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T2"); + END T2; + + BEGIN + BEGIN + EVENT ('B'); + + SELECT + ACCEPT E1; + OR WHEN ENTER_TERMINATE => TERMINATE; + END SELECT; + + FAILED ("TERMINATE NOT SELECTED IN T1"); + END; + END; + END T1; + + BEGIN + EVENT ('C'); + EXCEPTION + WHEN OTHERS => FAILED ("EXCEPTION RECEIVED IN MAIN"); + END; + + IF TRACE.GET.TRACE(3) = '.' OR TRACE.GET.TRACE(4) /= '.' THEN + FAILED ("ALL EVENTS NOT PROCESSED CORRECTLY"); + END IF; + + COMMENT ("EXECUTION ORDER WAS " & TRACE.GET.TRACE); + + RESULT; + END C94008D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94010a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,243 ---- + -- C94010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A GENERIC UNIT HAS A FORMAL LIMITED PRIVATE TYPE AND + -- DECLARES AN OBJECT OF THAT TYPE (OR HAS A SUBCOMPONENT OF THAT TYPE), + -- AND IF THE UNIT IS INSTANTIATED WITH A TASK TYPE OR AN OBJECT HAVING + -- A SUBCOMPONENT OF A TASK TYPE, THEN THE USUAL RULES APPLY TO THE + -- INSTANTIATED UNIT, NAMELY: + -- A) IF THE GENERIC UNIT IS A SUBPROGRAM, CONTROL CANNOT LEAVE THE + -- SUBPROGRAM UNTIL THE TASK CREATED BY THE OBJECT DECLARATION IS + -- TERMINATED. + + -- THIS TEST CONTAINS RACE CONDITIONS AND SHARED VARIABLES. + + -- TBN 9/22/86 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C94010A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PRIVATE + TASK TYPE LIM_PRI_TASK IS + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + END P; + + TASK BODY TT IS + BEGIN + DELAY 30.0 * Impdef.One_Second; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PROCEDURE PROC (A : INTEGER); + + PROCEDURE PROC (A : INTEGER) IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + FUNCTION FUNC (A : INTEGER) RETURN INTEGER; + + FUNCTION FUNC (A : INTEGER) RETURN INTEGER IS + OBJ_T : T; + BEGIN + IF A = IDENT_INT (1) THEN + RAISE MY_EXCEPTION; + END IF; + RETURN 1; + END FUNC; + + + BEGIN + TEST ("C94010A", "CHECK TERMINATION RULES FOR INSTANTIATIONS OF " & + "GENERIC SUBPROGRAM UNITS WHICH CREATE TASKS"); + + ------------------------------------------------------------------- + DECLARE + PROCEDURE PROC1 IS NEW PROC (TT); + BEGIN + PROC1 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + DELAY 35.0; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC2 IS NEW PROC (REC); + BEGIN + PROC2 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC3 IS NEW PROC (LIM_PRI_TASK); + BEGIN + PROC3 (1); + FAILED ("EXCEPTION WAS NOT RAISED - 3"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + PROCEDURE PROC4 IS NEW PROC (LIM_REC); + BEGIN + PROC4 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC1 IS NEW FUNC (TT); + BEGIN + A := FUNC1 (1); + FAILED ("EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + DELAY 35.0 * Impdef.One_Second; + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC2 IS NEW FUNC (REC); + BEGIN + A := FUNC2 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC3 IS NEW FUNC (LIM_PRI_TASK); + BEGIN + A := FUNC3 (0); + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 7"); + DELAY 35.0 * Impdef.One_Second; + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + A : INTEGER; + FUNCTION FUNC4 IS NEW FUNC (LIM_REC); + BEGIN + A := FUNC4 (1); + FAILED ("EXCEPTION NOT RAISED - 8"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 8"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 8"); + END; + + ------------------------------------------------------------------- + + RESULT; + END C94010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94011a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,268 ---- + -- C94011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A FORMAL ACCESS TYPE OF A GENERIC UNIT DESIGNATES A + -- FORMAL LIMITED PRIVATE TYPE, THEN WHEN THE UNIT IS INSTANTIATED WITH + -- A TASK TYPE OR A TYPE HAVING A SUBCOMPONENT OF A TASK TYPE, THE + -- MASTER FOR ANY TASKS ALLOCATED WITHIN THE INSTANTIATED UNIT IS + -- DETERMINED BY THE ACTUAL PARAMETER. + + -- TBN 9/22/86 + + WITH REPORT; USE REPORT; + PROCEDURE C94011A IS + + GLOBAL_INT : INTEGER := 0; + MY_EXCEPTION : EXCEPTION; + + PACKAGE P IS + TYPE LIM_PRI_TASK IS LIMITED PRIVATE; + PROCEDURE E (T : LIM_PRI_TASK); + PRIVATE + TASK TYPE LIM_PRI_TASK IS + ENTRY E; + END LIM_PRI_TASK; + END P; + + USE P; + + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE REC IS + RECORD + A : INTEGER := 1; + B : TT; + END RECORD; + + TYPE LIM_REC IS + RECORD + A : INTEGER := 1; + B : LIM_PRI_TASK; + END RECORD; + + PACKAGE BODY P IS + TASK BODY LIM_PRI_TASK IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (2); + END LIM_PRI_TASK; + + PROCEDURE E (T : LIM_PRI_TASK) IS + BEGIN + T.E; + END E; + END P; + + TASK BODY TT IS + BEGIN + ACCEPT E; + GLOBAL_INT := IDENT_INT (1); + END TT; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PROCEDURE PROC (A : OUT ACC_T); + + PROCEDURE PROC (A : OUT ACC_T) IS + BEGIN + A := NEW T; + END PROC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + FUNCTION FUNC RETURN ACC_T; + + FUNCTION FUNC RETURN ACC_T IS + BEGIN + RETURN NEW T; + END FUNC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + TYPE ACC_T IS ACCESS T; + PACKAGE PAC IS + PTR_T : ACC_T := NEW T; + END PAC; + + BEGIN + TEST ("C94011A", "CHECK THAT IF A FORMAL ACCESS TYPE OF A " & + "GENERIC UNIT DESIGNATES A FORMAL LIMITED " & + "PRIVATE TYPE, THEN WHEN THE UNIT IS " & + "INSTANTIATED, THE MASTER FOR ANY TASKS " & + "ALLOCATED WITHIN THE INSTANTIATED UNIT IS " & + "DETERMINED BY THE ACTUAL PARAMETER"); + + ------------------------------------------------------------------- + DECLARE + TYPE ACC_TT IS ACCESS TT; + ACC1 : ACC_TT; + PROCEDURE PROC1 IS NEW PROC (TT, ACC_TT); + BEGIN + PROC1 (ACC1); + ACC1.E; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 1"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 1"); + END IF; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + DECLARE + TYPE ACC_REC IS ACCESS REC; + A : ACC_REC; + FUNCTION FUNC1 IS NEW FUNC (REC, ACC_REC); + BEGIN + A := FUNC1; + A.B.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 2"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 2"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 2"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_TT IS ACCESS LIM_PRI_TASK; + BEGIN + DECLARE + A : ACC_LIM_TT; + FUNCTION FUNC2 IS NEW FUNC (LIM_PRI_TASK, + ACC_LIM_TT); + BEGIN + A := FUNC2; + E (A.ALL); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 3"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 3"); + END IF; + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + BEGIN + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + ACC2 : ACC_LIM_REC; + PROCEDURE PROC2 IS NEW PROC (LIM_REC, ACC_LIM_REC); + BEGIN + PROC2 (ACC2); + E (ACC2.B); + END; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 4"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 4"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 4"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 4"); + END; + + ------------------------------------------------------------------- + BEGIN + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_TT IS ACCESS TT; + PACKAGE PAC1 IS NEW PAC (TT, ACC_TT); + USE PAC1; + BEGIN + PTR_T.E; + RAISE MY_EXCEPTION; + EXCEPTION + WHEN MY_EXCEPTION => + RAISE MY_EXCEPTION; + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 5"); + END; + FAILED ("MY_EXCEPTION NOT RAISED - 5"); + EXCEPTION + WHEN MY_EXCEPTION => + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 5"); + END IF; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + ------------------------------------------------------------------- + GLOBAL_INT := IDENT_INT (0); + + DECLARE + TYPE ACC_LIM_REC IS ACCESS LIM_REC; + BEGIN + DECLARE + PACKAGE PAC2 IS NEW PAC (LIM_REC, ACC_LIM_REC); + USE PAC2; + BEGIN + E (PTR_T.B); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("TASK DEPENDENT ON WRONG MASTER - 6"); + END; + IF GLOBAL_INT = IDENT_INT (0) THEN + FAILED ("TASK NOT DEPENDENT ON MASTER - 6"); + END IF; + + ------------------------------------------------------------------- + + RESULT; + END C94011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94020a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94020a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c94020a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c94020a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C94020A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE CONDITIONS FOR TERMINATION ARE RECOGNIZED WHEN THE + -- LAST MISSING TASK TERMINATES DUE TO AN ABORT + + -- JEAN-PIERRE ROSEN 08-MAR-1984 + -- JBG 6/1/84 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C94020A IS + + TASK TYPE T2 IS + END T2; + + TASK TYPE T3 IS + ENTRY E; + END T3; + + TASK BODY T2 IS + BEGIN + COMMENT("T2"); + END; + + TASK BODY T3 IS + BEGIN + COMMENT("T3"); + SELECT + ACCEPT E; + OR TERMINATE; + END SELECT; + FAILED("T3 EXITED SELECT OR TERMINATE"); + END; + + BEGIN + + TEST ("C94020A", "TEST OF TASK DEPENDENCES, TERMINATE, ABORT"); + + DECLARE + TASK TYPE T1 IS + END T1; + + V1 : T1; + TYPE A_T1 IS ACCESS T1; + + TASK BODY T1 IS + BEGIN + ABORT T1; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T1 NOT ABORTED"); + END; + + BEGIN + DECLARE + V2 : T2; + A1 : A_T1; + BEGIN + DECLARE + V3 : T3; + TASK T4 IS + END T4; + TASK BODY T4 IS + TASK T41 IS + END T41; + TASK BODY T41 IS + BEGIN + COMMENT("T41"); + ABORT T4; + DELAY 0.0; --SYNCHRONIZATION POINT + FAILED("T41 NOT ABORTED"); + END; + BEGIN --T4 + COMMENT("T4"); + END; + BEGIN + COMMENT("BLOC 3"); + END; + COMMENT("BLOC 2"); + A1 := NEW T1; + END; + COMMENT("BLOC 1"); + EXCEPTION + WHEN OTHERS => FAILED("SOME EXCEPTION RAISED"); + END; + + RESULT; + + END C94020A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c940a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c940a03.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- C940A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a protected object provides coordinated access to + -- shared data. Check that it can implement a semaphore-like construct + -- controlling access to shared data through procedure parameters to + -- allow a specific maximum number of tasks to run and exclude all + -- others. + -- + -- TEST DESCRIPTION: + -- Declare a resource descriptor tagged type. Extend the type and + -- use the extended type in a protected data structure. + -- Implement a counting semaphore type that can be initialized to a + -- specific number of available resources. Declare an entry for + -- requesting a specific resource and an procedure for releasing the + -- same resource it. Declare an object of this (protected) type, + -- initialized to two resources. Declare and start three tasks each + -- of which asks for a resource. Verify that only two resources are + -- granted and that the last task in is queued. + -- + -- This test models a multi-user operating system that allows a limited + -- number of logins. Users requesting login are modeled by tasks. + -- + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F940A00 + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Nov 95 SAIC Fixed bugs for ACVC 2.0.1 + -- + --! + + package C940A03_0 is + --Resource_Pkg + + -- General type declarations that will be extended to model available + -- logins + + type Resource_ID_Type is range 0..10; + type Resource_Type is tagged record + Id : Resource_ID_Type := 0; + end record; + + end C940A03_0; + --Resource_Pkg + + --======================================-- + -- no body for C940A3_0 + --======================================-- + + with F940A00; -- Interlock_Foundation + with C940A03_0; -- Resource_Pkg; + + package C940A03_1 is + -- Semaphores + + -- Models a counting semaphore that will allow up to a specific + -- number of logins + -- Users (tasks) request a login slot by calling the Request_Login + -- entry and logout by calling the Release_Login procedure + + Max_Logins : constant Integer := 2; + + + type Key_Type is range 0..100; + -- When a user requests a login, an + -- identifying key will be returned + Init_Key : constant Key_Type := 0; + + type Login_Record_Type is new C940A03_0.Resource_Type with record + Key : Key_Type := Init_Key; + end record; + + + protected type Login_Semaphore_Type (Resources_Available : Integer :=1) is + + entry Request_Login (Resource_Key : in out Login_Record_Type); + procedure Release_Login; + function Available return Integer; -- how many logins are available? + private + Logins_Avail : Integer := Resources_Available; + Next_Key : Key_Type := Init_Key; + + end Login_Semaphore_Type; + + Login_Semaphore : Login_Semaphore_Type (Max_Logins); + + --====== machinery for the test, not the model =====-- + TC_Control_Message : F940A00.Interlock_Type; + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer; + + + end C940A03_1; + -- Semaphores; + + --=========================================================-- + + package body C940A03_1 is + -- Semaphores is + + protected body Login_Semaphore_Type is + + entry Request_Login (Resource_Key : in out Login_Record_Type) + when Logins_Avail > 0 is + begin + Next_Key := Next_Key + 1; -- login process returns a key + Resource_Key.Key := Next_Key; -- to the requesting user + Logins_Avail := Logins_Avail - 1; + end Request_Login; + + procedure Release_Login is + begin + Logins_Avail := Logins_Avail + 1; + end Release_Login; + + function Available return Integer is + begin + return Logins_Avail; + end Available; + + end Login_Semaphore_Type; + + function TC_Key_Val (Login_Rec : Login_Record_Type) return Integer is + begin + return Integer (Login_Rec.Key); + end TC_Key_Val; + + end C940A03_1; + -- Semaphores; + + --=========================================================-- + + with C940A03_0; -- Resource_Pkg, + with C940A03_1; -- Semaphores; + + package C940A03_2 is + -- Task_Pkg + + package Semaphores renames C940A03_1; + + task type User_Task_Type is + + entry Login (user_id : C940A03_0.Resource_Id_Type); + -- instructs the task to ask for a login + entry Logout; -- instructs the task to release the login + --=======================-- + -- this entry is used to get information to verify test operation + entry Get_Status (User_Record : out Semaphores.Login_Record_Type); + + end User_Task_Type; + + end C940A03_2; + -- Task_Pkg + + --=========================================================-- + + with Report; + with C940A03_0; -- Resource_Pkg, + with C940A03_1; -- Semaphores, + with F940A00; -- Interlock_Foundation; + + package body C940A03_2 is + -- Task_Pkg + + -- This task models a user requesting a login from the system + -- For control of this test, we can ask the task to login, logout, or + -- give us the current user record (containing login information) + + task body User_Task_Type is + Rec : Semaphores.Login_Record_Type; + begin + loop + select + accept Login (user_id : C940A03_0.Resource_Id_Type) do + Rec.Id := user_id; + end Login; + + Semaphores.Login_Semaphore.Request_Login (Rec); + -- request a resource; if resource is not available, + -- task will be queued to wait + + --== following is test control machinery ==-- + F940A00.Counter.Increment; + Semaphores.TC_Control_Message.Post; + -- after resource is obtained, post message + + or + accept Logout do + Semaphores.Login_Semaphore.Release_Login; + -- release the resource + --== test control machinery ==-- + F940A00.Counter.Decrement; + end Logout; + exit; + + or + accept Get_Status (User_Record : out Semaphores.Login_Record_Type) do + User_Record := Rec; + end Get_Status; + + end select; + end loop; + + exception + when others => Report.Failed ("Exception raised in model user task"); + end User_Task_Type; + + end C940A03_2; + -- Task_Pkg + + --=========================================================-- + + with Report; + with ImpDef; + with C940A03_1; -- Semaphores, + with C940A03_2; -- Task_Pkg, + with F940A00; -- Interlock_Foundation; + + procedure C940A03 is + + package Semaphores renames C940A03_1; + package Users renames C940A03_2; + + Task1, Task2, Task3 : Users.User_Task_Type; + User_Rec : Semaphores.Login_Record_Type; + + begin -- Tasks start here + + Report.Test ("C940A03", "Check that a protected object can coordinate " & + "shared data access using procedure parameters"); + + if F940A00.Counter.Number /=0 then + Report.Failed ("Wrong initial conditions"); + end if; + + Task1.Login (1); -- request resource; request should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + -- Task 1 waiting for call to Logout + -- Others still available + Task1.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) + or (Semaphores.TC_Key_Val (User_Rec) /= 1) then + Report.Failed ("Resource not assigned to task 1"); + end if; + + Task2.Login (2); -- Request for resource should be granted + Semaphores.TC_Control_Message.Consume; + -- ensure that task obtains resource by + -- waiting for task to post message + + Task2.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 2) then + Report.Failed ("Resource not assigned to task 2"); + end if; + + + Task3.Login (3); -- request for resource should be denied + -- and task queued + + + -- Tasks 1 and 2 holds resources + -- and are waiting for a call to Logout + -- Task 3 is queued + + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) then + Report.Failed ("Resource incorrectly assigned to task 3"); + end if; + + Task1.Logout; -- released resource should be given to + -- queued task + Semaphores.TC_Control_Message.Consume; + -- wait for confirming message from task + + -- Task 1 holds no resources + -- and is terminated (or will soon) + -- Tasks 2 and 3 hold resources + -- and are waiting for a call to Logout + + Task3.Get_Status (User_Rec); + if (F940A00.Counter.Number /= 2) + or (Semaphores.Login_Semaphore.Available /=0) + or (Semaphores.TC_Key_Val (User_Rec) /= 3) then + Report.Failed ("Resource not properly released/assigned to task 3"); + end if; + + Task2.Logout; -- no outstanding request for released + -- resource + -- Tasks 1 and 2 hold no resources + -- Task 3 holds a resource + -- and is waiting for a call to Logout + + if (F940A00.Counter.Number /= 1) + or (Semaphores.Login_Semaphore.Available /=1) then + Report.Failed ("Resource not properly released from task 2"); + end if; + + Task3.Logout; + + -- all resources have been returned + -- all tasks have terminated or will soon + + if (F940A00.Counter.Number /=0) + or (Semaphores.Login_Semaphore.Available /=2) then + Report.Failed ("Resource not properly released from task 3"); + end if; + + -- Ensure all tasks have terminated before calling Result + while not (Task1'terminated and + Task2'terminated and + Task3'terminated) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C940A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95008a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,426 ---- + -- C95008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXCEPTION CONSTRAINT_ERROR IS RAISED FOR AN + -- OUT-OF-RANGE INDEX VALUE WHEN REFERENCING AN ENTRY FAMILY, + -- EITHER IN AN ACCEPT_STATEMENT OR IN AN ENTRY_CALL. + + -- SUBTESTS ARE: + -- (A) INTEGER TYPE, STATIC LOWER BOUND, NO PARAMETERS. + -- (B) CHARACTER TYPE, DYNAMIC UPPER BOUND, NO PARAMETERS. + -- (C) BOOLEAN TYPE, STATIC NULL RANGE, NO PARAMETERS. + -- (D) USER-DEFINED ENUMERATED TYPE, DYNAMIC LOWER BOUND, ONE + -- PARAMETER. + -- (E) DERIVED INTEGER TYPE, DYNAMIC NULL RANGE, ONE PARAMETER. + -- (F) DERIVED USER-DEFINED ENUMERATED TYPE, STATIC UPPER BOUND, + -- ONE PARAMETER. + + -- JRK 11/4/81 + -- JBG 11/11/84 + -- SAIC 11/14/95 fixed test for 2.0.1 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C95008A IS + + C_E_NOT_RAISED : BOOLEAN; + WRONG_EXC_RAISED : BOOLEAN; + + BEGIN + TEST ("C95008A", "OUT-OF-RANGE ENTRY FAMILY INDICES IN " & + "ACCEPT_STATEMENTS AND ENTRY_CALLS"); + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (A) + + TASK T IS + ENTRY E (1..10); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (0); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (A) + + SELECT + T.E (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + EXCEPTION -- (A) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (A)"); + T.CONTINUE; + + END; -- (A) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (A)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (B) + + TASK T IS + ENTRY E (CHARACTER RANGE 'A'..'Y'); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (IDENT_CHAR('Z')); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (B) + + SELECT + T.E (IDENT_CHAR('Z')); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + EXCEPTION -- (B) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (B)"); + T.CONTINUE; + + END; -- (B) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (B)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (C) + + TASK T IS + ENTRY E (TRUE..FALSE); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (FALSE); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (C) + + SELECT + T.E (TRUE); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + EXCEPTION -- (C) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (C)"); + T.CONTINUE; + + END; -- (C) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (C)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (D) + + TYPE ET IS (E0, E1, E2); + DLB : ET := ET'VAL (IDENT_INT(1)); -- E1. + + TASK T IS + ENTRY E (ET RANGE DLB..E2) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (E0) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (D) + + SELECT + T.E (E0) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + EXCEPTION -- (D) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (D)"); + T.CONTINUE; + + END; -- (D) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (D)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (E) + + TYPE D_I IS NEW INTEGER; + SUBTYPE DI IS D_I RANGE 3 .. D_I(IDENT_INT(2)); + + TASK T IS + ENTRY E (DI) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_I(3)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (E) + + SELECT + T.E (D_I(2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + EXCEPTION -- (E) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (E)"); + T.CONTINUE; + + END; -- (E) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (E)"); + END IF; + + -------------------------------------------------- + + C_E_NOT_RAISED := FALSE; + WRONG_EXC_RAISED := FALSE; + + DECLARE -- (F) + + TYPE ET IS (E0, E1, E2); + TYPE D_ET IS NEW ET; + + TASK T IS + ENTRY E (D_ET RANGE E0..E1) (I : INTEGER); + ENTRY CONTINUE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT CONTINUE; + SELECT + ACCEPT E (D_ET'(E2)) (I : INTEGER); + OR + DELAY 1.0 * Impdef.One_Second; + END SELECT; + C_E_NOT_RAISED := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + WRONG_EXC_RAISED := TRUE; + END T; + + BEGIN -- (F) + + SELECT + T.E (D_ET'(E2)) (0); + OR + DELAY 15.0 * Impdef.One_Second; + END SELECT; + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + EXCEPTION -- (F) + + WHEN CONSTRAINT_ERROR => + T.CONTINUE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN " & + "ENTRY_CALL - (F)"); + T.CONTINUE; + + END; -- (F) + + IF C_E_NOT_RAISED THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + IF WRONG_EXC_RAISED THEN + FAILED ("WRONG EXCEPTION RAISED IN " & + "ACCEPT_STATEMENT - (F)"); + END IF; + + -------------------------------------------------- + + RESULT; + END C95008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95009a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- C95009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK OBJECT CAN CALL ENTRIES OF OTHER TASKS. + + -- THIS TEST CONTAINS SHARED VARIABLES. + + -- JRK 11/5/81 + -- JRK 8/3/84 + + WITH REPORT; USE REPORT; + PROCEDURE C95009A IS + + V1 : INTEGER := 0; + V2 : INTEGER := 0; + + PI : INTEGER := 0; + PO : INTEGER := 0; + + BEGIN + TEST ("C95009A", "CHECK THAT A TASK OBJECT CAN CALL ENTRIES " & + "OF OTHER TASKS"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T1 IS + ENTRY E1N; + ENTRY EF1P (INT) (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2P (I : INTEGER); + ENTRY EF2N (INT); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + V1 := 1; + ACCEPT E1N; + V1 := 2; + AT2.E2P (1); + V1 := 3; + ACCEPT EF1P (2) (I : OUT INTEGER) DO + I := 2; + END EF1P; + V1 := 4; + AT2.EF2N (IDENT_INT(3)); + V1 := 5; + END T1; + + TASK BODY T2T IS + BEGIN + V2 := 1; + T1.E1N; + V2 := 2; + ACCEPT E2P (I : INTEGER) DO + PI := I; + END E2P; + V2 := 3; + T1.EF1P (2) (PO); + V2 := 4; + ACCEPT EF2N (1+IDENT_INT(2)); + V2 := 5; + END T2T; + + PACKAGE DUMMY IS + END DUMMY; + + PACKAGE BODY DUMMY IS + BEGIN + AT2 := NEW T2T; + END DUMMY; + + BEGIN + NULL; + END; + + IF V1 /= 5 THEN + FAILED ("TASK T1 ONLY REACHED V1 = " & INTEGER'IMAGE(V1)); + END IF; + + IF V2 /= 5 THEN + FAILED ("TASK AT2 ONLY REACHED V2 = " & INTEGER'IMAGE(V2)); + END IF; + + IF PI /= 1 THEN + FAILED ("ENTRY IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + + IF PO /= 2 THEN + FAILED ("ENTRY OUT PARAMETER NOT PASSED CORRECTLY"); + END IF; + + RESULT; + END C95009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95010a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C95010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK MAY CONTAIN MORE THAN ONE ACCEPT_STATEMENT + -- FOR AN ENTRY. + + -- THIS TEST CONTAINS SHARED VARIABLES. + + -- JRK 11/5/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; USE REPORT; + PROCEDURE C95010A IS + + V : INTEGER := 0; + + BEGIN + TEST ("C95010A", "CHECK THAT A TASK MAY CONTAIN MORE THAN " & + "ONE ACCEPT_STATEMENT FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + ACCEPT E; + V := 2; + ACCEPT E; + V := 3; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 5; + ACCEPT EF (2) (I : INTEGER) DO + V := I; + END EF; + V := 7; + END T; + + BEGIN + + T.E; + T.E; + T.EF (2) (4); + T.EF (2) (6); + + END; + + IF V /= 7 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; + END C95010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95011a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C95011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK NEED NOT CONTAIN ANY ACCEPT_STATEMENTS FOR AN + -- ENTRY. + + -- THIS TEST CONTAINS SHARED VARIABLES. + + -- JRK 11/5/81 + -- JWC 6/28/85 RENAMED TO -AB + + WITH REPORT; USE REPORT; + PROCEDURE C95011A IS + + V : INTEGER := 0; + + BEGIN + TEST ("C95011A", "CHECK THAT A TASK NEED NOT CONTAIN ANY " & + "ACCEPT_STATEMENTS FOR AN ENTRY"); + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 1..5; + + TASK T IS + ENTRY E; + ENTRY EF (INT) (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + V := 1; + END T; + + BEGIN + + NULL; + + END; + + IF V /= 1 THEN + FAILED ("WRONG CONTROL FLOW VALUE"); + END IF; + + RESULT; + END C95011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95012a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C95012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CALL TO AN ENTRY OF A TASK THAT HAS NOT BEEN ACTIVATED + -- DOES NOT RAISE EXCEPTIONS. + + -- THIS TEST CONTAINS RACE CONDITIONS. + + -- JRK 11/6/81 + -- SPS 11/21/82 + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C95012A IS + + I : INTEGER := 0; + + + BEGIN + TEST ("C95012A", "CHECK THAT A CALL TO AN ENTRY OF A TASK " & + "THAT HAS NOT BEEN ACTIVATED DOES NOT " & + "RAISE EXCEPTIONS"); + + DECLARE + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER); + END T1; + + TASK TYPE T2T IS + ENTRY E2 (I : OUT INTEGER); + END T2T; + + TYPE AT2T IS ACCESS T2T; + AT2 : AT2T; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER) DO + I := IDENT_INT (1); + END E1; + END T1; + + TASK BODY T2T IS + J : INTEGER := 0; + BEGIN + BEGIN + T1.E1 (J); + EXCEPTION + WHEN OTHERS => + J := -1; + END; + ACCEPT E2 (I : OUT INTEGER) DO + I := J; + END E2; + END T2T; + + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + AT2 := NEW T2T; + DELAY 60.0 * Impdef.One_Second; + END PKG; + + BEGIN + + AT2.ALL.E2 (I); + + IF I = -1 THEN + FAILED ("EXCEPTION RAISED"); + T1.E1 (I); + END IF; + + IF I /= 1 THEN + FAILED ("WRONG VALUE PASSED"); + END IF; + + END; + + RESULT; + END C95012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95021a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95021a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95021a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95021a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C95021A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CALLS TO AN ENTRY ARE PLACED IN A FIFO QUEUE. + + -- JBG 2/22/84 + -- DAS 10/8/90 ADDED PRAGMA PRIORITY TO ENSURE THAT THE FIFO + -- DISCIPLINE MUST BE FOLLOWED (OTHERWISE THE + -- IMPLEMENTATION MIGHT PROHIBIT QUEUES FROM + -- FORMING SO THAT E'COUNT IS ALWAYS ZERO FOR + -- AN ENTRY E). + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + -- THE TASK QUEUE IS THE TASK THAT CHECKS THE QUEUEING DISCIPLINE. + -- + -- THIS TEST PLACES TWO CALLS ON AN ENTRY, WAITS UNTIL ONE OF THE CALLS + -- IS ACCEPTED, AND THEN PLACES A THIRD CALL ON THE ENTRY. THE TEST + -- CHECKS THAT THE SECOND CALL IS HANDLED BEFORE THE THIRD. (IT IS + -- NONDETERMINISTIC WHICH CALL WILL BE THE FIRST ONE ON THE QUEUE, SO + -- THIS MORE COMPLICATED APPROACH IS NECESSARY.) + -- + -- THE TASK DISPATCH FIRES UP THE TWO TASKS THAT MAKE THE FIRST TWO + -- CALLS AND THEN WAITS UNTIL QUEUE SAYS IT IS READY FOR THE THIRD CALL. + -- + -- THE TASK TYPE CALLERS IS USED TO CREATE TASKS THAT WILL CALL THE + -- ENTRY IN THE TASK QUEUE. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE C95021A IS + BEGIN + + TEST ("C95021A", "CHECK THAT ENTRY CALLS ARE PUT IN FIFO QUEUES"); + + -- DO THIS TEST 3 TIMES TO ALLOW FOR RANDOM VARIATIONS IN TIMING. + FOR I IN 1..3 LOOP + COMMENT ("ITERATION" & INTEGER'IMAGE(I)); + + DECLARE + + TASK TYPE CALLERS IS + ENTRY NAME (N : NATURAL); + END CALLERS; + + TASK QUEUE IS + ENTRY GO; + ENTRY E1 (NAME : NATURAL); + END QUEUE; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + TASK BODY CALLERS IS + MY_NAME : NATURAL; + BEGIN + + -- GET NAME OF THIS TASK OBJECT + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + -- PUT THIS TASK ON QUEUE FOR QUEUE.E1 + QUEUE.E1 (MY_NAME); + END CALLERS; + + TASK BODY DISPATCH IS + TYPE ACC_CALLERS IS ACCESS CALLERS; + OBJ : ACC_CALLERS; + BEGIN + + -- FIRE UP TWO CALLERS FOR QUEUE.E1 + OBJ := NEW CALLERS; + OBJ.NAME(1); + OBJ := NEW CALLERS; + OBJ.NAME(2); + + -- ALLOW THESE CALLS TO BE PROCESSED (ONLY ONE WILL BE ACCEPTED). + QUEUE.GO; + + -- WAIT TILL ONE CALL HAS BEEN PROCESSED. + ACCEPT READY; -- CALLED FROM QUEUE + + -- FIRE UP THIRD CALLER + OBJ := NEW CALLERS; + OBJ.NAME(3); + + END DISPATCH; + + TASK BODY QUEUE IS + NEXT : NATURAL; -- NUMBER OF SECOND CALLER IN QUEUE. + BEGIN + + -- WAIT UNTIL TWO TASKS CALLING E1 HAVE BEEN ACTIVATED. + ACCEPT GO; + + -- WAIT FOR TWO CALLS TO BE AVAILABLE. THIS WAIT ASSUMES THAT THE + -- CALLER TASKS WILL PROCEED IF THIS TASK IS EXECUTING A DELAY + -- STATEMENT, ALTHOUGH THIS IS NOT STRICTLY REQUIRED BY THE STANDARD. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 1"); + END IF; + + -- ASSUMING NO FAILURE, PROCESS ONE OF THE QUEUED CALLS. + ACCEPT E1 (NAME : NATURAL) DO + + -- GET NAME OF NEXT CALLER + CASE NAME IS + WHEN 1 => + NEXT := 2; + WHEN 2 => + NEXT := 1; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR"); + END CASE; + END E1; + + -- TELL DISPATCH TO FIRE UP NEXT CALLER (ONE IS STILL IN QUEUE). + DISPATCH.READY; + + -- WAIT FOR CALL TO ARRIVE. + FOR I IN 1..6 -- WILL WAIT FOR ONE MINUTE + LOOP + EXIT WHEN E1'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; -- WAIT FOR CALLS TO ARRIVE + END LOOP; + + IF E1'COUNT /= 2 THEN + FAILED ("CALLER TASKS NOT QUEUED AFTER ONE " & + "MINUTE - 2"); + END IF; + + -- ASSUMING NO FAILURE, ACCEPT SECOND CALL AND CHECK THAT IT IS FROM THE + -- CORRECT TASK. + ACCEPT E1 (NAME : NATURAL) DO + IF NAME /= NEXT THEN + FAILED ("FIFO DISCIPLINE NOT OBEYED"); + END IF; + END E1; + + -- ACCEPT THE LAST CALLER + ACCEPT E1 (NAME : NATURAL); + + END QUEUE; + + BEGIN + NULL; + END; -- ALL TASKS NOW TERMINATED. + END LOOP; + + RESULT; + + END C95021A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95022a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95022a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95022a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95022a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + --C95022A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + --CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE THE + --THE BODY OF AN ACCEPT STATEMENT. + + --CHECK THE CASE OF NORMAL ENTRY TERMINATION. + + -- JEAN-PIERRE ROSEN 25-FEB-1984 + -- JBG 6/1/84 + + -- FOUR CLIENT TASKS CALL ONE SERVER TASK. EACH CLIENT CALLS JUST ONE + -- ENTRY OF THE SERVER TASK. THE TEST CHECKS TO BE SURE THAT CALLS FROM + -- DIFFERENT TASKS ARE NOT MIXED UP. + + WITH REPORT; USE REPORT; + PROCEDURE C95022A IS + + BEGIN + TEST("C95022A", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY"); + DECLARE + + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + ENTRY RESTART; + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK SERVER IS + ENTRY E1 (I : IN OUT INTEGER); + ENTRY E2 (I : IN OUT INTEGER); + ENTRY E3 (I : IN OUT INTEGER); + ENTRY E4 (I : IN OUT INTEGER); + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 (I : IN OUT INTEGER) DO + ACCEPT E2 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + ACCEPT E3 (I : IN OUT INTEGER) DO + ACCEPT E4 (I : IN OUT INTEGER) DO + I := IDENT_INT(I); + END E4; + I := IDENT_INT(I); + END E3; + END E2; + I := IDENT_INT(I); + END E1; + + FOR I IN 1 .. 4 LOOP + T_ARR(I).RESTART; + END LOOP; + END SERVER; + + TASK BODY CLIENT IS + ID : INTEGER; + SAVE_ID : INTEGER; + BEGIN + ACCEPT GET_ID (I : INTEGER) DO + ID := I; + END GET_ID; + + SAVE_ID := ID; + + CASE ID IS + WHEN 1 => SERVER.E1(ID); + WHEN 2 => SERVER.E2(ID); + WHEN 3 => SERVER.E3(ID); + WHEN 4 => SERVER.E4(ID); + WHEN OTHERS => FAILED("INCORRECT ID"); + END CASE; + + ACCEPT RESTART; -- WAIT FOR ALL TASKS TO HAVE COMPLETED + -- RENDEZVOUS + IF ID /= SAVE_ID THEN + FAILED("SCRAMBLED EMBEDDED RENDEZVOUS"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED("EXCEPTION IN CLIENT"); + END CLIENT; + + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + + END C95022A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95022b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95022b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95022b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95022b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C95022B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IT IS POSSIBLE TO ACCEPT AN ENTRY CALL FROM INSIDE + -- THE BODY OF AN ACCEPT STATEMENT. + + -- CHECK THE CASE OF ABORT DURING THE INNERMOST ACCEPT. + + -- JEAN-PIERRE ROSEN 25-FEB-1984 + -- JBG 6/1/84 + + WITH REPORT; USE REPORT; + PROCEDURE C95022B IS + + BEGIN + + TEST("C95022B", "CHECK THAT EMBEDDED RENDEZVOUS ARE PROCESSED " & + "CORRECTLY (ABORT CASE)"); + DECLARE + TASK TYPE CLIENT IS + ENTRY GET_ID (I : INTEGER); + END CLIENT; + + T_ARR : ARRAY (1..4) OF CLIENT; + + TASK KILL IS + ENTRY ME; + END KILL; + + TASK SERVER IS + ENTRY E1; + ENTRY E2; + ENTRY E3; + ENTRY E4; + END SERVER; + + TASK BODY SERVER IS + BEGIN + + ACCEPT E1 DO + ACCEPT E2 DO + ACCEPT E3 DO + ACCEPT E4 DO + KILL.ME; + E1; -- WILL DEADLOCK UNTIL ABORT. + END E4; + END E3; + END E2; + END E1; + + END SERVER; + + TASK BODY KILL IS + BEGIN + ACCEPT ME; + ABORT SERVER; + END; + + TASK BODY CLIENT IS + ID : INTEGER; + BEGIN + ACCEPT GET_ID( I : INTEGER) DO + ID := I; + END GET_ID; + + CASE ID IS + WHEN 1 => SERVER.E1; + WHEN 2 => SERVER.E2; + WHEN 3 => SERVER.E3; + WHEN 4 => SERVER.E4; + WHEN OTHERS => FAILED ("INCORRECT ID"); + END CASE; + + FAILED ("TASKING_ERROR NOT RAISED IN CLIENT" & + INTEGER'IMAGE(ID)); + + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("EXCEPTION IN CLIENT" & INTEGER'IMAGE(ID)); + END CLIENT; + BEGIN + FOR I IN 1 .. 4 LOOP + T_ARR(I).GET_ID(I); + END LOOP; + END; + + RESULT; + + END C95022B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95033a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95033a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95033a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95033a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C95033A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT - IN THE CASE OF AN ENTRY FAMILY - EXECUTION OF AN + -- ACCEPT STATEMENT STARTS WITH THE EVALUATION OF AN ENTRY INDEX. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950BGA-B.ADA + + WITH REPORT; + USE REPORT; + PROCEDURE C95033A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2); + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (FINIT_POS (1)) DO + PSPY_NUMB (2); + END E1; + ACCEPT BYE; + END T1; + + BEGIN + TEST ("C95033A", "EVALUATION OF ENTRY INDEX"); + + T1.E1 (1); + T1.BYE; + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C95033A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95033b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95033b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95033b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95033b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- C95033B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXECUTION OF AN ENTRY CALL STARTS WITH THE EVALUATION OF + -- ANY ENTRY INDEX, FOLLOWED BY THE EVALUATION OF ANY EXPRESSION IN + -- THE PARAMETER LIST. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950BHA-B.ADA + + WITH REPORT; + USE REPORT; + PROCEDURE C95033B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + FUNCTION FINIT_POS (DIGT: IN ARG) RETURN NATURAL IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + RETURN DIGT; + END FINIT_POS; + + TASK T1 IS + ENTRY E1 (NATURAL RANGE 1 .. 2) (P1 : IN NATURAL); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (1) (P1 : IN NATURAL); + END T1; + + BEGIN + + TEST ("C95033B", "EVALUATION OF ENTRY INDEX AND OF " & + "EXPRESSIONS IN PARAMETER LIST"); + + T1.E1 (FINIT_POS (1)) (FINIT_POS (2)); + IF SPYNUMB /= 12 THEN + FAILED ("ENTRY INDEX NOT EVALUATED FIRST"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C95033B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95034a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95034a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95034a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95034a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C95034A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CALLING TASK IS SUSPENDED IF THE RECEIVING TASK + -- HAS NOT REACHED A CORRESPONDING ACCEPT STATEMENT. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950BJA-B.ADA + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C95034A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY E2; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + END E1; + ACCEPT E2 DO + PSPY_NUMB (2); + END E2; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E2; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + + BEGIN + + TEST ("C95034A", "SUSPENSION OF CALLING TASK"); + + T1.E1; + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C95034A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95034b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95034b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95034b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95034b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- C95034B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CALLING TASK REMAINS SUSPENDED UNTIL THE ACCEPT + -- STATEMENT RECEIVING THIS ENTRY CALL HAS COMPLETED THE EXECUTION OF + -- ITS SEQUENCE OF STATEMENTS. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950CBA-B.ADA + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C95034B IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + PSPY_NUMB (1); + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (2); + END E1; + END T1; + + TASK T2 IS + ENTRY BYE; + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + PSPY_NUMB (3); + ACCEPT BYE; + END T2; + + BEGIN + + TEST ("C95034B", "TASK SUSPENSION UNTIL COMPLETION OF ACCEPT " & + "STATEMENT"); + + T2.BYE; + + IF SPYNUMB /= 123 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C95034B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95035a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95035a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95035a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95035a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- C95035A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK IS SUSPENDED IF IT REACHES AN ACCEPT STATEMENT + -- PRIOR TO ANY CALL OF THE CORRESPONDING ENTRY. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950CAA-B.ADA + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C95035A IS + + SUBTYPE ARG IS NATURAL RANGE 0..9; + SPYNUMB : NATURAL := 0; + + PROCEDURE PSPY_NUMB (DIGT: IN ARG) IS + BEGIN + SPYNUMB := 10*SPYNUMB+DIGT; + END PSPY_NUMB; + + TASK T1 IS + ENTRY E1; + ENTRY BYE; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + PSPY_NUMB (2); + ACCEPT BYE; + END T1; + + TASK T2; + + TASK BODY T2 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + PSPY_NUMB (1); + T1.E1; + END T2; + + BEGIN + + TEST ("C95035A", "TASK SUSPENSION PRIOR TO ENTRY CALL"); + + T1.BYE; + + IF SPYNUMB /= 12 THEN + FAILED ("ERROR DURING TASK EXECUTION"); + COMMENT ("ACTUAL ORDER WAS:" & INTEGER'IMAGE(SPYNUMB)); + END IF; + + RESULT; + + END C95035A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- C95040A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED IF AN ENTRY OF A + -- COMPLETED TASK IS CALLED. + + -- WEI 3/ 4/82 + -- JWC 6/28/85 RENAMED FROM C950CHA-B.ADA + + WITH REPORT; + USE REPORT; + PROCEDURE C95040A IS + BEGIN + + TEST ("C95040A", "ENTRY CALL OF COMPLETED TASK"); + + BLOCK1 : + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1; + END T1; + BEGIN -- BLOCK1 + T1.E1; + T1.E1; + + FAILED ("DID NOT RAISE TASKING_ERROR"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + END BLOCK1; + + RESULT; + + END C95040A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- C95040B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXCEPTION TASKING_ERROR IS RAISED BY A TASK IF THE + -- TASK BECOMES COMPLETED OR ABNORMAL BEFORE ACCEPTING THE CALL. + + -- WEI 3/ 4/82 + -- TLB 10/30/87 RENAMED FROM C950CHC.ADA. + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C95040B IS + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + DELAY 1.0 * Impdef.One_Second; + IF EQUAL (1, 1) THEN + ABORT T1; + END IF; + ACCEPT E1; + END T1; + + BEGIN + + TEST ("C95040B", "TASK COMPLETION BEFORE ACCEPTING AN ENTRY CALL"); + + T1.E1; + + FAILED ("NO EXCEPTION TASKING_ERROR RAISED"); + + RESULT; + + EXCEPTION + WHEN TASKING_ERROR => + RESULT; + + END C95040B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- C95040C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECKS THAT A TASK COMPLETED, BUT NOT TERMINATED (I.E. WAITING + -- FOR TERMINATION OF A DEPENDENT TASK) IS NEITHER 'TERMINATED NOR + -- 'CALLABLE. CALLS TO ENTRIES BELONGING TO SUCH A TASK RAISE + -- TASKING_ERROR. + + -- J.P. ROSEN, ADA PROJECT, NYU + -- JBG 6/1/84 + -- JWC 6/28/85 RENAMED FROM C9A009A-B.ADA + -- PWN 9/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C95040C IS + BEGIN + + TEST ("C95040C", "TASKING_ERROR RAISED WHEN CALLING COMPLETED " & + "BUT UNTERMINATED TASK"); + + DECLARE + + TASK T1 IS + ENTRY E; + END T1; + + TASK BODY T1 IS + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + COMMENT ("BEGIN T2"); + T1.E; -- T1 WILL COMPLETE BEFORE THIS CALL + -- OR WHILE WAITING FOR THIS CALL TO + -- BE ACCEPTED. WILL DEADLOCK IF + -- TASKING_ERROR IS NOT RAISED. + FAILED ("NO TASKING_ERROR RAISED"); + EXCEPTION + WHEN TASKING_ERROR => + IF T1'CALLABLE THEN + FAILED ("T1 STILL CALLABLE"); + END IF; + + IF T1'TERMINATED THEN -- T1 CAN'T TERMINATE + -- UNTIL T2 HAS + -- TERMINATED. + FAILED ("T1 TERMINATED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END T2; + BEGIN + NULL; + END; + + BEGIN + NULL; + END; + + RESULT; + + END C95040C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95040d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95040d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C95040D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASKING_ERROR IS RAISED IN A CALLING + -- TASK WHEN THE TASK OWNING THE ENTRY TERMINATES BEFORE RENDEZVOUS + -- CAN OCCUR. + + -- CHECK THAT RE-RAISING TASKING_ERROR, ONCE TRAPPED IN THE CALLER, + -- DOES NOT PROPAGATE OUTSIDE THE TASK BODY. + + -- GOM 11/29/84 + -- JWC 05/14/85 + -- PWB 02/11/86 CORRECTED CALL TO TEST TO SHOW CORRECT TEST NAME. + -- RLB 12/15/99 REMOVED POTENTIALLY ERRONEOUS CALLS TO REPORT.COMMENT. + + WITH REPORT; + USE REPORT; + + PROCEDURE C95040D IS + + PROCEDURE DRIVER IS + + TASK NEST IS + ENTRY OUTER; + ENTRY INNER; + END NEST; + + TASK SLAVE; + + TASK BODY NEST IS + BEGIN + --COMMENT("AT TOP OF 'NEST' TASK WAITING ON 'OUTER' " & + -- "RENDEZVOUS"); + + ACCEPT OUTER DO + --COMMENT("IN 'OUTER' RENDEZVOUS OF 'NEST' TASK " & + -- "ABOUT TO 'RETURN'"); + + RETURN; -- CAUSES 'INNER' RENDEZVOUS TO BE SKIPPED. + + ACCEPT INNER DO + FAILED("'INNER' RENDEZVOUS OF 'NEST' TASK " & + "SHOULD NEVER BE PERFORMED"); + END INNER; + END OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED IN 'NEST' TASK " & + -- "AND NOW TERMINATING"); + END NEST; + + TASK BODY SLAVE IS + BEGIN + --COMMENT("AT TOP OF 'SLAVE' TASK. CALLING 'INNER' " & + -- "RENDEZVOUS"); + + NEST.INNER; + + FAILED("SHOULD HAVE RAISED 'TASKING_ERROR' IN 'SLAVE' " & + "TASK"); + EXCEPTION + WHEN TASKING_ERROR => + --COMMENT("'SLAVE' TASK CORRECTLY TRAPPING " & + -- "'TASKING_ERROR' AND RE-RAISING IT (BUT " & + -- "SHOULD NOT BE PROPAGATED)"); + RAISE; + END SLAVE; + + BEGIN -- START OF DRIVER PROCEDURE. + + --COMMENT("AT TOP OF 'DRIVER'. CALLING 'OUTER' ENTRY OF " & + -- "'NEST' TASK"); + + NEST.OUTER; + + --COMMENT("'OUTER' RENDEZVOUS COMPLETED. 'DRIVER' AWAITING " & + -- "TERMINATION OF 'NEST' AND 'SLAVE' TASKS"); + + EXCEPTION + WHEN TASKING_ERROR => + FAILED("'TASKING_ERROR' CAUGHT IN 'DRIVER' WHEN IT " & + "SHOULD HAVE BEEN CAUGHT IN 'SLAVE' TASK, OR " & + "'TASKING_ERROR' WAS INCORRECTLY PROPAGATED BY " & + "'SLAVE' TASK"); + END DRIVER; + + BEGIN -- START OF MAIN PROGRAM. + + TEST("C95040D","CHECK THAT 'TASKING_ERROR' IS RAISED IN A " & + "CALLER TASK WHEN TASK OWNING THE ENTRY CANNOT " & + "PERFORM RENDEZVOUS. ALSO CHECK THAT " & + "'TASKING_ERROR', ONCE RAISED, IS NOT PROPAGATED " & + "OUTSIDE THE TASK BODY"); + + --COMMENT("MAIN PROGRAM CALLING 'DRIVER' PROCEDURE"); + + DRIVER; + + --COMMENT("MAIN PROGRAM NOW TERMINATING"); + + RESULT; + END C95040D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95041a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95041a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95041a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95041a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95041A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENTRY FAMILY INDEX CAN BE SPECIFIED WITH THE FORM + -- A'RANGE. + + -- HISTORY: + -- DHH 03/17/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C95041A IS + + GLOBAL_A, GLOBAL_B : INTEGER; + GLOBAL_C, GLOBAL_D : INTEGER; + TYPE COLOR IS (RED, BLUE, YELLOW); + TYPE ARR IS ARRAY(COLOR RANGE RED .. BLUE) OF BOOLEAN; + ARRY : ARR; + + TASK CHECK IS + ENTRY CHECK_LINK(ARR'RANGE)(I : INTEGER); + END CHECK; + + TASK CHECK_OBJ IS + ENTRY CHECK_OBJ_LINK(ARRY'RANGE)(I : INTEGER); + END CHECK_OBJ; + + TASK BODY CHECK IS + BEGIN + ACCEPT CHECK_LINK(RED)(I : INTEGER) DO + GLOBAL_A := IDENT_INT(I); + END; + + ACCEPT CHECK_LINK(BLUE)(I : INTEGER) DO + GLOBAL_B := IDENT_INT(I); + END; + END CHECK; + + TASK BODY CHECK_OBJ IS + BEGIN + ACCEPT CHECK_OBJ_LINK(RED)(I : INTEGER) DO + GLOBAL_C := IDENT_INT(I); + END; + + ACCEPT CHECK_OBJ_LINK(BLUE)(I : INTEGER) DO + GLOBAL_D := IDENT_INT(I); + END; + END CHECK_OBJ; + + BEGIN + TEST("C95041A", "CHECK THAT AN ENTRY FAMILY INDEX CAN BE " & + "SPECIFIED WITH THE FORM A'RANGE"); + CHECK.CHECK_LINK(RED)(10); + CHECK.CHECK_LINK(BLUE)(5); + + CHECK_OBJ.CHECK_OBJ_LINK(RED)(10); + CHECK_OBJ.CHECK_OBJ_LINK(BLUE)(5); + + IF GLOBAL_A /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_B /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_C /= IDENT_INT(10) THEN + FAILED("ENTRY CHECK_LINK(RED) HAS INCORRECT VALUE"); + END IF; + + IF GLOBAL_D /= IDENT_INT(5) THEN + FAILED("ENTRY CHECK_LINK(BLUE) HAS INCORRECT VALUE"); + END IF; + + RESULT; + END C95041A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C95065A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND + -- INITIALIZED WITH A STATIC AGGREGATE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065A IS + + BEGIN + + TEST ("C95065A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. IDENT_INT(1), 1 .. IDENT_INT(10)) + OF INTEGER; + + TASK T IS + ENTRY E1 (A : A1 := ((1, 0), (0, 1))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, 0), (0, 1))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C95065B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS + -- INITIALIZED WITH A STATIC VALUE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065B IS + + BEGIN + + TEST ("C95065B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER + RANGE IDENT_INT(0) .. IDENT_INT(63); + + TASK T IS + ENTRY E1 (I : INT := -1); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (I : INT := -1) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95065C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC + -- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065C IS + + BEGIN + + TEST ("C95065C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 3) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(3); + + TYPE REC IS + RECORD + I : INTEGER RANGE IDENT_INT(1)..IDENT_INT(3); + A : A1; + END RECORD; + + TASK T IS + ENTRY E1 (R : REC := (-3,(0,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC := (-3,(0,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C95065D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON + -- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065D IS + + BEGIN + + TEST ("C95065D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := ((1, -1), (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := ((1, -1), (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- C95065E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (E) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON + -- SUBSCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065E IS + + BEGIN + + TEST ("C95065E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + TYPE A1 IS ARRAY (1 .. 2, 1 .. 2) OF INTEGER + RANGE IDENT_INT(1) .. IDENT_INT(2); + + TASK T IS + ENTRY E1 (A : A1 := (3 .. 4 => (1, 2))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (A : A1 := (3 .. 4 => (1, 2))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95065f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95065f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95065F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED WHEN AN ENTRY IS DECLARED + -- IF THE VALUE OF THE DEFAULT EXPRESSION FOR THE FORMAL PARAMETER DOES + -- NOT SATISFY THE CONSTRAINTS OF THE TYPE MARK, BUT IS RAISED WHEN THE + -- ENTRY IS CALLED AND THE DEFAULT VALUE IS USED. + + -- CASE (F) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT + -- INITIALIZED WITH A STATIC AGGREGATE. + + -- JWC 6/19/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95065F IS + + BEGIN + + TEST ("C95065F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED IF " & + "AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER WHEN THE " & + "FORMAL PART IS ELABORATED"); + + BEGIN + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0 .. 10; + TYPE A1 IS ARRAY (1 .. 3) OF INT; + TYPE REC (I : INT) IS + RECORD + A : A1; + END RECORD; + + SUBTYPE REC4 IS REC (IDENT_INT(4)); + + TASK T IS + ENTRY E1 (R : REC4 := (3,(1,2,3))); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E1 (R : REC4 := (3,(1,2,3))) DO + FAILED ("ACCEPT E1 EXECUTED"); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK T"); + END T; + + BEGIN + T.E1; + FAILED ("CONSTRAINT ERROR NOT RAISED ON CALL TO T.E1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - E1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED (BY ENTRY DECL)"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED"); + END; + + RESULT; + + END C95065F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95066a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95066a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95066a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95066a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- C95066A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A STATIC EXPRESSION, CONSTANT NAME, ATTRIBUTE NAME, + -- VARIABLE, DEREFERENCED ACCESS, USER-DEFINED OPERATOR, USER- + -- DEFINED FUNCTION, OR ALLOCATOR CAN BE USED IN THE INITIALIZATION + -- EXPRESSION OF A FORMAL PARAMETER, AND THAT THE APPROPRIATE + -- VALUE IS USED AS A DEFAULT PARAMETER VALUE WHEN THE ENTRY + -- IS CALLED. + + -- GLH 6/19/85 + + WITH REPORT; + PROCEDURE C95066A IS + + USE REPORT; + + TYPE INT IS RANGE 1 .. 10; + + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + A : ARR (0..CONSTRAINT); + END RECORD; + + C7 : CONSTANT INTEGER := 7; + V7 : INTEGER := 7; + + TYPE A_INT IS ACCESS INTEGER; + C_A : CONSTANT A_INT := NEW INTEGER'(7); + + SUBTYPE RECTYPE1 IS RECTYPE (2 + 5); + SUBTYPE RECTYPE2 IS RECTYPE (C7); + SUBTYPE RECTYPE3 IS RECTYPE (V7); + + FUNCTION "&" (X,Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 10; + END "&"; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X; + END FUNC; + + -- STATIC EXPRESSION. + + TASK T1 IS + ENTRY E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC : RECTYPE1 := (3+4,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E1 PARAMETER"); + END IF; + END E1; + END T1; + + -- CONSTANT NAME. + + TASK T2 IS + ENTRY E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : RECTYPE2 := (C7,(0,1,2,3,4,5,6,7))) DO + IF (REC /= (C7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E2 PARAMETER"); + END IF; + END E2; + END T2; + + -- ATTRIBUTE NAME. + + TASK T3 IS + ENTRY E3 (P1 : INT := INT'LAST); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (P1 : INT := INT'LAST) DO + IF (P1 /= INT (10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E3 PARAMETER"); + END IF; + END E3; + END T3; + + -- VARIABLE. + + TASK T4 IS + ENTRY E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))); + END T4; + + TASK BODY T4 IS + BEGIN + ACCEPT E4 (P4 : RECTYPE3 := (V7,(0,1,2,3,4,5,6,7))) DO + IF (P4 /= (V7,(0,1,2,3,4,5,6,7))) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E4 PARAMETER"); + END IF; + END E4; + END T4; + + -- DEREFERENCED ACCESS. + + TASK T5 IS + ENTRY E5 (P5 : INTEGER := C_A.ALL); + END T5; + + TASK BODY T5 IS + BEGIN + ACCEPT E5 (P5 : INTEGER := C_A.ALL) DO + IF (P5 /= C_A.ALL) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E5 PARAMETER"); + END IF; + END E5; + END T5; + + -- USER-DEFINED OPERATOR. + + TASK T6 IS + ENTRY E6 (P6 : INTEGER := 6&4); + END T6; + + TASK BODY T6 IS + BEGIN + ACCEPT E6 (P6 : INTEGER := 6&4) DO + IF (P6 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E6 PARAMETER"); + END IF; + END E6; + END T6; + + -- USER-DEFINED FUNCTION. + + TASK T7 IS + ENTRY E7 (P7 : INTEGER := FUNC(10)); + END T7; + + TASK BODY T7 IS + BEGIN + ACCEPT E7 (P7 : INTEGER := FUNC(10)) DO + IF (P7 /= IDENT_INT(10)) THEN + FAILED ("INCORRECT DEFAULT VALUE FOR " & + "E7 PARAMETER"); + END IF; + END E7; + END T7; + + -- ALLOCATOR. + + TASK T8 IS + ENTRY E8 (P8 : A_INT := NEW INTEGER'(7)); + END T8; + + TASK BODY T8 IS + BEGIN + ACCEPT E8 (P8 : A_INT := NEW INTEGER'(7)) DO + IF (P8.ALL /= IDENT_INT(7)) THEN + FAILED ("INCORRECT DEFAULT VALUE " & + "FOR E8 PARAMETER"); + END IF; + END E8; + END T8; + + BEGIN + TEST ("C95066A", "CHECK USE OF STATIC EXPRESSIONS, CONSTANT " & + "NAMES, ATTRIBUTE NAMES, VARIABLES, USER- " & + "DEFINED OPERATORS, USER-DEFINED FUNCTIONS, " & + "DEREFERENCED ACCESSES, AND ALLOCATORS IN " & + "THE FORMAL PART OF A TASK SPECIFICATION"); + + T1.E1; + T2.E2; + T3.E3; + T4.E4; + T5.E5; + T6.E6; + T7.E7; + T8.E8; + + RESULT; + + END C95066A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95067a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95067a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95067a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95067a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,302 ---- + -- C95067A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FORMAL PARAMETER OF MODE IN OR IN OUT CAN BE OF A + -- LIMITED TYPE, INCLUDING A COMPOSITE LIMITED TYPE. + + -- JWC 6/20/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95067A IS + + PACKAGE PKG IS + + TYPE ITYPE IS LIMITED PRIVATE; + + TASK T1 IS + + ENTRY LOOK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY LOOK_INOUT_I (X : IN OUT ITYPE; V : INTEGER; + M : STRING); + + ENTRY SET_I (X : IN OUT ITYPE; V : INTEGER); + + END T1; + + SUBTYPE INT_0_20 IS INTEGER RANGE 0 .. 20; + TYPE VRTYPE (C : INT_0_20 := 20) IS LIMITED PRIVATE; + + TASK T2 IS + + ENTRY LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY LOOK_INOUT_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING); + + ENTRY SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING); + + END T2; + + PRIVATE + + TYPE ITYPE IS NEW INTEGER RANGE 0 .. 99; + + TYPE VRTYPE (C : INT_0_20 := 20) IS + RECORD + I : INTEGER; + S : STRING (1 .. C); + END RECORD; + + END PKG; + + USE PKG; + + I1 : ITYPE; + + TYPE ATYPE IS ARRAY (1 .. 3) OF ITYPE; + + A1 : ATYPE; + + VR1 : VRTYPE; + + D : CONSTANT INT_0_20 := 10; + + TYPE RTYPE IS + RECORD + J : ITYPE; + R : VRTYPE (D); + END RECORD; + + R1 : RTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_I (X : IN ITYPE; V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_IN_I; + OR + ACCEPT LOOK_INOUT_I (X : IN OUT ITYPE; + V : INTEGER; + M : STRING) DO + IF INTEGER (X) /= V THEN + FAILED ("WRONG SCALAR VALUE - " & M); + END IF; + END LOOK_INOUT_I; + OR + ACCEPT SET_I (X : IN OUT ITYPE; V : INTEGER) DO + X := ITYPE (IDENT_INT (V)); + END SET_I; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT LOOK_IN_VR (X : IN VRTYPE; C : INTEGER; + I : INTEGER; S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_IN_VR; + OR + ACCEPT LOOK_INOUT_VR (X : IN OUT VRTYPE; + C : INTEGER; I : INTEGER; + S : STRING; + M : STRING) DO + IF (X.C /= C OR X.I /= I) OR ELSE + X.S /= S THEN + FAILED ("WRONG COMPOSITE VALUE - " & + M); + END IF; + END LOOK_INOUT_VR; + OR + ACCEPT SET_VR (X : IN OUT VRTYPE; C : INTEGER; + I : INTEGER; S : STRING) DO + X := (IDENT_INT(C), IDENT_INT(I), + IDENT_STR(S)); + END SET_VR; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + BEGIN + I1 := ITYPE (IDENT_INT(2)); + + FOR I IN A1'RANGE LOOP + A1 (I) := ITYPE (3 + IDENT_INT(I)); + END LOOP; + + VR1 := (IDENT_INT(5), IDENT_INT(4), IDENT_STR("01234")); + + R1.J := ITYPE (IDENT_INT(6)); + R1.R := (IDENT_INT(D), IDENT_INT(19), + IDENT_STR("ABCDEFGHIJ")); + END PKG; + + TASK T3 IS + ENTRY CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING); + + ENTRY CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING); + + ENTRY CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING); + + ENTRY CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; OS : STRING; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + + ENTRY CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING); + + ENTRY CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT CHECK_IN_I (X : IN ITYPE; V : INTEGER; M : STRING) DO + T1.LOOK_IN_I (X, V, M); + END CHECK_IN_I; + + ACCEPT CHECK_INOUT_I (X : IN OUT ITYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + T1.LOOK_INOUT_I (X, OV, M & " - A"); + T1.SET_I (X, NV); + T1.LOOK_INOUT_I (X, NV, M & " - B"); + T1.LOOK_IN_I (X, NV, M & " - C"); + END CHECK_INOUT_I; + + ACCEPT CHECK_IN_A (X : IN ATYPE; V : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_IN_I (X(I), V+I, M & " -" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_IN_A; + + ACCEPT CHECK_INOUT_A (X : IN OUT ATYPE; OV : INTEGER; + NV : INTEGER; M : STRING) DO + FOR I IN X'RANGE LOOP + T1.LOOK_INOUT_I (X(I), OV+I, M & " - A" & + INTEGER'IMAGE (I)); + T1.SET_I (X(I), NV+I); + T1.LOOK_INOUT_I (X(I), NV+I, M & " - B" & + INTEGER'IMAGE (I)); + T1.LOOK_IN_I (X(I), NV+I, M & " - C" & + INTEGER'IMAGE (I)); + END LOOP; + END CHECK_INOUT_A; + + ACCEPT CHECK_IN_VR (X : IN VRTYPE; C : INTEGER; I : INTEGER; + S : STRING; M : STRING) DO + T2.LOOK_IN_VR (X, C, I, S, M); + END CHECK_IN_VR; + + ACCEPT CHECK_INOUT_VR (X : IN OUT VRTYPE; + OC : INTEGER; OI : INTEGER; + OS : STRING; + NC : INTEGER; NI : INTEGER; + NS : STRING; + M : STRING) DO + T2.LOOK_INOUT_VR (X, OC, OI, OS, M & " - A"); + T2.SET_VR (X, NC, NI, NS); + T2.LOOK_INOUT_VR (X, NC, NI, NS, M & " - B"); + T2.LOOK_IN_VR (X, NC, NI, NS, M & " - C"); + END CHECK_INOUT_VR; + + ACCEPT CHECK_IN_R (X : IN RTYPE; J : INTEGER; C : INTEGER; + I : INTEGER; S : STRING; M : STRING) DO + T1.LOOK_IN_I (X.J, J, M & " - A"); + T2.LOOK_IN_VR (X.R, C, I, S, M & " - B"); + END CHECK_IN_R; + + ACCEPT CHECK_INOUT_R (X : IN OUT RTYPE; OJ : INTEGER; + OC : INTEGER; OI : INTEGER; OS : STRING; + NJ : INTEGER; + NC : INTEGER; NI : INTEGER; NS : STRING; + M : STRING) DO + T1.LOOK_INOUT_I (X.J, OJ, M & " - A"); + T2.LOOK_INOUT_VR (X.R, OC, OI, OS, M & " - B"); + T1.SET_I (X.J, NJ); + T2.SET_VR (X.R, NC, NI, NS); + T1.LOOK_INOUT_I (X.J, NJ, M & " - C"); + T2.LOOK_INOUT_VR (X.R, NC, NI, NS, M & " - D"); + T1.LOOK_IN_I (X.J, NJ, M & " - E"); + T2.LOOK_IN_VR (X.R, NC, NI, NS, M & " - F"); + END CHECK_INOUT_R; + END T3; + + BEGIN + TEST ("C95067A", "CHECK THAT LIMITED PRIVATE/COMPOSITE TYPES " & + "CAN BE USED AS IN OR IN OUT FORMAL PARAMETERS"); + + T3.CHECK_IN_I (I1, 2, "IN I"); + + T3.CHECK_INOUT_I (I1, 2, 5, "INOUT I"); + + T3.CHECK_IN_A (A1, 3, "IN A"); + + T3.CHECK_INOUT_A (A1, 3, 17, "INOUT A"); + + T3.CHECK_IN_VR (VR1, 5, 4, "01234", "IN VR"); + + T3.CHECK_INOUT_VR (VR1, 5, 4, "01234", 10, 11, "9876543210", + "INOUT VR"); + + T3.CHECK_IN_R (R1, 6, D, 19, "ABCDEFGHIJ", "IN R"); + + T3.CHECK_INOUT_R (R1, 6, D, 19, "ABCDEFGHIJ", 13, D, 5, + "ZYXWVUTSRQ", "INOUT R"); + + RESULT; + END C95067A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95071a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95071a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95071a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95071a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- C95071A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OBJECTS DESIGNATED BY IN PARAMETERS OF ACCESS TYPES CAN + -- BE USED AS THE TARGET OF AN ASSIGNMENT STATEMENT AND AS AN ACTUAL + -- PARAMETER OF ANY MODE. SUBTESTS ARE: + -- (A) INTEGER ACCESS TYPE. + -- (B) ARRAY ACCESS TYPE. + -- (C) RECORD ACCESS TYPE. + + -- JWC 7/11/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95071A IS + + BEGIN + + TEST ("C95071A", "CHECK THAT COMPONENTS OF ACCESS IN PARAMETERS " & + "MAY BE USED IN ASSIGNMENT CONTEXTS"); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE PTRINT IS ACCESS INTEGER; + PI : PTRINT; + + TASK TA IS + ENTRY EA (PI : IN PTRINT); + END TA; + + TASK BODY TA IS + BEGIN + ACCEPT EA (PI : IN PTRINT) DO + DECLARE + TASK TA1 IS + ENTRY EA1 (I : OUT INTEGER); + ENTRY EA2 (I : IN OUT INTEGER); + END TA1; + + TASK BODY TA1 IS + BEGIN + ACCEPT EA1 (I : OUT INTEGER) DO + I := 7; + END EA1; + + ACCEPT EA2 (I : IN OUT INTEGER) DO + I := I + 1; + END EA2; + END TA1; + + BEGIN + TA1.EA1 (PI.ALL); + TA1.EA2 (PI.ALL); + PI.ALL := PI.ALL + 1; + IF (PI.ALL /= 9) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "INTEGER ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EA; + END TA; + + BEGIN -- (A) + + PI := NEW INTEGER'(0); + TA.EA (PI); + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + TYPE TBL IS ARRAY (1..3) OF INTEGER; + TYPE PTRTBL IS ACCESS TBL; + PT : PTRTBL; + + TASK TB IS + ENTRY EB (PT : IN PTRTBL); + END TB; + + TASK BODY TB IS + BEGIN + ACCEPT EB (PT : IN PTRTBL) DO + DECLARE + TASK TB1 IS + ENTRY EB1 (T : OUT TBL); + ENTRY EB2 (T : IN OUT TBL); + ENTRY EB3 (I : OUT INTEGER); + ENTRY EB4 (I : IN OUT INTEGER); + END TB1; + + TASK BODY TB1 IS + BEGIN + ACCEPT EB1 (T : OUT TBL) DO + T := (1,2,3); + END EB1; + + ACCEPT EB2 (T : IN OUT TBL) DO + T(3) := T(3) - 1; + END EB2; + + ACCEPT EB3 (I : OUT INTEGER) DO + I := 7; + END EB3; + + ACCEPT EB4 (I : IN OUT INTEGER) DO + I := I + 1; + END EB4; + END TB1; + + BEGIN + TB1.EB1 (PT.ALL); -- (1,2,3) + TB1.EB2 (PT.ALL); -- (1,2,2) + TB1.EB3 (PT(2)); -- (1,7,2) + TB1.EB4 (PT(1)); -- (2,7,2) + PT(3) := PT(3) + 7; -- (2,7,9) + IF (PT.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "ARRAY ACCESS PARAMETER FAILED"); + END IF; + END; + END EB; + END TB; + + BEGIN -- (B) + + PT := NEW TBL'(0,0,0); + TB.EB (PT); + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + TYPE REC IS + RECORD + I1 : INTEGER; + I2 : INTEGER; + I3 : INTEGER; + END RECORD; + + TYPE PTRREC IS ACCESS REC; + PR : PTRREC; + + TASK TC IS + ENTRY EC (PR : IN PTRREC); + END TC; + + TASK BODY TC IS + BEGIN + ACCEPT EC (PR : IN PTRREC) DO + DECLARE + TASK TC1 IS + ENTRY EC1 (R : OUT REC); + ENTRY EC2 (R : IN OUT REC); + ENTRY EC3 (I : OUT INTEGER); + ENTRY EC4 (I : IN OUT INTEGER); + END TC1; + + TASK BODY TC1 IS + BEGIN + ACCEPT EC1 (R : OUT REC) DO + R := (1,2,3); + END EC1; + + ACCEPT EC2 (R : IN OUT REC) DO + R.I3 := R.I3 - 1; + END EC2; + + ACCEPT EC3 (I : OUT INTEGER) DO + I := 7; + END EC3; + + ACCEPT EC4 (I : IN OUT INTEGER) DO + I := I + 1; + END EC4; + END TC1; + + BEGIN + TC1.EC1 (PR.ALL); -- (1,2,3) + TC1.EC2 (PR.ALL); -- (1,2,2) + TC1.EC3 (PR.I2); -- (1,7,2) + TC1.EC4 (PR.I1); -- (2,7,2) + PR.I3 := PR.I3 + 7; -- (2,7,9) + IF (PR.ALL /= (2,7,9)) THEN + FAILED ("ASSIGNMENT TO COMPONENT OF " & + "RECORD ACCESS PARAMETER " & + "FAILED"); + END IF; + END; + END EC; + END TC; + + BEGIN -- (C) + + PR := NEW REC'(0,0,0); + TC.EC (PR); + + END; -- (C) + + --------------------------------------------- + + RESULT; + + END C95071A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95072a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95072a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95072a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95072a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,197 ---- + -- C95072A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SCALAR AND ACCESS PARAMETERS ARE COPIED FOR ALL THREE + -- PARAMETER MODES. + -- SUBTESTS ARE: + -- (A) SCALAR PARAMETERS TO ENTRIES. + -- (B) ACCESS PARAMETERS TO ENTRIES. + + -- JWC 7/22/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95072A IS + + BEGIN + TEST ("C95072A", "CHECK THAT SCALAR AND ACCESS PARAMETERS ARE " & + "COPIED"); + + -------------------------------------------------- + + DECLARE -- (A) + + I : INTEGER; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER); + END TA; + + TASK BODY TA IS + + TMP : INTEGER; + + BEGIN + + ACCEPT EA (EI : IN INTEGER; EO : OUT INTEGER; + EIO : IN OUT INTEGER) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := 10; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := EIO + 100; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + I := I + 1; + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO SCALAR ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A) + + I := 0; -- INITIALIZE I SO VARIOUS CASES CAN BE DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= 1 THEN + CASE I IS + WHEN 11 => + FAILED ("OUT ACTUAL SCALAR PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL SCALAR " & + "PARAMETERS CHANGED GLOBAL " & + "VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO GLOBAL " & + "VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ACCTYPE IS ACCESS INTEGER; + + I : ACCTYPE; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE); + END TB; + + TASK BODY TB IS + + TMP : ACCTYPE; + + BEGIN + + ACCEPT EB (EI : IN ACCTYPE; EO : OUT ACCTYPE; + EIO : IN OUT ACCTYPE) DO + + TMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := NEW INTEGER'(101); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS ACTUAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EO := NEW INTEGER'(1); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + TMP := EI; -- RESET TMP FOR NEXT CASE. + END IF; + + EIO := NEW INTEGER'(10); + IF EI /= TMP THEN + FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B) + + I := NEW INTEGER'(100); + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I.ALL /= 101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B) + + -------------------------------------------------- + + RESULT; + END C95072A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95072b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95072b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95072b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95072b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,278 ---- + -- C95072B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PRIVATE TYPES IMPLEMENTED AS SCALAR OR ACCESS TYPES ARE + -- PASSED BY COPY FOR ALL MODES. + -- SUBTESTS ARE: + -- (A) PRIVATE SCALAR PARAMETERS TO ENTRIES. + -- (B) PRIVATE ACCESS PARAMETERS TO ENTRIES. + + -- JWC 7/22/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95072B IS + + BEGIN + TEST("C95072B", "CHECK THAT PRIVATE SCALAR AND ACCESS " & + "PARAMETERS ARE COPIED"); + + --------------------------------------------------- + + DECLARE -- (A) + + PACKAGE SCALAR_PKG IS + + TYPE T IS PRIVATE; + C0 : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T; + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER; + + PRIVATE + + TYPE T IS NEW INTEGER; + C0 : CONSTANT T := 0; + C1 : CONSTANT T := 1; + C10 : CONSTANT T := 10; + C100 : CONSTANT T := 100; + + END SCALAR_PKG; + + PACKAGE BODY SCALAR_PKG IS + + FUNCTION "+" (OLD : IN T; INCREMENT : IN T) RETURN T IS + BEGIN + RETURN T (INTEGER(OLD) + INTEGER(INCREMENT)); + END "+"; + + FUNCTION CONVERT (OLD_PRIVATE : IN T) RETURN INTEGER IS + BEGIN + RETURN INTEGER (OLD_PRIVATE); + END CONVERT; + + END SCALAR_PKG; + + USE SCALAR_PKG; + + BEGIN -- (A) + + DECLARE -- (A1) + + I : T; + E : EXCEPTION; + + TASK TA IS + ENTRY EA (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TA; + + TASK BODY TA IS + + TEMP : T; + + BEGIN + + ACCEPT EA (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + EO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := EIO + C100; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + I := I + C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(SCALAR) ACTUAL PARAMETER " & + "CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EA; + + EXCEPTION + WHEN OTHERS => NULL; + END TA; + + BEGIN -- (A1) + + I := C0; -- INITIALIZE I SO VARIOUS CASES CAN BE + -- DETECTED. + TA.EA (I, I, I); + FAILED ("EXCEPTION NOT RAISED - A"); + + EXCEPTION + WHEN E => + IF I /= C1 THEN + CASE CONVERT (I) IS + WHEN 11 => + FAILED ("OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 101 => + FAILED ("IN OUT ACTUAL PRIVATE " & + "(SCALAR) PARAMETER " & + "CHANGED GLOBAL VALUE"); + WHEN 111 => + FAILED ("OUT AND IN OUT ACTUAL " & + "PRIVATE (SCALAR) " & + "PARAMETER CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - A"); + END; -- (A1) + + END; -- (A) + + --------------------------------------------------- + + DECLARE -- (B) + + PACKAGE ACCESS_PKG IS + + TYPE T IS PRIVATE; + C_NULL : CONSTANT T; + C1 : CONSTANT T; + C10 : CONSTANT T; + C100 : CONSTANT T; + C101 : CONSTANT T; + + PRIVATE + + TYPE T IS ACCESS INTEGER; + C_NULL : CONSTANT T := NULL; + C1 : CONSTANT T := NEW INTEGER'(1); + C10 : CONSTANT T := NEW INTEGER'(10); + C100 : CONSTANT T := NEW INTEGER'(100); + C101 : CONSTANT T := NEW INTEGER'(101); + + END ACCESS_PKG; + + USE ACCESS_PKG; + + BEGIN -- (B) + + DECLARE -- (B1) + + I : T; + E : EXCEPTION; + + TASK TB IS + ENTRY EB (EI : IN T; EO : OUT T; + EIO : IN OUT T); + END TB; + + TASK BODY TB IS + + TEMP : T; + + BEGIN + + ACCEPT EB (EI : IN T; EO : OUT T; + EIO : IN OUT T) DO + + TEMP := EI; -- SAVE VALUE OF EI AT ACCEPT. + + I := C101; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) ACTUAL VARIABLE " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EO := C1; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + TEMP := EI; -- RESET TEMP FOR NEXT CASE. + END IF; + + EIO := C10; + IF EI /= TEMP THEN + FAILED ("ASSIGNMENT TO PRIVATE " & + "(ACCESS) IN OUT PARAMETER " & + "CHANGES THE VALUE OF INPUT " & + "PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION + -- HANDLING. + END EB; + + EXCEPTION + WHEN OTHERS => NULL; + END TB; + + BEGIN -- (B1) + + I := C100; + TB.EB (I, I, I); + FAILED ("EXCEPTION NOT RAISED - B"); + + EXCEPTION + WHEN E => + IF I /= C101 THEN + FAILED ("OUT OR IN OUT ACTUAL ENTRY " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - B"); + END; -- (B1) + + END; -- (B) + + --------------------------------------------------- + + RESULT; + END C95072B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95073a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95073a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95073a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95073a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- C95073A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALIASING IS PERMITTED FOR PARAMETERS OF COMPOSITE TYPES, + -- E.G., THAT A MATRIX ADDITION PROCEDURE CAN BE CALLED WITH THREE + -- IDENTICAL ARGUMENTS. + + -- JWC 7/29/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95073A IS + + TYPE MATRIX IS ARRAY (1..3, 1..3) OF INTEGER; + + A : MATRIX := ((1,2,3), (4,5,6), (7,8,9)); + + TASK T IS + ENTRY MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX); + END T; + + TASK BODY T IS + BEGIN + ACCEPT MAT_ADD (X,Y : IN MATRIX; SUM : OUT MATRIX) DO + FOR I IN 1..3 LOOP + FOR J IN 1..3 LOOP + SUM (I,J) := X (I,J) + Y (I,J); + END LOOP; + END LOOP; + END MAT_ADD; + END T; + + BEGIN + + TEST ("C95073A", "CHECK THAT ALIASING IS PERMITTED FOR " & + "PARAMETERS OF COMPOSITE TYPES"); + + T.MAT_ADD (A, A, A); + + IF A /= ((2,4,6), (8,10,12), (14,16,18)) THEN + FAILED ("THE RESULT OF THE MATRIX ADDITION IS INCORRECT"); + END IF; + + RESULT; + + END C95073A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95074c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95074c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95074c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95074c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C95074C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT 'FIRST, 'LAST, 'LENGTH, AND 'RANGE, CAN BE APPLIED TO AN + -- OUT PARAMETER OR OUT PARAMETER SUBCOMPONENT THAT DOES NOT HAVE AN + -- ACCESS TYPE. + + -- JWC 6/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95074C IS + + BEGIN + + TEST ("C95074C", "CHECK THAT ATTRIBUTES MAY BE APPLIED TO " & + "NON-ACCESS FORMAL OUT PARAMETERS"); + + DECLARE + + TYPE ARR IS ARRAY (1 .. 10) OF NATURAL; + + TYPE REC IS RECORD + A : ARR; + END RECORD; + + A1 : ARR; + R1 : REC; + + TASK T1 IS + ENTRY E (A2 : OUT ARR; R2 : OUT REC); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E (A2 : OUT ARR; R2 : OUT REC) DO + + IF A2'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR A2'FIRST"); + END IF; + + IF A2'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LAST"); + END IF; + + IF A2'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR A2'LENGTH"); + END IF; + + IF (1 NOT IN A2'RANGE) OR + (10 NOT IN A2'RANGE) OR + (0 IN A2'RANGE) OR + (11 IN A2'RANGE) THEN + FAILED ("WRONG VALUE FOR A2'RANGE"); + END IF; + + IF R2.A'FIRST /= 1 THEN + FAILED ("WRONG VALUE FOR R2.A'FIRST"); + END IF; + + IF R2.A'LAST /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LAST"); + END IF; + + IF R2.A'LENGTH /= 10 THEN + FAILED ("WRONG VALUE FOR R2.A'LENGTH"); + END IF; + + IF (1 NOT IN R2.A'RANGE) OR + (10 NOT IN R2.A'RANGE) OR + (0 IN R2.A'RANGE) OR + (11 IN R2.A'RANGE) THEN + FAILED ("WRONG VALUE FOR R2.A'RANGE"); + END IF; + END E; + END T1; + + BEGIN + T1.E (A1,R1); + END; + + RESULT; + END C95074C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95076a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95076a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95076a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95076a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C95076A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ACCEPT STATEMENT WITH AND WITHOUT A RETURN + -- STATEMENT RETURNS CORRECTLY. + + -- GLH 7/11/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C95076A IS + + I : INTEGER; + + TASK T1 IS + ENTRY E1 (N : IN OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (N : IN OUT INTEGER) DO + IF (N = 5) THEN + N := N + 5; + ELSE + N := 0; + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (N : IN OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (N : IN OUT INTEGER) DO + IF (N = 10) THEN + N := N + 5; + RETURN; + END IF; + N := 0; + END E2; + END T2; + + BEGIN + + TEST ("C95076A", "CHECK THAT AN ACCEPT STATEMENT WITH AND " & + "WITHOUT A RETURN STATEMENT RETURNS CORRECTLY"); + + I := 5; + T1.E1 (I); + IF (I /= 10) THEN + FAILED ("INCORRECT RENDEVOUS WITHOUT A RETURN"); + END IF; + + I := 10; + T2.E2 (I); + IF (I /= 15) THEN + FAILED ("INCORRECT RENDEVOUS WITH A RETURN"); + END IF; + + RESULT; + + END C95076A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95078a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95078a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95078a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95078a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- C95078A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXCEPTION RAISED DURING THE EXECUTION OF AN ACCEPT + -- STATEMENT CAN BE HANDLED WITHIN THE ACCEPT BODY. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- DHH 03/21/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE C95078A IS + + BEGIN + + TEST("C95078A", "CHECK THAT AN EXCEPTION RAISED DURING THE " & + "EXECUTION OF AN ACCEPT STATEMENT CAN BE " & + "HANDLED WITHIN THE ACCEPT BODY"); + + DECLARE + O,PT,QT,R,S,TP,B,C,D :INTEGER := 0; + TASK TYPE PROG_ERR IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END PROG_ERR; + + TASK T IS + ENTRY START(M,N,A : IN OUT INTEGER); + ENTRY STOP; + END T; + + TYPE REC IS + RECORD + B : PROG_ERR; + END RECORD; + + TYPE ACC IS ACCESS PROG_ERR; + + SUBTYPE X IS INTEGER RANGE 1 .. 10; + + PACKAGE P IS + OBJ : REC; + END P; + + TASK BODY PROG_ERR IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK TYPE"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END PROG_ERR; + + TASK BODY T IS + FAULT : X; + BEGIN + ACCEPT START(M,N,A : IN OUT INTEGER) DO + BEGIN + M := IDENT_INT(1); + FAULT := IDENT_INT(11); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + BEGIN + N := IDENT_INT(1); + FAULT := IDENT_INT(5); + FAULT := FAULT/IDENT_INT(0); + FAULT := IDENT_INT(FAULT); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED ERROR RAISED - " & + "CONSTRAINT - TASK"); + END; -- EXCEPTION + A := IDENT_INT(1); + END START; + + ACCEPT STOP; + END T; + + PACKAGE BODY P IS + BEGIN + OBJ.B.START(O,PT,B); + OBJ.B.STOP; + + IF O /= IDENT_INT(1) OR PT /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - TASK TYPE OBJECT"); + END IF; + + IF B /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK TYPE " & + "OBJECT"); + END IF; + END P; + + PACKAGE Q IS + OBJ : ACC; + END Q; + + PACKAGE BODY Q IS + BEGIN + OBJ := NEW PROG_ERR; + OBJ.START(QT,R,C); + OBJ.STOP; + + IF QT /= IDENT_INT(1) OR R /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED " & + "PROPERLY - ACCESS TASK TYPE"); + END IF; + + IF C /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - ACCESS TASK " & + "TYPE"); + END IF; + END; + + BEGIN + T.START(S,TP,D); + T.STOP; + + IF S /= IDENT_INT(1) OR TP /= IDENT_INT(1) THEN + FAILED("EXCEPTION HANDLER NEVER ENTERED PROPERLY " & + "- TASK"); + END IF; + + IF D /= IDENT_INT(1) THEN + FAILED("TASK NOT EXITED PROPERLY - TASK"); + END IF; + END; -- DECLARE + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION NOT HANDLED INSIDE ACCEPT BODY"); + RESULT; + END C95078A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95080b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95080b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95080b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95080b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C95080B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PARAMETERLESS ENTRIES CAN BE CALLED WITH THE APPROPRIATE + -- NOTATION. + + -- JWC 7/15/85 + -- JRK 8/21/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95080B IS + + I : INTEGER := 1; + + TASK T IS + ENTRY E; + ENTRY EF (1..3); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E DO + I := 15; + END E; + ACCEPT EF (2) DO + I := 20; + END EF; + END T; + + BEGIN + + TEST ("C95080B", "CHECK THAT PARAMETERLESS ENTRIES CAN BE " & + "CALLED"); + + T.E; + IF I /= 15 THEN + FAILED ("PARAMETERLESS ENTRY CALL YIELDS INCORRECT " & + "RESULT"); + END IF; + + I := 0; + T.EF (2); + IF I /= 20 THEN + FAILED ("PARAMETERLESS ENTRY FAMILY CALL YIELDS " & + "INCORRECT RESULT"); + END IF; + + RESULT; + + END C95080B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95082g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95082g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95082g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95082g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- C95082G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR CALLS TO ENTRIES HAVING AT LEAST ONE DEFAULT + -- PARAMETER, THE CORRECT ASSOCIATION IS MADE BETWEEN ACTUAL AND + -- FORMAL PARAMETERS. + + -- JWC 7/17/85 + + WITH REPORT;USE REPORT; + PROCEDURE C95082G IS + + Y1,Y2,Y3 : INTEGER := 0; + + TASK T IS + ENTRY E (I1: INTEGER; I2: INTEGER := 2; I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1: INTEGER; I2: INTEGER := 2; + I3: INTEGER := 3; + O1,O2,O3: OUT INTEGER) DO + O1 := I1; + O2 := I2; + O3 := I3; + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + + BEGIN + + TEST ("C95082G", "CHECK ASSOCIATIONS BETWEEN ACTUAL AND FORMAL " & + "PARAMETERS (HAVING DEFAULT VALUES)"); + + T.E (I1=>11, I2=>12, I3=>13, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 11) OR (Y2 /= 12) OR (Y3 /= 13) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 1"); + END IF; + + T.E (I1=>21, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 21) OR (Y2 /= 2) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 2"); + END IF; + + T.E (O1=>Y1, O3=>Y3, I1=>31, I3=>33, O2=>Y2); + IF (Y1 /= 31) OR (Y2 /= 2) OR (Y3 /= 33) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 3"); + END IF; + + T.E (41, 42, O1=>Y1, O2=>Y2, O3=>Y3); + IF (Y1 /= 41) OR (Y2 /= 42) OR (Y3 /= 3) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 4"); + END IF; + + T.E (51, O3=>Y3, O1=>Y1, O2=>Y2, I3=>53); + IF (Y1 /= 51) OR (Y2 /= 2) OR (Y3 /= 53) THEN + FAILED ("INCORRECT PARAMETER ASSOCIATION - 5"); + END IF; + + RESULT; + + END C95082G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,279 ---- + -- C95085A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR OUT OF RANGE SCALAR + -- ARGUMENTS. SUBTESTS ARE: + -- (A) STATIC IN ARGUMENT. + -- (B) DYNAMIC IN ARGUMENT. + -- (C) IN OUT, OUT OF RANGE ON CALL. + -- (D) OUT, OUT OF RANGE ON RETURN. + -- (E) IN OUT, OUT OF RANGE ON RETURN. + + -- GLH 7/15/85 + -- JRK 8/23/85 + -- JWC 11/15/85 ADDED VARIABLE "CALLED" TO ENSURE THAT THE ENTRY + -- CALL WAS MADE FOR THOSE CASES THAT ARE APPLICABLE. + + WITH REPORT; USE REPORT; + PROCEDURE C95085A IS + + SUBTYPE DIGIT IS INTEGER RANGE 0..9; + + D : DIGIT; + I : INTEGER; + M1 : CONSTANT INTEGER := IDENT_INT (-1); + COUNT : INTEGER := 0; + CALLED : BOOLEAN; + + SUBTYPE SI IS INTEGER RANGE M1 .. 10; + + TASK T1 IS + ENTRY E1 (PIN : IN DIGIT; WHO : STRING); -- (A), (B). + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (PIN : IN DIGIT; + WHO : STRING) DO -- (A), (B). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E1 " & WHO); + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E1"); + END; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (PINOUT : IN OUT DIGIT; WHO : STRING); -- (C). + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E2 (PINOUT : IN OUT DIGIT; + WHO : STRING) DO -- (C). + FAILED ("EXCEPTION NOT RAISED BEFORE " & + "CALL - E2 " & WHO); + END E2; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E2"); + END; + END LOOP; + END T2; + + TASK T3 IS + ENTRY E3 (POUT : OUT SI; WHO : STRING); -- (D). + END T3; + + TASK BODY T3 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E3 (POUT : OUT SI; + WHO : STRING) DO -- (D). + CALLED := TRUE; + IF WHO = "10" THEN + POUT := IDENT_INT (10); -- 10 IS NOT + -- A DIGIT. + ELSE + POUT := -1; + END IF; + END E3; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E3"); + END; + END LOOP; + END T3; + + TASK T4 IS + ENTRY E4 (PINOUT : IN OUT INTEGER; WHO : STRING); -- (E). + END T4; + + TASK BODY T4 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E4 (PINOUT : IN OUT INTEGER; + WHO : STRING) DO -- (E). + CALLED := TRUE; + IF WHO = "10" THEN + PINOUT := 10; -- 10 IS NOT A DIGIT. + ELSE + PINOUT := IDENT_INT (-1); + END IF; + END E4; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN E4"); + END; + END LOOP; + END T4; + + BEGIN + + TEST ("C95085A", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "FOR OUT OF RANGE SCALAR ARGUMENTS"); + + BEGIN -- (A) + T1.E1 (10, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (10)"); + END; -- (A) + + BEGIN -- (B) + T1.E1 (IDENT_INT (-1), "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E1 (" & + "IDENT_INT (-1))"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E1 (" & + "IDENT_INT (-1))"); + END; -- (B) + + BEGIN -- (C) + I := IDENT_INT (10); + T2.E2 (I, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (10)"); + END; -- (C) + + BEGIN -- (C1) + I := IDENT_INT (-1); + T2.E2 (I, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR E2 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E2 (-1)"); + END; -- (C1) + + BEGIN -- (D) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (10)"); + END; -- (D) + + BEGIN -- (D1) + CALLED := FALSE; + D := IDENT_INT (1); + T3.E3 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E3 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E3 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E3 (-1)"); + END; -- (D1) + + BEGIN -- (E) + CALLED := FALSE; + D := 9; + T4.E4 (D, "10"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (10)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (10)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (10)"); + END; -- (E) + + BEGIN -- (E1) + CALLED := FALSE; + D := 0; + T4.E4 (D, "-1"); + FAILED ("CONSTRAINT_ERROR NOT RAISED ON RETURN FROM " & + "E4 (-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COUNT := COUNT + 1; + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL " & + "E4 (-1)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR E4 (-1)"); + END; -- (E1) + + IF COUNT /= 8 THEN + FAILED ("INCORRECT NUMBER OF CONSTRAINT_ERRORS RAISED"); + END IF; + + RESULT; + + END C95085A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C95085B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER APPROPRIATE CIRCUMSTANCES + -- WITH RESPECT TO PARAMETERS OF RECORD TYPES IN ENTRY CALLS. SUBTESTS + -- INVOLVE ACTUAL RECORD PARAMETERS WHOSE CONSTRAINT VALUES ARE NOT + -- EQUAL TO THE CONSTRAINTS ON THEIR CORRESPONDING FORMAL PARAMETERS: + -- (A) IN PARAMETER, STATIC AGGREGATE. + -- (B) IN PARAMETER, DYNAMIC AGGREGATE. + -- (C) IN PARAMETER, VARIABLE. + -- (D) IN OUT PARAMETER, EXCEPTION RAISED ON CALL. + -- (E) OUT PARAMETER, EXCEPTION RAISED ON CALL. + + -- JWC 10/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085B IS + + SUBTYPE INT IS INTEGER RANGE 0..10; + + TYPE REC (N : INT := 0) IS + RECORD + A : STRING (1..N); + END RECORD; + + SUBTYPE SREC IS REC(N=>3); + + BEGIN + + TEST ("C95085B", "CHECK RAISING OF CONSTRAINT_ERROR FOR " & + "PARAMETERS OF RECORD TYPES"); + + DECLARE + + TASK TSK1 IS + ENTRY E (R : IN SREC); + END TSK1; + + TASK BODY TSK1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E (R : IN SREC) DO + FAILED ("EXCEPTION NOT RAISED ON " & + "CALL TO TSK1"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK1"); + END; + END LOOP; + END TSK1; + + BEGIN + + BEGIN -- (A) + TSK1.E ((2,"AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (A)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (A)"); + END; -- (A) + + BEGIN -- (B) + TSK1.E ((IDENT_INT(2), "AA")); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (B)"); + END; -- (B) + + DECLARE -- (C) + R : REC := (IDENT_INT(2), "AA"); + BEGIN -- (C) + TSK1.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (C)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (C)"); + END; -- (C) + + END; + + DECLARE -- (D) + + R : REC := (IDENT_INT(2), "AA"); + + TASK TSK2 IS + ENTRY E (R : IN OUT SREC); + END TSK2; + + TASK BODY TSK2 IS + BEGIN + SELECT + ACCEPT E (R : IN OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK2"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK2"); + END TSK2; + + BEGIN -- (D) + TSK2.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (D)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (D)"); + END; -- (D) + + DECLARE -- (E) + + R : REC; + + TASK TSK3 IS + ENTRY E (R : OUT SREC); + END TSK3; + + TASK BODY TSK3 IS + BEGIN + SELECT + ACCEPT E (R : OUT SREC) DO + FAILED ("EXCEPTION NOT RAISED ON CALL TO " & + "TSK3"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TSK3"); + END TSK3; + + BEGIN -- (E) + TSK3.E (R); + FAILED ("EXCEPTION NOT RAISED IN SUBTEST (E)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN SUBTEST (E)"); + END; -- (E) + + RESULT; + + END C95085B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- C95085C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE + -- APPROPRIATE CIRCUMSTANCES FOR ARRAY PARAMETERS IN ENTRY CALLS, + -- NAMELY WHEN THE ACTUAL BOUNDS DON'T MATCH THE FORMAL BOUNDS + -- (BEFORE THE CALL FOR ALL MODES). + -- SUBTESTS ARE: + -- (A) IN MODE, ONE DIMENSION, STATIC AGGREGATE. + -- (B) IN MODE, TWO DIMENSIONS, DYNAMIC AGGREGATE. + -- (C) IN MODE, TWO DIMENSIONS, DYNAMIC VARIABLE. + -- (D) IN OUT MODE, THREE DIMENSIONS, STATIC VARIABLE. + -- (E) OUT MODE, ONE DIMENSION, DYNAMIC VARIABLE. + -- (F) IN OUT MODE, NULL STRING AGGREGATE. + -- (G) IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE (OK CASE). + -- IN OUT MODE, TWO DIMENSIONS, NULL AGGREGATE. + + -- JWC 10/28/85 + -- PWN 11/30/94 REMOVED TEST ILLEGAL IN ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE C95085C IS + + BEGIN + TEST ("C95085C", "CHECK THAT CONSTRAINT_ERROR IS RAISED WHEN " & + "ACTUAL ARRAY BOUNDS DON'T MATCH FORMAL BOUNDS"); + + -------------------------------------------------- + + DECLARE -- (A) + SUBTYPE ST IS STRING (1..3); + + TASK TSK IS + ENTRY E (A : ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (A)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END TSK; + + BEGIN -- (A) + + TSK.E ("AB"); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (A)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + SUBTYPE S IS INTEGER RANGE 1..3; + TYPE T IS ARRAY (S,S) OF INTEGER; + + TASK TSK IS + ENTRY E (A : T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : T) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (B)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END TSK; + + BEGIN -- (B) + + TSK.E ((1..3 => (1..IDENT_INT(2) => 0))); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (B)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF INTEGER; + SUBTYPE ST IS T (1..3,1..3); + V : T (1..IDENT_INT(2), 1..3) := + (1..IDENT_INT(2) => (1..3 => 0)); + + TASK TSK IS + ENTRY E (A :ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A :ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (C)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END TSK; + + BEGIN -- (C) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (C)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>, S RANGE <>) OF + INTEGER; + SUBTYPE ST IS T (1..3, 1..3, 1..3); + V : T (1..3, 1..2, 1..3) := + (1..3 => (1..2 => (1..3 => 0))); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + FAILED ("EXCEPTION NOT RAISED ON CALL - (D)"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END TSK; + + BEGIN -- (D) + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL - (D)"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + + DECLARE -- (G) + + SUBTYPE S IS INTEGER RANGE 1..5; + TYPE T IS ARRAY (S RANGE <>, S RANGE <>) OF CHARACTER; + SUBTYPE ST IS T (2..1, 2..1); + V : T (2..1, 2..1) := (2..1 => (2..1 => ' ')); + + TASK TSK IS + ENTRY E (A : IN OUT ST); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (A : IN OUT ST) DO + COMMENT ("OK CASE CALLED CORRECTLY"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (G)"); + END TSK; + + BEGIN -- (G) + + TSK.E (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON OK CASE - (G)"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON OK CASE - (G)"); + END; -- (G) + + -------------------------------------------------- + + + RESULT; + END C95085C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95085D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (A) BEFORE CALL, IN MODE, STATIC PRIVATE DISCRIMINANT. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085D IS + + BEGIN + TEST ("C95085D", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1) IS PRIVATE; + TYPE AR IS ARRAY (E1 .. E3) OF INTEGER; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + A : AR; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (E3); + V : A (E2) := NEW T (E2); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; + END C95085D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C95085E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (B) BEFORE CALL, IN MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085E IS + + BEGIN + TEST ("C95085E", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE T IS ARRAY (BOOLEAN RANGE <>, CHARACTER RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE A1 IS A (BOOLEAN, 'A'..'C'); + V : A := NEW T (BOOLEAN, 'A'..IDENT_CHAR('B')); + + TASK TSK IS + ENTRY E (X : A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C95085F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY + -- WHEN THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (C) BEFORE CALL, IN OUT MODE, STATIC ONE DIMENSIONAL BOUNDS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085F IS + + BEGIN + TEST ("C95085F", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + TYPE A IS ACCESS STRING; + SUBTYPE A1 IS A (1..3); + V : A (2..4) := NEW STRING (2..4); + + TASK TSK IS + ENTRY E (X : IN OUT A1); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A1) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C95085G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (D) BEFORE CALL, IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085G IS + + BEGIN + TEST ("C95085G", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + SUBTYPE INT IS INTEGER RANGE 0..10; + TYPE T (C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INT := 0) IS + RECORD + J : INTEGER; + CASE B IS + WHEN FALSE => + K : INTEGER; + WHEN TRUE => + S : STRING (1 .. I); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('Z', TRUE, 5); + V : A := NEW T ('Z', IDENT_BOOL(FALSE), 5); + + TASK TSK IS + ENTRY E (X : IN OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT SA) DO + FAILED ("EXCEPTION NOT RAISED ON CALL"); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED BEFORE CALL"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085h.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- C95085H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (E) AFTER RETURN, IN OUT MODE, STATIC LIMITED PRIVATE + -- DISCRIMINANTS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085H IS + + BEGIN + TEST ("C95085H", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..10; + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'C'; + TYPE T (I : INT := 0; C : CHAR := 'A') IS + LIMITED PRIVATE; + PRIVATE + TYPE T (I : INT := 0; C : CHAR := 'A') IS + RECORD + J : INTEGER; + CASE C IS + WHEN 'A' => + K : INTEGER; + WHEN 'B' => + S : STRING (1..I); + WHEN OTHERS => + NULL; + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + + V : A (2,'B') := NEW T (2,'B'); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + X := NEW T (2,'A'); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085i.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C95085I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (F) AFTER RETURN, IN OUT MODE, DYNAMIC THREE DIMENSIONAL + -- BOUNDS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085I IS + + BEGIN + TEST ("C95085I", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE E IS (E1, E2, E3); + + TYPE T IS ARRAY (CHARACTER RANGE <>, + E RANGE <>, + BOOLEAN RANGE <> + ) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A ('A'..'Z', E1..E2, BOOLEAN) := + NEW T ('A'..'Z', E1..E2, BOOLEAN); + + TASK TSK IS + ENTRY E (X : IN OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT A) DO + CALLED := TRUE; + IF EQUAL (3,3) THEN + X := NEW T ('A'..'Z', E2..E3, BOOLEAN); + END IF; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085j.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C95085J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (G) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, STATIC ONE + -- DIMENSIONAL BOUNDS. + + -- JWC 10/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085J IS + + BEGIN + TEST ("C95085J", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE A IS ACCESS STRING; + + V : A (1..3) := NEW STRING (1..3); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW STRING (2..3); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085k.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95085K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (H) AFTER RETURN, OUT MODE, UNCONSTRAINED FORMAL, DYNAMIC + -- RECORD DISCRIMINANT. + + -- JWC 10/24/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085K IS + + BEGIN + TEST ("C95085K", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE ARR IS ARRAY (BOOLEAN RANGE <>) OF INTEGER; + TYPE T (B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + A : ARR (FALSE..B); + END RECORD; + + TYPE A IS ACCESS T; + + V : A (IDENT_BOOL(FALSE)) := NEW T (IDENT_BOOL(FALSE)); + + TASK TSK IS + ENTRY E (X : OUT A); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT A) DO + CALLED := TRUE; + X := NEW T (TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085l.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- C95085L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN + -- THE ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (I) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, STATIC + -- PRIVATE DISCRIMINANTS. + + -- JWC 10/24/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085L IS + + BEGIN + TEST ("C95085L", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE PKG IS + TYPE E IS (E1, E2, E3); + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (E RANGE <>) OF INTEGER; + TYPE T (D : E := E1; B : BOOLEAN := FALSE) IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR (E1 .. D); + END CASE; + END RECORD; + END PKG; + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2, TRUE); + V : A (E2, FALSE) := NEW T (E2, FALSE); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (E2, TRUE); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + ------------------------------------------------ + + RESULT; + END C95085L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085m.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- C95085M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED UNDER THE APPROPRIATE + -- CIRCUMSTANCES FOR ACCESS PARAMETERS IN ENTRY CALLS, NAMELY WHEN THE + -- ACTUAL INDEX BOUNDS OR DISCRIMINANTS ARE NOT EQUAL + -- TO THE FORMAL CONSTRAINTS BEFORE THE CALL (FOR IN AND IN OUT + -- MODES), AND WHEN THE FORMAL CONSTRAINTS ARE NOT EQUAL TO THE + -- ACTUAL CONSTRAINTS UPON RETURN (FOR IN OUT AND OUT MODES). + + -- (J) AFTER RETURN, OUT MODE, CONSTRAINED FORMAL, DYNAMIC TWO + -- DIMENSIONAL BOUNDS. + + -- JWC 10/24/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95085M IS + + BEGIN + TEST ("C95085M", "CHECK THAT CONSTRAINT_ERROR IS RAISED " & + "APPROPRIATELY FOR ACCESS PARAMETERS"); + + -------------------------------------------------- + + DECLARE + + CALLED : BOOLEAN := FALSE; + + TYPE T IS ARRAY (INTEGER RANGE <>, + CHARACTER RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + + V : A (1..10, 'A'..'Z') := NEW T (1..10, 'A'..'Z'); + + Y : CONSTANT CHARACTER := IDENT_CHAR('Y'); + SUBTYPE SA IS A (1..10, 'A'..Y); + + TASK TSK IS + ENTRY E (X : OUT SA); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (1..10, 'A'..IDENT_CHAR('Y')); + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + BEGIN + + TSK.E (V); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + -------------------------------------------------- + + RESULT; + END C95085M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085n.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C95085N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE + -- CASE OF A PRIVATE TYPE IMPLEMENTED AS A SCALAR TYPE WHERE THE VALUE + -- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL + -- PARAMETER. + + -- JWC 10/29/85 + -- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE + -- CALL. + + WITH REPORT; USE REPORT; + PROCEDURE C95085N IS + + BEGIN + TEST ("C95085N", "CHECK THAT PRIVATE TYPE (SCALAR) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS NEW INTEGER; + DC : CONSTANT T := -1; + END P; + + TASK TSK IS + ENTRY E (X : OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T RANGE 0..1 := 0; + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; + END C95085N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95085o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95085o.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C95085O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED AFTER AN ENTRY CALL FOR THE + -- CASE OF A PRIVATE TYPE IMPLEMENTED AS AN ACCESS TYPE WHERE THE VALUE + -- OF THE FORMAL PARAMETER DOES NOT BELONG TO THE SUBTYPE OF THE ACTUAL + -- PARAMETER. + + -- JWC 10/30/85 + -- JRK 1/15/86 ENSURE THAT EXCEPTION RAISED AFTER CALL, NOT BEFORE + -- CALL. + + WITH REPORT; USE REPORT; + PROCEDURE C95085O IS + + BEGIN + + TEST ("C95085O", "CHECK THAT PRIVATE TYPE (ACCESS) RAISES " & + "CONSTRAINT_ERROR AFTER CALL WHEN FORMAL " & + "PARAMETER VALUE IS NOT IN ACTUAL'S SUBTYPE"); + + DECLARE + + CALLED : BOOLEAN := FALSE; + + PACKAGE P IS + TYPE T IS PRIVATE; + DC : CONSTANT T; + + GENERIC PACKAGE PP IS + END PP; + PRIVATE + TYPE T IS ACCESS STRING; + DC : CONSTANT T := NEW STRING'("AAA"); + END P; + + TASK TSK IS + ENTRY E (X : IN OUT P.T); + END TSK; + + TASK BODY TSK IS + BEGIN + SELECT + ACCEPT E (X : IN OUT P.T) DO + CALLED := TRUE; + X := P.DC; + END E; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK BODY"); + END TSK; + + GENERIC + Y : IN OUT P.T; + PACKAGE CALL IS + END CALL; + + PACKAGE BODY CALL IS + BEGIN + TSK.E (Y); + FAILED ("EXCEPTION NOT RAISED AFTER RETURN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END CALL; + + PACKAGE BODY P IS + Z : T (1..5) := NEW STRING'("CCCCC"); + PACKAGE BODY PP IS + PACKAGE CALL_Q IS NEW CALL (Z); + END PP; + END P; + + BEGIN + + BEGIN + DECLARE + PACKAGE CALL_Q_NOW IS NEW P.PP; -- START HERE. + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER INVOKED"); + END; + + END; + + RESULT; + END C95085O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C95086A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED AT THE TIME OF CALL WHEN + -- THE VALUE OF AN ACTUAL OUT SCALAR PARAMETER DOES NOT SATISFY THE + -- RANGE CONSTRAINTS OF THE FORMAL PARAMETER. + + -- GLH 7/16/85 + -- JRK 8/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95086A IS + + SUBTYPE SUBINT1 IS INTEGER RANGE -10..10; + SUBTYPE SUBINT2 IS INTEGER RANGE -20..20; + + I10 : SUBINT1 := 10; + I20 : SUBINT2 := 20; + + TASK T1 IS + ENTRY E1 (I : OUT SUBINT1); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + BEGIN + SELECT + ACCEPT E1 (I : OUT SUBINT1) DO + I := SUBINT1'FIRST; + END E1; + OR + TERMINATE; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN ACCEPT E1"); + END; + END LOOP; + END T1; + + BEGIN + + TEST ("C95086A", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AT THE TIME OF CALL WHEN THE VALUE OF AN " & + "ACTUAL OUT SCALAR PARAMETER DOES NOT " & + "SATISFY THE RANGE CONSTRAINTS OF THE FORMAL " & + "PARAMETER"); + + BEGIN + T1.E1 (SUBINT1(I20)); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 1"); + END; + + BEGIN + I20 := IDENT_INT (20); + T1.E1 (I20); + IF I20 /= IDENT_INT (-10) THEN + FAILED ("OUT PARAM DID NOT GET CORRECT VALUE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON CALL TO E1 - 2"); + END; + + RESULT; + + END C95086A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,202 ---- + -- C95086B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL ACCESS + -- PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS DIFFERENT + -- FROM THE FORMAL PARAMETER. + -- + -- SUBTESTS ARE: + -- (A) IN MODE, STATIC ONE DIMENSIONAL BOUNDS. + -- (B) IN OUT MODE, DYNAMIC RECORD DISCRIMINANTS. + -- (C) CASE (A), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + -- (D) CASE (B), BUT ACTUAL PARAMETER IS A TYPE CONVERSION. + + -- RJW 1/27/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95086B IS + + BEGIN + TEST ( "C95086B", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AN ENTRY CALL, WHEN AN IN OR IN OUT ACTUAL " & + "ACCESS PARAMETER HAS VALUE NULL, BUT WITH CONSTRAINTS " & + "DIFFERENT FROM THE FORMAL PARAMETER" ); + + -------------------------------------------------- + + DECLARE -- (A) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (A)" ); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (A)" ); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (B)" ); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (B)" ); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + TYPE E IS (E1, E2, E3, E4); + TYPE T IS ARRAY (E RANGE <>) OF INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2..E4); + V : A (E1..E2) := NULL; + + TASK T1 IS + ENTRY P (X : SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : SA) DO + NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (C)" ); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (C)" ); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE ARR IS ARRAY (CHARACTER RANGE <>) OF INTEGER; + + TYPE T (B : BOOLEAN := FALSE; C : CHARACTER := 'A') IS + RECORD + I : INTEGER; + CASE B IS + WHEN FALSE => + J : INTEGER; + WHEN TRUE => + A : ARR ('A' .. C); + END CASE; + END RECORD; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (TRUE, 'C'); + V : A (IDENT_BOOL(FALSE), IDENT_CHAR('B')) := NULL; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA); + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED IN TASK - (D)" ); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - (D)" ); + END; -- (D) + + -------------------------------------------------- + + RESULT; + END C95086B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,250 ---- + -- C95086C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL + -- ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS + -- DIFFERENT CONSTRAINTS. + -- + -- SUBTESTS ARE: + -- (A) IN OUT MODE, STATIC PRIVATE DISCRIMINANT. + -- (B) OUT MODE, DYNAMIC TWO DIMENSIONAL BOUNDS. + -- (C) SAME AS (A), WITH TYPE CONVERSION. + -- (D) SAME AS (B), WITH TYPE CONVERSION. + + -- RJW 1/29/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95086C IS + + BEGIN + TEST ("C95086C", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "AFTER THE ENTRY CALL, WHEN AN IN OUT OR OUT FORMAL " & + "ACCESS VALUE IS NULL, AND THE ACTUAL PARAMETER HAS " & + "DIFFERENT CONSTRAINTS" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + TYPE E IS (E1, E2); + TYPE T (D : E := E1) IS PRIVATE; + PRIVATE + TYPE T (D : E := E1) IS + RECORD + I : INTEGER; + CASE D IS + WHEN E1 => + B : BOOLEAN; + WHEN E2 => + C : CHARACTER; + END CASE; + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (E2); + V : A (E1) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : IN OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : IN OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T1; + + BEGIN -- (C) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + -------------------------------------------------- + + DECLARE -- (D) + + TYPE T IS ARRAY (CHARACTER RANGE <>, BOOLEAN RANGE <>) OF + INTEGER; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A ('D'..'F', FALSE..FALSE); + V : A (IDENT_CHAR('A') .. IDENT_CHAR('B'), + IDENT_BOOL(TRUE) .. IDENT_BOOL(TRUE)) := NULL; + ENTERED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + ENTERED := TRUE; + X := NULL; + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T1; + + BEGIN -- (D) + + T1.P (SA(V)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT ENTERED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + -------------------------------------------------- + + RESULT; + END C95086C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- C95086D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED FOR ACCESS PARAMETERS + -- BEFORE OR AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED ACTUAL + -- OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR TO THE + -- ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE FORMAL + -- PARAMETER. + -- + -- SUBTESTS ARE: + -- (A) STATIC LIMITED PRIVATE DISCRIMINANT. + -- (B) DYNAMIC ONE DIMENSIONAL BOUNDS. + + -- RJW 2/3/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95086D IS + + BEGIN + TEST ("C95086D", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE AND AFTER THE ENTRY CALL, WHEN AN UNCONSTRAINED " & + "ACTUAL OUT ACCESS PARAMETER DESIGNATES AN OBJECT (PRIOR " & + "TO THE ENTRY CALL) WITH CONSTRAINTS DIFFERENT FROM THE " & + "FORMAL PARAMETER"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + SUBTYPE INT IS INTEGER RANGE 0..5; + TYPE T (I : INT := 0) IS LIMITED PRIVATE; + PRIVATE + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE T (I : INT := 0) IS + RECORD + J : INTEGER; + A : ARR (1..I); + END RECORD; + END PKG; + + USE PKG; + + TYPE A IS ACCESS T; + SUBTYPE SA IS A (3); + V : A := NEW T (2); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW T (3); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T1; + + BEGIN -- (A) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + TYPE A IS ACCESS STRING; + SUBTYPE SA IS A (1..2); + V : A := NEW STRING (IDENT_INT(5) .. IDENT_INT(7)); + CALLED : BOOLEAN := FALSE; + + TASK T1 IS + ENTRY P (X : OUT SA); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT P (X : OUT SA) DO + CALLED := TRUE; + X := NEW STRING (IDENT_INT(1) .. IDENT_INT(2)); + END P; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T1; + + BEGIN -- (B) + + T1.P (V); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE ENTRY CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + -------------------------------------------------- + + RESULT; + END C95086D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- C95086E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY + -- CALL FOR IN OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE + -- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: + -- (A) OK CASE. + -- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER + -- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE + -- FORMAL INDEX SUBTYPE. + -- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER + -- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL + -- ARRAYS. + -- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE + -- FORMAL INDEX SUBTYPE. + -- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE + -- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + + -- RJW 2/3/86 + -- TMB 11/15/95 ELIMINATED INCOMPATIBILITY WITH ADA95 + -- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + + WITH REPORT; USE REPORT; + PROCEDURE C95086E IS + + BEGIN + TEST ("C95086E", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR IN OUT ARRAY " & + "PARAMETERS, WITH THE ACTUAL HAVING THE FORM OF A TYPE " & + "CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL := (1..3 => (1..3 => TRUE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL := (3..5 => (3..5 => FALSE)); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3) := (2..1 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL := (3..5 => (5..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL := (5..2 => (1..3 => ' ')); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : IN OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : IN OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; + END C95086E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95086f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95086f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- C95086F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS NOT RAISED BEFORE OR AFTER THE ENTRY + -- CALL FOR OUT ARRAY PARAMETERS, WHERE THE ACTUAL PARAMETER HAS THE + -- FORM OF A TYPE CONVERSION. THE FOLLOWING CASES ARE TESTED: + -- (A) OK CASE. + -- (B) FORMAL CONSTRAINED, BOTH FORMAL AND ACTUAL HAVE SAME NUMBER + -- COMPONENTS PER DIMENSION, BUT ACTUAL INDEX BOUNDS LIE OUTSIDE + -- FORMAL INDEX SUBTYPE. + -- (C) FORMAL CONSTRAINED, FORMAL AND ACTUAL HAVE DIFFERENT NUMBER + -- COMPONENTS PER DIMENSION, BOTH FORMAL AND ACTUAL ARE NULL + -- ARRAYS. + -- (D) FORMAL CONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE + -- FORMAL INDEX SUBTYPE. + -- (E) FORMAL UNCONSTRAINED, ACTUAL NULL, WITH INDEX BOUNDS OUTSIDE + -- FORMAL INDEX SUBTYPE FOR NULL DIMENSIONS ONLY. + + -- RJW 2/3/86 + -- TMB 11/15/95 FIXED INCOMPATIBILITIES WITH ADA95 + -- TMB 11/19/96 FIXED SLIDING PROBLEM IN SECTION D + + WITH REPORT; USE REPORT; + PROCEDURE C95086F IS + + BEGIN + TEST ("C95086F", "CHECK THAT CONSTRAINT_ERROR IS NOT RAISED " & + "BEFORE OR AFTER THE ENTRY CALL FOR OUT ARRAY PARAMETERS, " & + "WITH THE ACTUAL HAVING THE FORM OF A TYPE CONVERSION"); + + --------------------------------------------- + + DECLARE -- (A) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF BOOLEAN; + SUBTYPE FORMAL IS ARRAY_TYPE (1..3, 1..3); + SUBTYPE ACTUAL IS ARRAY_TYPE (1..3, 1..3); + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X := (1..3 => (1..3 => TRUE)); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (A)"); + END T; + + BEGIN -- (A) + + T.E (FORMAL (AR)); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (A)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (A)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX, INDEX) OF BOOLEAN; + TYPE ACTUAL IS ARRAY (3..5, 3..5) OF BOOLEAN; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + CALLED := TRUE; + X(3, 3) := TRUE; + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (B)"); + END T; + + BEGIN -- (B) + + T.E (FORMAL (AR)); + IF AR(5, 5) /= TRUE THEN + FAILED ("INCORRECT RETURNED VALUE - (B)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (B)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (B)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + SUBTYPE INDEX IS INTEGER RANGE 1..5; + TYPE ARRAY_TYPE IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + SUBTYPE FORMAL IS ARRAY_TYPE (2..0, 1..3); + AR : ARRAY_TYPE (2..1, 1..3); + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 0 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (C)"); + END IF; + CALLED := TRUE; + X := (2..0 => (1..3 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (C)"); + END T; + + BEGIN -- (C) + + T.E (FORMAL (AR)); + IF AR'LAST /= 1 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (C)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (C)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (C)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE 1..3, INDEX RANGE 3..1) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (3..5, 5..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 3 AND X'LAST(2) /= 1 THEN + FAILED ("WRONG BOUNDS PASSED - (D)"); + END IF; + CALLED := TRUE; + X := (1..3 => (3..1 => 'A')); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (D)"); + END T; + + BEGIN -- (D) + + T.E (FORMAL (AR)); + IF AR'LAST /= 5 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (D)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (D)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (D)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + + SUBTYPE INDEX IS INTEGER RANGE 1..3; + TYPE FORMAL IS ARRAY (INDEX RANGE <>, INDEX RANGE <>) + OF CHARACTER; + TYPE ACTUAL IS ARRAY (POSITIVE RANGE 5..2, + POSITIVE RANGE 1..3) OF CHARACTER; + AR : ACTUAL; + CALLED : BOOLEAN := FALSE; + + TASK T IS + ENTRY E (X : OUT FORMAL); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (X : OUT FORMAL) DO + IF X'LAST /= 2 AND X'LAST(2) /= 3 THEN + FAILED ("WRONG BOUNDS PASSED - (E)"); + END IF; + CALLED := TRUE; + X := (3..1 => (1..3 => ' ' )); + END E; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TASK - (E)"); + END T; + + BEGIN -- (E) + + T.E (FORMAL (AR)); + IF AR'LAST /= 2 AND AR'LAST(2) /= 3 THEN + FAILED ("BOUNDS CHANGED - (E)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF NOT CALLED THEN + FAILED ("EXCEPTION RAISED BEFORE CALL - (E)"); + ELSE + FAILED ("EXCEPTION RAISED ON RETURN - (E)"); + END IF; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; -- (E) + + --------------------------------------------- + + RESULT; + END C95086F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,412 ---- + -- C95087A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNCONSTRAINED RECORD, PRIVATE, LIMITED PRIVATE, AND ARRAY + -- FORMAL PARAMETERS USE THE CONSTRAINTS OF ACTUAL PARAMETERS. + -- SUBTESTS ARE: + -- (A) RECORD TYPE, UNCONSTRAINED ACTUALS, DEFAULTS. + -- (B) PRIVATE TYPE, CONSTRAINED ACTUALS, NO DEFAULTS. + -- (C) LIMITED PRIVATE TYPE, UNCONSTRAINED ACTUALS, NO DEFAULTS. + -- (D) ARRAY TYPE, CONSTRAINED ACTUALS, DEFAULTS. + + -- GLH 7/19/85 + -- JRK 8/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95087A IS + + BEGIN + TEST ("C95087A", "CHECK USE OF ACTUAL CONSTRAINTS BY " & + "UNCONSTRAINED FORMAL PARAMETERS"); + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + REC1 : RECTYPE := (10,10,"0123456789"); + REC2 : RECTYPE := (17,7,"C95087A.........."); + REC3 : RECTYPE := (1,1,"A"); + REC4 : RECTYPE; -- 80. + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE := (2,0,"AB"); + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("RECORD TYPE IN PARAMETER " & + "DID NOT USE CONSTRAINT " & + "OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("RECORD TYPE IN OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + REC2 := PKG.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("RECORD TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + END PKG; + + BEGIN -- (A) + + PKG.T1.E1 (PKG.REC1, PKG.REC2, PKG.REC3); + PKG.T2.E2 (PKG.REC4); + + END; -- (A) + + --------------------------------------------- + + B : DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS PRIVATE; + + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE (10); + REC2 : PKG.RECTYPE (17); + REC3 : PKG.RECTYPE (1); + REC4 : PKG.RECTYPE (10); + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE IN " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("PRIVATE TYPE IN OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "ACTUAL"); + END IF; + REC2 := B.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("PRIVATE TYPE OUT " & + "PARAMETER DID " & + "NOT USE CONSTRAINT OF " & + "UNINITIALIZED ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (B) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END B; -- (B) + + --------------------------------------------- + + C : DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INT IS INTEGER RANGE 0..100; + + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + LIMITED PRIVATE; + + TASK T1 IS + ENTRY E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE); + END T1; + + TASK T2 IS + ENTRY E2 (REC : OUT RECTYPE); + END T2; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INT := 80) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC1 : PKG.RECTYPE; -- 10. + REC2 : PKG.RECTYPE; -- 17. + REC3 : PKG.RECTYPE; -- 1. + REC4 : PKG.RECTYPE; -- 80. + + PACKAGE BODY PKG IS + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (REC1 : IN RECTYPE; + REC2 : OUT RECTYPE; + REC3 : IN OUT RECTYPE) DO + IF REC1.CONSTRAINT /= IDENT_INT (10) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF ACTUAL"); + END IF; + IF REC2.CONSTRAINT /= IDENT_INT (17) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF " & + "ACTUAL"); + END IF; + IF REC3.CONSTRAINT /= IDENT_INT (1) THEN + FAILED ("LIMITED PRIVATE TYPE IN " & + "OUT PARAMETER DID NOT " & + "USE CONSTRAINT OF ACTUAL"); + END IF; + REC2 := C.REC2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (REC : OUT RECTYPE) DO + IF REC.CONSTRAINT /= IDENT_INT (80) THEN + FAILED ("LIMITED PRIVATE TYPE OUT " & + "PARAMETER DID NOT USE " & + "CONSTRAINT OF UNINITIALIZED " & + "ACTUAL"); + END IF; + REC := (10,10,"9876543210"); + END E2; + END T2; + + BEGIN + REC1 := (10,10,"0123456789"); + REC2 := (17,7,"C95087A.........."); + REC3 := (1,1,"A"); + END PKG; + + BEGIN -- (C) + + PKG.T1.E1 (REC1, REC2, REC3); + PKG.T2.E2 (REC4); + + END C; -- (C) + + --------------------------------------------- + + D : DECLARE -- (D) + + TYPE ATYPE IS ARRAY (INTEGER RANGE <>, POSITIVE RANGE <>) OF + CHARACTER; + + A1, A2, A3 : ATYPE (-1..1, 4..5) := (('A','B'), + ('C','D'), + ('E','F')); + + A4 : ATYPE (-1..1, 4..5); + + CA1 : CONSTANT ATYPE (8..9, -7..INTEGER'FIRST) := + (8..9 => (-7..INTEGER'FIRST => 'A')); + + S1 : STRING (1..INTEGER'FIRST) := ""; + S2 : STRING (-5..-7) := ""; + S3 : STRING (1..0) := ""; + + TASK T1 IS + ENTRY E1 (A1 : IN ATYPE := CA1; + A2 : OUT ATYPE; + A3 : IN OUT ATYPE); + END T1; + + TASK T2 IS + ENTRY E2 (A4 : OUT ATYPE); + END T2; + + TASK T3 IS + ENTRY E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING); + END T3; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (A1 : IN ATYPE := CA1; A2 : OUT ATYPE; + A3 : IN OUT ATYPE) DO + IF A1'FIRST(1) /= IDENT_INT (-1) OR + A1'LAST(1) /= IDENT_INT (1) OR + A1'FIRST(2) /= IDENT_INT (4) OR + A1'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A2'FIRST(1) /= IDENT_INT (-1) OR + A2'LAST(1) /= IDENT_INT (1) OR + A2'FIRST(2) /= IDENT_INT (4) OR + A2'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL"); + END IF; + IF A3'FIRST(1) /= IDENT_INT (-1) OR + A3'LAST(1) /= IDENT_INT (1) OR + A3'FIRST(2) /= IDENT_INT (4) OR + A3'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL"); + END IF; + A2 := D.A2; + END E1; + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (A4 : OUT ATYPE) DO + IF A4'FIRST(1) /= IDENT_INT (-1) OR + A4'LAST(1) /= IDENT_INT (1) OR + A4'FIRST(2) /= IDENT_INT (4) OR + A4'LAST(2) /= IDENT_INT (5) THEN + FAILED ("ARRAY TYPE OUT PARAMETER DID " & + "NOT USE CONSTRAINTS OF " & + "UNINITIALIZED ACTUAL"); + END IF; + A4 := A2; + END E2; + END T2; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (S1 : IN STRING; + S2 : IN OUT STRING; + S3 : OUT STRING) DO + IF S1'FIRST /= IDENT_INT (1) OR + S1'LAST /= IDENT_INT (INTEGER'FIRST) THEN + FAILED ("STRING TYPE IN PARAMETER DID " & + "NOT USE CONSTRAINTS OF ACTUAL " & + "NULL STRING"); + END IF; + IF S2'FIRST /= IDENT_INT (-5) OR + S2'LAST /= IDENT_INT (-7) THEN + FAILED ("STRING TYPE IN OUT PARAMETER " & + "DID NOT USE CONSTRAINTS OF " & + "ACTUAL NULL STRING"); + END IF; + IF S3'FIRST /= IDENT_INT (1) OR + S3'LAST /= IDENT_INT (0) THEN + FAILED ("STRING TYPE OUT PARAMETER DID NOT " & + "USE CONSTRAINTS OF ACTUAL NULL " & + "STRING"); + END IF; + S3 := ""; + END E3; + END T3; + + BEGIN -- (D) + + T1.E1 (A1, A2, A3); + T2.E2 (A4); + T3.E3 (S1, S2, S3); + + END D; -- (D) + + RESULT; + END C95087A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- C95087B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED + -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITHOUT DEFAULT + -- CONSTRAINTS RAISE CONSTRAINT_ERROR IF AN ATTEMPT IS MADE TO CHANGE + -- THE CONSTRAINT OF THE ACTUAL PARAMETER. + -- SUBTESTS ARE: + -- (A) RECORD TYPE. + -- (B) PRIVATE TYPE. + -- (C) LIMITED PRIVATE TYPE. + + -- RJW 1/10/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95087B IS + + BEGIN + + TEST ( "C95087B", "CHECK ASSIGNMENT TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPE (WITH NO DEFAULT)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + END PKG; + + REC9 : PKG.RECTYPE(IDENT_INT(9)) := + (IDENT_INT(9), 9, "123456789"); + REC6 : PKG.RECTYPE(IDENT_INT(6)) := + (IDENT_INT(6), 5, "AEIOUY"); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(IDENT_INT(4)) := + (IDENT_INT(4), 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (A.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.1"); + END; -- (A.1) + + BEGIN -- (A.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- A.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- A.2"); + END; -- (A.2) + + REC9 := (IDENT_INT(9), 9, "987654321"); + + END E; + END T; + END PKG; + + BEGIN -- (A) + + PKG.T.E (REC9, REC6); + + IF REC9.STRFIELD /= IDENT_STR("987654321") THEN + FAILED ("ASSIGNMENT TO REC9 FAILED - (A)"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC9 : PKG.RECTYPE(9); + REC6 : PKG.RECTYPE(6); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (B.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.1"); + END; -- (B.1) + + BEGIN -- (B.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- B.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- B.2"); + END; -- (B.2) + + END E; + END T; + + BEGIN + REC9 := (9, 9, "123456789"); + REC6 := (6, 5, "AEIOUY"); + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC9, REC6); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + TYPE RECTYPE (CONSTRAINT : INTEGER) IS LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE); + END T; + + PRIVATE + TYPE RECTYPE (CONSTRAINT : INTEGER) IS + RECORD + INTFIELD : INTEGER; + STRFIELD : STRING (1..CONSTRAINT); + END RECORD; + END PKG; + + REC6 : PKG.RECTYPE(IDENT_INT(6)); + REC9 : PKG.RECTYPE(IDENT_INT(9)); + + PACKAGE BODY PKG IS + + TASK BODY T IS + + REC4 : CONSTANT RECTYPE(4) := (4, 4, "OOPS"); + + BEGIN + ACCEPT E (REC9 : OUT RECTYPE; + REC6 : IN OUT RECTYPE) DO + + BEGIN -- (C.1) + REC9 := REC6; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.1"); + END; -- (C.1) + + BEGIN -- (C.2) + REC6 := REC4; + FAILED ("CONSTRAINT_ERROR NOT RAISED " & + "- C.2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- C.2"); + END; -- (C.2) + + END E; + END T; + + BEGIN + REC6 := (6, 5, "AEIOUY"); + REC9 := (9, 9, "123456789"); + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC9, REC6); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C95087B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,299 ---- + -- C95087C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED + -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT + -- CONSTRAINTS RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER IS + -- CONSTRAINED AND THE CONSTRAINT VALUES OF THE OBJECT BEING + -- ASSIGNED TO DO NOT SATISFY THOSE OF THE ACTUAL PARAMETER. + + -- SUBTESTS ARE: + -- (A) CONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. + -- (B) CONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. + -- (C) CONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + + -- RJW 1/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95087C IS + + BEGIN + + TEST ( "C95087C", "CHECK ASSIGNMENTS TO ENTRY FORMAL " & + "PARAMETERS OF UNCONSTRAINED TYPES " & + "(WITH DEFAULTS)" ); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + REC91,REC92,REC93 : RECTYPE(9); + REC_OOPS : RECTYPE(4); + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON RECORD TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - A.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - A.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (A) + + PKG.T.E (PKG.REC91, PKG.REC92, PKG.REC93); + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= IDENT_INT(9)) THEN + FAILED ( "CONSTRAINT ON PRIVATE TYPE " & + "IN PARAMETER NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - B.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - B.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91,REC92,REC93 : PKG.RECTYPE(9); + REC_OOPS : PKG.RECTYPE(4); + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF (NOT REC1'CONSTRAINED) OR + (REC1.CONSTRAINT /= 9) THEN + FAILED ( "CONSTRAINT ON LIMITED " & + "PRIVATE TYPE IN PARAMETER " & + "NOT RECOGNIZED" ); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT " & + "RAISED - C.1" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.1" ); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + FAILED ( "CONSTRAINT_ERROR NOT RAISED " & + "- C.2" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION " & + "RAISED - C.2" ); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C95087C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95087d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95087d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,268 ---- + -- C95087D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ASSIGNMENTS TO ENTRY FORMAL PARAMETERS OF UNCONSTRAINED + -- RECORD, PRIVATE, AND LIMITED PRIVATE TYPES WITH DEFAULT + -- CONSTRAINTS DO NOT RAISE CONSTRAINT_ERROR IF THE ACTUAL PARAMETER + -- IS UNCONSTRAINED, EVEN IF THE CONSTRAINT VALUES OF THE OBJECT + -- BEING ASSIGNED ARE DIFFERENT THAN THOSE OF THE ACTUAL PARAMETER. + + -- SUBTESTS ARE: + -- (A) UNCONSTRAINED ACTUAL PARAMETERS OF RECORD TYPE. + -- (B) UNCONSTRAINED ACTUAL PARAMETERS OF PRIVATE TYPE. + -- (C) UNCONSTRAINED ACTUAL PARAMETERS OF LIMITED PRIVATE TYPE. + + -- RJW 1/17/86 + + WITH REPORT; USE REPORT; + PROCEDURE C95087D IS + + BEGIN + + TEST ( "C95087D", "CHECK ASSIGNMENTS TO ENTRY FORMAL PARAMETERS " & + "OF UNCONSTRAINED TYPES WITH UNCONSTRAINED " & + "ACTUAL PARAMETERS"); + + -------------------------------------------------- + + DECLARE -- (A) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE := + (IDENT_INT(5), 5, IDENT_STR( "12345")); + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF NOT REC1'CONSTRAINED THEN + FAILED ( "REC1 IS NOT CONSTRAINED - A.1"); + END IF; + IF REC1.CONSTRAINT /= IDENT_INT(9) THEN + FAILED ( "REC1 CONSTRAINT IS NOT 9 " & + "- A.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - A.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + USE PKG; + + BEGIN -- (A) + + PKG.T.E (REC91, REC92, REC93); + IF (REC92 /= REC_OOPS) OR (REC93 /= REC_OOPS) THEN + FAILED ( "RESULTANT VALUE OF REC92 OR REC93 INCORRECT"); + END IF; + + END; -- (A) + + -------------------------------------------------- + + DECLARE -- (B) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + IF REC3'CONSTRAINED THEN + FAILED ( "REC3 IS CONSTRAINED - B.1"); + END IF; + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - B.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (B) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (B) + + -------------------------------------------------- + + DECLARE -- (C) + + PACKAGE PKG IS + + SUBTYPE INTRANGE IS INTEGER RANGE 0..31; + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + LIMITED PRIVATE; + + TASK T IS + ENTRY E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE); + END T; + + PRIVATE + + TYPE RECTYPE (CONSTRAINT : INTRANGE := 15) IS + RECORD + INTFLD : INTRANGE; + STRFLD : STRING(1..CONSTRAINT); + END RECORD; + END PKG; + + REC91, REC92, REC93 : PKG.RECTYPE; + REC_OOPS : PKG.RECTYPE; + + PACKAGE BODY PKG IS + + TASK BODY T IS + BEGIN + ACCEPT E (REC1 : IN RECTYPE; REC2 : IN OUT RECTYPE; + REC3 : OUT RECTYPE) DO + + BEGIN -- ASSIGNMENT TO IN OUT PARAMETER. + REC2 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.1"); + END; + + BEGIN -- ASSIGNMENT TO OUT PARAMETER. + REC3 := REC_OOPS; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED - C.2"); + END; + + END E; + END T; + + BEGIN + + REC91 := (9, 9, "123456789"); + REC92 := REC91; + REC93 := REC91; + + REC_OOPS := (4, 4, "OOPS"); + + END PKG; + + BEGIN -- (C) + + PKG.T.E (REC91, REC92, REC93); + + END; -- (C) + + -------------------------------------------------- + + RESULT; + + END C95087D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95088a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95088a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95088a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95088a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- C95088A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ACTUAL PARAMETERS ARE EVALUATED AND IDENTIFIED AT THE + -- TIME OF CALL. + + -- GLH 7/10/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C95088A IS + + TYPE VECTOR IS ARRAY (1..10) OF INTEGER; + TYPE PTRINT IS ACCESS INTEGER; + + I : INTEGER := 1; + A : VECTOR := (1,2,3,4,5,6,7,8,9,10); + P1 : PTRINT := NEW INTEGER'(2); + P2 : PTRINT := P1; + + TASK T1 IS + ENTRY E1 (I : OUT INTEGER; J : OUT INTEGER); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (I : OUT INTEGER; J : OUT INTEGER) DO + I := 10; + J := -1; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (P : OUT PTRINT; I : OUT INTEGER); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (P : OUT PTRINT; I : OUT INTEGER) DO + P := NEW INTEGER'(3); + I := 5; + END E2; + END T2; + + BEGIN + + TEST ("C95088A", "CHECK THAT ACTUAL PARAMETERS ARE EVALUATED " & + "AND IDENTIFIED AT THE TIME OF CALL"); + + COMMENT ("FIRST CALL"); + T1.E1 (I, A(I)); + IF (A /= (-1,2,3,4,5,6,7,8,9,10)) THEN + FAILED ("A(I) EVALUATED UPON RETURN"); + END IF; + + COMMENT ("SECOND CALL"); + T2.E2 (P1, P1.ALL); + IF (P2.ALL /= 5) THEN + FAILED ("P1.ALL EVALUATED UPON RETURN"); + END IF; + + RESULT; + + END C95088A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95089a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95089a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95089a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95089a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,175 ---- + -- C95089A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL PERMITTED FORMS OF VARIABLE NAMES ARE PERMITTED + -- AS ACTUAL PARAMETERS. + + -- GLH 7/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95089A IS + + SUBTYPE INT IS INTEGER RANGE 1..3; + + TYPE REC (N : INT) IS + RECORD + S : STRING (1..N); + END RECORD; + + TYPE PTRSTR IS ACCESS STRING; + + R1, R2, R3 : REC (3); + S1, S2, S3 : STRING (1..3); + PTRTBL : ARRAY (1..3) OF PTRSTR; + + TASK T1 IS + ENTRY E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING); + END T1; + + TASK BODY T1 IS + BEGIN + LOOP + SELECT + ACCEPT E1 (S1 : IN STRING; S2: IN OUT STRING; + S3 : OUT STRING) DO + S3 := S2; + S2 := S1; + END E1; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + + TASK T2 IS + ENTRY E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER); + END T2; + + TASK BODY T2 IS + BEGIN + LOOP + SELECT + ACCEPT E2 (C1 : IN CHARACTER; C2 : IN OUT CHARACTER; + C3 : OUT CHARACTER) DO + C3 := C2; + C2 := C1; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T2; + + FUNCTION F1 (X : INT) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (X); + END F1; + + FUNCTION "+" (S1, S2 : STRING) RETURN PTRSTR IS + BEGIN + RETURN PTRTBL (CHARACTER'POS(S1(1))-CHARACTER'POS('A')+1); + END "+"; + + BEGIN + + TEST ("C95089A", "CHECK THAT ALL PERMITTED FORMS OF VARIABLE " & + "NAMES ARE PERMITTED AS ACTUAL PARAMETERS"); + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1, S2, S3); + IF S2 /= "AAA" OR S3 /= "BBB" THEN + FAILED ("SIMPLE VARIABLE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + S3 := IDENT_STR ("CCC"); + T2.E2 (S1(1), S2(IDENT_INT(1)), S3(1)); + IF S2 /= "ABB" OR S3 /= "BCC" THEN + FAILED ("INDEXED COMPONENT AS AN ACTUAL PARAMETER NOT " & + "WORKING"); + END IF; + + R1.S := "AAA"; + R2.S := "BBB"; + T1.E1 (R1.S, R2.S, R3.S); + IF R2.S /= "AAA" OR R3.S /= "BBB" THEN + FAILED ("SELECTED COMPONENT AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + S1 := "AAA"; + S2 := "BBB"; + T1.E1 (S1(1..IDENT_INT(2)), S2(1..2), + S3(IDENT_INT(1)..IDENT_INT(2))); + IF S2 /= "AAB" OR S3 /= "BBC" THEN + FAILED ("SLICE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1).ALL, F1(2).ALL, F1(IDENT_INT(3)).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + S1 := IDENT_STR("AAA"); + S2 := IDENT_STR("BBB"); + S3 := IDENT_STR("CCC"); + T1.E1 ("+"(S1,S1).ALL, "+"(S2,S2).ALL, "+"(S3,S3).ALL); + IF PTRTBL(2).ALL /= "AAA" OR PTRTBL(3).ALL /= "BBB" THEN + FAILED ("SELECTED COMPONENT OF OVERLOADED OPERATOR " & + "FUNCTION VALUE AS AN ACTUAL PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T2.E2 (F1(1)(1), F1(IDENT_INT(2))(1), F1(3)(IDENT_INT(1))); + IF PTRTBL(2).ALL /= "ABB" OR PTRTBL(3).ALL /= "BCC" THEN + FAILED ("INDEXED COMPONENT OF FUNCTION VALUE AS AN ACTUAL " & + "PARAMETER NOT WORKING"); + END IF; + + PTRTBL(1) := NEW STRING'("AAA"); + PTRTBL(2) := NEW STRING'("BBB"); + PTRTBL(3) := NEW STRING'("CCC"); + T1.E1 (F1(1)(2..3), F1(2)(IDENT_INT(2)..3), + F1(3)(2..IDENT_INT(3))); + IF PTRTBL(2).ALL /= "BAA" OR PTRTBL(3).ALL /= "CBB" THEN + FAILED ("SLICE OF FUNCTION VALUE AS AN ACTUAL PARAMETER " & + "NOT WORKING"); + END IF; + + RESULT; + + END C95089A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95090a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95090a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95090a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95090a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C95090A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ARRAYS THAT ARE COMPONENTS OF RECORDS ARE PASSED CORRECTLY + -- TO ENTRIES. SPECIFICALLY, + -- (A) CHECK ALL PARAMETER MODES. + + -- GLH 7/25/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95090A IS + + BEGIN + TEST ("C95090A", "CHECK THAT ARRAYS WHICH ARE COMPONENTS OF " & + "RECORDS ARE PASSED CORRECTLY TO ENTRIES"); + + -------------------------------------------- + + DECLARE -- (A) + + TYPE ARRAY_TYPE IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE ARRAY_SUBTYPE IS ARRAY_TYPE (1..IDENT_INT(5)); + + TYPE RECORD_TYPE IS + RECORD + I : INTEGER; + A : ARRAY_SUBTYPE; + END RECORD; + + REC : RECORD_TYPE := (I => 23, + A => (1..3 => IDENT_INT(7), 4..5 => 9)); + BOOL : BOOLEAN; + + TASK T1 IS + ENTRY E1 (ARR : ARRAY_TYPE); + END T1; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 (ARR : ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAMETER NOT PASSED CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN PARAMETER"); + END IF; + END E1; + END T1; + + TASK T2 IS + ENTRY E2 (ARR : IN OUT ARRAY_TYPE); + END T2; + + TASK BODY T2 IS + BEGIN + ACCEPT E2 (ARR : IN OUT ARRAY_TYPE) DO + IF ARR /= (7, 7, 7, 9, 9) THEN + FAILED ("IN OUT PARAMETER NOT PASSED " & + "CORRECTLY"); + END IF; + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR IN OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 5); + END E2; + END T2; + + TASK T3 IS + ENTRY E3 (ARR : OUT ARRAY_TYPE); + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3 (ARR : OUT ARRAY_TYPE) DO + IF ARR'FIRST /= IDENT_INT (1) OR + ARR'LAST /= IDENT_INT (5) THEN + FAILED ("WRONG BOUNDS FOR OUT PARAMETER"); + END IF; + ARR := (ARR'RANGE => 3); + END E3; + END T3; + + BEGIN -- (A) + + T1.E1 (REC.A); + IF REC.A /= (7, 7, 7, 9, 9) THEN + FAILED ("IN PARAM CHANGED BY PROCEDURE"); + END IF; + + T2.E2 (REC.A); + IF REC.A /= (5, 5, 5, 5, 5) THEN + FAILED ("IN OUT PARAM RETURNED INCORRECTLY"); + END IF; + + T3.E3 (REC.A); + IF REC.A /= (3, 3, 3, 3, 3) THEN + FAILED ("OUT PARAM RETURNED INCORRECTLY"); + END IF; + + END; -- (A) + + -------------------------------------------- + + RESULT; + END C95090A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95092a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95092a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95092a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95092a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,193 ---- + -- C95092A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR ENTRIES OF TASKS, DEFAULT VALUES OF ALL TYPES CAN + -- BE GIVEN FOR A FORMAL PARAMETER. + + -- HISTORY: + -- DHH 03/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE C95092A IS + + SUBTYPE INT IS INTEGER RANGE 1 ..10; + TYPE FLT IS DIGITS 5; + TYPE FIX IS DELTA 0.125 RANGE 0.0 .. 10.0; + TYPE ENUM IS (RED, BLUE, YELLOW); + SUBTYPE CHAR IS CHARACTER RANGE 'A' .. 'F'; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE REC IS + RECORD + A : INT; + B : ENUM; + C : CHAR; + END RECORD; + + FUNCTION IDENT_FLT(E : FLT) RETURN FLT IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + FUNCTION IDENT_FIX(E : FIX) RETURN FIX IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIX; + + FUNCTION IDENT_ENUM(E : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN YELLOW; + END IF; + END IDENT_ENUM; + + FUNCTION IDENT_CHAR(E : CHAR) RETURN CHAR IS + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN 'F'; + END IF; + END IDENT_CHAR; + + FUNCTION IDENT_ARR(E : ARR) RETURN ARR IS + Z : ARR := (3,2,1); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_ARR; + + FUNCTION IDENT_REC(E : REC) RETURN REC IS + Z : REC := (10, YELLOW, 'F'); + BEGIN + IF EQUAL(3,3) THEN + RETURN E; + ELSE + RETURN Z; + END IF; + END IDENT_REC; + + TASK TEST_DEFAULTS IS + ENTRY BOOL(G : BOOLEAN := TRUE); + ENTRY INTEGR(X : IN INT := 5); + ENTRY FLOAT(Y : IN FLT := 1.25); + ENTRY FIXED(Z : IN FIX := 1.0); + ENTRY ENUMERAT(A : IN ENUM := RED); + ENTRY CHARACTR(B : IN CHAR := 'A'); + ENTRY ARRY(C : IN ARR := (1, 2, 3)); + ENTRY RECD(D : IN REC := (5, RED, 'A')); + END TEST_DEFAULTS; + + TASK BODY TEST_DEFAULTS IS + BEGIN + + ACCEPT BOOL(G : BOOLEAN := TRUE) DO + IF G /= IDENT_BOOL(TRUE) THEN + FAILED("BOOLEAN DEFAULT FAILED"); + END IF; + END BOOL; + + ACCEPT INTEGR(X : IN INT := 5) DO + IF X /= IDENT_INT(5) THEN + FAILED("INTEGER DEFAULT FAILED"); + END IF; + END INTEGR; + + ACCEPT FLOAT(Y : IN FLT := 1.25) DO + IF Y /= IDENT_FLT(1.25) THEN + FAILED("FLOAT DEFAULT FAILED"); + END IF; + END FLOAT; + + ACCEPT FIXED(Z : IN FIX := 1.0) DO + IF Z /= IDENT_FIX(1.0) THEN + FAILED("FIXED DEFAULT FAILED"); + END IF; + END FIXED; + + ACCEPT ENUMERAT(A : IN ENUM := RED) DO + IF A /= IDENT_ENUM(RED) THEN + FAILED("ENUMERATION DEFAULT FAILED"); + END IF; + END ENUMERAT; + + ACCEPT CHARACTR(B : IN CHAR := 'A') DO + IF B /= IDENT_CHAR('A') THEN + FAILED("CHARACTER DEFAULT FAILED"); + END IF; + END CHARACTR; + + ACCEPT ARRY(C : IN ARR := (1, 2, 3)) DO + FOR I IN 1 ..3 LOOP + IF C(I) /= IDENT_INT(I) THEN + FAILED("ARRAY " & INTEGER'IMAGE(I) & + "DEFAULT FAILED"); + END IF; + END LOOP; + END ARRY; + + ACCEPT RECD(D : IN REC := (5, RED, 'A')) DO + IF D.A /= IDENT_INT(5) THEN + FAILED("RECORD INTEGER DEFAULT FAILED"); + END IF; + IF D.B /= IDENT_ENUM(RED) THEN + FAILED("RECORD ENUMERATION DEFAULT FAILED"); + END IF; + IF D.C /= IDENT_CHAR('A') THEN + FAILED("RECORD CHARACTER DEFAULT FAILED"); + END IF; + END RECD; + + END TEST_DEFAULTS; + + BEGIN + + TEST("C95092A", "CHECK THAT FOR ENTRIES OF TASKS, DEFAULT " & + "VALUES OF ALL TYPES CAN BE GIVEN FOR A FORMAL " & + "PARAMETER"); + + TEST_DEFAULTS.BOOL; + TEST_DEFAULTS.INTEGR; + TEST_DEFAULTS.FLOAT; + TEST_DEFAULTS.FIXED; + TEST_DEFAULTS.ENUMERAT; + TEST_DEFAULTS.CHARACTR; + TEST_DEFAULTS.ARRY; + TEST_DEFAULTS.RECD; + + RESULT; + END C95092A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95093a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95093a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95093a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95093a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- C95093A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE DEFAULT EXPRESSIONS OF FORMAL PARAMETERS ARE EVALUATED + -- EACH TIME THEY ARE NEEDED. + + -- GLH 7/2/85 + + WITH REPORT; USE REPORT; + + PROCEDURE C95093A IS + BEGIN + + TEST ("C95093A", "CHECK THAT THE DEFAULT EXPRESSION IS " & + "EVALUATED EACH TIME IT IS NEEDED"); + + DECLARE + + X : INTEGER := 1; + + FUNCTION F RETURN INTEGER IS + BEGIN + X := X + 1; + RETURN X; + END F; + + TASK T1 IS + ENTRY E1 (X, Y : INTEGER := F); + END T1; + + TASK BODY T1 IS + BEGIN + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR Y /= 2 THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "1, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + ACCEPT E1 (X, Y : INTEGER := F) DO + IF X = Y OR + NOT ((X = 3 AND Y = 4) OR + (X = 4 AND Y = 3)) THEN + FAILED ("DEFAULT NOT EVALUATED CORRECTLY - " & + "2, X =" & INTEGER'IMAGE(X) & + ", Y =" & INTEGER'IMAGE(Y)); + END IF; + END E1; + + END T1; + + BEGIN + + COMMENT ("FIRST CALL"); + T1.E1 (3); + + COMMENT ("SECOND CALL"); + T1.E1; + + END; + + RESULT; + + END C95093A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C95095A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (A) A FUNCTION AND AN ENTRY. + + -- JWC 7/24/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95095A IS + + BEGIN + TEST ("C95095A", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- BOTH PARAMETERIZED AND PARAMETERLESS SUBPROGRAMS AND ENTRIES + -- ARE TESTED. + + DECLARE + I, J, K : INTEGER := 0; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2; + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E2 DO + S (1) := 'C'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + FUNCTION E1 (I1, I2 : INTEGER) RETURN INTEGER IS + BEGIN + S (2) := 'B'; + RETURN I1; -- RETURNED VALUE IS IRRELEVENT. + END E1; + + + FUNCTION E2 RETURN INTEGER IS + BEGIN + S (2) := 'D'; + RETURN I; -- RETURNED VALUE IS IRRELEVENT. + END E2; + + BEGIN + T.E1 (I, J); + K := E1 (I, J); + + IF S /= "AB" THEN + FAILED ("PARAMETERIZED OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2; + K := E2; + + IF S /= "CD" THEN + FAILED ("PARAMETERLESS OVERLOADED " & + "SUBPROGRAM AND ENTRY " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + END C95095A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- C95095B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED ENTRY DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (B) ONE ENTRY HAS ONE LESS PARAMETER THAN THE OTHER. + + -- JWC 7/24/85 + -- JRK 10/2/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95095B IS + + BEGIN + TEST ("C95095B", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- ONE ENTRY HAS ONE MORE PARAMETER + -- THAN THE OTHER. THIS IS TESTED IN THE + -- CASE IN WHICH THAT PARAMETER HAS A DEFAULT + -- VALUE, AND THE CASE IN WHICH IT DOES NOT. + + DECLARE + I, J : INTEGER := 0; + B : BOOLEAN := TRUE; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E1 (I1, I2 : INTEGER; B1 : IN OUT BOOLEAN); + ENTRY E1 (I1, I2 : INTEGER); + ENTRY E2 (B1 : IN OUT BOOLEAN; I1 : INTEGER := 0); + ENTRY E2 (B1 : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E1 (I1, I2 : INTEGER; + B1 : IN OUT BOOLEAN) DO + S (1) := 'A'; + END E1; + OR + ACCEPT E1 (I1, I2 : INTEGER) DO + S (2) := 'B'; + END E1; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN; + I1 : INTEGER := 0) DO + S (1) := 'C'; + END E2; + OR + ACCEPT E2 (B1 : IN OUT BOOLEAN) DO + S (2) := 'D'; + END E2; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E1 (I, J, B); + T.E1 (I, J); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "NUMBER OF PARAMETERS (NO DEFAULTS) " & + "CAUSED CONFUSION"); + END IF; + + S := "12"; + T.E2 (B, I); + -- NOTE THAT A CALL TO T.E2 WITH ONLY + -- ONE PARAMETER IS AMBIGUOUS. + + IF S /= "C2" THEN + FAILED ("ENTRIES DIFFERING ONLY IN " & + "EXISTENCE OF ONE PARAMETER (WITH " & + "DEFAULT) CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + END C95095B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- C95095C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED ENTRY DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (C) THE BASE TYPE OF A PARAMETER IS DIFFERENT FROM THAT + -- OF THE CORRESPONDING ONE. + + -- JWC 7/24/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95095C IS + + BEGIN + TEST ("C95095C", "ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- THE BASE TYPE OF ONE PARAMETER IS + -- DIFFERENT FROM THAT OF THE CORRESPONDING + -- ONE. + + DECLARE + + TYPE NEWINT IS NEW INTEGER; + + I, J, K : INTEGER := 0; + N : NEWINT; + S : STRING (1..2) := "12"; + + TASK T IS + ENTRY E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER); + ENTRY E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT E (I1 : INTEGER; N1 : OUT NEWINT; + I2 : IN OUT INTEGER) DO + S (1) := 'A'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + ACCEPT E (I1 : INTEGER; N1 : OUT INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + N1 := 0; -- THIS VALUE IS IRRELEVENT. + END E; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + BEGIN + T.E (I, N, K); + T.E (I, J, K); + + IF S /= "AB" THEN + FAILED ("ENTRIES DIFFERING ONLY BY " & + "THE BASE TYPE OF A PARAMETER " & + "CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + END C95095C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- C95095D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (D) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IS DECLARED IN A TASK, AND THE + -- PARAMETERS ARE ORDERED DIFFERENTLY. + + -- JWC 7/24/85 + -- JRK 10/2/85 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C95095D IS + + + BEGIN + TEST ("C95095D", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IS DECLARED IN A TASK, AND THE + -- PARAMETERS ARE ORDERED DIFFERENTLY. + + DECLARE + S : STRING (1..2) := "12"; + + I : INTEGER := 0; + + PROCEDURE E (I1 : INTEGER; I2 : IN OUT INTEGER; + B1 : BOOLEAN) IS + BEGIN + S (1) := 'A'; + END E; + + TASK T IS + ENTRY E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER); + END T; + + TASK BODY T IS + BEGIN + E (5, I, TRUE); -- PROCEDURE CALL. + ACCEPT E (B1 : BOOLEAN; I1 : INTEGER; + I2 : IN OUT INTEGER) DO + S (2) := 'B'; + END E; + E (TRUE, 5, I); -- ENTRY CALL; SELF-BLOCKING. + -- NOTE THAT A CALL IN WHICH ALL ACTUAL PARAMETERS + -- ARE NAMED_ASSOCIATIONS IS AMBIGUOUS. + FAILED ("TASK DID NOT BLOCK ITSELF"); + END T; + + BEGIN + + T.E (TRUE, 5, I); + + DELAY 10.0 * Impdef.One_Second; + ABORT T; + + IF S /= "AB" THEN + FAILED ("PROCEDURES/ENTRIES " & + "DIFFERING ONLY IN PARAMETER " & + "TYPE ORDER CAUSED CONFUSION"); + END IF; + END; + + -------------------------------------------------- + + RESULT; + END C95095D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c95095e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c95095e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C95095E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT OVERLOADED SUBPROGRAM AND ENTRY DECLARATIONS + -- ARE PERMITTED IN WHICH THERE IS A MINIMAL + -- DIFFERENCE BETWEEN THE DECLARATIONS. + + -- (E) A SUBPROGRAM IS DECLARED IN AN OUTER DECLARATIVE PART, + -- AN ENTRY IN A TASK, AND ONE HAS ONE MORE PARAMETER + -- THAN THE OTHER; THE OMITTED PARAMETER HAS A DEFAULT VALUE. + + -- JWC 7/30/85 + -- JRK 10/2/85 + + WITH REPORT; USE REPORT; + PROCEDURE C95095E IS + + BEGIN + TEST ("C95095E", "SUBPROGRAM/ENTRY OVERLOADING WITH " & + "MINIMAL DIFFERENCES ALLOWED"); + + -------------------------------------------------- + + -- A SUBPROGRAM IS IN AN OUTER DECLARATIVE + -- PART, AN ENTRY IN A TASK, AND ONE + -- HAS ONE MORE PARAMETER (WITH A DEFAULT + -- VALUE) THAN THE OTHER. + + DECLARE + S : STRING (1..3) := "123"; + + PROCEDURE E (I1, I2, I3 : INTEGER := 1) IS + C : CONSTANT STRING := "CXA"; + BEGIN + S (I3) := C (I3); + END E; + + TASK T IS + ENTRY E (I1, I2 : INTEGER := 1); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I1, I2 : INTEGER := 1) DO + S (2) := 'B'; + END E; + END T; + + BEGIN + + E (1, 2, 3); + T.E (1, 2); + E (1, 2); + + IF S /= "CBA" THEN + FAILED ("PROCEDURES/ENTRIES DIFFERING " & + "ONLY IN EXISTENCE OF ONE " & + "DEFAULT-VALUED PARAMETER CAUSED " & + "CONFUSION"); + END IF; + + END; + + -------------------------------------------------- + + RESULT; + END C95095E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c951001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c951001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c951001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c951001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- C951001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that two procedures in a protected object will not be + -- executed concurrently. + -- + -- TEST DESCRIPTION: + -- A very simple example of two tasks calling two procedures in the same + -- protected object is used. Test control code has been added to the + -- procedures such that, whichever gets called first executes a lengthy + -- calculation giving sufficient time (on a multiprocessor or a + -- time-slicing machine) for the other task to get control and call the + -- other procedure. The control code verifies that entry to the second + -- routine is postponed until the first is complete. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + procedure C951001 is + + protected Ramp_31 is + + procedure Add_Meter_Queue; + procedure Subtract_Meter_Queue; + function TC_Failed return Boolean; + + private + + Ramp_Count : integer range 0..20 := 4; -- Start test with some + -- vehicles on the ramp + + TC_Add_Started : Boolean := false; + TC_Subtract_Started : Boolean := false; + TC_Add_Finished : Boolean := false; + TC_Subtract_Finished : Boolean := false; + TC_Concurrent_Running: Boolean := false; + + end Ramp_31; + + + protected body Ramp_31 is + + function TC_Failed return Boolean is + begin + -- this indicator will have been set true if any instance + -- of concurrent running has been proved + return TC_Concurrent_Running; + end TC_Failed; + + + procedure Add_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Add_Started := true; + if TC_Subtract_Started then + if not TC_Subtract_Finished then + TC_Concurrent_Running := true; + end if; + else + -- Subtract has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Subtract_Started then + -- Subtract was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Add_Finished := true; + --================================================== + Ramp_Count := Ramp_Count + 1; + end Add_Meter_Queue; + + procedure Subtract_Meter_Queue is + begin + --================================================== + -- This section is all Test_Control code + TC_Subtract_Started := true; + if TC_Add_Started then + if not TC_Add_Finished then + -- We already have concurrent running + TC_Concurrent_Running := true; + end if; + else + -- Add has not started. + -- Execute a lengthy routine to give it a chance to do so + ImpDef.Exceed_Time_Slice; + + if TC_Add_Started then + -- Add was able to start so we have concurrent + -- running and the test has failed + TC_Concurrent_Running := true; + end if; + end if; + TC_Subtract_Finished := true; + --================================================== + Ramp_Count := Ramp_Count - 1; + end Subtract_Meter_Queue; + + end Ramp_31; + + begin + + Report.Test ("C951001", "Check that two procedures in a protected" & + " object will not be executed concurrently"); + + declare -- encapsulate the test + + task Vehicle_1; + task Vehicle_2; + + + -- Vehicle_1 and Vehicle_2 are simulations of Instances of the task + -- of type Vehicle in different stages of execution + + task body Vehicle_1 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + null; -- ::::: stub: Ramp_31.Subtract_Meter_Queue + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_1 task"); + end Vehicle_1; + + + task body Vehicle_2 is + begin + null; -- ::::: stub. preparation code + + -- Add to the count of vehicles on the queue + null; -- ::::: stub Ramp_31.Add_Meter_Queue; + + null; -- ::::: stub: wait at the meter then pass to first sensor + + -- Reduce the count of vehicles on the queue + Ramp_31.Subtract_Meter_Queue; + exception + when others => + Report.Failed ("Unexpected Exception in Vehicle_2 task"); + end Vehicle_2; + + + + begin + null; + end; -- encapsulation + + if Ramp_31.TC_Failed then + Report.Failed ("Concurrent Running detected"); + end if; + + Report.Result; + + end C951001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c951002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c951002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c951002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c951002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- C951002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an entry and a procedure within the same protected object + -- will not be executed simultaneously. + -- + -- TEST DESCRIPTION: + -- Two tasks are used. The first calls an entry who's barrier is set + -- and is thus queued. The second calls a procedure in the same + -- protected object. This procedure clears the entry barrier of the + -- first then executes a lengthy compute bound procedure. This is + -- intended to allow a multiprocessor, or a time-slicing implementation + -- of a uniprocessor, to (erroneously) permit the first task to continue + -- while the second is still computing. Flags in each process in the + -- PO are checked to ensure that they do not run out of sequence or in + -- parallel. + -- In the second part of the test another entry and procedure are used + -- but in this case the procedure is started first. A different task + -- calls the entry AFTER the procedure has started. If the entry + -- completes before the procedure the test fails. + -- + -- This test will not be effective on a uniprocessor without time-slicing + -- It is designed to increase the chances of failure on a multiprocessor, + -- or a uniprocessor with time-slicing, if the entry and procedure in a + -- Protected Object are not forced to acquire a single execution + -- resource. It is not guaranteed to fail. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + procedure C951002 is + + -- These global error flags are used for failure conditions within + -- the protected object. We cannot call Report.Failed (thus Text_io) + -- which would result in a bounded error. + -- + TC_Error_01 : Boolean := false; + TC_Error_02 : Boolean := false; + TC_Error_03 : Boolean := false; + TC_Error_04 : Boolean := false; + TC_Error_05 : Boolean := false; + TC_Error_06 : Boolean := false; + + begin + + Report.Test ("C951002", "Check that a procedure and an entry body " & + "in a protected object will not run concurrently"); + + declare -- encapsulate the test + + task Credit_Message is + entry TC_Start; + end Credit_Message; + + task Credit_Task is + entry TC_Start; + end Credit_Task; + + task Debit_Message is + entry TC_Start; + end Debit_Message; + + task Debit_Task is + entry TC_Start; + end Debit_Task; + + --==================================== + + protected Hold is + + entry Wait_for_CR_Underload; + procedure Clear_CR_Overload; + entry Wait_for_DB_Underload; + procedure Set_DB_Overload; + procedure Clear_DB_Overload; + -- + function TC_Message_is_Queued return Boolean; + + private + Credit_Overloaded : Boolean := true; -- Test starts in overload + Debit_Overloaded : Boolean := false; + -- + TC_CR_Proc_Finished : Boolean := false; + TC_CR_Entry_Finished : Boolean := false; + TC_DB_Proc_Finished : Boolean := false; + TC_DB_Entry_Finished : Boolean := false; + end Hold; + --==================== + protected body Hold is + + entry Wait_for_CR_Underload when not Credit_Overloaded is + begin + -- The barrier must only be re-evaluated at the end of the + -- of the execution of the procedure, also while the procedure + -- is executing this entry body must not be executed + if not TC_CR_Proc_Finished then + TC_Error_01 := true; -- Set error indicator + end if; + TC_CR_Entry_Finished := true; + end Wait_for_CR_Underload ; + + -- This is the procedure which should NOT be able to run in + -- parallel with the entry body + -- + procedure Clear_CR_Overload is + begin + + -- The entry body must not be executed until this procedure + -- is completed. + if TC_CR_Entry_Finished then + TC_Error_02 := true; -- Set error indicator + end if; + Credit_Overloaded := false; -- clear the entry barrier + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task. + -- + ImpDef.Exceed_Time_Slice; + + -- Again, the entry body must not be executed until the current + -- procedure is completed. + -- + if TC_CR_Entry_Finished then + TC_Error_03 := true; -- Set error indicator + end if; + TC_CR_Proc_Finished := true; + + end Clear_CR_Overload; + + --============ + -- The following subprogram and entry body are used in the second + -- part of the test + + entry Wait_for_DB_Underload when not Debit_Overloaded is + begin + -- By the time the task that calls this entry is allowed access to + -- the queue the barrier, which starts off as open, will be closed + -- by the Set_DB_Overload procedure. It is only reopened + -- at the end of the test + if not TC_DB_Proc_Finished then + TC_Error_04 := true; -- Set error indicator + end if; + TC_DB_Entry_Finished := true; + end Wait_for_DB_Underload ; + + + procedure Set_DB_Overload is + begin + -- The task timing is such that this procedure should be started + -- before the entry is called. Thus the entry should be blocked + -- until the end of this procedure which then sets the barrier + -- + if TC_DB_Entry_Finished then + TC_Error_05 := true; -- Set error indicator + end if; + + -- Execute an implementation defined compute bound routine which + -- is designed to run long enough to allow a task switch on a + -- time-sliced uniprocessor, or for a multiprocessor to pick up + -- another task + -- + ImpDef.Exceed_Time_Slice; + + Debit_Overloaded := true; -- set the entry barrier + + if TC_DB_Entry_Finished then + TC_Error_06 := true; -- Set error indicator + end if; + TC_DB_Proc_Finished := true; + + end Set_DB_Overload; + + procedure Clear_DB_Overload is + begin + Debit_Overloaded := false; -- open the entry barrier + end Clear_DB_Overload; + + function TC_Message_is_Queued return Boolean is + begin + + -- returns true when one message arrives on the queue + return (Wait_for_CR_Underload'Count = 1); + + end TC_Message_is_Queued ; + + end Hold; + + --==================================== + + task body Credit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Credit + -- application. This message task queues itself on a queue + -- waiting till the overload in no longer in effect + Hold.Wait_for_CR_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Message Task"); + end Credit_Message; + + task body Credit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Clear_CR_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Credit_Task"); + end Credit_Task; + + --============== + + -- The following two tasks are used in the second part of the test + + task body Debit_Message is + begin + accept TC_Start; + --:: some application processing. Part of the process finds that + -- the Overload threshold has been exceeded for the Debit + -- application. This message task queues itself on a queue + -- waiting till the overload is no longer in effect + -- + Hold.Wait_for_DB_Underload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Message Task"); + end Debit_Message; + + task body Debit_Task is + begin + accept TC_Start; + -- Application code here (not shown) determines that the + -- underload threshold has been reached + Hold.Set_DB_Overload; + exception + when others => + Report.Failed ("Unexpected Exception in Debit_Task"); + end Debit_Task; + + begin -- declare + + Credit_Message.TC_Start; + + -- Wait until the message is queued on the entry before starting + -- the Credit_Task + while not Hold.TC_Message_is_Queued loop + delay ImpDef.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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- C953001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the evaluation of an entry_barrier condition + -- propagates an exception, the exception Program_Error + -- is propagated to all current callers of all entries of the + -- protected object. + -- + -- TEST DESCRIPTION: + -- This test declares a protected object (PO) with two entries and + -- a 5 element entry family. + -- All the entries are always closed. However, one of the entries + -- (Oh_No) will get a constraint_error in its barrier_evaluation + -- whenever the global variable Blow_Up is true. + -- An array of tasks is created where the tasks wait on the various + -- entries of the protected object. Once all the tasks are waiting + -- the main procedure calls the entry Oh_No and causes an exception + -- to be propagated to all the tasks. The tasks record the fact + -- that they got the correct exception in global variables that + -- can be checked after the tasks complete. + -- + -- + -- CHANGE HISTORY: + -- 19 OCT 95 SAIC ACVC 2.1 + -- + --! + + + with Report; + with ImpDef; + procedure C953001 is + Verbose : constant Boolean := False; + Max_Tasks : constant := 12; + + -- note status and error conditions + Blocked_Entry_Taken : Boolean := False; + In_Oh_No : Boolean := False; + Task_Passed : array (1..Max_Tasks) of Boolean := (1..Max_Tasks => False); + + begin + Report.Test ("C953001", + "Check that an exception in an entry_barrier condition" & + " causes Program_Error to be propagated to all current" & + " callers of all entries of the protected object"); + + declare -- test encapsulation + -- miscellaneous values + Cows : Integer := Report.Ident_Int (1); + Came_Home : Integer := Report.Ident_Int (2); + + -- make the Barrier_Condition fail only when we want it to + Blow_Up : Boolean := False; + + function Barrier_Condition return Boolean is + begin + if Blow_Up then + return 5 mod Report.Ident_Int(0) = 1; + else + return False; + end if; + end Barrier_Condition; + + subtype Family_Index is Integer range 1..5; + + protected PO is + entry Block1; + entry Oh_No; + entry Family (Family_Index); + end PO; + + protected body PO is + entry Block1 when Report.Ident_Int(0) = Report.Ident_Int(1) is + begin + Blocked_Entry_Taken := True; + end Block1; + + -- barrier will get a Constraint_Error (divide by 0) + entry Oh_No when Barrier_Condition is + begin + In_Oh_No := True; + end Oh_No; + + entry Family (for Member in Family_Index) when Cows = Came_Home is + begin + Blocked_Entry_Taken := True; + end Family; + end PO; + + + task type Waiter is + entry Take_Id (Id : Integer); + end Waiter; + + Bunch_of_Waiters : array (1..Max_Tasks) of Waiter; + + task body Waiter is + Me : Integer; + Action : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + + Action := Me mod (Family_Index'Last + 1); + begin + if Action = 0 then + PO.Block1; + else + PO.Family (Action); + end if; + Report.Failed ("no exception for task" & Integer'Image (Me)); + exception + when Program_Error => + Task_Passed (Me) := True; + if Verbose then + Report.Comment ("pass for task" & Integer'Image (Me)); + end if; + when others => + Report.Failed ("wrong exception raised in task" & + Integer'Image (Me)); + end; + end Waiter; + + + begin -- test encapsulation + for I in 1..Max_Tasks loop + Bunch_Of_Waiters(I).Take_Id (I); + end loop; + + -- give all the Waiters time to get queued + delay 2*ImpDef.Clear_Ready_Queue; + + -- cause the protected object to fail + begin + Blow_Up := True; + PO.Oh_No; + Report.Failed ("no exception in call to PO.Oh_No"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error instead of Program_Error"); + when Program_Error => + if Verbose then + Report.Comment ("main exception passed"); + end if; + when others => + Report.Failed ("wrong exception in main"); + end; + end; -- test encapsulation + + -- all the tasks have now completed. + -- check the flags for pass/fail info + if Blocked_Entry_Taken then + Report.Failed ("blocked entry taken"); + end if; + if In_Oh_No then + Report.Failed ("entry taken with exception in barrier"); + end if; + for I in 1..Max_Tasks loop + if not Task_Passed (I) then + Report.Failed ("task" & Integer'Image (I) & " did not pass"); + end if; + end loop; + + Report.Result; + end C953001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- C953002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the servicing of entry queues of a protected object + -- continues until there are no open entries with queued calls + -- and that this takes place as part of a single protected + -- operation. + -- + -- TEST DESCRIPTION: + -- This test enqueues a bunch of tasks on the entries of the + -- protected object Main_PO. At the same time another bunch of + -- of tasks are queued on the single entry of protected object + -- Holding_Pen. + -- Once all the tasks have had time to block, the main procedure + -- opens all the entries for Main_PO by calling the + -- Start_Protected_Operation protected procedure. This should + -- process all the pending callers as part of a single protected + -- operation. + -- During this protected operation, the entries of Main_PO release + -- the tasks blocked on Holding_Pen by calling the protected + -- procedure Release. + -- Once released from Holding_Pen, the task immediately calls + -- an entry in Main_PO. + -- These new calls should not gain access to Main_PO until + -- the initial protected operation on that object completes. + -- The order in which the entry calls on Main_PO are taken is + -- recorded in a global array and checked after all the tasks + -- have terminated. + -- + -- + -- CHANGE HISTORY: + -- 25 OCT 95 SAIC ACVC 2.1 + -- 15 JAN 95 SAIC Fixed deadlock problem. + -- + --! + + with Report; + procedure C953002 is + Verbose : constant Boolean := False; + + Half_Tasks : constant := 15; -- how many tasks of each group + Max_Tasks : constant := Half_Tasks * 2; -- total number of tasks + + Note_Order : array (1..Max_Tasks) of Integer := (1..Max_Tasks => 0); + Note_Cnt : Integer := 0; + begin + Report.Test ("C953002", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + First_Wave : array (1 .. Half_Tasks) of Assault_PO; + Second_Wave : array (1 .. Half_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + entry E1 (Who : Integer); + entry E2 (Who : Integer); + entry E3 (Who : Integer); + entry All_Present; + procedure Start_Protected_Operation; + private + Open : Boolean := False; + end Main_PO; + + protected Holding_Pen is + -- Note that Release is called by tasks executing in + -- the protected object Main_PO. + entry Wait (Who : Integer); + entry All_Present; + procedure Release; + private + Open : Boolean := False; + end Holding_Pen; + + + protected body Main_PO is + procedure Start_Protected_Operation is + begin + Open := True; + -- at this point all the First_Wave tasks are + -- waiting at the entries and all of them should + -- be processed as part of the protected operation. + end Start_Protected_Operation; + + entry All_Present when E0'Count + E1'Count + E2'Count + E3'Count = + Max_Tasks / 2 is + begin + null; -- all tasks are waiting + end All_Present; + + entry E0 (Who : Integer) when Open is + begin + Holding_Pen.Release; + -- note the order in which entry calls are handled. + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E0; + + entry E1 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E1; + + entry E2 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E2; + + entry E3 (Who : Integer) when Open is + begin + Holding_Pen.Release; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + end E3; + end Main_PO; + + + protected body Holding_Pen is + procedure Release is + begin + Open := True; + end Release; + + entry All_Present when Wait'Count = Max_Tasks / 2 is + begin + null; -- all tasks waiting + end All_Present; + + entry Wait (Who : Integer) when Open is + begin + null; -- unblock the task + end Wait; + end Holding_Pen; + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + if Me >= 200 then + Holding_Pen.Wait (Me); + end if; + case Me mod 4 is + when 0 => Main_PO.E0 (Me); + when 1 => Main_PO.E1 (Me); + when 2 => Main_PO.E2 (Me); + when 3 => Main_PO.E3 (Me); + when others => null; -- cant happen + end case; + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in First_Wave'Range loop + First_Wave (I).Take_ID (100 + I); + end loop; + for I in Second_Wave'Range loop + Second_Wave (I).Take_ID (200 + I); + end loop; + + -- let all the tasks get blocked + Main_PO.All_Present; + Holding_Pen.All_Present; + + -- let the games begin + if Verbose then + Report.Comment ("starting protected operation"); + end if; + Main_PO.Start_Protected_Operation; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + -- check the order in which entries were handled. + -- all the 100 level items should be handled as part of the + -- first protected operation and thus should be completed + -- before any 200 level item. + + if Verbose then + for I in 1..Max_Tasks loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + for I in 2 .. Max_Tasks loop + if Note_Order (I) < 200 and + Note_Order (I-1) >= 200 then + Report.Failed ("protected operation failure" & + Integer'Image (Note_Order (I-1)) & + Integer'Image (Note_Order (I))); + end if; + end loop; + + Report.Result; + end C953002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c953003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c953003.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C953003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the servicing of entry queues of a protected object + -- continues until there are no open entries with queued (or + -- requeued) calls and that internal requeues are handled + -- as part of a single protected operation. + -- + -- TEST DESCRIPTION: + -- A number of tasks are created and blocked on a protected object + -- so that they can all be released at one time. When released, + -- these tasks make an entry call to an entry in the Main_PO + -- protected object. As part of the servicing of this entry + -- call the call is passed through the remaining entries of the + -- protected object by using internal requeues. The protected + -- object checks that no other entry call is accepted until + -- after all the internal requeuing has completed. + -- + -- + -- CHANGE HISTORY: + -- 12 JAN 96 SAIC Initial version for 2.1 + -- + --! + + with Report; + procedure C953003 is + Verbose : constant Boolean := False; + + Order_Error : Boolean := False; + + Max_Tasks : constant := 10; -- total number of tasks + Max_Entries : constant := 4; -- number of entries in Main_PO + Note_Cnt : Integer := 0; + Note_Order : array (1..Max_Tasks*Max_Entries) of Integer; + begin + Report.Test ("C953003", + "Check that the servicing of entry queues handles all" & + " open entries as part of a single protected operation," & + " including those resulting from an internal requeue"); + declare + task type Assault_PO is + entry Take_ID (Id : Integer); + end Assault_PO; + + Marines : array (1 .. Max_Tasks) of Assault_PO; + + protected Main_PO is + entry E0 (Who : Integer); + private + entry E3 (Who : Integer); + entry E2 (Who : Integer); + entry E1 (Who : Integer); + Expected_Next : Integer := 0; + end Main_PO; + + + protected body Main_PO is + + entry E0 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 0; + Expected_Next := 1; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E1; + end E0; + + entry E1 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 1; + Expected_Next := 2; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E2; + end E1; + + entry E3 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 3; + Expected_Next := 0; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + -- all done - return now + end E3; + + entry E2 (Who : Integer) when True is + begin + Order_Error := Order_Error or Expected_Next /= 2; + Expected_Next := 3; + Note_Cnt := Note_Cnt + 1; + Note_Order (Note_Cnt) := Who; + requeue E3; + end E2; + end Main_PO; + + protected Holding_Pen is + entry Wait_For_All_Present; + entry Wait; + private + Open : Boolean := False; + end Holding_Pen; + + protected body Holding_Pen is + entry Wait_For_All_Present when Wait'Count = Max_Tasks is + begin + Open := True; + end Wait_For_All_Present; + + entry Wait when Open is + begin + null; -- just go + end Wait; + end Holding_Pen; + + + task body Assault_PO is + Me : Integer; + begin + accept Take_Id (Id : Integer) do + Me := Id; + end Take_Id; + Holding_Pen.Wait; + Main_PO.E0 (Me); + if Verbose then + Report.Comment ("task" & Integer'Image (Me) & + " done"); + end if; + exception + when others => + Report.Failed ("exception in task"); + end Assault_PO; + + begin -- test encapsulation + for I in Marines'Range loop + Marines (I).Take_ID (100 + I); + end loop; + + -- let all the tasks get blocked so we can release them all + -- at one time + Holding_Pen.Wait_For_All_Present; + + -- wait for all the tasks to complete + if Verbose then + Report.Comment ("waiting for tasks to complete"); + end if; + end; + + -- make sure all tasks registered their order + if Note_Cnt /= Max_Tasks * Max_Entries then + Report.Failed ("task registration count wrong. " & + Integer'Image (Note_Cnt)); + end if; + + if Order_Error then + Report.Failed ("internal requeue not handled as part of operation"); + end if; + + if Verbose or Order_Error then + for I in 1..Max_Tasks * Max_Entries loop + Report.Comment ("order" & Integer'Image (I) & " is" & + Integer'Image (Note_Order (I))); + end loop; + end if; + + Report.Result; + end C953003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,273 ---- + -- C954001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue statement within an entry_body with parameters + -- may requeue the entry call to a protected entry with a subtype- + -- conformant parameter profile. Check that, if the call is queued on the + -- new entry's queue, the original caller remains blocked after the + -- requeue, but the entry_body containing the requeue is completed. + -- + -- TEST DESCRIPTION: + -- Declare a protected object which simulates a disk device. Declare an + -- entry that requeues the caller to a second entry if the disk head is + -- not in the proper location, but first sets the second entry's barrier + -- to false. Declare a procedure which sets the second entry's barrier + -- to true. + -- + -- Declare a task which calls the first entry such that the requeue is + -- called. This task should be queued on the second entry and remain + -- blocked, and the first entry should be complete. Call the procedure + -- which releases the second entry's queue. The second entry should + -- complete, after which the task should complete. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C954001_0 is -- Disk management abstraction. + + + -- Simulate a read-only disk device with a head that may be moved to + -- different tracks. If a read request is issued for the current + -- track, the request can be satisfied immediately. Otherwise, the head + -- must be moved to the correct track, during which time the calling task + -- is blocked. When the head reaches the correct track, the disk generates + -- an interrupt, after which the request can be satisfied, and the + -- calling task can proceed. + + Buffer_Size : constant := 100; + + type Disk_Buffer is new String (1 .. Buffer_Size); + type Disk_Track is new Natural; + + type Disk_Address is record + Track : Disk_Track; + -- Additional components. + end record; + + Initial_Track : constant Disk_Track := 0; + New_Track : constant Disk_Track := 5; + + --==============================================-- + + protected Disk_Device is + + entry Read (Where : Disk_Address; -- Read data from disk + Data : out Disk_Buffer); -- track. + + procedure Disk_Interrupt; -- Handle interrupt + -- from disk. + + function TC_Track return Disk_Track; -- Return current track. + + function TC_Pending_Queued return Boolean; -- True when there is + -- an entry in queue + + private + + entry Pending_Read (Where : Disk_Address; -- Wait for head to + Data : out Disk_Buffer); -- move then read data. + + Current_Track : Disk_Track := Initial_Track; -- Current disk track. + Operation_Pending : Boolean := False; -- Vis. entry barrier. + Disk_Interrupted : Boolean := False; -- Priv. entry barrier. + + end Disk_Device; + + + end C954001_0; + + + --==================================================================-- + + + package body C954001_0 is -- Disk management abstraction. + + + protected body Disk_Device is + + entry Read (Where : Disk_Address; Data : out Disk_Buffer) + when not Operation_Pending is + begin + if (Where.Track = Current_Track) then -- If the head is over the + -- Read data from disk... -- requested track, read + null; -- the data. + + else -- Otherwise, defer read + Operation_Pending := True; -- while head is moved to + -- correct track (signaled + -- -- -- by a disk interrupt). + -- Requeue is tested here -- + -- -- + + requeue Pending_Read; + + end if; + end Read; + + + procedure Disk_Interrupt is -- Called when the disk + begin -- interrupts, indicating + Disk_Interrupted := True; -- that the head is over + end Disk_Interrupt; -- the correct track. + + + function TC_Track return Disk_Track is -- Artifice required for + begin -- testing purposes. + return (Current_Track); + end TC_Track; + + + entry Pending_Read (Where : Disk_Address; Data : out Disk_Buffer) + when Disk_Interrupted is + begin + Current_Track := Where.Track; -- Head is now over the + -- Read data from disk... -- correct track; read + Operation_Pending := False; -- the data. + Disk_Interrupted := False; + end Pending_Read; + + function TC_Pending_Queued return Boolean is + begin + -- Return true when there is something on the Pending_Read queue + return (Pending_Read'Count /=0); + end TC_Pending_Queued; + + end Disk_Device; + + + end C954001_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with C954001_0; -- Disk management abstraction. + use C954001_0; + + procedure C954001 is + + + task type Read_Task is -- an unusual (but legal) declaration + end Read_Task; + -- + -- + task body Read_Task is + Location : constant Disk_Address := (Track => New_Track); + Data : Disk_Buffer := (others => ' '); + begin + Disk_Device.Read (Location, Data); -- Invoke requeue statement. + exception + when others => + Report.Failed ("Exception raised in task"); + end Read_Task; + + --==============================================-- + + begin -- Main program. + + Report.Test ("C954001", "Requeue from an entry within a P.O. " & + "to a private entry within the same P.O."); + + + declare + + IO_Request : Read_Task; -- Request a read from other + -- than the current track. + -- IO_Request will be requeued + -- from Read to Pending_Read. + begin + + -- To pass this test, the following must be true: + -- + -- (A) The Read entry call made by the task IO_Request must be + -- completed by the requeue. + -- (B) IO_Request must remain blocked following the requeue. + -- (C) IO_Request must be queued on the Pending_Read entry queue. + -- (D) IO_Request must continue execution after the Pending_Read + -- entry completes. + -- + -- First, verify (A): that the Read entry call is complete. + -- + -- Call a protected operation (Disk_Device.TC_Track). Since no two + -- protected actions may proceed concurrently unless both are protected + -- function calls, a call to a protected operation at this point can + -- proceed only if the Read entry call is already complete. + -- + -- Note that if Read is NOT complete, the test will likely hang here. + -- + -- Next, verify (B): that IO_Request remains blocked following the + -- requeue. Also verify that Pending_Read (the entry to which + -- IO_Request should have been queued) has not yet executed. + + -- Wait until the task had made the call and the requeue has been + -- effected. + while not Disk_Device.TC_Pending_Queued loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Disk_Device.TC_Track /= Initial_Track then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif IO_Request'Terminated then + Report.Failed ("Caller did not remain blocked after " & + "the requeue or was never requeued"); + else + + -- Verify (C): that IO_Request is queued on the + -- Pending_Read entry queue. + -- + -- Set the barrier for Pending_Read to true. Check that the + -- current track is updated and that IO_Request terminates. + + Disk_Device.Disk_Interrupt; -- Simulate a disk interrupt, + -- signaling that the head is + -- over the correct track. + + -- The Pending_Read entry body will complete before the next + -- protected action is called (Disk_Device.TC_Track). + + if Disk_Device.TC_Track /= New_Track then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Read_Task continues after Pending_Read + -- completes. + -- + -- Note that the test will hang here if Read_Task does not continue + -- executing following the completion of the requeued entry call. + + end if; + + end; -- We will not exit the declare block until the task completes + + Report.Result; + + end C954001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954010.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,286 ---- + -- C954010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue within an accept statement does not block. + -- This test uses: Requeue to an entry in a different task + -- Parameterless call + -- Requeue with abort + -- + -- TEST DESCRIPTION: + -- In the Distributor task, requeue two successive calls on the entries + -- of two separate target tasks. Verify that the target tasks are + -- run in parallel proving that the first requeue does not block + -- while the first target rendezvous takes place. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, + -- dynamic and unpredictable at the time of message generation. All + -- rerouting in this model is done by means of requeues. + -- + -- This test is directed towards the BLOCKING of the REQUEUE only + -- If the original caller does not block, the outcome of the test will + -- not be affected. If the original caller does not continue after + -- the return, the test will not pass. + -- If the requeue gets placed on the wrong entry a failing test could + -- pass (eg. if the first message is delivered to the second + -- computation task and the second message to the first) - a check for + -- this condition is made in other tests + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + procedure C954010 is + + -- Mechanism to count the number of Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + -- + TC_Expected_To_Complete : constant integer := 2; + + + task type Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input; + end Distributor; + + task Credit_Computation is + entry Input; + end Credit_Computation; + + task Debit_Computation is + entry Input; + entry TC_Artificial_Rendezvous_1; -- test purposes only + entry TC_Artificial_Rendezvous_2; -- test purposes only + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each and sends this to a Distributor + -- for appropriate disposal around the network of tasks + -- Such a task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop + declare + -- create a new message task + N : acc_Message_Task := new Message_Task; + begin + -- preparation code + null; -- stub + + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + task body Message_Task is + begin + -- Queue up on Distributor's Input queue + Distributor.Input; + + -- After the required computations have been performed + -- return the message appropriately (probably to an output + -- line driver + null; -- stub + + -- Increment to show completion of this task + TC_Tasks_Completed.Increment; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + -- Dispose each input message to the appropriate computation tasks + -- Normally this would be according to some parameters in the entry + -- but this simple test is using parameterless entries. + -- + task body Distributor is + Last_was_for_Credit_Computation : Boolean := false; -- switch + begin + loop + select + accept Input do + -- Determine to which task the message should be + -- distributed + -- For this test arbitrarily send the first to + -- Credit_Computation and the second to Debit_Computation + if Last_was_for_Credit_Computation then + requeue Debit_Computation.Input with abort; + else + Last_was_for_Credit_Computation := true; + requeue Credit_Computation.Input with abort; + end if; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + begin + loop + select + accept Input do + -- Perform the computations required for this message + -- + null; -- stub + + -- For the test: + -- Artificially rendezvous with Debit_Computation. + -- If the first requeue in Distributor has blocked + -- waiting for the current rendezvous to complete then the + -- second message will not be sent to Debit_Computation + -- which will still be waiting on its Input accept. + -- This task will HANG + -- + Debit_Computation.TC_Artificial_Rendezvous_1; + -- + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + TC_AR1_is_complete : Boolean := false; + begin + loop + select + accept Input do + -- Perform the computations required for this message + null; -- stub + end Input; + Message_Count := Message_Count + 1; + or + -- Guard until the rendezvous with the message for this task + -- has completed + when Message_Count > 0 => + accept TC_Artificial_Rendezvous_1; -- see comments in + -- Credit_Computation above + TC_AR1_is_complete := true; + or + -- Completion rendezvous with the main procedure + when TC_AR1_is_complete => + accept TC_Artificial_Rendezvous_2; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- c954010 + Report.Test ("C954010", "Requeue in an accept body does not block"); + + Line_Driver.Start; + + -- Ensure that both messages were delivered to the computation tasks + -- This shows that both requeues were effective. + -- + Debit_Computation.TC_Artificial_Rendezvous_2; + + -- Ensure that the message tasks completed + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954011.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,384 ---- + -- C954011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue is placed on the correct entry; that the + -- original caller waits for the completion of the requeued rendezvous; + -- that the original caller continues after the rendezvous. + -- Specifically, this test checks requeue to an entry in a different + -- task, requeue where the entry has parameters, and requeue with + -- abort. + -- + -- TEST DESCRIPTION: + -- In the Distributor task, requeue two successive calls on the entries + -- of two separate target tasks. Each task in each of the paths adds + -- identifying information in the transaction being passed. This + -- information is checked by the Message tasks on completion ensuring that + -- the requeues have been placed on the correct queues. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, + -- dynamic and unpredictable at the time of message generation. All + -- rerouting in this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Nov 95 SAIC Fixed problems with shared global variables + -- for ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954011 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + protected type Message_Mgr is + procedure Mark_Complete; + function Is_Complete return Boolean; + private + Complete : Boolean := False; + end Message_Mgr; + + protected body Message_Mgr is + procedure Mark_Complete is + begin + Complete := True; + end Mark_Complete; + + Function Is_Complete return Boolean is + begin + return Complete; + end Is_Complete; + end Message_Mgr; + + TC_Debit_Message : Message_Mgr; + TC_Credit_Message : Message_Mgr; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Mark_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Mark_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Mark the message as having passed through the distributor + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- c954011 + + Report.Test ("C954011", "Requeue from task body to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Is_Complete and + TC_Debit_Message.Is_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954012.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,496 ---- + -- C954012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check a requeue within an accept body to another entry in the same task + -- Specifically, check a call with parameters and a requeue with abort. + -- + -- TEST DESCRIPTION: + -- One transaction is sent through to check the paths. After + -- processing this the Credit task sets the "overloaded" indicator. Once + -- this indicator is set the Distributor queues low priority transactions + -- on a Wait_for_Underload queue in the same task using a requeue. The + -- Distributor still delivers high priority transactions. After two high + -- priority transactions have been processed by the Credit task it clears + -- the overload condition. The low priority transactions should now be + -- delivered. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Nov 95 SAIC Fixed shared global variable problem for + -- ACVC 2.0.1 + -- 14 Mar 03 RLB Fixed a race condition and an incorrect termination + -- condition in the test. + --! + + with Report; + with ImpDef; + with Ada.Calendar; + + procedure C954012 is + + function "=" (X,Y: Ada.Calendar.Time) return Boolean + renames Ada.Calendar."="; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- This is used as an "initializing" time for the messages as they are + -- created. As they pass through the Distributor they get a time_stamp + -- of the current time. An arbitrary base time is chosen. + -- TC: this fact is used, incidentally, to check that the messages have, + -- indeed, passed through the Distributor as expected. + -- + Base_Time : Ada.Calendar.Time := Ada.Calendar.Time_of(1959,3,9); + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + -- Handshaking mechanism between the Line Driver and the Credit task + TC_First_Message_Has_Arrived : Shared_Boolean (False); + Credit_Overloaded : Shared_Boolean (False); + + TC_Credit_Messages_Expected : constant integer := 5; + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + Message_Count : integer := 0; -- for test + Time_Stamp : Ada.Calendar.Time := Base_Time; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input (Transaction : acc_Transaction_Record); + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + entry TC_Credit_OK; + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_First_Message_Has_Arrived.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + -- TC: Wait for Credit_Overloaded to be cleared, then insure that the + -- Distributor has evalated all tasks. Otherwise, some tasks may never + -- be evaluated. + while Credit_Overloaded.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + Distributor.TC_Credit_OK; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.Message_Count /= 1 or + This_Transaction.Time_Stamp = Base_Time then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Time_Stamp the messages with the current time + -- TC: Used, incidentally, by the test to check that the + -- message did pass through the Distributor Task + Transaction.Time_Stamp := Ada.Calendar.Clock; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded.Value and + Transaction.Priority = Low then + requeue Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + when not Credit_Overloaded.Value => + accept Wait_for_Underload (Transaction : acc_Transaction_Record) do + requeue Credit_Computation.Input with abort; + end Wait_for_Underload; + or + accept TC_Credit_OK; + -- We need this to insure that we evaluate the guards at least + -- once when Credit_Overloaded is False. Otherwise, tasks + -- could stay queued on Wait_for_Underload forever (starvation). + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Credit_Overloaded.Value and + Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Distributor's Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Credit_Overloaded.Set_True; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_First_Message_Has_Arrived.Set_True; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Credit_Overloaded.Set_False; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if Transaction.Time_Stamp = Base_Time then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- c954012 + Report.Test ("C954012", "Requeue within an accept body" & + " to another entry in the same task"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + or (not TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954013.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,521 ---- + -- C954013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue is cancelled and that the requeuing task is + -- unaffected when the calling task is aborted. + -- Specifically, check requeue to an entry in a different task, + -- requeue where the entry has parameters, and requeue with abort. + -- + -- TEST DESCRIPTION: + -- Abort a task that has a call requeued to the entry queue of another + -- task. We do this by sending two messages to the Distributor which + -- requeues them to the Credit task. In the accept body of the Credit + -- task we wait for the second message to arrive then check that an + -- abort of the second message task does result in the requeue being + -- removed. The Line Driver task which generates the messages and the + -- Credit task communicate artificially in this test to arrange for the + -- proper timing of the messages and the abort. One extra message is + -- sent to the Debit task to ensure that the Distributor is still viable + -- and has been unaffected by the abort. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Nov 95 SAIC Fixed shared global variable problems for + -- ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954013 is + + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + TC_Credit_Message_Complete : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- This protected object is here for Test Control purposes only + protected TC_Prt is + procedure Set_First_Has_Arrived; + procedure Set_Second_Has_Arrived; + procedure Set_Abort_Has_Completed; + function First_Has_Arrived return Boolean; + function Second_Has_Arrived return Boolean; + function Abort_Has_Completed return Boolean; + private + First_Flag, Second_Flag, Abort_Flag : Boolean := false; + end TC_Prt; + + protected body TC_Prt is + + Procedure Set_First_Has_Arrived is + begin + First_Flag := true; + end Set_First_Has_Arrived; + + Procedure Set_Second_Has_Arrived is + begin + Second_Flag := true; + end Set_Second_Has_Arrived; + + Procedure Set_Abort_Has_Completed is + begin + Abort_Flag := true; + end Set_Abort_Has_Completed; + + Function First_Has_Arrived return boolean is + begin + return First_Flag; + end First_Has_Arrived; + + Function Second_Has_Arrived return boolean is + begin + return Second_Flag; + end Second_has_Arrived; + + Function Abort_Has_Completed return boolean is + begin + return Abort_Flag; + end Abort_Has_Completed; + + end TC_PRT; + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to three dummy messages for this test and use + -- special artificial checks to pace the messages out under controlled + -- conditions for the test; allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..3 loop -- TC: arbitrarily limit to two credit messages + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message to start up the Credit task + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + elsif not TC_Prt.Abort_Has_Completed then + -- We have not yet processed the second message + -- Wait to send the second message until we know the first + -- has arrived at the Credit task and that task is in the + -- accept body + while not TC_Prt.First_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- We can now send the second message + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + + -- Now wait for the second to arrive on the Credit input queue + while not TC_Prt.Second_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point: The Credit task is in the accept block + -- dealing with the first message and the second message is + -- is on the input queue + abort Next_Message_Task.all; -- Note: we are still in the + -- declare block for the + -- second message task + + -- Make absolutely certain that all the actions + -- associated with the abort have been completed, that the + -- task has gone from Abnormal right through to + -- Termination. All requeues that are to going to be + -- cancelled will have been by the point of Termination. + while not Next_Message_Task.all'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- We now signal the Credit task that the abort has taken place + -- so that it can check that the entry queue is empty as the + -- requeue should have been cancelled + TC_Prt.Set_Abort_Has_Completed; + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the cancellation of the requeue. + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message_Complete.Set_True; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that this message did pass through the Distributor Task + Transaction.TC_Thru_Dist := true; + + -- Pass this transaction on the the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not cancelled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- first message has arrived and the Line Driver may now send + -- the second one + TC_Prt.Set_First_Has_Arrived; + + -- Now wait for the second to arrive + + while Input'Count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Second message has been requeued - the Line driver may + -- now abort the calling task + TC_Prt.Set_Second_Has_Arrived; + + -- Now wait for the Line Driver to signal that the abort of + -- the first task is complete - the requeue should be cancelled + -- at this time + while not TC_Prt.Abort_Has_Completed loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + if Input'Count /=0 then + Report.Failed ("Aborted Requeue was not cancelled -2"); + end if; + -- We can now complete the rendezvous with the first caller + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- c954013 + + Report.Test ("C954013", "Abort a task that has a call requeued"); + + Line_Driver.Start; -- start the test + + -- Wait for the message tasks to complete before calling Report.Result. + -- Although two Credit tasks are generated one is aborted so only + -- one completes, thus a single flag is sufficient + -- Note: the test will hang here if there is a problem with the + -- completion of the tasks + while not (TC_Credit_Message_Complete.Value and + TC_Debit_Message_Complete.Value) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954014.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,485 ---- + -- C954014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue is not canceled and that the requeueing + -- task is unaffected when a calling task is aborted. Check that the + -- abort is deferred until the entry call is complete. + -- Specifically, check requeue to an entry in a different task, + -- requeue where the entry call has parameters, and requeue + -- without the abort option. + -- + -- TEST DESCRIPTION + -- In the Driver create a task that places a call on the + -- Distributor. In the Distributor requeue this call on the Credit task. + -- Abort the calling task when it is known to be in rendezvous with the + -- Credit task. (We arrange this by using artificial synchronization + -- points in the Driver and the accept body of the Credit task) Ensure + -- that the abort is deferred (the task is not terminated) until the + -- accept body completes. Afterwards, send one extra message through + -- the Distributor to check that the requeueing task has not been + -- disrupted. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Nov 95 SAIC Replaced global variables with protected objects + -- for ACVC 2.0.1. + -- + --! + + with Report; + with ImpDef; + + procedure C954014 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + + TC_Debit_Message_Complete : Shared_Boolean (False); + + -- Synchronization flags for handshaking between the Line_Driver + -- and the Accept body in the Credit Task + TC_Handshake_A : Shared_Boolean (False); + TC_Handshake_B : Shared_Boolean (False); + TC_Handshake_C : Shared_Boolean (False); + TC_Handshake_D : Shared_Boolean (False); + TC_Handshake_E : Shared_Boolean (False); + TC_Handshake_F : Shared_Boolean (False); + + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- TC: The Line Driver task would normally be designed to loop + -- continuously creating the messages as input is received. Simulate + -- this but limit it to two dummy messages for this test and use + -- special artificial handshaking checks with the Credit accept body + -- to control the test. Allow it to terminate at the end + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_First_message_sent: Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from main + + for i in 1..2 loop -- TC: arbitrarily limit to one credit message + -- and one debit, then complete + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if not TC_First_Message_Sent then + -- send out the first message which will be aborted + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + TC_First_Message_Sent := true; + + -- Wait for Credit task to get into the accept body + -- The call from the Message Task has been requeued by + -- the distributor + while not TC_Handshake_A.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Abort the calling task; the Credit task is guaranteed to + -- be in the accept body + abort Next_Message_Task.all; -- We are still in this declare + -- block + + -- Inform the Credit task that the abort has been initiated + TC_Handshake_B.Set_True; + + -- Now wait for the "acknowledgment" from the Credit task + -- this ensures a complete task switch (at least) + while not TC_Handshake_C.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The aborted task must not terminate till the accept body + -- has completed + if Next_Message_Task'terminated then + Report.Failed ("The abort was not deferred"); + end if; + + -- Inform the Credit task that the termination has been checked + TC_Handshake_D.Set_True; + + -- Now wait for the completion of the accept body in the + -- Credit task + while not TC_Handshake_E.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + while not ( Next_Message_Task'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Indicate to the Main program that this section is complete + TC_Handshake_F.Set_True; + + else + -- The main part of the test is complete. Send one Debit message + -- as further exercise of the Distributor to ensure it has not + -- been affected by the abort of the requeue; + Build_Debit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + -- The only Credit message was the one that should have been aborted + Report.Failed ("Abort was not effective"); + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + + -- Indicate that the message did pass through the + -- Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; -- without abort + when Debit => + requeue Debit_Computation.Input; -- without abort + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + if Message_Count /= 0 then + Report.Failed ("Aborted Requeue was not canceled -1"); + end if; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Having done the basic housekeeping we now need to signal + -- that we are in the accept body of the credit task. The + -- message has arrived and the Line Driver may now abort the + -- calling task + TC_Handshake_A.Set_True; + + -- Now wait for the Line Driver to inform us the calling + -- task has been aborted + while not TC_Handshake_B.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The abort has taken place + -- Inform the Line Driver that we are still running in the + -- accept body + TC_Handshake_C.Set_True; + + -- Now wait for the Line Driver to digest this information + while not TC_Handshake_D.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- The Line driver has checked that the caller is not terminated + -- We can now complete the accept + + end Input; + -- We are out of the accept + TC_Handshake_E.Set_True; + + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + -- + null; -- stub + + -- The rest of this code is for Test Control + -- + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- c954014 + Report.Test ("C954014", "Abort a task that has a call" & + " requeued_without_abort"); + + Line_Driver.Start; -- Start the test + + -- Wait for the message tasks to complete before reporting the result + -- + while not (TC_Handshake_F.Value -- abort not effective? + and TC_Debit_Message_Complete.Value -- Distributor affected? + and TC_Handshake_E.Value ) loop -- accept not completed? + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954015.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,549 ---- + -- C954015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that requeued calls to task entries may, in turn, be requeued. + -- Check that the intermediate requeues are not blocked and that the + -- original caller remains blocked until the last requeue is complete. + -- This test uses: + -- Call with parameters + -- Requeue with abort + -- + -- TEST DESCRIPTION + -- A call is placed on the input queue of the Distributor. The + -- Distributor requeues to the Credit task; the Credit task requeues to a + -- secondary task which, in turn requeues to yet another task. This + -- continues down the chain. At the furthest point of the chain the + -- rendezvous is completed. To verify the action, the furthest task + -- waits in the accept statement for a second message to arrive before + -- completing. This second message can only arrive if none of the earlier + -- tasks in the chain are blocked waiting for completion. Apart from + -- the two Credit messages which are used to check the requeue chain one + -- Debit message is sent to validate the mix. + -- + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with ImpDef; + + procedure C954015 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + TC_Expected_To_Complete : constant integer := 3; + + + -- Values added to the Return_Value indicating passage through the + -- particular task + TC_Credit_Value : constant integer := 1; + TC_Sub_1_Value : constant integer := 2; + TC_Sub_2_Value : constant integer := 3; + TC_Sub_3_Value : constant integer := 4; + TC_Sub_4_Value : constant integer := 5; + -- + TC_Full_Value : integer := TC_Credit_Value + TC_Sub_1_Value + + TC_Sub_2_Value + TC_Sub_3_Value + + TC_Sub_4_Value; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Distributor is + entry Input(Transaction : acc_Transaction_Record); + end Distributor; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- The following are almost identical for the purpose of the test + task Credit_Sub_1 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_1; + -- + task Credit_Sub_2 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_2; + -- + task Credit_Sub_3 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_3; + + -- This is the last in the chain + task Credit_Sub_4 is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Sub_4; + + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the number of dummy messages needed for this + -- test and allow it to terminate at that point. + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + -- Arbitrary limit for the number of messages sent for this test + type TC_Trans_Range is range 1..3; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + + begin + + accept Start; -- wait for trigger from Main + + -- Arbitrarily limit the loop to the number needed for this test only + for Transaction_Numb in TC_Trans_Range loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + -- Artificially send out in the order required + case Transaction_Numb is + when 1 => + Build_Credit_Record( Next_Transaction ); + when 2 => + Build_Credit_Record( Next_Transaction ); + when 3 => + Build_Debit_Record ( Next_Transaction ); + end case; + + -- Present the record to the message task + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= TC_Full_Value or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - CR"); + end if; + if + This_Transaction.TC_Message_Count not in 1..2 then + Report.Failed ("Incorrect Message Count"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or not + This_Transaction.TC_Thru_Distrib then + Report.Failed ("Expected path not traversed - DB"); + end if; + end if; + TC_Tasks_Completed.Increment; + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + task body Distributor is + + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Show that the message did pass through the Distributor Task + Transaction.TC_Thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + or + terminate; + end select; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Distributor"); + end Distributor; + + + + + -- Computation task. + -- Note: After the computation is performed in this task the message is + -- passed on for further processing to some subsidiary task. The choice + -- of subsidiary task is made according to criteria not specified in + -- this test. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test, plug a known value and count + Transaction.Return_Value := TC_Credit_Value; + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + -- Depending on transaction content send it on to the + -- some other task for further processing + -- TC: Arbitrarily send the message on to Credit_Sub_1 + requeue Credit_Sub_1.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + task body Credit_Sub_1 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_1_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_2 + requeue Credit_Sub_2.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_1"); + + end Credit_Sub_1; + + task body Credit_Sub_2 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_2_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_3 + requeue Credit_Sub_3.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_2"); + end Credit_Sub_2; + + task body Credit_Sub_3 is + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_3_Value; + -- Depending on transaction content send it on to the + -- some other task for further processing + -- Arbitrarily send the message on to Credit_Sub_4 + requeue Credit_Sub_4.Input with abort; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_3"); + end Credit_Sub_3; + + -- This is the last in the chain of tasks to which transactions will + -- be requeued + -- + task body Credit_Sub_4 is + + TC_First_Message : Boolean := true; + + begin + loop + select + accept Input(Transaction : acc_Transaction_Record) do + -- Process this transaction + null; -- stub + + -- Add the value showing passage through this task + Transaction.Return_Value := + Transaction.Return_Value + TC_Sub_4_Value; + -- TC: stay in the accept body dealing with the first message + -- until the second arrives. If any of the requeues are + -- blocked the test will hang here indicating failure + if TC_First_Message then + while Input'count = 0 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + TC_First_Message := false; + end if; + -- for the second message, just complete the rendezvous + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Sub_4"); + end Credit_Sub_4; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_Thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin + + Report.Test ("C954015", "Test multiple levels of requeue to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks completed before calling Result + while (TC_Tasks_Completed.Count < TC_Expected_To_Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954016.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- C954016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when a task that is called by a requeue is aborted, the + -- original caller receives Tasking_Error and the requeuing task is + -- unaffected. + -- + -- TEST DESCRIPTION: + -- The Intermediate task requeues a call from the Original_Caller to the + -- Receiver. While the Receiver is in the accept body for this + -- rendezvous the Main aborts it. Check that Tasking_Error is raised in + -- the Original_Caller, that the Receiver does, indeed, get aborted and + -- the Intermediate task is undisturbed. + -- There are several delay loops in this test any one of which could + -- cause it to hang which would constitute failure. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Nov 95 SAIC Replaced shared global variable with protected + -- object for ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954016 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Receiver_in_Accept : Shared_Boolean (False); + + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + entry TC_Never_Called; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_Original_Caller_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + accept Input do + TC_Receiver_in_Accept.Set_True; + -- Hang within the accept body to allow Main to abort this task + accept TC_Never_Called; + end Input; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + + begin + Report.Test ("C954016", "Requeue: abort the called task"); + + Original_Caller.Start; + + -- Wait till the rendezvous with Receiver is started + while not TC_Receiver_in_Accept.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- At this point the Receiver is guaranteed to be in its accept + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and TC_Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + + end C954016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954017.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954017.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954017.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954017.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- C954017.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when an exception is raised in the rendezvous of a task + -- that was called by a requeue the exception is propagated to the + -- original caller and that the requeuing task is unaffected. + -- + -- TEST DESCRIPTION: + -- The Intermediate task requeues a call from the Original_Caller to the + -- Receiver. While the Receiver is in the accept body for this + -- rendezvous a Constraint_Error exception is raised. Check that the + -- exception is propagated to the Original_Caller, that the Receiver's + -- normal exception logic is employed and that the Intermediate task + -- is undisturbed. + -- There are several delay loops in this test any one of which could + -- cause it to hang (and thus fail). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Nov 95 SAIC Fixed shared global variable problem for + -- ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + + procedure C954017 is + + TC_Original_Caller_Complete : Boolean := false; + TC_Intermediate_Complete : Boolean := false; + TC_Receiver_Complete : Boolean := false; + TC_Exception : Exception; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Exception_Process_Complete : Shared_Boolean (False); + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Exception not propagated to Original_Caller"); + + exception + when TC_Exception => + TC_Original_Caller_Complete := true; -- Expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + requeue Receiver.Input with abort; + end Input; + + -- Wait for Main to ensure that the exception housekeeping is finished + while not TC_Exception_Process_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + TC_Intermediate_Complete := true; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + -- + begin + accept Input do + null; -- the user code for the rendezvous is stubbed out + + -- Test Control: Raise an exception in the destination task which + -- should then be propagated + raise TC_Exception; + + end Input; + exception + when TC_Exception => + TC_Receiver_Complete := true; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + end Receiver; + + + begin + + Report.Test ("C954017", "Requeue: exception processing"); + + Original_Caller.Start; -- Start the test after the Report.Test + + -- Wait for the whole of the exception process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + TC_Exception_Process_Complete.Set_True; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_Original_Caller_Complete and + TC_Intermediate_Complete and + TC_Receiver_Complete) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + + end C954017; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954018.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954018.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954018.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954018.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,227 ---- + -- C954018.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a task is aborted while a requeued call is queued + -- on one of its entries the original caller receives Tasking_Error + -- and the requeuing task is unaffected. + -- This test uses: Requeue to an entry in a different task + -- Parameterless call + -- Requeue with abort + -- + -- TEST DESCRIPTION: + -- The Intermediate task requeues a call from the Original_Caller to the + -- Receiver on an entry with a guard that is always false. While the + -- Original_Caller is still queued the Receiver is aborted. + -- Check that Tasking_Error is raised in the Original_Caller, that the + -- Receiver does, indeed, get aborted and the Intermediate task + -- is undisturbed. + -- There are several delay loops in this test any one of which could + -- cause it to hang and thus indicate failure. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with ImpDef; + + + procedure C954018 is + + + -- Protected object to control the shared test variables + -- + protected TC_State is + function On_Entry_Queue return Boolean; + procedure Set_On_Entry_Queue; + function Original_Caller_Complete return Boolean; + procedure Set_Original_Caller_Complete; + function Intermediate_Complete return Boolean; + procedure Set_Intermediate_Complete; + private + On_Entry_Queue_Flag : Boolean := false; + Original_Caller_Complete_Flag : Boolean := false; + Intermediate_Complete_Flag : Boolean := false; + end TC_State; + -- + -- + protected body TC_State is + function On_Entry_Queue return Boolean is + begin + return On_Entry_Queue_Flag; + end On_Entry_Queue; + + procedure Set_On_Entry_Queue is + begin + On_Entry_Queue_Flag := true; + end Set_On_Entry_Queue; + + function Original_Caller_Complete return Boolean is + begin + return Original_Caller_Complete_Flag; + end Original_Caller_Complete; + + procedure Set_Original_Caller_Complete is + begin + Original_Caller_Complete_Flag := true; + end Set_Original_Caller_Complete; + + function Intermediate_Complete return Boolean is + begin + return Intermediate_Complete_Flag; + end Intermediate_Complete; + + procedure Set_Intermediate_Complete is + begin + Intermediate_Complete_Flag := true; + end Set_Intermediate_Complete; + + end TC_State; + + --================================ + + task Original_Caller is + entry Start; + end Original_Caller; + + task Intermediate is + entry Input; + entry TC_Abort_Process_Complete; + end Intermediate; + + task Receiver is + entry Input; + end Receiver; + + + task body Original_Caller is + begin + accept Start; -- wait for the trigger from Main + + Intermediate.Input; + Report.Failed ("Tasking_Error not raised in Original_Caller task"); + + exception + when tasking_error => + TC_State.Set_Original_Caller_Complete; -- expected behavior + when others => + Report.Failed ("Unexpected Exception in Original_Caller task"); + end Original_Caller; + + + task body Intermediate is + begin + accept Input do + -- Within this accept call another task + TC_State.Set_On_Entry_Queue; + requeue Receiver.Input with abort; + Report.Failed ("Requeue did not complete the Accept"); + end Input; + + -- Wait for Main to ensure that the abort housekeeping is finished + accept TC_Abort_Process_Complete; + + TC_State.Set_Intermediate_Complete; + + exception + when others => + Report.Failed ("Unexpected exception in Intermediate task"); + end Intermediate; + + + task body Receiver is + begin + loop + select + -- A call to Input will be placed on the queue and never serviced + when Report.Equal (1,2) => -- Always false + accept Input do + Report.Failed ("Receiver in Accept"); + end Input; + or + delay ImpDef.Minimum_Task_Switch; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Receiver Task"); + + end Receiver; + + + begin + + Report.Test ("C954018", "Requeue: abort the called task" & + " while Caller is still queued"); + + Original_Caller.Start; + + + -- This is the main part of the test + + -- Wait for the requeue + while not TC_State.On_Entry_Queue loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Delay long enough to ensure that the requeue has "arrived" on + -- the entry queue. Note: TC_State.Set_On_Entry_Queue is called the + -- statement before the requeue + -- + delay ImpDef.Switch_To_New_Task; + + -- At this point the Receiver is guaranteed to have the requeue on + -- the entry queue + -- + abort Receiver; + + -- Wait for the whole of the abort process to complete + while not ( Original_Caller'terminated and Receiver'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + -- Inform the Intermediate task that the process is complete to allow + -- it to continue to completion itself + Intermediate.TC_Abort_Process_Complete; + + -- Wait for everything to settle before reporting the result + while not ( Intermediate'terminated ) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + + if not ( TC_State.Original_Caller_Complete and + TC_State.Intermediate_Complete ) then + Report.Failed ("Proper paths not traversed"); + end if; + + Report.Result; + + end C954018; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954019.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954019.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954019.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954019.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,314 ---- + -- C954019.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when a requeue is to the same entry the items go to the + -- right queue and that they are placed back on the end of the queue. + -- + -- TEST DESCRIPTION: + -- Simulate part of a message handling application where the messages are + -- composed of several segments. The sequence of the segments within the + -- message is specified by Seg_Sequence_No. The segments are handled by + -- different tasks and finally forwarded to an output driver. The + -- segments can arrive in any order but must be assembled into the proper + -- sequence for final output. There is a Sequencer task interposed + -- before the Driver. This takes the segments of the message off the + -- Ordering_Queue and those that are in the right order it sends on to + -- the driver; those that are out of order it places back on the end of + -- the queue. + -- + -- The test just simulates the arrival of the segments at the Sequencer. + -- The task generating the segments handshakes with the Sequencer during + -- the "Await Arrival" phase ensuring that the three segments of a + -- message arrive in REVERSE order (the End-of-Message segment arrives + -- first and the Header last). In the first cycle the sequencer pulls + -- segments off the queue and puts them back on the end till it + -- encounters the header. It checks the sequence of the ones it pulls + -- off in case the segments are being put back on in the wrong part of + -- the queue. Having cycled once through it no longer verifies the + -- sequence - it just executes the "application" code for the correct + -- order for dispatch to the driver. + -- + -- In this simple example no attempt is made to address segments of + -- another message arriving or any other error conditions (such as + -- missing segments, timing etc.) + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Dec 94 SAIC Remove parameter from requeue statement + -- + --! + + with Report; + with ImpDef; + + procedure C954019 is + begin + + + Report.Test ("C954019", "Check Requeue to the same Accept"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Alpha : string (1..128); + EOM : Boolean := false; -- true for final msg segment + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + task Sequencer is + entry Ordering_Queue ( Segment : acc_Message_Segment ); + entry TC_Handshake_1; + entry TC_Handshake_2; + end Sequencer; + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + Sequencer.TC_Handshake_1; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header + 1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + Sequencer.TC_Handshake_2; + -- Build the segment. The last segment in order to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Ordering_Queue ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + + -- Pull segments off the Ordering_Queue and deliver them in the correct + -- sequence to the Output_Driver. + -- + task body Sequencer is + Next_Needed : Segment_Sequence := Header; + + TC_Await_Arrival : Boolean := true; + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + begin + loop + select + accept Ordering_Queue ( Segment : acc_Message_Segment ) do + + --===================================================== + -- This part is all Test_Control code + + if TC_Await_Arrival then + -- We have to arrange that the segments arrive on the + -- queue in the right order, so we handshake with the + -- TC_Simulate_Arrival task to "send" only one at + -- a time + accept TC_Handshake_1; -- the first has arrived + -- and has been pulled off the + -- queue + + -- Wait for the second to arrive (the first has already + -- been pulled off the queue + while Ordering_Queue'count < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + accept TC_Handshake_2; -- the second has arrived + + -- Wait for the third to arrive + while Ordering_Queue'count < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Subsequent passes through the loop, bypass this code + TC_Await_Arrival := false; + + + end if; -- await arrival + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + Report.Failed ("Sequencer: Segment out of sequence"); + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + + end if; -- decrementing + end if; -- first pass + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + Report.Failed ("Requeue did not complete accept body"); + else + -- Not the next needed - put it back on the queue + requeue Sequencer.Ordering_Queue; + Report.Failed ("Requeue did not complete accept body"); + end if; + end Ordering_Queue; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Sequencer"); + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + + begin + + null; + + end; -- encapsulation + + Report.Result; + + end C954019; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954020.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,422 ---- + -- C954020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a call to a protected entry can be requeued to a task + -- entry. Check that the requeue is placed on the correct entry; that the + -- original caller waits for the completion of the requeue and continues + -- after the requeued rendezvous. Check that the requeue does not block. + -- Specifically, check a requeue with abort from a protected entry to + -- an entry in a task. + -- + -- TEST DESCRIPTION: + -- + -- In the Distributor protected object, requeue two successive calls on + -- the entries of two separate target tasks. Each task in each of the + -- paths adds identifying information in the transaction being passed. + -- This information is checked by the Message tasks on completion + -- ensuring that the requeues have been placed on the correct queues. + -- There is an artificial guard on the Credit Task to ensure that the + -- input is queued; this guard is released by the Debit task which + -- handles its input immediately. This ensures that we have one of the + -- requeued items actually queued for later handling and also verifies + -- that the requeuing process (in the protected object) is not blocked. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor object which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, + -- dynamic and unpredictable at the time of message generation. All + -- rerouting in this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 06 Nov 95 SAIC Fixed problems for ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954020 is + Verbose : constant Boolean := False; + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + protected type Message_Status is + procedure Set_Complete; + function Complete return Boolean; + private + Is_Complete : Boolean := False; + end Message_Status; + + protected body Message_Status is + procedure Set_Complete is + begin + Is_Complete := True; + end Set_Complete; + + function Complete return Boolean is + begin + return Is_Complete; + end Complete; + end Message_Status; + + TC_Debit_Message : Message_Status; + TC_Credit_Message : Message_Status; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input with abort; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + if Verbose then + Report.Comment ("message task got " & + Transaction_Code'Image (This_Transaction.Code)); + end if; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Credit_Message.Set_Complete; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + TC_Debit_Message.Set_Complete; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + if Verbose then + Report.Comment ("Credit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + + end Input; + exit; -- only handle 1 transaction + else + -- poll until we can accept credit transaction + delay ImpDef.Clear_Ready_Queue; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + if Verbose then + Report.Comment ("Debit_Computation in accept"); + end if; + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + + end Debit_Computation; + + + begin -- C954020 + + Report.Test ("C954020", "Requeue, with abort, from protected entry " & + "to task entry"); + + Line_Driver.Start; -- Start the test + + -- Ensure that the message tasks complete before reporting the result + while not (TC_Credit_Message.Complete and TC_Debit_Message.Complete) loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954020; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954021.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,524 ---- + -- C954021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue within a protected entry to an entry in a + -- different protected object is queued correctly. + -- + -- TEST DESCRIPTION: + -- One transaction is sent through to check the paths. After processing + -- this the Credit task sets the "overloaded" indicator. Once this + -- indicator is set the Distributor (a protected object) queues low + -- priority transactions on a Wait_for_Underload queue in another + -- protected object using a requeue. The Distributor still delivers high + -- priority transactions. After two high priority transactions have been + -- processed by the Credit task it clears the overload condition. The + -- low priority transactions should now be delivered. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Nov 95 SAIC Fixed shared global variable for ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954021 is + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + + -- Mechanism to count the number of Credit Message tasks completed + protected TC_Tasks_Completed is + procedure Increment; + function Count return integer; + private + Number_Complete : integer := 0; + end TC_Tasks_Completed; + + + TC_Credit_Messages_Expected : constant integer := 5; + + protected TC_Handshake is + procedure Set; + function First_Message_Arrived return Boolean; + private + Arrived_Flag : Boolean := false; + end TC_Handshake; + + -- Handshaking mechanism between the Line Driver and the Credit task + -- + protected body TC_Handshake is + -- + procedure Set is + begin + Arrived_Flag := true; + end Set; + -- + function First_Message_Arrived return Boolean is + begin + return Arrived_Flag; + end First_Message_Arrived; + -- + end TC_Handshake; + + + protected type Shared_Boolean (Initial_Value : Boolean := False) is + procedure Set_True; + procedure Set_False; + function Value return Boolean; + private + Current_Value : Boolean := Initial_Value; + end Shared_Boolean; + + protected body Shared_Boolean is + procedure Set_True is + begin + Current_Value := True; + end Set_True; + + procedure Set_False is + begin + Current_Value := False; + end Set_False; + + function Value return Boolean is + begin + return Current_Value; + end Value; + end Shared_Boolean; + + TC_Debit_Message_Complete : Shared_Boolean (False); + + type Transaction_Code is (Credit, Debit); + type Transaction_Priority is (High, Low); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : Transaction_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Credit_Overloaded; + function Credit_is_Overloaded return Boolean; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Underloaded; + entry Wait_for_Underload (Transaction : acc_Transaction_Record); + private + Release_All : Boolean := false; + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Credit_Overloaded is + begin + Credit_Overloaded := false; + Hold.Underloaded; -- Release all held messages + end Clear_Credit_Overloaded; + + function Credit_is_Overloaded return Boolean is + begin + return Credit_Overloaded; + end Credit_is_Overloaded; + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority = Low then + requeue Hold.Wait_for_Underload with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once this is executed the barrier condition for the entry is + -- evaluated + procedure Underloaded is + begin + Release_All := true; + end Underloaded; + + entry Wait_for_Underload (Transaction : acc_Transaction_Record) + when Release_All is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload'count = 0 then + -- Queue is purged. Set up to hold next batch + Release_All := false; + end if; + end Wait_for_Underload; + + end Hold; + + -- Mechanism to count the number of Message tasks completed (Credit) + protected body TC_Tasks_Completed is + procedure Increment is + begin + Number_Complete := Number_Complete + 1; + end Increment; + + function Count return integer is + begin + return Number_Complete; + end Count; + end TC_Tasks_Completed; + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- alternate High and Low priority Credit transactions for this test. + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : Transaction_Priority := High; + + -- Artificial: number of messages required for this test + type TC_Trans_Range is range 1..6; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_Handshake.First_Message_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Alternate high and low priority transactions + if Current_Priority = High then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_Tasks_Completed.Increment; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete.Set_True; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + if Distributor.Credit_is_Overloaded + and Transaction.Priority = Low then + -- We should not be getting any Low Priority messages. They + -- should be waiting on the Hold.Wait_for_Underload + -- queue + Report.Failed + ("Credit Task: Low priority transaction during overload"); + end if; + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- The following is all Test Control code: + Transaction.Return_Value := Credit_Return; + Message_Count := Message_Count + 1; + -- + -- Now take special action depending on which Message + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and subsequent + -- messages may now be sent + TC_Handshake.Set; + end if; + if Message_Count = 3 then + -- The two high priority transactions created subsequent + -- to the overload have now been processed + Distributor.Clear_Credit_Overloaded; + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + + begin + Report.Test ("C954021", "Requeue from one entry body to an entry in" & + " another protected object"); + + Line_Driver.Start; -- Start the test + + + -- Ensure that the message tasks have completed before reporting result + while (TC_Tasks_Completed.Count < TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete.Value loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + Report.Result; + + end C954021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954022.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954022.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954022.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954022.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,351 ---- + -- C954022.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- In an entry body requeue the call to the same entry. Check that the + -- items go to the right queue and that they are placed back on the end + -- of the queue + -- + -- TEST DESCRIPTION: + -- Simulate part of a message handling application where the messages are + -- composed of several segments. The sequence of the segments within the + -- message is specified by Seg_Sequence_No. The segments are handled by + -- different tasks and finally forwarded to an output driver. The + -- segments can arrive in any order but must be assembled into the proper + -- sequence for final output. There is a Sequencer task interposed + -- before the Driver. This takes the segments of the message off the + -- Ordering_Queue and those that are in the right order it sends on to + -- the driver; those that are out of order it places back on the end of + -- the queue. + -- + -- The test just simulates the arrival of the segments at the Sequencer. + -- The task generating the segments handshakes with the Sequencer during + -- the "Await Arrival" phase ensuring that the three segments of a + -- message arrive in REVERSE order (the End-of-Message segment arrives + -- first and the Header last). In the first cycle the sequencer pulls + -- segments off the queue and puts them back on the end till it + -- encounters the header. It checks the sequence of the ones it pulls + -- off in case the segments are being put back on in the wrong part of + -- the queue. Having cycled once through it no longer verifies the + -- sequence - it just executes the "application" code for the correct + -- order for dispatch to the driver. + -- + -- In this simple example no attempt is made to address segments of + -- another message arriving or any other error conditions (such as + -- missing segments, timing etc.) + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 07 Nov 95 SAIC ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + + procedure C954022 is + + -- These global Booleans are set when failure conditions inside Protected + -- objects are encountered. Report.Failed cannot be called within + -- the object or a Bounded Error would occur + -- + TC_Failed_1 : Boolean := false; + TC_Failed_2 : Boolean := false; + TC_Failed_3 : Boolean := false; + + begin + + + Report.Test ("C954022", "Check Requeue to the same Protected Entry"); + + declare -- encapsulate the test + + type Segment_Sequence is range 1..8; + Header : constant Segment_Sequence := Segment_Sequence'first; + + type Message_Segment is record + ID : integer; -- Message ID + Seg_Sequence_No : Segment_Sequence; -- Within the message + Segs_In_Message : integer; -- Total segs this message + EOM : Boolean := false; -- true for final msg segment + Alpha : string (1..128); + end record; + type acc_Message_Segment is access Message_Segment; + + task TC_Simulate_Arrival; + + task type Carrier_Task is + entry Input ( Segment : acc_Message_Segment ); + end Carrier_Task; + type acc_Carrier_Task is access Carrier_Task; + + protected Sequencer is + function TC_Arrivals return integer; + entry Input ( Segment : acc_Message_Segment ); + entry Ordering_Queue ( Segment : acc_Message_Segment ); + private + Number_of_Segments_Arrived : integer := 0; + Number_of_Segments_Expected : integer := 0; + Next_Needed : Segment_Sequence := Header; + All_Segments_Arrived : Boolean := false; + Seen_EOM : Boolean := false; + + TC_First_Cycle : Boolean := true; + TC_Expected_Sequence : Segment_Sequence := Header+2; + + end Sequencer; + + + task Output_Driver is + entry Input ( Segment : acc_Message_Segment ); + end Output_Driver; + + + -- Simulate the arrival of three message segments in REVERSE order + -- + task body TC_Simulate_Arrival is + begin + for i in 1..3 loop + declare + -- Create a task for the next message segment + Next_Segment_Task : acc_Carrier_Task := new Carrier_Task; + -- Create a record for the next segment + Next_Segment : acc_Message_Segment := new Message_Segment; + begin + if i = 1 then + -- Build the EOM segment as the first to "send" + Next_Segment.Seg_Sequence_No := Header + 2; + Next_Segment.Segs_In_Message := 3; + Next_Segment.EOM := true; + elsif i = 2 then + -- Wait for the first segment to arrive at the Sequencer + -- before "sending" the second + while Sequencer.TC_Arrivals < 1 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment + Next_Segment.Seg_Sequence_No := Header +1; + else + -- Wait for the second segment to arrive at the Sequencer + -- before "sending" the third + while Sequencer.TC_Arrivals < 2 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- Build the segment. The last segment (in order) to + -- arrive will be the "header" segment + Next_Segment.Seg_Sequence_No := Header; + end if; + -- pass the record to its carrier + Next_Segment_Task.Input ( Next_Segment ); + end; + end loop; + + + exception + when others => + Report.Failed ("Unexpected Exception in TC_Simulate_Arrival"); + end TC_Simulate_Arrival; + + + -- One of these is generated for each message segment and the flow + -- of the segments through the system is controlled by the calls the + -- task makes and the requeues of those calls + -- + task body Carrier_Task is + This_Segment : acc_Message_Segment := new Message_Segment; + begin + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + null; --:: stub. Pass the segment around the application as needed + + -- Now output the segment to the Output_Driver. First we have to + -- go through the Sequencer. + Sequencer.Input ( This_Segment ); + exception + when others => + Report.Failed ("Unexpected Exception in Carrier_Task"); + end Carrier_Task; + + -- Store segments on the Ordering_Queue then deliver them in the correct + -- sequence to the Output_Driver. + -- + protected body Sequencer is + + function TC_Arrivals return integer is + begin + return Number_of_Segments_Arrived; + end TC_Arrivals; + + + -- Segments arriving at the Input queue are counted and checked + -- against the total number of segments for the message. They + -- are requeued onto the ordering queue where they are held until + -- all the segments have arrived. + entry Input ( Segment : acc_Message_Segment ) when true is + begin + -- check for EOM, if so get the number of segments in the message + -- Note: in this portion of code no attempt is made to address + -- reset for new message , end conditions, missing segments, + -- segments of a different message etc. + Number_of_Segments_Arrived := Number_of_Segments_Arrived + 1; + if Segment.EOM then + Number_of_Segments_Expected := Segment.Segs_In_Message; + Seen_EOM := true; + end if; + + if Seen_EOM then + if Number_of_Segments_Arrived = Number_of_Segments_Expected then + -- This is the last segment for this message + All_Segments_Arrived := true; -- clear the barrier + end if; + end if; + + requeue Ordering_Queue; + + -- At this exit point the entry queue barriers are evaluated + + end Input; + + + entry Ordering_Queue ( Segment : acc_Message_Segment ) + when All_Segments_Arrived is + begin + + --===================================================== + -- This part is all Test_Control code + + if TC_First_Cycle then + -- Check the order of the original three + if Segment.Seg_Sequence_No /= TC_Expected_Sequence then + -- The segments are not being pulled off in the + -- expected sequence. This could occur if the + -- requeue is not putting them back on the end. + TC_Failed_3 := true; + end if; -- sequence check + -- Decrement the expected sequence + if TC_Expected_Sequence /= Header then + TC_Expected_Sequence := TC_Expected_Sequence - 1; + else + TC_First_Cycle := false; -- This is the Header - the + -- first two segments are + -- back on the queue + end if; -- decrementing + end if; -- first cycle + --===================================================== + + -- And this is the Application code + if Segment.Seg_Sequence_No = Next_Needed then + if Segment.EOM then + Next_Needed := Header; -- reset for next message + -- :: other resets not shown + else + Next_Needed := Next_Needed + 1; + end if; + requeue Output_Driver.Input with abort; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_1 := true; + else + -- Not the next needed - put it back on the queue + -- NOTE: here we are requeueing to the same entry + requeue Sequencer.Ordering_Queue; + -- set to Report Failed - Requeue did not complete entry body + TC_Failed_2 := true; + end if; + end Ordering_Queue; + end Sequencer; + + + task body Output_Driver is + This_Segment : acc_Message_Segment := new Message_Segment; + + TC_Expected_Sequence : Segment_Sequence := Segment_Sequence'first; + TC_Segment_Total : integer := 0; + TC_Expected_Total : integer := 3; + begin + loop + -- Note: normally we would expect this Accept to be in a select + -- with terminate. For the test we exit the loop on completion + -- to give better control + accept Input ( Segment : acc_Message_Segment ) do + This_Segment.all := Segment.all; + end Input; + + null; --::: stub - output the next segment of the message + + -- The following is all test control code + -- + if This_Segment.Seg_Sequence_No /= TC_Expected_Sequence then + Report.Failed ("Output_Driver: Segment out of sequence"); + end if; + TC_Expected_Sequence := TC_Expected_Sequence + 1; + + -- Now count the number of segments + TC_Segment_Total := TC_Segment_Total + 1; + + -- Check the number and exit loop when complete + -- There must be exactly TC_Expected_Total in number and + -- the last one must be EOM + -- (test will hang if < TC_Expected_Total arrive + -- without EOM) + if This_Segment.EOM then + -- This is the last segment. + if TC_Segment_Total /= TC_Expected_Total then + Report.Failed ("EOM and wrong number of segments"); + end if; + exit; -- the loop and terminate the task + elsif TC_Segment_Total = TC_Expected_Total then + Report.Failed ("No EOM found"); + exit; + end if; + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in Output_Driver"); + end Output_Driver; + + + begin + + null; + + end; -- encapsulation + + if TC_Failed_1 then + Report.Failed ("Requeue did not complete entry body - 1"); + end if; + + if TC_Failed_2 then + Report.Failed ("Requeue did not complete entry body - 2"); + end if; + + if TC_Failed_3 then + Report.Failed ("Sequencer: Segment out of sequence"); + end if; + + Report.Result; + + end C954022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954023.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954023.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954023.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954023.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,558 ---- + -- C954023.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue within a protected entry to a family of entries + -- in a different protected object is queued correctly + -- Call with parameters + -- Requeue with abort + -- + -- TEST DESCRIPTION: + -- One transaction is sent through to check the paths. After processing + -- this, the Credit task sets the "overloaded" indicator. Once this + -- indicator is set the Distributor (a protected object) queues lower + -- priority transactions on a family of queues (Wait_for_Underload) in + -- another protected object using a requeue. The Distributor still + -- delivers high priority transactions. After two more high priority + -- transactions have been processed by the Credit task the artificial + -- test code clears the overload condition to the threshold level that + -- allows only the items on the Medium priority queue of the family to be + -- released. When these have been processed and checked the test code + -- then lowers the priority threshold once again, allowing the Low + -- priority items from the last queue in the family to be released, + -- processed and checked. Note: the High priority queue in the family is + -- not used. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, dynamic + -- and unpredictable at the time of message generation. All rerouting in + -- this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + procedure C954023 is + + -- Artificial: number of messages required for this test + subtype TC_Trans_Range is integer range 1..8; + + TC_Credit_Messages_Expected : constant integer + := TC_Trans_Range'Last - 1; + + TC_Debit_Message_Complete : Boolean := false; + + + -- Mechanism for handshaking between tasks + protected TC_PO is + procedure Increment_Tasks_Completed_Count; + function Tasks_Completed_Count return integer; + function First_Message_Has_Arrived return Boolean; + procedure Set_First_Message_Has_Arrived; + private + Number_Complete : integer := 0; + Message_Arrived_Flag : Boolean := false; + end TC_PO; + -- + protected body TC_PO is + procedure Increment_Tasks_Completed_Count is + begin + Number_Complete := Number_Complete + 1; + end Increment_Tasks_Completed_Count; + + function Tasks_Completed_Count return integer is + begin + return Number_Complete; + end Tasks_Completed_Count; + + function First_Message_Has_Arrived return Boolean is + begin + return Message_Arrived_Flag; + end First_Message_Has_Arrived; + + procedure Set_First_Message_Has_Arrived is + begin + Message_Arrived_Flag := true; + end Set_First_Message_Has_Arrived; + + end TC_PO; + + begin + + Report.Test ("C954023", "Requeue from within a protected object" & + " to a family of entries in another protected object"); + + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + type App_Priority is (Low, Medium, High); + type Priority_Block is array (App_Priority) of Boolean; + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Priority : App_Priority := High; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Distrib : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + protected Distributor is + procedure Set_Credit_Overloaded; + procedure Clear_Overload_to_Medium; + procedure Clear_Overload_to_Low; + entry Input (Transaction : acc_Transaction_Record); + private + Credit_Overloaded : Boolean := false; + end Distributor; + + protected Hold is + procedure Release_Medium; + procedure Release_Low; + -- Family of entry queues indexed by App_Priority + entry Wait_for_Underload (App_Priority) + (Transaction : acc_Transaction_Record); + private + Release : Priority_Block := (others => false); + end Hold; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + + procedure Set_Credit_Overloaded is + begin + Credit_Overloaded := true; + end Set_Credit_Overloaded; + + procedure Clear_Overload_to_Medium is + begin + Credit_Overloaded := false; + Hold.Release_Medium; -- Release all held messages on Medium + -- priority queue + end Clear_Overload_to_Medium; + + procedure Clear_Overload_to_Low is + begin + Credit_Overloaded := false; + Hold.Release_Low; -- Release all held messages on Low + -- priority queue + end Clear_Overload_to_Low; + + + + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Distrib := true; + + -- Pass this transaction on to the appropriate computation + -- task but temporarily hold low-priority transactions under + -- overload conditions + case Transaction.Code is + when Credit => + if Credit_Overloaded and Transaction.Priority /= High then + -- use the appropriate queue in the family + requeue Hold.Wait_for_Underload(Transaction.Priority) + with abort; + else + requeue Credit_Computation.Input with abort; + end if; + when Debit => + requeue Debit_Computation.Input with abort; + end case; + end Input; + end Distributor; + + + -- Low priority Message tasks are held on the Wait_for_Underload queue + -- while the Credit computation system is overloaded. Once the Credit + -- system reached underload send all queued messages immediately + -- + protected body Hold is + + -- Once these are executed the barrier conditions for the entries + -- are evaluated + procedure Release_Medium is + begin + Release(Medium) := true; + end Release_Medium; + -- + procedure Release_Low is + begin + Release(Low) := true; + end Release_Low; + + -- This is a family of entry queues indexed by App_Priority + entry Wait_for_Underload (for AP in App_Priority) + (Transaction : acc_Transaction_Record) + when Release(AP) is + begin + requeue Credit_Computation.Input with abort; + if Wait_for_Underload(AP)'count = 0 then + -- Queue is purged. Set up to hold next batch + Release(AP) := false; + end if; + end Wait_for_Underload; + + end Hold; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- The Line Driver task would normally be designed to loop + -- creating the messages as input is received. Simulate this + -- but limit it to the required number of dummy messages needed for + -- this test and allow it to terminate at that point. Artificially + -- cycle the generation of High medium and Low priority Credit + -- transactions for this test. Send out one final Debit message + -- + task body Line_Driver is + Current_ID : integer := 1; + Current_Priority : App_Priority := High; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + Next_Transaction.Priority := Current_Priority; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + for Transaction_Numb in TC_Trans_Range loop -- TC: limit the loop + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record := + new Transaction_Record; + begin + if Transaction_Numb = TC_Trans_Range'first then + -- Send the first Credit message + Build_Credit_Record ( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + -- TC: Wait until the first message has been received by the + -- Credit task and it has set the Overload indicator for the + -- Distributor + while not TC_PO.First_Message_Has_Arrived loop + delay ImpDef.Minimum_Task_Switch; + end loop; + elsif Transaction_Numb = TC_Trans_Range'last then + -- For this test send the last transaction to the Debit task + -- to improve the mix + Build_Debit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + else + -- TC: Cycle generation of high medium and low priority + -- transactions + if Current_Priority = High then + Current_Priority := Medium; + elsif + Current_Priority = Medium then + Current_Priority := Low; + else + Current_Priority := High; + end if; + Build_Credit_Record( Next_Transaction ); + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end if; + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + + accept Accept_Transaction(In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + -- For the test check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Credit"); + end if; + TC_PO.Increment_Tasks_Completed_Count; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Distrib then + Report.Failed ("Expected path not traversed - Debit"); + end if; + TC_Debit_Message_Complete := true; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + end Message_Task; + + + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + task body Credit_Computation is + + Message_Count : integer := 0; + + begin + loop + select + accept Input ( Transaction : acc_Transaction_Record) do + + -- Perform the computations required for this transaction + null; -- stub + + + -- The following is all Test Control code: + + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- This is checked by the Message_Task: + Transaction.Return_Value := Credit_Return; + + -- Now take special action depending on which Message. + -- Note: The count gives the order in which the messages are + -- arriving at this task NOT the order in which they + -- were originally generated and sent out. + + Message_Count := Message_Count + 1; + + if Message_Count < 4 then + -- This is one of the first three messages which must + -- be High priority because we will set "Overload" after + -- the first, which is known to be High. The lower + -- priority should be waiting on the queues + if Transaction.Priority /= High then + Report.Failed + ("Credit Task: Lower priority trans. during overload"); + end if; + if Message_Count = 1 then + -- After the first message : + Distributor.Set_Credit_Overloaded; + -- Now flag the Line_Driver that the second and + -- subsequent messages may now be sent + TC_PO.Set_First_Message_Has_Arrived; + elsif + Message_Count = 3 then + -- The two high priority transactions created + -- subsequent to the overload have now been processed, + -- release the Medium priority items + Distributor.Clear_Overload_to_Medium; + end if; + elsif Message_Count < 6 then + -- This must be one of the Medium priority messages + if Transaction.Priority /= Medium then + Report.Failed + ("Credit Task: Second group not Medium Priority"); + end if; + if Message_Count = 5 then + -- The two medium priority transactions + -- have now been processed - release the + -- Low priority items + Distributor.Clear_Overload_to_Low; + end if; + elsif Message_Count < TC_Trans_Range'Last then + -- This must be one of the Low priority messages + if Transaction.Priority /= Low then + Report.Failed + ("Credit Task: Third group not Low Priority"); + end if; + else + -- Too many transactions have arrived. Duplicates? + -- the Debit transaction? + Report.Failed + ("Credit Task: Too many transactions"); + end if; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. After the computation is performed the rendezvous + -- in the original message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Distrib then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + end Debit_Computation; + + + begin -- declare + + null; + + end; -- declare (test encapsulation) + + if (TC_PO.Tasks_Completed_Count /= TC_Credit_Messages_Expected) + and not TC_Debit_Message_Complete then + Report.Failed ("Incorrect number of Message Tasks completed"); + end if; + + Report.Result; + + end C954023; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954024.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954024.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954024.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954024.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,380 ---- + -- C954024.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a call to a protected entry can be requeued to a task + -- entry. Check that the requeue is placed on the correct entry; that the + -- original caller waits for the completion of the requeue and continues + -- after the requeued rendezvous. Check that the requeue does not block. + -- Specifically, check a requeue without abort from a protected entry to + -- an entry in a task. + -- + -- TEST DESCRIPTION: + -- In the Distributor protected object, requeue two successive calls on + -- the entries of two separate target tasks. Each task in each of the + -- paths adds identifying information in the transaction being passed. + -- This information is checked by the Message tasks on completion + -- ensuring that the requeues have been placed on the correct queues. + -- There is an artificial guard on the Credit Task to ensure that the + -- input is queued; this guard is released by the Debit task which + -- handles its input immediately. This ensures that we have one of the + -- requeued items actually queued for later handling and also verifies + -- that the requeuing process (in the protected object) is not blocked. + -- + -- This series of tests uses a simulation of a transaction driven + -- processing system. Line Drivers accept input from an external source + -- and build them into transaction records. These records are then + -- encapsulated in message tasks which remain extant for the life of the + -- transaction in the system. The message tasks put themselves on the + -- input queue of a Distributor object which, from information in the + -- transaction and/or system load conditions forwards them to other + -- operating tasks. These in turn might forward the transactions to yet + -- other tasks for further action. The routing is, in real life, + -- dynamic and unpredictable at the time of message generation. All + -- rerouting in this model is done by means of requeues. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 08 Nov 95 SAIC Fixed reported problems for ACVC 2.0.1 + -- + --! + + with Report; + with ImpDef; + procedure C954024 is + + + begin -- C954024 + + Report.Test ("C954024", "Requeue from protected entry to task entry"); + + declare -- encapsulate the test + + -- Arbitrary test values + Credit_Return : constant := 1; + Debit_Return : constant := 2; + + type Transaction_Code is (Credit, Debit); + + type Transaction_Record; + type acc_Transaction_Record is access Transaction_Record; + type Transaction_Record is + record + ID : integer := 0; + Code : Transaction_Code := Debit; + Account_Number : integer := 0; + Stock_Number : integer := 0; + Quantity : integer := 0; + Return_Value : integer := 0; + TC_Message_Count : integer := 0; + TC_Thru_Dist : Boolean := false; + end record; + + + task type Message_Task is + entry Accept_Transaction (In_Transaction : acc_Transaction_Record); + end Message_Task; + type acc_Message_Task is access Message_Task; + + task Line_Driver is + entry Start; + end Line_Driver; + + task Credit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Credit_Computation; + + task Debit_Computation is + entry Input(Transaction : acc_Transaction_Record); + end Debit_Computation; + + protected Time_Lock is + procedure Credit_Start; + function Credit_Enabled return Boolean; + private + Credit_OK : Boolean := false; + end Time_Lock; + + protected body Time_Lock is + procedure Credit_Start is + begin + Credit_OK := true; + end Credit_Start; + + function Credit_Enabled return Boolean is + begin + return Credit_OK; + end Credit_Enabled; + end Time_Lock; + + + + protected Distributor is + entry Input (Transaction : acc_Transaction_Record); + end Distributor; + -- + -- + -- Dispose each input Transaction_Record to the appropriate + -- computation tasks + -- + protected body Distributor is + entry Input (Transaction : acc_Transaction_Record) when true is + -- barrier is always open + begin + -- Test Control: Set the indicator in the message to show it has + -- passed through the Distributor object + Transaction.TC_thru_Dist := true; + + -- Pass this transaction on to the appropriate computation + -- task + case Transaction.Code is + when Credit => + requeue Credit_Computation.Input; + when Debit => + requeue Debit_Computation.Input; + end case; + end Input; + end Distributor; + + + + + -- Assemble messages received from an external source + -- Creates a message task for each. The message tasks remain extant + -- for the life of the messages in the system. + -- NOTE: + -- The Line Driver task would normally be designed to loop continuously + -- creating the messages as input is received. Simulate this + -- but limit it to two dummy messages for this test and allow it + -- to terminate at that point + -- + task body Line_Driver is + Current_ID : integer := 1; + TC_Last_was_for_credit : Boolean := false; + + procedure Build_Credit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 100; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Credit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Credit_Record; + + + procedure Build_Debit_Record + ( Next_Transaction : acc_Transaction_Record ) is + Dummy_Account : constant integer := 200; + begin + Next_Transaction.ID := Current_ID; + Next_Transaction.Code := Debit; + + Next_Transaction.Account_Number := Dummy_Account; + Current_ID := Current_ID + 1; + end Build_Debit_Record; + + begin + + accept Start; -- Wait for trigger from Main + + for i in 1..2 loop -- arbitrarily limit to two messages for the test + declare + -- Create a task for the next message + Next_Message_Task : acc_Message_Task := new Message_Task; + -- Create a record for it + Next_Transaction : acc_Transaction_Record + := new Transaction_Record; + begin + if TC_Last_was_for_credit then + Build_Debit_Record ( Next_Transaction ); + else + Build_Credit_Record( Next_Transaction ); + TC_Last_was_for_credit := true; + end if; + Next_Message_Task.Accept_Transaction ( Next_Transaction ); + end; -- declare + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Line_Driver"); + end Line_Driver; + + + + + task body Message_Task is + + TC_Original_Transaction_Code : Transaction_Code; + This_Transaction : acc_Transaction_Record := new Transaction_Record; + + begin + accept Accept_Transaction + (In_Transaction : acc_Transaction_Record) do + This_Transaction.all := In_Transaction.all; + end Accept_Transaction; + + -- Note the original code to ensure correct return + TC_Original_Transaction_Code := This_Transaction.Code; + + -- Queue up on Distributor's Input queue + Distributor.Input ( This_Transaction ); + -- This task will now wait for the requeued rendezvous + -- to complete before proceeding + + -- After the required computations have been performed + -- return the Transaction_Record appropriately (probably to an output + -- line driver) + null; -- stub + + + -- The following is all Test Control Code + + -- Check that the return values are as expected + if TC_Original_Transaction_Code /= This_Transaction.Code then + -- Incorrect rendezvous + Report.Failed ("Message Task: Incorrect code returned"); + end if; + + if This_Transaction.Code = Credit then + if This_Transaction.Return_Value /= Credit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + else + if This_Transaction.Return_Value /= Debit_Return or + This_Transaction.TC_Message_Count /= 1 or + not This_Transaction.TC_thru_Dist then + Report.Failed ("Expected path not traversed"); + end if; + end if; + + exception + when others => + Report.Failed ("Unexpected exception in Message_Task"); + + end Message_Task; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Credit_Computation is + Message_Count : integer := 0; + begin + loop + select + when Time_Lock.Credit_enabled => + accept Input ( Transaction : acc_Transaction_Record) do + -- Perform the computations required for this transaction + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Credit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Credit then + Report.Failed + ("Credit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Credit_Return; + -- one, and only one message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + end Input; + exit; -- one message is enough + else + delay ImpDef.Clear_Ready_Queue; -- poll + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Credit_Computation"); + end Credit_Computation; + + + + -- Computation task. + -- Note: After the computation is performed in this task and the + -- accept body is completed the rendezvous in the original + -- message task is completed. + -- + task body Debit_Computation is + Message_Count : integer := 0; + begin + loop + select + accept Input (Transaction : acc_Transaction_Record) do + -- Perform the computations required for this message + null; -- stub + + -- For the test: + if not Transaction.TC_thru_Dist then + Report.Failed + ("Debit Task: Wrong queue, Distributor bypassed"); + end if; + if Transaction.code /= Debit then + Report.Failed + ("Debit Task: Requeue delivered to the wrong queue"); + end if; + + -- for the test plug a known value and count + Transaction.Return_Value := Debit_Return; + -- one, and only one, message should pass through + Message_Count := Message_Count + 1; + Transaction.TC_Message_Count := Message_Count; + -- for the test: once we have completed the only Debit + -- message release the Credit Messages which are queued + -- on the Credit Input queue + Time_Lock.Credit_Start; + + end Input; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Debit_Computation"); + + end Debit_Computation; + + begin -- declare block + Line_Driver.Start; + end; -- test encapsulation + + Report.Result; + + end C954024; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954025.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954025.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954025.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954025.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,237 ---- + -- C954025.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the original entry call was a conditional entry call, + -- the call is cancelled if a requeue-with-abort of the call is not + -- selected immediately. + -- Check that if the original entry call was a timed entry call, the + -- expiration time for a requeue-with-abort is the original expiration + -- time. + -- + -- TEST DESCRIPTION: + -- This test declares two tasks: Launch_Control and Mission_Control. + -- Mission_Control instructs Launch_Control to start its countdown + -- and then requeues (with abort) to the Launch_Control.Launch + -- entry. This call to Launch will be accepted at the end of the + -- countdown (if the task is still waiting). + -- The main task does an unconditional, conditional, and timed + -- entry call to Mission_Control and checks to see if the launch + -- was accepted. + -- + -- + -- CHANGE HISTORY: + -- 18 OCT 95 SAIC ACVC 2.1 + -- 10 JUL 96 SAIC Incorporated reviewer's comments. + -- + --! + + with Calendar; use type Calendar.Time; + with Report; + with ImpDef; + procedure C954025 is + Verbose : constant Boolean := False; + Countdown_Amount : constant Duration := 2.0 * Impdef.One_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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954026.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954026.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954026.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954026.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,269 ---- + -- C954026.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the original protected entry call was a conditional + -- entry call, the call is cancelled if a requeue-with-abort of the + -- call is not selected immediately. + -- Check that if the original protected entry call was a timed entry + -- call, the expiration time for a requeue-with-abort is the original + -- expiration time. + -- + -- TEST DESCRIPTION: + -- In this test the main task makes a variety of calls to the protected + -- object Initial_PO. These calls include a simple call, a conditional + -- call, and a timed call. The timed calls include calls with enough + -- time and those with less than the needed amount of time to get through + -- the requeue performed by Initial_PO. + -- Initial_PO requeues its entry call to Final_PO. + -- Final_PO does not accept the requeued call until the protected + -- procedure Ok_To_Take_Requeue is called. + -- A separate task, Delayed_Opener, is used to call Ok_To_Take_Requeue + -- after a delay amount specified by the main task has expired. + -- + -- + -- CHANGE HISTORY: + -- 15 DEC 95 SAIC ACVC 2.1 + -- 10 JUL 96 SAIC Incorporated reviewer comments. + -- 10 OCT 96 SAIC Incorporated fix provided by vendor. + -- + --! + + with Calendar; + use type Calendar.Time; + with Report; + with Impdef; + procedure C954026 is + Verbose : constant Boolean := False; + Final_Po_Reached : Boolean := False; + Allowed_Time : constant Duration := 2.0 * Impdef.One_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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a01.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,262 ---- + -- C954A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a task requeued without abort on a protected entry queue + -- is aborted, the abort is deferred until the entry call completes, + -- after which the task becomes completed. + -- + -- TEST DESCRIPTION: + -- Declare a protected type which simulates a printer device driver + -- (foundation code). + -- + -- Declare a task which simulates a printer server for multiple printers. + -- + -- For the protected type, declare an entry with a barrier that is set + -- false by a protected procedure (which simulates starting a print job + -- on the printer), and is set true by a second protected procedure (which + -- simulates a handler called when the printer interrupts, indicating + -- that printing is done). + -- + -- For the task, declare an entry whose corresponding accept statement + -- contains a call to first protected procedure of the protected type + -- (which sets the barrier of the protected entry to false), followed by + -- a requeue with abort to the protected entry. Declare a second entry + -- which does nothing. + -- + -- Declare a "requesting" task which calls the printer server task entry + -- (and thus executes the requeue). Attempt to abort the requesting + -- task. Verify that it is not aborted. Call the second protected + -- procedure of the protected type (the interrupt handler) and verify that + -- the protected entry completes for the requesting task. Verify that + -- the requesting task is then aborted. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F954A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Oct 96 SAIC Added pragma elaborate. + -- + --! + + package C954A01_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + + end C954A01_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with F954A00; -- Printer device abstraction. + use F954A00; + pragma Elaborate(F954A00); + + package body C954A01_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing; -- server task free + -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + -- Allow other tasks to get control + delay ImpDef.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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a02.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- C954A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a task requeued with abort on a protected entry queue + -- is aborted, the protected entry call is canceled and the aborted + -- task becomes completed. + -- + -- TEST DESCRIPTION: + -- Declare a protected type which simulates a printer device driver + -- (foundation code). + -- + -- Declare a task which simulates a printer server for multiple printers. + -- + -- For the protected type, declare an entry with a barrier that is set + -- false by a protected procedure (which simulates starting a print job + -- on the printer), and is set true by a second protected procedure (which + -- simulates a handler called when the printer interrupts, indicating + -- that printing is done). + -- + -- For the task, declare an entry whose corresponding accept statement + -- contains a call to first protected procedure of the protected type + -- (which sets the barrier of the protected entry to false), followed by + -- a requeue with abort to the protected entry. Declare a second entry + -- which does nothing. + -- + -- Declare a "requesting" task which calls the printer server task entry + -- (and thus executes the requeue). Attempt to abort the requesting + -- task. Verify that it is aborted, that the requeued entry call is + -- canceled, and that the corresponding entry body is not executed. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F954A00.A + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Oct 96 SAIC Added pragma elaborate + -- + --! + + package C954A02_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + + end C954A02_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with F954A00; -- Printer device abstraction. + use F954A00; + pragma Elaborate(F954a00); + + package body C954A02_0 is -- Printer server abstraction. + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other task to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + + end C954A02_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with F954A00; -- Printer device abstraction. + with C954A02_0; -- Printer server abstraction. + + use C954A02_0; + use F954A00; + + procedure C954A02 is + + -- Length of time which simulates a very long process + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + --==============================================-- + + task Print_Request; -- Send a print request. + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Report.Failed ("Task continued execution following entry call"); + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + + begin -- Main program. + + Report.Test ("C954A02", "Abort a requeue on a Protected entry"); + + -- To pass this test, the following must be true: + -- + -- (A) The abort of Print_Request takes place immediately. + -- (B) The Done_Printing entry call is canceled, and the corresponding + -- entry body is not executed. + -- + -- Call the entry Verify_Results. The entry call will not be accepted + -- until after Print_Request has been requeued to Done_Printing. + + Printer_Server.Verify_Results; -- Accepted after Print_Request is + -- requeued to Done_Printing. + + -- Verify that the Done_Printing entry call has not been completed. + -- + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + else + + -- Simulate an application which needs access to the printer within + -- a specified time, and which aborts the current printer job if time + -- runs out. + + select + Printer(1).Done_Printing; -- Wait for printer to come free. + or + delay Long_Enough; -- Print job took too long. + abort Print_Request; -- Abort print job. + end select; + + Printer_Server.Verify_Results; -- Abortion completion point: force + -- Print_Request abort to complete. + + -- Verify (A): that Print_Request has been aborted. + -- Note: the test will hang if the task as not been aborted + -- + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- Verify (B): that the Done_Printing entry call was canceled, and + -- the corresponding entry body was not executed. + -- + -- Set the barrier of the entry to true, then check that the entry + -- body is not executed. If the entry call is NOT canceled, the + -- entry body will execute when the barrier is set true. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + if Printer(1).Is_Done then + Report.Failed ("Entry call was not canceled"); + end if; + + + end if; + + + Report.Result; + + end C954A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c954a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c954a03.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,322 ---- + -- C954A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a requeue statement in an accept_statement with + -- parameters may requeue the entry call to a protected entry with no + -- parameters. Check that, if the call is queued on the new entry's + -- queue, the original caller remains blocked after the requeue, but + -- the accept_statement containing the requeue is completed. + -- + -- Note that this test uses a requeue "with abort," although it does not + -- check that such a requeued caller can be aborted; that feature is + -- tested elsewhere. + -- + -- TEST DESCRIPTION: + -- Declare a protected type which simulates a printer device driver + -- (foundation code). + -- + -- Declare a task which simulates a printer server for multiple printers. + -- + -- For the protected type, declare an entry with a barrier that is set + -- false by a protected procedure (which simulates starting a print job + -- on the printer), and is set true by a second protected procedure (which + -- simulates a handler called when the printer interrupts, indicating + -- that printing is done). + -- + -- For the task, declare an entry whose corresponding accept statement + -- contains a call to first protected procedure of the protected type + -- (which sets the barrier of the protected entry to false), followed by + -- a requeue with abort to the protected entry. Declare a second entry + -- which does nothing. + -- + -- Declare a "requesting" task which calls the printer server task entry + -- (and thus executes the requeue). Verify that, following the requeue, + -- the requesting task remains blocked. Call the second entry of the + -- printer server task (the acceptance of this entry call verifies that + -- the requeue statement completed the entry call by the requesting task. + -- Call the second protected procedure of the protected type (the + -- interrupt handler) and verify that the protected entry completes for + -- the requesting task (which verifies that the requeue statement queued + -- the first task object to the protected entry). + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- F954A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Oct 96 SAIC Added pragma elaborate. + -- + --! + + package C954A03_0 is -- Printer server abstraction. + + -- Simulate a system with multiple printers. The entry Print requests + -- that data be printed on the next available printer. The entry call + -- is accepted when a printer is available, and completes when printing + -- is done. + + task Printer_Server is + entry Print (File_Name : String); -- Test the requeue statement. + entry Verify_Results; -- Artifice for test purposes. + end Printer_Server; + + end C954A03_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with F954A00; -- Printer device abstraction. + use F954A00; + pragma Elaborate(F954a00); + + package body C954A03_0 is -- Printer server abstraction. + + + task body Printer_Server is + Printers_Busy : Boolean := True; + Index : Printer_ID := 1; + Print_Accepted : Boolean := False; + begin + + loop + -- Wait for a printer to become available: + + while Printers_Busy loop + Printers_Busy := False; -- Exit loop if + -- entry accepted. + select + Printer(Index).Done_Printing; -- Accepted immed. + -- when printer is + -- available. + else + Index := 1 + (Index mod Number_Of_Printers);-- Entry not immed. + Printers_Busy := True; -- accepted; keep + end select; -- looping. + + -- Allow other tasks to get control + delay ImpDef.Minimum_Task_Switch; + + end loop; + -- Value of Index + -- at loop exit + -- identifies the + -- avail. printer. + + -- Wait for a print request or terminate: + + select + accept Print (File_Name : String) do + Print_Accepted := True; -- Allow + -- Verify_Results + -- to be accepted. + + Printer(Index).Start_Printing (File_Name); -- Begin printing on + -- the available + -- -- -- printer. + -- Requeue is tested here -- + -- -- + -- Requeue caller so + requeue Printer(Index).Done_Printing -- server task free + with abort; -- to accept other + end Print; -- requests. + or + -- Guard ensures that Verify_Results cannot be accepted + -- until after Print has been accepted. This avoids a + -- race condition in the main program. + + when Print_Accepted => accept Verify_Results; -- Artifice for + -- testing purposes. + or + terminate; + end select; + + end loop; + + exception + when others => + Report.Failed ("Exception raised in Printer_Server task"); + end Printer_Server; + + + end C954A03_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with F954A00; -- Printer device abstraction. + with C954A03_0; -- Printer server abstraction. + + use C954A03_0; + use F954A00; + + procedure C954A03 is + + Long_Enough : constant Duration := ImpDef.Clear_Ready_Queue; + + + --==============================================-- + + Task_Completed : Boolean := False; -- Testing flag. + + protected Interlock is -- Artifice for test purposes. + entry Wait; -- Wait for lock to be released. + procedure Release; -- Release the lock. + private + Locked : Boolean := True; + end Interlock; + + + protected body Interlock is + + entry Wait when not Locked is -- Calls are queued until after + -- -- Release is called. + begin + Task_Completed := True; + end Wait; + + procedure Release is -- Called by Print_Request. + begin + Locked := False; + end Release; + + end Interlock; + + --==============================================-- + + task Print_Request is -- Send a print request. + end Print_Request; + + task body Print_Request is + My_File : constant String := "MYFILE.DAT"; + begin + Printer_Server.Print (My_File); -- Invoke requeue statement. + Interlock.Release; -- Allow main to continue. + exception + when others => + Report.Failed ("Exception raised in Print_Request task"); + end Print_Request; + + --==============================================-- + + begin -- Main program. + + Report.Test ("C954A03", "Requeue from an Accept with parameters" & + " to a Protected Entry without parameters"); + + -- To pass this test, the following must be true: + -- + -- (A) The Print entry call made by the task Print_Request must be + -- completed by the requeue statement. + -- (B) Print_Request must remain blocked following the requeue. + -- (C) Print_Request must be queued on the Done_Printing queue of + -- Printer(1). + -- (D) Print_Request must continue execution after Done_Printing is + -- complete. + -- + -- First, verify (A): that the Print entry call is complete. + -- + -- Call the entry Verify_Results. If the requeue statement completed the + -- entry call to Print, the entry call to Verify_Results should be + -- accepted. Since the main will hang if this is NOT the case, make this + -- a timed entry call. + + select + Printer_Server.Verify_Results; -- Accepted if requeue completed + -- entry call to Print. + or + delay Long_Enough; -- Time out otherwise. + Report.Failed ("Requeue did not complete entry call"); + end select; + + -- Now verify (B): that Print_Request remains blocked following the + -- requeue. Also verify that Done_Printing (the entry to which + -- Print_Request should have been queued) has not yet executed. + + if Printer(1).Is_Done then + Report.Failed ("Target entry of requeue executed prematurely"); + elsif Print_Request'Terminated then + Report.Failed ("Caller did not remain blocked after the requeue"); + else + + -- Verify (C): that Print_Request is queued on the + -- Done_Printing queue of Printer(1). + -- + -- Set the barrier for Printer(1).Done_Printing to true. Check + -- that the Done flag is updated and that Print_Request terminates. + + Printer(1).Handle_Interrupt; -- Simulate a printer interrupt, + -- signaling that printing is + -- done. + + -- The Done_Printing entry body will complete before the next + -- protected action is called (Printer(1).Is_Done). + + if not Printer(1).Is_Done then + Report.Failed ("Caller was not requeued on target entry"); + end if; + + -- Finally, verify (D): that Print_Request continues after Done_Printing + -- completes. + -- + -- After Done_Printing completes, there is a potential race condition + -- between the main program and Print_Request. The protected object + -- Interlock is provided to ensure that the check of whether + -- Print_Request continued is made *after* it has had a chance to do so. + -- The main program waits until the statement in Print_Request following + -- the requeue-causing statement has executed, then checks to see + -- whether Print_Request did in fact continue executing. + -- + -- Note that the test will hang here if Print_Request does not continue + -- executing following the completion of the requeued entry call. + + Interlock.Wait; -- Wait until Print_Request is + -- done. + if not Task_Completed then + Report.Failed ("Caller remained blocked after target " & + "entry released"); + end if; + + -- Wait for Print_Request to finish before calling Report.Result. + while not Print_Request'Terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + end if; + + Report.Result; + + end C954A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- C960001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Confirm that a simple Delay Until statement is performed. Check + -- that the delay does not complete before the requested time and that it + -- does complete thereafter + -- + -- TEST DESCRIPTION: + -- Simulate a task that sends a "pulse" at regular intervals. The Delay + -- Until statement is used to avoid accumulated drift. For the + -- test, we expect the delay to return very close to the requested time; + -- we use an additional Pulse_Time_Delta for the limit. The test + -- driver (main) artificially limits the number of iterations by setting + -- the Stop_Pulse Boolean after a small number. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Fixed global variable problem for ACVC 2.0.1 + -- + --! + + with Report; + with Ada.Calendar; + with ImpDef; + + procedure C960001 is + + begin + + Report.Test ("C960001", "Simple Delay Until"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "<" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar."<"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + TC_Loop_Count : integer range 0..4 := 0; + + + -- control over stopping tasks + protected Control is + procedure Stop_Now; + function Stop return Boolean; + private + Halt : Boolean := False; + end Control; + + protected body Control is + procedure Stop_Now is + begin + Halt := True; + end Stop_Now; + + function Stop return Boolean is + begin + return Halt; + end Stop; + end Control; + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization; Control.Stop + -- becoming true terminates the task. + -- + task body Pulse_Task is + + Pulse_Time : Ada.Calendar.Time; + + Pulse_Time_Delta : duration := ImpDef.Clear_Ready_Queue; + + TC_Last_Time : Ada.Calendar.Time; + TC_Current : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + TC_Last_Time := Pulse_Time; + + while not Control.Stop loop + delay until Pulse_Time; + Pulse; + + -- Calculate time for next pulse. Note: this is based on the + -- last pulse time, not the time we returned from the delay + -- + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- Test Control: + TC_Current := Ada.Calendar.Clock; + if TC_Current < TC_Last_Time then + Report.Failed ("Delay expired before requested time"); + end if; + if TC_Current > Pulse_Time then + Report.Failed ("Delay too long"); + end if; + TC_Last_Time := Pulse_Time; + TC_Loop_Count := TC_Loop_Count +1; + end loop; + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + -- Artificially limit the number of iterations + while TC_Loop_Count < 3 loop + delay ImpDef.Minimum_Task_Switch; + end loop; + -- + Control.Stop_Now; -- End test + + end; -- declare + + Report.Result; + + end C960001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,171 ---- + -- C960002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the simple "delay until" when the request time is "now" and + -- also some time already in the past is obeyed and returns immediately + -- + -- TEST DESCRIPTION: + -- Simulate a task that sends a "pulse" at regular intervals. The Delay + -- Until statement is used to avoid accumulated drift. In this test + -- three simple situations simulating the start of drift are used: the + -- next pulse being called for at the normal time, the next pulse being + -- called for at exactly the current time and then at some time which has + -- already past. We assume the delay is within a While Loop and, to + -- simplify the test, we "unfold" the While Loop and execute the Delays + -- in a serial fashion. This loop is shown in test C960001. + -- It is not possible to test the actual immediacy of the expiration. We + -- can only check that it returns in a "reasonable" time. In this case + -- we check that it expires before the next "pulse" should have been + -- issued. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + with Ada.Calendar; + with System; + + procedure C960002 is + + begin + + Report.Test ("C960002", "Simple Delay Until with requested time being" & + " ""now"" and time already in the past"); + + declare -- To get the Report.Result after all has completed + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + function "-" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "-" (Left, Right : Ada.Calendar.Time) + return duration renames Ada.Calendar."-"; + function ">" (Left, Right : Ada.Calendar.Time) + return Boolean renames Ada.Calendar.">"; + + + task Pulse_Task is + entry Trigger; + end Pulse_Task; + + + -- Task to synchronize all qualified receivers. + -- The entry Trigger starts the synchronization. + -- + task body Pulse_Task is + Pulse_Time : Ada.Calendar.Time; + Pulse_Time_Delta : constant duration := ImpDef.Clear_Ready_Queue; + + + + TC_Time_Back : Ada.Calendar.Time; + + + -- This routine transmits a synchronizing "pulse" to + -- all receivers + procedure Pulse is + begin + null; -- Stub + Report.Comment (".......PULSE........"); + end Pulse; + + begin + accept Trigger; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Ada.Calendar.Clock + Pulse_Time_Delta; + + -- TC: unfold the "while" loop in C960001. Four passes through + -- the loop are shown + + delay until Pulse_Time; + + Pulse; + --------------- + -- TC: the normal calculation for "next" would be + -- Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Instead of this normal pulse time calculation simulate + -- the new pulse time to be exactly "now" (or, as exactly as + -- we can) + Pulse_Time := Ada.Calendar.Clock; + delay until Ada.Calendar.Clock; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - A"); + end if; + Pulse; + --------------- + -- normal calculation for "next" would be + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + + -- TC: Instead of this, simulate the new calculated pulse time + -- being already past + Pulse_Time := Ada.Calendar.Clock - System.Tick; + delay until Pulse_Time; + + TC_Time_Back := Ada.Calendar.Clock; + + -- Now check for reasonableness + if TC_Time_Back > Pulse_Time + Pulse_Time_Delta then + Report.Failed + ("""Now"" delayed for more than Pulse_Time_Delta - B"); + end if; + Pulse; + --------------- + -- normal calculation for "next" + Pulse_Time := Pulse_Time + Pulse_Time_Delta; + -- Now simulate getting back into synch + delay until Pulse_Time; + Pulse; + --------------- + -- This would be the end of the "while" loop + + exception + when others => + Report.Failed ("Unexpected exception in Pulse_Task"); + end Pulse_Task; + + + + begin -- declare + + Pulse_Task.Trigger; -- Start test + + end; -- declare + + Report.Result; + + end C960002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c960004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c960004.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,206 ---- + -- C960004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- With the triggering statement being a delay and with the Asynchronous + -- Select statement being in a tasking situation complete the abortable + -- part before the delay expires. Check that the delay is cancelled + -- and that the optional statements in the triggering part are not + -- executed. + -- + -- TEST DESCRIPTION: + -- Simulate the creation of a carrier task to control the output of + -- a message via a line driver. If the message sending process is + -- not complete (the completion of the rendezvous) within a + -- specified time the carrier task is designed to take corrective action. + -- Use an asynchronous select to control the timing; arrange that + -- the abortable part (the rendezvous) completes almost immediately. + -- Check that the optional statements are not executed and that the + -- test completes well before the time of the trigger delay request thus + -- showing that it has been cancelled. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with Ada.Calendar; + + procedure C960004 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + -- Note: a properly executing test will complete immediately. + Allowable_ACK_Time : duration := 600.0; + + begin + + Report.Test ("C960004", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed. Tasking situation"); + + declare -- To get the Report.Result after all has completed + + type Sequence_Number is range 1..1_999_999; -- Message Number + subtype S_length_subtype is integer range 1..80; + + type Message_Type (Max_String : S_length_subtype := 1) is + record + Message_Number : Sequence_Number; + Alpha : string(1..Max_String); + end record; + + -- TC: Dummy message for the test + Dummy_Alpha : constant string := "This could be printed"; + Message_to_Send : Message_Type (Max_string => Dummy_Alpha'length); + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task type Require_ACK_task is + entry Message_In (Message_to_Send: Message_Type); + end Require_ACK_task; + type acc_Require_ACK_task is access Require_ACK_task; + + + --::::::::::::::::::::::::::::::::: + -- There would also be another task type "No_ACK_Task" which would + -- be the carrier task for those messages not requiring an ACK. + -- This task would call Send_Message.ACK_Not_Required. It is not + -- shown in this test as it is not used. + --::::::::::::::::::::::::::::::::: + + + + task Send_Message is + entry ACK_Required (Message_to_Send: Message_Type); + entry ACK_Not_Required (Message_to_Send: Message_Type); + end Send_Message; + + + -- This is the carrier task. One of these is created for each + -- message that requires ACK + -- + task body Require_ACK_task is + Hold_Message : Message_Type; + + procedure Time_Out (Failed_Message_Number : Sequence_Number) is + begin + -- Take remedial action on the timed-out message + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Time_out; + + begin + accept Message_In (Message_to_Send: Message_Type) do + Hold_Message := Message_to_Send; -- to release caller + end Message_In; + + -- Now put the message out to the Send_Message task and + -- wait (no more than Allowable_Ack_Time) for its completion + -- + select + delay Allowable_ACK_Time; + -- ACK not received in specified time + Time_out (Hold_Message.Message_Number); + then abort + -- If the rendezvous is not completed in the above time, this + -- call is cancelled + -- Note: for this test this call will complete immediately + -- and thus the trigger should be cancelled + Send_Message.ACK_Required (Hold_Message); + end select; + + exception + when others => + Report.Failed ("Unexpected exception in Require_ACK_task"); + end Require_ACK_task; + + + -- This is the Line Driver task + -- + task body Send_Message is + Hold_Non_ACK_Message : Message_Type; + begin + loop + select + accept ACK_Required (Message_to_Send: Message_Type) do + -- Here send the message from within the rendezvous + -- waiting for full transmission to complete + null; -- stub + -- Note: In this test this accept will complete immediately + end ACK_Required; + or + accept ACK_Not_Required (Message_to_Send: Message_Type) do + Hold_Non_ACK_Message := Message_to_Send; + end ACK_Not_Required; + -- Here send the message from outside the rendezvous + null; -- stub + or + terminate; + end select; + end loop; + exception + when others => Report.Failed ("Unexpected exception in Send_Message"); + end Send_Message; + + begin -- declare + -- Build a dummy message + Message_to_Send.Alpha := Dummy_Alpha; + Message_to_Send.Message_Number := 110_693; + + declare + New_Require_ACK_task : acc_Require_ACK_task := + new Require_ACK_task; + begin + -- Create a carrier task for this message and pass the latter in + New_Require_ACK_task.Message_In (Message_to_Send); + end; -- declare + + end; -- declare + + --Once we are out of the above declarative region, all tasks have completed + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Check that the test has completed well before the time of the requested + -- delay to ensure the delay was cancelled + -- + if (TC_Elapsed_Time > Allowable_ACK_Time/2) then + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + Report.Result; + end C960004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96001a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- C96001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DELAY STATEMENT DELAYS EXECUTION FOR AT LEAST THE + -- SPECIFIED TIME. SPECIFICALLY, + -- (A) POSITIVE DELAY ARGUMENT. + -- (B) NEGATIVE DELAY ARGUMENT. + -- (C) ZERO DELAY ARGUMENT. + -- (D) DURATION'SMALL DELAY ARGUMENT. + -- (E) EXPRESSION OF TYPE DURATION AS DELAY ARGUMENT. + + -- HISTORY: + -- CPP 8/14/84 CREATED ORIGINAL TEST. + -- RJW 11/13/87 ADDED CODE WHICH ALLOWS TEST TO REPORT "PASSED" + -- IF TICK > DURATION'SMALL. + + with Impdef; + WITH CALENDAR; USE CALENDAR; + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C96001A IS + + SUBTYPE INT IS INTEGER RANGE 0 .. 20_000; + + BEGIN + TEST ("C96001A", "CHECK THAT DELAY STATEMENT DELAYS " & + "EXECUTION FOR AT LEAST THE SPECIFIED TIME"); + + --------------------------------------------- + + DECLARE -- (A) + X : DURATION := 5.0; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (A) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST 5.0 " & + "SECONDS - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (A)"); + END; + + --------------------------------------------- + + DECLARE -- (B) + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (B) + LOOP + OLD_TIME := CLOCK; + DELAY -5.0; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(B) - NEGATIVE DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (B)"); + END; + + --------------------------------------------- + + DECLARE -- (C) + X : DURATION := 0.0; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (C) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + COMMENT ("(C) - ZERO DELAY LAPSED FOR " & + INT'IMAGE (INT (LAPSE * 1_000)) & " MILLISECONDS"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (C)"); + END; + + --------------------------------------------- + + DECLARE -- (D) + X : DURATION := DURATION'SMALL; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (D) + LOOP + OLD_TIME := CLOCK; + DELAY X; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < X THEN + IF TICK < DURATION'SMALL THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "DURATION'SMALL SECONDS - (D)"); + ELSE + COMMENT ("TICK > DURATION'SMALL SO DELAY IN " & + "'(D)' IS NOT MEASURABLE"); + END IF; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (D)"); + END; + + --------------------------------------------- + + DECLARE -- (E) + INC1 : DURATION := 2.0 * Impdef.One_Second; + INC2 : DURATION := 3.0 * Impdef.One_Second; + OLD_TIME : TIME; + LAPSE : DURATION; + BEGIN -- (E) + LOOP + OLD_TIME := CLOCK; + DELAY INC1 + INC2; + LAPSE := CLOCK - OLD_TIME; + EXIT; + END LOOP; + IF LAPSE < (INC1 + INC2) THEN + FAILED ("DELAY DID NOT LAPSE AT LEAST " & + "INC1 + INC2 SECONDS - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - (E)"); + END; + + RESULT; + END C96001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,258 ---- + -- C96004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PRE-DEFINED SUBTYPES FROM THE PACKAGE CALENDAR, + -- NAMELY YEAR_NUMBER, MONTH_NUMBER, DAY_NUMBER, AND DAY_DURATION, + -- HAVE THE CORRECT RANGE CONSTRAINTS. SUBTESTS ARE: + -- (A) YEAR_NUMBER. + -- (B) MONTH_NUMBER. + -- (C) DAY_NUMBER. + -- (D) DAY_DURATION. + + -- HISTORY: + -- CPP 08/15/84 CREATED ORIGINAL TEST. + -- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO PREVENT + -- OPTIMIZATION. + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96004A IS + + BEGIN + TEST("C96004A", "CHECK THAT PRE-DEFINED SUBTYPES FROM THE " & + "CALENDAR PACKAGE HAVE CORRECT RANGE CONSTRAINTS"); + + --------------------------------------------- + + DECLARE -- (A) + + YR : YEAR_NUMBER; + + BEGIN -- (A) + + BEGIN + YR := 1900; + FAILED ("EXCEPTION NOT RAISED - (A)1"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)1"); + END; + + BEGIN + YR := 84; + FAILED ("EXCEPTION NOT RAISED - (A)2"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)2"); + END; + + BEGIN + YR := 2099; + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 2099 - (A)"); + END; + + BEGIN + YR := IDENT_INT(2100); + FAILED ("EXCEPTION NOT RAISED - (A)3"); + IF NOT EQUAL (YR, YR) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (A)3"); + END; + + END; -- (A) + + --------------------------------------------- + + DECLARE -- (B) + + MO : MONTH_NUMBER; + + BEGIN -- (B) + + BEGIN + MO := IDENT_INT(0); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + BEGIN + MO := 12; + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 12 - (B)"); + END; + + BEGIN + MO := 13; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + IF NOT EQUAL (MO, MO) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + + DY : DAY_NUMBER; + + BEGIN -- (C) + + BEGIN + DY := 0; + FAILED ("EXCEPTION NOT RAISED - (C)1"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)1"); + END; + + BEGIN + DY := IDENT_INT(32); + FAILED ("EXCEPTION NOT RAISED - (C)2"); + IF NOT EQUAL (DY, DY) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (C)2"); + END; + + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + + SEGMENT : DAY_DURATION; + + FUNCTION CHECK_OK (X : DAY_DURATION) RETURN BOOLEAN IS + I : INTEGER := INTEGER (X); + BEGIN + RETURN EQUAL (I,I); + END CHECK_OK; + + BEGIN -- (D) + + BEGIN + SEGMENT := 86_400.0; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + COMMENT ("NO EXCEPTION RAISED (D1)"); + ELSE + COMMENT ("NO EXCEPTION RAISED (D2)"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("OK CASE RAISED EXCEPTION ON 86_400 - (D)"); + END; + + BEGIN + SEGMENT := -4.0; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + IF NOT EQUAL (INTEGER(SEGMENT), INTEGER(SEGMENT)) THEN + COMMENT ("NO EXCEPTION RAISED (D3)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + BEGIN + SEGMENT := 86_401.00; + IF CHECK_OK (SEGMENT - 86_000.0) THEN + FAILED ("NO EXCEPTION RAISED (D4)"); + ELSE + FAILED ("NO EXCEPTION RAISED (D5)"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; + END C96004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- C96005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN + -- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. + -- SPECIFICALLY, + -- (A) CHECK THAT ADDITION AND SUBTRACTION OPERATORS WORK CORRECTLY ON + -- VALUES OF TYPE TIME. + + -- CPP 8/16/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + -- WITH TEXT_IO; USE TEXT_IO; + PROCEDURE C96005A IS + + -- PACKAGE DURATION_IO IS NEW FIXED_IO (DURATION); + -- USE DURATION_IO; + + BEGIN + TEST ("C96005A", "CHECK THAT THE ADDITION AND SUBTRACTION " & + "FUNCTIONS FOR VALUES OF TYPE TIME WORK CORRECTLY"); + + ----------------------------------------------- + + BEGIN -- (A) + + -- ADDITION TESTS FOLLOW. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW + INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)1"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := INCREMENT + NOW; + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)2"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(INCREMENT, NOW); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)3"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := "+"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 8, 13, 1.0) THEN + FAILED ("SUM OF TIMES IS INCORRECT - (A)4"); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 45_000.0); + ONCE := TIME_OF (1984, 8, 12, 45_000.0); + DIFFERENCE := NOW - ONCE; + IF DIFFERENCE /= 86_400.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)1"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT MONTHS. + NOW, ONCE : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, IDENT_INT(1), 60.0); + ONCE := TIME_OF (1984, 7, 31, 86_399.0); + DIFFERENCE := "-"(NOW, ONCE); + IF DIFFERENCE /= 61.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)2"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN DIFFERENT YEARS. + NOW, AFTER : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (IDENT_INT(1999), 12, 31, 86_399.0); + AFTER := TIME_OF (2000, 1, 1, 1.0); + DIFFERENCE := "-"(LEFT => AFTER, + RIGHT => NOW); + IF DIFFERENCE /= 2.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)3"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A LEAP YEAR. + NOW, LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1984, 3, 1); + LEAP := TIME_OF (1984, 2, 29, 86_399.0); + DIFFERENCE := NOW - LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)4"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + DECLARE + -- TIMES IN A NON-LEAP YEAR. + NOW, NON_LEAP : TIME; + DIFFERENCE : DURATION; + BEGIN + NOW := TIME_OF (1983, 3, 1); + NON_LEAP := TIME_OF (1983, 2, 28, 86_399.0); + DIFFERENCE := NOW - NON_LEAP; + IF DIFFERENCE /= 1.0 THEN + FAILED ("DIFFERENCE OF TIMES IS INCORRECT - (A)5"); + -- COMMENT ("DIFFERENCE YIELDS: "); + -- PUT (DIFFERENCE); + END IF; + END; + + + -- SUBTRACTION TESTS FOLLOW: TIME - DURATION. + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 8, 12, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)6"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := NOW - INCREMENT; + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(LEFT => NOW, + RIGHT => INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)8"); + END IF; + END; + + + DECLARE + NOW, NEW_TIME : TIME; + INCREMENT : DURATION := 1.0; + BEGIN + NOW := TIME_OF (1984, 8, 1, 0.0); + NEW_TIME := "-"(NOW, INCREMENT); + IF NEW_TIME /= TIME_OF (1984, 7, 31, 86_399.0) THEN + FAILED ("DIFFERENCE OF TIME AND DURATION IS " & + "INCORRECT - (A)7"); + END IF; + END; + + + END; -- (A) + + ----------------------------------------------- + + RESULT; + END C96005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005b.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005b.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005b.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005b.tst 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- C96005B.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN + -- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. + -- SPECIFICALLY, + -- (B) ADDITION AND SUBTRACTION OPERATORS RAISE CONSTRAINT_ERROR WHEN + -- CALLED WITH AN OUT OF RANGE DURATION PARAMETER. + + -- CPP 8/16/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96005B IS + + BEGIN + TEST ("C96005B", "CHECK THAT ADDITION AND SUBTRACTION " & + "OPERATORS RAISE CONSTRAINT_ERROR WHEN CALLED WITH " & + "OUT OF RANGE DURATION PARAMETER"); + + ----------------------------------------------- + + BEGIN -- (B) + + -- ADDITION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)1"); + BEFORE := BEFORE + ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)1"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)1"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)1"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)2"); + BEFORE := $GREATER_THAN_DURATION + BEFORE; + FAILED ("EXCEPTION NOT RAISED - (B)2"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)2"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)2"); + END; + + + -- SUBTRACTION TESTS FOLLOW. + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'BASE'FIRST < DURATION'FIRST THEN + COMMENT("LOW VALUES EXIST - (B)3"); + BEFORE := BEFORE - ($LESS_THAN_DURATION); + FAILED ("EXCEPTION NOT RAISED - (B)3"); + ELSE + NOT_APPLICABLE ("NO LOW VALUES EXIST - (B)3"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)3"); + END; + + DECLARE + BEFORE : TIME := CLOCK; + BEGIN + IF DURATION'LAST < DURATION'BASE'LAST THEN + COMMENT("HIGH VALUES EXIST - (B)4"); + BEFORE := BEFORE - $GREATER_THAN_DURATION; + FAILED ("EXCEPTION NOT RAISED - (B)4"); + ELSE + NOT_APPLICABLE ("NO HIGH VALUES EXIST - (B)4"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN TIME_ERROR => + FAILED ("TIME_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - (B)4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (B)4"); + END; + + + END; -- (B) + + ----------------------------------------------- + + RESULT; + END C96005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C96005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THE CORRECTNESS OF THE ADDITION AND SUBTRACTION FUNCTIONS IN + -- THE PREDEFINED PACKAGE CALENDAR, AND APPROPRIATE EXCEPTION HANDLING. + -- SPECIFICALLY, + -- (D) THE EXCEPTION TIME_ERROR IS RAISED WHEN THE FUNCTION "-" + -- RETURNS A VALUE NOT IN THE SUBTYPE RANGE DURATION. + + -- CPP 8/16/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96005D IS + + BEGIN + TEST ("C96005D", "CHECK THAT THE SUBTRACTION OPERATOR RAISES " & + "TIME_ERROR APPROPRIATELY"); + + --------------------------------------------- + + BEGIN -- (D) + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'LAST) + 1.0; + WAIT := LATER - NOW; + FAILED ("EXCEPTION NOT RAISED - (D)1"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)1"); + END; + + + DECLARE + NOW, LATER : TIME; + WAIT : DURATION; + BEGIN + NOW := TIME_OF (1984, 8, 13, 0.0); + LATER := (NOW + DURATION'FIRST) - 1.0; + WAIT := NOW - LATER; + FAILED ("EXCEPTION NOT RAISED - (D)2"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (D)2"); + END; + + END; -- (D) + + --------------------------------------------- + + RESULT; + END C96005D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96005f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96005f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- C96005F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PACKAGE CALENDAR + AND - FUNCTIONS WORK PROPERLY, + -- ESPECIALLY WITH VALUES AT MIDNIGHT. + + -- GOM 02/18/85 + -- JWC 05/14/85 + + WITH REPORT; + USE REPORT; + WITH CALENDAR; + USE CALENDAR; + + PROCEDURE C96005F IS + + CURR_DAY1 : CONSTANT TIME := TIME_OF(1984,1,1,0.0); + CURR_DAY2 : CONSTANT TIME := TIME_OF(1984,1,1,DAY_DURATION'LAST); + CURR_DAY3 : CONSTANT TIME := TIME_OF(1984,1,1,10000.0); + + TOMORROW1 : CONSTANT TIME := TIME_OF(1984,1,2,0.0); + TOMORROW2 : CONSTANT TIME := TIME_OF(1984,1,2,DAY_DURATION'LAST); + TOMORROW3 : CONSTANT TIME := TIME_OF(1984,1,2,10000.0); + + YESTERDAY1 : CONSTANT TIME := TIME_OF(1983,12,31,0.0); + YESTERDAY2 : CONSTANT TIME := TIME_OF(1983,12,31, + DAY_DURATION'LAST); + YESTERDAY3 : CONSTANT TIME := TIME_OF(1983,12,31,10000.0); + + BEGIN + TEST("C96005F","CHECKING PACKAGE CALENDAR + AND - FUNCTIONS"); + + -- CHECK IF ADDING ONE DAY TO 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'TOMORROW'. + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= TOMORROW1 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 + DAY_DURATION'LAST) /= TOMORROW2 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 + DAY_DURATION'LAST) /= TOMORROW3 THEN + FAILED("FAILURE IN ADDING 1 DAY TO 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY1 + DAY_DURATION'LAST) /= CURR_DAY2 THEN + FAILED("'CURR_DAY1' + 1 /= 'CURR_DAY2'"); + END IF; + + -- CHECK IF SUBTRACTING ONE DAY FROM 'CURR_DAY#' TIMES YIELDS + -- TIMES EQUAL TO 'YESTERDAY'. + + IF (CURR_DAY1 - DAY_DURATION'LAST) /= YESTERDAY1 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY1'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= YESTERDAY2 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY2'"); + END IF; + + IF (CURR_DAY3 - DAY_DURATION'LAST) /= YESTERDAY3 THEN + FAILED("FAILURE IN SUBTRACTING 1 DAY FROM 'CURR_DAY3'"); + END IF; + + IF (CURR_DAY2 - DAY_DURATION'LAST) /= CURR_DAY1 THEN + FAILED("'CURR_DAY2' - 1 /= 'CURR_DAY1'"); + END IF; + + RESULT; + END C96005F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,298 ---- + -- C96006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR THE PACKAGE CALENDAR, THE RELATIONAL OPERATORS WORK + -- CORRECTLY FOR OPERANDS OF TYPE TIME AND TYPE DURATION. PARTICULARLY, + -- (A) RELATIONS BASED ON YEARS. + -- (B) RELATIONS BASED ON MONTH. + -- (C) RELATIONS BASED ON SECONDS. + -- (D) RELATIONS AT EXTREMES OF THE PERMITTED RANGE OF TIME. + + -- CPP 8/16/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96006A IS + + BEGIN + TEST ("C96006A", "CHECK THAT RELATIONAL OPERATORS WORK " & + "CORRECTLY IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + -- RELATIONS BASED ON YEARS. + NOW, LATER : TIME; + BEGIN -- (A) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1985, 8, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (A)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (A)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (A)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (A)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (A)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (A)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (A)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (A)2"); + END IF; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + -- RELATIONS BASED ON MONTH. + NOW, LATER : TIME; + BEGIN -- (B) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := TIME_OF (1984, 9, 12, 500.0); + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (B)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (B)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (B)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (B)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (B)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (B)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (B)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (B)2"); + END IF; + + IF NOW = NOW THEN + COMMENT ("= OPERATOR OK - (B)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (B)"); + END IF; + + IF LATER /= NOW THEN + COMMENT ("/= OPERATOR OK - (B)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (B)"); + END IF; + + END; -- (B) + + -------------------------------------------- + + DECLARE -- (C) + -- RELATIONS BASED ON SECONDS. + NOW, LATER : TIME; + INCREMENT : DURATION := 99.9; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 12, 500.0); + LATER := NOW + INCREMENT; + + IF NOW < LATER THEN + COMMENT ("< OPERATOR OK - (C)"); + ELSE + FAILED ("< OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= LATER THEN + COMMENT ("<= OPERATOR OK - (C)"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW <= NOW THEN + COMMENT ("<= OPERATOR OK - (C)2"); + ELSE + FAILED ("<= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER > NOW THEN + COMMENT ("> OPERATOR OK - (C)"); + ELSE + FAILED ("> OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= NOW THEN + COMMENT (">= OPERATOR OK - (C)"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)"); + END IF; + + IF LATER >= LATER THEN + COMMENT (">= OPERATOR OK - (C)2"); + ELSE + FAILED (">= OPERATOR INCORRECT - (C)2"); + END IF; + + IF LATER = LATER THEN + COMMENT ("= OPERATOR OK - (C)"); + ELSE + FAILED ("= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW /= LATER THEN + COMMENT ("/= OPERATOR OK - (C)"); + ELSE + FAILED ("/= OPERATOR INCORRECT - (C)"); + END IF; + + IF NOW < NOW THEN + FAILED ("NOW < NOW INCORRECT - (C)"); + ELSIF NOW /= NOW THEN + FAILED ("NOW = NOW INCORRECT - (C)"); + ELSIF LATER < NOW THEN + FAILED ("LATER < NOW INCORRECT - (C)"); + ELSIF LATER <= NOW THEN + FAILED ("LATER <= NOW INCORRECT - (C)"); + ELSIF LATER = NOW THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + ELSIF NOW > LATER THEN + FAILED ("NOW > LATER INCORRECT - (C)"); + ELSIF NOW > NOW THEN + FAILED ("NOW > NOW INCORRECT - (C)"); + ELSIF NOW >= LATER THEN + FAILED ("NOW >= LATER INCORRECT - (C)"); + ELSIF NOW = LATER THEN + FAILED ("NOW = LATER INCORRECT - (C)"); + END IF; + + END; -- (C) + + -------------------------------------------- + + DECLARE -- (D) + + NOW, WAY_BACK_THEN : TIME; + + BEGIN -- (D) + + NOW := TIME_OF (2099, 12, 31); + WAY_BACK_THEN := TIME_OF (1901, 1, 1); + + BEGIN + IF NOW < WAY_BACK_THEN THEN + FAILED ("TEST < AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("< AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW <= WAY_BACK_THEN THEN + FAILED ("TEST <= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("<= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN > NOW THEN + FAILED ("TEST > AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("> AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN >= NOW THEN + FAILED ("TEST >= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED (">= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF WAY_BACK_THEN /= WAY_BACK_THEN THEN + FAILED ("TEST /= AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("/= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + BEGIN + IF NOW = WAY_BACK_THEN THEN + FAILED ("TEST = AT EXTREMES INCORRECT - (D)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("= AT EXTREMES RAISED EXCEPTION - (D)"); + END; + + END; -- (D) + + -------------------------------------------- + + RESULT; + END C96006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96007a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- C96007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED FOR THE TIME_OF() + -- FUNCTION IN THE PACKAGE CALENDAR. PARTICULARLY, + -- (A) TIME_ERROR IS RAISED ON INVALID DATES. + -- (B) CONSTRAINT_ERROR IS RAISED FOR OUT-OF-RANGE PARAMETERS. + + -- CPP 8/16/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96007A IS + + BEGIN + TEST ("C96007A", "CHECK THAT APPROPRIATE EXCEPTIONS ARE RAISED " & + "FOR THE TIME_OF FUNCTION IN THE PACKAGE CALENDAR"); + + -------------------------------------------- + + DECLARE -- (A) + + BAD_TIME : TIME; + + BEGIN -- (A) + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 30); + FAILED ("EXCEPTION NOT RAISED - 2/30 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/30 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 2, 31); + FAILED ("EXCEPTION NOT RAISED - 2/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 4, 31); + FAILED ("EXCEPTION NOT RAISED - 4/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 6, 31); + FAILED ("EXCEPTION NOT RAISED - 6/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 9, 31); + FAILED ("EXCEPTION NOT RAISED - 9/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 9/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 11, 31); + FAILED ("EXCEPTION NOT RAISED - 11/31 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 11/31 (A)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1983, 2, 29); + FAILED ("EXCEPTION NOT RAISED - 2/29 (A)"); + EXCEPTION + WHEN TIME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2/29 (A)"); + END; + + END; -- (A) + + -------------------------------------------- + + DECLARE -- (B) + + BAD_TIME : TIME; + + BEGIN -- (B) + + BEGIN + BAD_TIME := TIME_OF (1900, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 1900 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1900 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (2100, 8, 13); + FAILED ("EXCEPTION NOT RAISED - 2100 (B)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2100 (B)"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 0, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 13, 13); + FAILED ("EXCEPTION NOT RAISED - MONTH (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - MONTH (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 0); + FAILED ("EXCEPTION NOT RAISED - DAY (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)1"); + END; + + BEGIN + BAD_TIME := TIME_OF (19784, 8, 32); + FAILED ("EXCEPTION NOT RAISED - DAY (B)2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DAY (B)2"); + END; + + BEGIN + BAD_TIME := TIME_OF (1984, 8, 13, -0.5); + FAILED ("EXCEPTION NOT RAISED - SECONDS (B)1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - SECONDS (B)1"); + END; + + END; -- (B) + + -------------------------------------------- + + RESULT; + END C96007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96008a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- C96008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE + -- CALENDAR. SUBTESTS ARE: + -- (A) TIME_OF() AND SPLIT() ARE INVERSE FUNCTIONS. + -- (B) FORMAL PARAMETERS OF TIME_OF() AND SPLIT() ARE NAMED CORRECTLY. + -- (C) TIME_OF() GIVES THE PARAMETER SECONDS A DEFAULT VALUE OF 0.0. + -- (D) THE FUNCTIONS YEAR(), MONTH(), DAY(), AND SECONDS() RETURN + -- CORRECT VALUES USING NAMED NOTATION. + -- (E) A VALUE RETURNED FROM CLOCK() CAN BE PROCESSED BY SPLIT(). + -- (F) DURATION'SMALL MEETS REQUIRED LIMIT. + + -- CPP 8/16/84 + + WITH SYSTEM; + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96008A IS + + BEGIN + TEST ("C96008A", "CHECK MISCELLANEOUS FUNCTIONS IN THE " & + "PACKAGE CALENDAR"); + + --------------------------------------------- + + DECLARE -- (A) + NOW : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (A) + BEGIN + NOW := TIME_OF (1984, 8, 13, DURATION(1.0/3.0)); + SPLIT (NOW, YR, MO, DY, SEC); + IF NOW /= TIME_OF (YR, MO, DY, SEC) THEN + COMMENT ("TIME_OF AND SPLIT ARE NOT INVERSES " & + "WHEN SECONDS IS A NON-MODEL NUMBER " & + "- (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("TIME_OF(SPLIT) RAISED EXCEPTION - (A)"); + END; + + + BEGIN + -- RESET VALUES. + YR := 1984; + MO := 8; + DY := 13; + SEC := 1.0; + + SPLIT (TIME_OF (YR, MO, DY, SEC), YR, MO, DY, SEC); + + IF YR /= 1984 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF YR - (A)"); + END IF; + + IF MO /= 8 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF MO - (A)"); + END IF; + + IF DY /= 13 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF DY - (A)"); + END IF; + + IF SEC /= 1.0 THEN + FAILED ("SPLIT(TIME_OF) CHANGED VALUE OF " & + "SEC - (A)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT(TIME_OF) PROCESSING RAISED " & + "EXCEPTION - (A)"); + END; + END; -- (A) + + --------------------------------------------- + + BEGIN -- (B) + DECLARE + NOW : TIME; + BEGIN + NOW := TIME_OF (YEAR => 1984, + MONTH => 8, + DAY => 13, + SECONDS => 60.0); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON TIME_OF() RAISED " & + "EXCEPTION - (B)"); + END; + + + DECLARE + NOW : TIME := CLOCK; + YR : YEAR_NUMBER := 1984; + MO : MONTH_NUMBER := 8; + DY : DAY_NUMBER := 13; + SEC : DAY_DURATION := 0.0; + BEGIN + SPLIT (DATE => NOW, + YEAR => YR, + MONTH => MO, + DAY => DY, + SECONDS => SEC); + EXCEPTION + WHEN OTHERS => + FAILED ("NAMED ASSOCIATION ON SPLIT() RAISED " & + "EXCEPTION - (B)2"); + END; + END; -- (B) + + --------------------------------------------- + + DECLARE -- (C) + NOW : TIME; + BEGIN -- (C) + NOW := TIME_OF (1984, 8, 13); + IF SECONDS (NOW) /= 0.0 THEN + FAILED ("TIME_OF() DID NOT ZERO SECONDS - (C)"); + END IF; + END; -- (C) + + --------------------------------------------- + + DECLARE -- (D) + -- ASSUMES TIME_OF() WORKS CORRECTLY. + HOLIDAY : TIME; + BEGIN -- (D) + HOLIDAY := TIME_OF (1958, 9, 9, 1.0); + + IF YEAR (DATE => HOLIDAY) /= 1958 THEN + FAILED ("YEAR() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF MONTH (DATE => HOLIDAY) /= 9 THEN + FAILED ("MONTH() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF DAY (DATE => HOLIDAY) /= 9 THEN + FAILED ("DAY() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + + IF SECONDS (HOLIDAY) /= 1.0 THEN + FAILED ("SECONDS() DID NOT RETURN CORRECT VALUE - (D)"); + END IF; + END; -- (D) + + --------------------------------------------- + + DECLARE -- (E) + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + BEGIN -- (E) + SPLIT (CLOCK, YR, MO, DY, SEC); + DELAY SYSTEM.TICK; + + IF TIME_OF (YR, MO, DY, SEC) > CLOCK THEN + FAILED ("SPLIT() ON CLOCK INCORRECT - (E)"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("SPLIT() ON CLOCK RAISED EXCEPTION - (E)"); + END; -- (E) + + --------------------------------------------- + + BEGIN -- (F) + IF DURATION'SMALL > 0.020 THEN + FAILED ("DURATION'SMALL LARGER THAN SPECIFIED - (F)"); + END IF; + END; -- (F) + + --------------------------------------------- + + RESULT; + END C96008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96008b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96008b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c96008b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c96008b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C96008B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- MISCELLANEOUS CHECKS ON THE PRE-DEFINED FUNCTIONS IN THE PACKAGE + -- CALENDAR. SUBTESTS ARE: + -- (A) THE FUNCTION TIME_OF() MUST ADVANCE DAY WHEN CALLED WITH THE + -- SECONDS ARGUMENT HAVING THE VALUE 86_400. + + -- CPP 8/16/84 + -- JRK 12/4/84 + + WITH CALENDAR; USE CALENDAR; + WITH REPORT; USE REPORT; + PROCEDURE C96008B IS + + NOW1, NOW2 : TIME; + YR : YEAR_NUMBER; + MO : MONTH_NUMBER; + DY : DAY_NUMBER; + SEC : DAY_DURATION; + + BEGIN + + TEST ("C96008B", "CHECK THAT TIME_OF() ADVANCES DAY"); + + NOW1 := TIME_OF (1984, 8, 13, 86_400.0); + NOW2 := TIME_OF (1984, 8, 14, 0.0); + + IF NOW1 /= NOW2 THEN + FAILED ("TIME_OF DID NOT CONVERT 86_400 SECONDS TO A DAY"); + END IF; + + SPLIT (NOW2, YR, MO, DY, SEC); + + IF DY /= 14 THEN + FAILED ("DAY OF NOW2 INCORRECT"); + END IF; + IF SEC /= 0.0 THEN + FAILED ("SECONDS OF NOW2 INCORRECT"); + END IF; + + SPLIT (NOW1, YR, MO, DY, SEC); + + IF DY /= 14 OR SEC /= 0.0 OR + DAY (NOW1) /= 14 OR SECONDS (NOW1) /= 0.0 THEN + FAILED ("TIME_OF DID NOT ADVANCE DAY"); + END IF; + + RESULT; + END C96008B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97112a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97112a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97112a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97112a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- C97112A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DELAY STATEMENT IS ALLOWED IN THE SEQUENCE OF STATEMENTS + -- OF A SELECT ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A TERMINATE + -- ALTERNATIVE OR AN ELSE PART. + + -- WRG 7/9/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97112A IS + + ACCEPT_ALTERNATIVE_TAKEN : BOOLEAN := FALSE; + + BEGIN + + TEST ("C97112A", "CHECK THAT A DELAY STATEMENT IS ALLOWED IN " & + "THE SEQUENCE OF STATEMENTS OF A SELECT " & + "ALTERNATIVE OF A SELECTIVE WAIT CONTAINING A " & + "TERMINATE ALTERNATIVE OR AN ELSE PART"); + + -------------------------------------------------- + + A: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + SELECT + ACCEPT E; + ACCEPT_ALTERNATIVE_TAKEN := TRUE; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (A)"); + END IF; + OR + TERMINATE; + END SELECT; + END T; + + BEGIN + + T.E; + + END A; + + IF NOT ACCEPT_ALTERNATIVE_TAKEN THEN + FAILED ("ACCEPT ALTERNATIVE NOT TAKEN"); + END IF; + + -------------------------------------------------- + + B: DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E; + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-1)"); + END IF; + ELSE + FAILED ("ELSE PART EXECUTED (B-1)"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPT STATEMENT EXECUTED (B-2)"); + ELSE + BEFORE := CLOCK; + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY (B-2)"); + END IF; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.E; + + END B; + + -------------------------------------------------- + + RESULT; + + END C97112A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97113a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97113a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97113a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97113a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- C97113A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL CONDITIONS, OPEN DELAY ALTERNATIVE EXPRESSIONS, AND + -- OPEN ENTRY FAMILY INDICES ARE EVALUATED (EVEN WHEN SOME (PERHAPS + -- ALL BUT ONE) OF THE ALTERNATIVES CAN BE RULED OUT WITHOUT + -- COMPLETING THE EVALUATIONS). + + -- RM 5/06/82 + -- SPS 11/21/82 + -- WRG 7/9/86 ADDED DELAY EXPRESSIONS AND ENTRY FAMILY INDICES. + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97113A IS + + EXPR1_EVALUATED : BOOLEAN := FALSE; + EXPR2_EVALUATED : BOOLEAN := FALSE; + EXPR3_EVALUATED : BOOLEAN := FALSE; + + FUNCTION F1 RETURN BOOLEAN IS + BEGIN + EXPR1_EVALUATED := TRUE; + RETURN TRUE; + END F1; + + FUNCTION F2 (X : INTEGER) RETURN INTEGER IS + BEGIN + EXPR2_EVALUATED := TRUE; + RETURN X; + END F2; + + FUNCTION F3 (X : DURATION) RETURN DURATION IS + BEGIN + EXPR3_EVALUATED := TRUE; + RETURN X; + END F3; + + BEGIN + + TEST ("C97113A", "CHECK THAT ALL CONDITIONS, OPEN DELAY " & + "ALTERNATIVE EXPRESSIONS, AND OPEN ENTRY " & + "FAMILY INDICES ARE EVALUATED"); + + DECLARE + + TASK T IS + ENTRY E1; + ENTRY E2; + ENTRY E3 (1..1); + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E1 HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E1'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT E1; + OR + WHEN F1 => + ACCEPT E2; + OR + ACCEPT E3 ( F2(1) ); + OR + DELAY F3 ( 1.0 ) * Impdef.One_Second; + END SELECT; + END T; + + BEGIN + + T.E1; + + END; + + IF NOT EXPR1_EVALUATED THEN + FAILED ("GUARD NOT EVALUATED"); + END IF; + + IF NOT EXPR2_EVALUATED THEN + FAILED ("ENTRY FAMILY INDEX NOT EVALUATED"); + END IF; + + IF NOT EXPR3_EVALUATED THEN + FAILED ("OPEN DELAY ALTERNATIVE EXPRESSION NOT EVALUATED"); + END IF; + + RESULT; + + END C97113A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97114a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97114a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97114a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97114a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- C97114A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK WHETHER A DELAY EXPRESSION FOLLOWING AN OPEN GUARD IS EVALUATED + -- DIRECTLY AFTER THE GUARD OR ONLY AFTER ALL GUARDS HAVE BEEN + -- EVALUATED, OR IN SOME MIXED ORDER SUCH THAT DELAY EXPRESSIONS ARE + -- EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE OPEN. + + -- RM 5/10/82 + -- SPS 11/21/82 + -- JBG 10/24/83 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97114A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + DUMMY : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION D1( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'D'; -- 123: DDD ( 'D' FOR 'DELAY' ) + RETURN ( 1.0 ); + END D1; + + + FUNCTION D2( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 2.0 ); + END D2; + + + FUNCTION D3( X:INTEGER ) RETURN DURATION IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'D'; + RETURN ( 3.0 ); + END D3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + + BEGIN + + + TEST ("C97114A", "CHECK THAT THE DELAY EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + DELAY D1( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F2(7) = 13 => + DELAY D2( DUMMY ) * Impdef.One_Second; + + OR + + WHEN 6 + F3(7) = 13 => + DELAY D3( DUMMY ) * Impdef.One_Second; + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("EVALUATIONS WERE DONE IN THE ORDER " & EVAL_ORD); + COMMENT ("FUNCTIONS WERE CALLED IN THE ORDER " & EVAL_ORDER); + + IF EVAL_ORD = "GGGDDD" THEN + COMMENT ("ALL GUARDS EVALUATED FIRST"); + ELSIF EVAL_ORD = "GDGDGD" THEN + COMMENT ("DELAY EXPRESSION EVALUATED AFTER EACH GUARD"); + END IF; + + -- CHECK THAT GUARDS ARE ALWAYS EVALUATED BEFORE DELAY EXPRESSIONS + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("A DELAY EXPRESSION WAS EVALUATED BEFORE ITS " & + "GUARD"); + END IF; + + + RESULT; + + + END C97114A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97115a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97115a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97115a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97115a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- C97115A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK WHETHER AN ENTRY FAMILY INDEX EXPRESSION FOLLOWING AN OPEN + -- GUARD IS EVALUATED DIRECTLY AFTER THE GUARD, OR ONLY AFTER ALL GUARDS + -- HAVE BEEN EVALUATED, OR IN SOME MIXED ORDER SUCH THAT INDEX + -- EXPRESSIONS ARE EVALUATED AFTER THEIR GUARDS ARE DETERMINED TO BE + -- OPEN. + + -- RM 5/11/82 + -- SPS 11/21/82 + -- JBG 10/24/83 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97115A IS + + + -- THE TASK WILL HAVE LAST PRIORITY ( PRIORITY'FIRST ) + + EVAL_ORDER : STRING (1..6) := ( 1..6 => '*' ); + EVAL_ORD : STRING (1..6) := ( 1..6 => '*' ); + INDEX : INTEGER := 0; + + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'F'; -- 123: FGH + EVAL_ORD (INDEX) := 'G'; -- 123: GGG ( 'G' FOR 'GUARD' ) + RETURN ( IDENT_INT(7) ); + END F1; + + + FUNCTION F2 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'G'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F2; + + + FUNCTION F3 (X:INTEGER) RETURN INTEGER IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'H'; + EVAL_ORD (INDEX) := 'G'; + RETURN ( IDENT_INT(7) ); + END F3; + + + FUNCTION I1 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'A'; -- 123: ABC + EVAL_ORD (INDEX) := 'I'; -- 123: III ( 'I' FOR 'INDEX' ) + RETURN ( IDENT_BOOL(TRUE) ); -- (THAT'S ENTRY-FAMILY INDEX) + END I1; + + + FUNCTION I2 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'B'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I2; + + + FUNCTION I3 ( X:INTEGER ) RETURN BOOLEAN IS + BEGIN + INDEX := INDEX + 1; + EVAL_ORDER (INDEX) := 'C'; + EVAL_ORD (INDEX) := 'I'; + RETURN ( IDENT_BOOL(TRUE) ); + END I3; + + FUNCTION POS_OF (FUNC : CHARACTER) RETURN INTEGER IS + BEGIN + FOR I IN EVAL_ORDER'RANGE LOOP + IF EVAL_ORDER(I) = FUNC THEN + RETURN I; + END IF; + END LOOP; + FAILED ("DID NOT FIND LETTER " & FUNC); + RETURN 0; + END POS_OF; + + + BEGIN + + + TEST ("C97115A", "CHECK THAT THE INDEX EXPRESSIONS ARE" & + " EVALUATED AFTER THE GUARDS BUT" & + " BEFORE THE RENDEZVOUS IS ATTEMPTED" ); + + + DECLARE + + + TASK T IS + + + ENTRY E ( BOOLEAN ); + ENTRY E1; + + END T; + + + TASK BODY T IS + BEGIN + + + WHILE E1'COUNT = 0 -- IF E1 NOT YET CALLED, THEN GIVE + LOOP -- THE MAIN TASK AN OPPORTUNITY + DELAY 10.01 * Impdef.One_Second; -- TO ISSUE THE CALL. + END LOOP; + + + SELECT + + ACCEPT E1; + + OR + + WHEN 6 + F1(7) = 13 => + ACCEPT E ( I1(17) ); + + OR + + WHEN 6 + F2(7) = 13 => + ACCEPT E ( I2(17) ); + + OR + + WHEN 6 + F3(7) = 13 => + ACCEPT E ( I3(17) ); + + END SELECT; + + + END T; + + + BEGIN + + T.E1; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS + + + COMMENT ("GUARD AND INDEX FUNCTIONS WERE CALLED IN ORDER " & + EVAL_ORDER); + COMMENT ("GUARD AND INDEX EXPRESSIONS WERE EVALUATED IN THE " & + "ORDER " & EVAL_ORD); + + IF POS_OF ('F') > POS_OF ('A') OR + POS_OF ('G') > POS_OF ('B') OR + POS_OF ('H') > POS_OF ('C') THEN + FAILED ("AN INDEX EXPRESSION WAS EVALUATED TOO EARLY"); + END IF; + + RESULT; + + END C97115A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97116a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97116a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97116a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97116a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C97116A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE GUARD CONDITIONS IN A SELECTIVE WAIT STATEMENT + -- ARE NOT RE-EVALUATED DURING THE WAIT. + + -- HISTORY: + -- WRG 7/10/86 CREATED ORIGINAL TEST. + -- RJW 5/15/90 REMOVED SHARED VARIABLES. + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97116A IS + + GUARD_EVALUATIONS : NATURAL := 0; + + FUNCTION GUARD RETURN BOOLEAN IS + BEGIN + GUARD_EVALUATIONS := GUARD_EVALUATIONS + 1; + RETURN FALSE; + END GUARD; + + FUNCTION SO_LONG RETURN DURATION IS + BEGIN + RETURN 20.0; + END SO_LONG; + + BEGIN + + TEST ("C97116A", "CHECK THAT THE GUARD CONDITIONS IN A " & + "SELECTIVE WAIT STATEMENT ARE NOT RE-EVALUATED " & + "DURING THE WAIT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT CALL TO E"); + OR WHEN GUARD => + DELAY 0.0; + FAILED ("EXECUTED ALTERNATIVE CLOSED BY FALSE " & + "GUARD FUNCTION" ); + OR + DELAY SO_LONG * Impdef.One_Second; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + TASK GET_CPU; + + TASK BODY GET_CPU IS + BEGIN + WHILE NOT T'TERMINATED LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + END GET_CPU; + + BEGIN + + NULL; + + END; + + IF GUARD_EVALUATIONS /= 1 THEN + FAILED ("GUARD EVALUATED" & + NATURAL'IMAGE(GUARD_EVALUATIONS) & " TIMES"); + END IF; + + RESULT; + + END C97116A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- C97117A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PROGRAM_ERROR IS RAISED IF ALL ALTERNATIVES ARE CLOSED AND + -- NO ELSE PART IS PRESENT. + + -- WRG 7/10/86 + + WITH REPORT; USE REPORT; + PROCEDURE C97117A IS + + BEGIN + + TEST ("C97117A", "CHECK THAT PROGRAM_ERROR IS RAISED IF ALL " & + "ALTERNATIVES ARE CLOSED AND NO ELSE PART IS " & + "PRESENT"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (FALSE) => + DELAY 0.0; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + END SELECT; + FAILED ("PROGRAM_ERROR NOT RAISED"); + EXCEPTION + WHEN PROGRAM_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END T; + + BEGIN + + NULL; + + END; + + RESULT; + + END C97117A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C97117B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ELSE PART IS EXECUTED IF ALL ALTERNATIVES ARE CLOSED OR + -- IF THERE ARE NO TASKS QUEUED FOR OPEN ALTERNATIVES. + + -- WRG 7/10/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97117B IS + + BEGIN + + TEST ("C97117B", "CHECK THAT AN ELSE PART IS EXECUTED IF ALL " & + "ALTERNATIVES ARE CLOSED OR IF THERE ARE NO " & + "TASKS QUEUED FOR OPEN ALTERNATIVES"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT NO_GO HAS BEEN CALLED BEFORE PROCEEDING: + WHILE NO_GO'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ACCEPT ALTERNATIVE TAKEN " & + "FOR NONEXISTENT ENTRY CALL - 1"); + OR + WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 1"); + ELSE + COMMENT ("ELSE PART EXECUTED - 1"); + END SELECT; + + SELECT + ACCEPT E; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL - 2"); + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT NO_GO; + FAILED ("CLOSED ALTERNATIVE TAKEN - 2"); + ELSE + COMMENT ("ELSE PART EXECUTED - 2"); + END SELECT; + + ACCEPT NO_GO; + END T; + + BEGIN + + T.NO_GO; + + END; + + RESULT; + + END C97117B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97117c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97117c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- C97117C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN ELSE PART IS NOT EXECUTED IF A TASK IS QUEUED AT AN + -- OPEN ALTERNATIVE. + + -- WRG 7/10/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97117C IS + + BEGIN + + TEST ("C97117C", "CHECK THAT AN ELSE PART IS NOT EXECUTED IF A " & + "TASK IS QUEUED AT AN OPEN ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY NO_GO; + END T; + + TASK BODY T IS + BEGIN + --ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + + END C97117C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97118a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97118a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97118a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97118a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- C97118A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF A SELECTIVE WAIT IS NOT + -- ACCEPTED. + + -- WRG 7/11/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97118A IS + + BEGIN + + TEST ("C97118A", "CHECK THAT A CALL TO A CLOSED ALTERNATIVE OF " & + "A SELECTIVE WAIT IS NOT ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("ACCEPTED CALL TO CLOSED ALTERNATIVE"); + ELSE + NULL; + END SELECT; + + IF E'COUNT = 1 THEN + ACCEPT E; + END IF; + END T; + + BEGIN + + T.E; + + END; + + RESULT; + + END C97118A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97120a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97120a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97120a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97120a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- C97120A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST AS LONG AS IS SPECIFIED + -- IN A DELAY ALTERNATIVE. + + -- WRG 7/11/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97120A IS + + BEGIN + + TEST ("C97120A", "CHECK THAT A SELECTIVE WAIT DELAYS AT LEAST " & + "AS LONG AS IS SPECIFIED IN A DELAY ALTERNATIVE"); + + DECLARE + + TASK T IS + ENTRY NO_GO; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEFORE, AFTER : TIME; + BEGIN + -- ENSURE THAT SYNCH HAS BEEN CALLED BEFORE PROCEEDING: + WHILE SYNCH'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + BEFORE := CLOCK; + SELECT + ACCEPT NO_GO; + FAILED ("ACCEPTED NONEXISTENT ENTRY CALL"); + OR + DELAY 10.0 * Impdef.One_Second; + AFTER := CLOCK; + IF AFTER - BEFORE < 10.0 * Impdef.One_Second THEN + FAILED ("INSUFFICIENT DELAY"); + END IF; + END SELECT; + + ACCEPT SYNCH; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + BEGIN + + T.SYNCH; -- SUSPEND MAIN TASK BEFORE READING CLOCK. + + END; + + RESULT; + + END C97120A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97120b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97120b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97120b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97120b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- C97120B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A SPECIFIED DELAY IS ZERO OR NEGATIVE AND AN ENTRY CALL + -- IS WAITING AT AN OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS + -- EXECUTED, THE CALL IS ACCEPTED. + + -- WRG 7/11/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97120B IS + + ZERO, NEG : DURATION := 1.0; + + BEGIN + + TEST ("C97120B", "CHECK THAT IF A SPECIFIED DELAY IS ZERO OR " & + "NEGATIVE AND AN ENTRY CALL IS WAITING AT AN " & + "OPEN ALTERNATIVE WHEN THE SELECTIVE WAIT IS " & + "EXECUTED, THE CALL IS ACCEPTED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + NEG := -1.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E; + END T; + + TASK BODY T IS + BEGIN + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + A: BEGIN + SELECT + WHEN IDENT_BOOL (TRUE) => + ACCEPT E; + OR + DELAY ZERO * Impdef.One_Second; + FAILED ("ZERO DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (A)"); + END A; + + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + B: BEGIN + SELECT + ACCEPT E; + OR + DELAY NEG; + FAILED ("NEGATIVE DELAY ALTERNATIVE TAKEN"); + ACCEPT E; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED (B)"); + END B; + + END T; + + BEGIN + + T.E; + T.E; + + END; + + RESULT; + + END C97120B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- C97201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL + -- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + + -- CASE A: THE TASK TO BE CALLED IS NOT YET ACTIVE AS OF THE + -- MOMENT OF CALL (CONDITIONAL_ENTRY_CALL), + -- AND THIS FACT CAN BE DETERMINED STATICALLY. + + + -- RM 4/20/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201A IS + + ELSE_BRANCH_TAKEN : INTEGER := 3 ; + + BEGIN + + + TEST ("C97201A", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN OCCUR WHILE" & + " THE CALLED TASK IS NOT YET ACTIVE" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) ; + END T ; + + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT ; + PACKAGE BODY SECOND_ATTEMPT IS + BEGIN + + SELECT + DO_IT_NOW_ORELSE (FALSE) ;--CALLING (OWN) ENTRY + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 2 * ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#2)" ); + END SELECT; + + END SECOND_ATTEMPT ; + + BEGIN + + ACCEPT DO_IT_NOW_ORELSE ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_ORELSE ; + + + END T ; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT ; + PACKAGE BODY FIRST_ATTEMPT IS + BEGIN + SELECT + T.DO_IT_NOW_ORELSE (FALSE) ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := 1 + ELSE_BRANCH_TAKEN ; + COMMENT( "ELSE_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT ; + + + BEGIN + + T.DO_IT_NOW_ORELSE ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED) + + + CASE ELSE_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'ELSE'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'ELSE' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'ELSE' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'ELSE': #2,#1 " ); + + WHEN 8 => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + + RESULT; + + + END C97201A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C97201B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF THERE IS + -- ANOTHER TASK QUEUED FOR THE ENTRY. + + -- WRG 7/11/86 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97201B IS + + + BEGIN + + TEST ("C97201B", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF THERE IS ANOTHER TASK QUEUED " & + "FOR THE ENTRY"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + ENTRY DONE; + END T; + + TASK BODY T IS + BEGIN + -- ENSURE THAT E HAS BEEN CALLED BEFORE PROCEEDING: + WHILE E'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + + ACCEPT SYNCH; + + SELECT + WHEN IDENT_BOOL (FALSE) => + ACCEPT E; + FAILED ("CLOSED ALTERNATIVE TAKEN"); + OR + ACCEPT DONE DO + IF E'COUNT /= 1 THEN + FAILED (NATURAL'IMAGE(E'COUNT) & + " CALLS WERE QUEUED FOR ENTRY " & + "E OF TASK T"); + END IF; + END DONE; + OR + DELAY 1000.0 * Impdef.One_Second; + FAILED ("DELAY EXPIRED; E'COUNT =" & + NATURAL'IMAGE(E'COUNT) ); + END SELECT; + + WHILE E'COUNT > 0 LOOP + ACCEPT E; + END LOOP; + END T; + + TASK AGENT; + + TASK BODY AGENT IS + BEGIN + T.E; + END AGENT; + + BEGIN + + T.SYNCH; + + DELAY 10.0 * Impdef.One_Second; + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED" ); + ELSE + COMMENT ("ELSE PART EXECUTED"); + T.DONE; + END SELECT; + + END; + + RESULT; + + END C97201B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- C97201C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONDITIONAL ENTRY CALL IS NOT ACCEPTED IF AN ACCEPT + -- STATEMENT FOR THE CALLED ENTRY HAS NOT YET BEEN REACHED. + + -- WRG 7/11/86 + + WITH REPORT; USE REPORT; + PROCEDURE C97201C IS + + BEGIN + + TEST ("C97201C", "CHECK THAT A CONDITIONAL ENTRY CALL IS NOT " & + "ACCEPTED IF AN ACCEPT STATEMENT FOR THE " & + "CALLED ENTRY HAS NOT YET BEEN REACHED"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY BARRIER; + END T; + + TASK BODY T IS + BEGIN + ACCEPT BARRIER; + IF E'COUNT > 0 THEN + FAILED ("ENTRY CALL WAS QUEUED"); + ACCEPT E; + END IF; + END T; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED"); + ELSE + COMMENT ("ELSE PART EXECUTED"); + END SELECT; + + T.BARRIER; + + END; + + RESULT; + + END C97201C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C97201D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL + -- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + + -- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY + -- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - + -- AND THIS FACT IS DETERMINED STATICALLY. + + + -- RM 4/12/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201D IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + + BEGIN + + + TEST ("C97201D", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ; + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE ; + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + + END C97201D ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- C97201E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL + -- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + + -- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY + -- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - + -- AND THIS FACT CAN NOT BE DETERMINED STATICALLY. + -- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS + -- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + + + -- RM 4/13/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201E IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + + BEGIN + + + TEST ("C97201E", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IN THE ABSENCE OF A CORRESPONDING " & + " ACCEPT_STATEMENT " ); + + + DECLARE + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE ( SHORT ) ; + END T ; + + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED + ACCEPT DO_IT_NOW_ORELSE ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + END ; + + + BEGIN + + SELECT + T.DO_IT_NOW_ORELSE (10) ; -- ACCEPT_STATEMENT HAS 15 + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_ORELSE(KEEP_ALIVE) ;-- THIS ALSO UPDATES NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + -- BY NOW, THE TASK IS TERMINATED + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + + END C97201E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C97201G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL + -- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + + -- CASE G: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED + -- AND THIS FACT IS STATICALLY DETERMINABLE. + + + -- RM 4/21/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201G IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + + BEGIN + + + TEST ("C97201G", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = 5 => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + + END C97201G ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201h.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C97201H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RENDEZVOUS REQUESTED BY A CONDITIONAL_ENTRY_CALL + -- IS PERFORMED ONLY IF IMMEDIATELY POSSIBLE. + + -- CASE H: THE CORRESPONDING ACCEPT_STATEMENT IS CLOSED + -- AND THIS FACT IS NOT STATICALLY DETERMINABLE. + + + -- RM 4/22/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201H IS + + ELSE_BRANCH_TAKEN : BOOLEAN := FALSE ; + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + X : INTEGER := 17 ; + + BEGIN + + + TEST ("C97201H", "CHECK THAT NO RENDEZVOUS REQUESTED BY" & + " A CONDITIONAL_ENTRY_CALL CAN EVER OCCUR" & + " IF THE CORRESPONDING ACCEPT_STATEMENT IS" & + " CLOSED" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK T IS + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + WHEN 3 = IDENT_INT(5) => + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN) + DO + DID_YOU_DO_IT := TRUE ; + END; + OR + ACCEPT KEEP_ALIVE ; -- TO PREVENT SELECT_ERROR + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + END T ; + + + BEGIN + + COMMENT( "PERMANENTLY CLOSED" ); + + SELECT + T.DO_IT_NOW_ORELSE( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER ADOPTS A NO-WAIT POLICY) + -- THEREFORE THIS BRANCH MUST BE CHOSEN + ELSE_BRANCH_TAKEN := TRUE ; + COMMENT( "ELSE_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL + + + ------------------------------------------------------------------- + + + -- BY NOW, THE TASK IS TERMINATED + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + IF ELSE_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + + END C97201H ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97201x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97201x.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- C97201X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF BOTH PARTNERS REFUSE TO + -- WAIT (THAT IS, IF THE ENTRY CALL IS ISSUED BY A + -- "CONDITIONAL_ENTRY_CALL" AND THUS FOLLOWS A NO-WAIT POLICY + -- (DEMANDING UNCONDITIONALLY THAT "YOU DO IT N O W , OR ELSE"), + -- WHILE THE CALLEE IS ALSO COMMITTED TO A NO-WAIT POLICY, + -- BY VIRTUE OF A SELECTIVE_WAIT STATEMENT OF THE THIRD KIND + -- (WITH AN "ELSE" PART) IN WHICH THE CORRESPONDING ACCEPT_STATEMENT + -- IS EMBEDDED). + -- ("CLOSE ENCOUNTERS OF THE THIRD KIND" -- ARE THEY POSSIBLE?) + + + -- THE SEMANTICS OF THIS ENTRY CALL REQUIRES THAT THE CALLING TASK + -- N O T ENTER ITSELF ON ANY QUEUE BUT RATHER ATTEMPT AN IMMEDIATE + -- RENDEZVOUS WHICH IS TO TAKE PLACE IF AND ONLY IF THE CALLED TASK + -- HAS REACHED A POINT WHERE IT IS READY TO ACCEPT THE CALL (I.E. + -- IT IS EITHER WAITING AT AN ACCEPT STATEMENT FOR THE CORRESPONDING + -- ENTRY OR IT IS WAITING AT A SELECTIVE_WAIT STATEMENT WITH AN OPEN + -- ALTERNATIVE STARTING WITH SUCH AN ACCEPT STATEMENT). IT ALSO + -- REQUIRES THAT THE ENTRY CALL BE CANCELLED IF THE CALLED TASK + -- IS NOT AT SUCH A POINT. ON THE OTHER HAND, THE SEMANTICS OF THE + -- SELECTIVE_WAIT STATEMENT WITH AN 'ELSE' PART SPECIFIES THAT + -- THE 'ELSE' PART MUST BE SELECTED IF NO 'ACCEPT' ALTERNATIVE + -- CAN BE IMMEDIATELY SELECTED, AND THAT SUCH AN ALTERNATIVE + -- IS DEEMED TO BE IMMEDIATELY SELECTABLE ("SELECTION OF ONE SUCH + -- ALTERNATIVE OCCURS IMMEDIATELY"), AND A CORRESPONDING RENDEZVOUS + -- POSSIBLE, IF AND ONLY IF THERE IS A CORRESPONDING ENTRY CALL + -- W A I T I N G TO BE ACCCEPTED. A "CONDITIONAL ENTRY CALL" + -- NEVER WAITS, AND IS NEVER ENTERED IN WAIT QUEUES; IT TAKES + -- THE 'ELSE' PART INSTEAD. + + + -- NOTE: IF THIS TEST PROGRAM HANGS UP, THE COMPILER WILL BE DEEMED + -- TO HAVE FAILED. + + + -- RM 3/19/82 + + + WITH REPORT; USE REPORT; + PROCEDURE C97201X IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE ; + + CALLER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + SERVER_TAKES_WRONG_BRANCH : BOOLEAN := TRUE ; + QUEUE_NOT_EMPTY : BOOLEAN := FALSE ; + + BEGIN + + + TEST ("C97201X", "CHECK THAT NO RENDEZVOUS CAN EVER OCCUR IF" & + " BOTH PARTNERS REFUSE TO WAIT" ); + + + DECLARE + + + TASK T IS + ENTRY SYNCHRONIZE ; + ENTRY DO_IT_NOW_ORELSE( DID_YOU_DO_IT : IN OUT BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + + TASK BODY T IS + BEGIN + + + ACCEPT SYNCHRONIZE ; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + SELECT + ACCEPT DO_IT_NOW_ORELSE + ( DID_YOU_DO_IT : IN OUT BOOLEAN ) + DO + DID_YOU_DO_IT := TRUE ; + END ; + ELSE -- (I.E. TASK ADOPTS NO-WAIT POLICY) + -- 'ELSE' BRANCH MUST THEREFORE BE CHOSEN + SERVER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + IF DO_IT_NOW_ORELSE'COUNT /= 0 THEN + QUEUE_NOT_EMPTY := TRUE ; + END IF; + + + ACCEPT KEEP_ALIVE ; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF IT GETS TO + -- THE NO-WAIT MEETING-PLACE + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME OF + -- THE NO-WAIT CALL). + + + END T ; + + + BEGIN + + + T.SYNCHRONIZE ; -- TO MINIMIZE THE N E E D TO WAIT + + + SELECT + T.DO_IT_NOW_ORELSE ( RENDEZVOUS_OCCURRED ); + ELSE -- (I.E. CALLER TOO ADOPTS A NO-WAIT POLICY) + -- MUST THEREFORE CHOOSE THIS BRANCH + CALLER_TAKES_WRONG_BRANCH := FALSE ; + END SELECT; + + + T.KEEP_ALIVE ; -- THIS ALSO UPDATES THE NONLOCALS + + + END; -- END OF BLOCK CONTAINING THE NO-WAIT ENTRY CALL + + + IF RENDEZVOUS_OCCURRED + THEN + FAILED( "RENDEZVOUS OCCURRED" ); + END IF; + + IF CALLER_TAKES_WRONG_BRANCH OR + SERVER_TAKES_WRONG_BRANCH + THEN + FAILED( "WRONG BRANCH TAKEN" ); + END IF; + + IF QUEUE_NOT_EMPTY + THEN + FAILED( "ENTRY QUEUE NOT EMPTY" ); + END IF; + + + RESULT; + + + END C97201X ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97202a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C97202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE INDEX IS EVALUATED BEFORE THE ENTRY PARAMETER AND BOTH + -- THE INDEX AND THE ENTRY PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS + -- IS ATTEMPED. + + -- RM 4/05/82 + -- TBN 2/3/86 ADDED A CHECK THAT INDEX IS EVALUATED BEFORE THE ENTRY + -- PARAMETER AND FIXED APPROPRIATE COMMENTS. + + WITH REPORT; USE REPORT; + PROCEDURE C97202A IS + + INDEX_COMPUTED : BOOLEAN := FALSE ; + FORMAL_COMPUTED : BOOLEAN := FALSE ; + + BEGIN + + TEST ("C97202A", "CHECK THAT THE INDEX IS EVALUATED BEFORE THE " & + "ENTRY PARAMETER AND BOTH INDEX AND THE ENTRY " & + "PARAMETER ARE EVALUATED BEFORE THE RENDEZVOUS " & + "IS ATTEMPTED"); + + DECLARE + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + TASK T IS + ENTRY DO_IT_NOW_ORELSE (SHORT) + (DID_YOU_DO_IT : IN BOOLEAN); + ENTRY KEEP_ALIVE ; + END T ; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE ; + END T ; + + FUNCTION F1 (X:INTEGER) RETURN INTEGER IS + BEGIN + IF FORMAL_COMPUTED THEN + FAILED ("INDEX WAS NOT EVALUATED FIRST"); + END IF; + INDEX_COMPUTED := TRUE ; + RETURN (7) ; + END F1 ; + + FUNCTION F2 (X:INTEGER) RETURN BOOLEAN IS + BEGIN + FORMAL_COMPUTED := TRUE ; + RETURN (FALSE) ; + END F2 ; + + BEGIN + SELECT + T.DO_IT_NOW_ORELSE ( 6 + F1(7) ) + ( NOT(F2(7)) ) ; + ELSE + NULL ; + END SELECT; + + T.KEEP_ALIVE ; + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF INDEX_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY INDEX WAS NOT COMPUTED" ); + END IF; + + IF FORMAL_COMPUTED THEN + NULL ; + ELSE + FAILED( "ENTRY PARAMETER WAS NOT COMPUTED" ); + END IF; + + RESULT; + + END C97202A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- C97203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A + -- SELECTIVE_WAIT CANNOT. + + -- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + + -- RM 4/01/1982 + + + WITH REPORT; + USE REPORT; + PROCEDURE C97203A IS + + + BEGIN + + + TEST ( "C97203A" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + + END C97203A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- C97203B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONDITIONAL_ENTRY_CALL CAN APPEAR IN PLACES WHERE A + -- SELECTIVE_WAIT CANNOT. + + -- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + + -- RM 4/09/1982 + + + WITH REPORT; + USE REPORT; + PROCEDURE C97203B IS + + + BEGIN + + + TEST ( "C97203B" , "CHECK THAT A CONDITIONAL_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + ELSE + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF COND_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + ELSE + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF COND_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + + END C97203B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97203c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97203c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- C97203C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A CONDITIONAL ENTRY CALL CAN APPEAR IN PLACES WHERE A + -- SELECTIVE WAIT IS NOT ALLOWED. + + -- PART 3: TASK BODY NESTED WITHIN A TASK. + + -- WRG 7/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE C97203C IS + + BEGIN + + TEST ("C97203C", "CHECK THAT A CONDITIONAL ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (1)"); + ELSE + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - " & + "INNER (2)"); + ELSE + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("CONDITIONAL ENTRY CALL ACCEPTED - OUTER"); + ELSE + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + + END C97203C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97204a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- C97204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED + -- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE + -- CONDITIONAL_ENTRY_CALL. + + + -- RM 5/28/82 + -- SPS 11/21/82 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97204A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + + BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97204A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " CONDITIONAL_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + ELSE + FAILED( "'ELSE' BRANCH TAKEN INSTEAD OF TSKG_ERR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + + END C97204A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97204b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97204b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97204b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97204b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- C97204B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED + -- BEFORE THE CONDITIONAL ENTRY CALL IS EXECUTED. + + -- WRG 7/13/86 + + WITH REPORT; USE REPORT; + PROCEDURE C97204B IS + + BEGIN + + TEST ("C97204B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE CONDITIONAL " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("CONDITIONAL ENTRY CALL MADE"); + ELSE + FAILED ("ELSE PART EXECUTED"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + + END C97204B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97205a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97205a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97205a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97205a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- C97205A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A + -- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + + -- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT + -- STATEMENT. + + -- WRG 7/13/86 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97205A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + + BEGIN + + TEST ("C97205A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + + END C97205A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97205b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97205b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97205b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97205b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- C97205B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A + -- CONDITIONAL ENTRY CALL), IT IS PERFORMED. + + -- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + + -- WRG 7/13/86 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97205B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + + + BEGIN + + TEST ("C97205B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A CONDITIONAL ENTRY CALL), IT " & + "IS PERFORMED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + ELSE + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + + END C97205B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- C97301A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED + -- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + + -- CASE A: THE TASK TO BE CALLED HAS NOT YET BEEN ACTIVATED AS OF THE + -- MOMENT OF CALL. + + -- RJW 3/31/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97301A IS + + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + OR_BRANCH_TAKEN : INTEGER := 3; + + BEGIN + + TEST ("C97301A", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "CALLED TASK IS NOT ACTIVE" ); + + ------------------------------------------------------------------ + + DECLARE + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ); + END T; + + TASK BODY T IS + + PACKAGE SECOND_ATTEMPT IS END SECOND_ATTEMPT; + PACKAGE BODY SECOND_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + DO_IT_NOW_OR_WAIT (FALSE); --CALLING OWN ENTRY. + OR + -- THEREFORE THIS BRANCH + -- MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#2)" ); + END IF; + OR_BRANCH_TAKEN := 2 * OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#2)" ); + END SELECT; + END SECOND_ATTEMPT; + + BEGIN + + ACCEPT DO_IT_NOW_OR_WAIT ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END DO_IT_NOW_OR_WAIT; + + + END T; + + + PACKAGE FIRST_ATTEMPT IS END FIRST_ATTEMPT; + PACKAGE BODY FIRST_ATTEMPT IS + START_TIME : TIME; + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (FALSE); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY (#1)" ); + END IF; + OR_BRANCH_TAKEN := 1 + OR_BRANCH_TAKEN; + COMMENT( "OR_BRANCH TAKEN (#1)" ); + END SELECT; + + END FIRST_ATTEMPT; + + BEGIN + + T.DO_IT_NOW_OR_WAIT ( TRUE ); -- TO SATISFY THE SERVER'S + -- WAIT FOR SUCH A CALL. + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------ + + + -- BY NOW, THE TASK IS TERMINATED (AND THE NONLOCALS UPDATED). + + + CASE OR_BRANCH_TAKEN IS + + WHEN 3 => + FAILED( "NO 'OR'; BOTH (?) RENDEZVOUS ATTEMPTED?" ); + + WHEN 4 => + FAILED( "'OR' #1 ONLY; RENDEZVOUS (#2) ATTEMPTED?" ); + + WHEN 6 => + FAILED( "'OR' #2 ONLY; RENDEZVOUS (#1) ATTEMPTED?" ); + + WHEN 7 => + FAILED( "WRONG ORDER FOR 'OR': #2,#1" ); + + WHEN 8 => + NULL; + + WHEN OTHERS => + FAILED( "WRONG CASE_VALUE" ); + + END CASE; + + RESULT; + + END C97301A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- C97301B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED + -- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + + -- CASE B: THE QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS + -- ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE COMPLETED WITHIN + -- THE SPECIFIED DELAY. + + --HISTORY: + -- RJW 03/31/86 CREATED ORIGINAL TEST. + -- DHH 10/20/87 SHORTENED LINES CONTAINING MORE THAN 72 CHARACTERS. + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97301B IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + + BEGIN + + TEST ("C97301B", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "QUEUE FOR THE CALLED ENTRY ALREADY CONTAINS " & + "ANOTHER TASK WHOSE RENDEZVOUS CANNOT BE " & + "COMPLETED WITHIN THE SPECIFIED DELAY" ); + + + DECLARE + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T1; + + TASK T2 IS + ENTRY AWAKEN_T2; + END T2; + + TASK T3 IS + ENTRY AWAKEN_T3; + ENTRY RELEASE_T; + END T3; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT (X : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X = 1 THEN + T2.AWAKEN_T2; + WHILE DO_IT_NOW_OR_WAIT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + T3.AWAKEN_T3; + T3.RELEASE_T; + ELSE + FAILED ("WRONG TASK IN RENDEZVOUS - 1"); + END IF; + END DO_IT_NOW_OR_WAIT; + ACCEPT DO_IT_NOW_OR_WAIT (X : INTEGER) DO + IF X /= 2 THEN + FAILED ("WRONG TASK IN RENDEZVOUS - 2"); + END IF; + END DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T1 IS + BEGIN + T.DO_IT_NOW_OR_WAIT (1); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT AWAKEN_T2; + T.DO_IT_NOW_OR_WAIT (2); + END T2; + + TASK BODY T3 IS + START_TIME : TIME; + STOP_TIME : TIME; + BEGIN + BEGIN + ACCEPT AWAKEN_T3; + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (3); + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + ACCEPT RELEASE_T; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, THE TASK T IS EFFECTIVELY + -- TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + END T3; + BEGIN + NULL; + END; + + RESULT; + + END C97301B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- C97301C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED + -- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + + -- CASE C: AN ACCEPT STATEMENT FOR THE CALLED ENTRY HAS NOT BEEN + -- REACHED. + + -- RJW 3/31/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97301C IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + + BEGIN + + TEST ("C97301C", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN AN " & + "ACCEPT STATEMENT FOR THE CALLED ENTRY HAS " & + "NOT BEEN REACHED" ); + + + DECLARE + START_TIME : TIME; + STOP_TIME : TIME; + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TASK T IS + ENTRY NO_SPIN; + ENTRY DO_IT_NOW_OR_WAIT; + END T; + + TASK BODY T IS + BEGIN + ACCEPT NO_SPIN; + ACCEPT DO_IT_NOW_OR_WAIT; + END T; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + FAILED("RENDEZVOUS OCCURRED"); + ABORT T; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + T.NO_SPIN; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + T.DO_IT_NOW_OR_WAIT; + END SELECT; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + END; + -- END OF BLOCK CONTAINING TIMED + -- ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED (AND THE NONLOCALS UPDATED). + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + + END C97301C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- C97301D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED + -- AMOUNT OF TIME IF A RENDEVOUS IS NOT POSSIBLE. + + -- CASE D: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY + -- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY. + + -- RJW 3/31/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97301D IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + + BEGIN + + TEST ("C97301D", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME WHEN THE " & + "BODY OF THE TASK CONTAINING THE CALLED ENTRY " & + "DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR " & + "THAT ENTRY" ); + + DECLARE + START_TIME : TIME; + WAIT_TIME : CONSTANT DURATION := 10.0 * Impdef.One_Second; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT; + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + + ACCEPT KEEP_ALIVE; -- TO PREVENT THIS SERVER TASK FROM + -- TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END; + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT; + OR + -- THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + IF CLOCK >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT WAITING TIME" ); + END IF; + OR_BRANCH_TAKEN := TRUE; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.KEEP_ALIVE; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR RAISED" ); + + END; -- END OF BLOCK CONTAINING THE ENTRY CALL. + + -- BY NOW, THE TASK IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED?" ); + END IF; + + RESULT; + + END C97301D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97301e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97301e.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- C97301E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT LEAST THE SPECIFIED + -- AMOUNT OF TIME IF A RENDEZVOUS IS NOT POSSIBLE. + + -- CASE E: THE BODY OF THE TASK CONTAINING THE CALLED ENTRY + -- DOES NOT CONTAIN AN ACCEPT_STATEMENT FOR THAT ENTRY - + -- (THE ENTRY BELONGS TO AN ENTRY FAMILY; SOME FAMILY MEMBERS + -- ARE "ACCEPTABLE", BUT NOT THE CALLED ONE.) + + -- RJW 3/31/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97301E IS + + OR_BRANCH_TAKEN : BOOLEAN := FALSE; + + BEGIN + + TEST ("C97301E", "CHECK THAT A TIMED_ENTRY_CALL DELAYS FOR AT " & + "LEAST THE SPECIFIED AMOUNT OF TIME " & + "IN THE ABSENCE OF A CORRESPONDING " & + "ACCEPT_STATEMENT " ); + + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + START_TIME : TIME; + + STOP_TIME : TIME; + + SUBTYPE SHORT IS INTEGER RANGE 10..20 ; + + KEEP_ALIVE : INTEGER := 15 ; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT ( SHORT ) ; + END T ; + + TASK BODY T IS + BEGIN + + -- NO ACCEPT_STATEMENT FOR THE ENTRY_CALL BEING TESTED. + ACCEPT DO_IT_NOW_OR_WAIT ( IDENT_INT(15) ); + + -- THIS ALSO PREVENTS THIS SERVER + -- TASK FROM TERMINATING IF + -- UPON ACTIVATION + -- IT GETS TO RUN + -- AHEAD OF THE CALLER (WHICH + -- WOULD LEAD TO A SUBSEQUENT + -- TASKING_ERROR AT THE TIME + -- OF THE NO-WAIT CALL). + + END ; + + + BEGIN + START_TIME := CLOCK; + SELECT + T.DO_IT_NOW_OR_WAIT (10) ; -- ACCEPT_STATEMENT HAS 15. + OR + -- THEREFORE THIS BRANCH MUST BE CHOSEN. + DELAY WAIT_TIME; + STOP_TIME := CLOCK; + IF STOP_TIME >= (WAIT_TIME + START_TIME) THEN + NULL; + ELSE + FAILED ( "INSUFFICIENT DELAY" ); + END IF; + OR_BRANCH_TAKEN := TRUE ; + COMMENT( "OR_BRANCH TAKEN" ); + END SELECT; + + T.DO_IT_NOW_OR_WAIT (KEEP_ALIVE) ; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED ( "TASKING ERROR" ); + + END; -- END OF BLOCK CONTAINING THE TIMED ENTRY CALL. + + -- BY NOW, TASK T IS TERMINATED. + + IF OR_BRANCH_TAKEN THEN + NULL ; + ELSE + FAILED( "RENDEZVOUS ATTEMPTED" ); + END IF; + + RESULT; + + END C97301E ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97302a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97302a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97302a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97302a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- C97302A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHENEVER AN INDEX IS PRESENT IN A TIMED_ENTRY_CALL, IT + -- IS EVALUATED BEFORE ANY PARAMETER ASSOCIATIONS ARE EVALUATED, AND + -- PARAMETER ASSOCIATIONS ARE EVALUATED BEFORE THE DELAY EXPRESSION. + -- THEN A RENDEZVOUS IS ATTEMPTED. + + -- RJW 3/31/86 + + with Impdef; + WITH REPORT; USE REPORT; + WITH CALENDAR; USE CALENDAR; + PROCEDURE C97302A IS + + INDEX_COMPUTED : BOOLEAN := FALSE; + PARAM_COMPUTED : BOOLEAN := FALSE; + DELAY_COMPUTED : BOOLEAN := FALSE; + BEGIN + + TEST ("C97302A", "CHECK THAT WHENEVER AN INDEX IS PRESENT IN " & + "A TIMED_ENTRY_CALL, IT IS EVALUATED BEFORE " & + "ANY PARAMETER ASSOCIATIONS ARE EVALUATED, " & + "AND PARAMETER ASSOCIATIONS ARE EVALUATED " & + "BEFORE THE DELAY EXPRESSION" ); + DECLARE + + WAIT_TIME : DURATION := 3.0 * Impdef.One_Second; + + TYPE SHORT IS RANGE 10 .. 20; + + TASK T IS + ENTRY DO_IT_NOW_OR_WAIT + ( SHORT ) + ( DID_YOU_DO_IT : IN BOOLEAN ); + ENTRY KEEP_ALIVE; + END T; + + TASK BODY T IS + BEGIN + ACCEPT KEEP_ALIVE; + END T; + + FUNCTION F1 (X : SHORT) RETURN SHORT IS + BEGIN + INDEX_COMPUTED := TRUE; + RETURN (15); + END F1; + + FUNCTION F2 RETURN BOOLEAN IS + BEGIN + IF INDEX_COMPUTED THEN + NULL; + ELSE + FAILED ( "INDEX NOT EVALUATED FIRST" ); + END IF; + PARAM_COMPUTED := TRUE; + RETURN (FALSE); + END F2; + + FUNCTION F3 RETURN DURATION IS + BEGIN + IF PARAM_COMPUTED THEN + NULL; + ELSE + FAILED ( "PARAMETERS NOT EVALUATED BEFORE DELAY " & + "EXPRESSION" ); + END IF; + DELAY_COMPUTED := TRUE; + RETURN (WAIT_TIME); + END; + BEGIN + + SELECT + T.DO_IT_NOW_OR_WAIT + ( F1 (15) ) + ( NOT F2 ); + FAILED ("RENDEZVOUS OCCURRED"); + OR + DELAY F3; + END SELECT; + + T.KEEP_ALIVE; + + END; -- END OF BLOCK CONTAINING THE ENTRY CALLS. + + IF DELAY_COMPUTED THEN + NULL; + ELSE + FAILED( "DELAY EXPRESSION NOT EVALUATED" ); + END IF; + + RESULT; + + END C97302A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C97303A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A + -- SELECTIVE_WAIT CANNOT. + + -- PART 1: PACKAGE BODY EMBEDDED IN TASK BODY. + + + -- RM 4/06/1982 + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C97303A IS + + + BEGIN + + + TEST ( "C97303A" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + PACKAGE WITHIN_TASK_BODY IS + -- NOTHING HERE + END WITHIN_TASK_BODY ; + + + PACKAGE BODY WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PACKAGE OUTSIDE_TASK_BODY IS + -- NOTHING HERE + END OUTSIDE_TASK_BODY ; + + + PACKAGE BODY OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 2.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + + ------------------------------------------------------------------- + + + RESULT ; + + + END C97303A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- C97303B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED_ENTRY_CALL CAN APPEAR IN PLACES WHERE A + -- SELECTIVE_WAIT CANNOT. + + -- PART 2: PROCEDURE BODY EMBEDDED IN TASK BODY. + + + -- RM 4/12/1982 + + with Impdef; + WITH REPORT; + USE REPORT; + PROCEDURE C97303B IS + + + BEGIN + + + TEST ( "C97303B" , "CHECK THAT A TIMED_ENTRY_CALL CAN" & + " APPEAR WHERE A SELECTIVE_WAIT CANNOT" ); + + + ------------------------------------------------------------------- + + + DECLARE + + + TASK TT IS + ENTRY A ( AUTHORIZED : IN BOOLEAN ); + END TT ; + + + TASK BODY TT IS + + + PROCEDURE WITHIN_TASK_BODY ; + + + PROCEDURE WITHIN_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + A ( FALSE ) ; -- CALLING (OWN) ENTRY + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END WITHIN_TASK_BODY ; + + + BEGIN + + + -- CALL THE INNER PROC. TO FORCE EXEC. OF TIMED_E_CALL + WITHIN_TASK_BODY ; + + + ACCEPT A ( AUTHORIZED : IN BOOLEAN ) DO + + IF AUTHORIZED THEN + COMMENT( "AUTHORIZED ENTRY_CALL" ); + ELSE + FAILED( "UNAUTHORIZED ENTRY_CALL" ); + END IF; + + END A ; + + END TT ; + + + PROCEDURE OUTSIDE_TASK_BODY IS + BEGIN + + SELECT -- NOT A SELECTIVE_WAIT + TT.A ( FALSE ) ; -- UNBORN + OR + DELAY 1.0 * Impdef.One_Second; + COMMENT( "(OUT:) ALTERNATIVE BRANCH TAKEN" ); + END SELECT; + + END OUTSIDE_TASK_BODY ; + + + PACKAGE CREATE_OPPORTUNITY_TO_CALL IS END; + PACKAGE BODY CREATE_OPPORTUNITY_TO_CALL IS + BEGIN + -- CALL THE OTHER PROC. TO FORCE EXEC. OF TIMED_E_CALL + OUTSIDE_TASK_BODY ; + END CREATE_OPPORTUNITY_TO_CALL ; + + + BEGIN + + TT.A ( TRUE ); + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED( "TASKING ERROR" ); + + END ; + + ------------------------------------------------------------------- + + RESULT ; + + + END C97303B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97303c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97303c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- C97303C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED ENTRY CALL CAN APPEAR IN PLACES WHERE A SELECTIVE + -- WAIT IS NOT ALLOWED. + + -- PART 3: TASK BODY NESTED WITHIN A TASK. + + -- WRG 7/15/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97303C IS + + BEGIN + + TEST ("C97303C", "CHECK THAT A TIMED ENTRY CALL CAN " & + "APPEAR IN PLACES WHERE A SELECTIVE WAIT " & + "IS NOT ALLOWED; CASE: TASK BODY NESTED " & + "WITHIN A TASK"); + + DECLARE + + TASK T IS + ENTRY E; + ENTRY SYNCH; + END T; + + TASK BODY T IS + BEGIN + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + END T; + + TASK OUTER IS + ENTRY E; + ENTRY SYNCH; + END OUTER; + + TASK BODY OUTER IS + + TASK TYPE INNER; + + INNER1 : INNER; + + TASK BODY INNER IS + BEGIN + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (1)"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + SELECT + OUTER.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - " & + "INNER (2)"); + OR + DELAY 1.0 * Impdef.One_Second; + OUTER.SYNCH; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - INNER"); + END INNER; + + PACKAGE DUMMY IS + TYPE ACC_INNER IS ACCESS INNER; + INNER2 : ACC_INNER := NEW INNER; + END DUMMY; + + BEGIN + + SELECT + T.E; + FAILED ("TIMED ENTRY CALL ACCEPTED - OUTER"); + OR + DELAY 1.0 * Impdef.One_Second; + T.SYNCH; + END SELECT; + + ACCEPT SYNCH; + ACCEPT SYNCH; + ACCEPT E; + + EXCEPTION + + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - OUTER"); + + END OUTER; + + BEGIN + + T.E; + OUTER.E; + + END; + + RESULT; + + END C97303C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97304a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- C97304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE EXCEPTION TASKING_ERROR WILL BE RAISED IF THE CALLED + -- TASK HAS ALREADY COMPLETED ITS EXECUTION AT THE TIME OF THE + -- TIMED_ENTRY_CALL. + + + -- RM 5/28/82 + -- SPS 11/21/82 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97304A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + + BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C97304A", "CHECK THAT THE EXCEPTION TASKING_ERROR WILL" & + " BE RAISED IF THE CALLED TASK HAS ALREADY" & + " COMPLETED ITS EXECUTION AT THE TIME OF THE" & + " TIMED_ENTRY_CALL" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN T_OBJECT1'TERMINATED ; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 50 S.)" ); + END IF; + + + BEGIN + + SELECT + T_OBJECT1.E ; + FAILED( "CALL WAS NOT DISOBEYED" ); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED( "'OR' BRANCH TAKEN INSTEAD OF TSKG_ERROR" ); + END SELECT; + + FAILED( "EXCEPTION NOT RAISED" ); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL ; + + WHEN OTHERS => + FAILED( "WRONG EXCEPTION RAISED" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + + END C97304A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97304b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97304b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97304b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97304b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- C97304B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASKING_ERROR IS RAISED IF THE CALLED TASK IS ABORTED + -- BEFORE THE TIMED ENTRY CALL IS EXECUTED. + + -- WRG 7/13/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97304B IS + + BEGIN + + TEST ("C97304B", "CHECK THAT TASKING_ERROR IS RAISED IF THE " & + "CALLED TASK IS ABORTED BEFORE THE TIMED " & + "ENTRY CALL IS EXECUTED"); + + DECLARE + + TASK T IS + ENTRY E (I : INTEGER); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (I : INTEGER); + FAILED ("ENTRY CALL ACCEPTED"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED"); + END T; + + FUNCTION F RETURN INTEGER IS + BEGIN + ABORT T; + RETURN 1; + END F; + + BEGIN + + SELECT + T.E (F); + FAILED ("TIMED ENTRY CALL MADE"); + OR + DELAY 1.0 * Impdef.One_Second; + FAILED ("DELAY ALTERNATIVE TAKEN"); + END SELECT; + + FAILED ("EXCEPTION NOT RAISED"); + + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + + END; + + RESULT; + + END C97304B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- C97305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A + -- TIMED ENTRY CALL), IT IS PERFORMED. + + -- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT + -- STATEMENT. + + -- WRG 7/13/86 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97305A IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + + BEGIN + + TEST ("C97305A", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + + END C97305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- C97305B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY POSSIBLE (FOR A + -- TIMED ENTRY CALL), IT IS PERFORMED. + + -- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + + -- WRG 7/13/86 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97305B IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + COUNT : POSITIVE := 1; + ZERO : DURATION := 1.0; + + + BEGIN + + TEST ("C97305B", "CHECK THAT IF THE RENDEZVOUS IS IMMEDIATELY " & + "POSSIBLE (FOR A TIMED ENTRY CALL), IT " & + "IS PERFORMED"); + + IF EQUAL (3, 3) THEN + ZERO := 0.0; + END IF; + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + WHILE NOT STATEMENTS_AFTER_CALL_EXECUTED LOOP + DELAY 1.0 * Impdef.One_Second; + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY ZERO; + IF COUNT < 60 * 60 THEN + COUNT := COUNT + 1; + ELSE + FAILED ("NO RENDEZVOUS AFTER AT LEAST ONE " & + "HOUR ELAPSED"); + EXIT; + END IF; + END SELECT; + END LOOP; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF COUNT > 1 THEN + COMMENT ("DELAYED" & POSITIVE'IMAGE(COUNT) & " SECONDS"); + END IF; + + RESULT; + + END C97305B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- C97305C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES + -- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + + -- CASE A: SINGLE ENTRY; THE CALLED TASK IS EXECUTING AN ACCEPT + -- STATEMENT. + + -- WRG 7/13/86 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97305C IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + + BEGIN + + TEST ("C97305C", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + ACCEPT E (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + END T; + + BEGIN + + SELECT + T.E (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + + END C97305C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97305d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97305d.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C97305D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF THE RENDEZVOUS IS NOT IMMEDIATELY POSSIBLE BUT BECOMES + -- POSSIBLE BEFORE THE DELAY EXPIRES, THE TIMED ENTRY CALL IS ACCEPTED. + + -- CASE B: ENTRY FAMILY; THE CALLED TASK IS EXECUTING A SELECTIVE WAIT. + + -- WRG 7/13/86 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C97305D IS + + RENDEZVOUS_OCCURRED : BOOLEAN := FALSE; + STATEMENTS_AFTER_CALL_EXECUTED : BOOLEAN := FALSE; + DELAY_IN_MINUTES : CONSTANT POSITIVE := 30; + + + BEGIN + + TEST ("C97305D", "CHECK THAT IF THE RENDEZVOUS IS NOT " & + "IMMEDIATELY POSSIBLE BUT BECOMES POSSIBLE " & + "BEFORE THE DELAY EXPIRES, THE TIMED ENTRY " & + "CALL IS ACCEPTED"); + + DECLARE + + TASK T IS + ENTRY E (1..3) (B : IN OUT BOOLEAN); + END T; + + TASK BODY T IS + BEGIN + DELAY 10.0 * Impdef.One_Second; + + SELECT + ACCEPT E (2) (B : IN OUT BOOLEAN) DO + B := IDENT_BOOL (TRUE); + END E; + OR + ACCEPT E (3) (B : IN OUT BOOLEAN); + FAILED ("NONEXISTENT ENTRY CALL ACCEPTED"); + END SELECT; + END T; + + BEGIN + + SELECT + T.E (2) (RENDEZVOUS_OCCURRED); + STATEMENTS_AFTER_CALL_EXECUTED := IDENT_BOOL (TRUE); + OR + DELAY DELAY_IN_MINUTES * 60.0 * Impdef.One_Second; + FAILED ("TIMED ENTRY CALL NOT ACCEPTED AFTER" & + POSITIVE'IMAGE(DELAY_IN_MINUTES) & + " MINUTES ELAPSED"); + + END SELECT; + + END; + + IF NOT RENDEZVOUS_OCCURRED THEN + FAILED ("RENDEZVOUS DID NOT OCCUR"); + END IF; + + IF NOT STATEMENTS_AFTER_CALL_EXECUTED THEN + FAILED ("STATEMENTS AFTER ENTRY CALL NOT EXECUTED"); + END IF; + + RESULT; + + END C97305D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97307a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97307a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c97307a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c97307a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C97307A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TIMED ENTRY CALL THAT IS CANCELED (BECAUSE THE DELAY HAS + -- EXPIRED) IS REMOVED FROM THE QUEUE OF THE CALLED TASK'S ENTRY. + + -- WRG 7/14/86 + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C97307A IS + + BEGIN + + TEST ("C97307A", "CHECK THAT A TIMED ENTRY CALL THAT IS " & + "CANCELED (BECAUSE THE DELAY HAS EXPIRED) IS " & + "REMOVED FROM THE QUEUE OF THE CALLED TASK'S " & + "ENTRY"); + + DECLARE + + DELAY_TIME : CONSTANT DURATION := 2 * 60.0 * Impdef.One_Second; + + TASK EXPIRED IS + ENTRY INCREMENT; + ENTRY READ (COUNT : OUT NATURAL); + END EXPIRED; + + TASK TYPE NON_TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END NON_TIMED_CALLER; + + TASK TYPE TIMED_CALLER IS + ENTRY NAME (N : NATURAL); + END TIMED_CALLER; + + CALLER1 : TIMED_CALLER; + CALLER2 : NON_TIMED_CALLER; + CALLER3 : TIMED_CALLER; + CALLER4 : NON_TIMED_CALLER; + CALLER5 : TIMED_CALLER; + + TASK T IS + ENTRY E (NAME : NATURAL); + END T; + + TASK DISPATCH IS + ENTRY READY; + END DISPATCH; + + -------------------------------------------------- + + TASK BODY EXPIRED IS + EXPIRED_CALLS : NATURAL := 0; + BEGIN + LOOP + SELECT + ACCEPT INCREMENT DO + EXPIRED_CALLS := EXPIRED_CALLS + 1; + END INCREMENT; + OR + ACCEPT READ (COUNT : OUT NATURAL) DO + COUNT := EXPIRED_CALLS; + END READ; + OR + TERMINATE; + END SELECT; + END LOOP; + END EXPIRED; + + -------------------------------------------------- + + TASK BODY NON_TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + T.E (MY_NAME); + END NON_TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY TIMED_CALLER IS + MY_NAME : NATURAL; + BEGIN + ACCEPT NAME (N : NATURAL) DO + MY_NAME := N; + END NAME; + + SELECT + T.E (MY_NAME); + FAILED ("TIMED ENTRY CALL NOT CANCELED FOR CALLER" & + NATURAL'IMAGE(MY_NAME)); + OR + DELAY DELAY_TIME; + EXPIRED.INCREMENT; + END SELECT; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED IN TIMED_CALLER -- " & + "CALLER" & NATURAL'IMAGE(MY_NAME)); + END TIMED_CALLER; + + -------------------------------------------------- + + TASK BODY DISPATCH IS + BEGIN + CALLER1.NAME (1); + ACCEPT READY; + + CALLER2.NAME (2); + ACCEPT READY; + + CALLER3.NAME (3); + ACCEPT READY; + + CALLER4.NAME (4); + ACCEPT READY; + + CALLER5.NAME (5); + END DISPATCH; + + -------------------------------------------------- + + TASK BODY T IS + + DESIRED_QUEUE_LENGTH : NATURAL := 1; + EXPIRED_CALLS : NATURAL; + + ACCEPTED : ARRAY (1..5) OF NATURAL RANGE 0..5 + := (OTHERS => 0); + ACCEPTED_INDEX : NATURAL := 0; + + BEGIN + LOOP + LOOP + EXPIRED.READ (EXPIRED_CALLS); + EXIT WHEN E'COUNT >= DESIRED_QUEUE_LENGTH - + EXPIRED_CALLS; + DELAY 2.0 * Impdef.One_Second; + END LOOP; + EXIT WHEN DESIRED_QUEUE_LENGTH = 5; + DISPATCH.READY; + DESIRED_QUEUE_LENGTH := DESIRED_QUEUE_LENGTH + 1; + END LOOP; + + -- AT THIS POINT, FIVE TASKS WERE QUEUED. + -- LET THE TIMED ENTRY CALLS ISSUED BY CALLER1, + -- CALLER3, AND CALLER5 EXPIRE: + + DELAY DELAY_TIME + 10.0 * Impdef.One_Second; + + -- AT THIS POINT, ALL THE TIMED ENTRY CALLS MUST HAVE + -- EXPIRED AND BEEN REMOVED FROM THE ENTRY QUEUE FOR E, + -- OTHERWISE THE IMPLEMENTATION HAS FAILED THIS TEST. + + WHILE E'COUNT > 0 LOOP + ACCEPT E (NAME : NATURAL) DO + ACCEPTED_INDEX := ACCEPTED_INDEX + 1; + ACCEPTED (ACCEPTED_INDEX) := NAME; + END E; + END LOOP; + + IF ACCEPTED /= (2, 4, 0, 0, 0) THEN + FAILED ("SOME TIMED CALLS NOT REMOVED FROM ENTRY " & + "QUEUE"); + COMMENT ("ORDER ACCEPTED WAS:" & + NATURAL'IMAGE (ACCEPTED (1)) & ',' & + NATURAL'IMAGE (ACCEPTED (2)) & ',' & + NATURAL'IMAGE (ACCEPTED (3)) & ',' & + NATURAL'IMAGE (ACCEPTED (4)) & ',' & + NATURAL'IMAGE (ACCEPTED (5)) ); + END IF; + END T; + + -------------------------------------------------- + + BEGIN + + NULL; + + END; + + RESULT; + + END C97307A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- C974001.A + -- + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is aborted if it does not complete before the triggering statement + -- completes, where the triggering statement is a delay_relative + -- statement and check that the sequence of statements of the triggering + -- alternative is executed after the abortable part is left. + -- + -- TEST DESCRIPTION: + -- Declare a task with an accept statement containing an asynchronous + -- select with a delay_relative triggering statement. Parameterize + -- the accept statement with the time to be used in the delay. Simulate a + -- time-consuming calculation by declaring a procedure containing an + -- infinite loop. Call this procedure in the abortable part. + -- + -- The delay will expire before the abortable part completes, at which + -- time the abortable part is aborted, and the sequence of statements + -- following the triggering statement is executed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with ImpDef; + + procedure C974001 is + + + --========================================================-- + + -- Medium length delay + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + + Calculation_Canceled : exception; + + + Count : Integer := 1234; + + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + delay ImpDef.Minimum_Task_Switch; -- allow other task + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + -- + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay Time_Limit; -- Time_Limit is not up yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + then abort + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C974001", "Asynchronous Select: Trigger is delay_relative" & + " which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + null; -- expected behavior + end; + + Report.Result; + + end C974001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C974002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sequence of statements of the triggering alternative + -- of an asynchronous select statement is executed if the triggering + -- statement is a delay_until statement, and the specified time has + -- already passed. Check that the abortable part is not executed after + -- the sequence of statements of the triggering alternative is left. + -- + -- Check that the sequence of statements of the triggering alternative + -- of an asynchronous select statement is not executed if the abortable + -- part completes before the triggering statement, and the triggering + -- statement is a delay_until statement. + -- + -- TEST DESCRIPTION: + -- Declare a task with an accept statement containing an asynchronous + -- select with a delay_until triggering statement. Parameterize + -- the accept statement with the time to be used in the delay. Simulate + -- a quick calculation by declaring a procedure which sets a Boolean + -- flag. Call this procedure in the abortable part. + -- + -- Make two calls to the task entry: (1) with a time that has already + -- expired, and (2) with a time that will not expire before the quick + -- calculation completes. + -- + -- For (1), the sequence of statements following the triggering statement + -- is executed, and the abortable part never starts. + -- + -- For (2), the abortable part completes before the triggering statement, + -- the delay is canceled, and the sequence of statements following the + -- triggering statement never starts. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Nov 95 SAIC Bug fix for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Calendar; + with ImpDef; + procedure C974002 is + + function "-" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."-"; + function "+" (Left: Ada.Calendar.Time; Right: Duration ) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + Abortable_Part_Executed : Boolean; + Triggering_Alternative_Executed : Boolean; + + + --========================================================-- + + + procedure Quick_Calculation is + begin + if Report.Equal (1, 1) then + Abortable_Part_Executed := True; + end if; + end Quick_Calculation; + + + --========================================================-- + + + task type Timed_Calculation_Task is + entry Calculation (Time_Out : in Ada.Calendar.Time); + end Timed_Calculation_Task; + + + task body Timed_Calculation_Task is + begin + loop + select + accept Calculation (Time_Out : in Ada.Calendar.Time) do + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + delay until Time_Out; -- Triggering + -- statement. + + Triggering_Alternative_Executed := True; -- Triggering + -- alternative. + then abort + Quick_Calculation; -- Abortable part. + end select; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation_Task"); + end Timed_Calculation_Task; + + + --========================================================-- + + + Start_Time : constant Ada.Calendar.Time := + Ada.Calendar.Time_of (1901,1,1); + Minute : constant Duration := 60.0; + + + --========================================================-- + + + begin -- Main program. + + Report.Test ("C974002", "Asynchronous Select with Delay_Until"); + + -- take care of implementations that start the clock at 1/1/01 + delay ImpDef.Delay_For_Time_Past; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + NO_DELAY_SUBTEST: + + declare + -- Set Expiry to a time which has already passed + Expiry : constant Ada.Calendar.Time := Start_Time; + Timed : Timed_Calculation_Task; + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. Since it has already passed, the + -- abortable part should not execute, and the sequence of statements + -- of the triggering alternative should be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select + -- inside accept block. + if Abortable_Part_Executed then + Report.Failed ("No delay: Abortable part was executed"); + end if; + + if not Triggering_Alternative_Executed then + Report.Failed ("No delay: triggering alternative sequence " & + "of statements was not executed"); + end if; + end No_Delay_Subtest; + + + Abortable_Part_Executed := False; + Triggering_Alternative_Executed := False; + + LONG_DELAY_SUBTEST: + + declare + + -- Quick_Calculation should finish before expiry. + Expiry : constant Ada.Calendar.Time := + Ada.Calendar.Clock + Minute; + Timed : Timed_Calculation_Task; + + begin + + -- Expiry is the time to be specified in the delay_until statement + -- of the asynchronous select. It should not pass before the abortable + -- part completes, at which time control should return to the caller; + -- the sequence of statements of the triggering alternative should + -- not be executed. + + Timed.Calculation (Time_Out => Expiry); -- Asynchronous select. + + if not Abortable_Part_Executed then + Report.Failed ("Long delay: Abortable part was not executed"); + end if; + + if Triggering_Alternative_Executed then + Report.Failed ("Long delay: triggering alternative sequence " & + "of statements was executed"); + end if; + end Long_Delay_Subtest; + + + Report.Result; + + end C974002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974003.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,249 ---- + -- C974003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is aborted if it does not complete before the triggering statement + -- completes, where the triggering statement is a task entry call, and + -- the entry call is queued. + -- + -- Check that the sequence of statements of the triggering alternative + -- is executed after the abortable part is left. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Force the entry call to be + -- queued by having the task call a procedure, prior to the corresponding + -- accept statement, which simulates a routine waiting for user input + -- (with a delay). + -- + -- Simulate a time-consuming routine in the abortable part by calling a + -- procedure containing an infinite loop. Meanwhile, simulate input by + -- the user (the delay expires), which causes the task to execute the + -- accept statement corresponding to the triggering entry call. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C974003_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + TC_Triggering_Statement_Completed : Boolean := False; + TC_Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974003_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + package body C974003_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Minimum_Task_Switch; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + -- then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + TC_Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + TC_Count := (TC_Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (TC_Count, TC_Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + + end C974003_0; + + + --==================================================================-- + + + with Report; + + with C974003_0; -- Automated teller machine abstraction. + use C974003_0; + + procedure C974003 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974003", "Asynchronous Select: Trigger is queued on a " & + "task entry and completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974003_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and completes before this call + -- finishes; it is then aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + if not TC_Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + if TC_Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end; + + Report.Result; + + end C974003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974004.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,273 ---- + -- C974004.A + -- + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is aborted if it does not complete before the triggering statement + -- completes, where the triggering statement is a task entry call, + -- the entry call is queued, and the entry call completes by propagating + -- an exception and that the sequence of statements of the triggering + -- alternative is not executed after the abortable part is left and that + -- the exception propagated by the entry call is re-raised immediately + -- following the asynchronous select. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Force the entry call to be + -- queued by having the task call a procedure, prior to the corresponding + -- accept statement, which simulates a routine waiting for user input + -- (with a delay). + -- + -- Simulate a time-consuming routine in the abortable part by calling a + -- procedure containing an infinite loop. Meanwhile, simulate input by + -- the user (the delay expires), which causes the task to execute the + -- accept statement corresponding to the triggering entry call. Raise + -- an exception in the accept statement which is not handled by the task, + -- and which is thus propagated to the caller. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C974004_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; -- Global to defeat + -- optimization. + Propagated_From_Task : exception; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974004_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + package body C974004_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses cancel before it completes. + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Cancel; + end if; + end Listen_For_Input; + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + loop + -- Force entry calls to be + Listen_For_Input (Key_Pressed); -- queued, then set guard to + -- true. + select + when (Key_Pressed = Cancel) => -- Guard is now true, so accept + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed + ("Exception not propagated in ATM_Keyboard_Task"); + + -- User has canceled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + Key_Pressed := None; + end select; + end loop; + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + -- Synch. point to allow transfer of control to Keyboard + -- task during this simulation + delay ImpDef.Minimum_Task_Switch; + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + + end C974004_0; + + + --==================================================================-- + + + with Report; + + with C974004_0; -- Automated teller machine abstraction. + use C974004_0; + + procedure C974004 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974004", "Asynchronous Select: Trigger is queued on a " & + "task entry and is completed first by an " & + "exception"); + + Read_Card (Card_Data); + + begin + + declare + -- Create the task for this transaction + Keyboard : C974004_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call finishes; it is then + -- aborted. + + -- Check that the whole of the abortable part is aborted, not + -- just the statement in the abortable part that was executing + -- at the time + Report.Failed ("Abortable part not aborted"); + end select; + -- The propagated exception is + -- re-raised here; control passes to + -- the exception handler. + + Perform_Transaction(Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + -- This is the expected test path + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + when Tasking_Error => + Report.Failed ("Tasking_Error raised"); + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Propagated_From_Task => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + + end C974004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974005.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- C974005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Tasking_Error is raised at the point of an entry call + -- which is the triggering statement of an asynchronous select, if + -- the entry call is queued, but the task containing the entry completes + -- before it can be accepted or canceled. + -- + -- Check that the abortable part is aborted if it does not complete + -- before the triggering statement completes. + -- + -- Check that the sequence of statements of the triggering alternative + -- is not executed. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Force the entry call to be + -- queued by having the task call a procedure, prior to the corresponding + -- accept statement, which simulates a routine waiting for user input + -- (with a delay). + -- + -- Simulate a time-consuming routine in the abortable part by calling a + -- procedure containing an infinite loop. Meanwhile, simulate input by + -- the user (the delay expires) which is NOT the input expected by the + -- guard on the accept statement. The entry remains closed, and the + -- task completes its execution. Since the entry was not accepted before + -- its task completed, Tasking_Error is raised at the point of the entry + -- call. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C974005_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Count : Integer := 1234; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974005_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + package body C974005_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where a user waits a bit for the card to + -- be validated, then presses a transaction key (NOT Cancel). + + -- Delay long enough to force queuing of Keyboard.Cancel_Pressed. + delay ImpDef.Clear_Ready_Queue; + + if Report.Equal (3, 3) then -- Always true. + Key := Deposit; -- Cancel is NOT pressed. + end if; + end Listen_For_Input; + + + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + + -- Note: no loop. If the user does not press Cancel, the task completes. + -- In this model of the keyboard monitor, the user only gets one chance + -- to cancel the card validation. + -- Force entry + Listen_For_Input (Key_Pressed); -- calls to be + -- queued, but do + -- NOT set guard + -- to true. + select + when (Key_Pressed = Cancel) => -- Guard is false, + accept Cancel_Pressed do -- so entry call + Report.Failed ("Accept statement executed"); -- remains queued. + end Cancel_Pressed; + else -- Else alternative + Key_Pressed := None; -- executed, then + end select; -- task ends. + exception + when others => + Report.Failed ("Unexpected exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + -- Simulate an exceedingly long validation activity. + loop -- Infinite loop. + Count := (Count + 1) mod Integer (Card.PIN); + + -- Synch Point to allow transfer of control to Keyboard task + -- during this simulation + delay ImpDef.Minimum_Task_Switch; + + exit when not Report.Equal (Count, Count); -- Always false. + end loop; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + if Count = 1234 then + -- Additional analysis added to aid developers + Report.Failed ("Abortable part did not execute"); + end if; + end Perform_Transaction; + + + end C974005_0; + + + --==================================================================-- + + + with Report; + + with C974005_0; -- Automated teller machine abstraction. + use C974005_0; + + procedure C974005 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974005", "ATC: trigger is queued but task terminates" & + " before call is serviced"); + + Read_Card (Card_Data); + + begin + + declare + Keyboard : C974005_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call initially queued, so + -- abortable part starts. + + -- Tasking_Error raised here when + -- Keyboard completes before entry + -- call can be accepted, and before + -- abortable part completes. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard task completes before + -- Keyboard.Cancel_Pressed is + -- accepted, and before this call + -- finishes. Tasking_Error is raised + -- at the point of the entry call, + -- and this call is aborted. + -- Check that the whole of the abortable part is aborted, not just + -- the statement in the abortable part that was executing at + -- the time + Report.Failed ("Abortable part not aborted"); + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when Tasking_Error => + Report.Failed ("Correct exception raised at wrong level"); + when others => + Report.Failed ("Wrong exception raised at wrong level"); + end; + + Report.Result; + + end C974005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974006.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,197 ---- + -- C974006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sequence of statements of the triggering alternative + -- of an asynchronous select statement is executed if the triggering + -- statement is a protected entry call, and the entry is accepted + -- immediately. Check that the corresponding entry body is executed + -- before the sequence of statements of the triggering alternative. + -- Check that the abortable part is not executed. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a + -- protected entry call as triggering statement. Declare a protected + -- procedure which sets the protected entry's barrier true. Force the + -- entry call to be accepted immediately by calling this protected + -- procedure prior to the asynchronous select. Since the entry call + -- is accepted immediately, the abortable part should never start. When + -- entry call completes, the sequence of statements of the triggering + -- alternative should execute. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package C974006_0 is -- Automated teller machine abstraction. + + + -- Flag for testing purposes: + + Entry_Body_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974006_0; + + + --==================================================================-- + + + with Report; + package body C974006_0 is + + + protected body ATM_Keyboard_Protected is + + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Entry_Body_Executed := True; + end Cancel_Pressed; + + procedure Read_Key is + begin + -- Simulate a procedure which processes user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not fully executed"); + end Perform_Transaction; + + + end C974006_0; + + + --==================================================================-- + + + with Report; + + with C974006_0; -- Automated teller machine abstraction. + use C974006_0; + + procedure C974006 is + + Card_Data : ATM_Card_Type; + + begin + + Report.Test ("C974006", "ATC: trigger is protected entry call" & + " and completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974006_0.ATM_Keyboard_Protected; + begin + + -- Simulate the situation where the user hits cancel before the + -- validation process can start: + Keyboard.Read_Key; -- Force Keyboard.Cancel_Pressed to + -- be accepted immediately. + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is accepted immediately, + -- so abortable part does NOT start. + + if not Entry_Body_Executed then -- Executes after entry completes. + Report.Failed ("Triggering alternative sequence of statements " & + "executed before triggering statement complete"); + end if; + + raise Transaction_Canceled; -- Control passes to exception + -- handler. + then abort + Validate_Card (Card_Data); -- Should not be executed. + end select; + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + null; + end; + + Report.Result; + + end C974006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974007.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,205 ---- + -- C974007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sequence of statements of the triggering alternative + -- of an asynchronous select statement is not executed if the triggering + -- statement is a protected entry call, and the entry is not accepted + -- before the abortable part completes. Check that execution continues + -- immediately following the asynchronous select. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a + -- protected entry call as triggering statement. Declare a protected + -- procedure which sets the protected entry's barrier true. Ensure + -- that the entry call is never accepted by not calling the protected + -- procedure; the barrier remains false, and the entry call from + -- asynchronous select is queued. Since the abortable part will complete + -- before the entry is accepted, the sequence of statements of the + -- triggering alternative is never executed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package C974007_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + -- + Abortable_Part_Executed : Boolean := False; + Perform_Transaction_Executed : Boolean := False; + Triggering_Statement_Executed : Boolean := False; + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + protected type ATM_Keyboard_Protected is + entry Cancel_Pressed; + procedure Read_Key; + private + Last_Key_Pressed : Key_Enum := None; + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974007_0; + + + --==================================================================-- + + + with Report; + package body C974007_0 is + + + protected body ATM_Keyboard_Protected is + + -- Barrier is false for the live of the test + entry Cancel_Pressed when (Last_Key_Pressed = Cancel) is + begin + Triggering_Statement_Executed := true; -- Test has failed + -- (Note: cannot call Report.Failed in the protected entry body] + end Cancel_Pressed; + + procedure Read_Key is -- Never + begin -- called. + -- Simulate a procedure which reads user keyboard input, and + -- which is called by some interrupt handler. + Last_Key_Pressed := Cancel; + end Read_Key; + + end ATM_Keyboard_Protected; + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Abortable_Part_Executed := True; + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Perform_Transaction_Executed := True; + end Perform_Transaction; + + + end C974007_0; + + + --==================================================================-- + with Report; + + with C974007_0; -- Automated teller machine abstraction. + use C974007_0; + + procedure C974007 is + + Card_Data : ATM_Card_Type; + + begin + + Report.Test ("C974007", "ATC: trigger is protected entry call" & + " and abortable part completes first"); + + Read_Card (Card_Data); + + declare + Keyboard : C974007_0.ATM_Keyboard_Protected; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Barrier is never set true, so + -- entry call is queued and never + -- accepted. + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- This call completes before + -- Keyboard.Cancel_Pressed can be + -- accepted. + end select; + Perform_Transaction (Card_Data); -- Execution proceeds here after + -- Validate_Card completes. + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + end; + + + if Triggering_Statement_Executed then + Report.Failed ("Triggering statement was executed"); + end if; + + if not Abortable_Part_Executed then + Report.Failed ("Abortable part not executed"); + end if; + + if not Perform_Transaction_Executed then + Report.Failed ("Statements following asynchronous select not " & + "executed"); + end if; + + Report.Result; + + end C974007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974008.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- C974008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is not started if the triggering statement is a task entry call, and + -- the entry call is not queued. + -- + -- Check that the sequence of statements of the triggering alternative + -- is executed after the abortable part is left. + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Ensure that the task is waiting + -- at the accept statement so the rendezvous is executed immediately (the + -- entry call is not queued). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C974008_0 is -- Automated teller machine abstraction. + + + -- Flags for testing purposes: + + Triggering_Statement_Completed : Boolean := False; + Count : Integer := 1234; -- Global to defeat + -- optimization. + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Read_Card (Card : in out ATM_Card_Type); + + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974008_0; + + + --==================================================================-- + + + with Report; + package body C974008_0 is + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Simulate the situation where the user presses the cancel key + -- before the card is validated + + -- press the cancel key immediately + Key := Cancel; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + -- NOTE: Normal usage for this routine would be the loop with + -- the select statement included. This particular test + -- requires that the task be waiting at the accept + -- for the call. To ensure that this is the case the + -- extraneous commands are commented out (we leave them + -- in this form to show the reader the surrounds to the + -- fragment of code remaining) + + -- loop + + Listen_For_Input (Key_Pressed); + + -- select + -- when (Key_Pressed = Cancel) => -- Guard is now + accept Cancel_Pressed do -- true, so accept + Triggering_Statement_Completed := True; -- queued entry + end Cancel_Pressed; -- call. + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + -- exit; + -- else + -- Key_Pressed := None; + -- end select; + + -- end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Triggering alternative sequence of statements " & + "not executed"); + if not Triggering_Statement_Completed then + Report.Failed ("Triggering statement did not complete"); + end if; + end Perform_Transaction; + + + end C974008_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with C974008_0; -- Automated teller machine abstraction. + use C974008_0; + + procedure C974008 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974008", "Asynchronous Select: Trigger is a call to a " & + "waiting task entry and completes immediately"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974008_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting at the accept + -- This is the time required to activate another task and allow it + -- to run to its first accept statement. + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + Keyboard.Cancel_Pressed; -- Entry call is executed immediately + + raise Transaction_Canceled; -- This is executed after Validate_Card + -- is aborted. + then abort + + -- In other similar tests Validate_Card is called here. In this + -- test we just check to see if the abortable part is called at + -- all. Since the triggering call is not queued the abortable + -- part should not be started + -- + Report.Failed ("Abortable part started"); + + end select; + + Perform_Transaction (Card_Data); -- Should not be reached. + exception + when Transaction_Canceled => + + if not Triggering_Statement_Completed then + Report.Failed ("Triggering alternative sequence of statements " & + "executed but triggering statement not complete"); + end if; + + end; + + Report.Result; + + end C974008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974009.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,206 ---- + -- C974009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is not started if the triggering statement is a task entry call, + -- the entry call is not queued and the entry call completes by + -- propagating an exception. + -- + -- Check that the exception is properly propagated to the asynchronous + -- select statement and thus the sequence of statements of the triggering + -- alternative is not executed after the abortable part is left. + -- + -- Check that the exception propagated by the entry call is re-raised + -- immediately following the asynchronous select. + -- + -- TEST DESCRIPTION: + -- + -- Use a small subset of the base Automated teller machine simulation + -- which is shown in greater detail in other tests of this series. + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Force the task to be waiting at + -- the accept statement so that the call is not queued and the rendezvous + -- is executed immediately. Simulate an unexpected exception in the + -- rendezvous. Use stripped down versions of called procedures to check + -- the correct path in the test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package C974009_0 is -- Automated teller machine abstraction. + + + Propagated_From_Task : exception; + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974009_0; + + + --==================================================================-- + + + with Report; + package body C974009_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum := None; + begin + accept Cancel_Pressed do -- queued entry call. + null; --:::: stub, user code for cancel + -- Now simulate an unexpected exception arising in the + -- user code + raise Propagated_From_Task; -- Propagate an exception. + + end Cancel_Pressed; + + Report.Failed ("Exception not propagated in ATM_Keyboard_Task"); + + exception + when Propagated_From_Task => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + + end C974009_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with C974009_0; -- Automated teller machine abstraction. + use C974009_0; + + procedure C974009 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974009", "Asynchronous Select: Trigger is a call to a " & + "task entry, is not queued and is completed " & + "first by an exception"); + + + begin + + declare + -- Create the task for this transaction + Keyboard : C974009_0.ATM_Keyboard_Task; + begin + + -- Ensure task is waiting a the accept so the call is not queued + -- This is the time required to activate another task and allow it + -- to run to its first accept statement + -- + delay ImpDef.Switch_To_New_Task; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + then abort + Validate_Card (Card_Data); -- Keyboard.Cancel_Pressed is accepted + -- and propagates an exception before + -- this call is executed + end select; + + -- The propagated exception is re-raised here. + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Propagated_From_Task => + null; -- This is the expected test path + when others => + Report.Failed ("Wrong exception raised"); + end; + + exception + when others => + Report.Failed ("Unexpected exception raised"); + end; + + Report.Result; + + end C974009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974010.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,209 ---- + -- C974010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is not started if the triggering statement is a task entry call to + -- a task that has already terminated. + -- + -- Check that Tasking_Error is properly propagated to the asynchronous + -- select statement and thus the sequence of statements of the triggering + -- alternative is not executed after the abortable part is left. + -- + -- Check that Tasking_Error is re-raised immediately following the + -- asynchronous select. + -- + -- TEST DESCRIPTION: + -- + -- Use a small subset of the base Automated Teller Machine simulation + -- which is shown in greater detail in other tests of this series. + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Ensure that the task is + -- terminated before the entry call. Use stripped down versions of + -- the called procedures to check the correct path in the test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package C974010_0 is -- Automated teller machine abstraction. + + + Transaction_Canceled : exception; + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974010_0; + + + --==================================================================-- + + + with Report; + package body C974010_0 is + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + TC_Suicide : exception; + Key_Pressed : Key_Enum := None; + begin + raise TC_Suicide; -- Simulate early, unexpected termination + + accept Cancel_Pressed do -- queued entry call. + null; --:::: user code for cancel + + end Cancel_Pressed; + + exception + when TC_Suicide => + null; -- This is the expected test behavior + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Report.Failed ("Abortable part was executed"); + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + Report.Failed ("Exception not re-raised immediately following " & + "asynchronous select"); + end Perform_Transaction; + + + end C974010_0; + + + --==================================================================-- + + + with Report; + with ImpDef; + + with C974010_0; -- Automated teller machine abstraction. + use C974010_0; + + procedure C974010 is + + Card_Data : ATM_Card_Type; + TC_Tasking_Error_Handled : Boolean := false; + + begin -- Main program. + + Report.Test ("C974010", "Asynchronous Select: Trigger is a call to a " & + "task entry of a task that is already completed"); + + + declare + -- Create the task for this transaction + Keyboard : C974010_0.ATM_Keyboard_Task; + begin + + -- Ensure the task is already completed before calling + -- + while not Keyboard'terminated loop + delay ImpDef.Minimum_Task_Switch; + end loop; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; + + raise Transaction_Canceled; -- Should not be executed. + + then abort + + -- Since the triggering call is not queued the abortable part + -- should not be executed. + -- + Validate_Card (Card_Data); + + end select; + -- + -- The propagated exception is re-raised here. + + Perform_Transaction(Card_Data); -- Should not be reached. + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Tasking_Error => + -- This is the expected test path + TC_Tasking_Error_Handled := true; + when others => + Report.Failed ("Wrong exception raised: "); + end; + + + if not TC_Tasking_Error_Handled then + Report.Failed ("Tasking_Error not properly propagated"); + end if; + + Report.Result; + + exception + when Tasking_Error => + Report.Failed ("Tasking_Error propagated to wrong handler"); + Report.Result; + + + end C974010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974011.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,275 ---- + -- C974011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sequence of statements of the triggering alternative + -- of an asynchronous select statement is not executed if the triggering + -- statement is a task entry call and the entry is not accepted + -- before the abortable part completes. + -- Check that the call queued on the entry is cancelled + -- + -- TEST DESCRIPTION: + -- Declare a main procedure containing an asynchronous select with a task + -- entry call as triggering statement. Force the entry call to be + -- queued by having the task call a procedure, prior to the corresponding + -- accept statement, which simulates (with a delay) a routine waiting + -- for user input + -- + -- Once the call is known to be queued, complete the abortable part. + -- Check that the rendezvous (and thus the trigger) does not complete. + -- Then clear the barrier and check that the entry has been cancelled + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Nov 95 SAIC Eliminated shared global variable for ACVC 2.0.1 + -- + --! + + with ImpDef; + -- + package C974011_0 is -- Automated teller machine abstraction. + + + + type Key_Enum is (None, Cancel, Deposit, Withdraw); + + protected Key_PO is + procedure Set (K : Key_Enum); + function Value return Key_Enum; + private + Current : Key_Enum := None; + end Key_PO; + + + -- Flags for testing purposes + TC_Abortable_Part_Completed : Boolean := False; + TC_Rendezvous_Entered : Boolean := False; + TC_Delay_Time : constant duration := ImpDef.Switch_To_New_Task; + + + Count : Integer := 1234; -- Global to defeat optimization. + + + type Card_Number_Type is private; + type Card_PIN_Type is private; + type ATM_Card_Type is private; + + + Transaction_Canceled : exception; + + + task type ATM_Keyboard_Task is + entry Cancel_Pressed; + end ATM_Keyboard_Task; + + procedure Read_Card (Card : in out ATM_Card_Type); + + procedure Validate_Card (Card : in ATM_Card_Type); + + procedure Perform_Transaction (Card : in ATM_Card_Type); + + private + + type Card_Number_Type is range 1 .. 9999; + type Card_PIN_Type is range 100 .. 999; + + type ATM_Card_Type is record + Number : Card_Number_Type; + PIN : Card_PIN_Type; + end record; + + end C974011_0; + + + --==================================================================-- + + + with Report; + package body C974011_0 is + + protected body Key_PO is + procedure Set (K : Key_Enum) is + begin + Current := K; + end Set; + + function Value return Key_Enum is + begin + return Current; + end Value; + end Key_PO; + + + procedure Listen_For_Input (Key : out Key_Enum) is + begin + -- Model the situation where the user does not press cancel thus + -- allowing validation to complete + + delay TC_Delay_Time; -- Long enough to force queuing on + -- Keyboard.Cancel_Pressed. + + Key := Key_PO.Value; + + end Listen_For_Input; + + + + -- One of these gets created as "Keyboard" for each transaction + -- + task body ATM_Keyboard_Task is + Key_Pressed : Key_Enum; + begin + loop + -- Force entry calls + Listen_For_Input (Key_Pressed); -- to be queued, + + select + when (Key_Pressed = Cancel) => + accept Cancel_Pressed do + TC_Rendezvous_Entered := True; + end Cancel_Pressed; + + -- User has cancelled the transaction so we exit the + -- loop and allow the task to terminate + exit; + else + delay ImpDef.Switch_To_New_Task; + end select; + + end loop; + exception + when others => + Report.Failed ("Unexpected Exception in ATM_Keyboard_Task"); + end ATM_Keyboard_Task; + + + + procedure Read_Card (Card : in out ATM_Card_Type) is + begin + Card.Number := 9999; + Card.PIN := 111; + end Read_Card; + + + procedure Validate_Card (Card : in ATM_Card_Type) is + begin + Count := (Count + 1) mod Integer (Card.PIN); + + -- Simulate a validation activity which is longer than the time + -- taken in Listen_For_Input but not inordinately so. + delay TC_Delay_Time * 2; + + end Validate_Card; + + + procedure Perform_Transaction (Card : in ATM_Card_Type) is + begin + if TC_Rendezvous_Entered then + Report.Failed ("Triggering statement completed"); + end if; + if Count = 1234 then + -- Initial value is unchanged + Report.Failed ("Abortable part did not execute"); + end if; + if not TC_Abortable_Part_Completed then + Report.Failed ("Abortable part did not complete"); + end if; + end Perform_Transaction; + + + end C974011_0; + + + --==================================================================-- + + + with Report; + + with C974011_0; -- Automated teller machine abstraction. + use C974011_0; + + procedure C974011 is + + Card_Data : ATM_Card_Type; + + begin -- Main program. + + Report.Test ("C974011", "Asynchronous Select: Trigger is queued on a " & + "task entry and the abortable part " & + "completes first"); + + Read_Card (Card_Data); + + declare + -- Create the task for this transaction + Keyboard : C974011_0.ATM_Keyboard_Task; + begin + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + Keyboard.Cancel_Pressed; -- Entry call is initially queued, so + -- abortable part starts. + raise Transaction_Canceled; -- This would be executed if we + -- completed the rendezvous + then abort + + Validate_Card (Card_Data); + TC_Abortable_Part_Completed := true; + + end select; + + Perform_Transaction (Card_Data); + + + -- Now clear the entry barrier to allow the rendezvous to complete + -- if the triggering call has not been cancelled + Key_PO.Set (Cancel); + -- + delay TC_Delay_Time; -- to allow it all to take place + + if TC_Rendezvous_Entered then + Report.Failed ("Triggering Call was not cancelled"); + end if; + + abort Keyboard; -- clean up. (Note: the task will only exit the + -- loop and terminate if the call hanging on the + -- entry is executed.) + + exception + when Transaction_Canceled => + Report.Failed ("Triggering alternative sequence of statements " & + "executed"); + when Others => + Report.Failed ("Unexpected exception in the Main"); + end; + + Report.Result; + + end C974011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974012.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C974012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement is + -- aborted if it does not complete before the triggering statement + -- completes, where the triggering statement is a call on a protected + -- entry which is queued. + -- + -- TEST DESCRIPTION: + -- A fraction of in-line code is simulated. A voltage deficiency causes + -- the routine to seek an alternate best-cost route on an electrical grid + -- system. + -- + -- An asynchronous select is used with the triggering alternative being a + -- call to a protected entry with a barrier. The abortable part is a + -- routine simulating the lengthy alternate path negotiation. The entry + -- barrier would be cleared if the voltage deficiency is rectified before + -- the alternate can be found thus nullifying the need for the alternate. + -- + -- The test simulates a return to normal in the middle of the + -- negotiation. The barrier is cleared, the triggering alternative + -- completes first and the abortable part should be aborted. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with ImpDef; + + procedure C974012 is + + subtype Grid_Path is string(1..21); + subtype Deficiency is integer range 100..1_000; -- in MWh + + New_Path : Grid_Path; + Dummy_Deficiency : Deficiency := 520; + Path_Available : Boolean := false; + + TC_Terminate_Negotiation_Executed : Boolean := false; + TC_Trigger_Completed : Boolean := false; + TC_Negotiation_Completed : Boolean := false; + + protected Local_Deficit is + procedure Set_Good_Voltage; + procedure Bad_Voltage; + entry Terminate_Negotiation; + private + Good_Voltage : Boolean := false; -- barrier + end Local_Deficit; + + protected body Local_Deficit is + + procedure Set_Good_Voltage is + begin + Good_Voltage := true; + end Set_Good_Voltage; + + procedure Bad_Voltage is + begin + Good_Voltage := false; + end Bad_Voltage; + + -- Trigger is queued on this entry with barrier condition + entry Terminate_Negotiation when Good_Voltage is + begin + -- complete the triggering call thus terminating grid_path + -- negotiation. + null; --::: stub - signal main board + TC_Terminate_Negotiation_Executed := true; -- show path traversal + end Terminate_Negotiation; + + end Local_Deficit; + + + -- Routine to find the most cost effective grid path for this + -- particular deficiency at this particular time + -- + procedure Path_Negotiation (Requirement : in Deficiency; + Best_Path : out Grid_Path ) is + + Dummy_Path : Grid_Path := "NYC.425_NY.227_NH.132"; + Match : Deficiency := Report.Ident_Int (Requirement); + + begin + -- + null; --::: stub + -- + -- Simulate a lengthy path negotiation + for i in 1..5 loop + delay ImpDef.Minimum_Task_Switch; + -- Part of the way through the negotiation simulate some external + -- event returning the voltage to acceptable level + if i = 3 then + Local_Deficit.Set_Good_Voltage; -- clear the barrier + end if; + end loop; + + Best_Path := Dummy_Path; + TC_Negotiation_Completed := true; + + end Path_Negotiation; + + + + begin + + Report.Test ("C974012", "Asynchronous Select: Trigger is queued on a " & + "protected entry and completes before the " & + "abortable part"); + + -- ::::::::: Fragment of code + + Local_Deficit.Bad_Voltage; -- Set barrier condition + + -- For the given voltage deficiency start negotiating the best grid + -- path. If voltage returns to acceptable level cancel the negotiation + -- + select + -- Prepare to terminate the Path_Negotiation if voltage improves + Local_Deficit.Terminate_Negotiation; + TC_Trigger_Completed := true; + then abort + Path_Negotiation (Dummy_Deficiency, New_Path) ; + Path_Available := true; + end select; + -- ::::::::: + + if not TC_Terminate_Negotiation_Executed or else not + TC_Trigger_Completed then + Report.Failed ("Unexpected test path taken"); + end if; + + if Path_Available or else TC_Negotiation_Completed then + Report.Failed ("Abortable part was not aborted"); + end if; + Report.Result; + + end C974012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974013.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- C974013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the abortable part of an asynchronous select statement + -- is aborted if it does not complete before the triggering statement + -- completes, where the triggering statement is a delay_until + -- statement. + -- + -- Check that the sequence of statements of the triggering alternative + -- is executed after the abortable part is left. + -- + -- TEST DESCRIPTION: + -- Declare a task with an accept statement containing an asynchronous + -- select with a delay_until triggering statement. Parameterize + -- the accept statement with the amount of time to be added to the + -- current time to be used for the delay. Simulate a time-consuming + -- calculation by declaring a procedure containing an infinite loop. + -- Call this procedure in the abortable part. + -- + -- The delay will expire before the abortable part completes, at which + -- time the abortable part is aborted, and the sequence of statements + -- following the triggering statement is executed. + -- + -- Main test logic is identical to c974001 which uses simple delay + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Nov 95 SAIC Fixed problems for ACVC 2.0.1. + -- + --! + + with Report; + with ImpDef; + with Ada.Calendar; + + procedure C974013 is + + + --========================================================-- + + function "+" (Left : Ada.Calendar.Time; Right: Duration) + return Ada.Calendar.Time renames Ada.Calendar."+"; + + + Allotted_Time : constant Duration := ImpDef.Switch_To_New_Task; + Calculation_Canceled : exception; + + Count : Integer := 1234; + procedure Lengthy_Calculation is + begin + -- Simulate a non-converging calculation. + loop -- Infinite loop. + Count := (Count + 1) mod 10; + exit when not Report.Equal (Count, Count); -- Condition always false. + delay 0.0; -- abort completion point + end loop; + end Lengthy_Calculation; + + + --========================================================-- + + + task type Timed_Calculation is + entry Calculation (Time_Limit : in Duration); + end Timed_Calculation; + + + task body Timed_Calculation is + Delay_Time : Ada.Calendar.Time; + begin + loop + select + accept Calculation (Time_Limit : in Duration) do + + -- We have to construct an "until" time artificially + -- as we have no control over when the test will be run + -- + Delay_Time := Ada.Calendar.Clock + Time_Limit; + + -- -- + -- Asynchronous select is tested here -- + -- -- + + select + + delay until Delay_Time; -- Time not reached yet, so + -- Lengthy_Calculation starts. + + raise Calculation_Canceled; -- This is executed after + -- Lengthy_Calculation aborted. + + then abort + + Lengthy_Calculation; -- Delay expires before complete, + -- so this call is aborted. + -- Check that the whole of the abortable part is aborted, + -- not just the statement in the abortable part that was + -- executing at the time + Report.Failed ("Abortable part not aborted"); + + end select; + + Report.Failed ("Triggering alternative sequence of " & + "statements not executed"); + + exception -- New Ada 9x: handler within accept + when Calculation_Canceled => + if Count = 1234 then + Report.Failed ("Abortable part did not execute"); + end if; + end Calculation; + or + terminate; + end select; + end loop; + exception + when others => + Report.Failed ("Unexpected exception in Timed_Calculation task"); + end Timed_Calculation; + + + --========================================================-- + + + + begin -- Main program. + + Report.Test ("C974013", "Asynchronous Select: Trigger is delay_until " & + "which completes before abortable part"); + + declare + Timed : Timed_Calculation; -- Task. + begin + Timed.Calculation (Time_Limit => Allotted_Time); -- Asynchronous select + -- inside accept block. + exception + when Calculation_Canceled => + Report.Failed ("wrong exception handler used"); + end; + + Report.Result; + + end C974013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c974014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c974014.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- C974014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the triggering alternative of an asynchronous select + -- statement is a delay and the abortable part completes before the delay + -- expires then the delay is cancelled and the optional statements in the + -- triggering part are not performed. In particular, check the case of + -- the ATC in non-tasking code. + -- + -- TEST DESCRIPTION: + -- A fraction of in-line code is simulated. An asynchronous select + -- is used with a triggering delay of several minutes. The abortable + -- part, which is simulating a very lengthy, time consuming procedure + -- actually returns almost immediately thus ensuring that it completes + -- first. At the conclusion, if a substantial amount of time has passed + -- the delay is assumed not to have been cancelled. + -- (based on example in LRM 9.7.4) + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + with Report; + with Ada.Calendar; + + procedure C974014 is + + function "-" (Left, Right : Ada.Calendar.Time) + return Duration renames Ada.Calendar."-"; + + TC_Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock; + TC_Elapsed_Time : duration; + + Maximum_Allowable_Time : duration := 300.0; -- for Calculate_Gamma_Function + + begin + + Report.Test ("C974014", "ATC: When abortable part completes before " & + "a triggering delay, check that the delay " & + "is cancelled & optional statements " & + "are not performed"); + + declare -- encapsulate test code + + type Gamma_Index is digits 5; -- float precision + + -- (These two fields are assumed filled elsewhere) + Input_Field, Result_of_Beta : Gamma_Index; + + -- Notify and take corrective action in the event that + -- the procedure Calculate_Gamma_Function does not converge. + -- + procedure Non_Convergent is + begin + null; -- stub + + Report.Failed ("Optional statements in triggering part" & + " were performed"); + end Non_Convergent; + + + -- This is a very time consuming calculation. It is possible, + -- that, with certain parameters, it will not converge. If it + -- runs for more than Maximum_Allowable_Time it is considered + -- not to be convergent and should be aborted. + -- + Procedure Calculate_Gamma_Function (X, Y : Gamma_Index) is + begin + null; -- Stub + -- + end Calculate_Gamma_Function; + + begin -- declare + + -- ..... Isolated segment of inline code + + -- Now Print Gamma Function (abort and display if not convergent) + -- + select + delay Maximum_Allowable_Time; -- for Calculate_Gamma_Function + Non_Convergent; -- Display error and flag result as failed + + then abort + Calculate_Gamma_Function (Input_Field, Result_of_Beta); + end select; + + -- ..... End of Isolated segment of inline code + + end; -- declare + + TC_Elapsed_Time := Ada.Calendar.Clock - TC_Start_Time; + + -- Note: We are not checking for "cancellation within a reasonable time", + -- we are checking for cancellation/non-cancellation of the delay. We + -- use a number which, if exceeded, means that the delay was not + -- cancelled and has proceeded to full term. + -- + if ( TC_Elapsed_Time > Maximum_Allowable_Time/2 ) then + -- Test time exceeds a reasonable value. + Report.Failed ("Triggering delay statement was not cancelled"); + end if; + + + Report.Result; + + end C974014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,303 ---- + -- C980001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when a construct is aborted the execution of an Initialize + -- procedure as the last step of the default initialization of a + -- controlled object is abort-deferred. + -- + -- Check that when a construct is aborted the execution of a Finalize + -- procedure as part of the finalization of a controlled object is + -- abort-deferred. + -- + -- Check that an assignment operation to an object with a controlled + -- part is an abort-deferred operation. + -- + -- TEST DESCRIPTION: + -- The controlled operations which are being tested call a subprogram + -- which guarantees that the enclosing operation becomes aborted. + -- + -- Each object is created with a unique value to prevent optimizations + -- due to the values being the same. + -- + -- Two protected objects are utilized to warrant that the operations + -- are delayed in their execution until such time that the abort is + -- processed. The object Hold_Up is used to hold the targeted + -- operation in execution, the object Progress is used to communicate + -- to the driver software that progress is indeed being made. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 SAIC Initial version + -- 01 MAY 96 SAIC Revised for 2.1 + -- 11 DEC 96 SAIC Final revision for 2.1 + -- 02 DEC 97 EDS Remove 2 calls to C980001_0.Hold_Up.Lock + --! + + ---------------------------------------------------------------- C980001_0 + + with Impdef; + with Ada.Finalization; + package C980001_0 is + + A_Little_While : constant Duration := Impdef.Switch_To_New_Task * 2.0; + Enough_Time_For_The_Controlled_Operation_To_Happen : constant Duration + := Impdef.Switch_To_New_Task * 4.0; + + function TC_Unique return Integer; + + type Sticks_In_Initialize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Initialize( AV: in out Sticks_In_Initialize ); + + type Sticks_In_Adjust is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Adjust ( AV: in out Sticks_In_Adjust ); + + type Sticks_In_Finalize is new Ada.Finalization.Controlled with record + Item: Integer := TC_Unique; + end record; + procedure Finalize ( AV: in out Sticks_In_Finalize ); + + Initialize_Called : Boolean := False; + Adjust_Called : Boolean := False; + Finalize_Called : Boolean := False; + + protected type Sticker is + entry Lock; + procedure Unlock; + function Is_Locked return Boolean; + private + Locked : Boolean := False; + end Sticker; + + Hold_Up : Sticker; + Progress : Sticker; + + procedure Fail_And_Clear( Message : String ); + + + end C980001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body C980001_0 is + + TC_Master_Value : Integer := 0; + + + function TC_Unique return Integer is -- make all values unique. + begin + TC_Master_Value := TC_Master_Value +1; + return TC_Master_Value; + end TC_Unique; + + protected body Sticker is + + entry Lock when not Locked is + begin + Locked := True; + end Lock; + + procedure Unlock is + begin + Locked := False; + end Unlock; + + function Is_Locked return Boolean is + begin + return Locked; + end Is_Locked; + + end Sticker; + + procedure Initialize( AV: in out Sticks_In_Initialize ) is + begin + TCTouch.Touch('I'); -------------------------------------------------- I + Hold_Up.Unlock; -- cause the select to abort + Initialize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('i'); -------------------------------------------------- i + Progress.Unlock; -- allows Wait_Your_Turn to continue + end Initialize; + + procedure Adjust ( AV: in out Sticks_In_Adjust ) is + begin + TCTouch.Touch('A'); -------------------------------------------------- A + Hold_Up.Unlock; -- cause the select to abort + Adjust_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('a'); -------------------------------------------------- a + Progress.Unlock; + end Adjust; + + procedure Finalize ( AV: in out Sticks_In_Finalize ) is + begin + TCTouch.Touch('F'); -------------------------------------------------- F + Hold_Up.Unlock; -- cause the select to abort + Finalize_Called := True; + AV.Item := TC_Unique; + TCTouch.Touch('f'); -------------------------------------------------- f + Progress.Unlock; + end Finalize; + + procedure Fail_And_Clear( Message : String ) is + begin + Report.Failed(Message); + Hold_Up.Unlock; + Progress.Unlock; + end Fail_And_Clear; + + end C980001_0; + + --------------------------------------------------------------------------- + + with Report; + with TCTouch; + with Impdef; + with C980001_0; + procedure C980001 is + + procedure Check_Initialize_Conditions is + begin + if not C980001_0.Initialize_Called then + C980001_0.Fail_And_Clear("Initialize did not correctly complete"); + end if; + TCTouch.Validate("Ii", "Initialization Sequence"); + end Check_Initialize_Conditions; + + procedure Check_Adjust_Conditions is + begin + if not C980001_0.Adjust_Called then + C980001_0.Fail_And_Clear("Adjust did not correctly complete"); + end if; + TCTouch.Validate("Aa", "Adjust Sequence"); + end Check_Adjust_Conditions; + + procedure Check_Finalize_Conditions is + begin + if not C980001_0.Finalize_Called then + C980001_0.Fail_And_Clear("Finalize did not correctly complete"); + end if; + TCTouch.Validate("FfFfFf", "Finalization Sequence", + Order_Meaningful => False); + end Check_Finalize_Conditions; + + procedure Wait_Your_Turn is + Overrun : Natural := 0; + begin + while C980001_0.Progress.Is_Locked loop -- and waits + delay C980001_0.A_Little_While; + Overrun := Overrun +1; + if Overrun > 10 then + C980001_0.Fail_And_Clear("Overrun expired lock"); + end if; + end loop; + end Wait_Your_Turn; + + begin -- Main test procedure. + + Report.Test ("C980001", "Check the interaction between asynchronous " & + "transfer of control and controlled types" ); + + C980001_0.Progress.Lock; + C980001_0.Hold_Up.Lock; + + select + C980001_0.Hold_Up.Lock; -- Init will unlock + + Wait_Your_Turn; -- abortable part is stuck in Initialize + Check_Initialize_Conditions; + + then abort + declare + Object : C980001_0.Sticks_In_Initialize; + begin + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object.Item ) /= Object.Item then + Report.Failed("Optimization foil caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Initialize test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Adjust will unlock + + Wait_Your_Turn; -- abortable part is stuck in Adjust + Check_Adjust_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Adjust; + Object2 : C980001_0.Sticks_In_Adjust; + begin + Object1 := Object2; + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 1 caused failure"); + end if; + C980001_0.Fail_And_Clear("Adjust test executed beyond expected region"); + end; + end select; + + C980001_0.Progress.Lock; + + select + C980001_0.Hold_Up.Lock; -- Finalize will unlock + + Wait_Your_Turn; -- abortable part is stuck in Finalize + Check_Finalize_Conditions; + + then abort + declare + Object1 : C980001_0.Sticks_In_Finalize; + Object2 : C980001_0.Sticks_In_Finalize; + begin + Object1 := Object2; -- cause a finalize call + delay Impdef.Minimum_Task_Switch; + if Report.Ident_Int( Object2.Item ) + /= Report.Ident_Int( Object1.Item ) then + Report.Failed("Optimization foil 2 caused failure"); + end if; + C980001_0.Fail_And_Clear( + "Finalize test executed beyond expected region"); + end; + end select; + + Report.Result; + + exception + when others => C980001_0.Fail_And_Clear("Exception in main"); + Report.Result; + end C980001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980002.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- C980002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that aborts are deferred during protected actions. + -- + -- TEST DESCRIPTION: + -- This test uses an asynchronous transfer of control to attempt + -- to abort a protected operation. The protected operation + -- includes several requeues to check that the requeue does not + -- allow the abort to occur. + -- + -- + -- CHANGE HISTORY: + -- 30 OCT 95 SAIC ACVC 2.1 + -- + --! + + with Report; + procedure C980002 is + + Max_Checkpoints : constant := 7; + type Checkpoint_ID is range 1..Max_Checkpoints; + type Points_Array is array (Checkpoint_ID) of Boolean; + begin + Report.Test ("C980002", + "Check that aborts are deferred during a protected action" & + " including requeues"); + + declare -- test encapsulation + + protected Checkpoint is + procedure Got_Here (Id : Checkpoint_ID); + function Results return Points_Array; + private + Reached_Points : Points_Array := (others => False); + end Checkpoint; + + protected body Checkpoint is + procedure Got_Here (Id : Checkpoint_ID) is + begin + Reached_Points (Id) := True; + end Got_Here; + + function Results return Points_Array is + begin + return Reached_Points; + end Results; + end Checkpoint; + + + protected Start_Here is + entry AST_Waits_Here; + entry Start_PO; + private + Open : Boolean := False; + entry First_Stop; + end Start_Here; + + protected Middle_PO is + entry Stop_1; + entry Stop_2; + end Middle_PO; + + protected Final_PO is + entry Final_Stop; + end Final_PO; + + + protected body Start_Here is + entry AST_Waits_Here when Open is + begin + null; + end AST_Waits_Here; + + entry Start_PO when True is + begin + Open := True; + Checkpoint.Got_Here (1); + requeue First_Stop; + end Start_PO; + + -- make sure the AST has been accepted before continuing + entry First_Stop when AST_Waits_Here'Count = 0 is + begin + Checkpoint.Got_Here (2); + requeue Middle_PO.Stop_1; + end First_Stop; + end Start_Here; + + protected body Middle_PO is + entry Stop_1 when True is + begin + Checkpoint.Got_Here (3); + requeue Stop_2; + end Stop_1; + + entry Stop_2 when True is + begin + Checkpoint.Got_Here (4); + requeue Final_PO.Final_Stop; + end Stop_2; + end Middle_PO; + + protected body Final_PO is + entry Final_Stop when True is + begin + Checkpoint.Got_Here (5); + end Final_Stop; + end Final_PO; + + + begin -- test encapsulation + select + Start_Here.AST_Waits_Here; + Checkpoint.Got_Here (6); + then abort + Start_Here.Start_PO; + delay 0.0; -- abort completion point + Checkpoint.Got_Here (7); + end select; + + Check_The_Results: declare + Chk : constant Points_Array := Checkpoint.Results; + Expected : constant Points_Array := (1..6 => True, + 7 => False); + begin + for I in Checkpoint_ID loop + if Chk (I) /= Expected (I) then + Report.Failed ("checkpoint error" & + Checkpoint_ID'Image (I) & + " actual is " & + Boolean'Image (Chk(I))); + end if; + end loop; + end Check_The_Results; + exception + when others => + Report.Failed ("unexpected exception"); + end; -- test encapsulation + + Report.Result; + end C980002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c980003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c980003.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,294 ---- + -- C980003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- TEST OBJECTIVE: + -- Check that aborts are deferred during the execution of an + -- Initialize procedure (as the last step of the default + -- initialization of a controlled object), during the execution + -- of a Finalize procedure (as part of the finalization of a + -- controlled object), and during an assignment operation to an + -- object with a controlled part. + -- + -- TEST DESCRIPTION: + -- A controlled type is created with Initialize, Adjust, and + -- Finalize operations. These operations note in a protected + -- object when the operation starts and completes. This change + -- in state of the protected object will open the barrier for + -- the entry in the protected object. + -- The test contains declarations of objects of the controlled + -- type. An asynchronous select is used to attempt to abort + -- the operations on the controlled type. The asynchronous select + -- makes use of the state change to the protected object to + -- trigger the abort. + -- + -- + -- CHANGE HISTORY: + -- 11 Jan 96 SAIC Initial Release for 2.1 + -- 5 May 96 SAIC Incorporated Reviewer comments. + -- 10 Oct 96 SAIC Addressed issue where assignment statement + -- can be 2 assignment operations. + -- + --! + + with Ada.Finalization; + package C980003_0 is + Verbose : constant Boolean := False; + + -- the following flag is set true whenever the + -- Initialize operation is called. + Init_Occurred : Boolean; + + type Is_Controlled is new Ada.Finalization.Controlled with + record + Id : Integer; + end record; + + procedure Initialize (Object : in out Is_Controlled); + procedure Finalize (Object : in out Is_Controlled); + procedure Adjust (Object : in out Is_Controlled); + + type States is (Unknown, + Start_Init, Finished_Init, + Start_Adjust, Finished_Adjust, + Start_Final, Finished_Final); + + protected State_Manager is + procedure Reset; + procedure Set (New_State : States); + function Current return States; + entry Wait_For_Change; + private + Current_State : States := Unknown; + Changed : Boolean := False; + end State_Manager; + + end C980003_0; + + + with Report; + with ImpDef; + package body C980003_0 is + protected body State_Manager is + procedure Reset is + begin + Current_State := Unknown; + Changed := False; + end Reset; + + procedure Set (New_State : States) is + begin + Changed := True; + Current_State := New_State; + end Set; + + function Current return States is + begin + return Current_State; + end Current; + + entry Wait_For_Change when Changed is + begin + Changed := False; + end Wait_For_Change; + end State_Manager; + + procedure Initialize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting initialize"); + end if; + State_Manager.Set (Start_Init); + if Verbose then + Report.Comment ("in initialize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Init); + if Verbose then + Report.Comment ("finished initialize"); + end if; + Init_Occurred := True; + end Initialize; + + procedure Finalize (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting finalize"); + end if; + State_Manager.Set (Start_Final); + if Verbose then + Report.Comment ("in finalize"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Final); + if Verbose then + Report.Comment ("finished finalize"); + end if; + end Finalize; + + procedure Adjust (Object : in out Is_Controlled) is + begin + if Verbose then + Report.Comment ("starting adjust"); + end if; + State_Manager.Set (Start_Adjust); + if Verbose then + Report.Comment ("in adjust"); + end if; + delay ImpDef.Switch_To_New_Task; -- tempting place for abort + State_Manager.Set (Finished_Adjust); + if Verbose then + Report.Comment ("finished adjust"); + end if; + end Adjust; + end C980003_0; + + + with Report; + with ImpDef; + with C980003_0; use C980003_0; + with Ada.Unchecked_Deallocation; + procedure C980003 is + + procedure Check_State (Should_Be : States; + Msg : String) is + Cur : States := State_Manager.Current; + begin + if Cur /= Should_Be then + Report.Failed (Msg); + Report.Comment ("expected: " & States'Image (Should_Be) & + " found: " & States'Image (Cur)); + elsif Verbose then + Report.Comment ("passed: " & Msg); + end if; + end Check_State; + + begin + + Report.Test ("C980003", "Check that aborts are deferred during" & + " initialization, finalization, and assignment" & + " operations on controlled objects"); + + Check_State (Unknown, "initial condition"); + + -- check that initialization and finalization take place + Init_Occurred := False; + select + State_Manager.Wait_For_Change; + then abort + declare + My_Controlled_Obj : Is_Controlled; + begin + delay 0.0; -- abort completion point + Report.Failed ("state change did not occur"); + end; + end select; + if not Init_Occurred then + Report.Failed ("Initialize did not complete"); + end if; + Check_State (Finished_Final, "init/final for declared item"); + + -- check adjust + State_Manager.Reset; + declare + Source, Dest : Is_Controlled; + begin + Check_State (Finished_Init, "adjust initial state"); + Source.Id := 3; + Dest.Id := 4; + State_Manager.Reset; -- so we will wait for change + select + State_Manager.Wait_For_Change; + then abort + Dest := Source; + end select; + + -- there are two implementation methods for the + -- assignment statement: + -- 1. no temporary was used in the assignment statement + -- thus the entire + -- assignment statement is abort deferred. + -- 2. a temporary was used in the assignment statement so + -- there are two assignment operations. An abort may + -- occur between the assignment operations + -- Various optimizations are allowed by 7.6 that can affect + -- how many times Adjust and Finalize are called. + -- Depending upon the implementation, the state can be either + -- Finished_Adjust or Finished_Finalize. If it is any other + -- state then the abort took place at the wrong time. + + case State_Manager.Current is + when Finished_Adjust => + if Verbose then + Report.Comment ("assignment aborted after adjust"); + end if; + when Finished_Final => + if Verbose then + Report.Comment ("assignment aborted after finalize"); + end if; + when Start_Adjust => + Report.Failed ("assignment aborted in adjust"); + when Start_Final => + Report.Failed ("assignment aborted in finalize"); + when Start_Init => + Report.Failed ("assignment aborted in initialize"); + when Finished_Init => + Report.Failed ("assignment aborted after initialize"); + when Unknown => + Report.Failed ("assignment aborted in unknown state"); + end case; + + + if Dest.Id /= 3 then + if Verbose then + Report.Comment ("assignment not performed"); + end if; + end if; + end; + + + -- check dynamically allocated objects + State_Manager.Reset; + declare + type Pointer_Type is access Is_Controlled; + procedure Free is new Ada.Unchecked_Deallocation ( + Is_Controlled, Pointer_Type); + Ptr : Pointer_Type; + begin + -- make sure initialize is done when object is allocated + Ptr := new Is_Controlled; + Check_State (Finished_Init, "init when item allocated"); + -- now try aborting the finalize + State_Manager.Reset; + select + State_Manager.Wait_For_Change; + then abort + Free (Ptr); + end select; + Check_State (Finished_Final, "finalization in dealloc"); + end; + + Report.Result; + + end C980003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c99004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c99004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c99004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c99004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + -- C99004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF 'TERMINATED AND 'CALLABLE CAN BE A + -- FUNCTION CALL RETURNING AN OBJECT HAVING A TASK TYPE. + + -- NOTE: SEE TEST C38202A FOR CHECKS INVOLVING PREFIXES WHICH ARE + -- ACCESS TYPES DENOTING TASK TYPES OR WHICH ARE FUNCTIONS + -- RETURNING ACCESS TYPES DENOTING TASK TYPES. + + -- HISTORY: + -- RJW 09/16/86 CREATED ORIGINAL TEST. + -- DHH 10/15/87 CORRECTED HEADER COMMENTS. + + with Impdef; + WITH REPORT; USE REPORT; + PROCEDURE C99004A IS + + TYPE ENUM IS (A, B, C, D); + + EARRAY : ARRAY (ENUM) OF STRING (1 .. 17) := + (A => "BEFORE ACTIVATION", + B => "DURING ACTIVATION", + C => "DURING EXECUTION ", + D => "AFTER TERMINATION" ); + + FUNCTION CHECK (S : STRING; CALL, B1, TERM, B2 : BOOLEAN; + E : ENUM) RETURN BOOLEAN IS + BEGIN + IF CALL /= B1 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'CALLABLE " & + EARRAY (E) & " OF TASK" ); + END IF; + + IF TERM /= B2 THEN + FAILED ( "INCORRECT VALUE FOR " & S & "'TERMINATED " & + EARRAY (E) & " OF TASK" ); + END IF; + + RETURN IDENT_BOOL (TRUE); + END CHECK; + + + BEGIN + TEST ( "C99004A", "CHECK THAT THE PREFIX OF 'TERMINATED AND " & + "'CALLABLE CAN BE A FUNCTION CALL RETURNING " & + "AN OBJECT HAVING A TASK TYPE" ); + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + PACKAGE PKG1 IS + T1 : TT; + END PKG1; + + FUNCTION F RETURN TT IS + BEGIN + RETURN PKG1.T1; + END F; + + PACKAGE PKG2 IS + A1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, A); + END PKG2; + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B1 : BOOLEAN := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, B); + C1 : BOOLEAN; + BEGIN + C1 := CHECK ("F", F'CALLABLE, TRUE, + F'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + PACKAGE BODY PKG1 IS + BEGIN + NULL; + END; + + TASK BODY MAIN_TASK IS + D1 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT PKG1.T1; + DELAY 5.0 * Impdef.One_Second; + D1 := CHECK ("F", F'CALLABLE, FALSE, + F'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + DECLARE + + TASK TYPE TT IS + ENTRY E; + END TT; + + T2 : TT; + + A2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, A); + + TASK MAIN_TASK IS + ENTRY E (INTEGER RANGE 1 .. 2); + END MAIN_TASK; + + TASK BODY TT IS + B2 : BOOLEAN := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, B); + C2 : BOOLEAN; + BEGIN + C2 := CHECK ("T2", T2'CALLABLE, TRUE, + T2'TERMINATED, FALSE, C); + MAIN_TASK.E (1); + MAIN_TASK.E (2); + END TT; + + TASK BODY MAIN_TASK IS + D2 : BOOLEAN; + BEGIN + ACCEPT E (1); + ABORT T2; + DELAY 5.0 * Impdef.One_Second; + D2 := CHECK ("T2", T2'CALLABLE, FALSE, + T2'TERMINATED, TRUE, D); + END MAIN_TASK; + + BEGIN + NULL; + END; + + RESULT; + END C99004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c99005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c99005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c99005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c99005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- C99005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE CORRECT VALUE. + + -- HISTORY: + -- DHH 03/24/88 CREATED ORIGINAL TEST. + + with Impdef; + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C99005A IS + + BEGIN + + TEST("C99005A", "CHECK THAT THE ATTRIBUTE 'COUNT RETURNS THE " & + "CORRECT VALUE"); + + DECLARE + TASK A IS + END A; + + TASK B IS + END B; + + TASK C IS + END C; + + TASK D IS + END D; + + TASK E IS + END E; + + TASK F IS + END F; + + TASK G IS + END G; + + TASK H IS + END H; + + TASK I IS + END I; + + TASK J IS + END J; + + TASK T IS + ENTRY WAIT; + END T; + + TASK CHOICE IS + ENTRY RETURN_CALL; + ENTRY E2; + ENTRY E1; + END CHOICE; + + TASK BODY A IS + BEGIN + CHOICE.E1; + END A; + + TASK BODY B IS + BEGIN + CHOICE.E1; + END B; + + TASK BODY C IS + BEGIN + CHOICE.E1; + END C; + + TASK BODY D IS + BEGIN + CHOICE.E1; + END D; + + TASK BODY E IS + BEGIN + CHOICE.E1; + END E; + + TASK BODY F IS + BEGIN + CHOICE.E2; + END F; + + TASK BODY G IS + BEGIN + CHOICE.E2; + END G; + + TASK BODY H IS + BEGIN + CHOICE.E2; + END H; + + TASK BODY I IS + BEGIN + CHOICE.E2; + END I; + + TASK BODY J IS + BEGIN + CHOICE.E2; + END J; + + TASK BODY T IS + BEGIN + LOOP + SELECT + ACCEPT WAIT DO + DELAY 1.0 * Impdef.One_Second; + END WAIT; + CHOICE.RETURN_CALL; + OR + TERMINATE; + END SELECT; + END LOOP; + END T; + + TASK BODY CHOICE IS + BEGIN + WHILE E1'COUNT + E2'COUNT < 10 LOOP + T.WAIT; + ACCEPT RETURN_CALL; + END LOOP; + + FOR I IN REVERSE 1 ..10 LOOP + SELECT + ACCEPT E2 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E2; + OR + ACCEPT E1 DO + IF (E2'COUNT + E1'COUNT + 1) /= I THEN + FAILED("'COUNT NOT RETURNING " & + "CORRECT VALUE FOR LOOP" & + INTEGER'IMAGE(I) & "VALUE " & + INTEGER'IMAGE((E2'COUNT + + E1'COUNT + 1))); + END IF; + END E1; + END SELECT; + END LOOP; + END CHOICE; + + BEGIN + NULL; + END; + + RESULT; + END C99005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a003a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- C9A003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ABORTING A TERMINATED TASK DOES NOT CAUSE EXCEPTIONS. + + + -- RM 5/21/82 + -- SPS 11/21/82 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + + with Impdef; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C9A003A IS + + -- THE TASK WILL HAVE HIGHER PRIORITY ( PRIORITY'LAST ) + + BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A003A", "CHECK THAT ABORTING A TERMINATED TASK" & + " DOES NOT CAUSE EXCEPTIONS" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + DELAY 20.0 * Impdef.One_Second; + END IF; + + IF NOT T_OBJECT1'TERMINATED THEN + COMMENT( "TASK NOT YET TERMINATED (AFTER 20 S.)" ); + END IF; + + + BEGIN + ABORT T_OBJECT1 ; + EXCEPTION + + WHEN OTHERS => + FAILED( "EXCEPTION RAISED (WHEN ABORTING A" & + " TERMINATED TASK)" ); + + END ; + + + END ; + + + ------------------------------------------------------------------- + + + + RESULT; + + + END C9A003A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- C9A004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A TASK IS ABORTED BEFORE BEING ACTIVATED, THE TASK IS + -- TERMINATED. + + + -- RM 5/21/82 + -- SPS 11/21/82 + -- JBG 6/3/85 + -- PWN 09/11/94 REMOVED PRAGMA PRIORITY FOR ADA 9X + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C9A004A IS + + BEGIN + + + ------------------------------------------------------------------- + + + TEST ("C9A004A", "CHECK THAT IF A TASK IS ABORTED" & + " BEFORE BEING ACTIVATED," & + " THE TASK IS TERMINATED" ); + + + DECLARE + + + TASK TYPE T_TYPE IS + + + ENTRY E ; + + END T_TYPE ; + + + T_OBJECT1 : T_TYPE ; + + + TASK BODY T_TYPE IS + BUSY : BOOLEAN := FALSE ; + BEGIN + + NULL; + + END T_TYPE ; + + + PACKAGE P IS + X : INTEGER := 0 ; + END P ; + + + PACKAGE BODY P IS + BEGIN + + IF T_OBJECT1'TERMINATED OR + NOT T_OBJECT1'CALLABLE + THEN + FAILED( "WRONG VALUES FOR ATTRIBUTES" ); + END IF; + + ABORT T_OBJECT1 ; -- ELABORATED BUT NOT YET ACTIVATED. + + END P ; + + + BEGIN + + + IF NOT T_OBJECT1'TERMINATED THEN + FAILED( "ABORTED (BEFORE ACTIVATION) TASK" & + " NOT TERMINATED" ); + END IF; + + EXCEPTION + + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED"); + + END; + + RESULT; + + END C9A004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a007a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,293 ---- + -- C9A007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK MAY ABORT A TASK IT DEPENDS ON. + + + -- RM 5/26/82 + -- RM 7/02/82 + -- SPS 11/21/82 + -- JBG 2/27/84 + -- JBG 3/8/84 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + -- EDS 08/04/98 ENSURE THAT ABORTED TASKS HAVE TIME TO EFFECT THEIR ABORTIONS. + + WITH IMPDEF; + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE C9A007A IS + + TASK_NOT_ABORTED : BOOLEAN := FALSE; + TEST_VALID : BOOLEAN := TRUE ; + + BEGIN + + + ------------------------------------------------------------------- + + + TEST ( "C9A007A" , "CHECK THAT A TASK MAY ABORT A TASK" & + " IT DEPENDS ON" ); + + + DECLARE + + + TASK REGISTER IS + + + ENTRY BIRTHS_AND_DEATHS; + + ENTRY SYNC1; + ENTRY SYNC2; + + + END REGISTER; + + + TASK BODY REGISTER IS + + + TASK TYPE SECONDARY IS + + + ENTRY WAIT_INDEFINITELY; + + END SECONDARY; + + + TASK TYPE T_TYPE1 IS + + + ENTRY E; + + END T_TYPE1; + + + TASK TYPE T_TYPE2 IS + + + ENTRY E; + + END T_TYPE2; + + + T_OBJECT1 : T_TYPE1; + T_OBJECT2 : T_TYPE2; + + + TASK BODY SECONDARY IS + BEGIN + SYNC1; + ABORT T_OBJECT1; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END SECONDARY; + + + TASK BODY T_TYPE1 IS + + TYPE ACCESS_TO_TASK IS ACCESS SECONDARY; + + BEGIN + + + DECLARE + DEPENDENT_BY_ACCESS : ACCESS_TO_TASK := + NEW SECONDARY ; + BEGIN + NULL; + END; + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE1; + + + TASK BODY T_TYPE2 IS + + TASK INNER_TASK IS + + + ENTRY WAIT_INDEFINITELY; + + END INNER_TASK; + + TASK BODY INNER_TASK IS + BEGIN + SYNC2; + ABORT T_OBJECT2; + DELAY 0.0; + TASK_NOT_ABORTED := TRUE; + END INNER_TASK; + + BEGIN + + + BIRTHS_AND_DEATHS; + -- DURING THIS SUSPENSION + -- MOST OF THE TASKS + -- ARE ABORTED (FIRST + -- TASK #1 -- T_OBJECT1 -- + -- THEN #2 ). + + + TASK_NOT_ABORTED := TRUE; + + + END T_TYPE2; + + + BEGIN + + DECLARE + OLD_COUNT : INTEGER := 0; + BEGIN + + + FOR I IN 1..5 LOOP + EXIT WHEN BIRTHS_AND_DEATHS'COUNT = 2; + DELAY 10.0 * Impdef.One_Second; + END LOOP; + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + IF OLD_COUNT = 2 THEN + + ACCEPT SYNC1; -- ALLOWING ABORT#1 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #1 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT1.E; + FAILED( "T_OBJECT1.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 1"); + + END; + + IF T_OBJECT1'CALLABLE THEN + FAILED( "T_OBJECT1'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#1 NOT REMOVED FROM QUEUE" ); + END IF; + + + OLD_COUNT := BIRTHS_AND_DEATHS'COUNT; + + + ACCEPT SYNC2; -- ALLOWING ABORT#2 + + DELAY IMPDEF.CLEAR_READY_QUEUE; + + -- CHECK THAT #2 WAS ABORTED - 3 WAYS: + + BEGIN + T_OBJECT2.E; + FAILED( "T_OBJECT2.E DID NOT RAISE" & + " TASKING_ERROR" ); + EXCEPTION + + WHEN TASKING_ERROR => + NULL; + + WHEN OTHERS => + FAILED("OTHER EXCEPTION RAISED - 2"); + + END; + + IF T_OBJECT2'CALLABLE THEN + FAILED( "T_OBJECT2'CALLABLE = TRUE" ); + END IF; + + IF OLD_COUNT - BIRTHS_AND_DEATHS'COUNT /= 1 + THEN + FAILED( "TASK#2 NOT REMOVED FROM QUEUE" ); + END IF; + + + IF BIRTHS_AND_DEATHS'COUNT /= 0 THEN + FAILED( "SOME TASKS STILL QUEUED" ); + END IF; + + + ELSE + + COMMENT( "LINEUP NOT COMPLETE (AFTER 50 S.)" ); + TEST_VALID := FALSE; + + END IF; + + + END; + + + WHILE BIRTHS_AND_DEATHS'COUNT > 0 LOOP + ACCEPT BIRTHS_AND_DEATHS; + END LOOP; + + + END REGISTER; + + + BEGIN + + NULL; + + END; + + + ------------------------------------------------------------------- + + + IF TEST_VALID AND TASK_NOT_ABORTED THEN + FAILED( "SOME TASKS NOT ABORTED" ); + END IF; + + + RESULT; + + + END C9A007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- C9A009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- TEST ABORT DURING RENDEZVOUS + + -- CALLING TASK IN RENDEVOUS IS NAMED IN ABORT STATEMENT. + + -- JEAN-PIERRE ROSEN 09 MARCH 1984 + -- JBG 6/1/84 + -- JWC 6/28/85 RENAMED FROM C9A009D-B.ADA + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C9A009A IS + + BEGIN + + TEST("C9A009A", "CALLING TASK IS ABORTED DIRECTLY"); + + DECLARE + -- T1 CALLS T2, WHICH ABORTS T1 WHILE IN RENDEVOUS + + T2_CONTINUED : BOOLEAN := FALSE; + + TASK CONTINUED IS + ENTRY GET (T2_CONTINUED : OUT BOOLEAN); + ENTRY PUT (T2_CONTINUED : IN BOOLEAN); + END CONTINUED; + + TASK BODY CONTINUED IS + CONTINUED : BOOLEAN := FALSE; + BEGIN + LOOP + SELECT + ACCEPT GET (T2_CONTINUED : OUT BOOLEAN) DO + T2_CONTINUED := CONTINUED; + END GET; + OR + ACCEPT PUT (T2_CONTINUED : IN BOOLEAN) DO + CONTINUED := T2_CONTINUED; + END PUT; + OR + TERMINATE; + END SELECT; + END LOOP; + END CONTINUED; + + BEGIN -- THIS BLOCK WILL MAKE SURE T2 IS TERMINATED, AND SO, + -- T2_CONTINUED IS ASSIGNED A VALUE IF T2 CONTINUES + -- EXECUTION CORRECTLY. + + DECLARE + + TASK T1; + + TASK T2 IS + ENTRY E1; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED ("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ABORT T1; + ABORT T1; -- WHY NOT? + IF T1'TERMINATED THEN + FAILED ("T1 PREMATURELY TERMINATED"); + END IF; + END E1; + CONTINUED.PUT (T2_CONTINUED => TRUE); + END T2; + BEGIN + NULL; + END; + -- T2 NOW TERMINATED + CONTINUED.GET (T2_CONTINUED); + IF NOT T2_CONTINUED THEN + FAILED ("WHEN CALLER WAS ABORTED IN RENDEVOUS, CALLED " & + "TASK DID NOT CONTINUE"); + END IF; + END; + + RESULT; + + END C9A009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009c.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C9A009C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- TEST ABORT DURING RENDEZVOUS + + -- THE CALLING TASK IN THE RENDEVOUS IS DEPENDENT ON THE ABORTED TASK, + -- SO THE DEPENDENT TASK IS INDIRECTLY ABORTED WHILE IN A RENDEVOUS; + -- NEITHER THE CALLING TASK NOR ITS MASTER CAN BE TERMINATED WHILE THE + -- RENDEVOUS CONTINUES. + + -- JEAN-PIERRE ROSEN 09 MARCH 1984 + -- JBG 6/1/84 + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C9A009C IS + + BEGIN + + TEST("C9A009C", "DEPENDENT TASK IN RENDEVOUS WHEN MASTER IS " & + "ABORTED"); + + DECLARE + -- T2 CONTAINS DEPENDENT TASK T3 WHICH CALLS T1. + -- T1 ABORTS T2 WHILE IN RENDEVOUS WITH T3. + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + + TASK T2; + + TASK BODY T2 IS + TASK T3; + TASK BODY T3 IS + BEGIN + T1.E1; + FAILED ("T3 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T3"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T3"); + END; + BEGIN -- T3 ACTIVATED NOW + NULL; + END T2; + + BEGIN -- T1 + ACCEPT E1 DO + ABORT T2; + ABORT T2; + ABORT T2; -- WHY NOT? + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED PREMATURELY"); + END IF; + END E1; + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1 BECAUSE CALLING TASK "& + "WAS ABORTED"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION - T1"); + END T1; + + BEGIN + NULL; + END; + + RESULT; + + END C9A009C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009f.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- C9A009F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK ABORTED DURING AN ENTRY CALL IS NOT TERMINATED + -- BEFORE THE END OF THE RENDEZVOUS. + + -- JEAN-PIERRE ROSEN 16-MAR-1984 + -- JBG 6/1/84 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT,SYSTEM; + USE REPORT,SYSTEM; + PROCEDURE C9A009F IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + + BEGIN + + TEST("C9A009F", "ABORTED TASK NOT TERMINATED BEFORE END OF " & + "RENDEVOUS"); + + DECLARE -- T1 ABORTED WHILE IN RENDEVOUS WITH BLOCKING. + + TASK T1 IS + END T1; + TASK BODY T1 IS + BEGIN + BLOCKING.STOP; + FAILED ("T1 NOT ABORTED"); + END; + + BEGIN + BLOCKING.START; -- ALLOWS T1 TO ENTER RENDEVOUS + + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 1"); + END IF; + + IF T1'TERMINATED THEN -- T1 STILL IN RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 1"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + + END C9A009F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009g.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- C9A009G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A MASTER ABORTED WITH SUBTASKS IN AN ENTRY CALL BECOMES + -- COMPLETED, BUT NOT TERMINATED, BEFORE THE END OF THE RENDEZVOUS. + + -- JEAN-PIERRE ROSEN 16-MAR-1984 + -- JBG 6/1/84 + -- PWN 11/30/94 REMOVED PRAGMA PRIORITY INSTANCES FOR ADA 9X. + + WITH REPORT,SYSTEM; + USE REPORT,SYSTEM; + PROCEDURE C9A009G IS + + + TASK BLOCKING IS + ENTRY START; + ENTRY STOP; + ENTRY RESTART; + ENTRY NO_CALL; + END BLOCKING; + + TASK BODY BLOCKING IS + BEGIN + SELECT + ACCEPT STOP DO + ACCEPT START; + ACCEPT RESTART; + END; + OR TERMINATE; + END SELECT; + END; + + BEGIN + + TEST("C9A009G", "MASTER COMPLETED BUT NOT TERMINATED"); + + DECLARE -- T1 ABORTED WHILE DEPENDENT TASK IN RENDEVOUS 9C? + + TASK T1 IS + ENTRY LOCK; + END T1; + + TASK BODY T1 IS + TASK T2; + + TASK BODY T2 IS + BEGIN + BLOCKING.STOP; + FAILED ("T2 NOT ABORTED"); + END; + BEGIN + BLOCKING.NO_CALL; -- WILL DEADLOCK UNTIL ABORT + END T1; + + BEGIN + BLOCKING.START; + ABORT T1; + + IF T1'CALLABLE THEN + FAILED("T1 STILL CALLABLE - 2"); + END IF; + + IF T1'TERMINATED THEN -- T1'S DEPENDENT TASK, T2, STILL IN + -- RENDEVOUS + FAILED("T1 PREMATURELY TERMINATED - 2"); + END IF; + + BLOCKING.RESTART; + END; + + RESULT; + + END C9A009G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a009h.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- C9A009H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A TASK ABORTED DURING A RENDEVOUS IS NEITHER CALLABLE NOR + -- TERMINATED BEFORE THE END OF THE RENDEVOUS. + + -- J.P ROSEN, ADA PROJECT, NYU + -- JBG 6/1/84 + + WITH REPORT; USE REPORT; + PROCEDURE C9A009H IS + BEGIN + TEST ("C9A009H", "TASK ABORTED IN RENDEVOUS IS NOT CALLABLE OR " & + "TERMINATED"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK T2 IS + END T2; + + TASK BODY T2 IS + BEGIN + T1.E1; + FAILED ("T2 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN ABORTED TASK"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED"); + END T2; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + ABORT T2; + IF T2'CALLABLE THEN + FAILED ("T2 STILL CALLABLE"); + END IF; + + IF T2'TERMINATED THEN + FAILED ("T2 TERMINATED"); + END IF; + END E1; + END T1; + + BEGIN + NULL; + END; + + RESULT; + + END C9A009H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a010a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- C9A010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- TEST ABORT DURING RENDEZVOUS + + -- ABORTING AN ABNORMAL (NOT YET TERMINATED) TASK. + + -- JEAN-PIERRE ROSEN 09 MARCH 1984 + -- JBG 6/1/84 + -- JWC 6/28/85 RENAMED FROM C9A009E-B.ADA + -- PWN 01/31/95 REMOVED PRAGMA PRIORITY FOR ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C9A010A IS + + BEGIN + + TEST("C9A010A", "ABORTING AN ABNORMAL TASK"); + + DECLARE + -- T1 CALLS T2. WHILE IN RENDEVOUS, T2 ABORTS T1 AND WAITS FOR A + -- CALL FROM THE MAIN PROGRAM. WHEN THE CALL IS ACCEPTED, THE MAIN + -- PROGRAM AGAIN ABORTS T1, WHICH IS NOW ABNORMAL, SINCE T1 HAS NOT + -- YET COMPLETED ITS RENDEVOUS WITH T2. + + TASK T1 IS + END T1; + + TASK T2 IS + ENTRY E1; + ENTRY E2; + END T2; + + TASK BODY T1 IS + BEGIN + T2.E1; + FAILED("T1 NOT ABORTED"); + EXCEPTION + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR IN T1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION IN T1"); + END T1; + + TASK BODY T2 IS + BEGIN + ACCEPT E1 DO + ABORT T1; + ACCEPT E2; -- NOTE CALLER REMAINS IN RENDEVOUS + ACCEPT E2; -- UNTIL TWO ENTRY CALLS ACCEPTED + END E1; + END T2; + BEGIN + T2.E2; -- ONLY ACCEPTED AFTER T1 HAS BEEN ABORTED. + ABORT T1; -- T1 IS ABNORMAL BECAUSE IT IS STILL IN RENDEVOUS. + IF T1'CALLABLE THEN + FAILED ("T1 CALLABLE AFTER BEING ABORTED"); + END IF; + IF T1'TERMINATED THEN + FAILED ("T1 TERMINATED ALTHOUGH IN RENDEVOUS"); + END IF; + T2.E2; -- T1'S RENDEVOUS CAN NOW COMPLETE; T1 CAN TERMINATE. + END; + + RESULT; + + END C9A010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a011a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- C9A011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A CALLED TASK IS ABORTED WHILE IN RENDEZVOUS, THEN + -- "TASKING_ERROR" IS RAISED IN THE CALLING TASK. + + -- HISTORY: + -- DHH 03/28/88 CREATED ORIGINAL TEST. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C9A011A IS + + TASK TYPE CHOICE IS + ENTRY E1; + END CHOICE; + + T : CHOICE; + + TASK BODY CHOICE IS + X : INTEGER; + BEGIN + ACCEPT E1 DO + X := IDENT_INT(3); + IF EQUAL(X,X) THEN + ABORT CHOICE; + END IF; + END E1; + END CHOICE; + + BEGIN + + TEST("C9A011A", "CHECK THAT IF A CALLED TASK IS ABORTED WHILE " & + "IN RENDEZVOUS, THEN ""TASKING_ERROR"" IS " & + "RAISED IN THE CALLING TASK"); + + T.E1; + FAILED("EXCEPTION NOT RAISED ON ABORT"); + + RESULT; + + EXCEPTION + WHEN TASKING_ERROR => + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED ON ABORT"); + RESULT; + END C9A011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/c9/c9a011b.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- C9A011B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT "TASKING_ERROR" IS RAISED BY A TIMED ENTRY CALL IF + -- THE CALLED TASK IS ABORTED BEFORE THE DELAY EXPIRES BUT NOT + -- WHEN THE CALL IS FIRST EXECUTED. + + -- HISTORY: + -- DHH 06/14/88 CREATED ORIGINAL TEST. + + with Impdef; + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE C9A011B IS + + TASK TIMED_ENTRY IS + ENTRY WAIT_AROUND; + END TIMED_ENTRY; + + TASK OWNER IS + ENTRY START; + ENTRY SELF_ABORT; + END OWNER; + + TASK BODY TIMED_ENTRY IS + BEGIN + SELECT + OWNER.SELF_ABORT; + OR + DELAY 60.0 * Impdef.One_Second; + END SELECT; + FAILED("NO EXCEPTION RAISED"); + + ACCEPT WAIT_AROUND; + EXCEPTION + WHEN TASKING_ERROR => + ACCEPT WAIT_AROUND; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + ACCEPT WAIT_AROUND; + END TIMED_ENTRY; + + TASK BODY OWNER IS + BEGIN + ACCEPT START DO + WHILE SELF_ABORT'COUNT = 0 LOOP + DELAY 1.0 * Impdef.One_Second; + END LOOP; + END START; + + ABORT OWNER; + + ACCEPT SELF_ABORT; + + END OWNER; + + BEGIN + + TEST("C9A011B", "CHECK THAT ""TASKING_ERROR"" IS RAISED BY A " & + "TIMED ENTRY CALL IF THE CALLED TASK IS " & + "ABORTED BEFORE THE DELAY EXPIRES BUT NOT " & + "WHEN THE CALL IS FIRST EXECUTED"); + + OWNER.START; + DELAY 5.0 * Impdef.One_Second; + + IF TIMED_ENTRY'CALLABLE THEN + TIMED_ENTRY.WAIT_AROUND; + ELSE + FAILED("TASK ABORTED WHEN TASKING ERROR IS RAISED"); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED OUTSIDE OF TASK"); + RESULT; + + END C9A011B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1003a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- CA1003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MORE THAN ONE COMPLETELY INDEPENDENT COMPILATION + -- UNIT CAN BE SUBMITTED IN A SINGLE FILE. + + -- JRK 5/13/81 + -- JBG 8/25/83 + + PROCEDURE CA1003A_P (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END CA1003A_P; + + + PACKAGE CA1003A_PKG IS + I : INTEGER := 0; + END CA1003A_PKG; + + + FUNCTION CA1003A_F (I : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -I; + END CA1003A_F; + + + WITH REPORT, CA1003A_P, CA1003A_PKG, CA1003A_F; + USE REPORT; + + PROCEDURE CA1003A IS + + I : INTEGER := IDENT_INT (0); + + BEGIN + TEST ("CA1003A", "INDEPENDENT UNITS IN A SINGLE FILE"); + + CA1003A_P (I); + IF I /= 1 THEN + FAILED ("INDEPENDENT PROCEDURE NOT INVOKED"); + END IF; + + CA1003A_PKG.I := CA1003A_PKG.I + IDENT_INT(10); + IF CA1003A_PKG.I /= 10 THEN + FAILED ("INDEPENDENT PACKAGE VARIABLE ACCESSED INCORRECTLY"); + END IF; + + IF CA1003A_F(IDENT_INT(5)) /= -5 THEN + FAILED ("INDEPENDENT FUNCTION NOT INVOKED"); + END IF; + + RESULT; + END CA1003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1004a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CA1004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A PACKAGE DECLARATION AND BODY CAN BE + -- SUBMITTED TOGETHER FOR COMPILATION. + + -- JRK 5/12/81 + + + PACKAGE CA1004A_PKG IS + + I : INTEGER := 0; + + PROCEDURE P (I : IN OUT INTEGER); + + END CA1004A_PKG; + + + PACKAGE BODY CA1004A_PKG IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I + 1; + END P; + + BEGIN + + I := 10; + + END CA1004A_PKG; + + + WITH REPORT, CA1004A_PKG; + USE REPORT; + + PROCEDURE CA1004A IS + + I : INTEGER := IDENT_INT (0); + + BEGIN + TEST ("CA1004A", "A PACKAGE DECLARATION AND BODY SUBMITTED " & + "TOGETHER"); + + CA1004A_PKG.I := CA1004A_PKG.I + IDENT_INT(5); + IF CA1004A_PKG.I /= 15 THEN + FAILED ("PACKAGED VARIABLE NOT ACCESSIBLE OR " & + "PACKAGE BODY NOT EXECUTED"); + END IF; + + CA1004A_PKG.P (I); + IF I /= 1 THEN + FAILED ("PACKAGED PROCEDURE NOT EXECUTED"); + END IF; + + RESULT; + END CA1004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1005a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CA1005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBPROGRAM DECLARATION AND BODY CAN BE + -- SUBMITTED TOGETHER FOR COMPILATION. + + -- JRK 5/14/81 + + + FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER; + + + FUNCTION CA1005A_F (I : INTEGER) RETURN INTEGER IS + BEGIN + RETURN I + 1; + END CA1005A_F; + + + PROCEDURE CA1005A_P (I : IN OUT INTEGER); + + + PROCEDURE CA1005A_P (I : IN OUT INTEGER) IS + BEGIN + I := -I; + END CA1005A_P; + + + WITH REPORT, CA1005A_F, CA1005A_P; + USE REPORT; + + PROCEDURE CA1005A IS + + I : INTEGER := IDENT_INT (7); + + BEGIN + TEST ("CA1005A", "SUBPROGRAM DECLARATIONS AND BODIES " & + "SUBMITTED TOGETHER"); + + IF CA1005A_F (IDENT_INT(2)) /= 3 THEN + FAILED ("FUNCTION NOT EXECUTED"); + END IF; + + CA1005A_P (I); + IF I /= -7 THEN + FAILED ("PROCEDURE NOT EXECUTED"); + END IF; + + RESULT; + END CA1005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1006a.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CA1006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A LIBRARY UNIT AND ITS SUBUNITS CAN BE + -- SUBMITTED TOGETHER FOR COMPILATION. + + -- JRK 5/14/81 + + WITH REPORT; + USE REPORT; + + PROCEDURE CA1006A IS + + I : INTEGER := IDENT_INT (0); + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA1006A", "A LIBRARY UNIT AND ITS SUBUNITS " & + "SUBMITTED TOGETHER"); + END CALL_TEST; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS SEPARATE; + + PACKAGE PKG IS + I : INTEGER := IDENT_INT (0); + PROCEDURE P (I : IN OUT INTEGER); + END PKG; + + PACKAGE BODY PKG IS SEPARATE; + + PROCEDURE P (I : IN OUT INTEGER) IS SEPARATE; + + BEGIN + + IF PKG.I /= 10 THEN + FAILED ("PACKAGE BODY STATEMENTS NOT EXECUTED"); + END IF; + + IF F(IDENT_INT(5)) /= -5 THEN + FAILED ("FUNCTION NOT ELABORATED/EXECUTED"); + END IF; + + PKG.P (I); + IF I /= 3 THEN + FAILED ("PACKAGED PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + I := IDENT_INT (-20); + P (I); + IF I /= -24 THEN + FAILED ("PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + RESULT; + END CA1006A; + + + SEPARATE (CA1006A) + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -I; + END F; + + + SEPARATE (CA1006A) + PACKAGE BODY PKG IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I + 3; + END P; + + BEGIN + I := I + 10; + END PKG; + + + SEPARATE (CA1006A) + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I - 4; + END P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA1011A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE CA1011A0 (X : IN OUT INTEGER; Y : IN INTEGER := 2) IS + BEGIN + + X := Y; + FAILED ("DID NOT REPLACE CA1011A0"); + + END CA1011A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA1011A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + PROCEDURE CA1011A0 (X : IN OUT INTEGER; + Y : IN INTEGER := -1; + Z : IN INTEGER := 2) IS + + BEGIN + + X := 3; + + END CA1011A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA1011A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + WITH REPORT; USE REPORT; + PROCEDURE CA1011A2 (X : INTEGER := 1; Y : IN OUT FLOAT) IS + BEGIN + + Y := 2.0; + FAILED ("DID NOT REPLACE CA1011A2"); + + END CA1011A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA1011A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + PROCEDURE CA1011A2 (X : BOOLEAN := TRUE; + Y : IN OUT FLOAT) IS + BEGIN + + Y := 3.0; + + END CA1011A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a4.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA1011A4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + WITH REPORT; USE REPORT; + FUNCTION CA1011A4 RETURN INTEGER IS + BEGIN + + FAILED ("DID NOT REPLACE CA1011A4"); + RETURN 2; + + END CA1011A4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a5.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + -- CA1011A5.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/20/84 + -- JBG 5/23/85 + + FUNCTION CA1011A4 RETURN FLOAT IS + BEGIN + + RETURN 3.0; + + END CA1011A4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1011a6.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CA1011A6M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A SUBPROGRAM BODY IS INITIALLY COMPILED, SUBSEQUENT + -- ATTEMPTS TO COMPILE A SUBPROGRAM BODY WITH A DIFFERENT PARAMETER AND + -- RESULT TYPE PROFILE ARE ACCEPTED (SEE AI-00199). + + -- SEPARATE FILES ARE: + -- CA1011A0 A LIBRARY PROCEDURE (CA1011A0). + -- CA1011A1 A LIBRARY PROCEDURE (CA1011A0). + -- CA1011A2 A LIBRARY PROCEDURE (CA1011A2). + -- CA1011A3 A LIBRARY PROCEDURE (CA1011A2). + -- CA1011A4 A LIBRARY FUNCTION (CA1011A4). + -- CA1011A5 A LIBRARY FUNCTION (CA1011A4). + -- CA1011A6M THE MAIN PROCEDURE. + + -- BHS 7/20/84 + -- JBG 5/23/85 + + WITH CA1011A0, CA1011A2, CA1011A4; + WITH REPORT; USE REPORT; + PROCEDURE CA1011A6M IS + + I : INTEGER := 5; + J : FLOAT := 4.0; + + BEGIN + + TEST("CA1011A", "ATTEMPTS TO RECOMPILE A SUBPROGRAM WITH " & + "NONCONFORMING PARAMETER OR RESULT TYPE " & + "PROFILES ARE ACCEPTED"); + + CA1011A0(X => I); -- EXPECT DEFAULT Y + IF I = 3 THEN + COMMENT ("SECOND DECLARATION OF CA1011A0 INVOKED CORRECTLY"); + END IF; + + CA1011A2(Y => J); -- USE DEFAULT X. + IF J = 3.0 THEN + COMMENT ("SECOND DECLARATION OF CA1011A2 INVOKED CORRECTLY"); + END IF; + + I := INTEGER(CA1011A4); + IF I = 3 THEN + COMMENT ("SECOND DECLARATION OF CA1011A4 INVOKED CORRECTLY"); + END IF; + + RESULT; + + END CA1011A6M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + -- CA1012A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- GENERIC PROCEDURE DECLARATION. + -- BODY IS IN CA1012A1.DEP. + -- INSTANTIATION IS IN CA1012A4M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- WKB 07/20/81 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES + -- AND CLARIFY POSSIBLE NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + GENERIC + TYPE INDEX IS RANGE <>; + PROCEDURE CA1012A0 (I : IN OUT INDEX); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + -- CA1012A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- GENERIC PROCEDURE BODY. + -- DECLARATION IS IN CA1012A0.DEP. + -- INSTANTIATION IN CA1012A4M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- WKB 07/20/81 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES + -- IN TEST AND POSSIBLE NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + PROCEDURE CA1012A0 (I : IN OUT INDEX) IS + + BEGIN + + I := I + 1; + + END CA1012A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + -- CA1012A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- GENERIC FUNCTION DECLARATION. + -- BODY IS IN CA1012A3.DEP. + -- INSTANTIATION IS IN CA1012A4M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- WKB 07/20/81 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES + -- AND POSSIBLE NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + GENERIC + TYPE ELEMENT IS RANGE <>; + FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + -- CA1012A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- GENERIC FUNCTION BODY. + -- DECLARATION IS IN CA1012AB.DEP. + -- INSTANTIATION IS IN CA1012A4B.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- WKB 07/20/81 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO DESCRIBE RELATION TO OTHER FILES + -- AND POSSIBLE NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + FUNCTION CA1012A2 (J : IN ELEMENT) RETURN ELEMENT IS + + BEGIN + + RETURN J + 1; + + END CA1012A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012a4.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- CA1012A4M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE + -- COMPILED SEPARATELY. + + -- SEPARATE FILES ARE: + -- CA1012A0 A LIBRARY GENERIC PROCEDURE DECLARATION. + -- CA1012A1 A LIBRARY GENERIC PROCEDURE BODY (CA1012A0). + -- CA1012A2 A LIBRARY GENERIC FUNCTION DECLARATION. + -- CA1012A3 A LIBRARY GENERIC FUNCTION BODY (CA1012A2). + -- CA1012A4M THE MAIN PROCEDURE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + -- THIS WAS NOT REQUIRED FOR ADA 83. + + -- HISTORY: + -- WKB 07/20/81 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS REGARDING NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + -- RLB 09/15/99 REMOVED OBSOLETE COMMENT. + + WITH REPORT, CA1012A0, CA1012A2; + USE REPORT; + PROCEDURE CA1012A4M IS + + N : INTEGER := 1; + + SUBTYPE S50 IS INTEGER RANGE 1..50; + + PROCEDURE P IS NEW CA1012A0 (S50); + + FUNCTION F IS NEW CA1012A2 (INTEGER); + + BEGIN + TEST ("CA1012A", "SEPARATELY COMPILED GENERIC SUBPROGRAM " & + "DECLARATIONS AND BODIES"); + + P(N); + IF N /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + N := 1; + IF F(N) /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; + END CA1012A4M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + -- CA1012B0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + + GENERIC + TYPE INDEX IS RANGE <>; + PROCEDURE CA1012B0 (I : IN OUT INDEX); + + PROCEDURE CA1012B0 (I : IN OUT INDEX) IS + + BEGIN + + I := I + 1; + + END CA1012B0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + -- CA1012B2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + + GENERIC + TYPE ELEMENT IS RANGE <>; + FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT; + + FUNCTION CA1012B2 (J : IN ELEMENT) RETURN ELEMENT IS + + BEGIN + + RETURN J + 1; + + END CA1012B2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1012b4.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CA1012B4M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC SUBPROGRAM DECLARATIONS AND BODIES CAN BE + -- COMPILED SEPARATELY. + + -- SEPARATE FILES ARE: + -- CA1012B0 A LIBRARY GENERIC PROCEDURE DECLARATION AND BODY. + -- CA1012B2 A LIBRARY GENERIC FUNCTION DECLARATION AND BODY. + -- CA1012B4M THE MAIN PROCEDURE. + + -- WKB 7/20/81 + + WITH REPORT, CA1012B0, CA1012B2; + USE REPORT; + PROCEDURE CA1012B4M IS + + N : INTEGER := 1; + + SUBTYPE S50 IS INTEGER RANGE 1..50; + + PROCEDURE P IS NEW CA1012B0 (S50); + + FUNCTION F IS NEW CA1012B2 (INTEGER); + + BEGIN + TEST ("CA1012B", "SEPARATELY COMPILED GENERIC SUBPROGRAM " & + "DECLARATIONS AND BODIES"); + + P(N); + IF N /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + N := 1; + IF F(N) /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; + + END CA1012B4M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- CA1013A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + -- PWN 5/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + + GENERIC + TYPE ELEM IS RANGE <>; + PACKAGE CA1013A0 IS + + I : ELEM; + + PROCEDURE REQUIRE_BODY; + + END CA1013A0; + + + PACKAGE BODY CA1013A0 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + BEGIN + + I := 1; + + END CA1013A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + -- CA1013A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + + + GENERIC + TYPE INDEX IS RANGE <>; + PROCEDURE CA1013A1 (I : IN OUT INDEX); + + + PROCEDURE CA1013A1 (I : IN OUT INDEX) IS + + BEGIN + + I := I + 1; + + END CA1013A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + -- CA1013A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + + + GENERIC + TYPE ITEM IS RANGE <>; + FUNCTION CA1013A2 RETURN ITEM; + + + FUNCTION CA1013A2 RETURN ITEM IS + + BEGIN + + RETURN 2; + + END CA1013A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + -- CA1013A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + -- SPS 10/27/82 + -- JBG 9/15/83 + + WITH CA1013A0; + PRAGMA ELABORATE (CA1013A0); + PACKAGE CA1013A3 IS NEW CA1013A0 (INTEGER); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a4.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + -- CA1013A4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + -- SPS 10/27/82 + -- JBG 9/15/83 + + WITH CA1013A1; + PRAGMA ELABORATE (CA1013A1); + PROCEDURE CA1013A4 IS NEW CA1013A1 (INTEGER); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a5.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,30 ---- + -- CA1013A5.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/20/81 + -- JBG 9/15/83 + + WITH CA1013A2; + PRAGMA ELABORATE (CA1013A2); + FUNCTION CA1013A5 IS NEW CA1013A2 (INTEGER); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1013a6.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- CA1013A6M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A GENERIC PACKAGE OR SUBPROGRAM INSTANTIATION + -- CAN BE SUBMITTED FOR SEPARATE COMPILATION. + + -- SEPARATE FILES ARE: + -- CA1013A0 A LIBRARY GENERIC PACKAGE. + -- CA1013A1 A LIBRARY GENERIC PROCEDURE. + -- CA1013A2 A LIBRARY GENERIC FUNCTION. + -- CA1013A3 A LIBRARY GENERIC PACKAGE INSTANTIATION. + -- CA1013A4 A LIBRARY GENERIC PROCEDURE INSTANTIATION. + -- CA1013A5 A LIBRARY GENERIC FUNCTION INSTANTIATION. + -- CA1013A6M THE MAIN PROCEDURE. + + -- WKB 7/20/81 + -- SPS 11/5/82 + + WITH REPORT; + WITH CA1013A3, CA1013A4, CA1013A5; + USE REPORT; + PROCEDURE CA1013A6M IS + + J : INTEGER := 1; + + BEGIN + TEST ("CA1013A", "GENERIC INSTANTIATIONS SUBMITTED " & + "FOR SEPARATE COMPILATION"); + + IF CA1013A3.I /= 1 THEN + FAILED ("PACKAGE NOT ACCESSED"); + END IF; + + CA1013A4 (J); + IF J /= 2 THEN + FAILED ("PROCEDURE NOT INVOKED"); + END IF; + + IF CA1013A5 /= 2 THEN + FAILED ("FUNCTION NOT INVOKED"); + END IF; + + RESULT; + END CA1013A6M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CA1014A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBUNIT CAN BE SUBMITTED FOR COMPILATION + -- SEPARATELY FROM ITS PARENT UNIT. + + -- SEPARATE FILES ARE: + -- CA1014A0M THE MAIN PROCEDURE. + -- CA1014A1 A SUBUNIT PROCEDURE BODY. + -- CA1014A2 A SUBUNIT PACKAGE BODY. + -- CA1014A3 A SUBUNIT FUNCTION BODY. + + -- JRK 5/20/81 + + WITH REPORT; + USE REPORT; + + PROCEDURE CA1014A0M IS + + I : INTEGER := 0; + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA1014A", "SUBUNITS SUBMITTED FOR COMPILATION " & + "SEPARATELY FROM PARENT UNIT"); + END CALL_TEST; + + PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS SEPARATE; + + PACKAGE CA1014A2 IS + I : INTEGER := 10; + PROCEDURE P (I : IN OUT INTEGER); + END CA1014A2; + + PACKAGE BODY CA1014A2 IS SEPARATE; + + FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS SEPARATE; + + BEGIN + + CA1014A1 (I); + IF I /= 1 THEN + FAILED ("SUBUNIT PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + IF CA1014A2.I /= 15 THEN + FAILED ("SUBUNIT PACKAGE BODY NOT ELABORATED/EXECUTED"); + END IF; + + I := 0; + CA1014A2.P (I); + IF I /= -20 THEN + FAILED ("SUBUNIT PACKAGED PROCEDURE NOT ELABORATED/EXECUTED"); + END IF; + + IF CA1014A3(50) /= -50 THEN + FAILED ("SUBUNIT FUNCTION NOT ELABORATED/EXECUTED"); + END IF; + + RESULT; + END CA1014A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA1014A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 5/20/81 + + SEPARATE (CA1014A0M) + PROCEDURE CA1014A1 (I : IN OUT INTEGER) IS + + BEGIN + + I := I + 1; + + END CA1014A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + -- CA1014A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 5/20/81 + + SEPARATE (CA1014A0M) + PACKAGE BODY CA1014A2 IS + + PROCEDURE P (I : IN OUT INTEGER) IS + BEGIN + I := I - 20; + END P; + + BEGIN + + I := I + 5; + + END CA1014A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1014a3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA1014A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- JRK 5/20/81 + + SEPARATE (CA1014A0M) + FUNCTION CA1014A3 (I : INTEGER) RETURN INTEGER IS + + BEGIN + + RETURN -I; + + END CA1014A3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- CA1020E0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC + -- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS + -- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS. + + -- HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT + -- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST + -- DECLARED WITHOUT A BODY. + + GENERIC + C : INTEGER; + PROCEDURE GENPROC_CA1020E (X : OUT INTEGER); + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE GENPROC_CA1020E (X : OUT INTEGER) IS + BEGIN + X := IDENT_INT(C); + END GENPROC_CA1020E; + + GENERIC + FUNCTION GENFUNC_CA1020E RETURN INTEGER; + + FUNCTION GENFUNC_CA1020E RETURN INTEGER IS + BEGIN + RETURN 2; + END GENFUNC_CA1020E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- CA1020E1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC + -- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS + -- SUBPROGRAMS TO BE REPLACED BY LATER GENERIC INSTANTIATIONS. + + -- HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT + -- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST + -- DECLARED WITHOUT A BODY. + + PROCEDURE CA1020E_PROC1 (X : OUT INTEGER) IS + BEGIN + X := 3; + END CA1020E_PROC1; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION CA1020E_FUNC1 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(4); + END CA1020E_FUNC1; + + PROCEDURE CA1020E_PROC2 (X : OUT INTEGER); + PROCEDURE CA1020E_PROC2 (X : OUT INTEGER) IS + BEGIN + X := 3; + END CA1020E_PROC2; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION CA1020E_FUNC2 RETURN FLOAT IS + BEGIN + RETURN FLOAT(IDENT_INT(4)); + END CA1020E_FUNC2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- CA1020E2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC + -- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS + -- GENERIC INSTANTIATIONS REPLACING LIBRARY UNITS CREATED IN + -- CA1020E1. + + -- HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT + -- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST + -- DECLARED WITHOUT A BODY. + + WITH GENPROC_CA1020E; + PRAGMA ELABORATE (GENPROC_CA1020E); + PROCEDURE CA1020E_PROC1 IS NEW GENPROC_CA1020E(1); + + WITH GENFUNC_CA1020E; + PRAGMA ELABORATE (GENFUNC_CA1020E); + FUNCTION CA1020E_FUNC1 IS NEW GENFUNC_CA1020E; + + WITH GENPROC_CA1020E; + PRAGMA ELABORATE (GENPROC_CA1020E); + PROCEDURE CA1020E_PROC2 IS NEW GENPROC_CA1020E(5); + + WITH GENFUNC_CA1020E; + PRAGMA ELABORATE (GENFUNC_CA1020E); + FUNCTION CA1020E_FUNC2 IS NEW GENFUNC_CA1020E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1020e3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CA1020E3M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE REPLACED BY A GENERIC + -- INSTANTIATION HAVING THE SAME IDENTIFIER. THIS FILE CONTAINS + -- GENERIC UNITS TO BE INSTANTIATED AS LIBRARY UNITS. + + -- SEPARATE FILES ARE: + -- CA1020E0 -- GENERIC UNITS GENPROC_CA1020E AND GENFUNC_CA1020E. + -- CA1020E1 -- SUBPROGRAM LIBRARY UNIT BODIES (CA1020E_PROC1, + -- CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2). + -- CA1020E2 -- INSTANTIATIONS REPLACING UNITS COMPILED IN CA1020E1. + -- CA1020E3M -- MAIN PROGRAM. + + -- HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- JET 07/29/88 ADDED CASES IN WHICH SUBPROGRAM PROFILES ARE NOT + -- THE SAME AND ALSO WHEN SUBPROGRAM IS FIRST + -- DECLARED WITHOUT A BODY. + + WITH REPORT; USE REPORT; + WITH CA1020E_PROC1, CA1020E_FUNC1, CA1020E_PROC2, CA1020E_FUNC2; + PROCEDURE CA1020E3M IS + TEMP : INTEGER := 0; + BEGIN + TEST ("CA1020E", "CHECK THAT A SUBPROGRAM LIBRARY UNIT CAN BE " & + "REPLACED BY A GENERIC INSTANTIATION HAVING " & + "THE SAME IDENTIFIER"); + + CA1020E_PROC1 (TEMP); + IF TEMP /= IDENT_INT(1) THEN + FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE"); + END IF; + + IF CA1020E_FUNC1 /= IDENT_INT(2) THEN + FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION"); + END IF; + + CA1020E_PROC2 (TEMP); + IF TEMP /= IDENT_INT(5) THEN + FAILED ("INSTANTIATION DID NOT REPLACE PROCEDURE"); + END IF; + + IF CA1020E_FUNC2 /= IDENT_INT(2) THEN + FAILED ("INSTANTIATION DID NOT REPLACE FUNCTION"); + END IF; + + RESULT; + END CA1020E3M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a0.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + -- CA1022A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/23/84 + + PACKAGE CA1022A0 IS + + I : INTEGER := 2; + PROCEDURE P0 (X : IN OUT INTEGER ); + + END CA1022A0; + + PACKAGE BODY CA1022A0 IS + + PROCEDURE P0 (X : IN OUT INTEGER) IS + BEGIN + + X := X + 1; + + END P0; + + END CA1022A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a1.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + -- CA1022A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/23/84 + + WITH CA1022A0; + PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS + BEGIN + + CA1022A0.P0 (Y); + + END CA1022A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a2.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + -- CA1022A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/23/84 + + WITH CA1022A0; + FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS + BEGIN + + RETURN TRUE; + + END CA1022A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a3.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- CA1022A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- RECOMPILATION OF PACKAGE CA1022A0. + + -- BHS 7/23/84 + + PACKAGE CA1022A0 IS + + I, J : INTEGER; + PROCEDURE P0 (X : IN OUT INTEGER); + FUNCTION F RETURN INTEGER; + + END CA1022A0; + + PACKAGE BODY CA1022A0 IS + + PROCEDURE P0 (X : IN OUT INTEGER) IS + BEGIN + + X := X + 2; + + END P0; + + FUNCTION F RETURN INTEGER IS + BEGIN + + RETURN 3; + + END F; + + END CA1022A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a4.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA1022A4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- RECOMPILATION OF PROCEDURE CA1022A1. + + -- BHS 7/23/84 + + WITH CA1022A0; + PROCEDURE CA1022A1 (Y : IN OUT INTEGER) IS + BEGIN + + Y := 3; + CA1022A0.P0 (Y); + + END CA1022A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a5.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA1022A5.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- RECOMPILATION OF FUNCTION CA1022A2 (DECL AND BODY). + + -- BHS 7/23/84 + + FUNCTION CA1022A2 (Z : INTEGER := 1) RETURN BOOLEAN IS + BEGIN + + RETURN Z /= 1; + + END CA1022A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1022a6.ada 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CA1022A6M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A SUBPROGRAM BODY IS INITIALLY COMPILED WITH A CONTEXT + -- CLAUSE AND A UNIT NAMED IN THE CONTEXT CLAUSE IS RECOMPILED, THEN AN + -- ATTEMPT TO COMPILE THE BODY AGAIN WILL SUCCEED IF THE CONTEXT CLAUSE + -- IS PRESENT. + -- CHECK THAT IF THE RECOMPILED UNIT IS NOT NEEDED IN THE SUBPROGRAM + -- BODY, THE BODY CAN BE SUCCESSFULLY RECOMPILED WITHOUT MENTIONING THE + -- RECOMPILED UNIT. + + -- SEPARATE FILES ARE: + -- CA1022A0 A LIBRARY PACKAGE. + -- CA1022A1 A LIBRARY PROCEDURE. + -- CA1022A2 A LIBRARY FUNCTION. + -- CA1022A3 A LIBRARY PACKAGE (CA1022A0). + -- CA1022A4 A LIBRARY PROCEDURE (CA1022A1). + -- CA1022A5 A LIBRARY FUNCTION (CA1022A2). + -- CA1022A6M THE MAIN PROCEDURE. + + -- BHS 7/23/84 + + WITH CA1022A1, CA1022A2; + WITH REPORT; USE REPORT; + PROCEDURE CA1022A6M IS + + I : INTEGER := 1; + + BEGIN + + TEST ("CA1022A", "USE OF CONTEXT CLAUSES NAMING RECOMPILED " & + "UNITS WITH RECOMPILED SUBPROGRAMS"); + + CA1022A1(I); + IF I /= 5 THEN + FAILED ("PROCEDURE CA1022A1 NOT INVOKED CORRECTLY"); + END IF; + + IF CA1022A2 THEN + FAILED ("FUNCTION CA1022A2 NOT INVOKED CORRECTLY"); + END IF; + + RESULT; + + END CA1022A6M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11001.a 2003-10-27 11:28:54.000000000 +0000 *************** *** 0 **** --- 1,276 ---- + -- CA11001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a child unit can be used to provide an alternate view and + -- operations on a private type in its parent package. Check that a + -- child unit can be a package. Check that a WITH of a child unit + -- includes an implicit WITH of its ancestor unit. + -- + -- TEST DESCRIPTION: + -- Declare a private type in a package specification. Declare + -- subprograms for the type. + -- + -- Add a public child to the above package. Within the body of this + -- package, access the private type. Declare operations to read and + -- write to its parent private type. + -- + -- In the main program, "with" the child. Declare objects of the + -- parent private type. Access the subprograms from both parent and + -- child packages. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11001_0 is -- Cartesian_Complex + -- This package represents a Cartesian view of a complex number. It contains + -- a private type plus subprograms to construct and decompose a complex + -- number. + + type Complex_Int is range 0 .. 100; + + type Complex_Type is private; + + Constant_Complex : constant Complex_Type; + + Complex_Error : exception; + + procedure Cartesian_Assign (R, I : in Complex_Int; + C : out Complex_Type); + + function Cartesian_Real_Part (C : Complex_Type) + return Complex_Int; + + function Cartesian_Imag_Part (C : Complex_Type) + return Complex_Int; + + function Complex (Real, Imaginary : Complex_Int) + return Complex_Type; + + private + type Complex_Type is -- Parent private type + record + Real, Imaginary : Complex_Int; + end record; + + Constant_Complex : constant Complex_Type := (Real => 0, Imaginary => 0); + + end CA11001_0; -- Cartesian_Complex + + --=======================================================================-- + + package body CA11001_0 is -- Cartesian_Complex + + procedure Cartesian_Assign (R, I : in Complex_Int; + C : out Complex_Type) is + begin + C.Real := R; + C.Imaginary := I; + end Cartesian_Assign; + ------------------------------------------------------------- + function Cartesian_Real_Part (C : Complex_Type) + return Complex_Int is + begin + return C.Real; + end Cartesian_Real_Part; + ------------------------------------------------------------- + function Cartesian_Imag_Part (C : Complex_Type) + return Complex_Int is + begin + return C.Imaginary; + end Cartesian_Imag_Part; + ------------------------------------------------------------- + function Complex (Real, Imaginary : Complex_Int) + return Complex_Type is + begin + return (Real, Imaginary); + end Complex; + + end CA11001_0; -- Cartesian_Complex + + --=======================================================================-- + + package CA11001_0.CA11001_1 is -- Polar_Complex + -- This public child provides a different view of the private type from its + -- parent. It provides a polar view by the provision of subprograms which + -- construct and decompose a complex number. + + procedure Polar_Assign (R, Theta : in Complex_Int; + C : out Complex_Type); + -- Complex_Type is a + -- record of CA11001_0 + + function Polar_Real_Part (C: Complex_Type) return Complex_Int; + + function Polar_Imag_Part (C: Complex_Type) return Complex_Int; + + function Equals_Const (Num : Complex_Type) return Boolean; + + end CA11001_0.CA11001_1; -- Polar_Complex + + --=======================================================================-- + + package body CA11001_0.CA11001_1 is -- Polar_Complex + + function Cos (Angle : Complex_Int) return Complex_Int is + Num : constant Complex_Int := 2; + begin + return (Angle * Num); -- not true Cosine function + end Cos; + ------------------------------------------------------------- + function Sine (Angle : Complex_Int) return Complex_Int is + begin + return 1; -- not true Sine function + end Sine; + ------------------------------------------------------------- + function Sqrt (Num : Complex_Int) + return Complex_Int is + begin + return (Num); -- not true Square root function + end Sqrt; + ------------------------------------------------------------- + function Tan (Angle : Complex_Int) return Complex_Int is + begin + return Angle; -- not true Tangent function + end Tan; + ------------------------------------------------------------- + procedure Polar_Assign (R, Theta : in Complex_Int; + C : out Complex_Type) is + begin + if R = 0 and Theta = 0 then + raise Complex_Error; + end if; + C.Real := R * Cos (Theta); + C.Imaginary := R * Sine (Theta); + end Polar_Assign; + ------------------------------------------------------------- + function Polar_Real_Part (C: Complex_Type) return Complex_Int is + begin + return Sqrt ((Cartesian_Imag_Part (C)) ** 2 + + (Cartesian_Real_Part (C)) ** 2); + end Polar_Real_Part; + ------------------------------------------------------------- + function Polar_Imag_Part (C: Complex_Type) return Complex_Int is + begin + return (Tan (Cartesian_Imag_Part (C) / + Cartesian_Real_Part (C))); + end Polar_Imag_Part; + ------------------------------------------------------------- + function Equals_Const (Num : Complex_Type) return Boolean is + begin + return Num.Real = Constant_Complex.Real and + Num.Imaginary = Constant_Complex.Imaginary; + end Equals_Const; + + end CA11001_0.CA11001_1; -- Polar_Complex + + --=======================================================================-- + + with CA11001_0.CA11001_1; -- Polar_Complex + with Report; + + procedure CA11001 is + + Complex_No : CA11001_0.Complex_Type; -- Complex_Type is a + -- record of CA11001_0 + + Complex_5x2 : CA11001_0.Complex_Type := CA11001_0.Complex (5, 2); + + Int_2 : CA11001_0.Complex_Int + := CA11001_0.Complex_Int (Report.Ident_Int (2)); + + begin + + Report.Test ("CA11001", "Check that a child unit can be used " & + "to provide an alternate view and operations " & + "on a private type in its parent package"); + + Basic_View_Subtest: + + begin + -- Assign using Cartesian coordinates. + CA11001_0.Cartesian_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (1)), Int_2, Complex_No); + + -- Read back in Polar coordinates. + -- Polar values are surrogates used in checking for correct + -- subprogram calls. + if CA11001_0."/=" (CA11001_0.CA11001_1.Polar_Real_Part (Complex_No), + CA11001_0.Cartesian_Real_Part (Complex_5x2)) and CA11001_0."/=" + (CA11001_0.CA11001_1.Polar_Imag_Part (Complex_No), + CA11001_0.Cartesian_Imag_Part (Complex_5x2)) then + Report.Failed ("Incorrect Cartesian result"); + end if; + + end Basic_View_Subtest; + ------------------------------------------------------------- + Alternate_View_Subtest: + begin + -- Assign using Polar coordinates. + CA11001_0.CA11001_1.Polar_Assign + (Int_2, CA11001_0.Complex_Int (Report.Ident_Int (3)), Complex_No); + + -- Read back in Cartesian coordinates. + if CA11001_0."/=" (CA11001_0.Cartesian_Real_Part + (Complex_No), CA11001_0.Complex_Int (Report.Ident_Int (12))) or + CA11001_0."/=" (CA11001_0.Cartesian_Imag_Part (Complex_No), Int_2) + then + Report.Failed ("Incorrect Polar result"); + end if; + end Alternate_View_Subtest; + ------------------------------------------------------------- + Other_Subtest: + begin + -- Assign using Polar coordinates. + CA11001_0.CA11001_1.Polar_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (0)), Int_2, Complex_No); + + -- Compare with Complex_Num in CA11001_0. + if not CA11001_0.CA11001_1.Equals_Const (Complex_No) + then + Report.Failed ("Incorrect result"); + end if; + end Other_Subtest; + ------------------------------------------------------------- + Exception_Subtest: + begin + -- Raised parent's exception. + CA11001_0.CA11001_1.Polar_Assign + (CA11001_0.Complex_Int (Report.Ident_Int (0)), + CA11001_0.Complex_Int (Report.Ident_Int (0)), Complex_No); + Report.Failed ("Exception was not raised"); + exception + when CA11001_0.Complex_Error => + null; + when others => + Report.Failed ("Unexpected exception raised in test"); + end Exception_Subtest; + + Report.Result; + + end CA11001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11002.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,238 ---- + -- CA11002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a public child can utilize its parent unit's visible + -- definitions. + -- + -- TEST DESCRIPTION: + -- Declare a parent package that contains the following: type, object, + -- constant, exception, and subprograms. Declare a public child unit + -- that utilizes the components found in the visible part of its parent. + -- + -- Demonstrate utilization of the following parent components in the + -- child package: + -- + -- Parent + -- Type X + -- Constant X + -- Object X + -- Subprogram X + -- Exception X + -- + -- This abstraction simulates a portion of a simple operating system. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11002_0 is -- Package OS. + + type File_Descriptor is new Integer; + type File_Mode is (Read_Only, Write_Only, Read_Write); + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Only; + Active_Mode : constant File_Mode := Read_Write; + + type File_Type is + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + end record; + + System_File : File_Type; + File_Mode_Error : exception; + + function Next_Available_File return File_Descriptor; + + function Mode_Of_File (File : File_Type) return File_Mode; + + end CA11002_0; -- Package OS. + + --=================================================================-- + + package body CA11002_0 is -- Package body OS. + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); -- Type conversion. + end Next_Available_File; + -------------------------------------------------------------- + function Mode_Of_File (File : File_Type) return File_Mode is + Mode : File_Mode := File.Mode; + begin + return (Mode); + end Mode_Of_File; + + end CA11002_0; -- Package body OS. + + --=================================================================-- + + package CA11002_0.CA11002_1 is -- Child package OS.Operations. + + -- Dot qualification of types, objects, etc. from parent is not required + -- in a child unit. + + procedure Create_File (Mode : in File_Mode:= Active_Mode; + File : out File_Type); + + end CA11002_0.CA11002_1; -- Child package OS.Operations. + + --=================================================================-- + + with Report; + package body CA11002_0.CA11002_1 is -- Child package body OS.Operations. + + function New_File_Validated (File : File_Type) -- Ensure that a newly + return Boolean is -- created file has + Result : Boolean := False; -- appropriate values. + begin + if (File.Descriptor > System_File.Descriptor) and -- Parent object. + (File.Mode in File_Mode ) -- Parent type. + then + Result := True; + end if; + + return (Result); + + end New_File_Validated; + -------------------------------------------------------------- + procedure Create_File + (Mode : in File_Mode := Active_Mode; -- Parent constant. + File : out File_Type) is -- Parent type. + + New_File : File_Type; + + begin + New_File.Descriptor := Next_Available_File; -- Parent subprogram. + New_File.Mode := Mode; + + if New_File_Validated (File => New_File) then + File := New_File; + end if; + + end Create_File; + + end CA11002_0.CA11002_1; -- Child Package body OS.Operations. + + --=================================================================-- + + -- Child library subprogram Convert_File_Mode specification. + procedure CA11002_0.CA11002_2 (File : in out File_Type; -- Parent type. + New_Mode : in File_Mode); -- Parent type. + + + --=================================================================-- + with Report; + + -- Child library subprogram Convert_File_Mode body. + procedure CA11002_0.CA11002_2 (File : in out File_Type; + New_Mode : in File_Mode) is + begin + if File.Mode = New_Mode then + raise File_Mode_Error; -- Parent exception. + Report.Failed ("Exception not raised in child unit"); + else + File.Mode := New_Mode; + end if; + end CA11002_0.CA11002_2; + + --=================================================================-- + + with Report; + with CA11002_0.CA11002_1; -- Child package OS.Operations. + with CA11002_0.CA11002_2; -- Child subprogram OS.Convert_File_Mode, + -- Implicitly with parent, OS. + use CA11002_0; -- All user-defined operators directly + -- visible. + procedure CA11002 is + begin + + Report.Test ("CA11002", "Check that a public child can utilize its " & + "parent unit's visible definitions"); + + File_Creation: -- This processing block will demonstrate + -- use of child package subroutine that + -- takes advantage of components declared + -- in the parent package. + declare + User_File : File_Type; + begin + CA11002_0.CA11002_1.Create_File (File => User_File); -- Default mode + -- parameter used in + -- this call. + if (User_File.Descriptor = System_File.Descriptor) or + (User_File.Mode = Default_Mode) + then + Report.Failed ("Incorrect file creation"); + end if; + + end File_Creation; + + -------------------------------------------------------------- + File_Mode_Conversion: -- This processing block will demonstrate + -- the occurrence of a (forced) exception + -- being raised in a child subprogram, and + -- propagated to the caller. The exception + -- is handled, and the child subprogram + -- is called again, this time to perform + -- without error. + declare + procedure Convert_File_Mode (File : in out File_Type; + New_Mode : in File_Mode) renames CA11002_0.CA11002_2; + New_File : File_Type; + begin -- Raise an exception with this + -- illegal conversion operation + -- (attempt to change to current mode). + + Convert_File_Mode (File => New_File, + New_Mode => Default_Mode); + Report.Failed ("Exception should have been raised in child unit"); + + exception + when File_Mode_Error => -- Perform the conversion again, this + -- time with a different file mode. + + Convert_File_Mode (File => New_File, + New_Mode => CA11002_0.Active_Mode); + + if New_File.Mode /= Read_Write then + Report.Failed ("Incorrect result from mode conversion operation"); + end if; + + when others => + Report.Failed ("Unexpected exception raised in File_Mode_Conversion"); + + end File_Mode_Conversion; + + Report.Result; + + end CA11002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11003.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,290 ---- + -- CA11003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a public grandchild can utilize its ancestor unit's visible + -- definitions. + -- + -- TEST DESCRIPTION: + -- Declare a public package, public child package, and public + -- grandchild package and library unit function. Within the + -- grandchild package and function, make use of components that are + -- declared in the ancestor packages, both parent and grandparent. + -- + -- Use the following ancestral components in the grandchildren library + -- units: + -- Grandparent Parent + -- Type X X + -- Constant X X + -- Object X X + -- Subprogram X X + -- Exception X X + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Dec 94 SAIC Modified procedure Create_File + -- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + package CA11003_0 is -- Package OS + + type File_Descriptor is new Integer; + type File_Mode is (Read_Only, Write_Only, Read_Write); + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Only; + File_Data_Error : exception; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Read_Write; + end record; + + System_File : File_Type; + + function Next_Available_File return File_Descriptor; + + procedure Reclaim_File_Descriptor; + + end CA11003_0; -- Package OS + + --=================================================================-- + + package body CA11003_0 is -- Package body OS + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return (File_Descriptor(File_Count)); + end Next_Available_File; + -------------------------------------------------- + procedure Reclaim_File_Descriptor is + begin + null; -- Dummy processing unit. + end Reclaim_File_Descriptor; + + end CA11003_0; -- Package body OS + + --=================================================================-- + + package CA11003_0.CA11003_1 is -- Child package OS.Operations + + subtype File_Length_Type is Integer range 0 .. 1000; + Min_File_Size : File_Length_Type := File_Length_Type'First; + Max_File_Size : File_Length_Type := File_Length_Type'Last; + + File_Duplication_Error : exception; + + type Extended_File_Type is new File_Type with private; + + procedure Create_File (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Duplicate_File (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type); + + private + type Extended_File_Type is new File_Type with + record + Blocks : File_Length_Type := Min_File_Size; + end record; + + System_Extended_File : Extended_File_Type; + + end CA11003_0.CA11003_1; -- Child Package OS.Operations + + --=================================================================-- + + package body CA11003_0.CA11003_1 is -- Child package body OS.Operations + + procedure Create_File + (Mode : in File_Mode; + File : out Extended_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Parent subprogram. + File.Mode := Default_Mode; -- Parent constant. + File.Blocks := Min_File_Size; + end Create_File; + -------------------------------------------------- + procedure Duplicate_File (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type) is + begin + Duplicate.Descriptor := Next_Available_File; -- Parent subprogram. + Duplicate.Mode := Original.Mode; + Duplicate.Blocks := Original.Blocks; + end Duplicate_File; + + end CA11003_0.CA11003_1; -- Child package body OS.Operations + + --=================================================================-- + + -- This package contains menu selectable operations for manipulating files. + -- This abstraction builds on the capabilities available from ancestor + -- packages. + + package CA11003_0.CA11003_1.CA11003_2 is + + procedure News (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Copy (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type); + + procedure Delete (File : in Extended_File_Type); + + end CA11003_0.CA11003_1.CA11003_2; -- Grandchild package OS.Operations.Menu + + --=================================================================-- + + -- Grandchild subprogram Validate + function CA11003_0.CA11003_1.CA11003_3 (File : in Extended_File_Type) + return Boolean; + + --=================================================================-- + + -- Grandchild subprogram Validate + function CA11003_0.CA11003_1.CA11003_3 + (File : in Extended_File_Type) -- Parent type. + return Boolean is + + function New_File_Validated (File : Extended_File_Type) + return Boolean is + begin + if (File.Descriptor > System_File.Descriptor) and -- Grandparent + (File.Mode in File_Mode ) and -- object and type + not ((File.Blocks < System_Extended_File.Blocks) or + (File.Blocks > Max_File_Size)) -- Parent object + then -- and constant. + return True; + else + return False; + end if; + end New_File_Validated; + + begin + return (New_File_Validated (File)) and + (File.Descriptor /= Null_File); -- Grandparent constant. + + end CA11003_0.CA11003_1.CA11003_3; -- Grandchild subprogram Validate + + --=================================================================-- + + with CA11003_0.CA11003_1.CA11003_3; + -- Grandchild package body OS.Operations.Menu + package body CA11003_0.CA11003_1.CA11003_2 is + + procedure News (Mode : in File_Mode; + File : out Extended_File_Type) is -- Parent type. + begin + Create_File (Mode, File); -- Parent subprogram. + if not CA11003_0.CA11003_1.CA11003_3 (File) then + raise File_Data_Error; -- Grandparent exception. + end if; + end News; + -------------------------------------------------- + procedure Copy (Original : in Extended_File_Type; + Duplicate : out Extended_File_Type) is + begin + Duplicate_File (Original, Duplicate); -- Parent subprogram. + + if Original.Descriptor = Duplicate.Descriptor then + raise File_Duplication_Error; -- Parent exception. + end if; + + end Copy; + -------------------------------------------------- + procedure Delete (File : in Extended_File_Type) is + begin + Reclaim_File_Descriptor; -- Grandparent + end Delete; -- subprogram. + + end CA11003_0.CA11003_1.CA11003_2; + + --=================================================================-- + + with CA11003_0.CA11003_1.CA11003_2; -- Grandchild Pkg OS.Operations.Menu + with CA11003_0.CA11003_1.CA11003_3; -- Grandchild Ftn OS.Operations.Validate + with Report; + + procedure CA11003 is + + package Menu renames CA11003_0.CA11003_1.CA11003_2; + + begin + + Report.Test ("CA11003", "Check that a public grandchild can utilize " & + "its ancestor unit's visible definitions"); + + File_Processing: -- Validate all of the capabilities contained in + -- the Menu package by exercising them on specific + -- files. This will demonstrate the use of child + -- and grandchild functionality based on components + -- that have been declared in the + -- parent/grandparent package. + declare + + function Validate (File : CA11003_0.CA11003_1.Extended_File_Type) + return Boolean renames CA11003_0.CA11003_1.CA11003_3; + + MacWrite_File, + Backup_Copy : CA11003_0.CA11003_1.Extended_File_Type; + MacWrite_File_Mode : CA11003_0.File_Mode := CA11003_0.Read_Write; + + begin + + Menu.News (MacWrite_File_Mode, MacWrite_File); + + if not Validate (MacWrite_File) then + Report.Failed ("Incorrect initialization of files"); + end if; + + Menu.Copy (MacWrite_File, Backup_Copy); + + if not (Validate (MacWrite_File) and + Validate (Backup_Copy)) + then + Report.Failed ("Incorrect duplication of files"); + end if; + + Menu.Delete (Backup_Copy); + + exception + when CA11003_0.File_Data_Error => + Report.Failed ("Exception raised during file validation"); + when CA11003_0.CA11003_1.File_Duplication_Error => + Report.Failed ("Exception raised during file duplication"); + when others => + Report.Failed ("Unexpected exception in test procedure"); + + end File_Processing; + + Report.Result; + + end CA11003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110040.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110040.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110040.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110040.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + -- CA110040.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA110042.AM + -- + -- TEST DESCRIPTION: + -- See CA110042.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- => CA110040.A + -- CA110041.A + -- CA110042.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma + -- Elaborate_Body. + -- + --! + + package CA110040 is -- Package Computer_System. + pragma Elaborate_Body (CA110040); + + -- Types. + type ID_Type is range 1 .. 4; + type System_Account_Capacity is new ID_Type; + + type Account is tagged + record + User_ID : ID_Type; + end record; + + -- Constants. + Maximum_System_Accounts : constant System_Account_Capacity := + System_Account_Capacity'Last; + + System_Administrator : constant ID_Type := + ID_Type (System_Account_Capacity'First); + + Administrator_Account : constant Account := + (User_ID => System_Administrator); + + -- Objects. + Total_Accounts : System_Account_Capacity := 1; + + -- Exceptions. + Illegal_Account : exception; + Account_Limit_Exceeded : exception; + + -- Subprograms. + function Next_Available_ID return ID_Type; + + end CA110040; -- Package Computer_System. + + --=================================================================-- + + package body CA110040 is -- Package body Computer_System. + + function Next_Available_ID return ID_Type is + begin + Total_Accounts := Total_Accounts + 1; + return (ID_Type(Total_Accounts)); + end Next_Available_ID; + + end CA110040; -- Package body Computer_System. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110041.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110041.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110041.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110041.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CA110041.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA110042.AM + -- + -- TEST DESCRIPTION: + -- See CA110042.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CA110040.A + -- => CA110041.A + -- CA110042.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + package CA110040.CA110041 is -- Child Package Computer_System.Manager + + type User_Account is new Account with private; + + procedure Initialize_User_Account (Acct : out User_Account); + + private + + -- The private portion of this spec demonstrates that components contained + -- in the visible part of the parent are directly visible in the private + -- part of a public child. + + type Account_Access_Type is (None, Guest, User, System); + + type User_Account is new Account with -- Parent type. + record + Privilege : Account_Access_Type := None; + end record; + + System_Account : User_Account := + (User_ID => Administrator_Account.User_ID, -- Parent constant. + Privilege => System); -- User_ID has been + -- set to 1. + Auditor_Account : User_Account := + (User_ID => Next_Available_ID, -- Parent function. + Privilege => System); -- User_ID has been + -- set to 2. + Total_Authorized_Accounts : System_Account_Capacity + renames Total_Accounts; -- Parent object. + + Unauthorized_Account : exception + renames Illegal_Account; -- Parent exception + + end CA110040.CA110041; -- Child Package Computer_System.Manager + + --=================================================================-- + + -- Child Package body Computer_System.Manager + package body CA110040.CA110041 is + + function Account_Limit_Reached return Boolean is + begin + if Total_Authorized_Accounts = Maximum_System_Accounts then + return (True); + else + return (False); + end if; + end Account_Limit_Reached; + --------------------------------------------------------------- + function Valid_Account (Acct : User_Account) return Boolean is + Result : Boolean := False; + begin + if (Acct.User_ID /= System_Account.User_ID) and + (Acct.User_ID /= Auditor_Account.User_ID) + then + Result := True; + end if; + return (Result); + end Valid_Account; + --------------------------------------------------------------- + procedure Initialize_User_Account (Acct : out User_Account) is + begin + if Account_Limit_Reached then + raise Account_Limit_Exceeded; + else + Acct.User_ID := Next_Available_ID; + Acct.Privilege := User; + end if; + if not Valid_Account (Acct) then + raise Unauthorized_Account; + end if; + end Initialize_User_Account; + + end CA110040.CA110041; -- Child Package body Computer_System.Manager diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110042.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110042.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110042.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110042.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CA110042.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the private part of a child library unit package can + -- utilize its parent unit's visible definitions. + -- + -- TEST DESCRIPTION: + -- Declare a public library unit package and child package, with the + -- child package having a private part in the specification. Within + -- this child private part, make use of components that are declared in + -- the visible part of the parent. + -- + -- Demonstrate visibility to the following parent components in the + -- child private part: + -- Parent + -- Type X + -- Constant X + -- Object X + -- Subprogram X + -- Exception X + -- + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CA110040.A + -- CA110041.A + -- => CA110042.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + with Report; + with CA110040.CA110041; + + procedure CA110042 is + + package System_Manager renames CA110040.CA110041; + use CA110040; + User1, User2, User3 : System_Manager.User_Account; + + begin + + Report.Test ("CA110042", "Check that the private part of a child " & + "library unit package can utilize its " & + "parent unit's visible definitions"); + + Assign_New_Accounts: -- This code simulates the entering of new + -- user accounts into a computer system. + -- It also simulates the processing that + -- could occur when the limit on system + -- accounts has been exceeded. + + -- This processing block demonstrates the + -- use of child package functionality that + -- takes advantage of components declared in + -- the parent package. + begin + + if Total_Accounts /= 2 then + Report.Failed ("Incorrect number of accounts currently allocated"); + end if; -- At this point, both + -- System_Account and + -- Auditor_Account have + -- been declared and + -- initialized in package + -- CA110040.CA110041. + + System_Manager.Initialize_User_Account (User1); -- User_ID has been + -- set to 3. + + System_Manager.Initialize_User_Account (User2); -- User_ID has been + -- set to 4, which + -- is the last value + -- defined for the + -- CA110040.ID_Type + -- range. + + System_Manager.Initialize_User_Account (User3); -- This final call will + -- result in an + -- Account_Limit_Exceeded + -- exception being raised. + + Report.Failed ("Control should have transferred with exception"); + + exception + + when Account_Limit_Exceeded => + if (not (Administrator_Account.User_ID = ID_Type'First)) or + (User2.User_ID /= CA110040.ID_Type'Last) + then + Report.Failed ("Account initialization failure"); + end if; + when others => + Report.Failed ("Unexpected exception raised"); + + end Assign_New_Accounts; + + if (User1.User_ID /= 3) or (User2.User_ID /= 4) then + Report.Failed ("Improper initialization of user accounts"); + end if; + + Report.Result; + + end CA110042; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110050.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110050.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110050.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110050.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- CA110050.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA110051.AM + -- + -- TEST DESCRIPTION: + -- See CA110051.AM + -- + -- TEST FILES: + -- The test consists of the following files: + -- + -- => CA110050.A + -- CA110051.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Dec 94 SAIC Modified discriminant type + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue; Added pragma + -- Elaborate_Body. + -- + --! + + package CA110050_0 is -- Package Messages. + pragma Elaborate_Body (CA110050_0); + + type Descriptor is new Integer; + + Null_Descriptor_Value : constant Descriptor := 0; + Null_Message_Descriptor : constant Descriptor := 0; + + type Message_Type is tagged + record + Number : Descriptor := Null_Message_Descriptor; + end record; + + function Next_Available_Message return Descriptor; + + end CA110050_0; -- Package Messages. + + --=================================================================-- + + package body CA110050_0 is -- Package body Messages. + + Message_Count : Integer := 0; + + function Next_Available_Message return Descriptor is + begin + Message_Count := Message_Count + 5; + return (Descriptor(Message_Count)); + end Next_Available_Message; + + end CA110050_0; -- Package body Messages. + + --=================================================================-- + + package CA110050_0.CA110050_1 is -- Child package Messages.Text + + subtype Default_Length is Natural range 0 .. 80; + + type Text_Type (Max_Length : Default_Length := 0) is + record + Length : Default_Length := Max_Length; + Text_Field : String (1 .. Max_Length); + end record; + + type Text_Message_Type is new Message_Type with + record + Text : Text_Type; + end record; + + Null_Text : Text_Type (0); -- Null range for + -- Text_Field component. + + end CA110050_0.CA110050_1; -- Child package Messages.Text + -- + -- No package body needed for this specification. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110051.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110051.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca110051.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca110051.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- CA110051.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that entities and operations declared in a package can be used + -- in the private part of a child of a child of the package. + -- + -- TEST DESCRIPTION: + -- Declare a series of library unit packages -- parent, child, and + -- grandchild. The grandchild package will have a private part. + -- From within the private part of the grandchild, make use of + -- components declared in the parent and grandparent packages. + -- + -- TEST FILES: + -- The test consists of the following files: + -- + -- CA110050.A + -- => CA110051.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Grandchild Package Message.Text.Encoded + package CA110050_0.CA110050_1.CA110050_2 is + + type Coded_Message is new Text_Message_Type with private; + + procedure Send (Message : in Coded_Message; + Confirm : out Coded_Message; + Status : out Boolean); + + function Encode (Message : Text_Message_Type) return Coded_Message; + function Decode (Message : Coded_Message) return Boolean; + function Test_Connection return Boolean; + + private + + Uncoded : Descriptor renames Null_Descriptor_Value; -- Grandparent object. + + type Coded_Message is new Text_Message_Type with -- Parent type. + record + Key : Descriptor := Uncoded; + Coded_Key : Descriptor := Next_Available_Message; + -- Grandparent type, grandparent function. + Scrambled : Text_Type := Null_Text; -- Parent object. + end record; + + Coded_Msg : Coded_Message; + + type Blank_Message is new Message_Type with -- Grandparent type. + record + ID : Descriptor := Next_Available_Message; + -- Grandparent type, grandparent function. + end record; + + Test_Message : Blank_Message; + + Confirm_String : constant String := "OK"; + Scrambled_String : constant String := "KO"; + + Confirm_Text : Text_Type (Confirm_String'Length) := + (Max_Length => Confirm_String'Length, + Length => Confirm_String'Length, + Text_Field => Confirm_String); + + Scrambled_Text : Text_Type (Scrambled_String'Length) := + (Max_Length => Scrambled_String'Length, + Length => Scrambled_String'Length, + Text_Field => Scrambled_String); + + end CA110050_0.CA110050_1.CA110050_2; -- Grandchild Pkg Message.Text.Encoded + + --=================================================================-- + + -- Grandchild Package body Message.Text.Encoded + package body CA110050_0.CA110050_1.CA110050_2 is + + procedure Send (Message : in Coded_Message; + Confirm : out Coded_Message; + Status : out Boolean) is + + Confirmation_Message : Coded_Message := + (Number => Message.Number, + Text => Confirm_Text, + Key => Message.Number, + Coded_Key => Message.Number, + Scrambled => Scrambled_Text); + + begin -- Dummy processing unit. + Confirm := Confirmation_Message; + if Confirm.Number /= Null_Message_Descriptor then + Status := True; + else + Status := False; + end if; + end Send; + ------------------------------------------------------------------------- + function Encode (Message : Text_Message_Type) return Coded_Message is + begin + Coded_Msg.Number := Message.Number; + if Message.Text.Length > 0 then + Coded_Msg.Text := Message.Text; -- Record assignment. + Coded_Msg.Key := Message.Number; -- Same as msg number. + Coded_Msg.Coded_Key := Message.Number; -- Same as msg number. + Coded_Msg.Scrambled := Message.Text; -- Dummy processing. + end if; + return (Coded_Msg); + end Encode; + ------------------------------------------------------------------------- + function Decode (Message : Coded_Message) return Boolean is + Decoded : Boolean := False; + begin + if (Message.Text.Length = Confirm_String'Length) and then + (Message.Text.Text_Field = Confirm_String) and then + (Message.Scrambled.Length = Scrambled_String'Length) and then + (Message.Scrambled.Text_Field = Scrambled_String) and then + (Message.Coded_Key = 15) + then + Decoded := True; + end if; + return (Decoded); + end Decode; + ------------------------------------------------------------------------- + function Test_Connection return Boolean is + begin + return Test_Message.Id = 10; + end Test_Connection; + + end CA110050_0.CA110050_1.CA110050_2; + -- Grandchild Package body Message.Text.Encoded + + --=================================================================-- + + with CA110050_0.CA110050_1.CA110050_2; + with Report; + + procedure CA110051 is + + package Message_Package renames CA110050_0.CA110050_1; + package Code_Package renames CA110050_0.CA110050_1.CA110050_2; + + Message_String : constant String := "One if by land, two if by sea"; + + Message_Text : Message_Package.Text_Type (Message_String'Length) := + (Max_Length => Message_String'Length, + Length => Message_String'Length, + Text_Field => Message_String); + + Message : Message_Package.Text_Message_Type := + (Number => CA110050_0.Next_Available_Message, + Text => Message_Text); + + Confirmation_Message : Code_Package.Coded_Message; + Verification_OK : Boolean := False; + Transmission_OK : Boolean := False; + + begin + + -- This test simulates the use of child library unit packages to implement + -- a message encoding and transmission scheme. The full capability of the + -- encoding and transmission mechanisms are not developed here, but the + -- intent is to demonstrate that a grandchild library unit package with a + -- private part will provide the framework for this type of processing. + + Report.Test ("CA110051", "Check that entities and operations declared " & + "in a package can be used in the private part " & + "of a child of a child of the package"); + + -- The following code demonstrates the use + -- of functionality contained in a grandchild + -- library unit. The grandchild unit made use + -- of components declared in the ancestor + -- packages. + + Code_Package.Send -- Message object declared + (Message => Code_Package.Encode (Message), -- above in "encoded" by a + Confirm => Confirmation_Message, -- call to grandchild pkg + Status => Transmission_OK); -- function call, reseting + -- fields and returning a + -- coded message to the + -- parameter. The confirm + -- parameter receives an + -- encoded message value + -- from proc Send, which is + -- "decoded"/verified below. + + if not Code_Package.Test_Connection then + Report.Failed ("Bad initialization"); + end if; + + Verification_OK := Code_Package.Decode (Confirmation_Message); + + if not (Transmission_OK and Verification_OK) then + Report.Failed ("Message transmission failure"); + end if; + + Report.Result; + + end CA110051; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11006.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,211 ---- + -- CA11006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the private part of a child library unit can utilize + -- its parent unit's private definition. + -- + -- TEST DESCRIPTION: + -- Declare a package and public child package, both with private + -- parts. The child package will have a private extension of a type + -- declared in the parent's private part. In addition, the private + -- part of the child package specification will make use of some of + -- the components declared in the private part of the parent. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + package CA11006_0 is -- Package File_Package + + type File_Descriptor is private; + type File_Mode is (Read_Only, Write_Only, Read_Write); + type File_Type is tagged private; + + function Next_Available_File return File_Descriptor; + + private + + type File_Measure is range 0 .. 1000; + type File_Descriptor is new Integer; + + Null_File : constant File_Descriptor := 0; + Default_Mode : constant File_Mode := Read_Write; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + Mode : File_Mode := Default_Mode; + end record; + + System_File : File_Type; + + end CA11006_0; -- Package File_Package + + --=================================================================-- + + package body CA11006_0 is -- Package File_Package + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return File_Descriptor (File_Count); + end Next_Available_File; + + end CA11006_0; -- Package File_Package + + --=================================================================-- + + package CA11006_0.CA11006_1 is -- Child package File_Package.Operations + + type File_Length_Type is private; + type Extended_File_Type is new File_Type with private; + + System_Extended_File : constant Extended_File_Type; + + procedure Create_File (Mode : in File_Mode; + File : out Extended_File_Type); + + procedure Compress_File (Original : in Extended_File_Type; + Compressed_File : out Extended_File_Type); + + function Validate (File : in Extended_File_Type) return Boolean; + + function Validate_Compression (File : in Extended_File_Type) + return Boolean; + -- These two validation functions provide + -- the capability to check the private + -- components defined in the parent and + -- child packages from within the client + -- program. + private + + type File_Length_Type is new File_Measure; -- Parent private type. + + Min_File_Size : File_Length_Type := File_Length_Type'First; + Max_File_Size : File_Length_Type := File_Length_Type'Last; + + type Extended_File_Type is new File_Type with -- Parent type. + record + Blocks : File_Length_Type := Min_File_Size; + end record; + + System_Extended_File : constant Extended_File_Type := + (Descriptor => System_File.Descriptor, -- Parent private object. + Mode => Read_Only, -- Parent enumeration literal. + Blocks => Min_File_Size); + + + end CA11006_0.CA11006_1; -- Child Package File_Package.Operations + + --=================================================================-- + + -- Child package body File_Package.Operations + package body CA11006_0.CA11006_1 is + + procedure Create_File + (Mode : in File_Mode; + File : out Extended_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Parent subprogram. + File.Mode := Default_Mode; -- Parent private constant. + File.Blocks := Max_File_Size; + end Create_File; + ------------------------------------------------------------------------ + procedure Compress_File (Original : in Extended_File_Type; + Compressed_File : out Extended_File_Type) is + begin + Compressed_File.Descriptor := Next_Available_File; + Compressed_File.Mode := Read_Only; + Compressed_File.Blocks := Original.Blocks / 2; -- Simulated file + end Compress_File; -- compression. + ------------------------------------------------------------------------ + function Validate (File : in Extended_File_Type) return Boolean is + begin + if ((File.Descriptor /= System_Extended_File.Descriptor) and + (File.Mode = Read_Write) and + (File.Blocks = Max_File_Size)) then + return True; + else + return False; + end if; + end Validate; + ------------------------------------------------------------------------ + function Validate_Compression (File : in Extended_File_Type) + return Boolean is + begin + if ((File.Descriptor /= System_File.Descriptor) and + (File.Mode = Read_Only) and + (File.Blocks = Max_File_Size/2)) then + return True; + else + return False; + end if; + end Validate_Compression; + + end CA11006_0.CA11006_1; -- Child package body File_Package.Operations + + --=================================================================-- + + with CA11006_0.CA11006_1; -- with Child package File_Package.Operations + with Report; + + procedure CA11006 is + + package File renames CA11006_0; + package File_Ops renames CA11006_0.CA11006_1; + + Validation_File_Mode : File.File_Mode := File.Read_Only; + Validation_File, + Storage_Copy : File_Ops.Extended_File_Type; + + begin + + Report.Test ("CA11006", "Check that the private part of a child " & + "library unit can utilize its parent " & + "unit's private definition"); + + File_Ops.Create_File (Validation_File_Mode, Validation_File); + + if not File_Ops.Validate (Validation_File) then + Report.Failed ("Incorrect initialization of file"); + end if; + + File_Ops.Compress_File (Validation_File, Storage_Copy); + + if not (File_Ops.Validate (Validation_File) and + File_Ops.Validate_Compression (Storage_Copy)) + then + Report.Failed ("Incorrect compression of file"); + end if; + + Report.Result; + + end CA11006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11007.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,228 ---- + -- CA11007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the private part of a grandchild library unit can + -- utilize its grandparent unit's private definition. + -- + -- TEST DESCRIPTION: + -- Declare a package, child package, and grandchild package, all + -- with private parts in their specifications. + -- + -- The private part of the grandchild package will make use of components + -- that have been declared in the private part of the grandparent + -- specification. + -- + -- The child package demonstrates the extension of a parent file type + -- into an abstraction of an analog file structure. The grandchild package + -- extends the grandparent file type into an abstraction of a digital + -- file structure, and provides conversion capability to/from the parent + -- analog file structure. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11007_0 is -- Package File_Package + + type File_Descriptor is private; + type File_Type is tagged private; + + function Next_Available_File return File_Descriptor; + + private + + type File_Measure_Type is range 0 .. 1000; + type File_Descriptor is new Integer; + + Null_Measure : constant File_Measure_Type := File_Measure_Type'First; + Null_File : constant File_Descriptor := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor := Null_File; + end record; + + end CA11007_0; -- Package File_Package + + --=================================================================-- + + package body CA11007_0 is -- Package body File_Package + + File_Count : Integer := 0; + + function Next_Available_File return File_Descriptor is + begin + File_Count := File_Count + 1; + return File_Descriptor (File_Count); + end Next_Available_File; + + end CA11007_0; -- Package body File_Package + + --=================================================================-- + + package CA11007_0.CA11007_1 is -- Child package Analog + + type Analog_File_Type is new File_Type with private; + + private + + type Wavelength_Type is new File_Measure_Type; + + Min_Wavelength : constant Wavelength_Type := Wavelength_Type'First; + + type Analog_File_Type is new File_Type with -- Parent type. + record + Wavelength : Wavelength_Type := Min_Wavelength; + end record; + + end CA11007_0.CA11007_1; -- Child package Analog + + --=================================================================-- + + package CA11007_0.CA11007_1.CA11007_2 is -- Grandchild package Digital + + type Digital_File_Type is new File_Type with private; + + procedure Recording (File : out Digital_File_Type); + + procedure Convert (From : in Analog_File_Type; + To : out Digital_File_Type); + + function Validate (File : in Digital_File_Type) return Boolean; + function Valid_Conversion (To : Digital_File_Type) return Boolean; + function Valid_Initial (From : Analog_File_Type) return Boolean; + + private + + type Track_Type is new File_Measure_Type; -- Grandparent type. + + Min_Tracks : constant Track_Type := + Track_Type (Null_Measure) + Track_Type'First; -- Grandparent private + Max_Tracks : constant Track_Type := -- constant. + Track_Type (Null_Measure) + Track_Type'Last; + + type Digital_File_Type is new File_Type with -- Grandparent type. + record + Tracks : Track_Type := Min_Tracks; + end record; + + end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package Digital + + --=================================================================-- + + -- Grandchild package body Digital + package body CA11007_0.CA11007_1.CA11007_2 is + + procedure Recording (File : out Digital_File_Type) is + begin + File.Descriptor := Next_Available_File; -- Assign new file descriptor. + File.Tracks := Max_Tracks; -- Change initial value. + end Recording; + -------------------------------------------------------------------------- + procedure Convert (From : in Analog_File_Type; + To : out Digital_File_Type) is + begin + To.Descriptor := From.Descriptor + 100; -- Dummy conversion. + To.Tracks := Track_Type (From.Wavelength) / 2; + end Convert; + -------------------------------------------------------------------------- + function Validate (File : in Digital_File_Type) return Boolean is + Result : Boolean := False; + begin + if not (File.Tracks /= Max_Tracks) then + Result := True; + end if; + return Result; + end Validate; + -------------------------------------------------------------------------- + function Valid_Conversion (To : Digital_File_Type) return Boolean is + begin + return (To.Descriptor = 100) and (To.Tracks = (Min_Tracks / 2)); + end Valid_Conversion; + -------------------------------------------------------------------------- + function Valid_Initial (From : Analog_File_Type) return Boolean is + begin + return (From.Wavelength = Min_Wavelength); -- Validate initial + end Valid_Initial; -- conditions. + + end CA11007_0.CA11007_1.CA11007_2; -- Grandchild package body Digital + + --=================================================================-- + + with CA11007_0.CA11007_1.CA11007_2; -- with Grandchild package Digital + with Report; + + procedure CA11007 is + + package Analog renames CA11007_0.CA11007_1; + package Digital renames CA11007_0.CA11007_1.CA11007_2; + + Original_Digital_File, + Converted_Digital_File : Digital.Digital_File_Type; + + Original_Analog_File : Analog.Analog_File_Type; + + begin + + -- This code demonstrates how private extensions could be utilized + -- in child packages to allow for recording on different media. + -- The processing contained in the procedures and functions is + -- "dummy" processing, not intended to perform actual recording, + -- conversion, or validation operations, but simply to demonstrate + -- this type of structural decomposition as a possible solution to + -- a user's design problem. + + Report.Test ("CA11007", "Check that the private part of a grandchild " & + "library unit can utilize its grandparent " & + "unit's private definition"); + + if not Digital.Valid_Initial (Original_Analog_File) + then + Report.Failed ("Incorrect initialization of Analog File"); + end if; + + --- + + Digital.Convert (From => Original_Analog_File, -- Convert file to + To => Converted_Digital_File); -- digital format. + + if not Digital.Valid_Conversion (To => Converted_Digital_File) then + Report.Failed ("Incorrect conversion of analog file"); + end if; + + --- + + Digital.Recording (Original_Digital_File); -- Create file in + -- digital format. + if not Digital.Validate (Original_Digital_File) then + Report.Failed ("Incorrect recording of digital file"); + end if; + + Report.Result; + + end CA11007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11008.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- CA11008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private child package can use entities declared in the + -- visible part of its parent unit. + -- + -- TEST DESCRIPTION: + -- Declare a parent package containing types and objects used + -- by the system. Declare a private child package that uses the parent + -- components to provide functionality to the system. + -- + -- The tagged file type defined in the parent has defaults for all + -- component fields. Prior to initialization, these values are checked + -- to ensure a correct start condition. The initial subprogram is + -- called, which utilizes the functionality provided in the private + -- child package. This subprogram changes the fields of the file object + -- to something other than the default values, and this process is then + -- verified at the conclusion of the test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11008_0 is -- Package OS. + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System, Bypass); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Max_Files : constant File_Descriptor_Type := 100; + Constant_Name : constant File_Name_Type := "AdaFileName"; + File_Counter : Integer := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + + -- + + function Get_File_Name return File_Name_Type; + + function Initialize_File return File_Descriptor_Type; + + end CA11008_0; -- Package OS. + + --=================================================================-- + + -- Subprograms that perform the actual file operations are contained in a + -- private package so that they are not accessible to any client. + + private package CA11008_0.CA11008_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent + -- object. + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function. + File_Mode : File_Mode_Type := Read_Write) -- Parent literal. + return File_Descriptor_Type; -- Parent type. + + end CA11008_0.CA11008_1; -- Package OS.Internals + + --=================================================================-- + + package body CA11008_0.CA11008_1 is -- Package body OS.Internals + + function Next_Available_File return File_Descriptor_Type is + begin + Private_File_Counter := Private_File_Counter + 1; + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ----------------------------------------------------------------- + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent function + File_Mode : File_Mode_Type := Read_Write) -- Parent literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent object + File_Table(Number).Name := File_Name; -- Default parameter value + File_Table(Number).Mode := File_Mode; -- Default parameter value + File_Table(Number).Acct_Access := User; + File_Table(Number).Current_Status := Open; + return (Number); + end Initialize; + + end CA11008_0.CA11008_1; -- Package body OS.Internals + + --=================================================================-- + + with CA11008_0.CA11008_1; -- Private child package "withed" by + -- parent body. + + package body CA11008_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (Constant_Name); -- Of course if this was a real function, the + end Get_File_Name; -- user would be asked to input a name, or + -- there would be some type of similar process. + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + function Initialize_File return File_Descriptor_Type is + begin + return (CA11008_0.CA11008_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + + end CA11008_0; -- Package body OS + + --=================================================================-- + + with CA11008_0; -- with Package OS. + with Report; + + procedure CA11008 is + + package OS renames CA11008_0; + use OS; + Ada_File_Key : File_Descriptor_Type := Default_Descriptor; + + begin + + -- This test indicates one approach to file management operations. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a user situation, that being the implementation of certain functions + -- being provided in a child package, with the parent package body + -- utilizing these implementations. + + Report.Test ("CA11008", "Check that a private child package can use " & + "entities declared in the visible part of its " & + "parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + if (Ada_File_Key /= Default_Descriptor) or else + (File_Table(1).Descriptor /= (Default_Descriptor) or + (File_Table(1).Name /= Default_Filename)) or else + (File_Table(1).Acct_Access /= (Default_Permission) or + (File_Table(1).Mode /= Default_Mode)) or else + (File_Table(1).Current_Status /= Default_Status) + then + Report.Failed ("Initial condition failure"); + end if; + + -- Call the initialization function. This will result in the resetting + -- of the fields associated with the first entry in the File_Table (this + -- is the first call of Initialize_File). + -- No parameters are necessary for this call, due to the default values + -- provided in the private child package routine Initialize. + + Ada_File_Key := Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not ((File_Table(1).Descriptor = Ada_File_Key) and then + (File_Table(1).Name = Constant_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + + end CA11008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11009.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,246 ---- + -- CA11009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private child package can use entities declared in the + -- visible part of the parent unit of its parent unit. + -- + -- TEST DESCRIPTION: + -- Declare a parent package containing types and objects used by the + -- system. Declare a public child package that provides a visible + -- interface to the system functionality. + -- Declare a private grandchild package that uses the visible grandparent + -- components to provide the actual functionality to the system. + -- + -- The public child (parent of the private grandchild) uses the + -- functionality of its private child (grandchild package) to provide + -- the visible interface to operations of the system. + -- + -- The test itself will utilize the visible interface provided in the + -- public child package to demonstrate a possible structure for + -- file management. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate_body. + -- + --! + + package CA11009_0 is -- Package OS. + pragma Elaborate_Body (CA11009_0); + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System, Bypass); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Max_Files : constant File_Descriptor_Type := 10; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + File_Counter : Integer := 0; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + + -- + + function Get_File_Name return File_Name_Type; + + end CA11009_0; -- Package OS. + + --=================================================================-- + + package body CA11009_0 is -- Package body OS. + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); -- Processing would be replace by a user + -- prompt in a functioning system. + end Get_File_Name; + + end CA11009_0; -- Package body OS. + + --=================================================================-- + + package CA11009_0.CA11009_1 is -- Child Package OS.File_Manager + + -- This package simulates a visible interface for the Operating System. + -- The actual processing performed by this routine is encapsulated + -- in the routines of private child package Internals, which is "withed" + -- by the body of this package. + + procedure Create_File (Mode : in File_Mode_Type; + File_Key : out File_Descriptor_Type); + + end CA11009_0.CA11009_1; -- Child Package OS.File_Manager + + --=================================================================-- + + -- Subprogram that performs the actual file operation is contained in a + -- private package so that it is not accessible to any client, and can be + -- modified/extended without requiring recompilation of the clients of the + -- parent (since this package is "withed" by the parent body only.) + + + -- Grandchild Package OS.File_Manager.Internals + private package CA11009_0.CA11009_1.CA11009_2 is + + Initial_Permission : constant Permission_Type := User; -- Grandparent + Initial_Status : constant File_Status_Type := Open; -- literals. + Initial_Filename : constant File_Name_Type := -- Grandparent type. + Get_File_Name; -- Grandparent function. + + function Create (Mode : File_Mode_Type) + return File_Descriptor_Type; -- Grandparent type. + + end CA11009_0.CA11009_1.CA11009_2; + -- Grandchild Package OS.File_Manager.Internals + + --=================================================================-- + + -- Grandchild Package body OS.File_Manager.Internals + package body CA11009_0.CA11009_1.CA11009_2 is + + function Next_Available_File return File_Descriptor_Type is + begin + File_Counter := File_Counter + 1; -- Grandparent object. + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ------------------------------------------------------------------------- + function Create (Mode : File_Mode_Type) -- Grandparent literal. + return File_Descriptor_Type is + Number : File_Descriptor_Type; -- Grandparent type. + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Grandparent object. + File_Table(Number).Name := Initial_Filename; + File_Table(Number).Mode := Mode; -- Parameter. + File_Table(Number).Acct_Access := Initial_Permission; + File_Table(Number).Current_Status := Initial_Status; + return (Number); + end Create; + + end CA11009_0.CA11009_1.CA11009_2; + -- Grandchild Package body OS.File_Manager.Internals + + --=================================================================-- + + -- "With" of a child package + -- by the parent body. + with CA11009_0.CA11009_1.CA11009_2; -- Grandchild OS.File_Manager.Internals + + package body CA11009_0.CA11009_1 is -- Child Package body OS.File_Manager + + package Internal renames CA11009_0.CA11009_1.CA11009_2; + + -- These subprograms utilize calls to subprograms contained in a private + -- sibling to perform the actual processing. + + procedure Create_File (Mode : in File_Mode_Type; + File_Key : out File_Descriptor_Type) is + begin + File_Key := Internal.Create (Mode); + end Create_File; + + end CA11009_0.CA11009_1; -- Child Package body OS.File_Manager + + --=================================================================-- + + with CA11009_0.CA11009_1; -- with Child Package OS.File_Manager + with Report; + + procedure CA11009 is + + package OS renames CA11009_0; + use OS; + package File_Manager renames CA11009_0.CA11009_1; + + Data_Base_File_Key : File_Descriptor_Type := Default_Descriptor; + New_Mode : File_Mode_Type := Read_Write; + + begin + + -- This test indicates one approach to file management. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package could provide a solution + -- to this type of situation. + + Report.Test ("CA11009", "Check that a private child package can use " & + "entities declared in the visible part of the " & + "parent unit of its parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + if (not (Data_Base_File_Key = Default_Descriptor)) and then + (((not (File_Table(1).Name = Default_Filename)) or + (File_Table(1).Descriptor /= Default_Descriptor)) or else + ((File_Table(1).Acct_Access /= Default_Permission) or + (not (File_Table(1).Mode = Default_Mode)) or + (File_Table(1).Current_Status /= Default_Status))) + then + Report.Failed ("Initial condition failure"); + end if; + + -- Create/initialize file using the capability provided by the visible + -- interface to the operating system, OS.File_Manager. The actual + -- processing routine is contained in the private grandchild package + -- Internals, which utilize the components from the grandparent package. + + File_Manager.Create_File (New_Mode, Data_Base_File_Key); + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not ((File_Table(1).Descriptor = Data_Base_File_Key) and then + (File_Table(1).Name = An_Ada_File_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + Report.Failed ("File creation failure"); + end if; + + Report.Result; + + end CA11009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11010.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,254 ---- + -- CA11010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private child package can use entities declared in the + -- private part of its parent unit. + -- + -- TEST DESCRIPTION: + -- Declare a parent package containing private types, objects, + -- and functions used by the system. Declare a private child package that + -- uses the parent components to provide functionality to the system. + -- + -- Declare an array of files with default values for all + -- component fields of the files (records). Check the initial state of + -- a specified file for proper default values. Perform the file "creation" + -- (initialization), which will modify the fields of the record object. + -- Again verify the file object to determine whether the fields have been + -- reset properly. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + + package CA11010_0 is -- Package OS. + + type File_Descriptor_Type is private; + + Default_Descriptor : constant File_Descriptor_Type; + + function Initialize_File return File_Descriptor_Type; + procedure Verify_Initial_Conditions (Status : out Boolean); + function Final_Conditions_Valid return Boolean; + + private + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + Max_Files : constant File_Descriptor_Type := 100; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + File_Counter : Integer := 0; + + -- + + function Get_File_Name return File_Name_Type; + + end CA11010_0; -- Package OS. + + --=================================================================-- + + -- Subprograms that perform the actual file operations are contained in a + -- private package so that they are not accessible to any client. + + private package CA11010_0.CA11010_1 is -- Package OS.Internals + + Private_File_Counter : Integer renames File_Counter; -- Parent priv. object. + + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function. + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal. + return File_Descriptor_Type; -- Parent type. + + end CA11010_0.CA11010_1; -- Package OS.Internals + + --=================================================================-- + + package body CA11010_0.CA11010_1 is -- Package body OS.Internals + + function Next_Available_File return File_Descriptor_Type is + begin + Private_File_Counter := Private_File_Counter + 1; + return (File_Descriptor_Type(File_Counter)); + end Next_Available_File; + ---------------------------------------------------------------- + function Initialize + (File_Name : File_Name_Type := Get_File_Name; -- Parent priv. function + File_Mode : File_Mode_Type := Read_Write) -- Parent priv. literal + return File_Descriptor_Type is -- Parent type + Number : File_Descriptor_Type; + begin + Number := Next_Available_File; + File_Table(Number).Descriptor := Number; -- Parent priv. object + File_Table(Number).Name := File_Name; -- Default parameter value + File_Table(Number).Mode := File_Mode; -- Default parameter value + File_Table(Number).Acct_Access := User; + File_Table(Number).Current_Status := Open; + return (Number); + end Initialize; + + end CA11010_0.CA11010_1; -- Package body OS.Internals + + --=================================================================-- + + with CA11010_0.CA11010_1; -- Private child package "withed" by + -- parent body. + + package body CA11010_0 is -- Package body OS + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); -- If this was a real function, the user + end Get_File_Name; -- would be asked to input a name, or there + -- would be some type of similar processing. + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + function Initialize_File return File_Descriptor_Type is + begin + return (CA11010_0.CA11010_1.Initialize); -- No parameters are needed, + -- since defaults have been + -- provided. + end Initialize_File; + + -- + -- Separate subunits. + -- + + procedure Verify_Initial_Conditions (Status : out Boolean) is separate; + + function Final_Conditions_Valid return Boolean is separate; + + end CA11010_0; -- Package body OS + + --=================================================================-- + + separate (CA11010_0) + procedure Verify_Initial_Conditions (Status : out Boolean) is + begin + Status := False; + if (File_Table(1).Descriptor = Default_Descriptor) and then + (File_Table(1).Name = Default_Filename) and then + (File_Table(1).Acct_Access = Default_Permission) and then + (File_Table(1).Mode = Default_Mode) and then + (File_Table(1).Current_Status = Default_Status) + then + Status := True; + end if; + end Verify_Initial_Conditions; + + --=================================================================-- + + separate (CA11010_0) + function Final_Conditions_Valid return Boolean is + begin + if ((File_Table(1).Descriptor /= Default_Descriptor) and then + (File_Table(1).Name = An_Ada_File_Name) and then + (File_Table(1).Acct_Access = User) and then + not ((File_Table(1).Mode = Default_Mode) or else + (File_Table(1).Current_Status = Default_Status))) + then + return (True); + else + return (False); + end if; + end Final_Conditions_Valid; + + --=================================================================-- + + with CA11010_0; -- with Package OS. + with Report; + + procedure CA11010 is + + package OS renames CA11010_0; + + Ada_File_Key : OS.File_Descriptor_Type := OS.Default_Descriptor; + Initialization_Status : Boolean := False; + + begin + + -- This test indicates one approach to a file management operation. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a user situation, that being the implementation of certain functions + -- being provided in a child package, with the parent package body + -- utilizing these implementations. + + Report.Test ("CA11010", "Check that a private child package can use " & + "entities declared in the private part of its " & + "parent unit"); + + -- Check initial conditions of the first entry in the file table. + -- These are all default values provided in the declaration of the + -- type File_Type. + + OS.Verify_Initial_Conditions (Initialization_Status); + + if not Initialization_Status then + Report.Failed ("Initial condition failure"); + end if; + + -- Call the initialization function. This will result in the resetting + -- of the fields associated with the first entry in the File_Table (this + -- is the first/only call of Initialize_File). + -- No parameters are necessary for this call, due to the default values + -- provided in the private child package routine Initialize. + + Ada_File_Key := OS.Initialize_File; + + -- Verify that the initial conditions of the file table component have + -- been properly modified by the initialization function. + + if not OS.Final_Conditions_Valid then + Report.Failed ("Initialization processing failure"); + end if; + + Report.Result; + + end CA11010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11011.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,271 ---- + -- CA11011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a private child package can use entities declared in the + -- private part of the parent unit of its parent unit. + -- + -- TEST DESCRIPTION: + -- Declare a parent package containing private types and objects + -- used by the system. Declare a public child package that + -- provides a visible interface to the system functionality. + -- Declare a private grandchild package that uses the visible grandparent + -- components to provide the actual functionality to the system. + -- + -- The public child (parent of the private grandchild) uses the + -- functionality of its private child (grandchild package) to provide + -- the visible interface to operations of the system. + -- + -- The test itself will utilize the visible interface provided in the + -- public child package to demonstrate a possible solution to file + -- management. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11011_0 is -- Package OS. + + type File_Descriptor_Type is private; + + Default_Descriptor : constant File_Descriptor_Type; + First_File : constant File_Descriptor_Type; + + procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; + Status : out Boolean); + + function Final_Conditions_Valid (Key : File_Descriptor_Type) + return Boolean; + + + private + + type File_Descriptor_Type is new Integer; + type File_Name_Type is new String (1 .. 11); + type Permission_Type is (None, User, System); + type File_Mode_Type is (Read_Only, Write_Only, Read_Write); + type File_Status_Type is (Open, Closed); + + Default_Descriptor : constant File_Descriptor_Type := 0; + First_File : constant File_Descriptor_Type := 1; + Default_Permission : constant Permission_Type := None; + Default_Mode : constant File_Mode_Type := Read_Only; + Default_Status : constant File_Status_Type := Closed; + Default_Filename : constant File_Name_Type := " "; + + Init_Permission : constant Permission_Type := User; + Init_Mode : constant File_Mode_Type := Read_Write; + Init_Status : constant File_Status_Type := Open; + An_Ada_File_Name : constant File_Name_Type := "AdaFileName"; + + Max_Files : constant File_Descriptor_Type := 10; + + type File_Type is tagged + record + Descriptor : File_Descriptor_Type := Default_Descriptor; + Name : File_Name_Type := Default_Filename; + Acct_Access : Permission_Type := Default_Permission; + Mode : File_Mode_Type := Default_Mode; + Current_Status : File_Status_Type := Default_Status; + end record; + + type File_Array_Type is array (1 .. Max_Files) of File_Type; + + File_Table : File_Array_Type; + File_Counter : Integer := 0; + + -- + + function Get_File_Name return File_Name_Type; + + end CA11011_0; -- Package OS. + + --=================================================================-- + + package body CA11011_0 is -- Package body OS. + + function Get_File_Name return File_Name_Type is + begin + return (An_Ada_File_Name); + end Get_File_Name; + --------------------------------------------------------------------- + procedure Verify_Initial_Conditions (Key : in File_Descriptor_Type; + Status : out Boolean) is + begin + Status := False; + if (File_Table(Key).Descriptor = Default_Descriptor) and then + (File_Table(Key).Name = Default_Filename) and then + (File_Table(Key).Acct_Access = Default_Permission) and then + (File_Table(Key).Mode = Default_Mode) and then + (File_Table(Key).Current_Status = Default_Status) + then + Status := True; + end if; + end Verify_Initial_Conditions; + --------------------------------------------------------------------- + function Final_Conditions_Valid (Key : File_Descriptor_Type) + return Boolean is + begin + if ((File_Table(Key).Descriptor = First_File) and then + (File_Table(Key).Name = An_Ada_File_Name) and then + (File_Table(Key).Acct_Access = Init_Permission) and then + not ((File_Table(Key).Mode = Default_Mode) or else + (File_Table(Key).Current_Status = Default_Status))) + then + return (True); + else + return (False); + end if; + end Final_Conditions_Valid; + + end CA11011_0; -- Package body OS. + + --=================================================================-- + + package CA11011_0.CA11011_1 is -- Package OS.File_Manager + + procedure Create_File (File_Key : in File_Descriptor_Type); + + end CA11011_0.CA11011_1; -- Package OS.File_Manager + + --=================================================================-- + + -- The Subprogram that performs the actual file operations is contained in a + -- private package so that it is not accessible to any client. + -- Default parameters are used in most cases in the subprogram calls, since + -- the caller does not have visibility to these private types. + + -- Package OS.File_Manager.Internals + private package CA11011_0.CA11011_1.CA11011_2 is + + Private_File_Counter : Integer renames File_Counter; -- Grandparent + -- object. + procedure Create + (Key : in File_Descriptor_Type; + File_Name : in File_Name_Type := Get_File_Name; -- Grandparent + -- prvt type, + -- prvt functn. + File_Mode : in File_Mode_Type := Init_Mode; -- Grandparent + -- prvt type, + -- prvt const. + File_Access : in Permission_Type := Init_Permission; -- Grandparent + -- prvt type, + -- prvt const. + File_Status : in File_Status_Type := Init_Status); -- Grandparent + -- prvt type, + -- prvt const. + + end CA11011_0.CA11011_1.CA11011_2; -- Package OS.File_Manager.Internals + + --=================================================================-- + + -- Package Body OS.File_Manager.Internals + package body CA11011_0.CA11011_1.CA11011_2 is + + procedure Create + (Key : in File_Descriptor_Type; + File_Name : in File_Name_Type := Get_File_Name; + File_Mode : in File_Mode_Type := Init_Mode; + File_Access : in Permission_Type := Init_Permission; + File_Status : in File_Status_Type := Init_Status) is + begin + Private_File_Counter := Private_File_Counter + 1; + File_Table(Key).Descriptor := Key; -- Grandparent object. + File_Table(Key).Name := File_Name; + File_Table(Key).Mode := File_Mode; + File_Table(Key).Acct_Access := File_Access; + File_Table(Key).Current_Status := File_Status; + end Create; + + end CA11011_0.CA11011_1.CA11011_2; -- Package body OS.File_Manager.Internals + + --=================================================================-- + + with CA11011_0.CA11011_1.CA11011_2; -- with Child OS.File_Manager.Internals + + package body CA11011_0.CA11011_1 is -- Package body OS.File_Manager + + package Internal renames CA11011_0.CA11011_1.CA11011_2; + + -- This subprogram utilizes a call to a subprogram contained in a private + -- child to perform the actual processing. + + procedure Create_File (File_Key : in File_Descriptor_Type) is + begin + Internal.Create (Key => File_Key); -- Other parameters are defaults, + -- since they are of private types + -- from the parent package. + -- File_Descriptor_Type is private, + -- but declared in visible part of + -- parent spec. + end Create_File; + + end CA11011_0.CA11011_1; -- Package body OS.File_Manager + + --=================================================================-- + + with CA11011_0.CA11011_1; -- with public Child Package OS.File_Manager + with Report; + + procedure CA11011 is + + package OS renames CA11011_0; + package File_Manager renames CA11011_0.CA11011_1; + + Data_Base_File_Key : OS.File_Descriptor_Type := OS.First_File; + TC_Status : Boolean := False; + + begin + + -- This test indicates one approach to file management operations. + -- It is not intended to demonstrate full functionality, but rather + -- that the use of a private child package can provide a solution + -- to a typical user situation. + + Report.Test ("CA11011", "Check that a private child package can use " & + "entities declared in the private part of the " & + "parent unit of its parent unit"); + + OS.Verify_Initial_Conditions (Data_Base_File_Key, TC_Status); + + if not TC_Status then + Report.Failed ("Initial condition failure"); + end if; + + -- Perform file initializations. + + File_Manager.Create_File (File_Key => Data_Base_File_Key); + + TC_Status := OS.Final_Conditions_Valid (Data_Base_File_Key); + + if not TC_Status then + Report.Failed ("Bad status return from Create_File"); + end if; + + Report.Result; + + end CA11011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11012.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- CA11012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a child package of a library level instantiation + -- of a generic can be the instantiation of a child package of + -- the generic. Check that the child instance can use its parent's + -- declarations and operations, including a formal type of the parent. + -- + -- TEST DESCRIPTION: + -- Declare a generic package which simulates an integer complex + -- abstraction. Declare a generic child package of this package + -- which defines additional complex operations. + -- + -- Instantiate the first generic package, then instantiate the child + -- generic package as a child unit of the first instance. In the main + -- program, check that the operations in both instances perform as + -- expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Dec 94 SAIC Corrected visibility errors for literals + -- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11012_3 + --! + + generic -- Complex number abstraction. + type Int_Type is range <>; + + package CA11012_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is private; + + Zero : constant Complex_Type; -- Real number (0,0). + + function Complex (Real, Imag : Int_Type) -- Create a complex + return Complex_Type; -- number. + + function "-" (Right : Complex_Type) -- Invert a complex + return Complex_Type; -- number. + + function "+" (Left, Right : Complex_Type) -- Add two complex + return Complex_Type; -- numbers. + + private + type Complex_Type is record + Real : Int_Type; + Imag : Int_Type; + end record; + + Zero : constant Complex_Type := (Real => 0, Imag => 0); + + end CA11012_0; + + --==================================================================-- + + package body CA11012_0 is + + function Complex (Real, Imag : Int_Type) return Complex_Type is + begin + return (Real, Imag); + end Complex; + --------------------------------------------------------------- + function "-" (Right : Complex_Type) return Complex_Type is + begin + return (-Right.Real, -Right.Imag); + end "-"; + --------------------------------------------------------------- + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + + end CA11012_0; + + --==================================================================-- + + -- Generic child of complex number package. Child must be generic since + -- parent is generic. + + generic -- Complex additional operations + + package CA11012_0.CA11012_1 is + + -- More operations on complex number. This child adds a layer of + -- functionality to the parent generic. + + function Real_Part (Complex_No : Complex_Type) + return Int_Type; + + function Imag_Part (Complex_No : Complex_Type) + return Int_Type; + + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type; + + function Vector_Magnitude (Complex_No : Complex_Type) + return Int_Type; + + end CA11012_0.CA11012_1; + + --==================================================================-- + + package body CA11012_0.CA11012_1 is + + function Real_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Real); + end Real_Part; + --------------------------------------------------------------- + function Imag_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Imag); + end Imag_Part; + --------------------------------------------------------------- + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type is + Result : Complex_Type := Zero; -- Zero is declared in parent, + -- Complex_Number + begin + for I in 1 .. abs (Factor) loop + Result := Result + C; -- Complex_Number "+" + end loop; + + if Factor < 0 then + Result := - Result; -- Complex_Number "-" + end if; + + return Result; + end "*"; + --------------------------------------------------------------- + function Vector_Magnitude (Complex_No : Complex_Type) + return Int_Type is -- Not a real vector magnitude. + begin + return (Complex_No.Real + Complex_No.Imag); + end Vector_Magnitude; + + end CA11012_0.CA11012_1; + + --==================================================================-- + + package CA11012_2 is + + subtype My_Integer is integer range -100 .. 100; + + -- ... Various other types used by the application. + + end CA11012_2; + + -- No body for CA11012_2; + + --==================================================================-- + + -- Declare instances of the generic complex packages for integer type. + -- The instance of the child must itself be declared as a child of the + -- instance of the parent. + + with CA11012_0; -- Complex number abstraction + with CA11012_2; -- Package containing integer type + pragma Elaborate (CA11012_0); + package CA11012_3 is new CA11012_0 (Int_Type => CA11012_2.My_Integer); + + with CA11012_0.CA11012_1; -- Complex additional operations + with CA11012_3; + package CA11012_3.CA11012_4 is new CA11012_3.CA11012_1; + + --==================================================================-- + + with CA11012_2; -- Package containing integer type + with CA11012_3.CA11012_4; -- Complex abstraction + additional operations + with Report; + + procedure CA11012 is + + package My_Complex_Pkg renames CA11012_3; + + package My_Complex_Operation renames CA11012_3.CA11012_4; + + use My_Complex_Pkg, -- All user-defined + My_Complex_Operation; -- operators directly + -- visible. + Complex_One, Complex_Two : Complex_Type; + + begin + + Report.Test ("CA11012", "Check that child instance can use its parent's " & + "declarations and operations, including a formal " & + "type of the parent"); + + Correct_Range_Test: + declare + My_Literal : CA11012_2.My_Integer := -3; + + begin + Complex_One := Complex (-4, 7); -- Operation from the generic + -- parent package. + + Complex_Two := My_Literal * Complex_One; -- Operation from the generic + -- child package. + + if Real_Part (Complex_Two) /= 12 -- Operation from the generic + or Imag_Part (Complex_Two) /= -21 -- child package. + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + end Correct_Range_Test; + + --------------------------------------------------------------- + + Out_Of_Range_Test: + declare + My_Vector : CA11012_2.My_Integer; + + begin + Complex_One := Complex (70, 70); -- Operation from the generic + -- parent package. + My_Vector := Vector_Magnitude (Complex_One); + -- Operation from the generic child package. + + Report.Failed ("Exception not raised in child package"); + + exception + when Constraint_Error => + Report.Comment ("Exception is raised as expected"); + + when others => + Report.Failed ("Others exception is raised"); + + end Out_Of_Range_Test; + + Report.Result; + + end CA11012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11013.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,201 ---- + -- CA11013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a child function of a library level instantiation + -- of a generic can be the instantiation of a child function of + -- the generic. Check that the child instance can use its parent's + -- declarations and operations, including a formal subprogram of the + -- parent. + -- + -- TEST DESCRIPTION: + -- Declare a generic package which simulates a real complex + -- abstraction. Declare a generic child function of this package + -- which builds a random complex number. Declare a second + -- package which defines a random complex number generator. This + -- package provides actual parameters for the generic parent package. + -- + -- Instantiate the first generic package, then instantiate the child + -- generic function as a child unit of the first instance. In the main + -- program, check that the operations in both instances perform as + -- expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context + -- clause of CA11013_3. + -- 27 Feb 97 CTA.PWB Added elaboration pragma at package CA11013_3 + --! + + generic -- Complex number abstraction. + type Real_Type is digits <>; + with function Random_Generator (Seed : Real_Type) return Real_Type; + + package CA11013_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is + record + Real : Real_Type; + Imag : Real_Type; + end record; + + function Make (Real, Imag : Real_Type) -- Create a complex + return Complex_Type; -- number. + + procedure Components (Complex_No : in Complex_Type; + Real_Part, Imag_Part : out Real_Type); + + end CA11013_0; + + --==================================================================-- + + package body CA11013_0 is + + function Make (Real, Imag : Real_Type) return Complex_Type is + begin + return (Real, Imag); + end Make; + ------------------------------------------------------------- + procedure Components (Complex_No : in Complex_Type; + Real_Part, Imag_Part : out Real_Type) is + begin + Real_Part := Complex_No.Real; + Imag_Part := Complex_No.Imag; + end Components; + + end CA11013_0; + + --==================================================================-- + + -- Generic child of complex number package. This child adds a layer of + -- functionality to the parent generic. + + generic -- Random complex number operation. + + function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type; + + --==============================================-- + + function CA11013_0.CA11013_1 (Seed : Real_Type) return Complex_Type is + + Random_Real_Part : Real_Type := Random_Generator (Seed); + -- parent's formal subprogram + Random_Imag_Part : Real_Type + := Random_Generator (Random_Generator (Seed)); + -- parent's formal subprogram + Random_Complex_No : Complex_Type; + + begin -- CA11013_0.CA11013_1 + + Random_Complex_No := Make (Random_Real_Part, Random_Imag_Part); + -- operation from parent + return (Random_Complex_No); + + end CA11013_0.CA11013_1; + + --==================================================================-- + + package CA11013_2 is + + -- To be used as actual parameters for random number generator + -- in the parent package. + + type My_Float is digits 6 range -10.0 .. 100.0; + + function Random_Complex (Seed : My_float) return My_Float; + + end CA11013_2; + + --==================================================================-- + + package body CA11013_2 is + + -- Not a real random number generator. + function Random_Complex (Seed : My_float) return My_Float is + begin + return (Seed + 3.0); + end Random_Complex; + + end CA11013_2; + + --==================================================================-- + + -- Declare instances of the generic complex packages for real type. + -- The instance of the child must itself be declared as a child of the + -- instance of the parent. + + with CA11013_0; -- Complex number. + with CA11013_2; -- Random number generator. + pragma Elaborate (CA11013_0); + package CA11013_3 is new + CA11013_0 (Random_Generator => CA11013_2.Random_Complex, + Real_Type => CA11013_2.My_Float); + + with CA11013_0.CA11013_1; -- Random complex number operation. + with CA11013_3; + pragma Elaborate (CA11013_3); + function CA11013_3.CA11013_4 is new CA11013_3.CA11013_1; + + --==================================================================-- + + with Report; + with CA11013_2; -- Random number generator. + with CA11013_3.CA11013_4; -- Complex abstraction + Random complex + -- number operation. + procedure CA11013 is + + package My_Complex_Pkg renames CA11013_3; + use type CA11013_2.My_Float; + + My_Complex : My_Complex_Pkg.Complex_Type; + My_Literal : CA11013_2.My_Float := 3.0; + My_Real_Part, My_Imag_Part : CA11013_2.My_Float; + + begin + + Report.Test ("CA11013", "Check that child instance can use its parent's " & + "declarations and operations, including a formal " & + "subprogram of the parent"); + + My_Complex := CA11013_3.CA11013_4 (My_Literal); + -- Operation from the generic child function. + + My_Complex_Pkg.Components (My_Complex, My_Real_Part, My_Imag_Part); + -- Operation from the generic parent package. + + if My_Real_Part /= 6.0 -- Operation from the generic + or My_Imag_Part /= 9.0 -- parent package. + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Report.Result; + + end CA11013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11014.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,302 ---- + -- CA11014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an instantiation of a child package of a generic package + -- can use its parent's declarations and operations, including a formal + -- package of the parent. + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any discrete type. Declare a generic package which + -- operates on lists of elements of integer types. Declare a generic + -- child of this package which defines additional list operations. + -- Use the formal discrete type as the generic formal actual part for the + -- parent formal package. + -- + -- Declare an instance of parent, then declare an instance of the child + -- which is itself a child the parent's instance. In the main program, + -- check that the operations in both instances perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- 07 Sep 96 SAIC Change formal param E to be out only. + -- 19 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate to context + -- clauses of CA11014_0, CA11014_1, and CA11014_5. + -- 27 Feb 97 PWB.CTA Added elaboration pragma at package CA11014_4 + --! + + -- Actual package for the parent's formal. + generic + + type Element_Type is (<>); -- List elems may be of any discrete types. + + package CA11014_0 is + + type Node_Type; + type Node_Pointer is access Node_Type; + + type Node_Type is record + Item : Element_Type; + Next : Node_Pointer := null; + end record; + + type List_Type is record + First : Node_Pointer := null; + Current : Node_Pointer := null; + Last : Node_Pointer := null; + end record; + + -- Return true if current element is last in the list. + function End_Of_List (L : List_Type) return boolean; + + -- Set "current" pointer to first list element. + procedure Reset (L : in out List_Type); + + end CA11014_0; + + --==================================================================-- + + package body CA11014_0 is + + function End_Of_List (L : List_Type) return boolean is + begin + return (L.Current = null); + end End_Of_List; + ------------------------------------------------------- + procedure Reset (L : in out List_Type) is + begin + L.Current := L.First; -- Set "current" pointer to first + end Reset; -- list element. + + end CA11014_0; + + --==================================================================-- + + with CA11014_0; -- Generic list abstraction. + pragma Elaborate (CA11014_0); + generic + + -- Import the list abstraction defined in CA11014_0. + with package List_Mgr is new CA11014_0 (<>); + + package CA11014_1 is + + -- Write to current element and advance "current" pointer. + procedure Write_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type); + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out List_Mgr.List_Type; + E : out List_Mgr.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type); + + end CA11014_1; + + --==================================================================-- + + package body CA11014_1 is + + procedure Write_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type) is + begin + L.Current.Item := E; -- Write to current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Write_Element; + ------------------------------------------------------- + procedure Read_Element (L : in out List_Mgr.List_Type; + E : out List_Mgr.Element_Type) is + begin + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Read_Element; + ------------------------------------------------------- + procedure Add_Element (L : in out List_Mgr.List_Type; + E : in List_Mgr.Element_Type) is + New_Node : List_Mgr.Node_Pointer := new List_Mgr.Node_Type'(E, null); + use type List_Mgr.Node_Pointer; + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + end CA11014_1; + + --==================================================================-- + + -- Generic child of list operation. This child adds a layer of + -- functionality to the parent generic. + + generic + + package CA11014_1.CA11014_2 is + + procedure Write_First_To_List (L : in out List_Mgr.List_Type); + + -- ... Various other operations used by the application. + + end CA11014_1.CA11014_2; + + --==================================================================-- + + package body CA11014_1.CA11014_2 is + + procedure Write_First_To_List (L : in out List_Mgr.List_Type) is + begin + List_Mgr.Reset (L); -- Parent's formal package. + + while not List_Mgr.End_Of_List (L) loop -- Parent's formal package. + Write_Element (L, List_Mgr.Element_Type'First); + -- Parent's operation, + end loop; -- parent's formal. + + end Write_First_To_List; + + end CA11014_1.CA11014_2; + + --==================================================================-- + + package CA11014_3 is + + type Points is range 0 .. 100; + + -- ... Various other types used by the application. + + end CA11014_3; + + + -- No body for CA11014_3; + + --==================================================================-- + + -- Declare instances of the generic list packages for the discrete type. + -- The instance of the child must itself be declared as a child of the + -- instance of the parent. + + with CA11014_0; -- Generic list abstraction. + with CA11014_3; -- Package containing discrete type declaration. + pragma Elaborate (CA11014_0); + package CA11014_4 is new CA11014_0 (CA11014_3.Points); -- Points list. + + with CA11014_4; -- Points list. + with CA11014_1; -- Generic list operation. + pragma Elaborate (CA11014_1); + package CA11014_5 is new CA11014_1 (CA11014_4); -- Scores list. + + with CA11014_1.CA11014_2; -- Additional generic list operation, + with CA11014_5; + pragma Elaborate (CA11014_5); + package CA11014_5.CA11014_6 is new CA11014_5.CA11014_2; + -- Points list operation. + + --==================================================================-- + + with CA11014_1.CA11014_2; -- Additional generic list operation, + -- implicitly with list operation. + with CA11014_3; -- Package containing discrete type declaration. + with CA11014_4; -- Points list. + with CA11014_5.CA11014_6; -- Points list operation. + with Report; + + procedure CA11014 is + + package Lists_Of_Scores renames CA11014_4; + package Score_Ops renames CA11014_5; + package Point_Ops renames CA11014_5.CA11014_6; + + Scores : Lists_Of_Scores.List_Type; -- List of points. + + type TC_Score_Array is array (1 .. 3) of CA11014_3.Points; + + TC_Initial_Values : constant TC_Score_Array := (10, 21, 49); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Initial_Values_Are_Correct : boolean := false; + TC_Final_Values_Are_Correct : boolean := false; + + -------------------------------------------------- + + -- Initial list contains 3 scores with the values 10, 21, and 49. + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin + for I in TC_Score_Array'range loop + Score_Ops.Add_Element (L, TC_Initial_Values(I)); + -- Operation from generic parent. + end loop; + end TC_Initialize_List; + + -------------------------------------------------- + + -- Verify that all scores have been set to zero. + procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; + Expected : in TC_Score_Array; + OK : out boolean) is + Actual : TC_Score_Array; + begin + Lists_of_Scores.Reset (L); -- Operation from parent's formal. + for I in TC_Score_Array'range loop + Score_Ops.Read_Element (L, Actual(I)); + -- Operation from generic parent. + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -------------------------------------------------- + + begin -- CA11014 + + Report.Test ("CA11014", "Check that an instantiation of a child package " & + "of a generic package can use its parent's " & + "declarations and operations, including a " & + "formal package of the parent"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Initial_Values_Are_Correct); + + if not TC_Initial_Values_Are_Correct then + Report.Failed ("List contains incorrect initial values"); + end if; + + Point_Ops.Write_First_To_List (Scores); + -- Operation from generic child package. + + TC_Verify_List (Scores, TC_Final_Values, TC_Final_Values_Are_Correct); + + if not TC_Final_Values_Are_Correct then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; + + end CA11014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11015.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,312 ---- + -- CA11015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a generic child of a non-generic package can use its + -- parent's declarations and operations. Check that the instantiation + -- of the generic child can correctly use the operations. + -- + -- TEST DESCRIPTION: + -- Declare a map abstraction in a package which manages basic physical + -- maps. Declare a generic child of this package which defines copies + -- of maps of any discrete type, i.e., population, density, or weather. + -- + -- In the main program, declare an instance of the child. Check that + -- the operations in the parent and instance of the child package + -- perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Simulates map of physical features, i.e., desert, forest, water, + -- or plains. + + package CA11015_0 is + type Map_Type is private; + subtype Latitude is integer range 1 .. 9; + subtype Longitude is integer range 1 .. 7; + + type Physical_Features is (Desert, Forest, Water, Plains, Unexplored); + type Page_Type is range 0 .. 80; + + Terra_Incognita : exception; + + -- Use geographic database to initialize the basic map. + + procedure Initialize_Basic_Map (Map : in out Map_Type); + + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Physical_Features; + + function Next_Page return Page_Type; + + private + type Map_Type is array (Latitude, Longitude) of Physical_Features; + Basic_Map : Map_Type; + Page : Page_Type := 0; -- Location for each copy of Map. + + end CA11015_0; + + --==================================================================-- + + package body CA11015_0 is + + procedure Initialize_Basic_Map (Map : in out Map_Type) is + -- Not a real initialization. Real application can use geographic + -- database to create the basic map. + begin + for I in Latitude'first .. Latitude'last loop + for J in 1 .. 2 loop + Map (I, J) := Unexplored; + end loop; + for J in 3 .. 4 loop + Map (I, J) := Desert; + end loop; + for J in 5 .. 7 loop + Map (I, J) := Plains; + end loop; + end loop; + + end Initialize_Basic_Map; + --------------------------------------------------- + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Physical_Features is + begin + return (Map (Lat, Long)); + end Get_Physical_Feature; + --------------------------------------------------- + function Next_Page return Page_Type is + begin + Page := Page + 1; + return (Page); + end Next_Page; + + --------------------------------------------------- + begin -- CA11015_0 + -- Initialize a basic map. + Initialize_Basic_Map (Basic_Map); + + end CA11015_0; + + --==================================================================-- + + -- Generic child package of physical map. Instantiate this package to + -- create map copy with a new geographic feature, i.e., population, density, + -- or weather. + + generic + + type Generic_Feature is (<>); -- Any geographic feature, i.e., population, + -- density, or weather that can be + -- characterized by a scalar value. + + package CA11015_0.CA11015_1 is + + type Feature_Map is private; + + function Get_Feature_Val (Lat : Latitude; + Long : Longitude; + Map : Feature_Map) return Generic_Feature; + + procedure Set_Feature_Val (Lat : in Latitude; + Long : in Longitude; + Fea : in Generic_Feature; + Map : in out Feature_Map); + + function Check_Page (Map : Feature_Map; + Page_No : Page_Type) return boolean; + + private + type Feature_Type is array (Latitude, Longitude) of Generic_Feature; + + type Feature_Map is + record + Feature : Feature_Type; + Page : Page_Type := Next_Page; -- Operation from parent. + end record; + + end CA11015_0.CA11015_1; + + --==================================================================-- + + package body CA11015_0.CA11015_1 is + + function Get_Feature_Val (Lat : Latitude; + Long : Longitude; + Map : Feature_Map) return Generic_Feature is + begin + return (Map.Feature (Lat, Long)); + end Get_Feature_Val; + --------------------------------------------------- + procedure Set_Feature_Val (Lat : in Latitude; + Long : in Longitude; + Fea : in Generic_Feature; + Map : in out Feature_Map) is + begin + if Get_Physical_Feature (Lat, Long, Basic_Map) = Unexplored + -- Parent's operation, + -- Parent's private object. + then + raise Terra_Incognita; -- Exception from parent. + else + Map.Feature (Lat, Long) := Fea; + end if; + end Set_Feature_Val; + --------------------------------------------------- + function Check_Page (Map : Feature_Map; + Page_No : Page_Type) return boolean is + begin + return (Map.Page = Page_No); + end Check_Page; + + end CA11015_0.CA11015_1; + + --==================================================================-- + + with CA11015_0.CA11015_1; -- Generic map operation, + -- implicitly withs parent, basic map + -- application. + with Report; + + procedure CA11015 is + + begin + + Report.Test ("CA11015", "Check that an instantiation of a child package " & + "of a non-generic package can use its parent's " & + "declarations and operations"); + + -- An application creates a population map using an integer type. + + Population_Map_Subtest: + declare + type Population_Type is range 0 .. 10_000; + + -- Declare instance of the child generic map package for one + -- particular integer type. + + package Population is new CA11015_0.CA11015_1 (Population_Type); + + Population_Map_Latitude : CA11015_0.Latitude := 1; + -- parent's type + Population_Map_Longitude : CA11015_0.Longitude := 5; + -- parent's type + Pop_Map : Population.Feature_Map; + Pop : Population_Type := 1000; + + begin + Population.Set_Feature_Val (Population_Map_Latitude, + Population_Map_Longitude, + Pop, + Pop_Map); + + If not ( (Population.Get_Feature_Val (Population_Map_Latitude, + Population_Map_Longitude, Pop_Map) = Pop) or + (Population.Check_Page (Pop_Map, 1)) ) then + Report.Failed ("Population map contains incorrect values"); + end if; + + end Population_Map_Subtest; + + -- An application creates a weather map using an enumeration type. + + Weather_Map_Subtest: + declare + type Weather_Type is (Hot, Cold, Mild); + + -- Declare instance of the child generic map package for one + -- particular enumeration type. + + package Weather_Pkg is new CA11015_0.CA11015_1 (Weather_Type); + + Weather_Map_Latitude : CA11015_0.Latitude := 2; + -- parent's type + Weather_Map_Longitude : CA11015_0.Longitude := 6; + -- parent's type + Weather_Map : Weather_Pkg.Feature_Map; + Weather : Weather_Type := Mild; + + begin + Weather_Pkg.Set_Feature_Val (Weather_Map_Latitude, + Weather_Map_Longitude, + Weather, + Weather_Map); + + if ( (Weather_Pkg.Get_Feature_Val (Weather_Map_Latitude, + Weather_Map_Longitude, Weather_Map) /= Weather) or + not (Weather_Pkg.Check_Page (Weather_Map, 2)) ) + then + Report.Failed ("Weather map contains incorrect values"); + end if; + + end Weather_Map_Subtest; + + -- During processing, the application may erroneously attempts to create + -- a density map on an unexplored area. This would result in the raising + -- of an exception. + + Density_Map_Subtest: + declare + type Density_Type is (High, Medium, Low); + + -- Declare instance of the child generic map package for one + -- particular enumeration type. + + package Density_Pkg is new CA11015_0.CA11015_1 (Density_Type); + + Density_Map_Latitude : CA11015_0.Latitude := 7; + -- parent's type + Density_Map_Longitude : CA11015_0.Longitude := 2; + -- parent's type + Density : Density_Type := Low; + Density_Map : Density_Pkg.Feature_Map; + + begin + Density_Pkg.Set_Feature_Val (Density_Map_Latitude, + Density_Map_Longitude, + Density, + Density_Map); + + Report.Failed ("Exception not raised in child generic package"); + + exception + + when CA11015_0.Terra_Incognita => -- parent's exception, + null; -- raised in child. + + when others => + Report.Failed ("Others exception is raised"); + + end Density_Map_Subtest; + + Report.Result; + + end CA11015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11016.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,321 ---- + -- CA11016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a child of a non-generic package can be a private generic + -- package. Check that the private child instance can use its parent's + -- declarations and operations. Check that the body of a public child + -- package can instantiate its sibling private generic package. + -- + -- TEST DESCRIPTION: + -- Declare a map abstraction in a package which manages basic physical + -- map[s]. Declare a private generic child of this package which can be + -- instantiated for any display device which has display locations of + -- the physical map that can be characterized by any integer type, i.e., + -- the intensity of the display point. + -- + -- Declare a public child of the physical map which specifies the + -- display device. In the body of this child, declare an instance of + -- its generic sibling to display the geographic locations. + -- + -- In the main program, check that the operations in the parent, public + -- child and instance of the private child package perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 17 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate. + -- + --! + + -- Simulates map of physical features, i.e., desert, forest, or water. + + package CA11016_0 is + type Map_Type is private; + subtype Latitude is integer range 1 .. 9; + subtype Longitude is integer range 1 .. 7; + + type Physical_Features is (Desert, Forest, Water); + + -- Use geographic database to initialize the basic map. + + procedure Initialize_Basic_Map (Map : in out Map_Type); + + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Physical_Features; + + private + type Map_Type is array (Latitude, Longitude) of Physical_Features; + Basic_Map : Map_Type; + + end CA11016_0; + + --==================================================================-- + + package body CA11016_0 is + + procedure Initialize_Basic_Map (Map : in out Map_Type) is + -- Not a real initialization. Real application can use geographic + -- database to create the basic map. + + begin + for I in Latitude'first .. Latitude'last loop + for J in 1 .. 2 loop + Map (I, J) := Desert; + end loop; + for J in 3 .. 4 loop + Map (I, J) := Forest; + end loop; + for J in 5 .. 7 loop + Map (I, J) := Water; + end loop; + end loop; + + end Initialize_Basic_Map; + -------------------------------------------------------- + function Get_Physical_Feature (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Physical_Features is + begin + return (Map (Lat, Long)); + end Get_Physical_Feature; + -------------------------------------------------------- + + begin + -- Initialize a basic map. + Initialize_Basic_Map (Basic_Map); + + end CA11016_0; + + --==================================================================-- + + -- Private generic child package of physical map. This generic package may + -- be instantiated for any display device which has display locations + -- (latitude, longitude) that can be characterized by an integer value. + -- For example, the intensity of the display point might be so characterized. + -- It can be instantiated for any desired range of values (which would + -- correspond to the range accepted by the display device). + + + private + + generic + + type Display_Value is range <>; -- Any display feature that is + -- represented by an integer. + + package CA11016_0.CA11016_1 is + + function Get_Display_Value (Lat : Latitude; + Long : Longitude; + Map : Map_Type) return Display_Value; + + end CA11016_0.CA11016_1; + + + --==================================================================-- + + + package body CA11016_0.CA11016_1 is + + function Get_Display_Value (Lat : Latitude; + Long : Longitude; + Map : Map_Type) + return Display_Value is + begin + case Get_Physical_Feature (Lat, Long, Map) is + -- Parent's operation, + when Forest => return (Display_Value'first); + -- Parent's type. + when Desert => return (Display_Value'last); + -- Parent's type. + when others => return + ( (Display_Value'last - Display_Value'first) / 2 ); + -- NOTE: Results are truncated. + end case; + + end Get_Display_Value; + + end CA11016_0.CA11016_1; + + + --==================================================================-- + + -- Map display operation, public child of physical map. + + package CA11016_0.CA11016_2 is + + -- Super-duper Ultra Geographic Display Device (SDUGD) can display + -- geographic locations with light intensity values ranging from 1 to 7. + + type Display_Val is range 1 .. 7; + + type Device_Color is (Brown, Blue, Green); + + type IO_Packet is + record + Lat : Latitude; -- Parent's type. + Long : Longitude; -- Parent's type. + Color : Device_Color; + Intensity : Display_Val; + end record; + + procedure Data_For_SDUGD (Lat : in Latitude; + Long : in Longitude; + Output_Packet : in out IO_Packet); + + end CA11016_0.CA11016_2; + + --==================================================================-- + + + with CA11016_0.CA11016_1; -- Private generic sibling. + pragma Elaborate (CA11016_0.CA11016_1); + + package body CA11016_0.CA11016_2 is + + -- Declare instance of the private generic sibling for + -- an integer type that represents color intensity. + + package SDUGD is new CA11016_0.CA11016_1 (Display_Val); + + procedure Data_For_SDUGD (Lat : in Latitude; + Long : in Longitude; + Output_Packet : in out IO_Packet) is + + -- Simulates sending control information to a display device. + -- Control information consists of latitude, longitude, a + -- color, and an intensity. + + begin + case Get_Physical_Feature (Lat, Long, Basic_Map) is + -- Parent's operation. + when Water => Output_Packet.Color := Blue; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + when Forest => Output_Packet.Color := Green; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + when others => Output_Packet.Color := Brown; + Output_Packet.Intensity := SDUGD.Get_Display_Value + (Lat, Long, Basic_Map); + -- Sibling's operation. + end case; + + end Data_For_SDUGD; + + end CA11016_0.CA11016_2; + + --==================================================================-- + + with CA11016_0.CA11016_2; -- Map display device operation, + -- implicitly withs parent, physical map + -- application. + + use CA11016_0.CA11016_2; -- Allows direct visibility to the simple + -- name of CA11016_0.CA11016_2. + + with Report; + + procedure CA11016 is + + TC_Packet : IO_Packet; + + begin + + Report.Test ("CA11016", "Check that body of a public child package can " & + "use its sibling private generic package " & + "declarations and operations"); + + -- Simulate control information at coordinates 3 and 7 of the + -- basic map for the SDUGD. + + Water_Display_Subtest: + begin + TC_Packet.Lat := 3; + TC_Packet.Long := 7; + + -- Build color and light intensity of the basic map at + -- latitude 3 and longitude 7. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Blue) or + (TC_Packet.Intensity /= 3) ) then + Report.Failed ("Map display device contains " & + "incorrect values for water subtest"); + end if; + + end Water_Display_Subtest; + + -- Simulate control information at coordinates 2 and 1 of the + -- basic map for the SDUGD. + + Desert_Display_Subtest: + begin + TC_Packet.Lat := 9; + TC_Packet.Long := 2; + + -- Build color and light intensity of the basic map at + -- latitude 9 and longitude 2. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Brown) or + (TC_Packet.Intensity /= 7) ) then + Report.Failed ("Map display device contains " & + "incorrect values for desert subtest"); + end if; + + end Desert_Display_Subtest; + + -- Simulate control information at coordinates 8 and 4 of the + -- basic map for the SDUGD. + + Forest_Display_Subtest: + begin + TC_Packet.Lat := 8; + TC_Packet.Long := 4; + + -- Build color and light intensity of the basic map at + -- latitude 8 and longitude 4. + + Data_For_SDUGD (TC_Packet.Lat, TC_Packet.Long, TC_Packet); + + if ( (TC_Packet.Color /= Green) or + (TC_Packet.Intensity /= 1) ) then + Report.Failed ("Map display device contains " & + "incorrect values for forest subtest"); + end if; + + end Forest_Display_Subtest; + + Report.Result; + + end CA11016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11017.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11017.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11017.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11017.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,246 ---- + -- CA11017.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of the parent package may depend on one of its own + -- public children. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of adding a + -- public child during code maintenance without distubing a large + -- subsystem. After child is added to the subsystem, a maintainer + -- decides to take advantage of the new functionality and rewrites + -- the parent's body. + -- + -- Declare a string abstraction in a package which manipulates string + -- replacement. Define a parent package which provides operations for + -- a record type with discriminant. Declare a public child of this + -- package which adds functionality to the original subsystem. In the + -- parent body, call operations from the public child. + -- + -- In the main program, check that operations in the parent and public + -- child perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Simulates application which manipulates strings. + + package CA11017_0 is + + type String_Rec (The_Size : positive) is private; + + type Substring is new string; + + -- ... Various other types used by the application. + + procedure Replace (In_The_String : in out String_Rec; + At_The_Position : in positive; + With_The_String : in String_Rec); + + -- ... Various other operations used by the application. + + private + -- Different size for each individual record. + + type String_Rec (The_Size : positive) is + record + The_Length : natural := 0; + The_Content : Substring (1 .. The_Size); + end record; + + end CA11017_0; + + --=================================================================-- + + -- Public child added during code maintenance without disturbing a + -- large system. This public child would add functionality to the + -- original system. + + package CA11017_0.CA11017_1 is + + Position_Error : exception; + + function Equal_Length (Left : in String_Rec; + Right : in String_Rec) return boolean; + + function Same_Content (Left : in String_Rec; + Right : in String_Rec) return boolean; + + procedure Copy (From_The_Substring : in Substring; + To_The_String : in out String_Rec); + + -- ... Various other operations used by the application. + + end CA11017_0.CA11017_1; + + --=================================================================-- + + package body CA11017_0.CA11017_1 is + + function Equal_Length (Left : in String_Rec; + Right : in String_Rec) return boolean is + -- Quick comparison between the lengths of the input strings. + + begin + return (Left.The_Length = Right.The_Length); -- Parent's private + -- type. + end Equal_Length; + -------------------------------------------------------------------- + function Same_Content (Left : in String_Rec; + Right : in String_Rec) return boolean is + + begin + for I in 1 .. Left.The_Length loop + if Left.The_Content (I) = Right.The_Content (I) then + return true; + else + return false; + end if; + end loop; + + end Same_Content; + -------------------------------------------------------------------- + procedure Copy (From_The_Substring : in Substring; + To_The_String : in out String_Rec) is + begin + To_The_String.The_Content -- Parent's private type. + (1 .. From_The_Substring'length) := From_The_Substring; + + To_The_String.The_Length -- Parent's private type. + := From_The_Substring'length; + end Copy; + + end CA11017_0.CA11017_1; + + --=================================================================-- + + -- After child is added to the subsystem, a maintainer decides + -- to take advantage of the new functionality and rewrites the + -- parent's body. + + with CA11017_0.CA11017_1; + + package body CA11017_0 is + + -- Calls functions from public child for a quick comparison of the + -- input strings. If their lengths are the same, do the replacement. + + procedure Replace (In_The_String : in out String_Rec; + At_The_Position : in positive; + With_The_String : in String_Rec) is + End_Position : natural := At_The_Position + + With_The_String.The_Length - 1; + + begin + if not CA11017_0.CA11017_1.Equal_Length -- Public child's operation. + (With_The_String, In_The_String) then + raise CA11017_0.CA11017_1.Position_Error; + -- Public child's exception. + else + In_The_String.The_Content (At_The_Position .. End_Position) := + With_The_String.The_Content (1 .. With_The_String.The_Length); + end if; + + end Replace; + + end CA11017_0; + + --=================================================================-- + + with Report; + + with CA11017_0.CA11017_1; -- Explicit with public child package, + -- implicit with parent package (CA11017_0). + + procedure CA11017 is + + package String_Pkg renames CA11017_0; + use String_Pkg; + + begin + + Report.Test ("CA11017", "Check that body of the parent package can " & + "depend on one of its own public children"); + + -- Both input strings have the same size. Replace the first string by the + -- second string. + + Replace_Subtest: + declare + The_First_String, The_Second_String : String_Rec (16); + -- Parent's private type. + The_Position : positive := 1; + begin + CA11017_1.Copy ("This is the time", + To_The_String => The_First_String); + + CA11017_1.Copy ("For all good men", The_Second_String); + + Replace (The_First_String, The_Position, The_Second_String); + + -- Compare results using function from public child since + -- the type is private. + + if not CA11017_1.Same_Content + (The_First_String, The_Second_String) then + Report.Failed ("Incorrect results"); + end if; + + end Replace_Subtest; + + -- During processing, the application may erroneously attempt to replace + -- strings of different size. This would result in the raising of an + -- exception. + + Exception_Subtest: + declare + The_First_String : String_Rec (17); + -- Parent's private type. + The_Second_String : String_Rec (13); + -- Parent's private type. + The_Position : positive := 2; + begin + CA11017_1.Copy (" ACVC Version 2.0", The_First_String); + + CA11017_1.Copy (From_The_Substring => "ACVC 9X Basic", + To_The_String => The_Second_String); + + Replace (The_First_String, The_Position, The_Second_String); + + Report.Failed ("Exception was not raised"); + + exception + when CA11017_1.Position_Error => + Report.Comment ("Exception is raised as expected"); + + end Exception_Subtest; + + Report.Result; + + end CA11017; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11018.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11018.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11018.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11018.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,366 ---- + -- CA11018.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of the parent package may depend on one of its own + -- public generic children. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of adding a + -- public generic child during code maintenance without distubing a large + -- subsystem. After child is added to the subsystem, a maintainer + -- decides to take advantage of the new functionality and rewrites + -- the parent's body. + -- + -- Declare a message application in a package which highlights some + -- key words. Declare a public generic child of this package which adds + -- functionality to the original subsystem. In the parent body, + -- instantiate the child. + -- + -- In the main program, check that the operations in the parent, + -- and instances of the public child package perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Dec 94 SAIC Modified Copy_Particularly_Designated_Pkg inst. + -- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + -- Simulates application which displays messages. + + package CA11018_0 is + + type Designated_Num is new Integer range 0 .. 100; + + type Particularly_Designated_Num is new Integer range 0 .. 100; + + type Message is new String; + + type Message_Rec is tagged private; + + type Designated_Msg is new Message_Rec with private; + + type Particularly_Designated_Msg is new Message_Rec with private; + + -- Analyzes message for presence of word in the secret message. If found, + -- word is highlighted. + + procedure Highlight_Designated (The_Word : in Message; + In_The_Message : in out Designated_Msg); + + + -- Analyzes message for presence of word in the secret message. If found, + -- word is highlighted and do other actions. + + procedure Highlight_Particularly_Designated + (The_Word : in Message; + In_The_Message : in out Particularly_Designated_Msg); + + + -- Begin test code declarations: ----------------------- + + TC_Designated_Not_Zero : Boolean := false; + + TC_Particularly_Designated_Not_Zero : Boolean := false; + + -- The following two functions are used to check for function + -- calls from the public generic child. + + function TC_Designated_Success return Boolean; + + function TC_Particularly_Designated_Success return Boolean; + + -- End test code declarations. ------------------------- + + private + type Message_Rec is tagged + record + The_Length : natural := 0; + The_Content : Message (1 .. 60); + end record; + + type Designated_Msg is new Message_Rec with null record; + -- ... More components in real application. + + type Particularly_Designated_Msg is new Message_Rec with null record; + -- ... More components in real application. + + end CA11018_0; + + --=================================================================-- + + + -- Public generic child package of message display application. Imagine that + -- messages of one security level are associated with a type derived from + -- integer. For overall system security, messages of a different security + -- level are associated with a different type derived from integer. By + -- instantiating this package for each security level, the results of Count + -- applied to one kind of message cannot inadvertently be compared with the + -- results applied to a different kind. + + generic + type Msg_Type is new Message_Rec with private; + -- Derived from parent's type. + type Count is range <>; + + package CA11018_0.CA11018_1 is + + TC_Function_Called : Boolean := false; + + function Find_Word (Wrd : in Message; + Msg : in Msg_Type) return Count; + + end CA11018_0.CA11018_1; + + --=================================================================-- + + package body CA11018_0.CA11018_1 is + + function Find_Word (Wrd : in Message; + Msg : in Msg_Type) return Count is + + Num : Count := Count'first; + + -- Count how many time the word appears within the given message. + + begin + -- ... Error-checking code omitted for brevity. + + for I in 1 .. (Msg.The_Length - Wrd'length + 1) loop + -- Parent's private type + if Msg.The_Content (I .. I + Wrd'length - 1) = Wrd + -- Parent's private type + then + Num := Num + 1; + end if; + + end loop; + + TC_Function_Called := true; + + return (Num); + + end Find_Word; + + end CA11018_0.CA11018_1; + + --=================================================================-- + + with CA11018_0.CA11018_1; -- Public generic child. + + pragma Elaborate (CA11018_0.CA11018_1); + package body CA11018_0 is + + ---------------------------------------------------- + -- Parent's body depends on public generic child. -- + ---------------------------------------------------- + + -- Instantiate the public child for the secret message. + + package Designated_Pkg is new CA11018_0.CA11018_1 + (Msg_Type => Designated_Msg, Count => Designated_Num); + + -- Instantiate the public child for the top secret message. + + package Particularly_Designated_Pkg is new CA11018_0.CA11018_1 + (Particularly_Designated_Msg, Particularly_Designated_Num); + + -- End instantiations. ----------------------------- + + + function TC_Designated_Success return Boolean is + -- Check to see if the function in the public generic child is called. + + begin + return Designated_Pkg.TC_Function_Called; + end TC_Designated_Success; + -------------------------------------------------------------- + function TC_Particularly_Designated_Success return Boolean is + -- Check to see if the function in the public generic child is called. + + begin + return Particularly_Designated_Pkg.TC_Function_Called; + end TC_Particularly_Designated_Success; + -------------------------------------------------------------- + -- Calls functions from public child to search for a key word. + -- If the word appears more than once in each message, + -- highlight all of them. + + procedure Highlight_Designated (The_Word : in Message; + In_The_Message : in out Designated_Msg) is + + -- Not a real highlight procedure. Real application can use graphic + -- device to highlight all occurrences of words. + + begin + -------------------------------------------------------------- + -- Parent's body uses function from instantiation of public -- + -- generic child. -- + -------------------------------------------------------------- + + if Designated_Pkg.Find_Word -- Child's operation. + (The_Word, In_The_Message) > 0 then + + -- Highlight all occurrences in lavender. + + TC_Designated_Not_Zero := true; + end if; + + end Highlight_Designated; + -------------------------------------------------------------- + procedure Highlight_Particularly_Designated + (The_Word : in Message; + In_The_Message : in out Particularly_Designated_Msg) is + + -- Not a real highlight procedure. Real application can use graphic + -- device to highlight all occurrences of words. + + begin + -------------------------------------------------------------- + -- Parent's body uses function from instantiation of public -- + -- generic child. -- + -------------------------------------------------------------- + + if Particularly_Designated_Pkg.Find_Word -- Child's operation. + (The_Word, In_The_Message) > 0 then + + -- Highlight all occurrences in chartreuse. + -- Do other more secret stuff. + + TC_Particularly_Designated_Not_Zero := true; + end if; + + end Highlight_Particularly_Designated; + + end CA11018_0; + + --=================================================================-- + + -- Public generic child to copy words to the messages. + + generic + type Message_Type is new Message_Rec with private; + -- Derived from parent's type. + + package CA11018_0.CA11018_2 is + + procedure Copy (From_The_Word : in Message; + To_The_Message : in out Message_Type); + + end CA11018_0.CA11018_2; + + --=================================================================-- + + package body CA11018_0.CA11018_2 is + + procedure Copy (From_The_Word : in Message; + To_The_Message : in out Message_Type) is + + -- Copy words to the appropriate messages. + + begin + To_The_Message.The_Content -- Parent's private type. + (1 .. From_The_Word'length) := From_The_Word; + + To_The_Message.The_Length -- Parent's private type. + := From_The_Word'length; + end Copy; + + end CA11018_0.CA11018_2; + + --=================================================================-- + + with Report; + + with CA11018_0.CA11018_2; -- Public generic child package, copy words + -- to the message. + -- Implicit with parent package (CA11018_0). + + procedure CA11018 is + + package Message_Pkg renames CA11018_0; + + begin + + Report.Test ("CA11018", "Check that body of the parent package can " & + "depend on one of its own public generic children"); + + -- Highlight the word "Alert" from the secret message. + + Designated_Subtest: + declare + The_Message : Message_Pkg.Designated_Msg; -- Parent's private type. + + -- Instantiate the public child to copy words to the secret message. + + package Copy_Designated_Pkg is new CA11018_0.CA11018_2 + (Message_Pkg.Designated_Msg); + + begin + Copy_Designated_Pkg.Copy ("Alert Level 1 : Alert The Guard", + To_The_Message => The_Message); + + Message_Pkg.Highlight_Designated ("Alert", The_Message); + + if not Message_Pkg.TC_Designated_Not_Zero and + Message_Pkg.TC_Designated_Success then + Report.Failed ("Alert should have been highlighted"); + end if; + + end Designated_Subtest; + + -- Highlight the word "Push The Alarm" from the top secret message. + + Particularly_Designated_Subtest: + declare + The_Message : Message_Pkg.Particularly_Designated_Msg ; + -- Parent's private type. + + -- Instantiate the public child to copy words to the top secret + -- message. + + package Copy_Particularly_Designated_Pkg is new + CA11018_0.CA11018_2 (Message_Pkg.Particularly_Designated_Msg); + + begin + Copy_Particularly_Designated_Pkg.Copy + ("Alert Level 10 : Alert The Guard and Push The Alarm", + The_Message); + + Message_Pkg.Highlight_Particularly_Designated + ("Push The Alarm", The_Message); + + if not Message_Pkg.TC_Particularly_Designated_Not_Zero and + Message_Pkg.TC_Particularly_Designated_Success then + Report.Failed ("Key words should have been highlighted"); + end if; + + end Particularly_Designated_Subtest; + + Report.Result; + + end CA11018; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11019.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11019.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11019.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11019.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,306 ---- + -- CA11019.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of the parent package may depend on one of its own + -- private generic children. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of adding a + -- generic private child during code maintenance without distubing a + -- large subsystem. After child is added to the subsystem, a maintainer + -- decides to take advantage of the new functionality and rewrites + -- the parent's body. + -- + -- Declare a data collection abstraction in a package. Declare a private + -- generic child of this package which provides parameterized code that + -- have been written once and will be used three times to implement the + -- services of the parent package. In the parent body, instantiate the + -- private child. + -- + -- In the main program, check that the operations in the parent, + -- and instance of the private child package perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 17 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + package CA11019_0 is + -- parent + + type Data_Record is tagged private; + type Data_Collection is private; + --- + --- + subtype Data_1 is integer range 0 .. 100; + procedure Add_1 (Data : Data_1; To : in out Data_Collection); + function Statistical_Op_1 (Data : Data_Collection) return Data_1; + --- + subtype Data_2 is integer range -100 .. 1000; + procedure Add_2 (Data : Data_2; To : in out Data_Collection); + function Statistical_Op_2 (Data : Data_Collection) return Data_2; + --- + subtype Data_3 is integer range -10_000 .. 10_000; + procedure Add_3 (Data : Data_3; To : in out Data_Collection); + function Statistical_Op_3 (Data : Data_Collection) return Data_3; + --- + + private + + type Data_Ptr is access Data_Record'class; + subtype Sequence_Number is positive range 1 .. 512; + + type Data_Record is tagged + record + Next : Data_Ptr := null; + Seq : Sequence_Number; + end record; + --- + type Data_Collection is + record + First : Data_Ptr := null; + Last : Data_Ptr := null; + end record; + + end CA11019_0; + -- parent + + --=================================================================-- + + -- This generic package provides parameterized code that has been + -- written once and will be used three times to implement the services + -- of the parent package. + + private + generic + type Data_Type is range <>; + + package CA11019_0.CA11019_1 is + -- parent.child + + type Data_Elem is new Data_Record with + record + Value : Data_Type; + end record; + + Next_Avail_Seq_No : Sequence_Number := 1; + + procedure Sequence (Ptr : Data_Ptr); + -- the child must be private for this procedure to know details of + -- the implementation of data collections + + procedure Add (Datum : Data_Type; To : in out Data_Collection); + + function Op (Data : Data_Collection) return Data_Type; + -- op models a complicated operation that whose code can be + -- used for various data types + + + end CA11019_0.CA11019_1; + -- parent.child + + --=================================================================-- + + + package body CA11019_0.CA11019_1 is + -- parent.child + + procedure Sequence (Ptr : Data_Ptr) is + begin + Ptr.Seq := Next_Avail_Seq_No; + Next_Avail_Seq_No := Next_Avail_Seq_No + 1; + end Sequence; + + --------------------------------------------------------- + + procedure Add (Datum : Data_Type; To : in out Data_Collection) is + Ptr : Data_Ptr; + begin + if To.First = null then + -- assign new record with data value to + -- to.next <- null; + To.First := new Data_Elem'(Next => null, + Value => Datum, + Seq => 1); + Sequence (To.First); + To.Last := To.First; + else + -- chase to end of list + Ptr := To.First; + while Ptr.Next /= null loop + Ptr := Ptr.Next; + end loop; + -- and add element there + Ptr.Next := new Data_Elem'(Next => null, + Value => Datum, + Seq => 1); + Sequence (Ptr.Next); + To.Last := Ptr.Next; + end if; + + end Add; + + --------------------------------------------------------- + + function Op (Data : Data_Collection) return Data_Type is + -- for simplicity, just return the maximum of the data set + Max : Data_Type := Data_Elem( Data.First.all ).Value; + -- assuming non-empty collection + Ptr : Data_Ptr := Data.First; + + begin + -- no error checking + while Ptr.Next /= null loop + if Data_Elem( Ptr.Next.all ).Value > Max then + Max := Data_Elem( Ptr.Next.all ).Value; + end if; + Ptr := Ptr.Next; + end loop; + return Max; + end Op; + + end CA11019_0.CA11019_1; + -- parent.child + + --=================================================================-- + + -- parent body depends on private generic child + with CA11019_0.CA11019_1; -- Private generic child. + + pragma Elaborate (CA11019_0.CA11019_1); + package body CA11019_0 is + + -- instantiate the generic child with data types needed by the + -- package interface services + package Data_1_Ops is new CA11019_1 + (Data_Type => Data_1); + + package Data_2_Ops is new CA11019_1 + (Data_Type => Data_2); + + package Data_3_Ops is new CA11019_1 + (Data_Type => Data_3); + + --------------------------------------------------------- + + procedure Add_1 (Data : Data_1; To : in out Data_Collection) is + begin + -- maybe do other stuff here + Data_1_Ops.Add (Data, To); + -- and here + end; + + --------------------------------------------------------- + + function Statistical_Op_1 (Data : Data_Collection) return Data_1 is + begin + -- maybe use generic operation(s) in some complicated ways + -- (but simplified out, for the sake of testing) + return Data_1_Ops.Op (Data); + end; + + --------------------------------------------------------- + + procedure Add_2 (Data : Data_2; To : in out Data_Collection) is + begin + Data_2_Ops.Add (Data, To); + end; + + --------------------------------------------------------- + + function Statistical_Op_2 (Data : Data_Collection) return Data_2 is + begin + return Data_2_Ops.Op (Data); + end; + + --------------------------------------------------------- + + procedure Add_3 (Data : Data_3; To : in out Data_Collection) is + begin + Data_3_Ops.Add (Data, To); + end; + + --------------------------------------------------------- + + function Statistical_Op_3 (Data : Data_Collection) return Data_3 is + begin + return Data_3_Ops.Op (Data); + end; + + end CA11019_0; + + + --=================================================-- + + with CA11019_0, + -- Main, + -- Main.Child is private + Report; + + procedure CA11019 is + + package Main renames CA11019_0; + + Col_1, + Col_2, + Col_3 : Main.Data_Collection; + + begin + + Report.Test ("CA11019", "Check that body of a (non-generic) package " & + "may depend on its private generic child"); + + -- build a data collection + + for I in 1 .. 10 loop + Main.Add_1 ( Main.Data_1(I), Col_1); + end loop; + + if Main.Statistical_Op_1 (Col_1) /= 10 then + Report.Failed ("Wrong data_1 value returned"); + end if; + + for I in reverse 10 .. 20 loop + Main.Add_2 ( Main.Data_2(I * 10), Col_2); + end loop; + + if Main.Statistical_Op_2 (Col_2) /= 200 then + Report.Failed ("Wrong data_2 value returned"); + end if; + + for I in 0 .. 10 loop + Main.Add_3 ( Main.Data_3(I + 5), Col_3); + end loop; + + if Main.Statistical_Op_3 (Col_3) /= 15 then + Report.Failed ("Wrong data_3 value returned"); + end if; + + Report.Result; + + end CA11019; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11020.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,238 ---- + -- CA11020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of the generic parent package can depend on one of + -- its own public generic children. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of adding a + -- public generic child during code maintenance without distubing a large + -- subsystem. After child is added to the subsystem, a maintainer + -- decides to take advantage of the new functionality and rewrites + -- the parent's body. + -- + -- Declare a bag abstraction in a generic package. Declare a public + -- generic child of this package which adds a generic procedure to the + -- original subsystem. In the parent body, instantiate the public + -- child. Then instantiate the procedure as a child instance of the + -- public child instance. + -- + -- In the main program, declare an instance of parent. Check that the + -- operations in both parent and child packages perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Simulates bag application. + + generic + type Element is private; + with function Image (E : Element) return String; + + package CA11020_0 is + + type Bag is limited private; + + procedure Add (E : in Element; To_The_Bag : in out Bag); + + function Bag_Image (B : Bag) return string; + + private + type Node_Type; + type Bag is access Node_Type; + + type Node_Type is + record + The_Element : Element; + + -- Other components in real application, i.e., + -- The_Count : positive; + + Next : Bag; + end record; + + end CA11020_0; + + --==================================================================-- + + -- More operations on Bag. + + generic + + -- Parameters go here. + + package CA11020_0.CA11020_1 is + + -- ... Other declarations. + + generic -- Generic iterator procedure. + with procedure Use_Element (E : in Element); + + procedure Iterate (B : in Bag); -- Called once per element in the bag. + + -- ... Various other operations. + + end CA11020_0.CA11020_1; + + --==================================================================-- + + package body CA11020_0.CA11020_1 is + + procedure Iterate (B : in Bag) is + + -- Traverse each element in the bag. + + Elem : Bag := B; + + begin + while Elem /= null loop + Use_Element (Elem.The_Element); + Elem := Elem.Next; + end loop; + + end Iterate; + + end CA11020_0.CA11020_1; + + --==================================================================-- + + with CA11020_0.CA11020_1; -- Public generic child package. + + package body CA11020_0 is + + ---------------------------------------------------- + -- Parent's body depends on public generic child. -- + ---------------------------------------------------- + + -- Instantiate the public child. + + package MS is new CA11020_1; + + function Bag_Image (B : Bag) return string is + + Buffer : String (1 .. 10_000); + Last : Integer := 0; + + ----------------------------------------------------- + + -- Will be called by the iterator. + + procedure Append_Image (E : in Element) is + Im : constant String := Image (E); + + begin -- Append_Image + if Last /= 0 then -- Insert a comma. + Last := Last + 1; + Buffer (Last) := ','; + end if; + + Buffer (Last + 1 .. Last + Im'Length) := Im; + Last := Last + Im'Length; + + end Append_Image; + + ----------------------------------------------------- + + -- Instantiate procedure Iterate as a child of instance MS. + + procedure Append_All is new MS.Iterate (Use_Element => Append_Image); + + begin -- Bag_Image + + Append_All (B); + + return Buffer (1 .. Last); + + end Bag_Image; + + ----------------------------------------------------- + + procedure Add (E : in Element; To_The_Bag : in out Bag) is + + -- Not a real bag addition. + + Index : Bag := To_The_Bag; + + begin + -- ... Error-checking code omitted for brevity. + + if Index = null then + To_The_Bag := new Node_Type' (The_Element => E, + Next => null); + else + -- Goto the end of the list. + + while Index.Next /= null loop + Index := Index.Next; + end loop; + + -- Add element to the end of the list. + + Index.Next := new Node_Type' (The_Element => E, + Next => null); + end if; + + end Add; + + end CA11020_0; + + --==================================================================-- + + with CA11020_0; -- Bag application. + + with Report; + + procedure CA11020 is + + -- Instantiate the bag application for integer type and attribute + -- Image. + + package Bag_Of_Integers is new CA11020_0 (Integer, Integer'Image); + + My_Bag : Bag_Of_Integers.Bag; + + begin + + Report.Test ("CA11020", "Check that body of the generic parent package " & + "can depend on one of its own public generic children"); + + -- Add 10 consecutive integers to the bag. + + for I in 1 .. 10 loop + Bag_Of_Integers.Add (I, My_Bag); + end loop; + + if Bag_Of_Integers.Bag_Image (My_Bag) + /= " 1, 2, 3, 4, 5, 6, 7, 8, 9, 10" then + Report.Failed ("Incorrect results"); + end if; + + Report.Result; + + end CA11020; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11021.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- CA11021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of the generic parent package can depend on one of + -- its own private generic children. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of adding a + -- public generic child during code maintenance without distubing a large + -- subsystem. After child is added to the subsystem, a maintainer + -- decides to take advantage of the new functionality and rewrites + -- the parent's body. + -- + -- Declare a generic package which declares high level operations for a + -- complex number abstraction. Declare a private generic child package + -- of this package which defines low level complex operations. In the + -- parent body, instantiate the private child. Use the low level + -- operation to complete the high level operation. + -- + -- In the main program, instantiate the parent generic package. + -- Check that the operations in both packages perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic -- Complex number abstraction. + type Int_Type is range <>; + + package CA11021_0 is + + -- Simulate a generic complex number support package. Complex numbers + -- are treated as coordinates in the Cartesian plane. + + type Complex_Type is private; + + Zero : constant Complex_Type; -- Real number (0,0). + + function Real_Part (Complex_No : Complex_Type) + return Int_Type; + + function Imag_Part (Complex_No : Complex_Type) + return Int_Type; + + function Complex (Real, Imag : Int_Type) + return Complex_Type; + + -- High level operation for complex number. + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type; + + -- ... and other complicated ones. + + private + type Complex_Type is record + Real : Int_Type; + Imag : Int_Type; + end record; + + Zero : constant Complex_Type := (Real => 0, Imag => 0); + + end CA11021_0; + + --==================================================================-- + + -- Private generic child of Complex_Number. + + private + + generic + + -- No parameter. + + package CA11021_0.CA11021_1 is + + -- ... Other declarations. + + -- Low level operation on complex number. + function "+" (Left, Right : Complex_Type) + return Complex_Type; + + function "-" (Right : Complex_Type) + return Complex_Type; + + -- ... Various other operations in real application. + + end CA11021_0.CA11021_1; + + --==================================================================-- + + package body CA11021_0.CA11021_1 is + + function "+" (Left, Right : Complex_Type) + return Complex_Type is + + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + + -------------------------------------------------- + + function "-" (Right : Complex_Type) return Complex_Type is + begin + return (-Right.Real, -Right.Imag); + end "-"; + + end CA11021_0.CA11021_1; + + --==================================================================-- + + with CA11021_0.CA11021_1; -- Private generic child package. + + package body CA11021_0 is + + ----------------------------------------------------- + -- Parent's body depends on private generic child. -- + ----------------------------------------------------- + + -- Instantiate the private child. + + package Complex_Ops is new CA11021_1; + use Complex_Ops; -- All user-defined operators + -- directly visible. + + -------------------------------------------------- + + function "*" (Factor : Int_Type; + C : Complex_Type) return Complex_Type is + Result : Complex_Type := Zero; + + begin + for I in 1 .. abs (Factor) loop + Result := Result + C; -- Private generic child "+". + end loop; + + if Factor < 0 then + Result := - Result; -- Private generic child "-". + end if; + + return Result; + end "*"; + + -------------------------------------------------- + + function Real_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Real); + end Real_Part; + + -------------------------------------------------- + + function Imag_Part (Complex_No : Complex_Type) return Int_Type is + begin + return (Complex_No.Imag); + end Imag_Part; + + -------------------------------------------------- + + function Complex (Real, Imag : Int_Type) return Complex_Type is + begin + return (Real, Imag); + end Complex; + + end CA11021_0; + + --==================================================================-- + + with CA11021_0; -- Complex number abstraction. + + with Report; + + procedure CA11021 is + + type My_Integer is range -100 .. 100; + + -------------------------------------------------- + + -- Declare instance of the generic complex package for one particular + -- integer type. + + package My_Complex_Pkg is new + CA11021_0 (Int_Type => My_Integer); + + use My_Complex_Pkg; -- All user-defined operators + -- directly visible. + + -------------------------------------------------- + + Complex_One, Complex_Two : Complex_Type; + + My_Literal : My_Integer := -3; + + begin + + Report.Test ("CA11021", "Check that body of the generic parent package " & + "can depend on its private generic child"); + + Complex_One := Complex (11, 6); + + Complex_Two := 5 * Complex_One; + + if Real_Part (Complex_Two) /= 55 + and Imag_Part (Complex_Two) /= 30 + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Complex_One := Complex (-4, 7); + + Complex_Two := My_Literal * Complex_One; + + if Real_Part (Complex_Two) /= 12 + and Imag_Part (Complex_Two) /= -21 + then + Report.Failed ("Incorrect results from complex operation"); + end if; + + Report.Result; + + end CA11021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11022.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11022.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11022.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11022.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,242 ---- + -- CA11022.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that body of a child unit can instantiate its generic sibling. + -- + -- TEST DESCRIPTION: + -- Declare a package that provides some types for the graphic + -- application. Add a generic child package with a subprogram parameter + -- to provide algorithms that can be used by different terminal types + -- but that have to be customized to the specific terminal. Add child + -- packages to take advantage of the parent types and to provide a + -- customized operation for each of the different terminals. The + -- customized operation will be passed as a generic subprogram parameter + -- to the child package's sibling. + -- + -- The main program "with"s the child packages. Check that the + -- operations in child units perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CA11022_0 is -- Graphic Manager + + type Row is range 1 .. 66; + type Column is range 1 .. 80; + type Radius is range 1 .. 3; + type Length is range 5 .. 10; + + -- Testing artifice. + TC_Screen : array (Row, Column) of boolean := (others => (others => false)); + TC_Draw_Circle : boolean := false; + TC_Draw_Square : boolean := false; + + -- ... and other complicated ones. + + end CA11022_0; + + -- No bodies required for CA11022_0. + + --==================================================================-- + + -- Child package to provide general graphic functionalities. + + generic + + with procedure Put_Dot (X : in Column; + Y : in Row); + + package CA11022_0.CA11022_1 is + + procedure Draw_Square (At_Col : in Column; + At_Row : in Row; + Len : in Length); + + procedure Draw_Circle (At_Col : in Column; + At_Row : in Row; + Rad : in Radius); + + -- procedure Draw_Ellipse ... + -- and other drawings ... + + end CA11022_0.CA11022_1; + + --==================================================================-- + + package body CA11022_0.CA11022_1 is + + procedure Draw_Square (At_Col : in Column; + At_Row : in Row; + Len : in Length) is + begin + -- use square drawing algorithm + -- call + Put_Dot (At_Col + Column (Len), At_Row + Row(Len)); + -- as needed in the algorithm. + TC_Draw_Square := true; + end Draw_Square; + + ------------------------------------------------------- + procedure Draw_Circle (At_Col : in Column; + At_Row : in Row; + Rad : in Radius) is + begin + -- use circle drawing algorithm + -- call + for I in 1 .. Rad loop + Put_Dot (At_Col + Column(I), At_Row + Row(I)); + end loop; + -- as needed in the algorithm. + TC_Draw_Circle := true; + end Draw_Circle; + + end CA11022_0.CA11022_1; + + --==================================================================-- + + with CA11022_0.CA11022_1; -- Generic sibling. + + -- Child package to provide customized graphic functions for the + -- VT100. + package CA11022_0.CA11022_2 is -- VT100 Graphic. + + X : Column := 8; + Y : Row := 3; + R : Radius := 2; + L : Length := 6; + + procedure VT100_Graphic; + + end CA11022_0.CA11022_2; + + --==================================================================-- + + package body CA11022_0.CA11022_2 is + + procedure VT100_Graphic is + procedure VT100_Putdot (X : in Column; + Y : in Row) is + begin + -- Light a pixel at location (X, Y); + TC_Screen (Y, X) := true; + end VT100_Putdot; + + ------------------------------------ + + -- Declare instance of the generic sibling package to draw a circle, + -- a square, or an ellipse customized for the VT100. + package VT100_Graphic is new CA11022_0.CA11022_1 (VT100_Putdot); + + begin + VT100_Graphic.Draw_Circle (X, Y, R); + VT100_Graphic.Draw_Square (X, Y, L); + end VT100_Graphic; + + end CA11022_0.CA11022_2; + + --==================================================================-- + + with CA11022_0.CA11022_1; -- Generic sibling. + + -- Child package to provide customized graphic functions for the + -- IBM3270. + package CA11022_0.CA11022_3 is -- IBM3270 Graphic. + + X : Column := 39; + Y : Row := 11; + R : Radius := 3; + L : Length := 7; + + procedure IBM3270_Graphic; + + end CA11022_0.CA11022_3; + + --==================================================================-- + + package body CA11022_0.CA11022_3 is + + procedure IBM3270_Graphic is + procedure IBM3270_Putdot (X : in Column; + Y : in Row) is + begin + -- Light a pixel at location (X + 2, Y); + TC_Screen (Y, X + Column(2)) := true; + end IBM3270_Putdot; + + ------------------------------------ + + -- Declare instance of the generic sibling package to draw a circle, + -- a square, or an ellipse customized for the IBM3270. + package IBM3270_Graphic is new CA11022_0.CA11022_1 (IBM3270_Putdot); + + begin + IBM3270_Graphic.Draw_Circle (X, Y, R); + IBM3270_Graphic.Draw_Square (X, Y, L); + end IBM3270_Graphic; + + end CA11022_0.CA11022_3; + + --==================================================================-- + + with CA11022_0.CA11022_2; -- VT100 Graphic, implicitly with + -- CA11022_0, Graphic Manager. + with CA11022_0.CA11022_3; -- IBM3270 Graphic. + with Report; + + procedure CA11022 is + + begin + + Report.Test ("CA11022", "Check that body of a child unit can depend on " & + "its generic sibling"); + + -- Customized graphic functions for the VT100 terminal. + CA11022_0.CA11022_2.VT100_Graphic; + + if not CA11022_0.TC_Screen (4,9) and not CA11022_0.TC_Screen (5,10) + and not CA11022_0.TC_Screen (9,14) and not CA11022_0.TC_Draw_Circle + and not CA11022_0.TC_Draw_Square then + Report.Failed ("Wrong results for the VT100"); + end if; + + CA11022_0.TC_Draw_Circle := false; + CA11022_0.TC_Draw_Square := false; + + -- Customized graphic functions for the IBM3270 terminal. + CA11022_0.CA11022_3.IBM3270_Graphic; + + if not CA11022_0.TC_Screen (12,42) and not CA11022_0.TC_Screen (13,43) + and not CA11022_0.TC_Screen (14,44) and not CA11022_0.TC_Screen (46,18) + and not CA11022_0.TC_Draw_Circle and not CA11022_0.TC_Draw_Square then + Report.Failed ("Wrong results for the IBM3270"); + end if; + + Report.Result; + + end CA11022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + -- CA1102A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/12/81 + + PACKAGE CA1102A0 IS -- BODY IS IN CA1102A1. + + PROCEDURE P (INVOKED : IN OUT BOOLEAN); + + END CA1102A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA1102A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/12/81 + + PACKAGE BODY CA1102A0 IS + + PROCEDURE P (INVOKED : IN OUT BOOLEAN) IS + BEGIN + INVOKED := TRUE; + END P; + + BEGIN + NULL; + END CA1102A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1102a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- CA1102A2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT MORE THAN ONE WITH_CLAUSE CAN APPEAR IN + -- A CONTEXT_SPECIFICATION. + -- CHECK THAT USE_CLAUSES CAN MENTION NAMES MADE + -- VISIBLE BY PRECEDING WITH_CLAUSES IN THE SAME + -- CONTEXT_SPECIFICATION. + -- CHECK THAT CONSECUTIVE USE_CLAUSES ARE ALLOWED. + + -- SEPARATE FILES ARE: + -- CA1102A0 A LIBRARY PACKAGE DECLARATION. + -- CA1102A1 A LIBRARY PACKAGE BODY (CA1102A0). + -- CA1102A2M THE MAIN PROCEDURE. + + -- WKB 6/12/81 + -- BHS 7/19/84 + + WITH CA1102A0; + WITH REPORT; USE CA1102A0; USE REPORT; + PROCEDURE CA1102A2M IS + + + INVOKED : BOOLEAN := FALSE; + + BEGIN + TEST ("CA1102A", "MORE THAN ONE WITH_CLAUSE; ALSO, A " & + "USE_CLAUSE REFERING TO A PRECEDING WITH_CLAUSE " & + "IN THE SAME CONTEXT_SPECIFICATION"); + + P (INVOKED); + IF NOT INVOKED THEN + FAILED ("COMPILATION UNIT NOT MADE VISIBLE"); + END IF; + + RESULT; + END CA1102A2M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1106a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CA1106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A WITH CLAUSE FOR A PACKAGE BODY (GENERIC OR + -- NONGENERIC) OR FOR A GENERIC SUBPROGRAM BODY CAN NAME THE + -- CORRESPONDING SPECIFICATION, AND A USE CLAUSE CAN ALSO BE + -- GIVEN. + + -- HISTORY: + -- JET 07/14/88 CREATED ORIGINAL TEST. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + PACKAGE CA1106A_1 IS + I : INTEGER := 0; + PROCEDURE REQUIRE_BODY; + END CA1106A_1; + + GENERIC + TYPE TG IS RANGE <>; + PACKAGE CA1106A_2 IS + J : TG := 0; + PROCEDURE REQUIRE_BODY; + END CA1106A_2; + + GENERIC + TYPE TG IS RANGE <>; + FUNCTION CA1106A_3 RETURN TG; + + WITH REPORT; USE REPORT; + WITH CA1106A_1; USE CA1106A_1; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CA1106A_1 IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + I := IDENT_INT(1); + END CA1106A_1; + + WITH REPORT; USE REPORT; + WITH CA1106A_2; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CA1106A_2 IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + J := TG(IDENT_INT(2)); + END CA1106A_2; + + WITH REPORT; USE REPORT; + WITH CA1106A_3; + FUNCTION CA1106A_3 RETURN TG IS + BEGIN + RETURN TG(IDENT_INT(3)); + END CA1106A_3; + + WITH REPORT; USE REPORT; + WITH CA1106A_1, CA1106A_2, CA1106A_3; + USE CA1106A_1; + PROCEDURE CA1106A IS + + PACKAGE CA1106A_2X IS NEW CA1106A_2 (INTEGER); + FUNCTION CA1106A_3X IS NEW CA1106A_3 (INTEGER); + + USE CA1106A_2X; + + BEGIN + TEST ("CA1106A", "CHECK THAT A WITH CLAUSE FOR A PACKAGE BODY " & + "(GENERIC OR NONGENERIC) OR FOR A GENERIC " & + "SUBPROGRAM BODY CAN NAME THE CORRESPONDING " & + "SPECIFICATION, AND A USE CLAUSE CAN ALSO BE " & + "GIVEN"); + + IF I /= 1 THEN + FAILED ("INCORRECT VALUE FROM NONGENERIC PACKAGE"); + END IF; + + IF J /= 2 THEN + FAILED ("INCORRECT VALUE FROM GENERIC PACKAGE"); + END IF; + + IF CA1106A_3X /= 3 THEN + FAILED ("INCORRECT VALUE FROM GENERIC SUBPROGRAM"); + END IF; + + RESULT; + END CA1106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1108a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- CA1108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A WITH_CLAUSE AND USE_CLAUSE GIVEN FOR A PACKAGE + -- SPECIFICATION APPLIES TO THE BODY AND SUBUNITS OF THE BODY. + + -- BHS 7/27/84 + -- JBG 5/1/85 + + PACKAGE OTHER_PKG IS + + I : INTEGER := 4; + FUNCTION F (X : INTEGER) RETURN INTEGER; + + END OTHER_PKG; + + PACKAGE BODY OTHER_PKG IS + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X + 1; + END F; + + END OTHER_PKG; + + WITH REPORT, OTHER_PKG; + USE REPORT, OTHER_PKG; + PRAGMA ELABORATE (OTHER_PKG); + PACKAGE CA1108A_PKG IS + + J : INTEGER := 2; + PROCEDURE PROC; + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER); + + END CA1108A_PKG; + + PACKAGE BODY CA1108A_PKG IS + + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE PROC IS + Y : INTEGER := 2; + BEGIN + Y := OTHER_PKG.I; + IF Y /= 4 THEN + FAILED ("OTHER_PKG VARIABLE NOT VISIBLE " & + "IN PACKAGE BODY PROCEDURE"); + END IF; + END PROC; + + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS + BEGIN + SUB (X, Y); + END CALL_SUBS; + + BEGIN + + J := F(J); -- J => J + 1. + IF J /= 3 THEN + FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN " & + "PACKAGE BODY"); + END IF; + + END CA1108A_PKG; + + + WITH REPORT, CA1108A_PKG; + USE REPORT, CA1108A_PKG; + PROCEDURE CA1108A IS + + VAR1, VAR2 : INTEGER; + + BEGIN + + TEST ("CA1108A", "WITH_ AND USE_CLAUSES GIVEN FOR A PACKAGE " & + "SPEC APPLY TO THE BODY AND ITS SUBUNITS"); + + PROC; + + VAR1 := 1; + VAR2 := 1; + CALL_SUBS (VAR1, VAR2); + IF VAR1 /= 4 THEN + FAILED ("OTHER_PKG VARIABLE NOT VISIBLE IN SUBUNIT"); + END IF; + + IF VAR2 /= 6 THEN + FAILED ("OTHER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + + RESULT; + + END CA1108A; + + + SEPARATE (CA1108A_PKG) + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS + PROCEDURE SUB2 (Z : IN OUT INTEGER) IS SEPARATE; + BEGIN + + X := I; + SUB2 (Y); + + END SUB; + + + SEPARATE (CA1108A_PKG.SUB) + PROCEDURE SUB2 (Z : IN OUT INTEGER) IS + I : INTEGER := 5; + BEGIN + + Z := OTHER_PKG.F(I); -- Z => I + 1. + + END SUB2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca1108b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- CA1108B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF WITH_CLAUSES ARE GIVEN FOR BOTH A SPEC AND A BODY, AND + -- THE CLAUSES NAME DIFFERENT LIBRARY UNITS, THE UNITS NAMED IN ALL THE + -- CLAUSES ARE VISIBLE IN THE BODY AND IN SUBUNITS OF THE BODY. + + -- BHS 7/31/84 + -- JBG 5/1/85 + + PACKAGE FIRST_PKG IS + + FUNCTION F (X : INTEGER := 1) RETURN INTEGER; + + END FIRST_PKG; + + PACKAGE BODY FIRST_PKG IS + + FUNCTION F (X : INTEGER := 1) RETURN INTEGER IS + BEGIN + RETURN X; + END F; + + END FIRST_PKG; + + PACKAGE LATER_PKG IS + + FUNCTION F (Y : INTEGER := 2) RETURN INTEGER; + + END LATER_PKG; + + PACKAGE BODY LATER_PKG IS + + FUNCTION F (Y : INTEGER := 2) RETURN INTEGER IS + BEGIN + RETURN Y + 1; + END F; + + END LATER_PKG; + + WITH REPORT, FIRST_PKG; + USE REPORT; + PRAGMA ELABORATE (FIRST_PKG); + PACKAGE CA1108B_PKG IS + + I, J : INTEGER; + PROCEDURE PROC; + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER); + + END CA1108B_PKG; + + WITH LATER_PKG; + PRAGMA ELABORATE (LATER_PKG); + PACKAGE BODY CA1108B_PKG IS + + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS SEPARATE; + + PROCEDURE PROC IS + I, J : INTEGER; + BEGIN + I := FIRST_PKG.F; + IF I /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN " & + "PACKAGE BODY PROCEDURE"); + END IF; + J := LATER_PKG.F; + IF J /= 3 THEN + FAILED ("LATER_PKG FUNCITON NOT VISIBLE IN " & + "PACKAGE BODY PROCEDURE"); + END IF; + END PROC; + + PROCEDURE CALL_SUBS (X, Y : IN OUT INTEGER) IS + BEGIN + SUB (X, Y); + END CALL_SUBS; + + BEGIN + + I := FIRST_PKG.F; + IF I /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY"); + END IF; + J := LATER_PKG.F; + IF J /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN PACKAGE BODY"); + END IF; + + END CA1108B_PKG; + + WITH REPORT, CA1108B_PKG; + USE REPORT, CA1108B_PKG; + PROCEDURE CA1108B IS + + VAR1, VAR2 : INTEGER; + + BEGIN + + TEST ("CA1108B", "IF DIFFERENT WITH_CLAUSES GIVEN FOR PACKAGE " & + "SPEC AND BODY, ALL NAMED UNITS ARE VISIBLE " & + "IN THE BODY AND ITS SUBUNITS"); + + PROC; + + VAR1 := 0; + VAR2 := 1; + CALL_SUBS (VAR1, VAR2); + IF VAR1 /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT"); + END IF; + + IF VAR2 /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT"); + END IF; + + RESULT; + + END CA1108B; + + + SEPARATE (CA1108B_PKG) + PROCEDURE SUB (X, Y : IN OUT INTEGER) IS + PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS SEPARATE; + BEGIN + + SUB2 (Y, X); + IF Y /= 1 THEN + FAILED ("FIRST_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + IF X /= 3 THEN + FAILED ("LATER_PKG FUNCTION NOT VISIBLE IN SUBUNIT " & + "OF SUBUNIT"); + END IF; + X := FIRST_PKG.F; + Y := LATER_PKG.F; + + END SUB; + + SEPARATE (CA1108B_PKG.SUB) + PROCEDURE SUB2 (A, B : IN OUT INTEGER) IS + BEGIN + + A := FIRST_PKG.F; + B := LATER_PKG.F; + + END SUB2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11a01.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,228 ---- + -- CA11A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that type extended in a public child inherits primitive + -- operations from its ancestor. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type in a package specification. Declare two + -- primitive subprograms for the type (foundation code). + -- + -- Add a public child to the above package. Extend the root type with + -- a record extension in the specification. Declare a new primitive + -- subprogram to write to the child extension. + -- + -- Add a public grandchild to the above package. Extend the extension of + -- the parent type with a record extension in the private part of the + -- specification. Declare a new primitive subprogram for this grandchild + -- extension. + -- + -- In the main program, "with" the grandchild. Access the primitive + -- operations from grandparent and parent package. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package FA11A00.CA11A01_0 is -- Color_Widget_Pkg + -- This public child declares an extension from its parent. It + -- represents processing of widgets in a window system. + + type Widget_Color_Enum is (Black, Green, White); + + type Color_Widget is new Widget with -- Record extension of + record -- parent tagged type. + Color : Widget_Color_Enum; + end record; + + -- Inherits procedure Set_Width from Widget. + -- Inherits procedure Set_Height from Widget. + + -- To be inherited by its derivatives. + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum); + + procedure Set_Color_Widget (The_Widget : in out Color_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum); + + end FA11A00.CA11A01_0; -- Color_Widget_Pkg + + --=======================================================================-- + + package body FA11A00.CA11A01_0 is -- Color_Widget_Pkg + + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum) is + begin + The_Widget.Color := C; + end Set_Color; + --------------------------------------------------------------- + procedure Set_Color_Widget (The_Widget : in out Color_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum) is + begin + Set_Width (The_Widget, The_Width); -- Inherited from parent. + Set_Height (The_Widget, The_Height); -- Inherited from parent. + Set_Color (The_Widget, The_Color); + end Set_Color_Widget; + + end FA11A00.CA11A01_0; -- Color_Widget_Pkg + + --=======================================================================-- + + package FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg + -- This public grandchild extends the extension from its parent. It + -- represents processing of widgets in a window system. + + -- Declaration used by private extension component. + subtype Widget_Label_Str is string (1 .. 10); + + type Label_Widget is new Color_Widget with private; + -- Record extension of parent tagged type. + + -- Inherits (inherited) procedure Set_Width from Color_Widget. + -- Inherits (inherited) procedure Set_Height from Color_Widget. + -- Inherits procedure Set_Color from Color_Widget. + -- Inherits procedure Set_Color_Widget from Color_Widget. + + procedure Set_Label_Widget (The_Widget : in out Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum; + The_Label : in Widget_Label_Str); + + -- The following function is needed to verify the value of the + -- extension's private component. + + function Verify_Label (The_Widget : in Label_Widget; + The_Label : in Widget_Label_Str) return Boolean; + + private + type Label_Widget is new Color_Widget with + record + Label : Widget_Label_Str; + end record; + + end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg + + --=======================================================================-- + + package body FA11A00.CA11A01_0.CA11A01_1 is -- Label_Widget_Pkg + + procedure Set_Label (The_Widget : in out Label_Widget; + L : in Widget_Label_Str) is + begin + The_Widget.Label := L; + end Set_Label; + -------------------------------------------------------------- + procedure Set_Label_Widget (The_Widget : in out Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in Widget_Color_Enum; + The_Label : in Widget_Label_Str) is + begin + Set_Width (The_Widget, The_Width); -- Twice inherited. + Set_Height (The_Widget, The_Height); -- Twice inherited. + Set_Color (The_Widget, The_Color); -- Inherited from parent. + Set_Label (The_Widget, The_Label); + end Set_Label_Widget; + -------------------------------------------------------------- + function Verify_Label (The_Widget : in Label_Widget; + The_Label : in Widget_Label_Str) return Boolean is + begin + return (The_Widget.Label = The_Label); + end Verify_Label; + + end FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg + + --=======================================================================-- + + with FA11A00.CA11A01_0.CA11A01_1; -- Label_Widget_Pkg, + -- implicitly with Widget_Pkg, + -- implicitly with Color_Widget_Pkg + with Report; + + procedure CA11A01 is + + package Widget_Pkg renames FA11A00; + package Color_Widget_Pkg renames FA11A00.CA11A01_0; + package Label_Widget_Pkg renames FA11A00.CA11A01_0.CA11A01_1; + + use Widget_Pkg; -- All user-defined operators directly visible. + + Mail_Label : Label_Widget_Pkg.Widget_Label_Str := "Quick_Mail"; + + Default_Widget : Widget; + Black_Widget : Color_Widget_Pkg.Color_Widget; + Mail_Widget : Label_Widget_Pkg.Label_Widget; + + begin + + Report.Test ("CA11A01", "Check that type extended in a public " & + "child inherits primitive operations from its " & + "ancestor"); + + Set_Width (Default_Widget, 9); -- Call from parent. + Set_Height (Default_Widget, 10); -- Call from parent. + + If Default_Widget.Width /= Widget_Length (Report.Ident_Int (9)) or + Default_Widget.Height /= Widget_Length (Report.Ident_Int (10)) then + Report.Failed ("Incorrect result for Default_Widget"); + end if; + + Color_Widget_Pkg.Set_Color_Widget + (Black_Widget, 17, 18, Color_Widget_Pkg.Black); -- Explicitly declared. + + If Black_Widget.Width /= Widget_Length (Report.Ident_Int (17)) or + Black_Widget.Height /= Widget_Length (Report.Ident_Int (18)) or + Color_Widget_Pkg."/=" (Black_Widget.Color, Color_Widget_Pkg.Black) then + Report.Failed ("Incorrect result for Black_Widget"); + end if; + + Label_Widget_Pkg.Set_Label_Widget + (Mail_Widget, 15, 21, Color_Widget_Pkg.White, + "Quick_Mail"); -- Explicitly declared. + + If Mail_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or + Mail_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or + Color_Widget_Pkg."/=" (Mail_Widget.Color, Color_Widget_Pkg.White) or + not Label_Widget_Pkg.Verify_Label (Mail_Widget, Mail_Label) then + Report.Failed ("Incorrect result for Mail_Widget"); + end if; + + Report.Result; + + end CA11A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11a02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- CA11A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a type extended in a client of a public child inherits + -- primitive operations from parent. + -- + -- TEST DESCRIPTION: + -- Declare a root tagged type in a package specification. Declare two + -- primitive subprograms for the type (foundation code). + -- + -- Add a public child to the above package. Extend the root type with + -- a record extension in the specification. Declare a new primitive + -- subprogram to write to the child extension. + -- + -- In the main program, "with" the child. Declare an extension of + -- the child extension. Access the primitive operations from both + -- parent and child packages. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 20 Dec 94 SAIC Moved declaration of Label_Widget to library level + -- + --! + + package FA11A00.CA11A02_0 is -- Color_Widget_Pkg + -- This public child declares an extension from its parent. It + -- represents processing of widgets in a window system. + + type Widget_Color_Enum is (Black, Green, White); + + type Color_Widget is new Widget with -- Record extension of + record -- parent tagged type. + Color : Widget_Color_Enum; + end record; + + -- Inherits procedure Set_Width from parent. + -- Inherits procedure Set_Height from parent. + + -- To be inherited by its derivatives. + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum); + + end FA11A00.CA11A02_0; -- Color_Widget_Pkg + + --=======================================================================-- + + package body FA11A00.CA11A02_0 is -- Color_Widget_Pkg + + procedure Set_Color (The_Widget : in out Color_Widget; + C : in Widget_Color_Enum) is + begin + The_Widget.Color := C; + end Set_Color; + + end FA11A00.CA11A02_0; -- Color_Widget_Pkg + + --=======================================================================-- + + with FA11A00.CA11A02_0; -- Color_Widget_Pkg. + + package CA11A02_1 is + + type Label_Widget (Str_Disc : Integer) is new + FA11A00.CA11A02_0.Color_Widget with + record + Label : String (1 .. Str_Disc); + end record; + + -- Inherits (inherited) procedure Set_Width from Color_Widget. + -- Inherits (inherited) procedure Set_Height from Color_Widget. + -- Inherits procedure Set_Color from Color_Widget. + + end CA11A02_1; + + --=======================================================================-- + + with FA11A00.CA11A02_0; -- Color_Widget_Pkg, + -- implicitly with Widget_Pkg + with CA11A02_1; + + with Report; + + procedure CA11A02 is + + package Widget_Pkg renames FA11A00; + package Color_Widget_Pkg renames FA11A00.CA11A02_0; + + use Widget_Pkg; -- All user-defined operators directly visible. + + procedure Set_Label (The_Widget : in out CA11A02_1.Label_Widget; + L : in String) is + begin + The_Widget.Label := L; + end Set_Label; + --------------------------------------------------------- + procedure Set_Widget (The_Widget : in out CA11A02_1.Label_Widget; + The_Width : in Widget_Length; + The_Height : in Widget_Length; + The_Color : in + Color_Widget_Pkg.Widget_Color_Enum; + The_Label : in String) is + begin + CA11A02_1.Set_Width (The_Widget, The_Width); -- Twice inherited. + CA11A02_1.Set_Height (The_Widget, The_Height); -- Twice inherited. + CA11A02_1.Set_Color (The_Widget, The_Color); -- Inherited. + Set_Label (The_Widget, The_Label); -- Explicitly declared. + end Set_Widget; + + White_Widget : CA11A02_1.Label_Widget (11); + + begin + + Report.Test ("CA11A02", "Check that a type extended in a client of " & + "a public child inherits primitive operations from parent"); + + Set_Widget (White_Widget, 15, 21, Color_Widget_Pkg.White, "Alarm_Clock"); + + If White_Widget.Width /= Widget_Length (Report.Ident_Int (15)) or + White_Widget.Height /= Widget_Length (Report.Ident_Int (21)) or + Color_Widget_Pkg."/=" (White_Widget.Color, Color_Widget_Pkg.White) or + White_Widget.Label /= "Alarm_Clock" then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + Report.Result; + + end CA11A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11b01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11b01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11b01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11b01.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,208 ---- + -- CA11B01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a type derived in a public child inherits primitive + -- operations from parent. + -- + -- TEST DESCRIPTION: + -- Declare a root record type with discriminant in a package + -- specification. Declare a primitive subprogram for the type + -- (foundation code). + -- + -- Add a public child to the above package. Derive a new type + -- with constraint to the discriminant record type from the parent + -- package. Declare a new primitive subprogram to write to the child + -- derived type. + -- + -- Add a new public child to the above package. This grandchild package + -- derives a new type using the record type from the above package. + -- Declare a new primitive subprogram to write to the grandchild derived + -- type. + -- + -- In the main program, "with" the grandchild. Access the inherited + -- operations from grandparent, parent, and grandchild packages. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11B00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Child package of FA11B00. + package FA11B00.CA11B01_0 is -- Application_Two_Widget + -- This public child declares a derived type from its parent. It + -- represents processing of widgets in a window system. + + type App2_Widget is new App1_Widget (Maximum_Size => 5000); + -- Inherits procedure Create_Widget from parent. + + -- Primitive operation of type App2_Widget. + -- To be inherited by its children derivatives. + procedure App2_Widget_Specific_Oper (The_Widget : in out App2_Widget; + Loc : in Widget_Location); + + end FA11B00.CA11B01_0; -- Application_Two_Widget + + --=======================================================================-- + + package body FA11B00.CA11B01_0 is -- Application_Two_Widget + + procedure App2_Widget_Specific_Oper + (The_Widget : in out App2_Widget; + Loc : in Widget_Location) is + begin + The_Widget.Location := Loc; + end App2_Widget_Specific_Oper; + + end FA11B00.CA11B01_0; -- Application_Two_Widget + + --=======================================================================-- + + -- Grandchild package of FA11B00, child package of FA11B00.CA11B01_0. + package FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget + -- This public grandchild declares a derived type from its parent. It + -- represents processing of widgets in a window system. + + type App3_Widget is new App2_Widget; -- Derived record of App2_Widget. + + -- Inherits (inherited) procedure Create_Widget from Application_One_Widget. + -- Inherits procedure App2_Widget_Specific_Oper from App2_Widget. + + -- Primitive operation of type App3_Widget. + procedure App3_Widget_Specific_Oper (The_Widget : in out App3_Widget; + S : in Widget_Size); + + end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget + + --=======================================================================-- + + package body FA11B00.CA11B01_0.CA11B01_1 is -- Application_Three_Widget + + procedure App3_Widget_Specific_Oper + (The_Widget : in out App3_Widget; + S : in Widget_Size) is + begin + The_Widget.Size := S; + end App3_Widget_Specific_Oper; + + end FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget + + --=======================================================================-- + + with FA11B00.CA11B01_0.CA11B01_1; -- Application_Three_Widget, + -- implicitly with Application_Two_Widget, + -- implicitly with Application_Three_Widget. + with Report; + + procedure CA11B01 is + + package Application_One_Widget renames FA11B00; + package Application_Two_Widget renames FA11B00.CA11B01_0; + package Application_Three_Widget renames FA11B00.CA11B01_0.CA11B01_1; + + use Application_One_Widget; + use Application_Two_Widget; + use Application_Three_Widget; + + begin + + Report.Test ("CA11B01", "Check that a type derived in a public " & + "child inherits primitive operations from parent"); + + Application_One_Subtest: + declare + White_Widget : App1_Widget; + + begin + -- perform an App1_Widget specific operation. + App1_Widget_Specific_Oper (C => White, L => "Line Editor ", + The_Widget => White_Widget, I => 10); + + If White_Widget.Color /= White or + White_Widget.Id /= Widget_ID + (Report.Ident_Int (10)) or + White_Widget.Label /= "Line Editor " then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + end Application_One_Subtest; + --------------------------------------------------------------- + Application_Two_Subtest: + declare + Amber_Widget : App2_Widget; + + begin + App1_Widget_Specific_Oper (Amber_Widget, I => 11, + C => Amber, L => "Alarm_Clock "); + -- Inherited from Application_One_Widget. + + -- perform an App2_Widget specific operation. + App2_Widget_Specific_Oper (The_Widget => Amber_Widget, Loc => (380,512)); + + If Amber_Widget.Color /= Amber or + Amber_Widget.Id /= Widget_ID (Report.Ident_Int (11)) or + Amber_Widget.Label /= "Alarm_Clock " or + Amber_Widget.Location /= (380,512) then + Report.Failed ("Incorrect result for Amber_Widget"); + end if; + + end Application_Two_Subtest; + --------------------------------------------------------------- + Application_Three_Subtest: + declare + Green_Widget : App3_Widget; + + begin + App1_Widget_Specific_Oper (Green_Widget, 100, Green, + "Screen Editor "); + -- Inherited (inherited) from Basic_Widget. + + -- perform an App2_Widget specific operation. + App2_Widget_Specific_Oper (Loc => (1024,760), + The_Widget => Green_Widget); + -- Inherited from App_1_Widget. + + -- perform an App3_Widget specific operation. + App3_Widget_Specific_Oper (Green_Widget, S => (100,100)); + + If Green_Widget.Color /= Green or + Green_Widget.Id /= Widget_ID (Report.Ident_Int (100)) or + Green_Widget.Label /= "Screen Editor " or + Green_Widget.Location /= (1024,760) or + Green_Widget.Size /= (100,100) then + Report.Failed ("Incorrect result for Green_Widget"); + end if; + + end Application_Three_Subtest; + + Report.Result; + + end CA11B01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11b02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11b02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11b02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11b02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,169 ---- + -- CA11B02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a type derived in a client of a public child inherits + -- primitive operations from parent. + -- + -- TEST DESCRIPTION: + -- Declare a root record type with discriminant in a package + -- specification. Declare a primitive subprogram for the type + -- (foundation code). + -- + -- Add a public child to the above package. Derive a new type + -- with constraint to the discriminant record type from the parent + -- package. Declare a new primitive subprogram to write to the child + -- derived type. + -- + -- In the main program, "with" the child. Derive a new type using the + -- record type from the child package. Access the inherited operations + -- from both parent and child packages. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11B00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Child package of FA11B00. + package FA11B00.CA11B02_0 is -- Application_Two_Widget + -- This public child declares a derived type from its parent. It + -- represents processing of widgets in a window system. + + -- Dimension of app2_widget is limited to 5000 pixels. + + type App2_Widget is new App1_Widget (Maximum_Size => 5000); + -- Derived record of parent type. + + -- Inherits procedure App1_Widget_Specific_Oper from parent. + + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size); + + -- Primitive operation of type App2_Widget. + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location); + + end FA11B00.CA11B02_0; -- Application_Two_Widget + + + --=======================================================================-- + + + package body FA11B00.CA11B02_0 is -- Application_Two_Widget + + procedure App2_Widget_Specific_Op1 (The_Widget : in out App2_Widget; + S : in Widget_Size) is + begin + The_Widget.Size := S; + end App2_Widget_Specific_Op1; + + --==============================================-- + + procedure App2_Widget_Specific_Op2 (The_Widget : in out App2_Widget; + Loc : in Widget_Location) is + begin + The_Widget.Location := Loc; + end App2_Widget_Specific_Op2; + + end FA11B00.CA11B02_0; -- Application_Two_Widget + + + --=======================================================================-- + + with FA11B00.CA11B02_0; -- Application_Two_Widget + -- implicitly with Application_One_Widget. + with Report; + + procedure CA11B02 is + + package Application_One_Widget renames FA11B00; + + package Application_Two_Widget renames FA11B00.CA11B02_0; + + use Application_One_Widget ; + use Application_Two_Widget ; + + type Emulator_Widget is new App2_Widget; -- Derived record of + -- parent type. + + White_Widget, Amber_Widget : Emulator_Widget; + + + begin + + Report.Test ("CA11B02", "Check that a type derived in client of a " & + "public child inherits primitive operations from parent"); + + App1_Widget_Specific_Oper (C => White, L => "Line Editor ", + The_Widget => White_Widget, I => 10); + -- Inherited from Application_One_Widget. + If White_Widget.Color /= White or + White_Widget.Id /= Widget_ID (Report.Ident_Int (10)) or + White_Widget.Label /= "Line Editor " + then + Report.Failed ("Incorrect result for White_Widget"); + end if; + + -- perform an App2_Widget specific operation. + + App2_Widget_Specific_Op1 (White_Widget, S => (100, 200)); + + If White_Widget.Size.X_Length /= 100 or + White_Widget.Size.Y_Length /= 200 + then + Report.Failed ("Incorrect size for White_Widget"); + end if; + + App1_Widget_Specific_Oper (Amber_Widget, 5, Amber, "Screen Editor "); + -- Inherited from Application_One_Widget. + + -- perform an App2_Widget specific operations. + + App2_Widget_Specific_Op1 (S => (1024,100), The_Widget => Amber_Widget); + App2_Widget_Specific_Op2 (Amber_Widget, (1024, 760)); + + If Amber_Widget.Color /= Amber or + Amber_Widget.Id /= Widget_ID (Report.Ident_Int (5)) or + Amber_Widget.Label /= "Screen Editor " or + Amber_Widget.Size /= (1024,100) or + Amber_Widget.Location.X_Location /= 1024 or + Amber_Widget.Location.Y_Location /= 760 + then + Report.Failed ("Incorrect result for Amber_Widget"); + end if; + + Report.Result; + + end CA11B02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c01.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- CA11C01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when primitive operations declared in a child package + -- override operations declared in ancestor packages, a client of the + -- child package inherits the operations correctly. + -- + -- TEST DESCRIPTION: + -- + -- This test builds on the foundation code file (FA11C00) that contains + -- a parent package, child package, and grandchild package. The parent + -- package declares a tagged type and primitive operation. The child + -- package extends the type, and overrides the primitive operation. The + -- grandchild package does the same. + -- + -- The test procedure "withs" the grandchild package, and receives + -- visibility to all of its ancestor packages, types and operations. + -- Three procedures, each with a formal parameter of a specific type are + -- defined. Each of these invokes a particular version of the overridden + -- primitive operation Image. Calls to these local procedures are made, + -- with objects of each of the tagged types as parameters, and the global + -- variable is finally examined to ensure that the correct version of + -- primitive operation was inherited by the client and invoked by the + -- call. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11C00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate + with Report; + + procedure CA11C01 is + + package Animal_Package renames FA11C00_0; + package Mammal_Package renames FA11C00_0.FA11C00_1; + package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; + + Max_Animals : constant := 3; + + subtype Data_String is String (1 .. 37); + type Data_Base_Type is array (1 .. Max_Animals) of Data_String; + + Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); + -- Global variable. + + Salmon : Animal_Package.Animal := (Common_Name => "Chinook Salmon ", + Weight => 10); + + Platypus : Mammal_Package.Mammal := (Common_Name => "Tasmanian Platypus ", + Weight => 13, + Hair_Color => Mammal_Package.Brown); + + Orangutan : Primate_Package.Primate := + (Common_Name => "Sumatran Orangutan ", + Weight => 220, + Hair_Color => Mammal_Package.Red, + Habitat => Primate_Package.Arboreal); + begin + + Report.Test ("CA11C01", "Check that when primitive operations declared " & + "in a child package override operations declared " & + "in ancestor packages, a client of the child " & + "package inherits the operations correctly"); + + declare + + use Animal_Package, Mammal_Package, Primate_Package; + + -- The function Image has been overridden in the child and grandchild + -- packages, but the client has inherited all versions of the function, + -- and can successfully use them to enter data into the database. + -- Each of the following procedures updates the global variable + -- Zoo_Data_Base. + + procedure Enter_Animal_Data (A : Animal; I : Integer) is + begin + Zoo_Data_Base (I) := Image (A); + end Enter_Animal_Data; + + procedure Enter_Mammal_Data (M : Mammal; I : Integer) is + begin + Zoo_Data_Base (I) := Image (M); + end Enter_Mammal_Data; + + procedure Enter_Primate_Data (P : Primate; I : Integer) is + begin + Zoo_Data_Base (I) := Image (P); + end Enter_Primate_Data; + + begin + + -- Verify initial test conditions. + + if not (Zoo_Data_Base(1)(1..6) = " ") + or else + (Zoo_Data_Base(2)(1..6) /= " ") + or else + (Zoo_Data_Base(3)(1..6) /= " ") + then + Report.Failed ("Initial condition failure"); + end if; + + + -- Enter data from all three animals into the zoo database. + + Enter_Animal_Data (A => Salmon, I => 1); -- First entry in database. + Enter_Mammal_Data (M => Platypus, I => 2); -- Second entry. + Enter_Primate_Data (P => Orangutan, I => 3); -- Third entry. + + -- Verify the correct version of the overridden function Image was used + -- for entering the specific data. + + if Zoo_Data_Base(1)(1 .. 6) /= "Animal" + or else + Zoo_Data_Base(1)(26 .. 31) /= "Salmon" + then + Report.Failed ("Incorrect version of Image for parent type"); + end if; + + if (Zoo_Data_Base(2)(1 .. 6) /= "Mammal") + or + (Zoo_Data_Base(2)(28 .. 35) /= "Platypus") + then + Report.Failed ("Incorrect version of Image for child type"); + end if; + + if ((Zoo_Data_Base(3)(1 .. 7) /= "Primate") + or + (Zoo_Data_Base(3)(27 .. 35) /= "Orangutan")) + then + Report.Failed ("Incorrect version of Image for grandchild type"); + end if; + + end; + + + Report.Result; + + end CA11C01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- CA11C02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that primitive operations declared in a child package + -- override operations declared in ancestor packages, and that + -- operations on class-wide types defined in the ancestor packages + -- dispatch as appropriate to these overriding implementations. + -- + -- TEST DESCRIPTION: + -- + -- This test builds on the foundation code file (FA11C00) that contains + -- a parent package, child package, and grandchild package. The parent + -- package declares a tagged type and primitive operation. The child + -- package extends the type, and overrides the primitive operation. The + -- grandchild package does the same. + -- + -- The test procedure "withs" the grandchild package, and receives + -- visibility to all of its ancestor packages, types and operations. + -- A procedure with a formal class-wide parameter is defined that will + -- allow for dispatching calls to the overridden primitive operations, + -- based on the specific type of the actual parameter. The primitive + -- operations provide a string value to update a global string array + -- variable. Calls to the local procedure are made, with objects of each + -- of the tagged types as parameters, and the global variable is finally + -- examined to ensure that the correct version of primitive operation was + -- dispatched correctly. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11C00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FA11C00_0.FA11C00_1.FA11C00_2; -- Package Animal.Mammal.Primate + with Report; + + procedure CA11C02 is + + package Animal_Package renames FA11C00_0; + package Mammal_Package renames FA11C00_0.FA11C00_1; + package Primate_Package renames FA11C00_0.FA11C00_1.FA11C00_2; + + Max_Animals : constant := 3; + + type Data_Base_Type is array (1 .. Max_Animals) of String (1 .. 37); + + Zoo_Data_Base : Data_Base_Type := (others => (others => ' ')); + -- Global variable. + + Macaw : Animal_Package.Animal := (Common_Name => "Scarlet Macaw ", + Weight => 2); + + Manatee : Mammal_Package.Mammal := (Common_Name => "Southern Manatee ", + Weight => 230, + Hair_Color => Mammal_Package.Brown); + + Lemur : Primate_Package.Primate := + (Common_Name => "Ring-Tailed Lemur ", + Weight => 5, + Hair_Color => Mammal_Package.Black, + Habitat => Primate_Package.Arboreal); + begin + + Report.Test ("CA11C02", "Check that primitive operations declared " & + "in a child package override operations declared " & + "in ancestor packages, and that operations " & + "on class-wide types defined in the ancestor " & + "packages dispatch as appropriate to these " & + "overriding implementations"); + + declare + + use Animal_Package, Mammal_Package, Primate_Package; + + -- The following procedure updates the global variable Zoo_Data_Base. + + procedure Enter_Data (A : Animal'Class; I : Integer) is + begin + Zoo_Data_Base (I) := Image (A); + end Enter_Data; + + begin + + -- Verify initial test conditions. + + if not (Zoo_Data_Base(1)(1..6) = " ") + or not + (Zoo_Data_Base(2)(1..6) = " ") + or not + (Zoo_Data_Base(3)(1..6) = " ") + then + Report.Failed ("Initial condition failure"); + end if; + + + -- Enter data from all three animals into the zoo database. + + Enter_Data (Macaw, 1); -- First entry in database. + Enter_Data (A => Manatee, I => 2); -- Second entry. + Enter_Data (Lemur, I => 3); -- Third entry. + + -- Verify the correct version of the overridden function Image was used + -- for entering the specific data. + + if not (Zoo_Data_Base(1)(1 .. 6) = "Animal") + or not + (Zoo_Data_Base(1)(26 .. 30) = "Macaw") + then + Report.Failed ("Incorrect version of Image for parent type"); + end if; + + if not (Zoo_Data_Base(2)(1 .. 6) = "Mammal" + and + Zoo_Data_Base(2)(27 .. 33) = "Manatee") + then + Report.Failed ("Incorrect version of Image for child type"); + end if; + + if not ((Zoo_Data_Base(3)(1 .. 7) = "Primate") + and + (Zoo_Data_Base(3)(30 .. 34) = "Lemur")) + then + Report.Failed ("Incorrect version of Image for grandchild type"); + end if; + + end; + + Report.Result; + + end CA11C02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11c03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11c03.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- CA11C03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that when a child unit is "withed", visibility is obtained to + -- all ancestor units named in the expanded name of the "withed" child + -- unit. Check that when the parent unit is "used", the simple name of + -- a "withed" child unit is made directly visible. + -- + -- TEST DESCRIPTION: + -- To satisfy the first part of the objective, various references are + -- made to types and functions declared in the ancestor packages of the + -- foundation code package hierarchy. Since the grandchild library unit + -- package has been "withed" by this test, the visibility of these + -- components demonstrates that visibility of the ancestor package names + -- is provided when the expanded name of a child library unit is "withed". + -- + -- The declare block in the test program includes a "use" clause of the + -- parent package (FA11C00_0.FA11C00_1) of the "withed" child package. + -- As a result, the simple name of the child package (FA11C00_2) is + -- directly visible. The type and function declared in the child + -- package are now visible when qualified with the simple name of the + -- "withed" package (FA11C00_2). + -- + -- This test simulates the formatting of data strings, based on the + -- component fields of a "doubly-extended" tagged record type. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11C00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FA11C00_0.FA11C00_1.FA11C00_2; -- "with" of child library package + -- Animal.Mammal.Primate. + -- This will be used in conjunction with + -- a "use" of FA11C00_0.FA11C00_1 below + -- to verify a portion of the objective. + with Report; + + procedure CA11C03 is + + Blank_Name_String : constant FA11C00_0.Species_Name_Type := (others => ' '); + -- Visibility of grandparent package. + -- The package FA11C00_0 is visible since + -- it is an ancestor that is mentioned in + -- the expanded name of its "withed" + -- grandchild package. + + Blank_Hair_Color : + String (1..FA11C00_0.FA11C00_1.Hair_Color_Type'Width) := (others => ' '); + -- Visibility of parent package. + -- The package FA11C00_0.FA11C00_1 is + -- visible due to the "with" of its + -- child package. + + subtype Data_String_Type is String (1 .. 60); + + TC_Result_String : Data_String_Type := (others => ' '); + + -- + + function Format_Primate_Data (Name : String := Blank_Name_String; + Hair : String := Blank_Hair_Color) + return Data_String_Type is + + Pos : Integer := 1; + Hair_Color_Field_Separator : constant String := " Hair Color: "; + + Result_String : Data_String_Type := (others => ' '); + + begin + Result_String (Pos .. Name'Length) := Name; -- Enter name at start + -- of string. + Pos := Pos + Name'Length; -- Increment counter to + -- next blank position. + Result_String + (Pos .. Pos + Hair_Color_Field_Separator'Length + Hair'Length - 1) := + Hair_Color_Field_Separator & Hair; -- Include hair color data + -- in result string. + return (Result_String); + end Format_Primate_Data; + + + begin + + Report.Test ("CA11C03", "Check that when a child unit is WITHED, " & + "visibility is obtained to all ancestor units " & + "named in the expanded name of the WITHED child " & + "unit. Check that when the parent unit is USED, " & + "the simple name of a WITHED child unit is made " & + "directly visible" ); + + declare + use FA11C00_0.FA11C00_1; -- This "use" clause will allow direct + -- visibility to the simple name of + -- package FA11C00_0.FA11C00_1.FA11C00_2, + -- since this child package was "withed" by + -- the main program. + + Tarsier : FA11C00_2.Primate := (Common_Name => "East-Indian Tarsier ", + Weight => 7, + Hair_Color => Brown, + Habitat => FA11C00_2.Arboreal); + + -- Demonstrates visibility of package + -- FA11C00_0.FA11C00_1.FA11C00_2. + -- + -- Type Primate referenced with the simple + -- name of package FA11C00_2 only. + -- + -- Simple name of package FA11C00_2 is + -- directly visible through "use" of parent. + + begin + + -- Verify that the Format_Primate_Data function will return a blank + -- filled string when no parameters are provided in the call. + + TC_Result_String := Format_Primate_Data; + + if (TC_Result_String (1 .. 20) /= Blank_Name_String) then + Report.Failed ("Incorrect initialization value from function"); + end if; + + + -- Use function Format_Primate_Data to return a formatted data string. + + TC_Result_String := + Format_Primate_Data + (Name => FA11C00_2.Image (Tarsier), + -- Function returns a 37 character string + -- value. + Hair => Hair_Color_Type'Image(Tarsier.Hair_Color)); + -- The Hair_Color_Type is referenced + -- directly, without package + -- FA11C00_0.FA11C00_1 qualifier. + -- No qualification of Hair_Color_Type is + -- needed due to "use" clause. + + -- Note that the result of calling 'Image + -- with an enumeration type argument + -- results in an upper-case string. + -- (See conditional statement below.) + + -- Verify the results of the function call. + + if not (TC_Result_String (1 .. 37) = + "Primate Species: East-Indian Tarsier " and then + TC_Result_String (38 .. 55) = + " Hair Color: BROWN") then + Report.Failed ("Incorrect result returned from function call"); + end if; + + end; + + Report.Result; + + end CA11C03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d010.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CA11D010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA11D013.AM + -- + -- TEST DESCRIPTION: + -- See CA11D013.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA11D00.A + -- => CA11D010.A + -- CA11D011.A + -- CA11D012.A + -- CA11D013.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + -- Child package of FA11D00. + + package FA11D00.CA11D010 is -- Add_Subtract_Complex + + procedure Add (Left, Right : in Complex_Type; -- Add two complex + C : out Complex_Type); -- numbers. + + function Subtract (Left, Right : Complex_Type) -- Subtract two + return Complex_Type; -- complex numbers. + + + + end FA11D00.CA11D010; -- Add_Subtract_Complex + + --=======================================================================-- + + with Report; + + package body FA11D00.CA11D010 is -- Add_Subtract_Complex + + procedure Add (Left, Right : in Complex_Type; + C : out Complex_Type) is + begin + -- Zero is declared in parent package. + + if Left.Real < Zero.Real or else Right.Real < Zero.Real + or else Left.Imag < Zero.Imag or else Right.Imag < Zero.Imag then + raise Add_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "procedure Add"); + else + C.Real := (Left.Real + Right.Real); + C.Imag := (Left.Imag + Right.Imag); + end if; + + exception + when Add_Error => + TC_Handled_In_Child_Pkg_Proc := true; + C := Check_Value; -- Reference to object in parent package. + raise; -- Reraise the Add_Error exception in the subtest. + Report.Failed ("Exception not reraised in handler"); + + when others => + Report.Failed ("Unexpected exception raised in Add"); + + end Add; + ----------------------------------------------------------- + function Subtract (Left, Right : Complex_Type) + return Complex_Type is + begin + -- Zero is declared in parent package. + if Left.Real < Zero.Real or Right.Real < Zero.Real + or Left.Imag < Zero.Imag or Right.Imag < Zero.Imag then + raise Subtract_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "function Subtract"); + else + return ( Real => (Left.Real - Right.Real), + Imag => (Left.Imag - Right.Imag) ); + end if; + + exception + when Subtract_Error => + Report.Comment ("Exception is properly handled in Subtract"); + TC_Handled_In_Child_Pkg_Func := true; + return Check_Value; + + when others => + Report.Failed ("Unexpected exception raised in Subtract"); + + end Subtract; + + end FA11D00.CA11D010; -- Add_Subtract_Complex diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d011.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- CA11D011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA11D013.AM + -- + -- TEST DESCRIPTION: + -- See CA11D013.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA11D00.A + -- CA11D010.A + -- => CA11D011.A + -- CA11D012.A + -- CA11D013.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Dec 94 SAIC Declared child procedure specification + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + + -- Child procedure of FA11D00. + + procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; + C : out Complex_Type); + + --=======================================================================-- + + procedure FA11D00.CA11D011 (Left, Right : in Complex_Type; + C : out Complex_Type) is + -- Multiply_Complex. + + begin + -- Zero is declared in parent package. + + if Left.Real < Zero.Real or Right.Imag < Zero.Imag then + raise Multiply_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "child procedure FA11D00.CA11D011"); + else + C.Real := (Left.Real * Right.Real); + C.Imag := (Left.Imag * Right.Imag); + end if; + + exception + when others => + TC_Handled_In_Child_Sub := true; + C := Check_Value; -- Reference to object in parent package. + + end FA11D00.CA11D011; -- Multiply_Complex diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d012.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- CA11D012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA11D013.AM + -- + -- TEST DESCRIPTION: + -- See CA11D013.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA11D00.A + -- CA11D010.A + -- CA11D011.A + -- => CA11D012.A + -- CA11D013.AM + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Dec 94 SAIC Declared child function specification + -- 26 Apr 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + + -- Child function of FA11D00. + -- Does not divide zero complex numbers. + + function FA11D00.CA11D012 (Left, Right : Complex_Type) + return Complex_Type; + + --=======================================================================-- + + function FA11D00.CA11D012 (Left, Right : Complex_Type) + return Complex_Type is -- Divide_Complex + + begin + -- Zero is declared in parent package. + + if Right.Real = Zero.Real or Right.Imag = Zero.Imag then + raise Divide_Error; -- Reference to exception in parent package. + Report.Failed ("Program control not transferred by raise in " & + "child function FA11D00.CA11D012"); + else + return ( Real => (Left.Real / Right.Real), + Imag => (Left.Imag / Right.Imag) ); + end if; + + end FA11D00.CA11D012; -- Divide_Complex diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d013.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d013.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d013.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d013.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- CA11D013.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a child unit can raise an exception that is declared in + -- parent. + -- + -- TEST DESCRIPTION: + -- Declare a package which defines complex number abstraction with + -- user-defined exceptions (foundation code). + -- + -- Add a public child package to the above package. Declare two + -- subprograms for the parent type. Each of the subprograms raises a + -- different exception, based on the value of an input parameter. + -- + -- Add a public child procedure to the foundation package. This + -- procedure raises an exception based on the value of an input + -- parameter. + -- + -- Add a public child function to the foundation package. This + -- function raises an exception based on the value of an input + -- parameter. + -- + -- In the main program, "with" the child packages, then check that + -- the exceptions are raised and handled as expected. Ensure that + -- exceptions are: + -- 1) raised in the public child package and handled/reraised to + -- be handled by the main program. + -- 2) raised and handled locally in the public child package. + -- 3) raised and handled locally by "others" in the public child + -- procedure. + -- 4) raised in the public child function and propagated to the + -- main program. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA11D00.A + -- CA11D010.A + -- CA11D011.A + -- CA11D012.A + -- => CA11D013.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FA11D00.CA11D010; -- Add_Subtract_Complex + with FA11D00.CA11D011; -- Multiply_Complex + with FA11D00.CA11D012; -- Divide_Complex + + with Report; + + + procedure CA11D013 is + + package Complex_Pkg renames FA11D00; + package Add_Subtract_Complex_Pkg renames FA11D00.CA11D010; + use Complex_Pkg; + + begin + + Report.Test ("CA11D013", "Check that a child unit can raise an " & + "exception that is declared in parent"); + + + Add_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (7))); + Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (3))); + Add_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (8)), + Int_Type (Report.Ident_Int (10))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-100)), + Int_Type (Report.Ident_Int (100))); + Complex_Num : Complex_Type := Zero; + + begin + Add_Subtract_Complex_Pkg.Add (First, Second, Complex_Num); + + if (Complex_Num /= Add_Result) then + Report.Failed ("Incorrect results from addition"); + end if; + + -- Error is raised in child package and exception + -- will be handled/reraised to caller. + + Add_Subtract_Complex_Pkg.Add (First, Third, Complex_Num); + + -- Error was not raised in child package. + Report.Failed ("Exception was not reraised in addition"); + + exception + when Add_Error => + if not TC_Handled_In_Child_Pkg_Proc then + Report.Failed ("Exception was not raised in addition"); + else + TC_Handled_In_Caller := true; -- Exception is reraised from + -- child package. + end if; + + when others => + Report.Failed ("Unexpected exception in addition subtest"); + TC_Handled_In_Caller := false; -- Improper exception handling + -- in caller. + + end Add_Complex_Subtest; + + + Subtract_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))); + Second : Complex_Type := Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (7))); + Sub_Result : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (1))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-200)), + Int_Type (Report.Ident_Int (1))); + Complex_Num : Complex_Type; + + begin + Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, First); + + if (Complex_Num /= Sub_Result) then + Report.Failed ("Incorrect results from subtraction"); + end if; + + -- Error is raised and exception will be handled in child package. + Complex_Num := Add_Subtract_Complex_Pkg.Subtract (Second, Third); + + exception + when Subtract_Error => + Report.Failed ("Exception raised in subtraction and " & + "propagated to caller"); + TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling + -- in caller. + + when others => + Report.Failed ("Unexpected exception in subtraction subtest"); + TC_Handled_In_Child_Pkg_Func := false; -- Improper exception handling + -- in caller. + + end Subtract_Complex_Subtest; + + + Multiply_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type(Report.Ident_Int(3)), + Int_Type (Report.Ident_Int (4))); + Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)), + Int_Type (Report.Ident_Int (3))); + Mult_Result : Complex_Type := Complex(Int_Type(Report.Ident_Int(15)), + Int_Type(Report.Ident_Int (12))); + Third : Complex_Type := Complex(Int_Type(Report.Ident_Int(10)), + Int_Type(Report.Ident_Int (-10))); + Complex_Num : Complex_Type; + + begin + CA11D011 (First, Second, Complex_Num); + + if (Complex_Num /= Mult_Result) then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled in child package. + CA11D011 (First, Third, Complex_Num); + + exception + when Multiply_Error => + Report.Failed ("Exception raised in multiplication and " & + "propagated to caller"); + TC_Handled_In_Child_Sub := false; -- Improper exception handling + -- in caller. + + when others => + Report.Failed ("Unexpected exception in multiplication subtest"); + TC_Handled_In_Child_Sub := false; -- Improper exception handling + -- in caller. + end Multiply_Complex_Subtest; + + + Divide_Complex_Subtest: + declare + First : Complex_Type := Complex (Int_Type (Report.Ident_Int(10)), + Int_Type (Report.Ident_Int (15))); + Second : Complex_Type := Complex (Int_Type(Report.Ident_Int(5)), + Int_Type (Report.Ident_Int (3))); + Div_Result : Complex_Type := Complex (Int_Type(Report.Ident_Int(2)), + Int_Type (Report.Ident_Int (5))); + Third : Complex_Type := Complex (Int_Type(Report.Ident_Int(-10)), + Int_Type (Report.Ident_Int (0))); + Complex_Num : Complex_Type := Zero; + + begin + Complex_Num := CA11D012 (First, Second); + + if (Complex_Num /= Div_Result) then + Report.Failed ("Incorrect results from division"); + end if; + + -- Error is raised in child package; exception will be + -- propagated to caller. + Complex_Num := CA11D012 (Second, Third); + + -- Error was not raised in child package. + Report.Failed ("Exception was not raised in division subtest "); + + exception + when Divide_Error => + TC_Propagated_To_Caller := true; -- Exception is propagated. + + when others => + Report.Failed ("Unexpected exception in division subtest"); + TC_Propagated_To_Caller := false; -- Improper exception handling + -- in caller. + end Divide_Complex_Subtest; + + + if not (TC_Handled_In_Caller and -- Check to see that all + TC_Handled_In_Child_Pkg_Proc and -- exceptions were handled in + TC_Handled_In_Child_Pkg_Func and -- the proper locations. + TC_Handled_In_Child_Sub and + TC_Propagated_To_Caller) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + + end CA11D013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,393 ---- + -- CA11D02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an exception declared in a package can be raised by a + -- child of a child package. Check that it can be renamed in the + -- child of the child package and raised with the correct effect. + -- + -- TEST DESCRIPTION: + -- Declare a package which defines complex number abstraction with + -- user-defined exceptions (foundation code). + -- + -- Add a public child package to the above package. Declare two + -- subprograms for the parent type. + -- + -- Add a public grandchild package to the foundation package. Declare + -- subprograms to raise exceptions. + -- + -- In the main program, "with" the grandchild package, then check that + -- the exceptions are raised and handled as expected. Ensure that + -- exceptions are: + -- 1) raised in the public grandchild package and handled/reraised to + -- be handled by the main program. + -- 2) raised and handled locally by the "others" handler in the + -- public grandchild package. + -- 3) raised in the public grandchild and propagated to the main + -- program. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11D00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Child package of FA11D00. + + package FA11D00.CA11D02_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) + return Complex_Type; -- Add two complex numbers. + + function "*" (Left, Right : Complex_Type) + return Complex_Type; -- Multiply two complex numbers. + + end FA11D00.CA11D02_0; -- Basic_Complex + + --=======================================================================-- + + package body FA11D00.CA11D02_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + -------------------------------------------------------------- + function "*" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( Real => (Left.Real * Right.Real), + Imag => (Left.Imag * Right.Imag) ); + end "*"; + + end FA11D00.CA11D02_0; -- Basic_Complex + + --=======================================================================-- + + -- Child package of FA11D00.CA11D02_0. + -- Grandchild package of FA11D00. + + package FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex + + Inverse_Error : exception renames Divide_Error; -- Reference to exception + -- in grandparent package. + Array_Size : constant := 2; + + type Complex_Array_Type is + array (1 .. Array_Size) of Complex_Type; -- Reference to type + -- in parent package. + + function Multiply (Left : Complex_Array_Type; -- Multiply two complex + Right : Complex_Array_Type) -- arrays. + return Complex_Array_Type; + + function Add (Left, Right : Complex_Array_Type) -- Add two complex + return Complex_Array_Type; -- arrays. + + procedure Inverse (Right : in Complex_Array_Type; -- Invert a complex + Left : in out Complex_Array_Type); -- array. + + end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex + + --=======================================================================-- + + with Report; + + + package body FA11D00.CA11D02_0.CA11D02_1 is -- Array_Complex + + function Multiply (Left : Complex_Array_Type; + Right : Complex_Array_Type) + return Complex_Array_Type is + + -- This procedure will raise an exception depending on the input + -- parameter. The exception will be handled locally by the + -- "others" handler. + + Result : Complex_Array_Type := (others => Zero); + + subtype Vector_Size is Positive range Left'Range; + + begin + if Left = Result or else Right = Result then -- Do not multiply zero. + raise Multiply_Error; -- Refence to exception in + -- grandparent package. + Report.Failed ("Program control not transferred by raise"); + else + for I in Vector_Size loop + Result(I) := ( Left(I) * Right(I) ); -- Basic_Complex."*". + end loop; + end if; + return (Result); + + exception + when others => + Report.Comment ("Exception is handled by others in Multiplication"); + TC_Handled_In_Grandchild_Pkg_Func := true; + return (Zero, Zero); + + end Multiply; + -------------------------------------------------------------- + function Add (Left, Right : Complex_Array_Type) + return Complex_Array_Type is + + -- This function will raise an exception depending on the input + -- parameter. The exception will be propagated and handled + -- by the caller. + + Result : Complex_Array_Type := (others => Zero); + + subtype Vector_Size is Positive range Left'Range; + + begin + if Left = Result or Right = Result then -- Do not add zero. + raise Add_Error; -- Refence to exception in + -- grandparent package. + Report.Failed ("Program control not transferred by raise"); + else + for I in Vector_Size loop + Result(I) := ( Left(I) + Right(I) ); -- Basic_Complex."+". + end loop; + end if; + return (Result); + + end Add; + -------------------------------------------------------------- + procedure Inverse (Right : in Complex_Array_Type; + Left : in out Complex_Array_Type) is + + -- This function will raise an exception depending on the input + -- parameter. The exception will be handled/reraised to be + -- handled by the caller. + + Result : Complex_Array_Type := (others => Zero); + + Array_With_Zero : boolean := false; + + begin + for I in 1 .. Right'Length loop + if Right(I) = Zero then -- Check for zero. + Array_With_Zero := true; + end if; + end loop; + + If Array_With_Zero then + raise Inverse_Error; -- Do not inverse zero. + Report.Failed ("Program control not transferred by raise"); + else + for I in 1 .. Array_Size loop + Left(I).Real := - Right(I).Real; + Left(I).Imag := - Right(I).Imag; + end loop; + end if; + + exception + when Inverse_Error => + TC_Handled_In_Grandchild_Pkg_Proc := true; + Left := Result; + raise; -- Reraise the Inverse_Error exception in the subtest. + Report.Failed ("Exception not reraised in handler"); + + when others => + Report.Failed ("Unexpected exception in procedure Inverse"); + end Inverse; + + end FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex + + --=======================================================================-- + + with FA11D00.CA11D02_0.CA11D02_1; -- Array_Complex, + -- implicitly with Basic_Complex. + with Report; + + procedure CA11D02 is + + package Complex_Pkg renames FA11D00; + package Array_Complex_Pkg renames FA11D00.CA11D02_0.CA11D02_1; + + use Complex_Pkg; + use Array_Complex_Pkg; + + begin + + Report.Test ("CA11D02", "Check that an exception declared in a package " & + "can be raised by a child of a child package"); + + Multiply_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (5))), + Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (8))) ); + Operand_2 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (1)), + Int_Type (Report.Ident_Int (2))), + Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))) ); + Operand_3 : Complex_Array_Type := ( Zero, Zero); + Mul_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (10))), + Complex (Int_Type (Report.Ident_Int (6)), + Int_Type (Report.Ident_Int (48))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + If (Multiply (Operand_1, Operand_2) /= Mul_Result) then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled in grandchild package. + + Complex_No := Multiply (Operand_1, Operand_3); + + if Complex_No /= (Zero, Zero) then + Report.Failed ("Exception was not raised in multiplication"); + end if; + + exception + when Multiply_Error => + Report.Failed ("Exception raised in multiplication and " & + "propagated to caller"); + TC_Handled_In_Grandchild_Pkg_Func := false; + -- Improper exception handling in caller. + + when others => + Report.Failed ("Unexpected exception in multiplication"); + TC_Handled_In_Grandchild_Pkg_Func := false; + -- Improper exception handling in caller. + + end Multiply_Complex_Subtest; + + + Add_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (7))), + Complex (Int_Type (Report.Ident_Int (5)), + Int_Type (Report.Ident_Int (8))) ); + Operand_2 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (4)), + Int_Type (Report.Ident_Int (1))), + Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (3))) ); + Operand_3 : Complex_Array_Type := ( Zero, Zero); + Add_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (6)), + Int_Type (Report.Ident_Int (8))), + Complex (Int_Type (Report.Ident_Int (7)), + Int_Type (Report.Ident_Int (11))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + Complex_No := Add (Operand_1, Operand_2); + + If (Complex_No /= Add_Result) then + Report.Failed ("Incorrect results from addition"); + end if; + + -- Error is raised in grandchild package and exception + -- will be propagated to caller. + + Complex_No := Add (Operand_1, Operand_3); + + if Complex_No = Add_Result then + Report.Failed ("Exception was not raised in addition"); + end if; + + exception + when Add_Error => + TC_Propagated_To_Caller := true; -- Exception is propagated. + + when others => + Report.Failed ("Unexpected exception in addition subtest"); + TC_Propagated_To_Caller := false; -- Improper exception handling + -- in caller. + end Add_Complex_Subtest; + + Inverse_Complex_Subtest: + declare + Operand_1 : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (1)), + Int_Type (Report.Ident_Int (5))), + Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (11))) ); + Operand_3 : Complex_Array_Type + := ( Zero, Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (6))) ); + Inv_Result : Complex_Array_Type + := ( Complex (Int_Type (Report.Ident_Int (-1)), + Int_Type (Report.Ident_Int (-5))), + Complex (Int_Type (Report.Ident_Int (-3)), + Int_Type (Report.Ident_Int (-11))) ); + Complex_No : Complex_Array_Type := (others => Zero); + + begin + Inverse (Operand_1, Complex_No); + + if (Complex_No /= Inv_Result) then + Report.Failed ("Incorrect results from inverse"); + end if; + + -- Error is raised in grandchild package and exception + -- will be handled/reraised to caller. + + Inverse (Operand_3, Complex_No); + + Report.Failed ("Exception was not handled in inverse"); + + exception + when Inverse_Error => + if not TC_Handled_In_Grandchild_Pkg_Proc then + Report.Failed ("Exception was not raised in inverse"); + else + TC_Handled_In_Caller := true; -- Exception is reraised from + -- child package. + end if; + + when others => + Report.Failed ("Unexpected exception in inverse"); + TC_Handled_In_Caller := false; + -- Improper exception handling in caller. + + end Inverse_Complex_Subtest; + + if not (TC_Handled_In_Caller and -- Check to see that all + TC_Handled_In_Grandchild_Pkg_Proc and -- exceptions were handled + TC_Handled_In_Grandchild_Pkg_Func and -- in proper location. + TC_Propagated_To_Caller) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + + end CA11D02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca11d03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca11d03.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- CA11D03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an exception declared in a package can be raised by a + -- client of a child of the package. Check that it can be renamed in + -- the client of the child of the package and raised with the correct + -- effect. + -- + -- TEST DESCRIPTION: + -- Declare a package which defines complex number abstraction with + -- user-defined exceptions (foundation code). + -- + -- Add a public child package to the above package. Declare two + -- subprograms for the parent type. + -- + -- In the main program, "with" the child package, then check that + -- an exception can be raised and handled as expected. + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- + -- FA11D00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Child package of FA11D00. + package FA11D00.CA11D03_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) + return Complex_Type; -- Add two complex numbers. + + function "*" (Left, Right : Complex_Type) + return Complex_Type; -- Multiply two complex numbers. + + end FA11D00.CA11D03_0; -- Basic_Complex + + --=======================================================================-- + + package body FA11D00.CA11D03_0 is -- Basic_Complex + + function "+" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( (Left.Real + Right.Real, Left.Imag + Right.Imag) ); + end "+"; + -------------------------------------------------------------- + function "*" (Left, Right : Complex_Type) return Complex_Type is + begin + return ( Real => (Left.Real * Right.Real), + Imag => (Left.Imag * Right.Imag) ); + end "*"; + + end FA11D00.CA11D03_0; -- Basic_Complex + + --=======================================================================-- + + with FA11D00.CA11D03_0; -- Basic_Complex, + -- implicitly with Complex_Definition. + with Report; + + procedure CA11D03 is + + package Complex_Pkg renames FA11D00; -- Complex_Definition_Pkg + package Basic_Complex_Pkg renames FA11D00.CA11D03_0; -- Basic_Complex + + use Complex_Pkg; + use Basic_Complex_Pkg; + + TC_Handled_In_Subtest_1, + TC_Handled_In_Subtest_2 : boolean := false; + + begin + + Report.Test ("CA11D03", "Check that an exception declared in a package " & + "can be raised by a client of a child of the package"); + + Multiply_Complex_Subtest: + declare + Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (3)), + Int_Type (Report.Ident_Int (2))); + -- Referenced to function in parent package. + Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (10)), + Int_Type (Report.Ident_Int (8))); + Mul_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (30)), + Int_Type (Report.Ident_Int (16))); + Complex_No : Complex_Type := Zero; -- Zero is declared in parent package. + begin + Complex_No := Operand_1 * Operand_2; -- Basic_Complex."*". + if Complex_No /= Mul_Res then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled. + if Complex_No = Mul_Res then + raise Multiply_Error; -- Reference to exception in + end if; -- parent package. + + exception + when Multiply_Error => + TC_Handled_In_Subtest_1 := true; + when others => + TC_Handled_In_Subtest_1 := false; -- Improper exception handling. + + end Multiply_Complex_Subtest; + + Add_Complex_Subtest: + declare + Error_In_Client : exception renames Add_Error; + -- Reference to exception in parent package. + Operand_1 : Complex_Type := Complex (Int_Type (Report.Ident_Int (2)), + Int_Type (Report.Ident_Int (7))); + Operand_2 : Complex_Type := Complex (Int_Type (Report.Ident_Int (-4)), + Int_Type (Report.Ident_Int (1))); + Add_Res : Complex_type := Complex (Int_Type (Report.Ident_Int (-2)), + Int_Type (Report.Ident_Int (8))); + Complex_No : Complex_Type := One; -- One is declared in parent + -- package. + begin + Complex_No := Operand_1 + Operand_2; -- Basic_Complex."+". + + if Complex_No /= Add_Res then + Report.Failed ("Incorrect results from multiplication"); + end if; + + -- Error is raised and exception will be handled. + if Complex_No = Add_Res then + raise Error_In_Client; + end if; + + exception + when Error_In_Client => + TC_Handled_In_Subtest_2 := true; + + when others => + TC_Handled_In_Subtest_2 := false; -- Improper exception handling. + + end Add_Complex_Subtest; + + if not (TC_Handled_In_Subtest_1 and -- Check to see that all + TC_Handled_In_Subtest_2) -- exceptions were handled + -- in the proper location. + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + Report.Result; + + end CA11D03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13001.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,370 ---- + -- CA13001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a separate protected unit declared in a non-generic child + -- unit of a private parent have the same visibility into its parent, + -- its siblings, and packages on which its parent depends as is available + -- at the point of their declaration. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential of having all + -- members of one family to take out a transportation. The restriction + -- is depend on each member to determine who can get a car, a clunker, + -- or a bicycle. If no transportation is available, that member has to + -- walk. + -- + -- Declare a package with location for each family member. Declare + -- a public parent package. Declare a private child package. Declare a + -- public grandchild of this private package. Declare a protected unit + -- as a subunit in a public grandchild package. This subunit has + -- visibility into it's parent body ancestor and its sibling. + -- + -- Declare another public parent package. The body of this package has + -- visibility into its private sibling's descendants. + -- + -- In the main program, "with"s the parent package. Check that the + -- protected subunit performs as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Nov 95 SAIC Update and repair for ACVC 2.0.1 + -- + --! + + package CA13001_0 is + + type Location is (School, Work, Beach, Home); + type Family is (Father, Mother, Teen); + Destination : array (Family) of Location; + + -- Other type definitions and procedure declarations in real application. + + end CA13001_0; + + -- No bodies required for CA13001_0. + + --==================================================================-- + + -- Public parent. + + package CA13001_1 is + + type Transportation is (Bicycle, Clunker, New_Car); + type Key_Type is private; + Walking : boolean := false; + + -- Other type definitions and procedure declarations in real application. + + private + type Key_Type + is range Transportation'pos(Bicycle) .. Transportation'pos(New_Car); + + end CA13001_1; + + -- No bodies required for CA13001_1. + + --==================================================================-- + + -- Private child. + + private package CA13001_1.CA13001_2 is + + type Transport is + record + In_Use : boolean := false; + end record; + Vehicles : array (Transportation) of Transport; + + -- Other type definitions and procedure declarations in real application. + + end CA13001_1.CA13001_2; + + -- No bodies required for CA13001_1.CA13001_2. + + --==================================================================-- + + -- Public grandchild of a private parent. + + package CA13001_1.CA13001_2.CA13001_3 is + + Flat_Tire : array (Transportation) of boolean := (others => false); + + -- Other type definitions and procedure declarations in real application. + + end CA13001_1.CA13001_2.CA13001_3; + + -- No bodies required for CA13001_1.CA13001_2.CA13001_3. + + --==================================================================-- + + -- Context clauses required for visibility needed by a separate subunit. + + with CA13001_0; + use CA13001_0; + + -- Public grandchild of a private parent. + + package CA13001_1.CA13001_2.CA13001_4 is + + type Transit is + record + Available : boolean := false; + end record; + type Keys_Array is array (Transportation) of Transit; + Fuel : array (Transportation) of boolean := (others => true); + + protected Family_Transportation is + + procedure Get_Vehicle (Who : in Family; + Key : out Key_Type); + procedure Return_Vehicle (Tr : in Transportation); + function TC_Verify (What : Transportation) return boolean; + + private + Keys : Keys_Array; + + end Family_Transportation; + + end CA13001_1.CA13001_2.CA13001_4; + + --==================================================================-- + + -- Context clause required for visibility needed by a separate subunit. + + with CA13001_1.CA13001_2.CA13001_3; -- Public sibling. + + package body CA13001_1.CA13001_2.CA13001_4 is + + protected body Family_Transportation is separate; + + end CA13001_1.CA13001_2.CA13001_4; + + --==================================================================-- + + separate (CA13001_1.CA13001_2.CA13001_4) + protected body Family_Transportation is + + procedure Get_Vehicle (Who : in Family; + Key : out Key_Type) is + begin + case Who is + when Father|Mother => + -- Drive new car to work + + -- Reference package with'ed by the subunit parent's body. + if Destination(Who) = Work then + + -- Reference type declared in the private parent of the subunit + -- parent's body. + -- Reference type declared in the visible part of the + -- subunit parent's body. + if not Vehicles(New_Car).In_Use and Fuel(New_Car) + + -- Reference type declared in the public sibling of the + -- subunit parent's body. + and not CA13001_1.CA13001_2.CA13001_3.Flat_Tire(New_Car) then + Vehicles(New_Car).In_Use := true; + + -- Reference type declared in the private part of the + -- protected subunit. + Keys(New_Car).Available := false; + Key := Transportation'pos(New_Car); + else + -- Reference type declared in the grandparent of the subunit + -- parent's body. + Walking := true; + end if; + + -- Drive clunker to other destinations. + else + if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not + CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then + Vehicles(Clunker).In_Use := true; + Keys(Clunker).Available := false; + Key := Transportation'pos(Clunker); + else + Walking := true; + Key := Transportation'pos(Bicycle); + end if; + end if; + + -- Similar for Teen. + when Teen => + if not Vehicles(Clunker).In_Use and Fuel(Clunker) and not + CA13001_1.CA13001_2.CA13001_3.Flat_Tire(Clunker) then + Vehicles(Clunker).In_Use := true; + Keys(Clunker).Available := false; + Key := Transportation'pos(Clunker); + else + Walking := true; + Key := Transportation'pos(Bicycle); + end if; + end case; + + end Get_Vehicle; + + ---------------------------------------------------------------- + + -- Any family member can bring back the transportation with the key. + + procedure Return_Vehicle (Tr : in Transportation) is + begin + Vehicles(Tr).In_Use := false; + Keys(Tr).Available := true; + end Return_Vehicle; + + ---------------------------------------------------------------- + + function TC_Verify (What : Transportation) return boolean is + begin + return Keys(What).Available; + end TC_Verify; + + end Family_Transportation; + + --==================================================================-- + + with CA13001_0; + use CA13001_0; + + -- Public child. + + package CA13001_1.CA13001_5 is + + -- In a real application, tasks could be used to demonstrate + -- a family transportation scenario, i.e., each member of + -- a family can take a vehicle out concurrently, then return + -- them at the same time. For the purposes of the test, family + -- transportation happens sequentially. + + procedure Provide_Transportation (Who : in Family; + Get_Key : out Key_Type; + Get_Veh : out boolean); + procedure Return_Transportation (What : in Transportation; + Rt_Veh : out boolean); + + end CA13001_1.CA13001_5; + + --==================================================================-- + + with CA13001_1.CA13001_2.CA13001_4; -- Public grandchild of a private parent, + -- implicitly with CA13001_1.CA13001_2. + package body CA13001_1.CA13001_5 is + + package Transportation_Pkg renames CA13001_1.CA13001_2.CA13001_4; + use Transportation_Pkg; + + -- These two validation subprograms provide the capability to check the + -- components defined in the private packages from within the client + -- program. + + procedure Provide_Transportation (Who : in Family; + Get_Key : out Key_Type; + Get_Veh : out boolean) is + begin + -- Goto work, school, or to the beach. + Family_Transportation.Get_Vehicle (Who, Get_Key); + if not Family_Transportation.TC_Verify + (Transportation'Val(Get_Key)) then + Get_Veh := true; + else + Get_Veh := false; + end if; + + end Provide_Transportation; + + ---------------------------------------------------------------- + + procedure Return_Transportation (What : in Transportation; + Rt_Veh : out boolean) is + begin + Family_Transportation.Return_Vehicle (What); + if Family_Transportation.TC_Verify(What) and + not CA13001_1.CA13001_2.Vehicles(What).In_Use then + Rt_Veh := true; + else + Rt_Veh := false; + end if; + + end Return_Transportation; + + end CA13001_1.CA13001_5; + + --==================================================================-- + + with CA13001_0; + with CA13001_1.CA13001_5; -- Implicitly with parent, CA13001_1. + with Report; + + procedure CA13001 is + + Mommy : CA13001_0.Family := CA13001_0.Mother; + Daddy : CA13001_0.Family := CA13001_0.Father; + BG : CA13001_0.Family := CA13001_0.Teen; + BG_Clunker : CA13001_1.Transportation := CA13001_1.Clunker; + Get_Key : CA13001_1.Key_Type; + Get_Transit : boolean := false; + Return_Transit : boolean := false; + + begin + Report.Test ("CA13001", "Check that a protected subunit declared in " & + "a child unit of a private parent have the same visibility " & + "into its parent, its parent's siblings, and packages on " & + "which its parent depends"); + + -- Get transportation for mother to go to work. + CA13001_0.Destination(CA13001_0.Mother) := CA13001_0.Work; + CA13001_1.CA13001_5.Provide_Transportation (Mommy, Get_Key, Get_Transit); + if not Get_Transit then + Report.Failed ("Failed to get mother transportation"); + end if; + + -- Get transportation for teen to go to school. + CA13001_0.Destination(CA13001_0.Teen) := CA13001_0.School; + Get_Transit := false; + CA13001_1.CA13001_5.Provide_Transportation (BG, Get_Key, Get_Transit); + if not Get_Transit then + Report.Failed ("Failed to get teen transportation"); + end if; + + -- Get transportation for father to go to the beach. + CA13001_0.Destination(CA13001_0.Father) := CA13001_0.Beach; + Get_Transit := false; + CA13001_1.CA13001_5.Provide_Transportation (Daddy, Get_Key, Get_Transit); + if Get_Transit and not CA13001_1.Walking then + Report.Failed ("Failed to make daddy to walk to the beach"); + end if; + + -- Return the clunker. + CA13001_1.CA13001_5.Return_Transportation (BG_Clunker, Return_Transit); + if not Return_Transit then + Report.Failed ("Failed to get back the clunker"); + end if; + + Report.Result; + + end CA13001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13002.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- CA13002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that two library child units and/or subunits may have the same + -- simple names if they have distinct expanded names. + -- + -- TEST DESCRIPTION: + -- Declare a package that provides some primitive functionality (minimal + -- terminal driver operations in this case). Add child packages to + -- expand the functionality for different but related contexts (different + -- terminal kinds). Add child packages, or subunits, to the children to + -- provide the same high level operation for each of the different + -- contexts (terminals). Since the operations are the same, at the leaf + -- level they are likely to have the same names. + -- + -- The main program "with"s the child packages. Check that the + -- child units and subunits perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Public parent. + package CA13002_0 is -- Terminal_Driver. + + type TC_Name is (First_Child, Second_Child, Third_Child, Fourth_Child); + type TC_Call_From is (First_Grandchild, Second_Grandchild, First_Subunit, + Second_Subunit); + type TC_Calls_Arr is array (TC_Name, TC_Call_From) of boolean; + TC_Calls : TC_Calls_Arr := (others => (others => false)); + + -- In real application, Send_Control_Sequence sends keystrokes from + -- the terminal, i.e., space, escape, etc. + procedure Send_Control_Sequence (Row : in TC_Name; + Col : in TC_Call_From); + + end CA13002_0; + + --==================================================================-- + + -- First child. + package CA13002_0.CA13002_1 is -- Terminal_Driver.VT100 + + -- Move cursor up, down, left, or right. + procedure Move_Cursor (Col : in TC_Call_From); + + end CA13002_0.CA13002_1; + + --==================================================================-- + + -- First grandchild. + procedure CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up + + --==================================================================-- + + -- Second child. + package CA13002_0.CA13002_2 is -- Terminal_Driver.IBM3270 + + procedure Move_Cursor (Col : in TC_Call_From); + + end CA13002_0.CA13002_2; + + --==================================================================-- + + -- Second grandchild. + procedure CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up + + --==================================================================-- + + -- Third child. + package CA13002_0.CA13002_3 is -- Terminal_Driver.DOS_ANSI + + procedure Move_Cursor (Col : in TC_Call_From); + + procedure CA13002_5; -- Terminal_Driver.DOS_ANSI.Cursor_Up + -- implementation will be as a + -- separate subunit. + end CA13002_0.CA13002_3; + + --==================================================================-- + + -- Fourth child. + package CA13002_0.CA13002_4 is -- Terminal_Driver.WYSE + + procedure Move_Cursor (Col : in TC_Call_From); + + procedure CA13002_5; -- Terminal_Driver.WYSE.Cursor_Up + -- implementation will be as a + -- separate subunit. + + end CA13002_0.CA13002_4; + + --==================================================================-- + + -- Terminal_Driver. + package body CA13002_0 is + + procedure Send_Control_Sequence (Row : in TC_Name; + Col : in TC_Call_From) is + begin + -- Reads a key and takes action. + TC_Calls (Row, Col) := true; + end Send_Control_Sequence; + + end CA13002_0; + + --==================================================================-- + + -- Terminal_Driver.VT100. + package body CA13002_0.CA13002_1 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (First_Child, Col); + end Move_Cursor; + + end CA13002_0.CA13002_1; + + --==================================================================-- + + -- Terminal_Driver.VT100.Cursor_Up. + procedure CA13002_0.CA13002_1.CA13002_5 is + begin + Move_Cursor (First_Grandchild); -- from Terminal_Driver.VT100. + end CA13002_0.CA13002_1.CA13002_5; + + --==================================================================-- + + -- Terminal_Driver.IBM3270. + package body CA13002_0.CA13002_2 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Second_Child, Col); + end Move_Cursor; + + end CA13002_0.CA13002_2; + + --==================================================================-- + + -- Terminal_Driver.IBM3270.Cursor_Up. + procedure CA13002_0.CA13002_2.CA13002_5 is + begin + Move_Cursor (Second_Grandchild); -- from Terminal_Driver.IBM3270. + end CA13002_0.CA13002_2.CA13002_5; + + --==================================================================-- + + -- Terminal_Driver.DOS_ANSI. + package body CA13002_0.CA13002_3 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Third_Child, Col); + end Move_Cursor; + + procedure CA13002_5 is separate; + + end CA13002_0.CA13002_3; + + --==================================================================-- + + -- Terminal_Driver.DOS_ANSI.Cursor_Up. + separate (CA13002_0.CA13002_3) + procedure CA13002_5 is + begin + Move_Cursor (First_Subunit); -- from Terminal_Driver.DOS_ANSI. + end CA13002_5; + + --==================================================================-- + + -- Terminal_Driver.WYSE. + package body CA13002_0.CA13002_4 is + + procedure Move_Cursor (Col : in TC_Call_From) is + begin + Send_Control_Sequence (Fourth_Child, Col); + end Move_Cursor; + + procedure CA13002_5 is separate; + + end CA13002_0.CA13002_4; + + --==================================================================-- + + -- Terminal_Driver.WYSE.Cursor_Up. + separate (CA13002_0.CA13002_4) + procedure CA13002_5 is + begin + Move_Cursor (Second_Subunit); -- from Terminal_Driver.WYSE. + end CA13002_5; + + --==================================================================-- + + with CA13002_0.CA13002_1.CA13002_5; -- Terminal_Driver.VT100.Cursor_Up, + -- implicitly with parent, CA13002_0. + with CA13002_0.CA13002_2.CA13002_5; -- Terminal_Driver.IBM3270.Cursor_Up. + with CA13002_0.CA13002_3; -- Terminal_Driver.DOS_ANSI. + with CA13002_0.CA13002_4; -- Terminal_Driver.WYSE. + with Report; + use CA13002_0; -- All primitive subprograms directly + -- visible. + + procedure CA13002 is + Expected_Calls : constant CA13002_0.TC_Calls_Arr + := ((true, false, false, false), + (false, true , false, false), + (false, false, true , false), + (false, false, false, true )); + begin + Report.Test ("CA13002", "Check that two library units and/or subunits " & + "may have the same simple names if they have distinct " & + "expanded names"); + + -- Note that the leaves all have the same name. + -- Call the first grandchild. + CA13002_0.CA13002_1.CA13002_5; + + -- Call the second grandchild. + CA13002_0.CA13002_2.CA13002_5; + + -- Call the first subunit. + CA13002_0.CA13002_3.CA13002_5; + + -- Call the second subunit. + CA13002_0.CA13002_4.CA13002_5; + + if TC_Calls /= Expected_Calls then + Report.Failed ("Wrong result"); + end if; + + Report.Result; + + end CA13002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13003.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,256 ---- + -- CA13003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that separate subunits which share an ancestor may have the + -- same name if they have different fully qualified names. Check + -- the case of separate subunits of separate subunits. + -- This test is a change in semantics from Ada 83 to Ada 9X. + -- + -- TEST DESCRIPTION: + -- Declare a package that provides file processing operations. Declare + -- one separate package to do the file processing, and another to do the + -- auditing. These packages contain similar functions declared in + -- separate subunits. Verify that the main program can call the + -- separate subunits with the same name. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Simulates a file processing application. The processing package opens + -- files, reads files, does file processing, and generates reports. + -- The auditing package opens files, read files, and generates reports. + + package CA13003_0 is + + type File_ID is range 1 .. 100; + subtype File_Name is string (1 .. 10); + + TC_Open_For_Process : boolean := false; + TC_Open_For_Audit : boolean := false; + TC_Report_From_Process : boolean := false; + TC_Report_From_Audit : boolean := false; + + type File_Rec is + record + Name : File_Name; + ID : File_ID; + end record; + + procedure Initialize_File_Rec (Name_In : in File_Name; + ID_In : in File_ID; + File_In : out File_Rec); + + ---------------------------------------------------------------------- + + package CA13003_1 is -- File processing + + procedure CA13003_3; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name; -- Process files + package CA13003_5 is -- Generate report + procedure Generate_Report; + end CA13003_5; + + end CA13003_1; + + ---------------------------------------------------------------------- + + package CA13003_2 is -- File auditing + + procedure CA13003_3; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name; -- Process files + package CA13003_5 is -- Generate report + procedure Generate_Report; + end CA13003_5; + + end CA13003_2; + + end CA13003_0; + + --==================================================================-- + + package body CA13003_0 is + + procedure Initialize_File_Rec (Name_In : in File_Name; + ID_In : in File_ID; + File_In : out File_Rec) is + -- Not a real initialization. Real application can use file + -- database to create the file record. + begin + File_In.Name := Name_In; + File_In.ID := ID_In; + end Initialize_File_Rec; + + package body CA13003_1 is separate; + package body CA13003_2 is separate; + + end CA13003_0; + + --==================================================================-- + + separate (CA13003_0) + package body CA13003_1 is + + procedure CA13003_3 is separate; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name is separate; -- Process files + package body CA13003_5 is separate; -- Generate report + + end CA13003_1; + + --==================================================================-- + + separate (CA13003_0.CA13003_1) + procedure CA13003_3 is -- Open files + begin + -- In real file processing application, open file from database, setup + -- data structure, etc. + TC_Open_For_Process := true; + end CA13003_3; + + --==================================================================-- + + separate (CA13003_0.CA13003_1) + function CA13003_4 (ID_In : File_ID; -- Process files + File_In : File_Rec) return File_Name is + begin + -- In real file processing application, process files for more information. + return File_In.Name; + end CA13003_4; + + --==================================================================-- + + separate (CA13003_0.CA13003_1) + package body CA13003_5 is -- Generate report + procedure Generate_Report is + begin + -- In real file processing application, generate various report from the + -- file database. + TC_Report_From_Process := true; + end Generate_Report; + + end CA13003_5; + + --==================================================================-- + + separate (CA13003_0) + package body CA13003_2 is + + procedure CA13003_3 is separate; -- Open files + function CA13003_4 (ID_In : File_ID; File_In : File_Rec) + return File_Name is separate; -- Process files + package body CA13003_5 is separate; -- Generate report + + end CA13003_2; + + --==================================================================-- + + separate (CA13003_0.CA13003_2) + procedure CA13003_3 is -- Open files + begin + TC_Open_For_Audit := true; + end CA13003_3; + + --==================================================================-- + + separate (CA13003_0.CA13003_2) + function CA13003_4 (ID_In : File_ID; + File_In : File_Rec) return File_Name is + begin + return File_In.Name; + end CA13003_4; + + --==================================================================-- + + separate (CA13003_0.CA13003_2) + package body CA13003_5 is -- Generate report + procedure Generate_Report is + begin + TC_Report_From_Audit := true; + end Generate_Report; + + end CA13003_5; + + --==================================================================-- + + with CA13003_0; + with Report; + + procedure CA13003 is + First_File_Name : CA13003_0.File_Name := "Joe Smith "; + First_File_Id : CA13003_0.File_ID := 11; + Second_File_Name : CA13003_0.File_Name := "John Schep"; + Second_File_Id : CA13003_0.File_ID := 47; + Expected_Name : CA13003_0.File_Name := " "; + Student_File : CA13003_0.File_Rec; + + function Process_Input_Files (ID_In : CA13003_0.File_ID; + File_In : CA13003_0.File_Rec) return + CA13003_0.File_Name renames CA13003_0.CA13003_1.CA13003_4; + + function Process_Audit_Files (ID_In : CA13003_0.File_ID; + File_In : CA13003_0.File_Rec) return + CA13003_0.File_Name renames CA13003_0.CA13003_2.CA13003_4; + begin + Report.Test ("CA13003", "Check that separate subunits which share " & + "an ancestor may have the same name if they have " & + "different fully qualified names"); + + Student_File := (ID => First_File_Id, Name => First_File_Name); + + -- Note that all subunits have the same simple name. + -- Generate report from file processing. + CA13003_0.CA13003_1.CA13003_3; + Expected_Name := Process_Input_Files (First_File_Id, Student_File); + CA13003_0.CA13003_1.CA13003_5.Generate_Report; + + if not CA13003_0.TC_Open_For_Process or + not CA13003_0.TC_Report_From_Process or + Expected_Name /= First_File_Name then + Report.Failed ("Unexpected results in processing file"); + end if; + + CA13003_0.Initialize_File_Rec + (Second_File_Name, Second_File_Id, Student_File); + + -- Generate report from file auditing. + CA13003_0.CA13003_2.CA13003_3; + Expected_Name := Process_Audit_Files (Second_File_Id, Student_File); + CA13003_0.CA13003_2.CA13003_5.Generate_Report; + + if not CA13003_0.TC_Open_For_Audit or + not CA13003_0.TC_Report_From_Audit or + Expected_Name /= Second_File_Name then + Report.Failed ("Unexpected results in auditing file"); + end if; + + Report.Result; + + end CA13003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13a01.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,320 ---- + -- CA13A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subunits declared in non-generic child units of a public + -- parent have the same visibility into its parent, its siblings + -- (public and private), and packages on which its parent depends + -- as is available at the point of their declaration. + -- + -- TEST DESCRIPTION: + -- Declare an check system procedure as a subunit in a private child + -- package of the basic operation package (FA13A00.A). This procedure + -- has visibility into its parent ancestor and its private sibling. + -- + -- Declare an emergency procedure as a subunit in a public child package + -- of the basic operation package (FA13A00.A). This procedure has + -- visibility into its parent ancestor and its private sibling. + -- + -- Declare an express procedure as a subunit in a public child subprogram + -- of the basic operation package (FA13A00.A). This procedure has + -- visibility into its parent ancestor and its public sibling. + -- + -- In the main program, "with"s the child package and subprogram. Check + -- that subunits perform as expected. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA13A00.A + -- CA13A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Private child package of an elevator application. This package + -- provides maintenance operations. + + private package FA13A00_1.CA13A01_4 is -- Maintenance operation + + One_Floor : Floor_No := 1; -- Type declared in parent. + + procedure Check_System; + + -- other type definitions and procedure declarations in real application. + + end FA13A00_1.CA13A01_4; + + --==================================================================-- + + -- Context clauses required for visibility needed by separate subunit. + + with FA13A00_0; -- Building Manager + + with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + + with FA13A00_1.FA13A00_3; -- Move Elevator + + use FA13A00_0; + + package body FA13A00_1.CA13A01_4 is + + procedure Check_System is separate; + + end FA13A00_1.CA13A01_4; + + --==================================================================-- + + separate (FA13A00_1.CA13A01_4) + + -- Subunit Check_System declared in Maintenance Operation. + + procedure Check_System is + begin + -- See if regular power is on. + + if Power /= V120 then -- Reference package with'ed by + TC_Operation := false; -- the subunit parent's body. + end if; + + -- Test elevator function. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of + (Penthouse, Call_Waiting); -- the subunit parent's body. + + if not Call_Waiting (Penthouse) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit package's + -- body. + end if; + + FA13A00_1.FA13A00_2.Down (One_Floor); -- Reference private sibling of + -- the subunit parent's body. + + if Current_Floor /= Floor'pred (Penthouse) then + TC_Operation := false; -- Reference type declared in the + end if; -- parent of the subunit parent's + -- body. + + end Check_System; + + --==================================================================-- + + -- Public child package of an elevator application. This package provides + -- an emergency operation. + + package FA13A00_1.CA13A01_5 is -- Emergency Operation + + -- Other type definitions in real application. + + procedure Emergency; + + private + type Bell_Type is (Inactive, Active); + + end FA13A00_1.CA13A01_5; + + --==================================================================-- + + -- Context clauses required for visibility needed by separate subunit. + + with FA13A00_0; -- Building Manager + + with FA13A00_1.FA13A00_3; -- Move Elevator + + with FA13A00_1.CA13A01_4; -- Maintenance Operation (private) + + use FA13A00_0; + + package body FA13A00_1.CA13A01_5 is + + procedure Emergency is separate; + + end FA13A00_1.CA13A01_5; + + --==================================================================-- + + separate (FA13A00_1.CA13A01_5) + + -- Subunit Emergency declared in Maintenance Operation. + + procedure Emergency is + Bell : Bell_Type; -- Reference type declared in the + -- subunit parent's body. + + begin + -- Calls maintenance operation. + + FA13A00_1.CA13A01_4.Check_System; -- Reference private sibling of the + -- subunit parent 's body. + + -- Clear all calls to the elevator. + + Clear_Calls (Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + for I in Floor loop + if Call_Waiting (I) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + end loop; + + -- Move elevator to the basement. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the + (Basement, Call_Waiting); -- subunit parent's body. + + if Current_Floor /= Basement then -- Reference type declared in the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Shut off power. + + Power := Off; -- Reference package with'ed by + -- the subunit parent's body. + + -- Activate bell. + + Bell := Active; -- Reference type declared in the + -- subunit parent's body. + + end Emergency; + + --==================================================================-- + + -- Public child subprogram of an elevator application. This subprogram + -- provides an express operation. + + procedure FA13A00_1.CA13A01_6; + + --==================================================================-- + + -- Context clauses required for visibility needed by separate subunit. + + with FA13A00_0; -- Building Manager + + with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + + with FA13A00_1.FA13A00_3; -- Move Elevator + + use FA13A00_0; + + procedure FA13A00_1.CA13A01_6 is -- Express Operation + + -- Other type definitions in real application. + + procedure GoTo_Penthouse is separate; + + begin + GoTo_Penthouse; + + end FA13A00_1.CA13A01_6; + + --==================================================================-- + + separate (FA13A00_1.CA13A01_6) + + -- Subunit GoTo_Penthouse declared in Express Operation. + + procedure GoTo_Penthouse is + begin + -- Go faster. + + Power := V240; -- Reference package with'ed by + -- the subunit parent's body. + + -- Call elevator. + + Call (Penthouse, Call_Waiting); -- Reference subprogram declared in + -- the parent of the subunit + -- parent's body. + + if not Call_Waiting (Penthouse) then -- Reference private part of the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Move elevator to Penthouse. + + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of the + (Penthouse, Call_Waiting); -- subunit parent's body. + + if Current_Floor /= Penthouse then -- Reference type declared in the + TC_Operation := false; -- parent of the subunit parent's + end if; -- body. + + -- Return slowly + + while Current_Floor /= Floor1 loop -- Reference type, subprogram + FA13A00_1.FA13A00_2.Down (1); -- declared in the parent of the + -- subunit parent's body. + end loop; + + if Current_Floor /= Floor1 then -- Reference type declared in + TC_Operation := false; -- the parent of the subunit + end if; -- parent's body. + + -- Back to normal. + + Power := V120; -- Reference package with'ed by + -- the subunit parent's body. + + end GoTo_Penthouse; + + --==================================================================-- + + with FA13A00_1.CA13A01_5; -- Emergency Operation + -- implicitly with Basic Elevator + -- Operations + + with FA13A00_1.CA13A01_6; -- Express Operation + + with Report; + + procedure CA13A01 is + + begin + + Report.Test ("CA13A01", "Check that subunits declared in non-generic " & + "child units of a public parent have the same visibility " & + "into its parent, its parent's siblings, and packages on " & + "which its parent depends"); + + -- Go to Penthouse. + + FA13A00_1.CA13A01_6; + + -- Call emergency operation. + + FA13A00_1.CA13A01_5.Emergency; + + if not FA13A00_1.TC_Operation then + Report.Failed ("Incorrect elevator operation"); + end if; + + Report.Result; + + end CA13A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca13a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca13a02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,301 ---- + -- CA13A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subunits declared in generic child units of a public + -- parent have the same visibility into its parent, its siblings + -- (public and private), and packages on which its parent depends + -- as is available at the point of their declaration. + -- + -- TEST DESCRIPTION: + -- Declare an outside elevator button operation as a subunit in a + -- generic child package of the basic operation package (FA13A00.A). + -- This procedure has visibility into its parent ancestor and its + -- private sibling. + -- + -- In the main program, instantiate the child package. Check that + -- subunits perform as expected. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FA13A00.A + -- CA13A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Public generic child package of an elevator application. This package + -- provides outside elevator button operations. + + generic -- Instantiate once for each floor. + Our_Floor : in Floor; -- Reference type declared in parent. + + package FA13A00_1.CA13A02_4 is -- Outside Elevator Button Operations + + type Light is (Up, Down, Express, Off); + + type Direction is (Up, Down, Express); + + function Call_Elevator (D : Direction) return Light; + + -- other type definitions and procedure declarations in real application. + + end FA13A00_1.CA13A02_4; + + --==================================================================-- + + -- Context clauses required for visibility needed by separate subunit. + + with FA13A00_0; -- Building Manager + + with FA13A00_1.FA13A00_2; -- Floor Calculation (private) + + with FA13A00_1.FA13A00_3; -- Move Elevator + + use FA13A00_0; + + package body FA13A00_1.CA13A02_4 is + + function Call_Elevator (D : Direction) return Light is separate; + + end FA13A00_1.CA13A02_4; + + --==================================================================-- + + separate (FA13A00_1.CA13A02_4) + + -- Subunit Call_Elevator declared in Outside Elevator Button Operations. + + function Call_Elevator (D : Direction) return Light is + Elevator_Button : Light; + + begin + -- See if power is on. + + if Power = Off then -- Reference package with'ed by + Elevator_Button := Off; -- the subunit parent's body. + + else + case D is + when Express => + FA13A00_1.FA13A00_3.Move_Elevator -- Reference public sibling of + (Penthouse, Call_Waiting); -- the subunit parent's body. + + Elevator_Button := Express; + + when Up => + if Current_Floor < Our_Floor then + FA13A00_1.FA13A00_2.Up -- Reference private sibling of + (Floor'pos (Our_Floor) -- the subunit parent's body. + - Floor'pos (Current_Floor)); + else + FA13A00_1.FA13A00_2.Down -- Reference private sibling of + (Floor'pos (Current_Floor) -- the subunit parent's body. + - Floor'pos (Our_Floor)); + end if; + + -- Call elevator. + + Call + (Current_Floor, Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + Elevator_Button := Up; + + when Down => + if Current_Floor > Our_Floor then + FA13A00_1.FA13A00_2.Down -- Reference private sibling of + (Floor'pos (Current_Floor) -- the subunit parent's body. + - Floor'pos (Our_Floor)); + else + FA13A00_1.FA13A00_2.Up -- Reference private sibling of + (Floor'pos (Our_Floor) -- the subunit parent's body. + - Floor'pos (Current_Floor)); + end if; + + Elevator_Button := Down; + + -- Call elevator. + + Call + (Current_Floor, Call_Waiting); -- Reference subprogram declared + -- in the parent of the subunit + -- parent's body. + end case; + + if not Call_Waiting (Current_Floor) -- Reference private part of the + then -- parent of the subunit parent's + -- body. + TC_Operation := false; + end if; + + end if; + + return Elevator_Button; + + end Call_Elevator; + + --==================================================================-- + + with FA13A00_1.CA13A02_4; -- Outside Elevator Button Operations + -- implicitly with Basic Elevator + -- Operations + with Report; + + procedure CA13A02 is + + begin + + Report.Test ("CA13A02", "Check that subunits declared in generic child " & + "units of a public parent have the same visibility into " & + "its parent, its parent's siblings, and packages on " & + "which its parent depends"); + + -- Going from floor one to penthouse. + + Going_To_Penthouse: + declare + -- Declare instance of the child generic elevator package for penthouse. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Penthouse); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Express); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Express then + Report.Failed ("Incorrect elevator operation going to penthouse"); + end if; + + end Going_To_Penthouse; + + -- Going from penthouse to basement. + + Going_To_Basement: + declare + -- Declare instance of the child generic elevator package for basement. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Basement); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Down); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then + Report.Failed ("Incorrect elevator operation going to basement"); + end if; + + end Going_To_Basement; + + -- Going from basement to floor three. + + Going_To_Floor3: + declare + -- Declare instance of the child generic elevator package for floor + -- three. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor3); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Up); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then + Report.Failed ("Incorrect elevator operation going to floor 3"); + end if; + + end Going_To_Floor3; + + -- Going from floor three to floor two. + + Going_To_Floor2: + declare + -- Declare instance of the child generic elevator package for floor two. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor2); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + + Call_Button_Light := Call_Elevator (Up); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Up then + Report.Failed ("Incorrect elevator operation going to floor 2"); + end if; + + end Going_To_Floor2; + + -- Going to floor one. + + Going_To_Floor1: + declare + -- Declare instance of the child generic elevator package for floor one. + + package Call_Elevator_Pkg is new FA13A00_1.CA13A02_4 + (FA13A00_1.Floor1); + + use Call_Elevator_Pkg; + + Call_Button_Light : Light; + + begin + -- Calling elevator from floor one. + + FA13A00_1.Current_Floor := FA13A00_1.Floor1; + + Call_Button_Light := Call_Elevator (Down); + + if not FA13A00_1.TC_Operation or Call_Button_Light /= Down then + Report.Failed ("Incorrect elevator operation going to floor 1"); + end if; + + end Going_To_Floor1; + + Report.Result; + + end CA13A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140230.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140230.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140230.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140230.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- CA140230.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA140232.AM. + -- + -- TEST DESCRIPTION: + -- See CA140232.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> CA140230.A + -- CA140231.A + -- CA140232.AM + -- CA140233.A + -- + -- PASS/FAIL CRITERIA: + -- See CA140232.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- 13 SEP 99 RLB Changed to C-test (by AI-00077). + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + -- + --! + + package CA14023_0 is + subtype Little_float is float digits 4 range 0.0..100.0; + type Data_rec is tagged record + Data : Little_float; + end record; + end CA14023_0; + + -------------------------------------------------------- + + generic + type Data_type is digits <>; + Floor : Data_type; + function CA14023_1 (P1, P2 : Data_type) return Data_type; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140231.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140231.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140231.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140231.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- CA140231.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA140232.AM. + -- + -- TEST DESCRIPTION: + -- See CA140232.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140230.A + -- -> CA140231.A + -- CA140232.AM + -- CA140233.A + -- + -- PASS/FAIL CRITERIA: + -- See CA140232.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- 13 SEP 99 RLB Changed to C-test (by AI-00077). + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + -- + --! + + function CA14023_1 (P1, P2 : Data_type) return Data_type is + begin + if Floor > P1 and Floor > P2 then + return Floor; + elsif P2 > P1 then + return P2; + else + return P1; + end if; + end CA14023_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140232.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140232.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140232.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140232.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- CA140232.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic instantiation depends on + -- a generic function that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic function, a generic + -- instantiation of the generic function, and a main + -- procedure that withs the instantiated generic + -- function. Then, a new version of the first generic + -- function is compiled (in a separate file, simulating + -- editing and modification to the unit). The test should + -- link the correct version of the withed function and + -- report "PASSED" at execution time. + -- + -- Note that compilers are required by the standard to support + -- replacement of a generic body without recompilation of the + -- instantation. The ARG confirmed 10.1.4(10) with AI-00077. + -- + -- To build this test: + -- 1) Compile the file CA140230 (and include the results in the + -- program library). + -- 2) Compile the file CA140231 (and include the results in the + -- program library). + -- 3) Compile the file CA140232 (and include the results in the + -- program library). + -- 4) Compile the file CA140233 (and include the results in the + -- program library). + -- 5) Build and run an executable image. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140230.A + -- CA140231.A + -- -> CA140232.AM + -- CA140233.A + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008T baseline version + -- 29 JUN 95 SAIC Initial version + -- 05 MAR 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved CA14023_1 to a separate file. + -- 13 SEP 99 RLB Changed to C-test (by AI-00077). + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + -- + --! + + with CA14023_0; + use CA14023_0; + + generic + Min : Little_float := 0.0; + type Any_rec is new Data_rec with private; + function CA14023_2 (R1, R2 : Any_rec) return Little_float; + + -------------------------------------------------------- + + with CA14023_1; + + function CA14023_2 (R1, R2 : Any_rec) return Little_float is + function Max_val is new CA14023_1 (Little_float, Min); + begin + return max_val (R1.Data, R2.Data); + end CA14023_2; + + -------------------------------------------------------- + + package CA14023_0.CA14023_3 is + type New_data_rec is new Data_rec with record + Other_val : integer := 100; + end record; + end CA14023_0.CA14023_3; + + -------------------------------------------------------- + + with Report; use Report; + with CA14023_2; + with CA14023_0; + with CA14023_0.CA14023_3; + + procedure CA140232 is + + NDR1, NDR2 : CA14023_0.CA14023_3.New_data_rec; + Min_value : constant CA14023_0.Little_float := 0.0; + TC_result : CA14023_0.Little_float; + function Max_Data_Val is new CA14023_2 (Min_value, + CA14023_0.CA14023_3.New_data_rec); + begin + Test ("CA14023", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic " & + "instantiation depends on a generic " & + "function that is changed"); + + NDR1.Data := 2.0; + NDR2.Data := 5.0; + + TC_result := Max_Data_Val (NDR1, NDR2); + + if TC_result = 5.0 then + Failed ("Revised generic not used"); + elsif TC_result /= 0.0 then -- the minimum, floor + Failed ("Incorrect value returned"); -- value of 0.0 should + end if; -- be returned rather + -- than the min of the + -- two actual parameters + + Result; + end CA140232; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140233.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140233.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140233.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140233.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,68 ---- + -- CA140233.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA140232.AM. + -- + -- TEST DESCRIPTION: + -- See CA140232.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140230.A + -- CA140231.A + -- CA140232.AM + -- -> CA140233.A + -- + -- PASS/FAIL CRITERIA: + -- See CA140232.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008T baseline version + -- 29 JUN 95 SAIC Initial version + -- 05 MAR 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- 13 SEP 99 RLB Changed to C-test (by AI-00077). + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + --! + + -- here is the replacement body, correcting "errors" in + -- the original + + function CA14023_1 (P1, P2 : Data_type) return Data_type is + begin + -- return min rather than max + if Floor < P1 and Floor < P2 then + return Floor; + elsif P2 < P1 then + return P2; + else + return P1; + end if; + end CA14023_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140280.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140280.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140280.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140280.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CA140280.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- See CA140283.AM. + -- + -- TEST DESCRIPTION + -- See CA140283.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> CA140280.A + -- CA140281.A + -- CA140282.A + -- CA140283.AM + -- + -- CHANGE HISTORY: + -- JBG 05/28/85 CREATED ORGINAL TEST. + -- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE + -- NOT THE SAME. + -- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + + GENERIC + C : INTEGER; + PROCEDURE GENPROC_CA14028 (X : OUT INTEGER); + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE GENPROC_CA14028 (X : OUT INTEGER) IS + BEGIN + X := IDENT_INT(C); + END GENPROC_CA14028; + + GENERIC + FUNCTION GENFUNC_CA14028 RETURN INTEGER; + + FUNCTION GENFUNC_CA14028 RETURN INTEGER IS + BEGIN + RETURN 2; + END GENFUNC_CA14028; + + WITH GENPROC_CA14028; + PRAGMA ELABORATE (GENPROC_CA14028); + PROCEDURE CA14028_PROC1 IS NEW GENPROC_CA14028(1); + + WITH GENFUNC_CA14028; + PRAGMA ELABORATE (GENFUNC_CA14028); + FUNCTION CA14028_FUNC2 IS NEW GENFUNC_CA14028; + + WITH GENPROC_CA14028; + PRAGMA ELABORATE (GENPROC_CA14028); + PROCEDURE CA14028_PROC3 IS NEW GENPROC_CA14028(3); + + WITH GENFUNC_CA14028; + PRAGMA ELABORATE (GENFUNC_CA14028); + FUNCTION CA14028_FUNC3 IS NEW GENFUNC_CA14028; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140281.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140281.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140281.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140281.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- CA140281.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- See CA140283.AM. + -- + -- TEST DESCRIPTION + -- See CA140283.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140280.A + -- -> CA140281.A + -- CA140282.A + -- CA140283.AM + -- + -- CHANGE HISTORY: + -- JBG 05/28/85 CREATED ORGINAL TEST. + -- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE + -- NOT THE SAME. + -- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + + PROCEDURE CA14028_PROC1 (X : OUT INTEGER) IS + BEGIN + X := 3; + END CA14028_PROC1; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION CA14028_FUNC2 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(4); + END CA14028_FUNC2; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CA14028_PROC3 (X : OUT BOOLEAN; Y : OUT INTEGER) IS + BEGIN + X := FALSE; + Y := IDENT_INT(6); + END CA14028_PROC3; + + FUNCTION CA14028_FUNC3 RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END CA14028_FUNC3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140282.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140282.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140282.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140282.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- CA140282.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- See CA140283.AM. + -- + -- TEST DESCRIPTION + -- See CA140283.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140280.A + -- CA140281.A + -- -> CA140282.A + -- CA140283.AM + -- + -- CHANGE HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE + -- NOT THE SAME. + -- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + + WITH GENPROC_CA14028; + PRAGMA ELABORATE (GENPROC_CA14028); + PROCEDURE CA14028_PROC5 IS NEW GENPROC_CA14028 (5); + + WITH GENFUNC_CA14028; + PRAGMA ELABORATE (GENFUNC_CA14028); + FUNCTION CA14028_FUNC22 IS NEW GENFUNC_CA14028; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CA14028_PROC3 (X : OUT INTEGER) IS + BEGIN + X := IDENT_INT(4); + END CA14028_PROC3; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + FUNCTION CA14028_FUNC3 RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(7); + END CA14028_FUNC3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140283.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140283.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca140283.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca140283.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CA140283.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- Check that when a subprogram body is compiled as a library unit + -- it is not interpreted as a completion for any previous library + -- subprogram created by generic instantiation, and it therefore + -- declares a new library subprogram. + -- + -- TEST DESCRIPTION + -- A generic function and procedure plus their instantiations are + -- created. Then, subprogram bodies which ought to replace the + -- instantiations are compiled. Following that, additional instantiations + -- are compiled. Finally the main subprogram is compiled. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA140280.A + -- CA140281.A + -- CA140282.A + -- -> CA140283.AM + -- + -- CHANGE HISTORY: + -- JBG 05/28/85 CREATED ORIGINAL TEST. + -- RDH 04/18/90 ADDED CASES WHERE SUBPROGRAM PARAMETER TYPES ARE + -- NOT THE SAME. + -- THS 09/24/90 REWORDED HEADER COMMENTS, ERROR MESSAGES, AND + -- CALL TO TEST. CALLED IDENT_INT CONSISTENTLY. + -- RLB 07/08/99 Reinstated withdrawn test; revised to Ada 95 format. + + WITH REPORT; USE REPORT; + WITH CA14028_PROC1, CA14028_FUNC2, CA14028_PROC5, CA14028_FUNC22, + CA14028_PROC3, CA14028_FUNC3; + PROCEDURE CA140283 IS + TEMP : INTEGER := 0; + BEGIN + TEST ("CA14028", "Check that library subprograms created by " & + "generic instantiation are replaced " & + "when new non-generic subprogram bodies are " & + "compiled"); + + CA14028_PROC1(TEMP); + IF TEMP /= IDENT_INT(3) THEN + FAILED ("CA14028_Proc1 instantiation not replaced"); + END IF; + + IF CA14028_FUNC2 /= IDENT_INT(4) THEN + FAILED ("CA14028_Func2 instantiation not replaced"); + END IF; + + CA14028_PROC5(TEMP); + IF TEMP /= IDENT_INT(5) THEN + FAILED ("New CA14028_Proc5 instantiation not correct"); + END IF; + + IF CA14028_FUNC22 /= IDENT_INT(2) THEN + FAILED ("New CA14028_Func22 instantiation not correct"); + END IF; + + CA14028_PROC3(TEMP); + IF TEMP /= IDENT_INT(4) THEN + FAILED ("CA14028_Proc3 not replaced by correct version"); + END IF; + + IF CA14028_FUNC3 /= IDENT_INT(7) THEN + FAILED ("CA14028_Func3 not replaced by correct version"); + END IF; + + RESULT; + END CA140283; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca15003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca15003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca15003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca15003.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- CA15003.A + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check the requirements of 10.1.5(4) and the modified 10.1.5(5) + -- from Technical Corrigendum 1. (Originally discussed as AI95-00136.) + -- Specifically: + -- Check that program unit pragma for a generic package are accepted + -- when given at the beginning of the package specification. + -- Check that a program unit pragma can be given for a generic + -- instantiation by placing the pragma immediately after the instantation. + -- + -- TEST DESCRIPTION + -- This test checks the cases that are *not* forbidden by the RM, + -- and makes sure such legal cases actually work. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 08 JUL 1999 RLB Cleaned up and added to test suite. + -- 27 AUG 1999 RLB Repaired errors introduced by me. + -- + --! + + with System; + package CA15003A is + pragma Pure; + + type Big_Int is range -System.Max_Int .. System.Max_Int; + type Big_Positive is new Big_Int range 1..Big_Int'Last; + end CA15003A; + + generic + type Int is new Big_Int; + package CA15003A.Pure is + pragma Pure; + function F(X: access Int) return Int; + end CA15003A.Pure; + + with CA15003A.Pure; + package CA15003A.Pure_Instance is new CA15003A.Pure(Int => Big_Positive); + pragma Pure(CA15003A.Pure_Instance); + + package body CA15003A.Pure is + function F(X: access Int) return Int is + begin + X.all := X.all + 1; + return X.all; + end F; + end CA15003A.Pure; + + generic + package CA15003A.Pure.Preelaborate is + pragma Preelaborate; + One: Int := 1; + function F(X: access Int) return Int; + end CA15003A.Pure.Preelaborate; + + package body CA15003A.Pure.Preelaborate is + function F(X: access Int) return Int is + begin + X.all := X.all + One; + return X.all; + end F; + end CA15003A.Pure.Preelaborate; + + with CA15003A.Pure_Instance; + with CA15003A.Pure.Preelaborate; + package CA15003A.Pure_Preelaborate_Instance is + new CA15003A.Pure_Instance.Preelaborate; + pragma Preelaborate(CA15003A.Pure_Preelaborate_Instance); + + package CA15003A.Empty_Pure is + pragma Pure; + pragma Elaborate_Body; + end CA15003A.Empty_Pure; + + package body CA15003A.Empty_Pure is + end CA15003A.Empty_Pure; + + package CA15003A.Empty_Preelaborate is + pragma Preelaborate; + pragma Elaborate_Body; + One: Big_Int := 1; + end CA15003A.Empty_Preelaborate; + + package body CA15003A.Empty_Preelaborate is + function F(X: access Big_Int) return Big_Int is + begin + X.all := X.all + One; + return X.all; + end F; + end CA15003A.Empty_Preelaborate; + + package CA15003A.Empty_Elaborate_Body is + pragma Elaborate_Body; + Three: aliased Big_Positive := 1; + Two, Tres: Big_Positive'Base := 0; + end CA15003A.Empty_Elaborate_Body; + + with Report; use Report; pragma Elaborate_All(Report); + with CA15003A.Pure_Instance; + with CA15003A.Pure_Preelaborate_Instance; + use CA15003A; + package body CA15003A.Empty_Elaborate_Body is + begin + if Two /= Big_Positive'Base(Ident_Int(0)) then + Failed ("Two should be zero now"); + end if; + if Tres /= Big_Positive'Base(Ident_Int(0)) then + Failed ("Tres should be zero now"); + end if; + if Two /= Tres then + Failed ("Tres should be zero now"); + end if; + Two := Pure_Instance.F(Three'Access); + Tres := Pure_Preelaborate_Instance.F(Three'Access); + if Two /= Big_Positive(Ident_Int(2)) then + Failed ("Two should be 2 now"); + end if; + if Tres /= Big_Positive(Ident_Int(3)) then + Failed ("Tres should be 3 now"); + end if; + end CA15003A.Empty_Elaborate_Body; + + with Report; use Report; + with CA15003A.Empty_Pure; + with CA15003A.Empty_Preelaborate; + with CA15003A.Empty_Elaborate_Body; use CA15003A.Empty_Elaborate_Body; + use type CA15003A.Big_Positive'Base; + procedure CA15003 is + begin + Test("CA15003", "Placement of Program Unit Pragmas in Generic Packages"); + if Two /= 2 then + Failed ("Two should be 2 now"); + end if; + if Tres /= 3 then + Failed ("Tres should be 3 now"); + end if; + Result; + end CA15003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200020.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CA200020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a partition can be created even if the environment contains + -- two units with the same name. (This is rule 10.2(19)). + -- + -- TEST DESCRIPTION: + -- Declare the a parent package (CA20002_0). Declare a child package + -- (CA20002_0.CA20002_1). Declare a subunit in the parent package body + -- (CA20002_1). Declare a main subprogram that does NOT include the + -- child package. Insure that this partition can be created. + -- + -- This test is intended to test the effects of program maintenance. + -- After the programmer receives an error from creating a partition + -- like that tested in test LA20001, the programmer may then repair + -- the partition by eliminating the reference of the child unit. The + -- partition should be able to be created. + -- + -- To build this test: + -- 1) Compile the file CA200020 (and include the results in the + -- program library). + -- 2) Compile the file CA200021 (and include the results in the + -- program library). + -- 3) Compile the file CA200022 (and include the results in the + -- program library). + -- 4) Build an executable image, and run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> CA200020.A + -- CA200021.A + -- CA200022.AM + -- + -- CHANGE HISTORY: + -- 27 Jan 99 RLB Initial test. + -- 20 Mar 00 RLB Removed special requirements, because there + -- aren't any. + --! + + package CA20002_0 is + procedure Do_a_Little (A : out Integer); + + end CA20002_0; + + package CA20002_0.CA20002_1 is + My_Global : Integer; + end CA20002_0.CA20002_1; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200021.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CA200021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA200020.A. + -- + -- TEST DESCRIPTION: + -- See CA200020.A. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA200020.A + -- -> CA200021.A + -- CA200022.AM + -- + -- PASS/FAIL CRITERIA: + -- See CA200020.A. + -- + -- CHANGE HISTORY: + -- 27 JAN 99 RLB Initial version. + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + -- + --! + + package body CA20002_0 is + + function CA20002_1 return Integer is separate; -- Has the same expanded name + -- as the child. + -- Note: An implementation may produce a warning about the child + -- unit at this point, but it must accept the subunit declaration. + + procedure Do_a_Little (A : out Integer) is + begin + A := CA20002_1; + end Do_a_Little; + + end CA20002_0; + + with Report; + separate (CA20002_0) + function CA20002_1 return Integer is + begin + return Report.Ident_Int(5); + end CA20002_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200022.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200022.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca200022.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca200022.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- CA200022.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CA200020.A. + -- + -- TEST DESCRIPTION: + -- See CA200020.A. + -- + -- TEST FILES: + -- This test consists of the following files: + -- CA200020.A + -- CA200021.A + -- -> CA200022.AM + -- + -- PASS/FAIL CRITERIA: + -- See CA200020.A. + -- + -- CHANGE HISTORY: + -- 25 JAN 99 RLB Initial version. + -- 08 JUL 99 RLB Repaired comments. + -- 20 MAR 00 RLB Removed special requirements, because there + -- aren't any. + --! + + with Report; + use Report; + with CA20002_0; -- Child unit not included in the partition. + procedure CA200022 is + Value : Integer := 0; + begin + Test ("CA20002","Check that compiling multiple units with the same " & + "name does not prevent the creation of a partition " & + "using only one of the units."); + CA20002_0.Do_a_Little (Value); + if Report.Equal (Value, 5) then + null; -- OK. + else + Failed ("Wrong result from subunit"); + end if; + + Result; + end CA200022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,40 ---- + -- CA2001H0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/25/81 + -- JBG 8/25/83 + + FUNCTION CA2001H0 RETURN INTEGER IS + + PACKAGE CA2001H1 IS + I : INTEGER := 0; + END CA2001H1; + + PACKAGE BODY CA2001H1 IS SEPARATE; + + BEGIN + + RETURN CA2001H1.I; + + END CA2001H0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + -- CA2001H1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/25/81 + -- JBG 8/25/83 + -- BHS 7/31/84 + + SEPARATE (CA2001H0) + + PACKAGE BODY CA2001H1 IS + PROCEDURE NOT_USED IS SEPARATE; + + BEGIN + + I := 1; + NOT_USED; + + END CA2001H1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + -- CA2001H2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/25/81 + -- JBG 8/25/83 + + FUNCTION CA2001H0 RETURN INTEGER IS + + PACKAGE CA2001H1 IS + I : INTEGER := 2; + END CA2001H1; + + BEGIN + + RETURN CA2001H1.I; + + END CA2001H0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2001h3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CA2001H3M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF A BODY_STUB IS DELETED FROM A COMPILATION UNIT, + -- THE PREVIOUSLY EXISTING SUBUNIT CAN NO LONGER BE ACCESSED. + + -- SEPARATE FILES ARE; + -- CA2001H0 A LIBRARY FUNCTION (CA2001H0). + -- CA2001H1 A SUBUNIT PACKAGE BODY. + -- CA2001H2 A LIBRARY FUNCTION (CA2001H0). + -- CA2001H3M THE MAIN PROCEDURE. + + -- WKB 6/25/81 + -- JRK 6/26/81 + -- SPS 11/2/82 + -- JBG 8/25/83 + + + WITH REPORT, CA2001H0; + USE REPORT; + PROCEDURE CA2001H3M IS + + I : INTEGER := -1; + + BEGIN + TEST ("CA2001H", "IF A BODY_STUB IS DELETED FROM A COMPILATION " & + "UNIT, THE PREVIOUSLY EXISTING SUBUNIT CAN NO " & + "LONGER BE ACCESSED"); + + I := CA2001H0; + + IF I = 1 THEN + FAILED ("SUBUNIT ACCESSED"); + END IF; + + IF I = 0 THEN + FAILED ("OLD LIBRARY UNIT ACCESSED"); + END IF; + + IF I /= 2 THEN + FAILED ("NEW LIBRARY UNIT NOT ACCESSED"); + END IF; + + RESULT; + END CA2001H3M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- CA2002A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SUBUNITS HAVING DIFFERENT ANCESTOR LIBRARY UNITS CAN HAVE + -- THE SAME NAME. + + -- SEPARATE FILES ARE: + -- CA2002A0M THE MAIN PROCEDURE, WITH SEPARATE LIBRARY + -- PACKAGES (CA2002A1) AND (CA2002A2). + -- CA2002A1 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A1. + -- CA2002A2 SUBUNIT BODIES FOR STUBS IN PACKAGE CA2002A2. + + -- BHS 8/02/84 + + PACKAGE CA2002A1 IS + + PROCEDURE PROC (X : OUT INTEGER); + FUNCTION FUN RETURN BOOLEAN; + + PACKAGE PKG IS + I : INTEGER; + PROCEDURE PKG_PROC (XX : IN OUT INTEGER); + END PKG; + + END CA2002A1; + + PACKAGE BODY CA2002A1 IS + + PROCEDURE PROC (X : OUT INTEGER) IS SEPARATE; + FUNCTION FUN RETURN BOOLEAN IS SEPARATE; + PACKAGE BODY PKG IS SEPARATE; + + END CA2002A1; + + + PACKAGE CA2002A2 IS + + PROCEDURE PROC (Y : OUT INTEGER); + FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN; + + PACKAGE PKG IS + I : INTEGER; + PROCEDURE PKG_PROC (YY : IN OUT INTEGER); + END PKG; + + END CA2002A2; + + PACKAGE BODY CA2002A2 IS + + PROCEDURE PROC (Y : OUT INTEGER) IS SEPARATE; + FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS SEPARATE; + PACKAGE BODY PKG IS SEPARATE; + + END CA2002A2; + + WITH CA2002A1, CA2002A2; + WITH REPORT; USE REPORT; + PROCEDURE CA2002A0M IS + BEGIN + + TEST ("CA2002A", "SUBUNITS WITH DIFFERENT ANCESTORS " & + "CAN HAVE THE SAME NAME"); + + DECLARE + VAR1 : INTEGER; + USE CA2002A1; + BEGIN + + PROC (VAR1); + IF VAR1 /= 1 THEN + FAILED ("CA2002A1 PROCEDURE NOT INVOKED CORRECTLY"); + END IF; + + IF NOT FUN THEN + FAILED ("CA2002A1 FUNCTION NOT INVOKED CORRECTLY"); + END IF; + + IF PKG.I /= 1 THEN + FAILED ("CA2202A1 PKG VARIABLE NOT ACCESSED CORRECTLY"); + END IF; + + VAR1 := 5; + PKG.PKG_PROC (VAR1); + IF VAR1 /= 4 THEN + FAILED ("CA2002A1 PKG SUBUNIT NOT INVOKED CORRECTLY"); + END IF; + + END; + + DECLARE + VAR2 : INTEGER; + USE CA2002A2; + BEGIN + + PROC (VAR2); + IF VAR2 /= 2 THEN + FAILED ("CA2002A2 PROCEDURE NOT INVOKED CORRECTLY"); + END IF; + + IF FUN THEN + FAILED ("CA2002A2 FUNCTION NOT INVOKED CORRECTLY"); + END IF; + + IF PKG.I /= 2 THEN + FAILED ("CA2002A2 PKG VARIABLE NOT ACCESSED CORRECTLY"); + END IF; + + VAR2 := 3; + PKG.PKG_PROC (VAR2); + IF VAR2 /= 4 THEN + FAILED ("CA2002A2 PKG SUBUNIT NOT INVOKED CORRECTLY"); + END IF; + + END; + + RESULT; + + END CA2002A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- CA2002A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A1 IN FILE + -- CA2002A0M. + + -- BHS 8/02/84 + + SEPARATE (CA2002A1) + PROCEDURE PROC (X : OUT INTEGER) IS + BEGIN + X := 1; + END PROC; + + SEPARATE (CA2002A1) + FUNCTION FUN RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END FUN; + + SEPARATE (CA2002A1) + PACKAGE BODY PKG IS + PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS SEPARATE; + BEGIN + I := 1; + END PKG; + + SEPARATE (CA2002A1.PKG) + PROCEDURE PKG_PROC (XX : IN OUT INTEGER) IS + BEGIN + XX := XX - 1; + END PKG_PROC; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2002a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- CA2002A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SUBUNIT BODIES FOR STUBS GIVEN IN PACKAGE CA2002A2 IN FILE + -- CA2002A0M. + + -- BHS 8/02/84 + + SEPARATE (CA2002A2) + PROCEDURE PROC (Y : OUT INTEGER) IS + BEGIN + Y := 2; + END PROC; + + SEPARATE (CA2002A2) + FUNCTION FUN (Z : INTEGER := 3) RETURN BOOLEAN IS + BEGIN + RETURN Z /= 3; + END FUN; + + SEPARATE (CA2002A2) + PACKAGE BODY PKG IS + PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS SEPARATE; + BEGIN + I := 2; + END PKG; + + SEPARATE (CA2002A2.PKG) + PROCEDURE PKG_PROC (YY : IN OUT INTEGER) IS + BEGIN + YY := YY + 1; + END PKG_PROC; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2003a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- CA2003A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED + -- PRIOR TO ITS BODY_STUB. + + -- SEPARATE FILES ARE: + -- CA2003A0M THE MAIN PROCEDURE. + -- CA2003A1 A SUBUNIT PROCEDURE BODY. + + -- WKB 6/26/81 + -- JRK 6/26/81 + + WITH REPORT; + USE REPORT; + PROCEDURE CA2003A0M IS + + I : INTEGER := 1; + + PROCEDURE CA2003A1 IS SEPARATE; + + PACKAGE P IS + I : INTEGER := 2; + END P; + + BEGIN + TEST ("CA2003A", "A SUBUNIT HAS VISIBILITY OF IDENTIFIERS " & + "DECLARED BEFORE ITS BODY_STUB"); + + + CA2003A1; + + RESULT; + END CA2003A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2003a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA2003A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/26/81 + + SEPARATE (CA2003A0M) + PROCEDURE CA2003A1 IS + BEGIN + + IF I /= 1 THEN + FAILED ("IDENTIFIER IN PARENT NOT VISIBLE"); + END IF; + + END CA2003A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- CA2004A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A SUBUNIT HAS VISIBILITY OF IDENTIFIERS DECLARED + -- IN ANCESTORS OTHER THAN THE PARENT. + + -- SEPARATE FILES ARE: + -- CA2004A0M THE MAIN PROCEDURE. + -- CA2004A1 A SUBUNIT PACKAGE BODY. + -- CA2004A2 A SUBUNIT PROCEDURE BODY. + -- CA2004A3 A SUBUNIT PROCEDURE BODY. + -- CA2004A4 A SUBUNIT PROCEDURE BODY. + + -- WKB 6/26/81 + -- JRK 6/26/81 + -- BHS 7/31/84 + + WITH REPORT; + USE REPORT; + PROCEDURE CA2004A0M IS + + I : INTEGER := 1; + + PACKAGE CA2004A1 IS + J : INTEGER := 2; + PROCEDURE CA2004A2; + END CA2004A1; + + USE CA2004A1; + PACKAGE BODY CA2004A1 IS SEPARATE; + PROCEDURE CA2004A3 IS SEPARATE; + + BEGIN + TEST ("CA2004A", "CHECK THAT A SUBUNIT HAS VISIBILITY OF " & + "IDENTIFIERS DECLARED IN ANCESTORS"); + + + CA2004A1. + CA2004A2; + + CA2004A3; + + RESULT; + END CA2004A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA2004A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/26/81 + + SEPARATE (CA2004A0M) + PACKAGE BODY CA2004A1 IS + + K : INTEGER := 3; + + PROCEDURE CA2004A2 IS SEPARATE; + + END CA2004A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + -- CA2004A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/26/81 + + SEPARATE (CA2004A0M.CA2004A1) + PROCEDURE CA2004A2 IS + BEGIN + + IF I /= 1 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 1"); + END IF; + + IF J /= 2 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 2"); + END IF; + + IF K /= 3 THEN + FAILED ("IDENTIFIER NOT VISIBLE - 3"); + END IF; + + END CA2004A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + -- CA2004A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/31/84 + + SEPARATE (CA2004A0M) + PROCEDURE CA2004A3 IS + + PROCEDURE CA2004A4 IS SEPARATE; + + BEGIN + + IF I /= IDENT_INT(1) OR + J /= IDENT_INT(2) THEN + FAILED ("IDENTIFIER NOT VISIBLE - 4"); + END IF; + + END CA2004A3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2004a4.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA2004A4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 7/31/84 + + SEPARATE (CA2004A0M.CA2004A3) + PROCEDURE CA2004A4 IS + BEGIN + + IF I /= IDENT_INT(1) OR + J /= IDENT_INT(2) THEN + FAILED ("IDENTIFIER NOT VISIBLE - 5"); + END IF; + + END CA2004A4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CA2007A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SUBUNIT PACKAGES ARE ELABORATED IN THE ORDER IN + -- WHICH THEIR BODY STUBS APPEAR, NOT (NECESSARILY) IN THE + -- ORDER IN WHICH THEY ARE COMPILED. + + -- SEPARATE FILES ARE: + -- CA2007A0M THE MAIN PROCEDURE. + -- CA2007A1 A SUBUNIT PACKAGE BODY. + -- CA2007A2 A SUBUNIT PACKAGE BODY. + -- CA2007A3 A SUBUNIT PACKAGE BODY. + + -- WKB 7/1/81 + -- JRK 7/1/81 + + WITH REPORT; + USE REPORT; + PROCEDURE CA2007A0M IS + + ELAB_ORDER : STRING (1..3) := " "; + NEXT : NATURAL := 1; + + PACKAGE CALL_TEST IS + END CALL_TEST; + + PACKAGE BODY CALL_TEST IS + BEGIN + TEST ("CA2007A", "CHECK THAT SUBUNIT PACKAGES ARE " & + "ELABORATED IN THE ORDER IN WHICH THEIR " & + "BODY STUBS APPEAR"); + END CALL_TEST; + + PACKAGE CA2007A3 IS + END CA2007A3; + + PACKAGE BODY CA2007A3 IS SEPARATE; + + PACKAGE CA2007A2 IS + END CA2007A2; + + PACKAGE BODY CA2007A2 IS SEPARATE; + + PACKAGE CA2007A1 IS + END CA2007A1; + + PACKAGE BODY CA2007A1 IS SEPARATE; + + BEGIN + + IF ELAB_ORDER /= "321" THEN + FAILED ("INCORRECT ELABORATION ORDER"); + END IF; + + RESULT; + END CA2007A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA2007A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/1/81 + + SEPARATE (CA2007A0M) + + PACKAGE BODY CA2007A1 IS + + BEGIN + + ELAB_ORDER (NEXT) := '1'; + NEXT := NEXT + 1; + + END CA2007A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA2007A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/1/81 + + SEPARATE (CA2007A0M) + + PACKAGE BODY CA2007A2 IS + + BEGIN + + ELAB_ORDER (NEXT) := '2'; + NEXT := NEXT + 1; + + END CA2007A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2007a3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + -- CA2007A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/1/81 + + SEPARATE (CA2007A0M) + + PACKAGE BODY CA2007A3 IS + + BEGIN + + ELAB_ORDER (NEXT) := '3'; + NEXT := NEXT + 1; + + END CA2007A3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- CA2008A0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT FOR AN OVERLOADED SUBPROGRAM, ONE OF THE + -- SUBPROGRAM BODIES CAN BE SPECIFIED WITH A BODY_STUB AND + -- COMPILED SEPARATELY. + + -- SEPARATE FILES ARE: + -- CA2008A0M THE MAIN PROCEDURE. + -- CA2008A1 A SUBUNIT PROCEDURE BODY. + -- CA2008A2 A SUBUNIT FUNCTION BODY. + + -- WKB 6/26/81 + -- SPS 11/2/82 + + WITH REPORT; + USE REPORT; + PROCEDURE CA2008A0M IS + + I : INTEGER := 0; + B : BOOLEAN := TRUE; + + PROCEDURE CA2008A1 (I : IN OUT INTEGER) IS + BEGIN + I := IDENT_INT (1); + END CA2008A1; + + PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS SEPARATE; + + FUNCTION CA2008A2 RETURN INTEGER IS SEPARATE; + + FUNCTION CA2008A2 RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END CA2008A2; + + BEGIN + TEST ("CA2008A", "CHECK THAT AN OVERLOADED SUBPROGRAM " & + "CAN HAVE ONE OF ITS BODIES COMPILED SEPARATELY"); + + CA2008A1 (I); + IF I /= 1 THEN + FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 1"); + END IF; + + CA2008A1 (B); + IF B THEN + FAILED ("OVERLOADED PROCEDURE NOT INVOKED - 2"); + END IF; + + IF CA2008A2 /= 2 THEN + FAILED ("OVERLOADED FUNCTION NOT INVOKED - 1"); + END IF; + + IF CA2008A2 THEN + FAILED ("OVERLOADED FUNCTION NOT INVOKED - 2"); + END IF; + + RESULT; + END CA2008A0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA2008A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/26/81 + + SEPARATE (CA2008A0M) + + PROCEDURE CA2008A1 (B : IN OUT BOOLEAN) IS + + BEGIN + + B := FALSE; + + END CA2008A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2008a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA2008A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 6/26/81 + + SEPARATE (CA2008A0M) + + FUNCTION CA2008A2 RETURN INTEGER IS + + BEGIN + + RETURN 2; + + END CA2008A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CA2009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND + -- INSTANTIATED. + + -- BHS 8/01/84 + -- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323. + + + WITH REPORT; + USE REPORT; + PROCEDURE CA2009A IS + + INT1 : INTEGER := 1; + + SUBTYPE STR15 IS STRING (1..15); + SVAR : STR15 := "ABCDEFGHIJKLMNO"; + + GENERIC + TYPE ITEM IS PRIVATE; + CON1 : IN ITEM; + VAR1 : IN OUT ITEM; + PACKAGE PKG1 IS + END PKG1; + + PACKAGE BODY PKG1 IS SEPARATE; + + PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1); + PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"), + SVAR); + + BEGIN + + TEST ("CA2009A", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC PACKAGE SUBUNITS"); + + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - INTEGER"); + END IF; + + IF SVAR /= "REINSTANTIATION" THEN + FAILED ("INCORRECT INSTANTIATION - STRING"); + END IF; + + + RESULT; + + END CA2009A; + + + SEPARATE (CA2009A) + PACKAGE BODY PKG1 IS + BEGIN + VAR1 := CON1; + END PKG1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009c0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CA2009C0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A GENERIC PACKAGE SUBUNIT CAN BE SPECIFIED AND + -- INSTANTIATED. IN THIS TEST, THE SUBUNIT BODY IS IN A + -- SEPARATE FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + + -- SEPARATE FILES ARE: + -- CA2009C0M THE MAIN PROCEDURE. + -- CA2009C1 A SUBUNIT PACKAGE BODY (PKG1). + + -- HISTORY: + -- BHS 08/01/84 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + -- RLB 09/15/99 REMOVED JUNK COMMENT. + + WITH REPORT; + USE REPORT; + PROCEDURE CA2009C0M IS + + INT1 : INTEGER := 1; + + SUBTYPE STR15 IS STRING (1..15); + SVAR : STR15 := "ABCDEFGHIJKLMNO"; + + GENERIC + TYPE ITEM IS PRIVATE; + CON1 : IN ITEM; + VAR1 : IN OUT ITEM; + PACKAGE PKG1 IS + END PKG1; + + PACKAGE BODY PKG1 IS SEPARATE; + + PACKAGE NI_PKG1 IS NEW PKG1 (INTEGER, IDENT_INT(2), INT1); + PACKAGE NS_PKG1 IS NEW PKG1 (STR15, IDENT_STR("REINSTANTIATION"), + SVAR); + + BEGIN + + TEST ("CA2009C", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC PACKAGE SUBUNITS " & + " - SEPARATE FILES USED"); + + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - INTEGER"); + END IF; + + IF SVAR /= "REINSTANTIATION" THEN + FAILED ("INCORRECT INSTANTIATION - STRING"); + END IF; + + + RESULT; + + END CA2009C0M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009c1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + -- CA2009C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- A GENERIC PACKAGE BODY. + -- THE DECLARATION AND AN INSTANTIATION ARE IN CA2009C0M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- BHS 08/09/84 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED COMMENTS TO RELATE TO OTHER TEST FILES + -- AND TO DESCRIBE EXPECTED COMPILER ACTION. + -- BCB 01/05/88 MODIFIED HEADER. + -- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA2009C0M) + PACKAGE BODY PKG1 IS + BEGIN + VAR1 := CON1; + END PKG1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009d.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- CA2009D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND + -- INSTANTIATED. + + -- BHS 8/01/84 + -- JRK 5/24/85 CHANGED TO .ADA, SEE AI-00323. + + + WITH REPORT; + USE REPORT; + PROCEDURE CA2009D IS + + INT1 : INTEGER := 1; + INT2 : INTEGER := 2; + + + GENERIC + TYPE ELEM IS PRIVATE; + PCON1 : IN ELEM; + PVAR1 : IN OUT ELEM; + PROCEDURE PROC1; + + + GENERIC + TYPE OBJ IS PRIVATE; + FCON1 : IN OBJ; + FVAR1 : IN OUT OBJ; + FUNCTION FUNC1 RETURN OBJ; + + + PROCEDURE PROC1 IS SEPARATE; + FUNCTION FUNC1 RETURN OBJ IS SEPARATE; + + + PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1); + FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 3, INT2); + + + BEGIN + + TEST ("CA2009D", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC SUBPROGRAM SUBUNITS"); + + NI_PROC1; + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC1"); + END IF; + + + IF NI_FUNC1 /= 3 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC1"); + END IF; + + + RESULT; + + END CA2009D; + + + SEPARATE (CA2009D) + PROCEDURE PROC1 IS + BEGIN + PVAR1 := PCON1; + END PROC1; + + + SEPARATE (CA2009D) + FUNCTION FUNC1 RETURN OBJ IS + BEGIN + FVAR1 := FCON1; + RETURN FVAR1; + END FUNC1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CA2009F0M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A GENERIC SUBPROGRAM SUBUNIT CAN BE SPECIFIED AND + -- INSTANTIATED. IN THIS TEST, SOME SUBUNIT BODIES ARE + -- IN SEPARATE FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + + -- SEPARATE FILES ARE: + -- CA2009F0M THE MAIN PROCEDURE, WITH SUBUNIT BODIES FOR + -- PROC2 AND FUNC2. + -- CA2009F1 A SUBUNIT PROCEDURE BODY (PROC1). + -- CA2009F2 A SUBUNIT FUNCTION BODY (FUNC1). + + -- HISTORY: + -- BHS 08/01/84 CREATED ORIGINAL TEST. + -- PWB 02/19/86 ADDED "SOME" TO FIRST COMMENT. + -- BCB 01/05/88 MODIFIED HEADER. + -- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + -- RLB 09/15/99 REMOVED JUNK COMMENT. + + WITH REPORT; + USE REPORT; + PROCEDURE CA2009F0M IS + + INT1 : INTEGER := 1; + INT2 : INTEGER := 2; + INT3 : INTEGER := 3; + INT4 : INTEGER := 4; + + + GENERIC + TYPE ELEM IS PRIVATE; + PCON1 : IN ELEM; + PVAR1 : IN OUT ELEM; + PROCEDURE PROC1; + + GENERIC + TYPE ELEM IS PRIVATE; + PCON2 : IN ELEM; + PVAR2 : IN OUT ELEM; + PROCEDURE PROC2; + + GENERIC + TYPE OBJ IS PRIVATE; + FCON1 : IN OBJ; + FVAR1 : IN OUT OBJ; + FUNCTION FUNC1 RETURN OBJ; + + GENERIC + TYPE OBJ IS PRIVATE; + FCON2 : IN OBJ; + FVAR2 : IN OUT OBJ; + FUNCTION FUNC2 RETURN OBJ; + + + PROCEDURE PROC1 IS SEPARATE; + PROCEDURE PROC2 IS SEPARATE; + FUNCTION FUNC1 RETURN OBJ IS SEPARATE; + FUNCTION FUNC2 RETURN OBJ IS SEPARATE; + + + PROCEDURE NI_PROC1 IS NEW PROC1 (INTEGER, 2, INT1); + PROCEDURE NI_PROC2 IS NEW PROC2 (INTEGER, 3, INT2); + FUNCTION NI_FUNC1 IS NEW FUNC1 (INTEGER, 4, INT3); + FUNCTION NI_FUNC2 IS NEW FUNC2 (INTEGER, 5, INT4); + + + BEGIN + + TEST ("CA2009F", "SPECIFICATION AND INSTANTIATION " & + "OF GENERIC SUBPROGRAM SUBUNITS"); + + NI_PROC1; + IF INT1 /= 2 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC1"); + END IF; + + NI_PROC2; + IF INT2 /= 3 THEN + FAILED ("INCORRECT INSTANTIATION - NI_PROC2"); + END IF; + + IF NI_FUNC1 /= 4 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC1"); + END IF; + + IF NI_FUNC2 /= 5 THEN + FAILED ("INCORRECT INSTANTIATION - NI_FUNC2"); + END IF; + + + RESULT; + + END CA2009F0M; + + + SEPARATE (CA2009F0M) + PROCEDURE PROC2 IS + BEGIN + PVAR2 := PCON2; + END PROC2; + + SEPARATE (CA2009F0M) + FUNCTION FUNC2 RETURN OBJ IS + BEGIN + FVAR2 := FCON2; + RETURN FVAR2; + END FUNC2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + -- CA2009F1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATE GENERIC PROCEDURE BODY. + -- SPECIFICATION, BODY STUB, AND INSTANTIATION ARE IN A2009F0M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- BHS 08/01/84 CREATED ORIGINAL TEST. + -- PWB 02/19/86 MODIFIED COMMENTS TO SHOW RELATION TO OTHER FILES + -- AND TO CLARIFY NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA2009F0M) + PROCEDURE PROC1 IS + BEGIN + PVAR1 := PCON1; + END PROC1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2009f2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + -- CA2009F2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- SEPARATE GENERIC FUNCTION BODY. + -- SPECIFICATION, BODY STUB, AND AN INSTANTIATION ARE + -- IN CA2009F0M.DEP. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- BHS 08/01/84 CREATED ORIGINAL TEST. + -- PWB 02/19/86 MODIFIED COMMENTS TO DESCRIBE RELATION TO OTHER + -- FILES AND POSSIBLE NON-APPLICABILITY. + -- BCB 01/05/88 MODIFIED HEADER. + -- EDS 08/04/98 REMOVE CONTROL Z AT END OF FILE. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA2009F0M) + FUNCTION FUNC1 RETURN OBJ IS + BEGIN + FVAR1 := FCON1; + RETURN FVAR1; + END FUNC1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca2011b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CA2011B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR A SUBPROGRAM DECLARATION-STUB-BODY TRIPLE, THE + -- DECLARATION-STUB AND STUB-BODY SPECIFICATIONS CAN CONFORM, BUT + -- THE DECLARATION-BODY SPECIFICATIONS NEED NOT. + + -- HISTORY: + -- JET 08/01/88 CREATED ORIGINAL TEST. + + PACKAGE CA2011B0 IS + SUBTYPE T IS INTEGER RANGE -100 .. 100; + I : T := 0; + END CA2011B0; + + WITH CA2011B0; USE CA2011B0; + PACKAGE CA2011B1 IS + PROCEDURE P1 (X : CA2011B0.T); + PROCEDURE P2 (X : T); + END CA2011B1; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CA2011B1 IS + PACKAGE CA2011BX RENAMES CA2011B0; + PROCEDURE P1 (X : T) IS SEPARATE; + PROCEDURE P2 (X : CA2011BX.T) IS SEPARATE; + END CA2011B1; + + SEPARATE (CA2011B1) + PROCEDURE P1 (X : CA2011BX.T) IS + BEGIN + I := IDENT_INT(X); + END P1; + + SEPARATE (CA2011B1) + PROCEDURE P2 (X : CA2011BX.T) IS + BEGIN + I := IDENT_INT(X); + END P2; + + WITH REPORT; USE REPORT; + WITH CA2011B0, CA2011B1; + PROCEDURE CA2011B IS + + PACKAGE P1 IS + SUBTYPE T IS INTEGER RANGE -100 .. 100; + END P1; + USE P1; + + FUNCTION F1 RETURN P1.T; + FUNCTION F2 RETURN T; + + PACKAGE P2 RENAMES P1; + + FUNCTION F1 RETURN T IS SEPARATE; + FUNCTION F2 RETURN P2.T IS SEPARATE; + + BEGIN + TEST ("CA2011B", "CHECK THAT FOR A SUBPROGRAM DECLARATION-STUB-" & + "BODY TRIPLE, THE DECLARATION-STUB AND STUB-" & + "BODY SPECIFICATIONS CAN CONFORM, BUT THE " & + "DECLARATON-BODY SPECIFICATIONS NEED NOT"); + + IF F1 /= IDENT_INT(100) THEN + FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 1"); + END IF; + + IF F2 /= IDENT_INT(-100) THEN + FAILED ("INCORRECT RETURN VALUE FROM FUNCTION 2"); + END IF; + + CA2011B1.P1(3); + IF CA2011B0.I /= IDENT_INT(3) THEN + FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 1"); + END IF; + + CA2011B1.P2(4); + IF CA2011B0.I /= IDENT_INT(4) THEN + FAILED ("INCORRECT RETURN VALUE FROM PROCEDURE 2"); + END IF; + + RESULT; + END CA2011B; + + SEPARATE (CA2011B) + FUNCTION F1 RETURN P2.T IS + BEGIN + RETURN 100; + END F1; + + SEPARATE (CA2011B) + FUNCTION F2 RETURN P2.T IS + BEGIN + RETURN -100; + END F2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca21001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca21001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca21001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca21001.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CA21001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687 and + -- F08630-91-C-0015, the U.S. Government obtained unlimited rights in the + -- software and documentation contained herein. Unlimited rights are + -- defined in DFAR 252.227-7013(a)(19). By making this public release, + -- the Government intends to confer upon all recipients unlimited rights + -- equal to those held by the Government. These rights include rights to + -- use, duplicate, release or disclose the released technical data and + -- computer software in whole or in part, in any manner and for any purpose + -- whatsoever, and to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check the requirements of the revised 10.2.1(11) from Technical + -- Corrigendum 1 (originally discussed as AI95-00002). + -- A package subunit whose parent is a preelaborated subprogram need + -- not be preelaborable. + -- + -- TEST DESCRIPTION + -- We create several preelaborated library procedures with + -- non-preelaborable package body subunits. We try various levels + -- of nesting of package and procedure subunits. + -- + -- CHANGE HISTORY: + -- 29 JUN 1999 RAD Initial Version + -- 23 SEP 1999 RLB Improved comments, renamed, issued. + -- + --! + + procedure CA21001_1(X: out Integer); + pragma Preelaborate(CA21001_1); + + procedure CA21001_1(X: out Integer) is + function F return Integer is separate; + + package Sub is + function G(X: Integer) return Integer; + -- Returns X + 1. + Not_Preelaborable: Integer := F; -- OK, by AI-2. + end Sub; + + package body Sub is separate; + + begin + X := -1; + X := F; + X := Sub.G(X); + end CA21001_1; + + separate(CA21001_1) + package body Sub is + package Sub_Sub is + -- Empty. + end Sub_Sub; + package body Sub_Sub is separate; + + function G(X: Integer) return Integer is separate; + begin + Not_Preelaborable := G(F); -- OK, by AI-2. + if Not_Preelaborable /= 101 then + raise Program_Error; -- Can't call Report.Failed, here, + -- because Report is not preelaborated. + end if; + end Sub; + + separate(CA21001_1.Sub) + package body Sub_Sub is + begin + X := X; -- OK by AI-2. + end Sub_Sub; + + separate(CA21001_1.Sub) + function G(X: Integer) return Integer is + + package G_Sub is + function H(X: Integer) return Integer; + -- Returns X + 1. + Not_Preelaborable: Integer := F; -- OK, by AI-2. + end G_Sub; + package body G_Sub is separate; + + begin + return G_Sub.H(X); + end G; + + separate(CA21001_1.Sub.G) + package body G_Sub is + function H(X: Integer) return Integer is separate; + begin + Not_Preelaborable := H(F); -- OK, by AI-2. + if Not_Preelaborable /= 101 then + raise Program_Error; -- Can't call Report.Failed, here, + -- because Report is not preelaborated. + end if; + end G_Sub; + + separate(CA21001_1.Sub.G.G_Sub) + function H(X: Integer) return Integer is + begin + return X + 1; + end H; + + separate(CA21001_1) + function F return Integer is + + package F_Sub is + -- Empty. + end F_Sub; + + package body F_Sub is separate; + begin + return 100; + end F; + + separate(CA21001_1.F) + package body F_Sub is + True_Var: Boolean; + begin + True_Var := True; + if True_Var then -- OK by AI-2. + X := X; + else + X := X + 2; + end if; + end F_Sub; + + with Report; use Report; + with CA21001_1; + procedure CA21001 is + X: Integer := 0; + begin + Test("CA21001", + "Test that a package subunit whose parent is a preelaborated" + & " subprogram need not be preelaborable"); + CA21001_1(X); + if X /= 101 then + Failed("Bad value for X"); + end if; + Result; + end CA21001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- CA3011A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- A GENERIC UNIT. + -- SUBUNITS ARE IN CA3011A1, CA3011A2, AND CA3011A3. + -- INSTANTIATION IS IN CA3011A4M. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- RJW 09/22/86 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + WITH REPORT; USE REPORT; + + GENERIC + TYPE T IS (<>); + X : T; + PROCEDURE CA3011A0 (Z : OUT T); + + PROCEDURE CA3011A0 (Z : OUT T) IS + T1 : T; + + FUNCTION CA3011A1 RETURN T IS SEPARATE; + + PROCEDURE CA3011A2 (Y : OUT T) IS SEPARATE; + + PACKAGE CA3011A3 IS + FUNCTION CA3011A3F RETURN T; + END CA3011A3; + + PACKAGE BODY CA3011A3 IS SEPARATE; + + BEGIN + IF CA3011A1 /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A1" ); + END IF; + + CA3011A2 (T1); + + IF T1 /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY PROCEDURE CA3011A2 " ); + END IF; + + IF CA3011A3.CA3011A3F /= X THEN + FAILED ( "INCORRECT VALUE RETURNED BY FUNCTION CA3011A3F " ); + END IF; + + Z := X; + + END CA3011A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + -- CA3011A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- A SUBUNIT OF A GENERIC UNIT. + -- THE GENERIC UNIT IS IN CA3011A0. + -- INSTANTIATION IS IN CA0011A4M. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- RJW 09/22/86 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA3011A0) + FUNCTION CA3011A1 RETURN T IS + + BEGIN + RETURN X; + END CA3011A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + -- CA3011A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- A SUBUNIT OF A GENERIC UNIT. + -- THE GENERIC UNIT IS IN CA3011A0. + -- INSTANTIATION IS IN CA3011A4M. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- RJW 09/22/86 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA3011A0) + PROCEDURE CA3011A2 (Y : OUT T) IS + + BEGIN + Y := X; + END CA3011A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + -- CA3011A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- A SUBUNIT OF A GENERIC UNIT. + -- THE GENERIC UNIT IS IN CA3011A0. + -- INSTANTIATION IS IN CA3011A4M. + + -- APPLICABILITY CRITERIA: + -- THIS UNIT MUST BE ACCEPTED BY ALL ADA 95 IMPLEMENTATIONS. + + -- HISTORY: + -- RJW 09/22/86 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + + SEPARATE (CA3011A0) + PACKAGE BODY CA3011A3 IS + FUNCTION CA3011A3F RETURN T IS + BEGIN + RETURN X; + END; + END CA3011A3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca3011a4.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- CA3011A4M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN IMPLEMENTATION DOES NOT REQUIRE GENERIC UNIT BODIES AND + -- SUBUNITS TO BE COMPILED TOGETHER IN THE SAME FILE. + + -- SEPARATE FILES ARE: + -- CA3011A0 - A GENERIC UNIT. + -- CA3011A1, CA3011A2, CA3011A3 - SUBUNITS OF GENERIC UNIT. + -- CA3011A4M - THE MAIN PROCEDURE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST MUST RUN AND REPORT "PASSED" FOR ALL ADA 95 IMPLEMENTATIONS. + -- THIS WAS NOT REQUIRED FOR ADA 83. + + -- HISTORY: + -- RJW 09/22/86 CREATED ORIGINAL TEST. + -- BCB 01/05/88 MODIFIED HEADER. + -- RLB 09/13/99 UPDATED APPLICABILITY CRITERIA FOR ADA 95. + -- RLB 09/15/99 REPAIRED OBJECTIVE FOR ADA 95. + + WITH REPORT; USE REPORT; + WITH CA3011A0; + PROCEDURE CA3011A4M IS + I : INTEGER; + PROCEDURE P IS NEW CA3011A0 (INTEGER, 22); + + BEGIN + TEST ( "CA3011A", "CHECK THAT AN IMPLEMENTATION DOES NOT REQUIRE " & + "GENERIC UNIT BODIES AND SUBUNITS TO BE " & + "COMPILED TOGETHER IN THE SAME FILE" ); + + P (I); + IF I /= 22 THEN + FAILED ( "INCORRECT INSTANTIATION" ); + END IF; + + RESULT; + END CA3011A4M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + -- CA5003A0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + PACKAGE CA5003A0 IS + + ORDER : STRING (1..5) := " "; + + INDEX : NATURAL := 1; + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER; + + END CA5003A0; + + + WITH REPORT; + USE REPORT; + PACKAGE BODY CA5003A0 IS + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS + BEGIN + ORDER (INDEX) := UNIT; + INDEX := INDEX + 1; + RETURN INDEX - 1; + END SHOW_ELAB; + + END CA5003A0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA5003A1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH CA5003A0; + USE CA5003A0; PRAGMA ELABORATE (CA5003A0); + PACKAGE CA5003A1 IS + + A1 : INTEGER := SHOW_ELAB ('1'); + + END CA5003A1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA5003A2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH CA5003A0; + USE CA5003A0; PRAGMA ELABORATE (CA5003A0); + PACKAGE CA5003A2 IS + + A2 : INTEGER := SHOW_ELAB ('2'); + + END CA5003A2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA5003A3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH CA5003A0, CA5003A2; + USE CA5003A0; PRAGMA ELABORATE (CA5003A0); + PACKAGE CA5003A3 IS + + A3 : INTEGER := SHOW_ELAB ('3'); + + END CA5003A3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a4.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA5003A4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH CA5003A0, CA5003A2; + USE CA5003A0; PRAGMA ELABORATE (CA5003A0); + PACKAGE CA5003A4 IS + + A4 : INTEGER := SHOW_ELAB ('4'); + + END CA5003A4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a5.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + -- CA5003A5.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH CA5003A0, CA5003A3, CA5003A4; + USE CA5003A0; PRAGMA ELABORATE (CA5003A0); + PACKAGE CA5003A5 IS + + A5 : INTEGER := SHOW_ELAB ('5'); + + END CA5003A5; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003a6.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CA5003A6M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ELABORATION OF LIBRARY UNITS REQUIRED BY + -- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL + -- ORDERING DEFINED BY THE COMPILATION ORDER RULES. + + -- SEPARATE FILES ARE: + -- CA5003A0 A LIBRARY PACKAGE. + -- CA5003A1 A LIBRARY PACKAGE SPECIFICATION. + -- CA5003A2 A LIBRARY PACKAGE SPECIFICATION. + -- CA5003A3 A LIBRARY PACKAGE SPECIFICATION. + -- CA5003A4 A LIBRARY PACKAGE SPECIFICATION. + -- CA5003A5 A LIBRARY PACKAGE SPECIFICATION. + -- CA5003A6M THE MAIN PROCEDURE. + + -- PACKAGE A5 MUST BE ELABORATED AFTER A2, A3, AND A4. + -- PACKAGE A3 MUST BE ELABORATED AFTER A2. + -- PACKAGE A4 MUST BE ELABORATED AFTER A2. + + -- WKB 7/22/81 + -- JBG 10/6/83 + + WITH REPORT, CA5003A0; + USE REPORT, CA5003A0; + WITH CA5003A1, CA5003A5; + PROCEDURE CA5003A6M IS + + BEGIN + + TEST ("CA5003A", "CHECK THAT ELABORATION ORDER IS CONSISTENT " & + "WITH PARTIAL ORDERING REQUIREMENTS"); + + COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER); + + IF ORDER /= "12345" AND + ORDER /= "12435" AND + ORDER /= "21345" AND + ORDER /= "21435" AND + ORDER /= "23145" AND + ORDER /= "24135" AND + ORDER /= "23415" AND + ORDER /= "24315" AND + ORDER /= "23451" AND + ORDER /= "24351" THEN + FAILED ("ILLEGAL ELABORATION ORDER"); + END IF; + + RESULT; + END CA5003A6M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- CA5003B0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + -- BHS 8/02/84 + -- JRK 9/20/84 + + + PACKAGE CA5003B0 IS + + ORDER : STRING (1..4) := " "; + + INDEX : NATURAL := 1; + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER; + + END CA5003B0; + + + PACKAGE BODY CA5003B0 IS + + FUNCTION SHOW_ELAB (UNIT : CHARACTER) RETURN INTEGER IS + BEGIN + ORDER (INDEX) := UNIT; + INDEX := INDEX + 1; + RETURN INDEX - 1; + END SHOW_ELAB; + + END CA5003B0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,46 ---- + -- CA5003B1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + -- BHS 8/02/84 + -- JRK 9/20/84 + + + WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); + PACKAGE CA5003B1 IS + + PACKAGE CA5003B2 IS + PROCEDURE P1; + END CA5003B2; + + END CA5003B1; + + + PACKAGE BODY CA5003B1 IS + + A1 : INTEGER := SHOW_ELAB ('1'); + PACKAGE BODY CA5003B2 IS SEPARATE; + + END CA5003B1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + -- CA5003B2.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 8/02/84 + -- JRK 9/20/84 + + WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); + SEPARATE (CA5003B1) + PACKAGE BODY CA5003B2 IS + + A2 : INTEGER := SHOW_ELAB ('2'); + + PROCEDURE P1 IS + BEGIN + NULL; + END P1; + + PACKAGE CA5003B4 IS + PROCEDURE P2; + END CA5003B4; + + PACKAGE BODY CA5003B4 IS SEPARATE; + + END CA5003B2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b3.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + -- CA5003B3.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- WKB 7/22/81 + -- JBG 10/6/83 + -- BHS 8/02/84 + -- JRK 9/20/84 + + WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); + PACKAGE CA5003B3 IS + + A3 : INTEGER := SHOW_ELAB ('3'); + + END CA5003B3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b4.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,40 ---- + -- CA5003B4.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- BHS 8/02/84 + -- JRK 9/20/84 + + WITH CA5003B3; -- MUST BE ELABORATED BEFORE CA5003B1. + WITH CA5003B0; USE CA5003B0; PRAGMA ELABORATE (CA5003B0); + SEPARATE (CA5003B1.CA5003B2) + PACKAGE BODY CA5003B4 IS + + A4 : INTEGER := SHOW_ELAB ('4'); + + PROCEDURE P2 IS + BEGIN + NULL; + END P2; + + END CA5003B4; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5003b5.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- CA5003B5M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ELABORATION OF LIBRARY UNITS REQUIRED BY + -- A MAIN PROGRAM IS PERFORMED CONSISTENTLY WITH THE PARTIAL + -- ORDERING DEFINED BY THE COMPILATION ORDER RULES. + -- IN PARTICULAR, CHECK THAT A LIBRARY UNIT MENTIONED IN THE + -- WITH_CLAUSE OF A SUBUNIT IS ELABORATED PRIOR TO THE BODY OF + -- THE ANCESTOR UNIT. + + -- SEPARATE FILES ARE: + -- CA5003B0 A LIBRARY PACKAGE. + -- CA5003B1 A LIBRARY PACKAGE. + -- CA5003B2 A SUBUNIT PACKAGE BODY (_B1._B2). + -- CA5003B3 A LIBRARY PACKAGE DECLARATION. + -- CA5003B4 A SUBUNIT PACKAGE BODY (_B1._B2._B4). + -- CA5003B5M THE MAIN PROCEDURE. + + -- LIBRARY PACKAGES MUST BE ELABORATED IN ORDER: _B0, _B3, _B1. + -- PARENT UNITS MUST BE ELABORATED BEFORE THEIR SUBUNITS. + + -- WKB 7/22/81 + -- JBG 10/6/83 + -- BHS 8/02/84 + -- JRK 9/20/84 + + WITH REPORT, CA5003B0; + USE REPORT, CA5003B0; + WITH CA5003B1; + PROCEDURE CA5003B5M IS + + BEGIN + TEST ("CA5003B", "CHECK THAT UNITS IN WITH_CLAUSES OF " & + "SUBUNITS ARE ELABORATED PRIOR TO THE " & + "BODY OF THE ANCESTOR UNIT"); + + COMMENT ("ACTUAL ELABORATION ORDER WAS " & ORDER); + + IF ORDER /= "3124" THEN + FAILED ("ILLEGAL ELABORATION ORDER"); + END IF; + + RESULT; + END CA5003B5M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CA5004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT IF PRAGMA ELABORATE IS APPLIED TO A PACKAGE THAT DECLARES + -- A TASK OBJECT, THE IMPLICIT PACKAGE BODY IS ELABORATED AND THE TASK + -- IS ACTIVATED. + + -- BHS 8/03/84 + -- JRK 9/20/84 + -- PWN 01/31/95 ADDED A PROCEDURE TO REQUIRE A BODY FOR ADA 9X. + + + PACKAGE CA5004A0 IS + + TASK TYPE TSK IS + ENTRY E (VAR : OUT INTEGER); + END TSK; + + END CA5004A0; + + + PACKAGE BODY CA5004A0 IS + + TASK BODY TSK IS + BEGIN + ACCEPT E (VAR : OUT INTEGER) DO + VAR := 4; + END E; + END TSK; + + END CA5004A0; + + + WITH CA5004A0; USE CA5004A0; PRAGMA ELABORATE (CA5004A0); + PACKAGE CA5004A1 IS + + T : TSK; + + END CA5004A1; + + + PACKAGE CA5004A2 IS + PROCEDURE REQUIRE_BODY; + END CA5004A2; + + + WITH REPORT; USE REPORT; + WITH CA5004A1; USE CA5004A1; + PRAGMA ELABORATE (CA5004A1, REPORT); + PACKAGE BODY CA5004A2 IS + + I : INTEGER := 1; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + + TEST ("CA5004A", "APPLYING PRAGMA ELABORATE TO A PACKAGE " & + "DECLARING A TASK OBJECT CAUSES IMPLICIT " & + "BODY ELABORATION AND TASK ACTIVATION"); + + SELECT + T.E(I); + IF I /= 4 THEN + FAILED ("TASK NOT EXECUTED PROPERLY"); + END IF; + OR + DELAY 10.0; + FAILED ("TASK NOT ACTIVATED AFTER 10 SECONDS"); + END SELECT; + + END CA5004A2; + + + WITH CA5004A2; + WITH REPORT; USE REPORT; + PROCEDURE CA5004A IS + BEGIN + + RESULT; + + END CA5004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- CA5004B0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: See CA5004B2M.ADA + -- + -- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA + -- + -- TEST FILES: + -- => CA5004B0.ADA + -- CA5004B1.ADA + -- CA5004B2M.ADA + + -- PWN 05/31/96 Split test into files without duplicate unit names. + -- RLB 03/11/99 Split test into files so that units that will be replaced + -- and units that won't are not in the same source file. + + ------------------------------------------------------------- + + PACKAGE HEADER IS + + PROCEDURE WRONG (WHY : STRING); + + END HEADER; + + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY HEADER IS + + PROCEDURE WRONG (WHY : STRING) IS + BEGIN + FAILED ("PACKAGE WITH " & WHY & " NOT ELABORATED " & + "CORRECTLY"); + END WRONG; + + BEGIN + + TEST ("CA5004B", "PRAGMA ELABORATE IS ACCEPTED AND OBEYED " & + "EVEN WHEN THE BODY OF THE UNIT NAMED IS " & + "MISSING OR OBSOLETE"); + + END HEADER; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- CA5004B1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: See CA5004B2M.ADA + -- + -- SPECIAL INSTRUCTIONS: See CA5004B2M.ADA + -- + -- TEST FILES: + -- CA5004B0.ADA + -- => CA5004B1.ADA + -- CA5004B2M.ADA + + -- PWN 05/31/96 Split test into files without duplicate unit names. + -- RLB 03/11/99 Split test into files so that units that will be replaced + -- and units that won't are not in the same source file. + + ------------------------------------------------------------------ + + PACKAGE CA5004B0 IS + + I : INTEGER := 1; + + FUNCTION F RETURN BOOLEAN; + + END CA5004B0; + + + PACKAGE BODY CA5004B0 IS + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F; + + END CA5004B0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5004b2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- CA5004B2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PRAGMA ELABORATE IS ACCEPTED AND OBEYED EVEN IF THE UNIT + -- NAMED IN THE PRAGMA DOES NOT YET HAVE A BODY IN THE LIBRARY OR IF + -- ITS BODY IS OBSOLETE. + -- CHECK THAT MORE THAN ONE NAME IS ALLOWED IN A PRAGMA ELABORATE. + -- + -- SPECIAL INSTRUCTIONS: + -- 1. Compile CA5004B0.ADA + -- 2. Compile CA5004B1.ADA + -- 3. Compile CA5004B2M.ADA + -- 4. Bind/Link main unit CA5004B2M + -- 5. Execute the resulting file + -- + -- TEST FILES: + -- CA5004B0.ADA + -- CA5004B1.ADA + -- => CA5004B2M.ADA + + -- BHS 8/03/84 + -- JRK 9/20/84 + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + -- PWN 05/31/96 Split test into files without duplicate unit names. + -- TMB 11/20/96 ADDED PROCEDURE DECL TO CA5004B0 TO INSURE IT MAKES + -- THE OLD BODY OBSOLETE + -- TMB 12/2/96 MADE NAME OF MAIN PROCEDURE SAME AS FILE NAME + -- RLB 03/11/99 Split first test file in order to prevent good units + -- from being made obsolete. + + ------------------------------------------------------------- + + PACKAGE CA5004B0 IS -- OLD BODY NOW OBSOLETE. + + I : INTEGER := 2; + B : BOOLEAN := TRUE; + + FUNCTION F RETURN BOOLEAN; + PROCEDURE P; + + END CA5004B0; + + --------------------------------------------------------- + + PACKAGE CA5004B1 IS + + J : INTEGER := 3; + + PROCEDURE P (X : INTEGER); + + END CA5004B1; -- NO BODY GIVEN YET. + + ---------------------------------------------------------- + + WITH HEADER; USE HEADER; + WITH CA5004B0, CA5004B1; + USE CA5004B0, CA5004B1; + PRAGMA ELABORATE (HEADER, CA5004B0, CA5004B1); + PACKAGE CA5004B2 IS + + K1 : INTEGER := CA5004B0.I; + K2 : INTEGER := CA5004B1.J; + + PROCEDURE REQUIRE_BODY; + + END CA5004B2; + + + PACKAGE BODY CA5004B2 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + BEGIN + + IF K1 /= 4 THEN + WRONG ("OBSOLETE BODY"); + END IF; + + IF K2 /= 5 THEN + WRONG ("NO BODY"); + END IF; + + END CA5004B2; + + -------------------------------------------------- + + WITH REPORT, CA5004B2; + USE REPORT, CA5004B2; + PROCEDURE CA5004B2M IS + BEGIN + + RESULT; + + END CA5004B2M; + + ---------------------------------------------------- + + PACKAGE BODY CA5004B0 IS + + FUNCTION F RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END F; + + PROCEDURE P IS + BEGIN + RETURN; + END P; + + BEGIN + + I := 4; + + END CA5004B0; + + --------------------------------------------------- + + PACKAGE BODY CA5004B1 IS + + PROCEDURE P (X : INTEGER) IS + BEGIN + NULL; + END P; + + BEGIN + + J := 5; + + END CA5004B1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ca/ca5006a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- CA5006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A PROGRAM IS NOT REJECTED JUST BECAUSE THERE IS NO WAY TO + -- ELABORATE SECONDARY UNITS SO PROGRAM_ERROR WILL BE AVOIDED. + + -- R.WILLIAMS 9/22/86 + + ----------------------------------------------------------------------- + + PACKAGE CA5006A0 IS + FUNCTION P_E_RAISED RETURN BOOLEAN; + PROCEDURE SHOW_PE_RAISED; + END CA5006A0; + + ----------------------------------------------------------------------- + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CA5006A0 IS + RAISED : BOOLEAN := FALSE; + + FUNCTION P_E_RAISED RETURN BOOLEAN IS + BEGIN + RETURN RAISED; + END P_E_RAISED; + + PROCEDURE SHOW_PE_RAISED IS + BEGIN + RAISED := TRUE; + END SHOW_PE_RAISED; + + BEGIN + TEST ( "CA5006A", "CHECK THAT A PROGRAM IS NOT REJECTED JUST " & + "BECAUSE THERE IS NO WAY TO ELABORATE " & + "SECONDARY UNITS SO PROGRAM_ERROR WILL BE " & + "AVOIDED" ); + + + END CA5006A0; + + ----------------------------------------------------------------------- + + PACKAGE CA5006A1 IS + FUNCTION F RETURN INTEGER; + END CA5006A1; + + ----------------------------------------------------------------------- + + PACKAGE CA5006A2 IS + FUNCTION G RETURN INTEGER; + END CA5006A2; + + ----------------------------------------------------------------------- + + WITH REPORT; USE REPORT; + WITH CA5006A0; USE CA5006A0; + WITH CA5006A2; USE CA5006A2; + PRAGMA ELABORATE(CA5006A0); + + PACKAGE BODY CA5006A1 IS + X : INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(0); + END F; + + BEGIN + X := G; + IF NOT P_E_RAISED THEN + FAILED ( "G CALLED" ); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A1" ); + SHOW_PE_RAISED; + WHEN OTHERS => + FAILED ( "OTHER ERROR RAISED IN CA5006A1" ); + END CA5006A1; + + ----------------------------------------------------------------------- + + WITH REPORT; USE REPORT; + WITH CA5006A0; USE CA5006A0; + WITH CA5006A1; USE CA5006A1; + PRAGMA ELABORATE(CA5006A0); + + PACKAGE BODY CA5006A2 IS + X : INTEGER; + + FUNCTION G RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END G; + + BEGIN + X := F; + IF NOT P_E_RAISED THEN + FAILED ( "F CALLED" ); + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + COMMENT ( "PROGRAM_ERROR RAISED IN CA5006A2" ); + SHOW_PE_RAISED; + WHEN OTHERS => + FAILED ( "OTHER ERROR RAISED IN CA5006A2" ); + END CA5006A2; + + ----------------------------------------------------------------------- + + WITH REPORT; USE REPORT; + WITH CA5006A0; USE CA5006A0; + WITH CA5006A1; + WITH CA5006A2; + + PROCEDURE CA5006A IS + BEGIN + IF NOT P_E_RAISED THEN + FAILED ( "PROGRAM_ERROR NEVER RAISED" ); + END IF; + + RESULT; + END CA5006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb10002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb10002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb10002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb10002.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- CB10002.A + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Storage_Error is raised when storage for allocated objects + -- is exceeded. + -- + -- TEST DESCRIPTION: + -- This test allocates a very large data structure. + -- + -- In order to avoid running forever on virtual memory targets, the + -- data structure is bounded in size, and elements are larger the longer + -- the program runs. + -- + -- The program attempts to allocate about 8,600,000 integers, or about + -- 32 Megabytes on a typical 32-bit machine. + -- + -- If Storage_Error is raised, the data structure is deallocated. + -- (Otherwise, Report.Result may fail as memory is exhausted). + + -- CHANGE HISTORY: + -- 30 Aug 85 JRK Ada 83 test created. + -- 14 Sep 99 RLB Created Ada 95 test. + + + with Report; + with Ada.Unchecked_Deallocation; + procedure CB10002 is + + type Data_Space is array (Positive range <>) of Integer; + + type Element (Size : Positive); + + type Link is access Element; + + type Element (Size : Positive) is + record + Parent : Link; + Child : Link; + Sibling: Link; + Data : Data_Space (1 .. Size); + end record; + + procedure Free is new Ada.Unchecked_Deallocation (Element, Link); + + Holder : array (1 .. 430) of Link; + Last_Allocated : Natural := 0; + + procedure Allocator (Count : in Positive) is + begin + -- Allocate various sized objects similar to what a real application + -- would do. + if Count in 1 .. 20 then + Holder(Count) := new Element (Report.Ident_Int(10)); + elsif Count in 21 .. 40 then + Holder(Count) := new Element (Report.Ident_Int(79)); + elsif Count in 41 .. 60 then + Holder(Count) := new Element (Report.Ident_Int(250)); + elsif Count in 61 .. 80 then + Holder(Count) := new Element (Report.Ident_Int(520)); + elsif Count in 81 .. 100 then + Holder(Count) := new Element (Report.Ident_Int(1000)); + elsif Count in 101 .. 120 then + Holder(Count) := new Element (Report.Ident_Int(2048)); + elsif Count in 121 .. 140 then + Holder(Count) := new Element (Report.Ident_Int(4200)); + elsif Count in 141 .. 160 then + Holder(Count) := new Element (Report.Ident_Int(7999)); + elsif Count in 161 .. 180 then + Holder(Count) := new Element (Report.Ident_Int(15000)); + else -- 181..430 + Holder(Count) := new Element (Report.Ident_Int(32000)); + end if; + Last_Allocated := Count; + end Allocator; + + + begin + Report.Test ("CB10002", "Check that Storage_Error is raised when " & + "storage for allocated objects is exceeded"); + + begin + for I in Holder'range loop + Allocator (I); + end loop; + Report.Not_Applicable ("Unable to exhaust memory"); + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + exception + when Storage_Error => + if Last_Allocated = 0 then + Report.Failed ("Unable to allocate anything"); + else -- Clean up, so we have enough memory to report on the result. + for I in 1 .. Last_Allocated loop + Free (Holder(I)); + end loop; + Report.Comment (Natural'Image(Last_Allocated) & " items allocated"); + end if; + when others => + Report.Failed ("Wrong exception raised by heap overflow"); + end; + + Report.Result; + + end CB10002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1001a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- CB1001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ALL PREDEFINED EXCEPTIONS MAY BE RAISED EXPLICITLY + -- AND MAY HAVE HANDLERS WRITTEN FOR THEM. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- DCB 03/25/80 + -- JRK 11/17/80 + -- SPS 11/2/82 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE CB1001A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + + BEGIN + TEST("CB1001A", "CHECK THAT ALL PREDEFINED EXCEPTIONS MAY BE " & + "RAISED EXPLICITLY AND MAY HAVE HANDLERS WRITTEN FOR THEM"); + + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED("NO EXCEPTION RAISED WHEN CONSTRAINT_ERROR EXPECTED"); + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN CONSTRAINT_ERROR " & + "EXPECTED"); + END; + + + BEGIN + RAISE PROGRAM_ERROR; + FAILED("NO EXCEPTION RAISED WHEN PROGRAM_ERROR EXPECTED"); + EXCEPTION + WHEN PROGRAM_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN PROGRAM_ERROR " & + "EXPECTED"); + END; + + BEGIN + RAISE STORAGE_ERROR; + FAILED("NO EXCEPTION RAISED WHEN STORAGE_ERROR EXPECTED"); + + EXCEPTION + WHEN STORAGE_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN STORAGE_ERROR " & + "EXPECTED"); + END; + + BEGIN + RAISE TASKING_ERROR; + FAILED("NO EXCEPTION RAISED WHEN TASKING_ERROR EXPECTED"); + + EXCEPTION + WHEN TASKING_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED WHEN TASKING_ERROR " & + "EXPECTED"); + END; + + IF FLOW_COUNT /= 4 THEN + FAILED("WRONG FLOW_COUNT VALUE"); + END IF; + + RESULT; + END CB1001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CB1004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXCEPTIONS DECLARED IN RECURSIVE PROCEDURES ARE NOT + -- REPLICATED ANEW FOR EACH RECURSIVE ACTIVATION OF THE PROCEDURE. + + -- DCB 03/30/80 + -- JRK 11/17/80 + -- SPS 3/23/83 + + WITH REPORT; + PROCEDURE CB1004A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + + PROCEDURE P1(SWITCH1 : IN INTEGER) IS + + E1 : EXCEPTION; + + PROCEDURE P2 IS + + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; -- 3 + P1(2); + FAILED("EXCEPTION NOT PROPAGATED"); + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; -- 6 + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED"); + END P2; + + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; -- 2 -- 4 + IF SWITCH1 = 1 THEN + P2; + ELSIF SWITCH1 = 2 THEN + FLOW_COUNT := FLOW_COUNT + 1; -- 5 + RAISE E1; + FAILED("EXCEPTION NOT RAISED"); + END IF; + END P1; + + BEGIN + TEST("CB1004A","CHECK THAT EXCEPTIONS ARE NOT RECURSIVELY " & + "REPLICATED"); + + FLOW_COUNT := FLOW_COUNT + 1; -- 1 + P1(1); + + IF FLOW_COUNT /= 6 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION HANDLED IN WRONG SCOPE"); + RESULT; + END CB1004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1005a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CB1005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXCEPTIONS DECLARED IN GENERIC PACKAGES AND PROCEDURES ARE + -- CONSIDERED DISTINCT FOR EACH INSTANTIATION. + + -- CHECK THAT AN EXCEPTION NAME DECLARED IN A GENERIC PACKAGE + -- INSTANTIATION IN A RECURSIVE PROCEDURE DENOTES THE SAME ENTITY + -- EVEN WHEN THE INSTANTIATION IS ELABORATED MORE THAN ONCE BECAUSE + -- OF RECURSIVE CALLS. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- TBN 9/23/86 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + PROCEDURE CB1005A IS + + PROCEDURE PROP; + + GENERIC + PACKAGE PAC IS + EXC : EXCEPTION; + END PAC; + + GENERIC + PROCEDURE PROC (INST_AGAIN : BOOLEAN); + + PROCEDURE PROC (INST_AGAIN : BOOLEAN) IS + EXC : EXCEPTION; + BEGIN + IF INST_AGAIN THEN + BEGIN + PROP; + FAILED ("EXCEPTION WAS NOT PROPAGATED - 9"); + EXCEPTION + WHEN EXC => + FAILED ("EXCEPTION NOT DISTINCT - 10"); + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | CONSTRAINT_ERROR => + FAILED ("WRONG EXCEPTION PROPAGATED - 11"); + WHEN OTHERS => + NULL; + END; + ELSE + RAISE EXC; + END IF; + END PROC; + + PROCEDURE RAISE_EXC (CALL_AGAIN : BOOLEAN) IS + PACKAGE PAC3 IS NEW PAC; + BEGIN + IF CALL_AGAIN THEN + BEGIN + RAISE_EXC (FALSE); + FAILED ("EXCEPTION WAS NOT PROPAGATED - 12"); + EXCEPTION + WHEN PAC3.EXC => + NULL; + END; + ELSE + RAISE PAC3.EXC; + END IF; + END RAISE_EXC; + + PROCEDURE PROP IS + PROCEDURE PROC2 IS NEW PROC; + BEGIN + PROC2 (FALSE); + END PROP; + + BEGIN + TEST ("CB1005A", "CHECK THAT EXCEPTIONS DECLARED IN GENERIC " & + "PACKAGES AND PROCEDURES ARE CONSIDERED " & + "DISTINCT FOR EACH INSTANTIATION"); + + ------------------------------------------------------------------- + DECLARE + PACKAGE PAC1 IS NEW PAC; + PACKAGE PAC2 IS NEW PAC; + PAC1_EXC_FOUND : BOOLEAN := FALSE; + BEGIN + BEGIN + IF EQUAL (3, 3) THEN + RAISE PAC2.EXC; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 1"); + + EXCEPTION + WHEN PAC1.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 2"); + PAC1_EXC_FOUND := TRUE; + END; + IF NOT PAC1_EXC_FOUND THEN + FAILED ("EXCEPTION WAS NOT PROPAGATED - 3"); + END IF; + + EXCEPTION + WHEN PAC1.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 4"); + WHEN PAC2.EXC => + BEGIN + IF EQUAL (3, 3) THEN + RAISE PAC1.EXC; + END IF; + FAILED ("EXCEPTION WAS NOT RAISED - 5"); + + EXCEPTION + WHEN PAC2.EXC => + FAILED ("PACKAGE EXCEPTIONS NOT DISTINCT - 6"); + WHEN PAC1.EXC => + NULL; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED - 7"); + END; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED - 8"); + END; + + ------------------------------------------------------------------- + DECLARE + PROCEDURE PROC1 IS NEW PROC; + BEGIN + PROC1 (TRUE); + END; + + ------------------------------------------------------------------- + BEGIN + RAISE_EXC (TRUE); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTIONS ARE DISTINCT FOR RECURSION - 13"); + END; + + ------------------------------------------------------------------- + + RESULT; + END CB1005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- CB1010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT STORAGE_ERROR IS RAISED WHEN STORAGE ALLOCATED TO A TASK + -- IS EXCEEDED. + + -- PNH 8/26/85 + -- JRK 8/30/85 + + WITH REPORT; USE REPORT; + + PROCEDURE CB1010A IS + + N : INTEGER := IDENT_INT (1); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + A : ARRAY (1 .. 1000) OF INTEGER; + BEGIN + N := N + M; + A (N) := M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END OVERFLOW_STACK; + + BEGIN + TEST ("CB1010A", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE ALLOCATED TO A TASK IS EXCEEDED"); + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " & + "PRIOR TO RENDEZVOUS"); + + DECLARE + + TASK T1 IS + ENTRY E1; + END T1; + + TASK BODY T1 IS + BEGIN + OVERFLOW_STACK; + FAILED ("TASK T1 NOT TERMINATED BY STACK OVERFLOW"); + END T1; + + BEGIN + + T1.E1; + FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T1.E1"); + + EXCEPTION + WHEN TASKING_ERROR => + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY CALL OF ENTRY E1 " & + "OF TERMINATED TASK T1"); + END; + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO HANDLE STORAGE_ERROR PRIOR TO " & + "RENDEZVOUS"); + + N := IDENT_INT (1); + M := IDENT_INT (0); + + DECLARE + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW IN " & + "TASK T2"); + EXCEPTION + WHEN STORAGE_ERROR => + ACCEPT E2; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK T2 BY " & + "STACK OVERFLOW"); + END T2; + + BEGIN + + T2.E2; + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 2"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED BY ENTRY CALL T2.E2"); + ABORT T2; + END; + + -------------------------------------------------- + + COMMENT ("CHECK TASKS THAT DO NOT HANDLE STORAGE_ERROR " & + "DURING RENDEZVOUS"); + + N := IDENT_INT (1); + M := IDENT_INT (0); + + DECLARE + + TASK T3 IS + ENTRY E3A; + ENTRY E3B; + END T3; + + TASK BODY T3 IS + BEGIN + ACCEPT E3A DO + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED IN ACCEPT E3A BY " & + "STACK OVERFLOW"); + END E3A; + FAILED ("EXCEPTION NOT PROPOGATED CORRECTLY IN TASK T3"); + EXCEPTION + WHEN STORAGE_ERROR => + ACCEPT E3B; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED IN TASK T3 BY " & + "STACK OVERFLOW"); + END T3; + + BEGIN + + T3.E3A; + FAILED ("NO EXCEPTION RAISED BY ENTRY CALL T3.E3A"); + + EXCEPTION + WHEN STORAGE_ERROR => + T3.E3B; + IF N /= 1 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M ALTERED - 3"); + END IF; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED BY ENTRY CALL T3.E3A " & + "INSTEAD OF STORAGE_ERROR"); + ABORT T3; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY ENTRY CALL T3.E3A"); + ABORT T3; + END; + + -------------------------------------------------- + + RESULT; + END CB1010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CB1010C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT STORAGE_ERROR IS RAISED WHEN STORAGE FOR A DECLARATIVE + -- ITEM IS INSUFFICIENT. + + -- JRK 8/30/85 + + WITH REPORT; USE REPORT; + + PROCEDURE CB1010C IS + + N : INTEGER := IDENT_INT (1000); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + BEGIN + N := N + M; + DECLARE + A : ARRAY (1 .. N) OF INTEGER; + BEGIN + A (N) := M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + M := A (N); -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END; + END OVERFLOW_STACK; + + BEGIN + TEST ("CB1010C", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE FOR A DECLARATIVE ITEM IS INSUFFICIENT"); + + BEGIN + + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW"); + + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1000 OR M /= 0 THEN + FAILED ("VALUES OF VARIABLES N OR M WERE ALTERED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW"); + END; + + RESULT; + END CB1010C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb1010d.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- CB1010D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT STORAGE_ERROR IS RAISED WHEN STORAGE FOR THE EXECUTION OF + -- A SUBPROGRAM IS INSUFFICIENT. + + -- PNH 8/26/85 + -- JRK 8/30/85 + + WITH REPORT; USE REPORT; + + PROCEDURE CB1010D IS + + N : INTEGER := IDENT_INT (1); + M : INTEGER := IDENT_INT (0); + + PROCEDURE OVERFLOW_STACK IS + BEGIN + N := N + M; + IF N > M THEN -- ALWAYS TRUE. + OVERFLOW_STACK; + END IF; + N := N - M; -- TO PREVENT TAIL RECURSION OPTIMIZATION. + END OVERFLOW_STACK; + + BEGIN + TEST ("CB1010D", "CHECK THAT STORAGE_ERROR IS RAISED WHEN " & + "STORAGE FOR THE EXECUTION OF A SUBPROGRAM " & + "IS INSUFFICIENT"); + + -- CHECK HANDLING OF STORAGE_ERROR IN MAIN PROGRAM. + + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 1"); + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1 THEN + FAILED ("VALUE OF VARIABLE N ALTERED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK OVERFLOW - 1"); + END; + + -- CHECK HANDLING OF STORAGE_ERROR IN SUBPROGRAM. + + DECLARE + + PROCEDURE P IS + BEGIN + OVERFLOW_STACK; + FAILED ("EXCEPTION NOT RAISED BY STACK OVERFLOW - 2"); + EXCEPTION + WHEN STORAGE_ERROR => + IF N /= 1 THEN + FAILED ("VALUE OF VARIABLE N ALTERED - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED BY STACK " & + "OVERFLOW - 2"); + END P; + + BEGIN + + N := IDENT_INT (1); + P; + + END; + + RESULT; + END CB1010D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20001.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,228 ---- + -- CB20001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions can be handled in accept bodies, and that a + -- task object that has an exception handled in an accept body is still + -- viable for future use. + -- + -- TEST DESCRIPTION: + -- Declare a task that has exception handlers within an accept + -- statement in the task body. Declare a task object, and make entry + -- calls with data that will cause various exceptions to be raised + -- by the accept statement. Ensure that the exceptions are: + -- 1) raised and handled locally in the accept body + -- 2) raised in the accept body and handled/reraised to be handled + -- by the task body + -- 3) raised in the accept body and propagated to the calling + -- procedure. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + + package CB20001_0 is + + Incorrect_Data, + Location_Error, + Off_Screen_Data : exception; + + TC_Handled_In_Accept, + TC_Reraised_In_Accept, + TC_Handled_In_Task_Block, + TC_Handled_In_Caller : boolean := False; + + type Location_Type is range 0 .. 2000; + + task type Submarine_Type is + entry Contact (Location : in Location_Type); + end Submarine_Type; + + Current_Position : Location_Type := 0; + + end CB20001_0; + + + --=================================================================-- + + + package body CB20001_0 is + + + task body Submarine_Type is + begin + loop + + Task_Block: + begin + select + accept Contact (Location : in Location_Type) do + if Location > 1000 then + raise Off_Screen_Data; + elsif (Location > 500) and (Location <= 1000) then + raise Location_Error; + elsif (Location > 100) and (Location <= 500) then + raise Incorrect_Data; + else + Current_Position := Location; + end if; + exception + when Off_Screen_Data => + TC_Handled_In_Accept := True; + when Location_Error => + TC_Reraised_In_Accept := True; + raise; -- Reraise the Location_Error exception + -- in the task block. + end Contact; + or + terminate; + end select; + + exception + + when Off_Screen_Data => + TC_Handled_In_Accept := False; + Report.Failed ("Off_Screen_Data exception " & + "improperly handled in task block"); + + when Location_Error => + TC_Handled_In_Task_Block := True; + end Task_Block; + + end loop; + + exception + + when Location_Error | Off_Screen_Data => + TC_Handled_In_Accept := False; + TC_Handled_In_Task_Block := False; + Report.Failed ("Exception improperly propagated out to task body"); + when others => + null; + end Submarine_Type; + + end CB20001_0; + + + --=================================================================-- + + + with CB20001_0; + with Report; + with ImpDef; + + procedure CB20001 is + + package Submarine_Tracking renames CB20001_0; + + Trident : Submarine_Tracking.Submarine_Type; -- Declare task + Sonar_Contact : Submarine_Tracking.Location_Type; + + TC_LEB_Error, + TC_Main_Handler_Used : Boolean := False; + + begin + + Report.Test ("CB20001", "Check that exceptions can be handled " & + "in accept bodies"); + + + Off_Screen_Block: + begin + Sonar_Contact := 1500; + Trident.Contact (Sonar_Contact); -- Cause Off_Screen_Data exception + -- to be raised and handled in a task + -- accept body. + exception + when Submarine_Tracking.Off_Screen_Data => + TC_Main_Handler_Used := True; + Report.Failed ("Off_Screen_Data exception improperly handled " & + "in calling procedure"); + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Off_Screen_Block"); + end Off_Screen_Block; + + + Location_Error_Block: + begin + Sonar_Contact := 700; + Trident.Contact (Sonar_Contact); -- Cause Location_Error exception + -- to be raised in task accept body, + -- propogated to a task block, and + -- handled there. Corresponding + -- exception propagated here also. + Report.Failed ("Expected exception not raised"); + exception + when Submarine_Tracking.Location_Error => + TC_LEB_Error := True; + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Location_Error_Block"); + end Location_Error_Block; + + + Incorrect_Data_Block: + begin + Sonar_Contact := 200; + Trident.Contact (Sonar_Contact); -- Cause Incorrect_Data exception + -- to be raised in task accept body, + -- propogated to calling procedure. + Report.Failed ("Expected exception not raised"); + exception + when Submarine_Tracking.Incorrect_Data => + Submarine_Tracking.TC_Handled_In_Caller := True; + when others => + Report.Failed ("Exception handled unexpectedly in " & + "Incorrect_Data_Block"); + end Incorrect_Data_Block; + + + if TC_Main_Handler_Used or + not (Submarine_Tracking.TC_Handled_In_Caller and -- Check to see that + Submarine_Tracking.TC_Handled_In_Task_Block and -- all exceptions + Submarine_Tracking.TC_Handled_In_Accept and -- were handled in + Submarine_Tracking.TC_Reraised_In_Accept and -- proper locations. + TC_LEB_Error) + then + Report.Failed ("Exceptions handled in incorrect locations"); + end if; + + if Integer(Submarine_Tracking.Current_Position) /= 0 then + Report.Failed ("Variable incorrectly written in task processing"); + end if; + + delay ImpDef.Minimum_Task_Switch; + if Trident'Callable then + Report.Failed ("Task didn't terminate with exception propagation"); + end if; + + Report.Result; + + end CB20001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20003.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,286 ---- + -- CB20003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions can be raised, reraised, and handled in an + -- accessed subprogram. + -- + -- + -- TEST DESCRIPTION: + -- Declare a record type, with one component being an access to + -- subprogram type. Various subprograms are defined to fit the profile + -- of this access type, such that the record component can refer to + -- any of the subprograms. + -- + -- Each of the subprograms raises a different exception, based on the + -- value of an input parameter. Exceptions are 1) raised, handled with + -- an others handler, reraised and propagated to main to be handled in + -- a specific handler; 2) raised, handled in a specific handler, reraised + -- and propagated to the main to be handled in an others handler there, + -- and 3) raised and propagated directly to the caller by the subprogram. + -- + -- Boolean variables are set throughout the test to ensure that correct + -- exception processing has occurred, and these variables are verified at + -- the conclusion of the test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CB20003_0 is -- package Push_Buttons + + + Non_Default_Priority, + Non_Alert_Priority, + Non_Emergency_Priority : exception; + + Handled_With_Others, + Reraised_In_Subprogram, + Handled_In_Caller : Boolean := False; + + subtype Priority_Type is Integer range 1 .. 10; + + Default_Priority : Priority_Type := 1; + Alert_Priority : Priority_Type := 3; + Emergency_Priority : Priority_Type := 5; + + + type Button is tagged private; -- Private tagged type. + + type Button_Response_Ptr is access procedure (P : in Priority_Type; + B : in out Button); + + + -- Procedures accessible with Button_Response_Ptr type. + + procedure Default_Response (P : in Priority_Type; + B : in out Button); + + procedure Alert_Response (P : in Priority_Type; + B : in out Button); + + procedure Emergency_Response (P : in Priority_Type; + B : in out Button); + + + + procedure Push (B : in out Button; + P : in Priority_Type); + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr); + + private + + type Button is tagged + record + Priority : Priority_Type := Default_Priority; + Response : Button_Response_Ptr := Default_Response'Access; + end record; + + + end CB20003_0; -- package Push_Buttons + + + --=================================================================-- + + + with Report; + + package body CB20003_0 is -- package Push_Buttons + + + procedure Push (B : in out Button; + P : in Priority_Type) is + begin -- Invoking subprogram designated + B.Response (P, B); -- by access value. + end Push; + + + procedure Set_Response (B : in out Button; + R : in Button_Response_Ptr) is + begin + B.Response := R; -- Set procedure value in record + end Set_Response; + + + procedure Default_Response (P : in Priority_Type; + B : in out Button) is + begin + if (P > Default_Priority) then + raise Non_Default_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + exception + when others => -- Catch exception with others handler + Handled_With_Others := True; -- Successfully caught with "others" + raise; + Report.Failed ("Exception not reraised in handler"); + end Default_Response; + + + + procedure Alert_Response (P : in Priority_Type; + B : in out Button) is + begin + if (P > Alert_Priority) then + raise Non_Alert_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + exception + when Non_Alert_Priority => + Reraised_In_Subprogram := True; + raise; -- Propagate to caller. + Report.Failed ("Exception not reraised in procedure excpt handler"); + when others => + Report.Failed ("Incorrect exception raised/handled"); + end Alert_Response; + + + + procedure Emergency_Response (P : in Priority_type; + B : in out Button) is + begin + if (P > Emergency_Priority) then + raise Non_Emergency_Priority; + Report.Failed ("Exception not raised in procedure body"); + else + B.Priority := P; + end if; + -- No exception handler here, exception will be propagated to caller. + end Emergency_Response; + + + end CB20003_0; -- package Push_Buttons + + + --=================================================================-- + + + with Report; + with CB20003_0; -- package Push_Buttons + + procedure CB20003 is + + package Push_Buttons renames CB20003_0; + + Console_Button : Push_Buttons.Button; + + begin + + Report.Test ("CB20003", "Check that exceptions can be raised, " & + "reraised, and handled in a subprogram " & + "referenced by an access to subprogram value"); + + + Default_Response_Processing: -- The exception + -- Handled_With_Others is to + -- be caught with an others + -- handler in Default_Resp., + -- reraised, and handled with + -- a specific handler here. + begin + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(2)); -- be handled in procedure. + exception + when Push_Buttons.Non_Default_Priority => + if not Push_Buttons.Handled_With_Others then -- Not reraised in + -- procedure. + Report.Failed + ("Exception not handled/reraised in procedure"); + end if; + when others => + Report.Failed ("Exception handled in " & + " Default_Response_Processing block"); + end Default_Response_Processing; + + + + Alert_Response_Processing: + begin + + Push_Buttons.Set_Response (Console_Button, + Push_Buttons.Alert_Response'access); + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(4)); -- be handled in procedure, + -- reraised, and propagated + -- to caller. + Report.Failed ("Exception not propagated to caller " & + "in Alert_Response_Processing block"); + + exception + when Push_Buttons.Non_Alert_Priority => + if not Push_Buttons.Reraised_In_Subprogram then -- Not reraised in + -- procedure. + Report.Failed ("Exception not reraised in procedure"); + end if; + when others => + Report.Failed ("Exception handled in " & + " Alert_Response_Processing block"); + end Alert_Response_Processing; + + + + Emergency_Response_Processing: + begin + + Push_Buttons.Set_Response (Console_Button, + Push_Buttons.Emergency_Response'access); + + Push_Buttons.Push (Console_Button, -- Raise exception that will + Report.Ident_Int(6)); -- be propagated directly to + -- caller. + Report.Failed ("Exception not propagated to caller " & + "in Emergency_Response_Processing block"); + + exception + when Push_Buttons.Non_Emergency_Priority => + Push_Buttons.Handled_In_Caller := True; + when others => + Report.Failed ("Exception handled in " & + " Emergency_Response_Processing block"); + end Emergency_Response_Processing; + + + + if not (Push_Buttons.Handled_With_Others and + Push_Buttons.Reraised_In_Subprogram and + Push_Buttons.Handled_In_Caller ) + then + Report.Failed ("Incorrect exception handling in referenced subprograms"); + end if; + + + Report.Result; + + end CB20003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20004.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- CB20004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions propagate correctly from objects of + -- protected types. Check propagation from protected entry bodies. + -- + -- TEST DESCRIPTION: + -- Declare a package with a protected type, including entries and private + -- data, simulating a bounded buffer abstraction. In the main procedure, + -- perform entry calls on an object of the protected type that raises + -- exceptions. + -- Ensure that the exceptions are: + -- 1) raised and handled locally in the entry body + -- 2) raised in the entry body and handled/reraised to be handled + -- by the caller. + -- 3) raised in the entry body and propagated directly to the calling + -- procedure. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CB20004_0 is -- Package Buffer. + + Max_Buffer_Size : constant := 2; + + Handled_In_Body, + Propagated_To_Caller, + Handled_In_Caller : Boolean := False; + + Data_Over_5, + Data_Degradation : exception; + + type Data_Item is range 0 .. 100; + + type Item_Array_Type is array (1 .. Max_Buffer_Size) of Data_Item; + + protected type Bounded_Buffer is + entry Put (Item : in Data_Item); + entry Get (Item : out Data_Item); + private + Item_Array : Item_Array_Type; + I, J : Integer range 1 .. Max_Buffer_Size := 1; + Count : Integer range 0 .. Max_Buffer_Size := 0; + end Bounded_Buffer; + + end CB20004_0; + + --=================================================================-- + + with Report; + + package body CB20004_0 is -- Package Buffer. + + protected body Bounded_Buffer is + + entry Put (Item : in Data_Item) when Count < Max_Buffer_Size is + begin + if Item > 10 then + Item_Array (I) := Item * 8; -- Constraint_Error will be raised + elsif Item > 5 then -- and handled in entry body. + raise Data_Over_5; -- Exception handled/reraised in + else -- entry body, propagated to caller. + Item_Array (I) := Item; -- Store data item in buffer. + I := (I mod Max_Buffer_Size) + 1; + Count := Count + 1; + end if; + exception + when Constraint_Error => + Handled_In_Body := True; + when Data_Over_5 => + Propagated_To_Caller := True; + raise; -- Propagate the exception to the caller. + end Put; + + + entry Get (Item : out Data_Item) when Count > 0 is + begin + Item := Item_Array(J); + J := (J mod Max_Buffer_Size) + 1; + Count := Count - 1; + if Count = 0 then + raise Data_Degradation; -- Exception to propagate to caller. + end if; + end Get; + + end Bounded_Buffer; + + end CB20004_0; + + + --=================================================================-- + + + with CB20004_0; -- Package Buffer. + with Report; + + procedure CB20004 is + + package Buffer renames CB20004_0; + + Data : Buffer.Data_Item := Buffer.Data_Item'First; + Data_Buffer : Buffer.Bounded_Buffer; -- an object of protected type. + + Handled_In_Caller : Boolean := False; -- same name as boolean declared + -- in package Buffer. + begin + + Report.Test ("CB20004", "Check that exceptions propagate correctly " & + "from objects of protected types" ); + + Initial_Data_Block: + begin -- Data causes Constraint_Error. + Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(51))); + + exception + when Constraint_Error => + Buffer.Handled_In_Body := False; -- Improper exception handling + -- in entry body. + Report.Failed ("Exception propagated to caller " & + " from Initial_Data_Block"); + when others => + Report.Failed ("Exception raised in processing and " & + "propagated to caller from Initial_Data_Block"); + end Initial_Data_Block; + + + Data_Entry_Block: + begin + -- Valid data. No exception. + Data_Buffer.Put (CB20004_0.Data_Item(Report.Ident_Int(3))); + + -- Data will cause exception. + Data_Buffer.Put (7); -- Call protected object entry, + -- exception to be handled/ + -- reraised in entry body. + Report.Failed ("Data_Over_5 Exception not raised in processing"); + exception + when Buffer.Data_Over_5 => + if Buffer.Propagated_To_Caller then -- Reraised in entry body? + Buffer.Handled_In_Caller := True; + else + Report.Failed ("Exception not reraised in entry body"); + end if; + when others => + Report.Failed ("Exception raised in processing and propagated " & + "to caller from Data_Entry_Block"); + end Data_Entry_Block; + + + Data_Retrieval_Block: + begin + + Data_Buffer.Get (Data); -- Retrieval of buffer data, buffer now empty. + -- Exception will be raised in entry body, with + -- propagation to caller. + Report.Failed ("Data_Degradation Exception not raised in processing"); + exception + when Buffer.Data_Degradation => + Handled_In_Caller := True; -- Local Boolean used here. + when others => + Report.Failed ("Exception raised in processing and propagated " & + "to caller from Data_Retrieval_Block"); + end Data_Retrieval_Block; + + + if not (Buffer.Handled_In_Body and -- Validate proper exception + Buffer.Propagated_To_Caller and -- handling in entry bodies. + Buffer.Handled_In_Caller and + Handled_In_Caller) + then + Report.Failed ("Improper exception handling by entry bodies"); + end if; + + + Report.Result; + + end CB20004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20005.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,210 ---- + -- CB20005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions are raised and properly handled locally in + -- protected operations. + -- + -- TEST DESCRIPTION: + -- Declare a package with a protected type, including protected operation + -- declarations and private data, simulating a counting semaphore. + -- In the main procedure, perform calls on protected operations + -- of the protected object designed to induce the raising of exceptions. + -- + -- Ensure that the exceptions are raised and handled locally in a + -- protected procedures and functions, and that in this case the + -- exceptions will not propagate to the calling unit. Use specific + -- exception handlers in the protected functions. + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CB20005_0 is -- Package Semaphore. + + Handled_In_Function, + Handled_In_Procedure : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + + end CB20005_0; + + --=================================================================-- + + with Report; + + package body CB20005_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed + ("Program control not transferred by raise in Secure"); + else + Count := Count - 1; -- Avail resources decremented. + end if; + exception + when Resource_Underflow => -- Exception handled locally in + Handled_In_Procedure := True; -- this protected operation. + when others => + Report.Failed ("Unexpected exception raised in Secure"); + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed + ("Program control not transferred by raise in " & + "Resource_Limit_Exceeded"); + else + return (False); + end if; + exception + when Resource_Overflow => -- Handle its own raised + Handled_In_Function := True; -- exception. + return (True); + when others => + Report.Failed + ("Unexpected exception raised in Resource_Limit_Exceeded"); + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises/handles + end if; -- an exception. + exception + when Resource_Overflow => + Handled_In_Function := False; + Report.Failed ("Exception propagated to Function Release"); + when others => + Report.Failed ("Unexpected exception raised in Function Release"); + end Release; + + + end Counting_Semaphore; + + end CB20005_0; + + + --=================================================================-- + + + with CB20005_0; -- Package Semaphore. + with Report; + + procedure CB20005 is + begin + + Report.Test ("CB20005", "Check that exceptions are raised and handled " & + "correctly in protected operations" ); + + Test_Block: + declare + + package Semaphore renames CB20005_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore(Total_Resources_Available); + -- An object of protected type. + + begin + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception. + Resources.Secure; + end loop; + exception + when Semaphore.Resource_Underflow => + Semaphore.Handled_In_Procedure := False; -- Excptn not handled + Report.Failed -- in prot. operation. + ("Resource_Underflow exception not handled " & + "in Allocate_Resources"); + when others => + Report.Failed + ("Exception unexpectedly raised during resource allocation"); + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force excptn. + Resources.Release; + end loop; + exception + when Semaphore.Resource_Overflow => + Semaphore.Handled_In_Function := False; -- Exception not handled + Report.Failed -- in prot. operation. + ("Resource overflow not handled by function"); + when others => + Report.Failed + ("Exception raised during resource deallocation"); + end Deallocate_Resources; + + + if not (Semaphore.Handled_In_Procedure and -- Incorrect excpt. handling + Semaphore.Handled_In_Function) -- in protected operations. + then + Report.Failed + ("Improper exception handling by protected operations"); + end if; + + + exception + when others => + Report.Failed ("Exception raised and propagated in test"); + + end Test_Block; + + Report.Result; + + end CB20005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20006.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,217 ---- + -- CB20006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions are raised and properly handled (including + -- propagation by reraise) in protected operations. + -- + -- TEST DESCRIPTION: + -- Declare a package with a protected type, including protected operation + -- declarations and private data, simulating a counting semaphore. + -- In the main procedure, perform calls on protected operations + -- of the protected object designed to induce the raising of exceptions. + -- + -- The exceptions raised are to be initially handled in the protected + -- operations, but this handling involves the reraise of the exception + -- and the propagation of the exception to the caller. + -- + -- Ensure that the exceptions are raised, handled / reraised successfully + -- in protected procedures and functions. Use "others" handlers in the + -- protected operations. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CB20006_0 is -- Package Semaphore. + + Reraised_In_Function, + Reraised_In_Procedure, + Handled_In_Function_Caller, + Handled_In_Procedure_Caller : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + + end CB20006_0; + + --=================================================================-- + + with Report; + + package body CB20006_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed + ("Program control not transferred by raise in Procedure Secure"); + else + Count := Count - 1; -- Available resources decremented. + end if; + exception + when Resource_Underflow => + Reraised_In_Procedure := True; + raise; -- Exception propagated to caller. + Report.Failed ("Exception not propagated to caller from Secure"); + when others => + Report.Failed ("Unexpected exception raised in Secure"); + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed + ("Specific raise did not alter program control" & + " from Resource_Limit_Exceeded"); + else + return (False); + end if; + exception + when others => + Reraised_In_Function := True; + raise; -- Exception propagated to caller. + Report.Failed ("Exception not propagated to caller" & + " from Resource_Limit_Exceeded"); + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises/reraises + -- an exception. + Report.Failed("Resource limit exceeded"); + end if; + + exception + when others => + raise; -- Reraised and propagated again. + Report.Failed ("Exception not reraised by procedure Release"); + end Release; + + + end Counting_Semaphore; + + end CB20006_0; + + + --=================================================================-- + + + with CB20006_0; -- Package Semaphore. + with Report; + + procedure CB20006 is + begin + + Report.Test ("CB20006", "Check that exceptions are raised and " & + "handled / reraised and propagated " & + "correctly by protected operations" ); + + Test_Block: + declare + + package Semaphore renames CB20006_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); + -- An object of protected type. + + begin + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception + Resources.Secure; + end loop; + Report.Failed + ("Exception not propagated from protected operation Secure"); + exception + when Semaphore.Resource_Underflow => -- Exception propagated + Semaphore.Handled_In_Procedure_Caller := True; -- from protected + when others => -- procedure. + Semaphore.Handled_In_Procedure_Caller := False; + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin + for I in 1..Loop_Count loop -- Force exception + Resources.Release; + end loop; + Report.Failed + ("Exception not propagated from protected operation Release"); + exception + when Semaphore.Resource_Overflow => -- Exception propagated + Semaphore.Handled_In_Function_Caller := True; -- from protected + when others => -- function. + Semaphore.Handled_In_Function_Caller := False; + end Deallocate_Resources; + + + if not (Semaphore.Reraised_In_Procedure and + Semaphore.Reraised_In_Function and + Semaphore.Handled_In_Procedure_Caller and + Semaphore.Handled_In_Function_Caller) + then -- Incorrect excpt. handling + Report.Failed -- in protected operations. + ("Improper exception handling/reraising by protected operations"); + end if; + + exception + + when others => + Report.Failed ("Unexpected exception " & + " raised and propagated in test"); + end Test_Block; + + Report.Result; + + + end CB20006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20007.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- CB20007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions are raised and can be directly propagated to + -- the calling unit by protected operations. + -- + -- TEST DESCRIPTION: + -- Declare a package with a protected type, including protected operation + -- declarations and private data, simulating a counting semaphore. + -- In the main procedure, perform calls on protected operations + -- of the protected object designed to induce the raising of exceptions. + -- + -- The exceptions raised are to be propagated directly from the protected + -- operations to the calling unit. + -- + -- Ensure that the exceptions are raised and correctly propagated directly + -- to the calling unit from protected procedures and functions. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CB20007_0 is -- Package Semaphore. + + Handled_In_Function_Caller, + Handled_In_Procedure_Caller : Boolean := False; + + Resource_Overflow, + Resource_Underflow : exception; + + protected type Counting_Semaphore (Max_Resources : Integer) is + procedure Secure; + function Resource_Limit_Exceeded return Boolean; + procedure Release; + private + Count : Integer := Max_Resources; + end Counting_Semaphore; + + end CB20007_0; + + --=================================================================-- + + with Report; + + package body CB20007_0 is -- Package Semaphore. + + protected body Counting_Semaphore is + + procedure Secure is + begin + if (Count = 0) then -- No resources left to secure. + raise Resource_Underflow; + Report.Failed ("Program control not transferred by raise"); + else + Count := Count - 1; -- Available resources decremented. + end if; + -- No exception handlers here, direct propagation to calling unit. + end Secure; + + + function Resource_Limit_Exceeded return Boolean is + begin + if (Count > Max_Resources) then + raise Resource_Overflow; -- Exception used as control flow + -- mechanism. + Report.Failed ("Program control not transferred by raise"); + else + return (False); + end if; + -- No exception handlers here, direct propagation to calling unit. + end Resource_Limit_Exceeded; + + + procedure Release is + begin + Count := Count + 1; -- Count of resources available + -- incremented. + if Resource_Limit_Exceeded then -- Call to protected operation + Count := Count - 1; -- function that raises an + -- exception. + Report.Failed("Resource limit exceeded"); + end if; + -- No exception handler here for exception raised in function. + -- Exception will propagate directly to calling unit. + end Release; + + + end Counting_Semaphore; + + end CB20007_0; + + + --=================================================================-- + + + with CB20007_0; -- Package Semaphore. + with Report; + + procedure CB20007 is + begin + + Test_Block: + declare + + package Semaphore renames CB20007_0; + + Total_Resources_Available : constant := 1; + + Resources : Semaphore.Counting_Semaphore (Total_Resources_Available); + -- An object of protected type. + + begin + + Report.Test ("CB20007", "Check that exceptions are raised and can " & + "be directly propagated to the calling unit " & + "by protected operations" ); + + Allocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin -- Force exception. + for I in 1..Loop_Count loop + Resources.Secure; + end loop; + Report.Failed ("Exception not propagated from protected " & + " operation in Allocate_Resources"); + exception + when Semaphore.Resource_Underflow => -- Exception prop. + Semaphore.Handled_In_Procedure_Caller := True; -- from protected + -- procedure. + when others => + Report.Failed ("Unknown exception during resource allocation"); + end Allocate_Resources; + + + Deallocate_Resources: + declare + Loop_Count : Integer := Total_Resources_Available + 1; + begin -- Force exception. + for I in 1..Loop_Count loop + Resources.Release; + end loop; + Report.Failed ("Exception not propagated from protected " & + "operation in Deallocate_Resources"); + exception + when Semaphore.Resource_Overflow => -- Exception prop + Semaphore.Handled_In_Function_Caller := True; -- from protected + -- function. + when others => + Report.Failed ("Exception raised during resource deallocation"); + end Deallocate_Resources; + + + if not (Semaphore.Handled_In_Procedure_Caller and -- Incorrect exception + Semaphore.Handled_In_Function_Caller) -- handling in + then -- protected ops. + Report.Failed + ("Improper exception propagation by protected operations"); + end if; + + exception + + when others => + Report.Failed ("Unexpected exception " & + " raised and propagated in test"); + end Test_Block; + + + Report.Result; + + end CB20007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + -- CB2004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A PREDEFINED OR A PROGRAMMER DEFINED EXCEPTION + -- RAISED SEVERAL LEVELS INSIDE A HIERARCHY OF NESTED BLOCKS + -- CAN BE SUCCESSFULLY HANDLED IN AN OUTER BLOCK. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- DCB 5/12/80 + -- JRK 11/17/80 + -- SPS 11/2/82 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE CB2004A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + + E1, E2, E3 : EXCEPTION; + + BEGIN + TEST("CB2004A","CHECK THAT EXCEPTIONS RAISED INSIDE NESTED " & + "BLOCKS CAN BE HANDLED IN OUTER BLOCKS"); + + BEGIN + + -- PROGRAMMER-DEFINED EXCEPTION, SINGLE EXCEPTON_CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #1"); + + EXCEPTION + WHEN E2 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #1"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #1"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PROGRAMMER-DEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E2; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #2"); + + EXCEPTION + WHEN E1 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #2"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E1 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #2"); + END; + + EXCEPTION + WHEN E3 => + FAILED("WRONG EXCEPTION HANDLED #2A"); + WHEN E1 | E2 | CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PROGRAMMER-DEFINED EXCEPTION, 'OTHERS' CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("PROGRAMMER-DEFINED EXCEPTION " & + "NOT RAISED #3"); + + EXCEPTION + WHEN E2 | E3 => + FAILED("WRONG PROGRAMMER-" & + "DEFINED EXCEPTION HANDLED #3"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR | + PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #3"); + END; + + EXCEPTION + WHEN E2 | CONSTRAINT_ERROR => + FAILED("WRONG EXCEPTION HANDLED #3A"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, SINGLE EXCEPTION_CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #4"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #4"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #4"); + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, MULTIPLE EXCEPTION_CHOICES. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #5"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + "EXCEPTION HANDLED #5"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | + STORAGE_ERROR | TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #5"); + END; + + EXCEPTION + WHEN E1 | E2 => + FAILED("WRONG EXCEPTION HANDLED #5A"); + WHEN CONSTRAINT_ERROR | E3 => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + -- PREDEFINED EXCEPTION, 'OTHERS' CHOICE. + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("PREDEFINED EXCEPTION NOT RAISED #6"); + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("WRONG " & + " EXCEPTION HANDLED #6"); + END; + + EXCEPTION + WHEN PROGRAM_ERROR | STORAGE_ERROR | + TASKING_ERROR => + FAILED("WRONG PREDEFINED " & + "EXCEPTION HANDLED #6"); + END; + + EXCEPTION + WHEN E1 => + FAILED("WRONG EXCEPTION HANDLED #6A"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + END; + + EXCEPTION + WHEN E1 | E2 | E3 => + FAILED("PROGRAMMER-DEFINED EXCEPTION HANDLED IN" & + "WRONG SCOPE"); + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR HANDLED IN WRONG SCOPE"); + WHEN OTHERS => + FAILED("OTHER EXCEPTIONS HANDLED IN WRONG SCOPE"); + END; + + IF FLOW_COUNT /= 12 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + END CB2004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2005a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CB2005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A RETURN STATEMENT CAN APPEAR IN AN EXCEPTION HANDLER + -- AND IT CAUSES CONTROL TO LEAVE THE SUBPROGRAM, FOR BOTH + -- FUNCTIONS AND PROCEDURES. + + -- DAT 4/13/81 + -- JRK 4/24/81 + -- SPS 10/26/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CB2005A IS + + I : INTEGER RANGE 0 .. 1; + + FUNCTION SETI RETURN INTEGER IS + BEGIN + I := I + 1; + FAILED ("CONSTRAINT_ERROR NOT RAISED 1"); + RETURN 0; + EXCEPTION + WHEN OTHERS => + RETURN I; + FAILED ("FUNCTION RETURN STMT DID NOT RETURN"); + RETURN 0; + END SETI; + + PROCEDURE ISET IS + BEGIN + I := 2; + FAILED ("CONSTRAINT_ERROR NOT RAISED 2"); + I := 0; + EXCEPTION + WHEN OTHERS => + RETURN; + FAILED ("PROCEDURE RETURN STMT DID NOT RETURN"); + END ISET; + + BEGIN + TEST ("CB2005A", "RETURN IN EXCEPTION HANDLERS"); + + I := 1; + IF SETI /= 1 THEN + FAILED ("WRONG VALUE RETURNED 1"); + END IF; + + I := 1; + ISET; + IF I /= 1 THEN + FAILED ("WRONG VALUE RETURNED 2"); + END IF; + + RESULT; + END CB2005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2006a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CB2006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT LOCAL VARIABLES AND PARAMETERS OF A SUBPROGRAM, + -- OR PACKAGE ARE ACCESSIBLE WITHIN A HANDLER. + + -- DAT 4/13/81 + -- SPS 3/23/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CB2006A IS + + I : INTEGER RANGE 0 .. 1; + + PACKAGE P IS + V2 : INTEGER := 2; + END P; + + PROCEDURE PR (J : IN OUT INTEGER) IS + K : INTEGER := J; + BEGIN + I := K; + FAILED ("CONSTRAINT_ERROR NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => + J := K + 1; + END PR; + + PACKAGE BODY P IS + L : INTEGER := 2; + BEGIN + TEST ("CB2006A", "LOCAL VARIABLES ARE ACCESSIBLE IN" + & " HANDLERS"); + + I := 1; + I := I + 1; + FAILED ("CONSTRAINT_ERROR NOT RAISED 2"); + EXCEPTION + WHEN OTHERS => + PR (L); + IF L /= V2 + 1 THEN + FAILED ("WRONG VALUE IN LOCAL VARIABLE"); + END IF; + END P; + BEGIN + + RESULT; + END CB2006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb2007a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CB2007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXIT STATEMENT IN A HANDLER CAN TRANSFER CONTROL + -- OUT OF A LOOP. + + -- DAT 4/13/81 + -- RM 4/30/81 + -- SPS 3/23/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CB2007A IS + BEGIN + TEST ("CB2007A", "EXIT STATEMENTS IN EXCEPTION HANDLERS"); + + DECLARE + FLOW_INDEX : INTEGER := 0 ; + BEGIN + + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT; + END; + FAILED ("WRONG CONTROL FLOW 2"); + EXIT; + END LOOP; + + FOR AAA IN 1..1 LOOP + FOR BBB IN 1..1 LOOP + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW A1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT; + END; + FAILED ("WRONG CONTROL FLOW A2"); + EXIT; + END LOOP; + + FLOW_INDEX := FLOW_INDEX + 1 ; + END LOOP; + END LOOP; + + LOOP1 : + FOR AAA IN 1..1 LOOP + LOOP2 : + FOR BBB IN 1..1 LOOP + LOOP3 : + FOR I IN 1 .. 10 LOOP + BEGIN + IF I = 1 THEN + RAISE CONSTRAINT_ERROR; + END IF; + FAILED ("WRONG CONTROL FLOW B1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => EXIT LOOP2 ; + END; + FAILED ("WRONG CONTROL FLOW B2"); + EXIT LOOP2 ; + END LOOP LOOP3 ; + + FAILED ("WRONG CONTROL FLOW B3"); + END LOOP LOOP2 ; + + FLOW_INDEX := FLOW_INDEX + 1 ; + END LOOP LOOP1 ; + + IF FLOW_INDEX /= 2 THEN FAILED( "WRONG FLOW OF CONTROL" ); + END IF; + + END ; + + RESULT; + END CB2007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb20a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb20a02.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- CB20A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the name and pertinent information about a user defined + -- exception are available to an enclosing program unit even when the + -- enclosing unit has no visibility into the scope where the exception + -- is declared and raised. + -- + -- TEST DESCRIPTION: + -- Declare a subprogram nested within the test subprogram. The enclosing + -- subprogram does not have visibility into the nested subprogram. + -- Declare and raise an exception in the nested subprogram, and allow + -- the exception to propagate to the enclosing scope. Use the function + -- Exception_Name in the enclosing subprogram to produce exception + -- specific information when the exception is handled in an others + -- handler. + -- + -- TEST FILES: + -- + -- This test depends on the following foundation code file: + -- FB20A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FB20A00; -- Package containing Function Find + with Ada.Exceptions; + with Report; + + procedure CB20A02 is + + Seed_Number : Integer; + Random_Number : Integer := 0; + + --=================================================================-- + + function Random_Number_Generator (Seed : Integer) return Integer is + + Result : Integer := 0; + + HighSeedError, + Mid_Seed_Error, + L_o_w_S_e_e_d_E_r_r_o_r : exception; + + begin -- Random_Number_Generator + + + if (Report.Ident_Int (Seed) > 1000) then + raise HighSeedError; + elsif (Report.Ident_Int (Seed) > 100) then + raise Mid_Seed_Error; + elsif (Report.Ident_Int (Seed) > 10) then + raise L_o_w_S_e_e_d_E_r_r_o_r; + else + Seed_Number := ((Seed_Number * 417) + 231) mod 53; + Result := Seed_Number / 52; + end if; + + return Result; + + end Random_Number_Generator; + + --=================================================================-- + + begin + + Report.Test ("CB20A02", "Check that the name " & + "of a user defined exception is available " & + "to an enclosing program unit even when the " & + "enclosing unit has no visibility into the " & + "scope where the exception is declared and " & + "raised" ); + + High_Seed: + begin + -- This seed value will result in the raising of a HighSeedError + -- exception. + Seed_Number := 1001; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in High_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "HighSeedError") + then + Report.Failed ("Expected HighSeedError, but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end High_Seed; + + + Mid_Seed: + begin + -- This seed value will generate a Mid_Seed_Error exception. + Seed_Number := 101; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in Mid_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "Mid_Seed_Error") + then + Report.Failed ("Expected Mid_Seed_Error, but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end Mid_Seed; + + + Low_Seed: + begin + -- This seed value will result in the raising of a + -- L_o_w_S_e_e_d_E_r_r_o_r exception. + Seed_Number := 11; + Random_Number := Random_Number_Generator (Seed_Number); + Report.Failed ("Exception not raised in Low_Seed block"); + exception + when Error : others => + if not FB20A00.Find (Ada.Exceptions.Exception_Name (Error), + "L_o_w_S_e_e_d_E_r_r_o_r") + then + Report.Failed ("Expected L_o_w_S_e_e_d_E_r_r_o_r but found " & + Ada.Exceptions.Exception_Name (Error)); + end if; + end Low_Seed; + + + Report.Result; + + end CB20A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3003a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CB3003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NON-SPECIFIC RAISE STATEMENT PROPAGATES THE EXCEPTION + -- FOR FURTHER PROCESSING(HANDLING) IN ANOTHER HANDLER. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- DCB 04/01/80 + -- JRK 11/19/80 + -- SPS 11/2/82 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE CB3003A IS + + USE REPORT; + + FLOW_COUNT : INTEGER := 0; + E1,E2 : EXCEPTION; + + BEGIN + TEST("CB3003A","CHECK THAT THE NON-SPECIFIC RAISE STATEMENT" & + " PROPAGATES THE ERROR FOR FURTHER HANDLING IN ANOTHER" & + " HANDLER"); + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 1)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 1; " & + "INNER)"); + END; + + EXCEPTION + -- A HANDLER SPECIFIC TO THE RAISED EXCEPTION (E1). + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 1; OUTER)"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED (CASE 1)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 1)"); + END; + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 2)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 2; " & + "INNER)"); + END; + + EXCEPTION + -- A HANDLER FOR SEVERAL EXCEPTIONS INCLUDING THE ONE RAISED. + WHEN CONSTRAINT_ERROR => + FAILED("WRONG EXCEPTION RAISED (CONSTRAINT_ERROR)"); + WHEN E2 => + FAILED("WRONG EXCEPTION RAISED (E2)"); + WHEN PROGRAM_ERROR | E1 | TASKING_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 2; OUTER)"); + WHEN STORAGE_ERROR => + FAILED("WRONG EXCEPTION RAISED (STORAGE_ERROR)"); + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED (OTHERS)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 2)"); + END; + + ------------------------------------------------------- + + BEGIN + BEGIN + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("EXCEPTION NOT RAISED (CASE 3)"); + EXCEPTION + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 3; " & + "INNER)"); + END; + + EXCEPTION + -- A NON-SPECIFIC HANDLER. + WHEN CONSTRAINT_ERROR | E2 => + FAILED("WRONG EXCEPTION RAISED " & + "(CONSTRAINT_ERROR | E2)"); + WHEN OTHERS => + FLOW_COUNT := FLOW_COUNT + 1; + RAISE; + FAILED("EXCEPTION NOT RERAISED (CASE 3; OUTER)"); + END; + + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("WRONG EXCEPTION PASSED (CASE 3)"); + END; + + ------------------------------------------------------- + + IF FLOW_COUNT /= 12 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + END CB3003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3003b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CB3003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A NON-EXPLICIT RAISE STATEMENT MAY APPEAR IN A BLOCK + -- STATEMENT WITHIN AN EXCEPTION HANDLER; IF THE BLOCK STATEMENT + -- INCLUDES A HANDLER FOR THE CURRENT EXCEPTION, THEN THE INNER + -- HANDLER RECEIVES CONTROL. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- L.BROWN 10/08/86 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + + PROCEDURE CB3003B IS + + MY_ERROR : EXCEPTION; + + BEGIN + TEST("CB3003B","A NON-EXPLICIT RAISE STATEMENT MAY APPEAR IN A "& + "BLOCK STATEMENT WITHIN AN EXCEPTION HANDLER"); + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 1"); + EXCEPTION + WHEN MY_ERROR => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 2"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 1"); + END; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 2"); + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 1"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 1"); + END; + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR | MY_ERROR | TASKING_ERROR => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 4"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 3"); + END; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 4"); + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 2"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 2"); + END; + + BEGIN + BEGIN + IF EQUAL(3,3) THEN + RAISE MY_ERROR; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 5"); + EXCEPTION + WHEN OTHERS => + BEGIN + IF EQUAL(3,3) THEN + RAISE; + END IF; + FAILED("MY_ERROR WAS NOT RAISED 6"); + EXCEPTION + WHEN MY_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED 5"); + END; + END; + EXCEPTION + WHEN MY_ERROR => + FAILED("CONTROL PASSED TO OUTER HANDLER 3"); + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED 3"); + END; + + RESULT; + + END CB3003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb3004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- CB3004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN AN INNER UNIT REDECLARES AN EXCEPTION NAME + -- THE HIDDEN DEFINITION IS STILL AVAILABLE FOR USE. + + -- NOTE : WE ASSUME FUNCTIONS ACT LIKE PROCEDURES AND + -- THAT UNITS, BLOCKS, AND PROCEDURES ACT THE SAME + -- IN OTHER CONTEXTS (E.G. TASKS AND PACKAGES). + + -- DCB 6/2/80 + -- JRK 11/19/80 + -- SPS 3/24/83 + + WITH REPORT; + PROCEDURE CB3004A IS + + USE REPORT; + + E1 : EXCEPTION; + FLOW_COUNT : INTEGER := 0; + + PROCEDURE P1 IS + E1, E2 : EXCEPTION; + + PROCEDURE P2 IS + E1 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE E1; + FAILED("E1 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN P1.E1 => + FAILED("P1.E1 EXCEPTION RAISED WHEN " & + "(P2)E1 EXPECTED"); + WHEN E1 => + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE P1.E1; + FAILED("P1.E1 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN E1 => + FAILED("(P2)E1 EXCEPTION RAISED WHEN" & + " P1.E1 EXPECTED"); + WHEN P1.E1 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN P1.E1 " & + "EXPECTED"); + END; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN (P2)E1 EXPECTED"); + END P2; + + PROCEDURE P3 IS + CONSTRAINT_ERROR : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE CONSTRAINT_ERROR; + FAILED("CONSTRAINT_ERROR EXCEPTION NOT RAISED"); + EXCEPTION + WHEN STANDARD.CONSTRAINT_ERROR => + FAILED("STANDARD.CONSTRAINT_ERROR EXCEPTION " & + "RAISED WHEN " & + "(P3)CONSTRAINT_ERROR EXPECTED"); + WHEN CONSTRAINT_ERROR => + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE STANDARD.CONSTRAINT_ERROR; + FAILED("STANDARD.CONSTRAINT_ERROR " & + "EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED("(P3)CONSTRAINT_ERROR " & + "EXCEPTION RAISED WHEN " & + "STANDARD.CONSTRAINT_ERROR " & + "EXPECTED"); + WHEN STANDARD.CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN " & + "STANDARD.CONSTRAINT_ERROR " & + "EXPECTED"); + END; + WHEN OTHERS => + FAILED("OTHERS RAISED WHEN " & + "(P3)CONSTRAINT_ERROR EXPECTED"); + END P3; + + PROCEDURE P4 IS + E2 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 1; + RAISE P1.E2; + FAILED("P1.E2 EXCEPTION NOT RAISED"); + EXCEPTION + WHEN E2 => + FAILED("(P4).E2 RAISED WHEN P1.E2 EXPECTED"); + END P4; + + BEGIN -- P1 + P2; + P3; + P4; + FAILED("P1.E2 EXCEPTION NOT PROPAGATED FROM P4"); + EXCEPTION + WHEN E2 => + FLOW_COUNT := FLOW_COUNT + 1; + WHEN OTHERS => + FAILED("EXCEPTION RAISED WHERE NONE EXPECTED"); + END P1; + + BEGIN + TEST("CB3004A","CHECK THAT WHEN EXCEPTION NAMES" & + " ARE REDECLARED THE HIDDEN DEFINITION IS STILL AVAILABLE"); + + P1; + + IF FLOW_COUNT /= 8 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + END CB3004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40005.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,339 ---- + -- CB40005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that exceptions raised in non-generic code can be handled by + -- a procedure in a generic package. Check that the exception identity + -- can be properly retrieved from the generic code and used by the + -- non-generic code. + -- + -- TEST DESCRIPTION: + -- This test models a possible usage paradigm for the type: + -- Ada.Exceptions.Exception_Occurrence. + -- + -- A generic package takes access to procedure types (allowing it to + -- be used at any accessibility level) and defines a "fail soft" + -- procedure that takes designators to a procedure to call, a + -- procedure to call in the event that it fails, and a function to + -- call to determine the next action. + -- + -- In the event an exception occurs on the call to the first procedure, + -- the exception is stored in a stack; along with the designator to the + -- procedure that caused it; allowing the procedure to be called again, + -- or the exception to be re-raised. + -- + -- A full implementation of such a tool would use a more robust storage + -- mechanism, and would provide a more flexible interface. + -- + -- + -- CHANGE HISTORY: + -- 29 MAR 96 SAIC Initial version + -- 12 NOV 96 SAIC Revised for 2.1 release + -- + --! + + ----------------------------------------------------------------- CB40005_0 + + with Ada.Exceptions; + generic + type Proc_Pointer is access procedure; + type Func_Pointer is access function return Proc_Pointer; + package CB40005_0 is -- Fail_Soft + + + procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; + Proc_To_Call_On_Exception : Proc_Pointer := null; + Retry_Routine : Func_Pointer := null ); + + function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence; + + function Top_Event_Procedure return Proc_Pointer; + + procedure Pop_Event; + + function Event_Stack_Size return Natural; + + end CB40005_0; -- Fail_Soft + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CB40005_0 + + with Report; + package body CB40005_0 is + + type History_Event is record + Exception_Event : Ada.Exceptions.Exception_Occurrence_Access; + Procedure_Called : Proc_Pointer; + end record; + + procedure Store_Event( Proc_Called : Proc_Pointer; + Error : Ada.Exceptions.Exception_Occurrence ); + + procedure Fail_Soft_Call( Proc_To_Call : Proc_Pointer; + Proc_To_Call_On_Exception : Proc_Pointer := null; + Retry_Routine : Func_Pointer := null ) is + + Current_Proc_To_Call : Proc_Pointer := Proc_To_Call; + + begin + while Current_Proc_To_Call /= null loop + begin + Current_Proc_To_Call.all; -- call procedure through pointer + Current_Proc_To_Call := null; + exception + when Capture: others => + Store_Event( Current_Proc_To_Call, Capture ); + if Proc_To_Call_On_Exception /= null then + Proc_To_Call_On_Exception.all; + end if; + if Retry_Routine /= null then + Current_Proc_To_Call := Retry_Routine.all; + else + Current_Proc_To_Call := null; + end if; + end; + end loop; + end Fail_Soft_Call; + + Stack : array(1..10) of History_Event; -- minimal, sufficient for testing + + Stack_Top : Natural := 0; + + procedure Store_Event( Proc_Called : Proc_Pointer; + Error : Ada.Exceptions.Exception_Occurrence ) + is + begin + Stack_Top := Stack_Top +1; + Stack(Stack_Top) := ( Ada.Exceptions.Save_Occurrence(Error), + Proc_Called ); + end Store_Event; + + function Top_Event_Exception return Ada.Exceptions.Exception_Occurrence is + begin + if Stack_Top > 0 then + return Stack(Stack_Top).Exception_Event.all; + else + return Ada.Exceptions.Null_Occurrence; + end if; + end Top_Event_Exception; + + function Top_Event_Procedure return Proc_Pointer is + begin + if Stack_Top > 0 then + return Stack(Stack_Top).Procedure_Called; + else + return null; + end if; + end Top_Event_Procedure; + + procedure Pop_Event is + begin + if Stack_Top > 0 then + Stack_Top := Stack_Top -1; + else + Report.Failed("Stack Error"); + end if; + end Pop_Event; + + function Event_Stack_Size return Natural is + begin + return Stack_Top; + end Event_Stack_Size; + + end CB40005_0; + + ------------------------------------------------------------------- CB40005 + + with Report; + with TCTouch; + with CB40005_0; + with Ada.Exceptions; + procedure CB40005 is + + type Proc_Pointer is access procedure; + type Func_Pointer is access function return Proc_Pointer; + + package Fail_Soft is new CB40005_0(Proc_Pointer, Func_Pointer); + + procedure Cause_Standard_Exception; + + procedure Cause_Visible_Exception; + + procedure Cause_Invisible_Exception; + + Exception_Procedure_Pointer : Proc_Pointer; + + Visible_Exception : exception; + + procedure Action_On_Exception; + + function Retry_Procedure return Proc_Pointer; + + Raise_Error : Boolean; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + procedure Cause_Standard_Exception is + begin + TCTouch.Touch('S'); --------------------------------------------------- S + if Raise_Error then + raise Constraint_Error; + end if; + end Cause_Standard_Exception; + + procedure Cause_Visible_Exception is + begin + TCTouch.Touch('V'); --------------------------------------------------- V + if Raise_Error then + raise Visible_Exception; + end if; + end Cause_Visible_Exception; + + procedure Cause_Invisible_Exception is + Invisible_Exception : exception; + begin + TCTouch.Touch('I'); --------------------------------------------------- I + if Raise_Error then + raise Invisible_Exception; + end if; + end Cause_Invisible_Exception; + + procedure Action_On_Exception is + begin + TCTouch.Touch('A'); --------------------------------------------------- A + end Action_On_Exception; + + function Retry_Procedure return Proc_Pointer is + begin + TCTouch.Touch('R'); --------------------------------------------------- R + return Action_On_Exception'Access; + end Retry_Procedure; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + begin -- Main test procedure. + + Report.Test ("CB40005", "Check that exceptions raised in non-generic " & + "code can be handled by a procedure in a generic " & + "package. Check that the exception identity can " & + "be properly retrieved from the generic code and " & + "used by the non-generic code" ); + + -- first, check that the no exception cases cause no action on the stack + Raise_Error := False; + + Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S + + Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V + Action_On_Exception'Access, + Retry_Procedure'Access ); + + Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I + null, + Retry_Procedure'Access ); + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Empty stack"); + + TCTouch.Validate( "SVI", "Non error case check" ); + + -- second, check that error cases add to the stack + Raise_Error := True; + + Fail_Soft.Fail_Soft_Call( Cause_Standard_Exception'Access ); -- S + + Fail_Soft.Fail_Soft_Call( Cause_Visible_Exception'Access, -- V + Action_On_Exception'Access, -- A + Retry_Procedure'Access ); -- RA + + Fail_Soft.Fail_Soft_Call( Cause_Invisible_Exception'Access, -- I + null, + Retry_Procedure'Access ); -- RA + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 3, "Stack = 3"); + + TCTouch.Validate( "SVARAIRA", "Error case check" ); + + -- check that the exceptions and procedure were stored correctly + -- on the stack + Raise_Error := False; + + -- return procedure pointer from top of stack and call the procedure + -- through that pointer: + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "I", "Invisible case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("1: Exception not raised"); + exception + when Constraint_Error => Report.Failed("1: Raised Constraint_Error"); + when Visible_Exception => Report.Failed("1: Raised Visible_Exception"); + when others => null; -- expected case + end; + + Fail_Soft.Pop_Event; + + -- return procedure pointer from top of stack and call the procedure + -- through that pointer: + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "V", "Visible case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("2: Exception not raised"); + exception + when Constraint_Error => Report.Failed("2: Raised Constraint_Error"); + when Visible_Exception => null; -- expected case + when others => Report.Failed("2: Raised Invisible_Exception"); + end; + + Fail_Soft.Pop_Event; + + Fail_Soft.Top_Event_Procedure.all; + + TCTouch.Validate( "S", "Standard case unwind" ); + + begin + Ada.Exceptions.Raise_Exception( + Ada.Exceptions.Exception_Identity(Fail_Soft.Top_Event_Exception) ); + Report.Failed("3: Exception not raised"); + exception + when Constraint_Error => null; -- expected case + when Visible_Exception => Report.Failed("3: Raised Visible_Exception"); + when others => Report.Failed("3: Raised Invisible_Exception"); + end; + + Fail_Soft.Pop_Event; + + TCTouch.Assert( Fail_Soft.Event_Stack_Size = 0, "Stack empty after pops"); + + Report.Result; + + end CB40005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4001a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- CB4001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ANY EXCEPTION RAISED IN THE STATEMENT SEQUENCE OF A + -- SUBPROGRAM IS PROPAGATED TO THE CALLER OF THE SUBPROGRAM, NOT TO THE + -- STATICALLY ENCLOSING LEXICAL ENVIRONMENT. + + -- RM 05/30/80 + -- JRK 11/19/80 + -- SPS 03/28/83 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + + WITH REPORT; + PROCEDURE CB4001A IS + + USE REPORT; + + E1 : EXCEPTION; + I9 : INTEGER RANGE 1..10 ; + FLOW_COUNT : INTEGER := 0 ; + + BEGIN + TEST("CB4001A","CHECK THAT ANY EXCEPTION RAISED IN THE " & + "STATEMENT SEQUENCE OF A SUBPROGRAM IS " & + "PROPAGATED TO THE CALLER, NOT TO THE STATICALLY ENCLOSING" & + " LEXICAL ENVIRONMENT"); + + BEGIN -- BLOCK WITH HANDLERS; LEX. ENVIRONMT FOR ALL PROC.DEFS + + DECLARE -- BLOCK WITH PROCEDURE DEFINITIONS + + PROCEDURE CALLEE1 ; + PROCEDURE CALLEE2 ; + PROCEDURE CALLEE3 ; + PROCEDURE R ; + PROCEDURE S ; + + PROCEDURE CALLER1 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE1 ; + FAILED("EXCEPTION NOT RAISED (CALLER1)"); + EXCEPTION + WHEN E1 => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLER2 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE2 ; + FAILED("EXCEPTION NOT RAISED (CALLER2)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLER3 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + CALLEE3 ; + FAILED("EXCEPTION NOT RAISED (CALLER3)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FLOW_COUNT := FLOW_COUNT + 1 ; + END ; + + PROCEDURE CALLEE1 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + R ; + FAILED("EXCEPTION NOT RAISED (CALLEE1)"); + END ; + + PROCEDURE CALLEE2 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + RAISE CONSTRAINT_ERROR ; + FAILED("EXCEPTION NOT RAISED (CALLEE2)"); + EXCEPTION + WHEN PROGRAM_ERROR => + FAILED("WRONG EXCEPTION RAISED (CALLEE2)"); + END ; + + PROCEDURE CALLEE3 IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 1 ; + I9 := IDENT_INT(20) ; + FAILED("EXCEPTION NOT RAISED (CALLEE3)"); + END ; + + PROCEDURE R IS + E2 : EXCEPTION; + BEGIN + FLOW_COUNT := FLOW_COUNT + 10 ; + S ; + FAILED("EXCEPTION E1 NOT RAISED (PROC R)"); + EXCEPTION + WHEN E2 => + FAILED("WRONG EXCEPTION RAISED (PROC R)"); + END ; + + PROCEDURE S IS + BEGIN + FLOW_COUNT := FLOW_COUNT + 10 ; + RAISE E1 ; + FAILED("EXCEPTION E1 NOT RAISED (PROC S)"); + END ; + + BEGIN -- (THE BLOCK WITH PROC. DEFS) + + CALLER1; + CALLER2; + CALLER3; + + END ; -- (THE BLOCK WITH PROC. DEFS) + + EXCEPTION + + WHEN OTHERS => + FAILED("EXCEPTION PROPAGATED STATICALLY"); + + END ; + + IF FLOW_COUNT /= 29 THEN + FAILED("INCORRECT FLOW_COUNT VALUE"); + END IF; + + RESULT; + END CB4001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4002a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- CB4002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXCEPTIONS RAISED DURING ELABORATION OF THE + -- DECLARATIVE PART OF A SUBPROGRAM ARE PROPAGATED TO THE + -- CALLER, FOR CONSTRAINT_ERROR CAUSED BY INITIALIZATION, + -- AND CONSTRAINT ELABORATION, AND FOR FUNCTION EVALUATIONS + -- RAISING CONSTRAINT_ERROR AND A PROGRAMMER-DEFINED EXCEPTION. + + -- DAT 4/13/81 + -- SPS 3/28/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CB4002A IS + BEGIN + TEST("CB4002A", "EXCEPTIONS IN SUBPROGRAM DECLARATIVE_PARTS" + & " ARE PROPAGATED TO CALLER"); + + DECLARE + SUBTYPE I5 IS INTEGER RANGE -5 .. 5; + + E : EXCEPTION; + + FUNCTION RAISE_IT (I : I5) RETURN INTEGER IS + J : INTEGER RANGE 0 .. 1 := I; + BEGIN + IF I = 0 THEN + RAISE CONSTRAINT_ERROR; + ELSIF I = 1 THEN + RAISE E; + END IF; + FAILED ("EXCEPTION NOT RAISED 0"); + RETURN J; + EXCEPTION + WHEN OTHERS => + IF I NOT IN 0 .. 1 THEN + FAILED ("WRONG HANDLER 0"); + RETURN 0; + ELSE + RAISE; + END IF; + END RAISE_IT; + + PROCEDURE P1 (P : INTEGER) IS + Q : INTEGER := RAISE_IT (P); + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER 1"); + END P1; + + PROCEDURE P2 (P : INTEGER) IS + Q : I5 RANGE 0 .. P := 1; + BEGIN + IF P = 0 OR P > 5 THEN + FAILED ("EXCEPTION NOT RAISED 2"); + END IF; + END P2; + + BEGIN + + BEGIN + P1(-1); + FAILED ("EXCEPTION NOT RAISED 2A"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P1(0); + FAILED ("EXCEPTION NOT RAISED 3"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P1(1); + FAILED ("EXCEPTION NOT RAISED 4"); + EXCEPTION + WHEN E => NULL; + END; + + BEGIN + P2(0); + FAILED ("EXCEPTION NOT RAISED 5"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + BEGIN + P2(6); + FAILED ("EXCEPTION NOT RAISED 6"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + + EXCEPTION + WHEN OTHERS => FAILED ("WRONG EXCEPTION OR HANDLER"); + END; + + RESULT; + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER FOR SURE"); RESULT; + END CB4002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4003a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CB4003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EXCEPTIONS RAISED DURING ELABORATION OF PACKAGE + -- SPECIFICATIONS, OR DECLARATIVE_PARTS OF BLOCKS AND PACKAGE + -- BODIES, ARE PROPAGATED TO THE STATIC ENVIRONMENT. EXCEPTIONS + -- ARE CAUSED BY INITIALIZATIONS AND FUNCTION CALLS. + + -- HISTORY: + -- DAT 04/14/81 CREATED ORIGINAL TEST. + -- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + + WITH REPORT; USE REPORT; + + PROCEDURE CB4003A IS + + E : EXCEPTION; + + FUNCTION F (B : BOOLEAN) RETURN INTEGER IS + BEGIN + IF B THEN + RAISE E; + ELSE + RETURN 1; + END IF; + END F; + + BEGIN + TEST ("CB4003A", "CHECK THAT EXCEPTIONS DURING ELABORATION" + & " OF DECLARATIVE PARTS" + & " IN BLOCKS, PACKAGE SPECS, AND PACKAGE BODIES ARE" + & " PROPAGATED TO STATIC ENCLOSING ENVIRONMENT"); + + BEGIN + DECLARE + PACKAGE P1 IS + I : INTEGER RANGE 1 .. 1 := 2; + END P1; + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + IF NOT EQUAL(P1.I,P1.I) THEN + COMMENT ("NO EXCEPTION RAISED"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER 1"); + END; + FAILED ("EXCEPTION NOT RAISED 1A"); + EXCEPTION + WHEN CONSTRAINT_ERROR =>NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION 1"); + END; + + FOR L IN IDENT_INT(1) .. IDENT_INT(4) LOOP + BEGIN + DECLARE + PACKAGE P2 IS + PRIVATE + J : INTEGER RANGE 2 .. 4 := L; + END P2; + + Q : INTEGER := F(L = 3); + + PACKAGE BODY P2 IS + K : INTEGER := F(L = 2); + + BEGIN + IF NOT (EQUAL(J,J) OR EQUAL(K,K)) THEN + COMMENT("CAN'T OPTIMIZE THIS"); + END IF; + END P2; + BEGIN + IF L /= 4 THEN + FAILED ("EXCEPTION NOT RAISED 2"); + END IF; + + IF NOT EQUAL(Q,Q) THEN + COMMENT("CAN'T OPTIMIZE THIS"); + END IF; + + EXIT; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION HANDLER 2"); + EXIT; + END; + FAILED ("EXCEPTION NOT RAISED 2A"); + EXCEPTION + WHEN E | CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + END LOOP; + + RESULT; + + END CB4003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CB4004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT VARIOUS EXCEPTIONS IN THE BODY OF A SUBPROGRAM WITH + -- AN APPLICABLE HANDLER ARE HANDLED LOCALLY. + + -- DAT 04/15/81 + -- JRK 04/24/81 + -- SPS 11/02/82 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CB4004A IS + + E, F : EXCEPTION; + STORAGE_ERROR: EXCEPTION; + + I1 : INTEGER RANGE 1 .. 1; + + FUNCTION F1 (I : INTEGER) RETURN BOOLEAN IS + BEGIN + CASE I IS + WHEN 1 => RAISE E; + WHEN 2 => RAISE STORAGE_ERROR; + WHEN 3 => I1 := 4; + WHEN 4 => RAISE TASKING_ERROR; + WHEN OTHERS => NULL; + END CASE; + RETURN FALSE; + EXCEPTION + WHEN E | F => RETURN I = 1; + WHEN STORAGE_ERROR => RETURN I = 2; + WHEN PROGRAM_ERROR | CONSTRAINT_ERROR => + RETURN I = 3; + WHEN OTHERS => RETURN I = 4; + END F1; + + BEGIN + TEST ("CB4004A", "EXCEPTIONS WITH LOCAL HANDLERS ARE HANDLED" + & " THERE"); + + BEGIN + FOR L IN 1 .. 4 LOOP + IF F1(L) /= TRUE THEN + FAILED ("LOCAL EXCEPTIONS DON'T WORK"); + EXIT; + END IF; + END LOOP; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG HANDLER"); + END; + + RESULT; + END CB4004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4005a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CB4005A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT EXCEPTIONS PROPAGATED OUT OF A HANDLER ARE PROPAGATED + -- OUTSIDE THE ENCLOSING UNIT. + + -- DAT 4/15/81 + -- SPS 3/28/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CB4005A IS + + E , F : EXCEPTION; + + B : BOOLEAN := FALSE; + + PROCEDURE P IS + BEGIN + RAISE E; + EXCEPTION + WHEN F => FAILED ("WRONG HANDLER 1"); + WHEN E => + IF B THEN + FAILED ("WRONG HANDLER 2"); + ELSE + B := TRUE; + RAISE F; + END IF; + END P; + + BEGIN + TEST ("CB4005A", "EXCEPTIONS FROM HANDLERS ARE PROPAGATED " & + "OUTSIDE"); + + BEGIN + P; + FAILED ("EXCEPTION NOT PROPAGATED 1"); + EXCEPTION + WHEN F => NULL; + WHEN OTHERS => FAILED ("WRONG HANDLER 3"); + END; + + RESULT; + END CB4005A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4006a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- CB4006A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EXCEPTIONS IN A BLOCK IN A HANDLER + -- ARE HANDLED CORRECTLY. + + -- HISTORY: + -- DAT 04/15/81 + -- SPS 11/02/82 + -- JET 01/06/88 UPDATED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + -- JRL 05/28/92 CHANGED CODE IN PROGRAM_ERROR BLOCK TO + -- PREVENT OPTIMIZATION. + + WITH REPORT; + USE REPORT; + + PROCEDURE CB4006A IS + + I1 : INTEGER RANGE 1 .. 2 := 1; + + PROCEDURE P IS + BEGIN + IF EQUAL(3,3) THEN + RAISE PROGRAM_ERROR; + END IF; + EXCEPTION + WHEN PROGRAM_ERROR => + DECLARE + I : INTEGER RANGE 1 .. 1 := I1; + BEGIN + IF EQUAL(I,I) THEN + I := I1 + 1; + END IF ; + FAILED ("EXCEPTION NOT RAISED 1"); + + IF NOT EQUAL(I,I) THEN + COMMENT ("CAN'T OPTIMIZE THIS"); + END IF; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I1 /= 1 THEN + FAILED ("WRONG HANDLER 1"); + ELSE + I1 := I1 + 1; + END IF; + END; + WHEN CONSTRAINT_ERROR => + FAILED ("WRONG HANDLER 3"); + END P; + + BEGIN + TEST ("CB4006A", "CHECK THAT EXCEPTIONS IN BLOCKS IN " & + "HANDLERS WORK"); + + P; + IF IDENT_INT(I1) /= 2 THEN + FAILED ("EXCEPTION NOT HANDLED CORRECTLY"); + ELSE + BEGIN + P; + FAILED ("EXCEPTION NOT RAISED CORRECTLY 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + END; + END IF; + + RESULT; + + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER 2"); + RESULT; + + END CB4006A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4007a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CB4007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE STATEMENT PART OF A PACKAGE CAN RAISE, PROPAGATE, + -- AND HANDLE EXCEPTIONS. IF THE BODY'S HANDLERS HANDLE ALL + -- EXCEPTIONS RAISED AND DO NOT RAISE ANY UNHANDLED EXCEPTIONS, + -- NO EXCEPTION IS PROPAGATED. + + -- HISTORY: + -- DHH 03/28/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CB4007A IS + BEGIN + + TEST("CB4007A", "CHECK THAT THE STATEMENT PART OF A PACKAGE " & + "CAN RAISE, PROPAGATE, AND HANDLE EXCEPTIONS. " & + "IF THE BODY'S HANDLERS HANDLE ALL EXCEPTIONS " & + "RAISED AND DO NOT RAISE ANY UNHANDLED " & + "EXCEPTIONS, NO EXCEPTION IS PROPAGATED"); + DECLARE + + PACKAGE OUTSIDE IS + END OUTSIDE; + + PACKAGE BODY OUTSIDE IS + + BEGIN + DECLARE + PACKAGE HANDLER IS + END HANDLER; + + PACKAGE BODY HANDLER IS + BEGIN + DECLARE + PACKAGE PROPAGATE IS + END PROPAGATE; + + PACKAGE BODY PROPAGATE IS + BEGIN + DECLARE + PACKAGE RISE IS + END RISE; + + PACKAGE BODY RISE IS + BEGIN + RAISE CONSTRAINT_ERROR; + FAILED("EXCEPTION " & + "NOT RAISED"); + END RISE; + + BEGIN + NULL; + END; -- PACKAGE PROPAGATE DECLARE. + EXCEPTION + WHEN CONSTRAINT_ERROR => + RAISE CONSTRAINT_ERROR; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION " & + "RAISED IN PROPAGATE " & + "PACKAGE"); + END PROPAGATE; + + BEGIN + NULL; + END; -- PACKAGE HANDLER DECLARE. + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN " & + "HANDLER PACKAGE"); + END HANDLER; + + BEGIN + NULL; + END; -- PACKAGE OUTSIDE DECLARE. + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED IN OUTSIDE " & + "PACKAGE"); + END OUTSIDE; + BEGIN + NULL; + END; + + RESULT; + + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + END CB4007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4008a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- CB4008A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NESTED LAST WISHES EXCEPTION HANDLERS WORK + -- (FOR PROCEDURES). + + -- DAT 4/15/81 + -- SPS 3/28/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CB4008A IS + + C : INTEGER := 0; + + E : EXCEPTION; + + DEPTH : CONSTANT := 99; + + PROCEDURE F; + + PROCEDURE I IS + BEGIN + C := C + 1; + IF C >= DEPTH THEN + RAISE E; + END IF; + END I; + + PROCEDURE O IS + BEGIN + C := C - 1; + END O; + + PROCEDURE X IS + PROCEDURE X1 IS + PROCEDURE X2 IS + BEGIN + F; + END X2; + + PROCEDURE X3 IS + BEGIN + I; + X2; + EXCEPTION + WHEN E => O; RAISE; + END X3; + BEGIN + I; + X3; + EXCEPTION + WHEN E => O; RAISE; + END X1; + + PROCEDURE X1A IS + BEGIN + I; + X1; + FAILED ("INCORRECT EXECUTION SEQUENCE"); + EXCEPTION + WHEN E => O; RAISE; + END X1A; + BEGIN + I; + X1A; + EXCEPTION + WHEN E => O; RAISE; + END X; + + PROCEDURE Y IS + BEGIN + I; + X; + EXCEPTION WHEN E => O; RAISE; + END Y; + + PROCEDURE F IS + PROCEDURE F2; + + PROCEDURE F1 IS + BEGIN + I; + F2; + EXCEPTION WHEN E => O; RAISE; + END F1; + + PROCEDURE F2 IS + BEGIN + I; + Y; + EXCEPTION WHEN E => O; RAISE; + END F2; + BEGIN + I; + F1; + EXCEPTION WHEN E => O; RAISE; + END F; + + BEGIN + TEST ("CB4008A", "(PROCEDURE) LAST WISHES UNWIND PROPERLY"); + + BEGIN + I; + Y; + FAILED ("INCORRECT EXECUTION SEQUENCE 2"); + EXCEPTION + WHEN E => + O; + IF C /= 0 THEN + FAILED ("EXCEPTION HANDLER MISSED SOMEWHERE"); + END IF; + END; + + RESULT; + END CB4008A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4009a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + -- CB4009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A PROGRAMMER DEFINED EXCEPTION AND A REDECLARED + -- PREDEFINED EXCEPTION MAY BE PROPAGATED OUT OF SCOPE AND BACK IN, + -- WITH OUT-OF-SCOPE 'OTHERS' HANDLERS HANDLING THE EXCEPTION + -- INSTEAD OF OTHER HANDLERS. SEPARATELY COMPILED UNITS ARE NOT TESTED. + + -- DAT 4/15/81 + -- SPS 1/14/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CB4009A IS + + E : EXCEPTION; + + I : INTEGER := 0; + + PROCEDURE P1 (C : INTEGER); + PROCEDURE P2 (C : INTEGER); + PROCEDURE P3 (C : INTEGER); + + F : BOOLEAN := FALSE; + T : CONSTANT BOOLEAN := TRUE; + + PROCEDURE P1 (C : INTEGER) IS + BEGIN + P3(C); + EXCEPTION + WHEN E => F := T; + WHEN CONSTRAINT_ERROR => F := T; + WHEN OTHERS => I := I + 1; RAISE; + END P1; + + PROCEDURE P2 (C : INTEGER) IS + E : EXCEPTION; + CONSTRAINT_ERROR : EXCEPTION; + BEGIN + CASE C IS + WHEN 0 => FAILED ("WRONG CASE"); + WHEN 1 => RAISE E; + WHEN -1 => RAISE CONSTRAINT_ERROR; + WHEN OTHERS => P1 (C - C/ABS(C)); + END CASE; + EXCEPTION + WHEN E => + I := I + 100; RAISE; + WHEN CONSTRAINT_ERROR => + I := I + 101; RAISE; + WHEN OTHERS => + F := T; + END P2; + + PROCEDURE P3 (C : INTEGER) IS + BEGIN + P2(C); + EXCEPTION + WHEN E => F := T; + WHEN CONSTRAINT_ERROR => F := T; + END P3; + + BEGIN + TEST ("CB4009A", "EXCEPTIONS PROPAGATED OUT OF SCOPE"); + + I := 0; + BEGIN + P3 (-2); + FAILED ("EXCEPTION NOT RAISED 1"); + EXCEPTION + WHEN OTHERS => NULL; + END; + IF I /= 203 THEN + FAILED ("INCORRECT HANDLER SOMEWHERE 1"); + END IF; + + I := 0; + BEGIN + P3(3); + FAILED ("EXCEPTION NOT RAISED 2"); + EXCEPTION + WHEN OTHERS => NULL; + END; + IF I /= 302 THEN + FAILED ("INCORRECT HANDLER SOMEWHERE 2"); + END IF; + + IF F = T THEN + FAILED ("WRONG HANDLER SOMEWHERE"); + END IF; + + RESULT; + END CB4009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb4013a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- CB4013A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN UNHANDLED EXCEPTION RAISED IN A TASK BODY, BUT + -- OUTSIDE AN ACCEPT STATEMENT, RAISES NO EXCEPTION OUTSIDE THE + -- TASK. + + -- HISTORY: + -- DHH 03/29/88 CREATED ORIGINAL TEST. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CB4013A IS + + TASK TYPE CHOICE IS + ENTRY E1; + ENTRY STOP; + END CHOICE; + + T : CHOICE; + + TASK BODY CHOICE IS + BEGIN + ACCEPT E1; + IF EQUAL(3,3) THEN + RAISE CONSTRAINT_ERROR; + END IF; + ACCEPT STOP; + END CHOICE; + + BEGIN + + TEST("CB4013A", "CHECK THAT AN UNHANDLED EXCEPTION RAISED IN " & + "A TASK BODY, BUT OUTSIDE AN ACCEPT STATEMENT, " & + "RAISES NO EXCEPTION OUTSIDE THE TASK"); + + T.E1; + DELAY 1.0; + IF T'CALLABLE THEN + FAILED("TASK NOT COMPLETED ON RAISING CONSTRAINT_ERROR"); + T.STOP; + END IF; + + RESULT; + + EXCEPTION + WHEN TASKING_ERROR => + FAILED("TASKING_ERROR RAISED OUTSIDE TASK"); + RESULT; + + WHEN CONSTRAINT_ERROR => + FAILED("CONSTRAINT_ERROR PROPAGATED OUTSIDE TASK"); + RESULT; + + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + RESULT; + END CB4013A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a01.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CB40A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a user defined exception is correctly propagated out of + -- a public child package. + -- + -- TEST DESCRIPTION: + -- Declare a public child package containing a procedure used to + -- analyze the alphanumeric content of a particular text string. + -- The procedure contains a processing loop that continues until the + -- range of the text string is exceeded, at which time a user defined + -- exception is raised. This exception propagates out of the procedure + -- through the parent package, to the main test program. + -- + -- Exception Type Raised: + -- * User Defined + -- Predefined + -- + -- Hierarchical Structure Employed For This Test: + -- * Parent Package + -- * Public Child Package + -- Private Child Package + -- Public Child Subprogram + -- Private Child Subprogram + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- FB40A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + package FB40A00.CB40A01_0 is -- package Text_Parser.Processing + + procedure Process_Text (Text : in String_Pointer_Type); + + end FB40A00.CB40A01_0; + + + --=================================================================-- + + + with Report; + + package body FB40A00.CB40A01_0 is + + procedure Process_Text (Text : in String_Pointer_Type) is + Pos : Natural := Text'First - 1; + begin + loop -- Process string, raise exception upon completion. + Pos := Pos + 1; + if Pos > Text.all'Last then + raise Completed_Text_Processing; + elsif (Text.all (Pos) in 'A' .. 'Z') or + (Text.all (Pos) in 'a' .. 'z') or + (Text.all (Pos) in '0' .. '9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + -- No exception handler here, exception propagates. + Report.Failed ("No exception raised in child package subprogram"); + end Process_Text; + + end FB40A00.CB40A01_0; + + + --=================================================================-- + + + with FB40A00.CB40A01_0; + with Report; + + procedure CB40A01 is + + String_Pointer : FB40A00.String_Pointer_Type := + new String'("'Twas the night before Christmas, " & + "and all through the house..."); + + begin + + Process_Block: + begin + + Report.Test ("CB40A01", "Check that a user defined exception " & + "is correctly propagated out of a " & + "public child package"); + + FB40A00.CB40A01_0.Process_Text (String_Pointer); + + Report.Failed ("Exception should have been handled"); + + exception + + when FB40A00.Completed_Text_Processing => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 48 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + + end CB40A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a020.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- CB40A020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CB40A021.AM. + -- + -- TEST DESCRIPTION: + -- See CB40A021.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FB40A00.A + -- => CB40A020.A + -- CB40A021.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + + package FB40A00.CB40A020_0 is -- package Text_Parser.Processing + + function Count_AlphaNumerics (Text : in String) return Natural; + + end FB40A00.CB40A020_0; + + + --=================================================================-- + + + -- Text_Parser.Processing.Process_Text + with Report; + private procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String); + + procedure FB40A00.CB40A020_0.CB40A020_1 (Text : in String) is + Pos : Natural := Text'First - 1; + begin + loop -- Process string, raise exception upon completion. + Pos := Pos + 1; + if Pos > Text'Last then + raise Completed_Text_Processing; + elsif (Text (Pos) in 'A' .. 'Z') or + (Text (Pos) in 'a' .. 'z') or + (Text (Pos) in '0' .. '9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + -- No exception handler here, exception propagates. + Report.Failed ("No exception raised in child package subprogram"); + end FB40A00.CB40A020_0.CB40A020_1; + + + --=================================================================-- + + + with FB40A00.CB40A020_0.CB40A020_1; -- "with" of private child subprogram + -- Text_Parser.Processing.Process_Text + package body FB40A00.CB40A020_0 is + + function Count_AlphaNumerics (Text : in String) return Natural is + begin + FB40A00.CB40A020_0.CB40A020_1 (Text); -- Call prvt child proc. + return (AlphaNumeric_Count); -- Global maintained in parent. + -- No exception handler here, exception propagates. + end Count_AlphaNumerics; + + end FB40A00.CB40A020_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a021.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a021.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a021.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a021.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CB40A021.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a user defined exception is correctly propagated from a + -- private child subprogram to its parent and then to a client of the + -- parent. + -- + -- TEST DESCRIPTION: + -- Declare a child package containing a function. The body of the + -- function contains a call to a private child subprogram (child of + -- the child). The private child subprogram raises an exception + -- defined in the root ancestor package, and it is propagated to the + -- test program. + -- + -- Exception Type Raised: + -- * User Defined + -- Predefined + -- + -- Hierarchical Structure Employed For This Test: + -- * Parent Package + -- * Visible Child Package + -- Private Child Package + -- Visible Child Subprogram + -- * Private Child Subprogram + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FB40A00.A + -- CB40A020.A + -- => CB40A021.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + + with Report; + with FB40A00.CB40A020_0; -- Explicit "with" of Text_Parser.Processing + -- Implicit "with" of Text_Parser (FB40A00) + + procedure CB40A021 is + + String_Constant : constant String := + "ACVC Version 2.0 will incorporate Ada 9X feature tests."; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + + begin + + Process_Block: + begin + + Report.Test ("CB40A021", "Check that a user defined exception " & + "is correctly propagated across " & + "package and subprogram boundaries"); + + Number_Of_AlphaNumeric_Characters := + FB40A00.CB40A020_0.Count_AlphaNumerics (String_Constant); + + Report.Failed ("Exception should have been handled"); + + exception + + when FB40A00.Completed_Text_Processing => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 45 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + + end CB40A021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a030.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a030.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a030.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a030.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CB40A030.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See CB40A031.AM. + -- + -- TEST DESCRIPTION: + -- See CB40A031.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FB40A00.A + -- => CB40A030.A + -- CB40A031.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + + package FB40A00.CB40A030_0 is -- package Text_Parser.Character_Counting + + function Count_AlphaNumerics (Text : in String) return Natural; + + end FB40A00.CB40A030_0; + + + --=================================================================-- + + + private package FB40A00.CB40A030_1 is -- package Text_Parser.Processing + + procedure Process_Text (Text : in String); + + end FB40A00.CB40A030_1; + + + --=================================================================-- + + + package body FB40A00.CB40A030_1 is + + procedure Process_Text (Text : in String) is + Loop_Count : Integer := Text'Length + 1; + begin + for Pos in 1..Loop_Count loop -- Process string, force the + -- raise of Constraint_Error. + if (Text (Pos) in 'a'..'z') or + (Text (Pos) in 'A'..'Z') or + (Text (Pos) in '0'..'9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + + end loop; + -- No exception handler here, exception propagates. + end Process_Text; + + end FB40A00.CB40A030_1; + + + --=================================================================-- + + + with FB40A00.CB40A030_1; -- private sibling package Text_Parser.Processing; + + package body FB40A00.CB40A030_0 is + + function Count_AlphaNumerics (Text : in String) return Natural is + begin + FB40A00.CB40A030_1.Process_Text (Text); -- Call proc in prvt child + -- package that is a + -- sibling of this package. + return (AlphaNumeric_Count); + -- No exception handler here, exception propagates. + end Count_AlphaNumerics; + + end FB40A00.CB40A030_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a031.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a031.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a031.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a031.am 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- CB40A031.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a predefined exception is correctly propagated from + -- a private child package through a visible child package to a client. + -- + -- TEST DESCRIPTION: + -- Declare two child packages from a root package, one visible, one + -- private. The visible child package contains a function, whose + -- body makes a call to a procedure contained in the private sibling + -- package. A predefined exception occurring in the subprogram within the + -- private package is propagated through the visible sibling and ancestor + -- to the test program. + -- + -- Exception Type Raised: + -- User Defined + -- * Predefined + -- + -- Hierarchical Structure Employed For This Test: + -- * Parent Package + -- * Visible Child Package + -- * Private Child Package + -- Visible Child Subprogram + -- Private Child Subprogram + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FB40A00.A + -- CB40A030.A + -- => CB40A031.AM + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 96 SAIC ACVC 2.1: Modified prologue. + -- + --! + + with Report; + with FB40A00.CB40A030_0; -- Explicit "with" of Text_Parser.Character_Counting + -- Implicit "with" of Text_Parser + + procedure CB40A031 is + + String_Constant : constant String := + "The San Diego Padres will win the World Series in 1999."; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + + begin + + Process_Block: + begin + + Report.Test ("CB40A031", "Check that a predefined exception " & + "is correctly propagated across " & + "package boundaries"); + + Number_Of_AlphaNumeric_Characters := + FB40A00.CB40A030_0.Count_AlphaNumerics (String_Constant); + + Report.Failed ("Exception should have been handled"); + + exception + + when Constraint_Error => -- Correct exception + if FB40A00.AlphaNumeric_Count /= 44 then -- propagation. + Report.Failed ("Incorrect string processing"); + end if; + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + + end CB40A031; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a04.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a04.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb40a04.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb40a04.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CB40A04.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a predefined exception is correctly propagated out of a + -- public child function to a client. + -- + -- TEST DESCRIPTION: + -- Declare a public child subprogram. Define the processing loop + -- inside the subprogram to expect a string with index starting at 1. + -- From the test procedure, call the child subprogram with a slice + -- from the middle of a string variable. This will cause an exception + -- to be raised in the child and propagated to the caller. + -- + -- Exception Type Raised: + -- User Defined + -- * Predefined + -- + -- Hierarchical Structure Employed For This Test: + -- * Parent Package + -- Public Child Package + -- Private Child Package + -- * Public Child Subprogram + -- Private Child Subprogram + -- + -- TEST FILES: + -- This test depends on the following foundation code: + -- FB40A00.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + + -- Child subprogram Text_Parser.Count_AlphaNumerics + + function FB40A00.CB40A04_0 (Text : string) return Natural is + begin + + for I in 1 .. Text'Last loop -- Raise immediate Constraint_Error + if (Text (I) in 'a'..'z') or -- with String slice passed from + (Text (I) in 'A'..'Z') or -- caller. (Slice'first /= 1) + (Text (I) in '0'..'9') then + Increment_AlphaNumeric_Count; + else + Increment_Non_AlphaNumeric_Count; + end if; + end loop; + + return (AlphaNumeric_Count); -- Global in parent package. + + -- No exception handler here, exception propagates. + + end FB40A00.CB40A04_0; + + + --=================================================================-- + + + with FB40A00.CB40A04_0; -- Explicit "with" of Text_Parser.Count_AlphaNumerics + with Report; -- Implicit "with" of Text_Parser. + + procedure CB40A04 is + + String_Var : String (1..19) := "The quick brown fox"; + + Number_Of_AlphaNumeric_Characters : Natural := 0; + + begin + + Report.Test ("CB40A04", "Check that a predefined exception is " & + "correctly propagated out of a public " & + "child function to a client"); + + Process_Block: + begin + + Number_Of_AlphaNumeric_Characters := -- Provide slice of string + FB40A00.CB40A04_0 (String_Var (5..10)); -- to subprogram. + + Report.Failed ("Exception should have been handled"); + + exception + + when Constraint_Error => -- Correct exception + null; -- propagation. + + when others => + Report.Failed ("Exception handled in an others handler"); + + end Process_Block; + + Report.Result; + + end CB40A04; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41001.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- CB41001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the 'Identity attribute returns the unique identity of an + -- exception. Check that the Raise_Exception procedure can raise an + -- exception that is specified through the use of the 'Identity attribute, + -- and that Reraise_Occurrence can re-raise an exception occurrence + -- using an exception choice parameter. + -- + -- TEST DESCRIPTION: + -- This test uses the capability of the 'Identity attribute, which + -- returns the unique identity of an exception, as an Exception_Id + -- result. This result is used as an input parameter to the procedure + -- Raise_Exception. The exception that results is handled, propagated + -- using the Reraise_Occurrence procedure, and handled again. + -- The above actions are performed for both a user-defined and a + -- predefined exception. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 11 Nov 96 SAIC ACVC 2.1: Modified Propagate_User_Exception. + -- + --! + + with Report; + with Ada.Exceptions; + + procedure CB41001 is + + begin + + Report.Test ("CB41001", "Check that the 'Identity attribute returns " & + "the unique identity of an exception. Check " & + "that the 'Identity attribute is of type " & + "Exception_Id. Check that the " & + "Raise_Exception procedure can raise an " & + "exception that is specified through the " & + "use of the 'Identity attribute"); + Test_Block: + declare + + Check_Points : constant := 5; + + type Check_Point_Array_Type is array (1..Check_Points) of Boolean; + + -- Global array used to track the processing path through the test. + TC_Check_Points : Check_Point_Array_Type := (others => False); + + A_User_Defined_Exception : Exception; + An_Exception_ID : Ada.Exceptions.Exception_Id := + Ada.Exceptions.Null_Id; + + procedure Propagate_User_Exception is + Hidden_Exception : Exception; + begin + -- Use the 'Identity function to store the unique identity of a + -- user defined exception into a variable of type Exception_Id. + + An_Exception_ID := A_User_Defined_Exception'Identity; + + -- Raise this user defined exception using the result of the + -- 'Identity attribute. + + Ada.Exceptions.Raise_Exception(E => An_Exception_Id); + + Report.Failed("User defined exception not raised by " & + "procedure Propagate_User_Exception"); + + exception + when Proc_Excpt : A_User_Defined_Exception => -- Expected exception. + begin + + -- By raising a different exception at this point, the + -- information associated with A_User_Defined_Exception must + -- be correctly stacked internally. + + Ada.Exceptions.Raise_Exception(Hidden_Exception'Identity); + Report.Failed("Hidden_Exception not raised by " & + "procedure Propagate_User_Exception"); + exception + when others => + TC_Check_Points(1) := True; + + -- Reraise the original exception, which will be propagated + -- outside the scope of this procedure. + + Ada.Exceptions.Reraise_Occurrence(Proc_Excpt); + Report.Failed("User defined exception not reraised"); + + end; + + when others => + Report.Failed("Unexpected exception raised by " & + "Procedure Propagate_User_Exception"); + end Propagate_User_Exception; + + begin + + User_Exception_Block: + begin + -- Call procedure to raise, handle, and reraise a user defined + -- exception. + Propagate_User_Exception; + + Report.Failed("User defined exception not propagated from " & + "procedure Propagate_User_Exception"); + + exception + when A_User_Defined_Exception => -- Expected exception. + TC_Check_Points(2) := True; + when others => + Report.Failed + ("Unexpected exception handled in User_Exception_Block"); + end User_Exception_Block; + + + Predefined_Exception_Block: + begin + + Inner_Block: + begin + + begin + -- Use the 'Identity attribute as an input parameter to the + -- Raise_Exception procedure. + + Ada.Exceptions.Raise_Exception(Constraint_Error'Identity); + Report.Failed("Constraint_Error not raised in Inner_Block"); + + exception + when Excpt : Constraint_Error => -- Expected exception. + TC_Check_Points(3) := True; + + -- Reraise the exception. + Ada.Exceptions.Reraise_Occurrence(X => Excpt); + Report.Failed("Predefined exception not raised from " & + "within the exception handler - 1"); + when others => + Report.Failed("Incorrect result from attempt to raise " & + "Constraint_Error using the 'Identity " & + "attribute - 1"); + end; + + Report.Failed("Constraint_Error not reraised in Inner_Block"); + + exception + when Block_Excpt : Constraint_Error => -- Expected exception. + TC_Check_Points(4) := True; + + -- Reraise the exception in a scope where the exception + -- was not originally raised. + + Ada.Exceptions.Reraise_Occurrence(X => Block_Excpt); + Report.Failed("Predefined exception not raised from " & + "within the exception handler - 2"); + + when others => + Report.Failed("Incorrect result from attempt to raise " & + "Constraint_Error using the 'Identity " & + "attribute - 2"); + end Inner_Block; + + Report.Failed("Exception not propagated from Inner_Block"); + + exception + when Constraint_Error => -- Expected exception. + TC_Check_Points(5) := True; + when others => + Report.Failed("Unexpected exception handled after second " & + "reraise of Constraint_Error"); + end Predefined_Exception_Block; + + + -- Verify the processing path taken through the test. + + for i in 1..Check_Points loop + if not TC_Check_Points(i) then + Report.Failed("Incorrect processing path taken through test, " & + "didn't pass check point #" & Integer'Image(i)); + end if; + end loop; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CB41001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41002.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,283 ---- + -- CB41002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the message string input parameter in a call to the + -- Raise_Exception procedure is associated with the raised exception + -- occurrence, and that the message string can be obtained using the + -- Exception_Message function with the associated Exception_Occurrence + -- object. Check that Function Exception_Information is available + -- to provide implementation-defined information about the exception + -- occurrence. + -- + -- TEST DESCRIPTION: + -- This test checks that a message associated with a raised exception + -- is propagated with the exception, and can be retrieved using the + -- Exception_Message function. The exception will be raised using the + -- 'Identity attribute as a parameter to the Raise_Exception procedure, + -- and an associated message string will be provided. The exception + -- will be handled, and the message associated with the occurrence will + -- be compared to the original source message (non-default). + -- + -- The test also includes a simulated logging procedure + -- (Check_Exception_Information) that checks that Exception_Information + -- can be called. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 22 Jun 00 RLB Added a check at Exception_Information can be + -- called. + -- + --! + + with Report; + with Ada.Exceptions; + + procedure CB41002 is + begin + + Report.Test ("CB41002", "Check that the message string input parameter " & + "in a call to the Raise_Exception procedure is " & + "associated with the raised exception " & + "occurrence, and that the message string can " & + "be obtained using the Exception_Message " & + "function with the associated " & + "Exception_Occurrence object. Also check that " & + "the Exception_Information function can be called"); + + Test_Block: + declare + + Number_Of_Exceptions : constant := 3; + + User_Exception_1, + User_Exception_2, + User_Exception_3 : exception; + + type String_Ptr is access String; + + User_Messages : constant array (1..Number_Of_Exceptions) + of String_Ptr := + (new String'("Msg"), + new String'("This message will override the default " & + "message provided by the implementation"), + new String'("The message can be captured by procedure" & -- 200 chars + " Exception_Message. It is designed to b" & + "e exactly 200 characters in length, sinc" & + "e there is a permission concerning the " & + "truncation of a message over 200 chars. ")); + + procedure Check_Exception_Information ( + Occur : in Ada.Exceptions.Exception_Occurrence) is + -- Simulates an error logging routine. + Info : constant String := + Ada.Exceptions.Exception_Information (Occur); + function Is_Substring_of (Target, Search : in String) return Boolean is + -- Returns True if Search is a substring of Target, and False + -- otherwise. + begin + for I in Report.Ident_Int(Target'First) .. + Target'Last - Search'Length + 1 loop + if Target(I .. I+Search'Length-1) = Search then + return True; + end if; + end loop; + return False; + end Is_Substring_of; + begin + -- We can't display Info, as it often contains line breaks + -- (confusing Report), and might look much like the failure of a test + -- with an unhandled exception (thus confusing grading tools). + -- + -- We don't particular care if the implementation advice is followed, + -- but we make these checks to insure that a compiler cannot optimize + -- away Info or the rest of this routine. + if not Is_Substring_of (Info, + Ada.Exceptions.Exception_Name (Occur)) then + Report.Comment ("Exception_Information does not contain " & + "Exception_Name - see 11.4.1(19)"); + elsif not Is_Substring_of (Info, + Ada.Exceptions.Exception_Message (Occur)) then + Report.Comment ("Exception_Information does not contain " & + "Exception_Message - see 11.4.1(19)"); + end if; + end Check_Exception_Information; + + begin + + for i in 1..Number_Of_Exceptions loop + begin + + -- Raise a user-defined exception with a specific message string. + case i is + when 1 => + Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, + User_Messages(i).all); + when 2 => + Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, + User_Messages(i).all); + when 3 => + Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, + User_Messages(i).all); + when others => + Report.Failed("Incorrect result from Case statement"); + end case; + + Report.Failed + ("Exception not raised by procedure Exception_With_Message " & + "for User_Exception #" & Integer'Image(i)); + + exception + when Excptn : others => + + begin + -- The message that is associated with the raising of each + -- exception is captured here using the Exception_Message + -- function. + + if User_Messages(i).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed + ("Message captured from exception is not the " & + "message provided when the exception was raised, " & + "User_Exception #" & Integer'Image(i)); + end if; + + Check_Exception_Information(Excptn); + end; + end; + end loop; + + + + -- Verify that the exception specific message is carried across + -- various boundaries: + + begin + + begin + Ada.Exceptions.Raise_Exception(User_Exception_1'Identity, + User_Messages(1).all); + Report.Failed("User_Exception_1 not raised"); + end; + Report.Failed("User_Exception_1 not propagated"); + exception + when Excptn : User_Exception_1 => + + if User_Messages(1).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_1 not found"); + end if; + Check_Exception_Information(Excptn); + + when others => Report.Failed("Unexpected exception handled - 1"); + end; + + + + begin + + begin + Ada.Exceptions.Raise_Exception(User_Exception_2'Identity, + User_Messages(2).all); + Report.Failed("User_Exception_2 not raised"); + exception + when Exc : User_Exception_2 => + + -- The exception is reraised here; message should propagate + -- with exception occurrence. + + Ada.Exceptions.Reraise_Occurrence(Exc); + when others => Report.Failed("User_Exception_2 not handled"); + end; + Report.Failed("User_Exception_2 not propagated"); + exception + when Excptn : User_Exception_2 => + + if User_Messages(2).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_2 not found"); + end if; + Check_Exception_Information(Excptn); + + when others => Report.Failed("Unexpected exception handled - 2"); + end; + + + -- Check exception and message propagation across task boundaries. + + declare + + task Raise_An_Exception is -- single task + entry Raise_It; + end Raise_An_Exception; + + task body Raise_An_Exception is + begin + accept Raise_It do + Ada.Exceptions.Raise_Exception(User_Exception_3'Identity, + User_Messages(3).all); + end Raise_It; + Report.Failed("User_Exception_3 not raised"); + exception + when Excptn : User_Exception_3 => + if User_Messages(3).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed + ("User_Message_3 not returned inside task body"); + end if; + Check_Exception_Information(Excptn); + when others => + Report.Failed("Incorrect exception raised in task body"); + end Raise_An_Exception; + + begin + Raise_An_Exception.Raise_It; -- Exception will be propagated here. + Report.Failed("User_Exception_3 not propagated to caller"); + exception + when Excptn : User_Exception_3 => + if User_Messages(3).all /= + Ada.Exceptions.Exception_Message(Excptn) + then + Report.Failed("User_Message_3 not returned to caller of task"); + end if; + Check_Exception_Information(Excptn); + when others => + Report.Failed("Incorrect exception raised by task"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CB41002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41003.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,358 ---- + -- CB41003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an exception occurrence can be saved into an object of + -- type Exception_Occurrence using the procedure Save_Occurrence. + -- Check that a saved exception occurrence can be used to reraise + -- another occurrence of the same exception using the procedure + -- Reraise_Occurrence. Check that the function Save_Occurrence will + -- allocate a new object of type Exception_Occurrence_Access, and saves + -- the source exception to the new object which is returned as the + -- function result. + -- + -- TEST DESCRIPTION: + -- This test verifies that an occurrence of an exception can be saved, + -- using either of two overloaded versions of Save_Occurrence. The + -- procedure version of Save_Occurrence is used to save an occurrence + -- of a user defined exception into an object of type + -- Exception_Occurrence. This object is then used as an input + -- parameter to procedure Reraise_Occurrence, the expected exception is + -- handled, and the exception id of the handled exception is compared + -- to the id of the originally raised exception. + -- The function version of Save_Occurrence returns a result of + -- Exception_Occurrence_Access, and is used to store the value of another + -- occurrence of the user defined exception. The resulting access value + -- is dereferenced and used as an input to Reraise_Occurrence. The + -- resulting exception is handled, and the exception id of the handled + -- exception is compared to the id of the originally raised exception. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with Ada.Exceptions; + + procedure CB41003 is + + begin + + Report.Test ("CB41003", "Check that an exception occurrence can " & + "be saved into an object of type " & + "Exception_Occurrence using the procedure " & + "Save_Occurrence"); + + Test_Block: + declare + + use Ada.Exceptions; + + User_Exception_1, + User_Exception_2 : Exception; + + Saved_Occurrence : Exception_Occurrence; + Occurrence_Ptr : Exception_Occurrence_Access; + + User_Message : constant String := -- 200 character string. + "The string returned by Exception_Message may be tr" & + "uncated (to no less then 200 characters) by the Sa" & + "ve_Occurrence procedure (not the function), the Re" & + "raise_Occurrence proc, and the re-raise statement."; + + begin + + Raise_And_Save_Block_1 : + begin + + -- This nested exception structure is designed to ensure that the + -- appropriate exception occurrence is saved using the + -- Save_Occurrence procedure. + + raise Program_Error; + Report.Failed("Program_Error not raised"); + + exception + when Program_Error => + + begin + -- Use the procedure Raise_Exception, along with the 'Identity + -- attribute to raise the first user defined exception. Note + -- that a 200 character message is included in the call. + + Raise_Exception(User_Exception_1'Identity, User_Message); + Report.Failed("User_Exception_1 not raised"); + + exception + when Exc : User_Exception_1 => + + -- This exception occurrence is saved into a variable using + -- procedure Save_Occurrence. This saved occurrence should + -- not be confused with the raised occurrence of + -- Program_Error above. + + Save_Occurrence(Target => Saved_Occurrence, Source => Exc); + + when others => + Report.Failed("Unexpected exception handled, expecting " & + "User_Exception_1"); + end; + + when others => + Report.Failed("Incorrect exception generated by raise statement"); + + end Raise_And_Save_Block_1; + + + Reraise_And_Handle_Saved_Exception_1 : + begin + -- Reraise the exception that was saved in the previous block. + + Reraise_Occurrence(X => Saved_Occurrence); + + exception + when Exc : User_Exception_1 => -- Expected exception. + -- Check the exception id of the handled id by using the + -- Exception_Identity function, and compare with the id of the + -- originally raised exception. + + if User_Exception_1'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_Ids do not match - 1"); + end if; + + -- Check that the message associated with this exception occurrence + -- has not been truncated (it was originally 200 characters). + + if User_Message /= Exception_Message(Exc) then + Report.Failed("Exception messages do not match - 1"); + end if; + + when others => + Report.Failed + ("Incorrect exception raised by Reraise_Occurrence - 1"); + end Reraise_And_Handle_Saved_Exception_1; + + + Raise_And_Save_Block_2 : + begin + + Raise_Exception(User_Exception_2'Identity, User_Message); + Report.Failed("User_Exception_2 not raised"); + + exception + when Exc : User_Exception_2 => + + -- This exception occurrence is saved into an access object + -- using function Save_Occurrence. + + Occurrence_Ptr := Save_Occurrence(Source => Exc); + + when others => + Report.Failed("Unexpected exception handled, expecting " & + "User_Exception_2"); + end Raise_And_Save_Block_2; + + + Reraise_And_Handle_Saved_Exception_2 : + begin + -- Reraise the exception that was saved in the previous block. + -- Dereference the access object for use as input parameter. + + Reraise_Occurrence(X => Occurrence_Ptr.all); + + exception + when Exc : User_Exception_2 => -- Expected exception. + -- Check the exception id of the handled id by using the + -- Exception_Identity function, and compare with the id of the + -- originally raised exception. + + if User_Exception_2'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_Ids do not match - 2"); + end if; + + -- Check that the message associated with this exception occurrence + -- has not been truncated (it was originally 200 characters). + + if User_Message /= Exception_Message(Exc) then + Report.Failed("Exception messages do not match - 2"); + end if; + + when others => + Report.Failed + ("Incorrect exception raised by Reraise_Occurrence - 2"); + end Reraise_And_Handle_Saved_Exception_2; + + + -- Another example of the use of saving an exception occurrence + -- is demonstrated in the following block, where the ability to + -- save an occurrence into a data structure, for later processing, + -- is modeled. + + Store_And_Handle_Block: + declare + + Exc_Number : constant := 3; + Exception_1, + Exception_2, + Exception_3 : exception; + + Exception_Storage : array (1..Exc_Number) of Exception_Occurrence; + Messages : array (1..Exc_Number) of String(1..9) := + ("Message 1", "Message 2", "Message 3"); + + begin + + Outer_Block: + begin + + Inner_Block: + begin + + for i in 1..Exc_Number loop + begin + + begin + -- Exceptions all raised in a deep scope. + if i = 1 then + Raise_Exception(Exception_1'Identity, Messages(i)); + elsif i = 2 then + Raise_Exception(Exception_2'Identity, Messages(i)); + elsif i = 3 then + Raise_Exception(Exception_3'Identity, Messages(i)); + end if; + Report.Failed("Exception not raised on loop #" & + Integer'Image(i)); + end; + Report.Failed("Exception not propagated on loop #" & + Integer'Image(i)); + exception + when Exc : others => + + -- Save each occurrence into a storage array for + -- later processing. + + Save_Occurrence(Exception_Storage(i), Exc); + end; + end loop; + + end Inner_Block; + end Outer_Block; + + -- Raise the exceptions from the stored occurrences, and handle. + + for i in 1..Exc_Number loop + begin + Reraise_Occurrence(Exception_Storage(i)); + Report.Failed("No exception reraised for " & + "exception #" & Integer'Image(i)); + exception + when Exc : others => + -- The following sequence of checks ensures that the + -- correct occurrence was stored, and the associated + -- exception was raised and handled in the proper order. + if i = 1 then + if Exception_1'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_1 not raised"); + end if; + elsif i = 2 then + if Exception_2'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_2 not raised"); + end if; + elsif i = 3 then + if Exception_3'Identity /= Exception_Identity(Exc) then + Report.Failed("Exception_3 not raised"); + end if; + end if; + + if Exception_Message(Exc) /= Messages(i) then + Report.Failed("Incorrect message associated with " & + "exception #" & Integer'Image(i)); + end if; + end; + end loop; + exception + when others => + Report.Failed("Unexpected exception in Store_And_Handle_Block"); + end Store_And_Handle_Block; + + + Reraise_Out_Of_Scope: + declare + + TC_Value : constant := 5; + The_Exception : exception; + Saved_Exc_Occ : Exception_Occurrence; + + procedure Handle_It (Exc_Occ : in Exception_Occurrence) is + Must_Be_Raised : exception; + begin + if Exception_Identity(Exc_Occ) = The_Exception'Identity then + raise Must_Be_Raised; + Report.Failed("Exception Must_Be_Raised was not raised"); + else + Report.Failed("Incorrect exception handled in " & + "Procedure Handle_It"); + end if; + end Handle_It; + + begin + + if Report.Ident_Int(5) = TC_Value then + raise The_Exception; + end if; + + exception + when Exc : others => + Save_Occurrence (Saved_Exc_Occ, Exc); + begin + Handle_It(Saved_Exc_Occ); -- Raise another exception, in a + exception -- different scope. + when others => -- Handle this new exception. + begin + Reraise_Occurrence (Saved_Exc_Occ); -- Reraise the + -- original excptn. + Report.Failed("Saved Exception was not raised"); + exception + when Exc_2 : others => + if Exception_Identity (Exc_2) /= + The_Exception'Identity + then + Report.Failed + ("Incorrect exception occurrence reraised"); + end if; + end; + end; + end Reraise_Out_Of_Scope; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CB41003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb41004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb41004.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,316 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5001a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CB5001A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO + -- THE CALLER AND TO THE CALLED TASK. + + -- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH ONE + -- LEVEL OF RENDEVOUS. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- JEAN-PIERRE ROSEN 09 MARCH 1984 + -- JBG 6/1/84 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CB5001A IS + + BEGIN + + TEST("CB5001A", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " & + "PROPAGATED TO CALLER AND CALLED TASKS -- ONE " & + "LEVEL"); + + DECLARE + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T2 IS + MY_EXCEPTION: EXCEPTION; + BEGIN + ACCEPT E2 DO + IF EQUAL (1,1) THEN + RAISE MY_EXCEPTION; + END IF; + END E2; + FAILED ("T2: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T2"); + WHEN OTHERS => + FAILED ("T2 RECEIVED ABNORMAL EXCEPTION"); + END T2; + + BEGIN + T2.E2; + FAILED ("MAIN: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR | STORAGE_ERROR => + FAILED ("PREDEFINED ERROR RAISED IN MAIN"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN MAIN"); + WHEN OTHERS => + NULL; + END; + + RESULT; + + END CB5001A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5001b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CB5001B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN EXCEPTION RAISED IN A RENDEVOUS IS PROPAGATED BOTH TO + -- THE CALLER AND TO THE CALLED TASK. + + -- THIS VERSION CHECKS THAT THE EXCEPTION IS PROPAGATED THROUGH TWO + -- LEVELS OF RENDEVOUS. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- JEAN-PIERRE ROSEN 09 MARCH 1984 + -- JBG 6/1/84 + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CB5001B IS + + BEGIN + + TEST("CB5001B", "CHECK THAT AN EXCEPTION IN A RENDEVOUS IS " & + "PROPAGATED TO CALLER AND CALLED TASKS -- TWO " & + "LEVELS"); + + DECLARE + TASK T1 IS + ENTRY E1; + END T1; + + TASK T2 IS + ENTRY E2; + END T2; + + TASK BODY T1 IS + BEGIN + ACCEPT E1 DO + T2.E2; + END E1; + FAILED ("T1: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR => + FAILED ("PREDEFINED EXCEPTION RAISED IN T1"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T1"); + WHEN OTHERS => + NULL; + END T1; + + TASK BODY T2 IS + MY_EXCEPTION: EXCEPTION; + BEGIN + ACCEPT E2 DO + IF EQUAL (1,1) THEN + RAISE MY_EXCEPTION; + END IF; + END E2; + FAILED ("T2: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN MY_EXCEPTION => + NULL; + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN T2"); + WHEN OTHERS => + FAILED ("T2 RECEIVED ABNORMAL EXCEPTION"); + END T2; + + BEGIN + T1.E1; + FAILED ("MAIN: EXCEPTION NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR | PROGRAM_ERROR => + FAILED ("PREDEFINED ERROR RAISED IN MAIN"); + WHEN TASKING_ERROR => + FAILED ("TASKING_ERROR RAISED IN MAIN"); + WHEN OTHERS => + NULL; + END; + + RESULT; + + END CB5001B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cb/cb5002a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- CB5002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN "TASKING_ERROR" IS RAISED EXPLICITLY OR BY + -- PROPAGATION WITHIN AN ACCEPT STATEMENT, THEN "TASKING_ERROR" + -- IS RAISED IN BOTH THE CALLING AND THE CALLED TASK. + + -- HISTORY: + -- DHH 03/31/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CB5002A IS + + BEGIN + TEST("CB5002A", "CHECK THAT WHEN ""TASKING_ERROR"" IS RAISED " & + "EXPLICITLY OR BY PROPAGATION WITHIN AN ACCEPT " & + "STATEMENT, THEN ""TASKING_ERROR"" IS RAISED " & + "IN BOTH THE CALLING AND THE CALLED TASK"); + + DECLARE + TASK CALLING_EXP IS + ENTRY A; + END CALLING_EXP; + + TASK CALLED_EXP IS + ENTRY B; + ENTRY STOP; + END CALLED_EXP; + + TASK CALLING_PROP IS + ENTRY C; + END CALLING_PROP; + + TASK CALLED_PROP IS + ENTRY D; + ENTRY STOP; + END CALLED_PROP; + + TASK PROP IS + ENTRY E; + ENTRY STOP; + END PROP; + ----------------------------------------------------------------------- + TASK BODY CALLING_EXP IS + BEGIN + ACCEPT A DO + BEGIN + CALLED_EXP.B; + FAILED("EXCEPTION NOT RAISED IN CALLING " & + "TASK - EXPLICIT RAISE"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN " & + "CALLING TASK - EXPLICIT RAISE"); + END; -- EXCEPTION + END A; + END CALLING_EXP; + + TASK BODY CALLED_EXP IS + BEGIN + BEGIN + ACCEPT B DO + RAISE TASKING_ERROR; + FAILED("EXCEPTION NOT RAISED IN CALLED " & + "TASK - EXPLICIT RAISE"); + END B; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN CALLED " & + "TASK - EXPLICIT RAISE"); + END; -- EXCEPTION BLOCK + + ACCEPT STOP; + END CALLED_EXP; + + ----------------------------------------------------------------------- + TASK BODY CALLING_PROP IS + BEGIN + ACCEPT C DO + BEGIN + CALLED_PROP.D; + FAILED("EXCEPTION NOT RAISED IN CALLING " & + "TASK - PROPAGATED RAISE"); + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN " & + "CALLING TASK - PROPAGATED RAISE"); + END; -- EXCEPTION + END C; + END CALLING_PROP; + + TASK BODY CALLED_PROP IS + BEGIN + BEGIN + ACCEPT D DO + PROP.E; + FAILED("EXCEPTION NOT RAISED IN CALLED " & + "TASK - PROPAGATED RAISE"); + END D; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN CALLED " & + "TASK - PROPAGATED RAISE"); + END; -- EXCEPTION BLOCK; + + ACCEPT STOP; + END CALLED_PROP; + + TASK BODY PROP IS + BEGIN + BEGIN + ACCEPT E DO + RAISE TASKING_ERROR; + FAILED("EXCEPTION NOT RAISED IN PROPAGATE " & + "TASK - ACCEPT E"); + END E; + EXCEPTION + WHEN TASKING_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED IN PROP. TASK"); + END; -- EXCEPTION BLOCK + + ACCEPT STOP; + + END PROP; + ----------------------------------------------------------------------- + BEGIN + CALLING_EXP.A; + CALLING_PROP.C; + CALLED_EXP.STOP; + CALLED_PROP.STOP; + PROP.STOP; + + END; -- DECLARE + + RESULT; + END CB5002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- CC1004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE ELABORATION OF A GENERIC DECLARATION + -- DOES NOT ELABORATE THE SUBPROGRAM OR PACKAGE SPECIFICATION. + + -- HISTORY: + -- DAT 07/31/81 CREATED ORIGINAL TEST. + -- SPS 10/18/82 + -- SPS 02/09/83 + -- JET 01/07/88 UPDATED HEADER FORMAT AND ADDED CODE TO + -- PREVENT OPTIMIZATION. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1004A IS + BEGIN + TEST ("CC1004A", "THE SPECIFICATION PART OF A GENERIC " & + "SUBPROGRAM IS NOT ELABORATED AT THE " & + "ELABORATION OF THE DECLARATION"); + + BEGIN + DECLARE + SUBTYPE I1 IS INTEGER RANGE 1 .. 1; + + GENERIC + PROCEDURE PROC (P1: I1 := IDENT_INT(2)); + + PROCEDURE PROC (P1: I1 := IDENT_INT(2)) IS + BEGIN + IF NOT EQUAL (P1,P1) THEN + COMMENT ("DON'T OPTIMIZE THIS"); + END IF; + END PROC; + BEGIN + BEGIN + DECLARE + PROCEDURE P IS NEW PROC; + BEGIN + IF NOT EQUAL(3,3) THEN + P(1); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("INSTANTIATION ELABORATES SPEC"); + END; + + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DECL ELABORATED SPEC PART - 1"); + END; + + BEGIN + DECLARE + SUBTYPE I1 IS INTEGER RANGE 1 .. 1; + + GENERIC + PACKAGE PKG IS + X : INTEGER := I1(IDENT_INT(2)); + END PKG; + BEGIN + BEGIN + DECLARE + PACKAGE P IS NEW PKG; + BEGIN + FAILED ("PACKAGE INSTANTIATION FAILED"); + IF NOT EQUAL(P.X,P.X) THEN + COMMENT("DON'T OPTIMIZE THIS"); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION - 2"); + END; + + END; + EXCEPTION + WHEN OTHERS => + FAILED ("DECL ELABORATED SPEC PART - 2"); + END; + + RESULT; + + END CC1004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1005b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- CC1005B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A GENERIC UNIT'S IDENTIFIER CAN BE USED IN ITS + -- FORMAL PART: + -- + -- (A) AS THE SELECTOR IN AN EXPANDED NAME TO DENOTE AN ENTITY IN THE + -- VISIBLE PART OF A PACKAGE, OR TO DENOTE AN ENTITY IMMEDIATELY + -- ENCLOSED IN A CONSTRUCT OTHER THAN THE CONSTRUCT IMMEDIATELY + -- ENCLOSING THE GENERIC UNIT. + -- + -- (B) AS A SELECTOR TO DENOTE A COMPONENT OF A RECORD OBJECT, + -- AS THE NAME OF A RECORD OR DISCRIMINANT COMPONENT IN A RECORD + -- AGGREGATE, AND AS THE NAME OF A FORMAL PARAMETER IN A + -- FUNCTION CALL. + + -- HISTORY: + -- BCB 08/03/88 CREATED ORIGINAL TEST. + -- JRL 03/20/92 DELETED TEST IN BLOCK STATEMENT; CONSOLIDATED + -- WITH CC1005C. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1005B IS + + S : INTEGER := IDENT_INT(0); + + PACKAGE CC1005B IS + I : INTEGER; + S : INTEGER := IDENT_INT(5); + GENERIC + S : INTEGER := IDENT_INT(10); + V : INTEGER := STANDARD.CC1005B.S; + W : INTEGER := STANDARD.CC1005B.CC1005B.S; + FUNCTION CC1005B RETURN INTEGER; + END CC1005B; + + PACKAGE BODY CC1005B IS + FUNCTION CC1005B RETURN INTEGER IS + BEGIN + IF NOT EQUAL(V,0) THEN + FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF V"); + END IF; + + IF NOT EQUAL(W,5) THEN + FAILED ("WRONG VALUE OF S USED IN ASSIGNMENT OF W"); + END IF; + + RETURN 0; + END CC1005B; + + FUNCTION NEW_CC IS NEW CC1005B; + + BEGIN + TEST ("CC1005B", "CHECK THAT A GENERIC UNIT'S IDENTIFIER " & + "CAN BE USED IN ITS FORMAL PART: AS THE " & + "SELECTOR IN AN EXPANDED NAME TO DENOTE " & + "AN ENTITY IN THE VISIBLE PART OF A " & + "PACKAGE, OR TO DENOTE AN ENTITY " & + "IMMEDIATELY ENCLOSED IN A CONSTRUCT " & + "OTHER THAN THE CONSTRUCT IMMEDIATELY " & + "ENCLOSING THE GENERIC UNIT; AND AS A " & + "SELECTOR TO DENOTE A COMPONENT OF A " & + "RECORD OBJECT, AS THE NAME OF A RECORD " & + "OR DISCRIMINANT COMPONENT IN A RECORD " & + "AGGREGATE, AND AS THE NAME OF A FORMAL " & + "PARAMETER IN A FUNCTION CALL"); + + I := NEW_CC; + END CC1005B; + + FUNCTION F (P : INTEGER) RETURN INTEGER IS + BEGIN + RETURN P; + END F; + + BEGIN + + BLOCK1: + DECLARE + TYPE REC IS RECORD + P : INTEGER := IDENT_INT(0); + END RECORD; + + TYPE REC2 (P : INTEGER) IS RECORD + NULL; + END RECORD; + + R : REC; + + J : INTEGER; + + GENERIC + V : INTEGER := R.P; + X : REC := (P => IDENT_INT(10)); + Y : REC2 := (P => IDENT_INT(15)); + Z : INTEGER := F(P => IDENT_INT(20)); + FUNCTION P RETURN INTEGER; + + FUNCTION P RETURN INTEGER IS + BEGIN + IF NOT EQUAL(V,0) THEN + FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " & + "OF V"); + END IF; + + IF NOT EQUAL(X.P,10) THEN + FAILED ("WRONG VALUE USED IN ASSIGNMENT OF X.P"); + END IF; + + IF NOT EQUAL(Y.P,15) THEN + FAILED ("WRONG VALUE USED IN ASSIGNMENT OF Y.P"); + END IF; + + IF NOT EQUAL(Z,20) THEN + FAILED ("WRONG VALUE OF P USED IN ASSIGNMENT " & + "OF Z"); + END IF; + + RETURN 0; + END P; + + FUNCTION NEW_P IS NEW P; + BEGIN + J := NEW_P; + END BLOCK1; + + RESULT; + END CC1005B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1010a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CC1010A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAMES IN A GENERIC SUBPROGRAM DECLARATION ARE + -- STATICALLY IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE + -- GENERIC DECLARATION TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY + -- BOUND AT THE POINT OF INSTANTIATION. + + -- ASL 8/12/81 + + WITH REPORT; + PROCEDURE CC1010A IS + USE REPORT; + BEGIN + TEST ("CC1010A","PROPER VISIBILITY OF FREE IDENTIFIERS IN " & + "GENERIC DECLARATIONS, BODIES AND INSTANTIATIONS"); + + OUTER: + DECLARE + FREE : CONSTANT INTEGER := 5; + BEGIN + DECLARE + GENERIC + GFP : INTEGER := FREE; + PROCEDURE P(PFP : IN INTEGER := FREE); + + FREE : CONSTANT INTEGER := 6; + + PROCEDURE P(PFP : IN INTEGER := OUTER.FREE) IS + BEGIN + IF FREE /= 6 OR GFP /= 5 OR PFP /= 5 THEN + FAILED ("BINDINGS INCORRECT"); + END IF; + END P; + BEGIN + DECLARE + FREE : CONSTANT INTEGER := 7; + PROCEDURE INST IS NEW P; + BEGIN + INST; + END; + END; + END OUTER; + RESULT; + END CC1010A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1010b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- CC1010B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAMES IN A GENERIC PACKAGE BODY ARE STATICALLY + -- IDENTIFIED (I.E., BOUND) AT THE POINT WHERE THE GENERIC BODY + -- TEXTUALLY OCCURS, AND ARE NOT DYNAMICALLY BOUND AT THE POINT + -- OF INSTANTIATION. + + -- ASL 8/13/81 + + WITH REPORT; + PROCEDURE CC1010B IS + + USE REPORT; + FREE : CONSTANT INTEGER := 5; + BEGIN + TEST("CC1010B","PROPER VISIBILITY OF FREE IDENTIFIERS IN " & + "GENERIC PACKAGE DECLARATIONS, BODIES AND INSTANTIATIONS"); + + DECLARE + GENERIC + GFP : INTEGER := FREE; + PACKAGE P IS + SPECITEM : CONSTANT INTEGER := FREE; + END P; + + FREE : CONSTANT INTEGER := 6; + + PACKAGE BODY P IS + BODYITEM : INTEGER := FREE; + BEGIN + IF GFP /= 5 OR SPECITEM /= 5 OR BODYITEM /= 6 THEN + FAILED ("BINDINGS INCORRECT"); + END IF; + END P; + BEGIN + DECLARE + FREE : CONSTANT INTEGER := 7; + PACKAGE INST IS NEW P; + BEGIN + NULL; + END; + END; + + RESULT; + END CC1010B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1018a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CC1018A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FORMAL OUT PARAMETER OF A GENERIC FORMAL SUBPROGRAM CAN + -- HAVE A FORMAL LIMITED TYPE AND AN ARRAY TYPE WITH LIMITED COMPONENTS. + + -- AH 10/3/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC1018A IS + TYPE INT IS RANGE 1..10; + TYPE ARR IS ARRAY (INTEGER RANGE <>) OF INT; + INT_OBJ : INT := 4; + ARR_OBJ : ARR(1..5) := (2, 8, 2, 8, 2); + + GENERIC + TYPE GLP IS LIMITED PRIVATE; + TYPE GARR IS ARRAY (INTEGER RANGE <>) OF GLP; + LP_OBJ : IN OUT GLP; + GA_OBJ : IN OUT GARR; + WITH PROCEDURE P (X : OUT GLP; Y : OUT GARR); + WITH FUNCTION SAME (LEFT, RIGHT : GLP) RETURN BOOLEAN; + PROCEDURE GEN_PROC; + + PROCEDURE GET_VALUES (X1 : OUT INT; Y1 : OUT ARR) IS + BEGIN + X1 := 4; + Y1 := (2, 8, 2, 8, 2); + END GET_VALUES; + + FUNCTION SAME_VALUE (LEFT, RIGHT : INT) RETURN BOOLEAN IS + BEGIN + RETURN LEFT = RIGHT; + END SAME_VALUE; + + PROCEDURE GEN_PROC IS + LP : GLP; + A : GARR(1..5); + BEGIN + P(LP, A); + IF NOT SAME(LP, LP_OBJ) THEN + FAILED ("LIMITED PRIVATE TYPE HAS INCORRECT VALUE"); + END IF; + + FOR INDEX IN A'RANGE LOOP + IF NOT SAME(A(INDEX), GA_OBJ(INDEX)) THEN + FAILED ("LIMITED PRIVATE TYPE COMPONENT " & + "HAS INCORRECT VALUE"); + END IF; + END LOOP; + END GEN_PROC; + + PROCEDURE TEST_LP IS NEW GEN_PROC(INT, ARR, INT_OBJ, ARR_OBJ, + GET_VALUES, SAME_VALUE); + + BEGIN + TEST ("CC1018A", "A GENERIC FORMAL SUBPROGRAM OUT PRARAMETER " & + "CAN HAVE A LIMITED TYPE"); + TEST_LP; + + RESULT; + END CC1018A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1104c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- CC1104C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE; + -- CHECK THAT A GENERIC FORMAL IN OUT PARAMETER CAN HAVE A + -- LIMITED TYPE. + + -- HISTORY: + -- BCB 08/03/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1104C IS + + TASK TYPE TSK IS + ENTRY E; + END TSK; + + VAR : INTEGER := IDENT_INT(0); + NEW_VAL : INTEGER := IDENT_INT(5); + + TSK_VAR : TSK; + + PACKAGE PP IS + TYPE LP IS LIMITED PRIVATE; + PROCEDURE INIT (ONE : OUT LP; TWO : INTEGER); + FUNCTION EQUAL (ONE : LP; TWO : INTEGER) RETURN BOOLEAN; + PRIVATE + TYPE LP IS RANGE 1 .. 100; + END PP; + + USE PP; + + TYPE REC IS RECORD + COMP : LP; + END RECORD; + + C : LP; + + REC_VAR : REC; + + GENERIC + TYPE T IS LIMITED PRIVATE; + IN_OUT_VAR : IN OUT T; + IN_OUT_TSK : IN OUT TSK; + VAL : IN OUT T; + WITH PROCEDURE INIT (L : IN OUT T; R : T); + PROCEDURE P; + + GENERIC + VAL : IN OUT LP; + PROCEDURE Q; + + GENERIC + VAL : IN OUT REC; + PROCEDURE R; + + PACKAGE BODY PP IS + PROCEDURE INIT(ONE : OUT LP; TWO : INTEGER) IS + BEGIN + ONE := LP(TWO); + END INIT; + + FUNCTION EQUAL(ONE : LP; TWO : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN ONE = LP(TWO); + END EQUAL; + END PP; + + TASK BODY TSK IS + BEGIN + ACCEPT E; + END TSK; + + PROCEDURE P IS + BEGIN + INIT(IN_OUT_VAR,VAL); + IN_OUT_TSK.E; + INIT(C,50); + END P; + + PROCEDURE Q IS + BEGIN + INIT(VAL,75); + INIT(REC_VAR.COMP,50); + END Q; + + PROCEDURE R IS + BEGIN + INIT(VAL.COMP,75); + END R; + + PROCEDURE I (ONE : IN OUT INTEGER; TWO : INTEGER) IS + BEGIN + ONE := TWO; + END I; + + PROCEDURE NEW_P IS NEW P(INTEGER,VAR,TSK_VAR,NEW_VAL,I); + + PROCEDURE NEW_Q IS NEW Q(C); + + PROCEDURE NEW_R IS NEW R(REC_VAR); + + BEGIN + TEST ("CC1104C", "CHECK THAT A GENERIC FORMAL IN OUT PARAMETER " & + "CAN HAVE A LIMITED TYPE"); + + NEW_P; + + IF NOT EQUAL(VAR,5) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 1"); + END IF; + + NEW_Q; + + IF NOT EQUAL(C,75) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 2"); + END IF; + + NEW_R; + + IF NOT EQUAL(REC_VAR.COMP,75) THEN + FAILED ("WRONG VALUE ASSIGNED TO IN OUT PARAMETER IN " & + "GENERIC PACKAGE - 3"); + END IF; + + RESULT; + END CC1104C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1107b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CC1107B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DEFAULT EXPRESSION MAY REFER TO AN EARLIER FORMAL + -- PARAMETER OF THE SAME GENERIC FORMAL PART. + + -- HISTORY: + -- BCB 08/03/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1107B IS + + J, I : INTEGER; + + X : INTEGER := IDENT_INT(0); + + VAL : INTEGER := IDENT_INT(10); + + GENERIC + X : INTEGER := IDENT_INT(5); + Y : INTEGER := X; + FUNCTION F RETURN INTEGER; + + GENERIC + X : INTEGER; + Y : INTEGER := X; + FUNCTION G RETURN INTEGER; + + FUNCTION F RETURN INTEGER IS + BEGIN + IF NOT EQUAL(X,Y) THEN + FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 1"); + END IF; + + RETURN 0; + END F; + + FUNCTION G RETURN INTEGER IS + BEGIN + IF NOT EQUAL(X,Y) THEN + FAILED ("WRONG VALUE FROM EARLIER FORMAL PARAMETER - 2"); + END IF; + + RETURN 0; + END G; + + FUNCTION NEW_F IS NEW F; + + FUNCTION NEW_G IS NEW G(VAL); + + BEGIN + TEST ("CC1107B", "CHECK THAT A DEFAULT EXPRESSION MAY REFER " & + "TO AN EARLIER FORMAL PARAMETER OF THE SAME " & + "GENERIC FORMAL PART"); + + J := NEW_F; + + I := NEW_G; + + RESULT; + END CC1107B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1111a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,322 ---- + -- CC1111A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AFTER A GENERIC UNIT IS INSTANTIATED, THE SUBTYPE OF + -- AN IN OUT OBJECT PARAMETER IS DETERMINED BY THE ACTUAL PARAMETER + -- (TESTS INTEGER, ENUMERATION, FLOATING POINT, FIXED POINT, ARRAY, + -- ACCESS, AND DISCRIMINATED TYPES). + + -- HISTORY: + -- BCB 03/28/88 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1111A IS + + SUBTYPE INT IS INTEGER RANGE 0..5; + INTVAR : INTEGER RANGE 1..3; + + TYPE ENUM IS (ONE, TWO, THREE, FOUR, FIVE, SIX, SEVEN, EIGHT); + SUBTYPE SUBENUM IS ENUM RANGE ONE .. FIVE; + ENUMVAR : ENUM RANGE TWO .. THREE; + + TYPE FLT IS DIGITS 5 RANGE -5.0 .. 5.0; + SUBTYPE SUBFLT IS FLT RANGE -1.0 .. 1.0; + FLTVAR : FLT RANGE 0.0 .. 1.0; + + TYPE FIX IS DELTA 0.5 RANGE -5.0 .. 5.0; + SUBTYPE SUBFIX IS FIX RANGE -1.0 .. 1.0; + FIXVAR : FIX RANGE 0.0 .. 1.0; + + SUBTYPE STR IS STRING (1..10); + STRVAR : STRING (1..5); + + TYPE REC (DISC : INTEGER := 5) IS RECORD + NULL; + END RECORD; + SUBTYPE SUBREC IS REC (6); + RECVAR : REC(5); + SUBRECVAR : SUBREC; + + TYPE ACCREC IS ACCESS REC; + SUBTYPE A1 IS ACCREC(1); + SUBTYPE A2 IS ACCREC(2); + A1VAR : A1 := NEW REC(1); + A2VAR : A2 := NEW REC(2); + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PRIVATE + TYPE PRIV IS RANGE 1 .. 100; + SUBTYPE SUBPRIV IS PRIV RANGE 5 .. 10; + PRIVVAR : PRIV RANGE 8 .. 10; + END P; + + PACKAGE BODY P IS + FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN; + + FUNCTION PRIVEQUAL (ONE, TWO : SUBPRIV) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO; + END PRIVEQUAL; + + GENERIC + INPUT : SUBPRIV; + OUTPUT : IN OUT SUBPRIV; + PROCEDURE I; + + PROCEDURE I IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "PRIVATE TYPE"); + IF PRIVEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END I; + + PROCEDURE I1 IS NEW I (5, PRIVVAR); + PROCEDURE I2 IS NEW I (SUBPRIV'FIRST, PRIVVAR); + + BEGIN + TEST ("CC1111A", "CHECK THAT AFTER A GENERIC UNIT IS " & + "INSTANTIATED, THE SUBTYPE OF AN IN OUT " & + "OBJECT PARAMETER IS DETERMINED BY THE " & + "ACTUAL PARAMETER (TESTS INTEGER, " & + "ENUMERATION, FLOATING POINT, FIXED POINT " & + ", ARRAY, ACCESS, AND DISCRIMINATED TYPES)"); + + I1; + I2; + END P; + + USE P; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GEN_IDENT (X : GP) RETURN GP; + + GENERIC + INPUT : INT; + OUTPUT : IN OUT INT; + PROCEDURE B; + + GENERIC + INPUT : SUBENUM; + OUTPUT : IN OUT SUBENUM; + PROCEDURE C; + + GENERIC + INPUT : SUBFLT; + OUTPUT : IN OUT SUBFLT; + PROCEDURE D; + + GENERIC + INPUT : SUBFIX; + OUTPUT : IN OUT SUBFIX; + PROCEDURE E; + + GENERIC + INPUT : STR; + OUTPUT : IN OUT STR; + PROCEDURE F; + + GENERIC + INPUT : A1; + OUTPUT : IN OUT A1; + PROCEDURE G; + + GENERIC + INPUT : SUBREC; + OUTPUT : IN OUT SUBREC; + PROCEDURE H; + + GENERIC + TYPE GP IS PRIVATE; + FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN; + + FUNCTION GENEQUAL (ONE, TWO : GP) RETURN BOOLEAN IS + BEGIN + RETURN ONE = TWO; + END GENEQUAL; + + FUNCTION GEN_IDENT (X : GP) RETURN GP IS + BEGIN + RETURN X; + END GEN_IDENT; + + FUNCTION INT_IDENT IS NEW GEN_IDENT (INT); + FUNCTION SUBENUM_IDENT IS NEW GEN_IDENT (SUBENUM); + FUNCTION SUBFLT_IDENT IS NEW GEN_IDENT (SUBFLT); + FUNCTION SUBFIX_IDENT IS NEW GEN_IDENT (SUBFIX); + + FUNCTION ENUMEQUAL IS NEW GENEQUAL (SUBENUM); + FUNCTION FLTEQUAL IS NEW GENEQUAL (SUBFLT); + FUNCTION FIXEQUAL IS NEW GENEQUAL (SUBFIX); + FUNCTION STREQUAL IS NEW GENEQUAL (STR); + FUNCTION ACCEQUAL IS NEW GENEQUAL (A2); + FUNCTION RECEQUAL IS NEW GENEQUAL (REC); + + PROCEDURE B IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "INTEGER TYPE"); + IF EQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END B; + + PROCEDURE C IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ENUMERATION TYPE"); + IF ENUMEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END C; + + PROCEDURE D IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "FLOATING POINT TYPE"); + IF FLTEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END D; + + PROCEDURE E IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "FIXED POINT TYPE"); + IF FIXEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END E; + + PROCEDURE F IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ARRAY TYPE"); + IF STREQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END F; + + PROCEDURE G IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "ACCESS TYPE"); + IF ACCEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END G; + + PROCEDURE H IS + BEGIN + OUTPUT := INPUT; + FAILED ("SUBTYPE NOT DETERMINED BY ACTUAL PARAMETER - " & + "DISCRIMINATED RECORD TYPE"); + IF RECEQUAL (OUTPUT, OUTPUT) THEN + COMMENT ("DON'T OPTIMIZE OUTPUT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END H; + + PROCEDURE B1 IS NEW B (4, INTVAR); + PROCEDURE C1 IS NEW C (FOUR, ENUMVAR); + PROCEDURE D1 IS NEW D (-1.0, FLTVAR); + PROCEDURE E1 IS NEW E (-1.0, FIXVAR); + PROCEDURE F1 IS NEW F ("9876543210", STRVAR); + PROCEDURE G1 IS NEW G (A1VAR, A2VAR); + PROCEDURE H1 IS NEW H (SUBRECVAR, RECVAR); + + PROCEDURE B2 IS NEW B (INT_IDENT(INT'FIRST), INTVAR); + PROCEDURE C2 IS NEW C (SUBENUM_IDENT(SUBENUM'FIRST), ENUMVAR); + PROCEDURE D2 IS NEW D (SUBFLT_IDENT(SUBFLT'FIRST), FLTVAR); + PROCEDURE E2 IS NEW E (SUBFIX_IDENT(SUBFIX'FIRST), FIXVAR); + + BEGIN + + B1; + C1; + D1; + E1; + F1; + G1; + H1; + + B2; + C2; + D2; + E2; + + RESULT; + END CC1111A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1204a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CC1204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC FORMAL TYPES MAY HAVE A DISCRIMINANT PART, + -- WHICH MAY BE OF A GENERIC FORMAL TYPE. + + -- DAT 8/14/81 + -- SPS 5/12/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1204A IS + BEGIN + TEST ("CC1204A", "DISCRIMINANT PARTS FOR GENERIC FORMAL TYPES"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + TYPE I IS RANGE <> ; + TYPE R1 (C : BOOLEAN) IS PRIVATE; + TYPE R2 (C : T) IS PRIVATE; + TYPE R3 (C : I) IS LIMITED PRIVATE; + P1 : IN R1; + P2 : IN R2; + V1 : IN OUT R1; + V2 : IN OUT R2; + V3 : IN OUT R3; + PROCEDURE PROC; + + TYPE DD IS NEW INTEGER RANGE 1 .. 10; + TYPE ARR IS ARRAY (DD RANGE <>) OF CHARACTER; + TYPE RECD (C : DD := DD (IDENT_INT (1))) IS + RECORD + C1 : ARR (1..C); + END RECORD; + + X1 : RECD; + X2 : RECD := (1, "Y"); + + TYPE RECB (C : BOOLEAN) IS + RECORD + V : INTEGER := 6; + END RECORD; + RB : RECB (IDENT_BOOL (TRUE)); + RB1 : RECB (IDENT_BOOL (TRUE)); + + PROCEDURE PROC IS + BEGIN + IF P1.C /= TRUE + OR P2.C /= T'FIRST + OR V1.C /= TRUE + OR V2.C /= T'FIRST + OR V3.C /= I'FIRST + THEN + FAILED ("WRONG GENERIC PARAMETER VALUE"); + END IF; + + V1 := P1; + V2 := P2; + + IF V1 /= P1 + OR V2 /= P2 + THEN + FAILED ("BAD ASSIGNMENT TO GENERIC PARAMETERS"); + END IF; + END PROC; + + BEGIN + RB1.V := IDENT_INT (1); + X1.C1 := "X"; + + DECLARE + + PROCEDURE PR IS NEW PROC + (T => DD, + I => DD, + R1 => RECB, + R2 => RECD, + R3 => RECD, + P1 => RB1, + P2 => X1, + V1 => RB, + V2 => X2, + V3 => X2); + BEGIN + PR; + IF RB /= (TRUE, 1) OR X2.C1 /= "X" THEN + FAILED ("PR NOT CALLED CORRECTLY"); + END IF; + END; + END; + + RESULT; + END CC1204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1207b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- CC1207B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN UNCONSTRAINED FORMAL TYPE WITH DISCRIMINANTS IS + -- ALLOWED AS THE TYPE OF A SUBPROGRAM OR AN ENTRY FORMAL + -- PARAMETER, AND AS THE TYPE OF A GENERIC FORMAL OBJECT PARAMETER, + -- AS A GENERIC ACTUAL PARAMETER, AND IN A MEMBERSHIP TEST, IN A + -- SUBTYPE DECLARATION, IN AN ACCESS TYPE DEFINITION, AND IN A + -- DERIVED TYPE DEFINITION. + + -- HISTORY: + -- BCB 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1207B IS + + GENERIC + TYPE X (L : INTEGER) IS PRIVATE; + PACKAGE PACK IS + END PACK; + + BEGIN + TEST ("CC1207B", "CHECK THAT AN UNCONSTRAINED FORMAL TYPE WITH " & + "DISCRIMINANTS IS ALLOWED AS THE TYPE OF A " & + "SUBPROGRAM OR AN ENTRY FORMAL PARAMETER, AND " & + "AS THE TYPE OF A GENERIC FORMAL OBJECT " & + "PARAMETER, AS A GENERIC ACTUAL PARAMETER, AND " & + "IN A MEMBERSHIP TEST, IN A SUBTYPE " & + "DECLARATION, IN AN ACCESS TYPE DEFINITION, " & + "AND IN A DERIVED TYPE DEFINITION"); + + DECLARE + TYPE REC (D : INTEGER := 3) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE R (D : INTEGER) IS PRIVATE; + OBJ : R; + PACKAGE P IS + PROCEDURE S (X : R); + + TASK T IS + ENTRY E (Y : R); + END T; + + SUBTYPE SUB_R IS R; + + TYPE ACC_R IS ACCESS R; + + TYPE NEW_R IS NEW R; + + BOOL : BOOLEAN := (OBJ IN R); + + SUB_VAR : SUB_R(5); + + ACC_VAR : ACC_R := NEW R(5); + + NEW_VAR : NEW_R(5); + + PACKAGE NEW_PACK IS NEW PACK (R); + END P; + + REC_VAR : REC(5) := (D => 5); + + PACKAGE BODY P IS + PROCEDURE S (X : R) IS + BEGIN + IF NOT EQUAL(X.D,5) THEN + FAILED ("WRONG DISCRIMINANT VALUE - S"); + END IF; + END S; + + TASK BODY T IS + BEGIN + ACCEPT E (Y : R) DO + IF NOT EQUAL(Y.D,5) THEN + FAILED ("WRONG DISCRIMINANT VALUE - T"); + END IF; + END E; + END T; + BEGIN + IF NOT EQUAL(OBJ.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE"); + END IF; + + S (OBJ); + + T.E (OBJ); + + IF NOT EQUAL(SUB_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - SUBTYPE"); + END IF; + + IF NOT EQUAL(ACC_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - ACCESS"); + END IF; + + IF NOT EQUAL(NEW_VAR.D,5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - DERIVED"); + END IF; + + IF NOT BOOL THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (REC,REC_VAR); + + BEGIN + NULL; + END; + + RESULT; + END CC1207B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1220a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- CC1220A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A GENERIC UNIT CAN REFER TO AN IMPLICITLY + -- DECLARED PREDEFINED OPERATOR. + + -- HISTORY: + -- DAT 08/20/81 CREATED ORIGINAL TEST. + -- SPS 05/03/82 + -- BCB 08/04/88 MODIFIED HEADER FORMAT AND ADDED CHECKS FOR OTHER + -- OPERATIONS OF A DISCRETE TYPE. + -- RJW 03/27/90 REVISED TEST TO CHECK FOR A GENERIC FORMAL + -- DISCRETE TYPE. + -- CJJ 10/14/90 ADDED CHECKS FOR RELATIONAL OPERATOR (<, <=, >, >=); + -- MADE FAILED MESSAGES IN PROCEDURE BODY MORE SPECIFIC. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CC1220A IS + + BEGIN + TEST ("CC1220A", "GENERIC UNIT CAN REFER TO IMPLICITLY " & + "DECLARED OPERATORS"); + + + DECLARE + + GENERIC + TYPE T IS (<>); + STR : STRING; + P1 : T := T'FIRST; + P2 : T := T(T'SUCC (P1)); + P3 : T := T'(T'PRED (P2)); + P4 : INTEGER := IDENT_INT(T'WIDTH); + P5 : BOOLEAN := (P1 < P2) AND (P2 > P3); + P6: BOOLEAN := (P1 <= P3) AND (P2 >= P1); + P7 : BOOLEAN := (P3 = P1); + P8 : T := T'BASE'FIRST; + P10 : T := T'LAST; + P11 : INTEGER := T'SIZE; + P12 : ADDRESS := P10'ADDRESS; + P13 : INTEGER := T'WIDTH; + P14 : INTEGER := T'POS(T'LAST); + P15 : T := T'VAL(1); + P16 : INTEGER := T'POS(P15); + P17 : STRING := T'IMAGE(T'BASE'LAST); + P18 : T := T'VALUE(P17); + P19 : BOOLEAN := (P15 IN T); + WITH FUNCTION IDENT (X : T) RETURN T; + PACKAGE PKG IS + ARR : ARRAY (1 .. 3) OF T := (P1,P2,P3); + B1 : BOOLEAN := P7 AND P19; + B2 : BOOLEAN := P5 AND P6; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF P1 /= T(T'FIRST) THEN + FAILED ("IMPROPER VALUE FOR 'FIRST - " & STR); + END IF; + + IF T'SUCC (P1) /= IDENT (P2) OR + T'PRED (P2) /= IDENT (P1) THEN + FAILED ("IMPROPER VALUE FOR 'SUCC, PRED - " & STR); + END IF; + + IF P10 /= T(T'LAST) THEN + FAILED ("IMPROPER VALUE FOR 'LAST - " & STR); + END IF; + + IF NOT EQUAL(P11,T'SIZE) THEN + FAILED ("IMPROPER VALUE FOR 'SIZE - " & STR); + END IF; + + IF NOT EQUAL(P13,T'WIDTH) THEN + FAILED ("IMPROPER VALUE FOR 'WIDTH - " & STR); + END IF; + + IF NOT EQUAL (P16, T'POS (P15)) OR + T'VAL (P16) /= T(IDENT (P15)) THEN + FAILED ("IMPROPER VALUE FOR 'POS, 'VAL - " & STR); + END IF; + + IF T'VALUE (P17) /= T'BASE'LAST OR + T'IMAGE (P18) /= T'IMAGE (T'BASE'LAST) THEN + FAILED ("IMPROPER VALUE FOR 'VALUE, 'IMAGE - " & + STR); + END IF; + END PKG; + + BEGIN + DECLARE + TYPE CHAR IS ('A', 'B', 'C', 'D', 'E'); + + FUNCTION IDENT (C : CHAR) RETURN CHAR IS + BEGIN + RETURN CHAR'VAL (IDENT_INT (CHAR'POS (C))); + END IDENT; + + PACKAGE N_CHAR IS NEW PKG (T => CHAR, STR => "CHAR", + IDENT => IDENT); + BEGIN + IF N_CHAR.ARR (1) /= IDENT ('A') OR + N_CHAR.ARR (2) /= IDENT ('B') OR + N_CHAR.ARR (3) /= 'A' OR + N_CHAR.B1 /= TRUE OR + N_CHAR.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_CHAR."); + END IF; + END; + + DECLARE + TYPE ENUM IS (JOVIAL, ADA, FORTRAN, BASIC); + + FUNCTION IDENT (C : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'VAL (IDENT_INT (ENUM'POS (C))); + END IDENT; + + PACKAGE N_ENUM IS NEW PKG (T => ENUM, STR => "ENUM", + IDENT => IDENT); + + BEGIN + IF N_ENUM.ARR (1) /= IDENT (JOVIAL) OR + N_ENUM.ARR (2) /= IDENT (ADA) OR + N_ENUM.ARR (3) /= JOVIAL OR + N_ENUM.B1 /= TRUE OR + N_ENUM.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_ENUM."); + END IF; + END; + + DECLARE + + PACKAGE N_INT IS NEW PKG (T => INTEGER, STR => "INTEGER", + IDENT => IDENT_INT); + BEGIN + IF N_INT.ARR (1) /= IDENT_INT (INTEGER'FIRST) OR + N_INT.ARR (2) /= IDENT_INT (INTEGER'FIRST + 1) OR + N_INT.ARR (3) /= INTEGER'FIRST OR + N_INT.B1 /= TRUE OR + N_INT.B2 /= TRUE THEN + FAILED ("IMPROPER VALUES FOR ARRAY COMPONENTS" & + " IN INSTANTIATION OF N_INT."); + END IF; + END; + END; + RESULT; + END CC1220A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- CC1221A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP, QUALIFICATION, + -- AND EXPLICIT CONVERSION TO AND FROM OTHER INTEGER TYPES. + + -- HISTORY: + -- RJW 09/26/86 CREATED ORIGINAL TEST. + -- BCB 11/12/87 CHANGED HEADER TO STANDARD FORMAT. SPLIT TEST + -- INTO PARTS A, B, C, AND D. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CC1221A IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + + BEGIN + TEST ( "CC1221A", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ASSIGNMENT, " & + "MEMBERSHIP, QUALIFICATION, AND EXPLICIT " & + "CONVERSION TO AND FROM OTHER INTEGER TYPES"); + + DECLARE -- (A) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART I. + + GENERIC + TYPE T IS RANGE <>; + TYPE T1 IS RANGE <>; + I : T; + I1 : T1; + PROCEDURE P (J : T; STR : STRING); + + PROCEDURE P (J : T; STR : STRING) IS + SUBTYPE ST IS T RANGE T'VAL (-1) .. T'VAL (1); + K, L : T; + + FUNCTION F (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END F; + + FUNCTION F (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END F; + + BEGIN + K := I; + L := J; + K := L; + + IF K /= J THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF I IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF J NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(I) /= I THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF F (T'(1)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + IF T (I1) /= I THEN + FAILED ( "INCORRECT RESULTS FOR EXPLICIT " & + "CONVERSION WITH TYPE - " & STR & + " - 1" ); + END IF; + + IF F (T (I1)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR EXPLICIT " & + "CONVERSION WITH TYPE - " & STR & + " - 2" ); + END IF; + + END P; + + PROCEDURE NP1 IS NEW P (SUBINT, SUBINT, 0, 0); + PROCEDURE NP2 IS NEW P (NEWINT, NEWINT, 0, 0); + PROCEDURE NP3 IS NEW P (INT, INT, 0, 0); + PROCEDURE NP4 IS NEW P (INTEGER, INTEGER, 0, 0); + + BEGIN + NP1 (2, "SUBINT"); + NP2 (2, "NEWINT"); + NP3 (2, "INT"); + NP4 (2, "INTEGER"); + END; -- (A). + + RESULT; + END CC1221A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- CC1221B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, 'LAST, 'WIDTH, + -- 'ADDRESS, AND 'SIZE. + + -- HISTORY: + -- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CC1221B IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + SUBTYPE NOINT IS INTEGER RANGE 1 .. -1; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + SUBTYPE SINT2 IS INT RANGE 16#E#E1 .. 2#1111_1111#; + TYPE INT2 IS RANGE 0E8 .. 1E3; + + BEGIN + TEST ( "CC1221B", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ATTRIBUTES 'FIRST, " & + "'LAST, 'WIDTH, 'ADDRESS, AND 'SIZE"); + + DECLARE -- (B) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART II. + + GENERIC + TYPE T IS RANGE <>; + F, L : T; + W : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + I : INTEGER := F'SIZE; + T1 : T; + A : ADDRESS := T1'ADDRESS; + + BEGIN + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'LAST" ); + END IF; + + IF T'BASE'FIRST > T'FIRST THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'FIRST" ); + END IF; + + IF T'BASE'LAST < T'LAST THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'LAST" ); + END IF; + + IF T'WIDTH /= W THEN + FAILED ( "INCORRECT VALUE FOR " & STR & + "'WIDTH" ); + END IF; + + IF T'BASE'WIDTH < T'WIDTH THEN + FAILED ( "INCORRECT RESULTS WITH " & STR & + "'BASE'WIDTH" ); + END IF; + + END P; + + GENERIC + TYPE T IS RANGE <>; + PROCEDURE Q; + + PROCEDURE Q IS + BEGIN + IF T'FIRST /= 1 THEN + FAILED ( "INCORRECT VALUE FOR NOINT'FIRST" ); + END IF; + + IF T'LAST /= -1 THEN + FAILED ( "INCORRECT VALUE FOR NOINT'LAST" ); + END IF; + + IF T'BASE'FIRST > T'FIRST THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'FIRST" ); + END IF; + + IF T'BASE'LAST < T'LAST THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'LAST" ); + END IF; + + IF T'WIDTH /= 0 THEN + FAILED ( "INCORRECT VALUE FOR " & + "NOINT'WIDTH" ); + END IF; + + IF T'BASE'WIDTH < T'WIDTH THEN + FAILED ( "INCORRECT RESULTS WITH " & + "NOINT'BASE'WIDTH" ); + END IF; + + END Q; + + PROCEDURE P1 IS NEW P (INTEGER, INTEGER'FIRST, INTEGER'LAST, + INTEGER'WIDTH); + PROCEDURE P2 IS NEW P (SUBINT, -100, 100, 4); + PROCEDURE P3 IS NEW P (NEWINT, NEWINT'FIRST, NEWINT'LAST, + NEWINT'WIDTH); + PROCEDURE P4 IS NEW P (SINT1, -4, 4, 2); + PROCEDURE P5 IS NEW P (SINT2, 224, 255, 4); + PROCEDURE P6 IS NEW P (INT2 , 0, 1000, 5); + + PROCEDURE Q1 IS NEW Q (NOINT); + + BEGIN + P1 ( "INTEGER" ); + P2 ( "SUBINT" ); + P3 ( "NEWINT" ); + P4 ( "SINT1" ); + P5 ( "SINT2" ); + P6 ( "INT2" ); + + Q1; + + END; -- (B). + + RESULT; + END CC1221B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,195 ---- + -- CC1221C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, 'VAL, 'PRED, 'SUCC, + -- 'IMAGE, AND 'VALUE. + + -- HISTORY: + -- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CC1221C IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE NEWINT IS NEW INTEGER; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + TYPE INT1 IS RANGE -6 .. 6; + + BEGIN + TEST ( "CC1221C", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: ATTRIBUTES 'POS, " & + "'VAL, 'PRED, 'SUCC, 'IMAGE, AND 'VALUE"); + + DECLARE -- (C1) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART III. + + GENERIC + TYPE T IS RANGE <>; + F : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + I : INTEGER; + Y : T; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'SUCC (T'FIRST); + END IF; + END IDENT; + + BEGIN + I := F; + FOR X IN T LOOP + IF T'VAL (I) /= X THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'VAL OF " & INTEGER'IMAGE (I)); + END IF; + + IF T'POS (X) /= I THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'POS OF " & T'IMAGE (X)); + END IF; + + I := I + 1; + END LOOP; + + FOR X IN T LOOP + IF T'SUCC (X) /= T'VAL (T'POS (X) + 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'SUCC OF " & T'IMAGE (X)); + END IF; + + IF T'PRED (X) /= T'VAL (T'POS (X) - 1) THEN + FAILED ( "WRONG VALUE FOR " & STR & + "'PRED OF " & T'IMAGE (X)); + END IF; + END LOOP; + + BEGIN + Y := T'SUCC (IDENT (T'BASE'LAST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'SUCC (IDENT (" & STR & + "'BASE'LAST))" ); + END; + + BEGIN + Y := T'PRED (IDENT (T'BASE'FIRST)); + FAILED ( "NO EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED FOR " & + STR & "'PRED (IDENT (" & STR & + "'BASE'FIRST))" ); + END; + + END P; + + PROCEDURE P1 IS NEW P (SUBINT, -100); + PROCEDURE P2 IS NEW P (SINT1, -4); + PROCEDURE P3 IS NEW P (INT1, -6); + + BEGIN + P1 ( "SUBINT" ); + P2 ( "SINT" ); + P3 ( "INT1" ); + END; -- (C1). + + DECLARE -- (C2) CHECKS FOR BASIC OPERATIONS OF A DISCRETE TYPE. + -- PART IV. + + GENERIC + TYPE T IS RANGE <>; + STR : STRING; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + PROCEDURE P (IM : STRING; VA : T) IS + BEGIN + IF T'IMAGE (VA) /= IM THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'IMAGE OF " & + INTEGER'IMAGE (INTEGER (VA))); + END IF; + END P; + + PROCEDURE Q (IM : STRING; VA : T) IS + BEGIN + IF T'VALUE (IM) /= VA THEN + FAILED ( "INCORRECT RESULTS FOR " & STR & + "'VALUE OF " & IM); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED FOR " & + STR &"'VALUE OF " & IM); + WHEN OTHERS => + FAILED ( "OTHER EXCEPTION RAISED FOR " & + STR &"'VALUE OF " & IM); + + END Q; + + BEGIN + P (" 2", 2); + P ("-1", -1); + + Q (" 2", 2); + Q ("-1", -1); + Q (" 2", 2); + Q ("-1 ", -1); + END PKG; + + PACKAGE PKG1 IS NEW PKG (SUBINT, "SUBINT"); + PACKAGE PKG2 IS NEW PKG (SINT1, "SINT1"); + PACKAGE PKG3 IS NEW PKG (INT1, "INT1"); + PACKAGE PKG4 IS NEW PKG (NEWINT, "NEWINT"); + + BEGIN + NULL; + END; -- (C2). + + RESULT; + END CC1221C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1221d.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- CC1221D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A FORMAL INTEGER TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: EXPLICIT CONVERSION TO AND FROM REAL + -- TYPES AND IMPLICIT CONVERSION FROM INTEGER LITERALS. + + -- HISTORY: + -- BCB 11/12/87 CREATED ORIGINAL TEST FROM SPLIT OF CC1221A.ADA + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CC1221D IS + + SUBTYPE SUBINT IS INTEGER RANGE -100 .. 100; + TYPE INT IS RANGE -300 .. 300; + SUBTYPE SINT1 IS INT + RANGE INT (IDENT_INT (-4)) .. INT (IDENT_INT (4)); + TYPE INT1 IS RANGE -6 .. 6; + + BEGIN + TEST ( "CC1221D", "FOR A FORMAL INTEGER TYPE, CHECK THAT THE " & + "FOLLOWING BASIC OPERATIONS ARE IMPLICITLY " & + "DECLARED AND ARE THEREFORE AVAILABLE " & + "WITHIN THE GENERIC UNIT: EXPLICIT " & + "CONVERSION TO AND FROM REAL TYPES AND " & + "IMPLICIT CONVERSION FROM INTEGER LITERALS"); + + DECLARE -- (D) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- INTEGER LITERALS. + + GENERIC + TYPE T IS RANGE <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + FI0 : FIXED := 0.0; + FI2 : FIXED := 2.0; + FIN2 : FIXED := -2.0; + + FL0 : FLOAT := 0.0; + FL2 : FLOAT := 2.0; + FLN2 : FLOAT := -2.0; + + T0 : T := 0; + T2 : T := 2; + TN2 : T := -2; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1 /= 1 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1 /= 3 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1 /= -1 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FI0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FI2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FIN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (FL0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FL2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FLN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (T0) /= FI0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FIXED (IDENT (T2)) /= FI2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (TN2) /= FIN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (T0)) /= FL0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (T2) /= FL2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (TN2)) /= FLN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (SUBINT); + PROCEDURE P2 IS NEW P (SINT1); + PROCEDURE P3 IS NEW P (INT1); + + BEGIN + P1 ( "SUBINT" ); + P2 ( "SINT" ); + P3 ( "INT1" ); + END; -- (D). + + RESULT; + END CC1221D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1222a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,290 ---- + -- CC1222A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- FOR A FORMAL FLOATING POINT TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS, + -- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC TYPES, + -- AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL TO THE + -- FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DIGITS, 'MACHINE_RADIX, + -- 'MACHINE_MANTISSA, 'MACHINE_EMAX, 'MACHINE_EMIN, 'MACHINE_ROUNDS, + -- 'MACHINE_OVERFLOWS. + + -- R.WILLIAMS 9/30/86 + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + PROCEDURE CC1222A IS + + TYPE NEWFLT IS NEW FLOAT; + + BEGIN + TEST ( "CC1222A", "FOR A FORMAL FLOATING POINT TYPE, CHECK " & + "THAT THE BASIC OPERATIONS ARE " & + "IMPLICITLY DECLARED AND ARE THEREFORE " & + "AVAILABLE WITHIN THE GENERIC UNIT" ); + + DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND + -- QUALIFICATION. + + GENERIC + TYPE T IS DIGITS <>; + TYPE T1 IS DIGITS <>; + F : T; + F1 : T1; + PROCEDURE P (F2 : T; STR : STRING); + + PROCEDURE P (F2 : T; STR : STRING) IS + SUBTYPE ST IS T RANGE -1.0 .. 1.0; + F3, F4 : T; + + FUNCTION FUN (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END FUN; + + FUNCTION FUN (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END FUN; + + BEGIN + F3 := F; + F4 := F2; + F3 := F4; + + IF F3 /= F2 THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF F IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF F2 NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(F) /= F THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF FUN (T'(1.0)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FLOAT, FLOAT, 0.0, 0.0); + PROCEDURE P2 IS NEW P (NEWFLT, NEWFLT, 0.0, 0.0); + + BEGIN + P1 (2.0, "FLOAT"); + P2 (2.0, "NEWFLT"); + END; -- (A). + + DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- REAL LITERAL. + + GENERIC + TYPE T IS DIGITS <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + FI0 : FIXED := 0.0; + FI2 : FIXED := 2.0; + FIN2 : FIXED := -2.0; + + I0 : INTEGER := 0; + I2 : INTEGER := 2; + IN2 : INTEGER := -2; + + T0 : T := 0.0; + T2 : T := 2.0; + TN2 : T := -2.0; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1.0 /= 1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1.0 /= 3.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1.0 /= -1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FI0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FI2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FIN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (I0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF T (I2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF T (IN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + IF FIXED (T0) /= FI0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FIXED (IDENT (T2)) /= FI2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FIXED (TN2) /= FIN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FIXED VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (T0)) /= I0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF INTEGER (T2) /= I2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (TN2)) /= IN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FLOAT); + PROCEDURE P2 IS NEW P (NEWFLT); + + BEGIN + P1 ( "FLOAT" ); + P2 ( "NEWFLT" ); + END; -- (B). + + DECLARE -- (C) CHECKS FOR ATTRIBUTES. + + GENERIC + TYPE T IS DIGITS <>; + F, L : T; + D : INTEGER; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + F1 : T; + A : ADDRESS := F'ADDRESS; + S : INTEGER := F'SIZE; + + I : INTEGER; + I1 : INTEGER := T'MACHINE_RADIX; + I2 : INTEGER := T'MACHINE_MANTISSA; + I3 : INTEGER := T'MACHINE_EMAX; + I4 : INTEGER := T'MACHINE_EMIN; + + B1 : BOOLEAN := T'MACHINE_ROUNDS; + B2 : BOOLEAN := T'MACHINE_OVERFLOWS; + + BEGIN + IF T'DIGITS /= D THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'DIGITS" ); + END IF; + + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'LAST" ); + END IF; + + END P; + + PROCEDURE P1 IS + NEW P (FLOAT, FLOAT'FIRST, FLOAT'LAST, FLOAT'DIGITS); + PROCEDURE P2 IS + NEW P (NEWFLT, NEWFLT'FIRST, NEWFLT'LAST, + NEWFLT'DIGITS); + + BEGIN + P1 ( "FLOAT" ); + P2 ( "NEWFLT" ); + END; -- (C). + + RESULT; + END CC1222A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1223a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,297 ---- + -- CC1223A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A FORMAL FIXED POINT TYPE, CHECK THAT THE FOLLOWING BASIC + -- OPERATIONS ARE IMPLICITLY DECLARED AND ARE THEREFORE AVAILABLE + -- WITHIN THE GENERIC UNIT: ASSIGNMENT, MEMBERSHIP TESTS, + -- QUALIFICATION, EXPLICIT CONVERSION TO AND FROM OTHER NUMERIC + -- TYPES, AND REAL LITERALS (IMPLICIT CONVERSION FROM UNIVERSAL REAL + -- TO THE FORMAL TYPE), 'FIRST, 'LAST, 'SIZE, 'ADDRESS, 'DELTA, 'FORE, + -- 'AFT, 'MACHINE_ROUNDS, 'MACHINE_OVERFLOWS. + + -- HISTORY: + -- RJW 09/30/86 CREATED ORIGINAL TEST. + -- JLH 09/25/87 REFORMATTED HEADER. + -- RJW 08/21/89 MODIFIED CHECKS FOR 'MANTISSA AND 'AFT. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CC1223A IS + + TYPE FIXED IS DELTA 0.1 RANGE -100.0 .. 100.0; + + BEGIN + TEST ( "CC1223A", "FOR A FORMAL FIXED POINT TYPE, CHECK " & + "THAT THE BASIC OPERATIONS ARE " & + "IMPLICITLY DECLARED AND ARE THEREFORE " & + "AVAILABLE WITHIN THE GENERIC UNIT" ); + + DECLARE -- (A). CHECKS FOR ASSIGNMENT, MEMBERSHIP TESTS AND + -- QUALIFICATION. + + GENERIC + TYPE T IS DELTA <>; + TYPE T1 IS DELTA <>; + F : T; + F1 : T1; + PROCEDURE P (F2 : T; STR : STRING); + + PROCEDURE P (F2 : T; STR : STRING) IS + SUBTYPE ST IS T RANGE -1.0 .. 1.0; + F3, F4 : T; + + FUNCTION FUN (X : T) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (TRUE); + END FUN; + + FUNCTION FUN (X : T1) RETURN BOOLEAN IS + BEGIN + RETURN IDENT_BOOL (FALSE); + END FUN; + + BEGIN + F3 := F; + F4 := F2; + F3 := F4; + + IF F3 /= F2 THEN + FAILED ( "INCORRECT RESULTS FOR ASSIGNMENT " & + "WITH TYPE - " & STR); + END IF; + + IF F IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF F2 NOT IN ST THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR ""NOT IN"" WITH " & + "TYPE - " & STR); + END IF; + + IF T'(F) /= F THEN + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 1" ); + END IF; + + IF FUN (T'(1.0)) THEN + NULL; + ELSE + FAILED ( "INCORRECT RESULTS FOR QUALIFICATION " & + "WITH TYPE - " & STR & " - 2" ); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FIXED, FIXED, 0.0, 0.0); + PROCEDURE P2 IS NEW P (DURATION, DURATION, 0.0, 0.0); + + BEGIN + P1 (2.0, "FIXED"); + P2 (2.0, "DURATION"); + END; -- (A). + + DECLARE -- (B) CHECKS FOR EXPLICIT CONVERSION TO AND FROM OTHER + -- NUMERIC TYPES, AND IMPLICIT CONVERSION FROM + -- REAL LITERAL. + + GENERIC + TYPE T IS DELTA <>; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + FL0 : FLOAT := 0.0; + FL2 : FLOAT := 2.0; + FLN2 : FLOAT := -2.0; + + I0 : INTEGER := 0; + I2 : INTEGER := 2; + IN2 : INTEGER := -2; + + T0 : T := 0.0; + T2 : T := 2.0; + TN2 : T := -2.0; + + FUNCTION IDENT (X : T) RETURN T IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN T'FIRST; + END IF; + END IDENT; + + BEGIN + IF T0 + 1.0 /= 1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 1" ); + END IF; + + IF T2 + 1.0 /= 3.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 2" ); + END IF; + + IF TN2 + 1.0 /= -1.0 THEN + FAILED ( "INCORRECT RESULTS FOR IMPLICIT " & + "CONVERSION WITH TYPE " & STR & " - 3" ); + END IF; + + IF T (FL0) /= T0 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF T (FL2) /= IDENT (T2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF T (FLN2) /= TN2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF T (I0) /= IDENT (T0) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF T (I2) /= T2 THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF T (IN2) /= IDENT (TN2) THEN + FAILED ( "INCORRECT CONVERSION FROM " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + IF FLOAT (T0) /= FL0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 0.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (IDENT (T2)) /= FL2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE 2.0 WITH TYPE " & STR); + END IF; + + IF FLOAT (TN2) /= FLN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "FLOAT VALUE -2.0 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (T0)) /= I0 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 0 WITH TYPE " & STR); + END IF; + + IF INTEGER (T2) /= I2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE 2 WITH TYPE " & STR); + END IF; + + IF INTEGER (IDENT (TN2)) /= IN2 THEN + FAILED ( "INCORRECT CONVERSION TO " & + "INTEGER VALUE -2 WITH TYPE " & STR); + END IF; + + END P; + + PROCEDURE P1 IS NEW P (FIXED); + PROCEDURE P2 IS NEW P (DURATION); + + BEGIN + P1 ( "FIXED" ); + P2 ( "DURATION" ); + END; -- (B). + + DECLARE -- (C) CHECKS FOR ATTRIBUTES. + + GENERIC + TYPE T IS DELTA <>; + F, L, D : T; + PROCEDURE P (STR : STRING); + + PROCEDURE P (STR : STRING) IS + + F1 : T; + A : ADDRESS := F'ADDRESS; + S : INTEGER := F'SIZE; + + I : INTEGER; + + B1 : BOOLEAN := T'MACHINE_ROUNDS; + B2 : BOOLEAN := T'MACHINE_OVERFLOWS; + + BEGIN + IF T'DELTA /= D THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'DELTA" ); + END IF; + + IF T'FIRST /= F THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FIRST" ); + END IF; + + IF T'LAST /= L THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'LAST" ); + END IF; + + IF T'FORE < 2 THEN + FAILED ( "INCORRECT VALUE FOR " & + STR & "'FORE" ); + END IF; + + IF T'AFT <= 0 THEN + FAILED ( "INCORRECT VALUE FOR " & STR & "'AFT" ); + END IF; + + END P; + + PROCEDURE P1 IS + NEW P (FIXED, FIXED'FIRST, FIXED'LAST, FIXED'DELTA); + PROCEDURE P2 IS + NEW P (DURATION, DURATION'FIRST, DURATION'LAST, + DURATION'DELTA); + + BEGIN + P1 ( "FIXED" ); + P2 ( "DURATION" ); + END; -- (C). + + RESULT; + END CC1223A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1224a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,558 ---- + -- CC1224A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR ARRAY TYPES WITH A NONLIMITED COMPONENT TYPE (OF A FORMAL + -- AND NONFORMAL GENERIC TYPE), CHECK THAT THE FOLLOWING OPERATIONS + -- ARE IMPLICITY DECLARED AND ARE, THEREFORE, AVAILABLE WITHIN THE + -- GENERIC UNIT: ASSIGNMENT, THE OPERATION ASSOCIATED WITH + -- AGGREGATE NOTATION, MEMBERSHIP TESTS, THE OPERATION ASSOCIATED + -- WITH INDEXED COMPONENTS, QUALIFICATION, EXPLICIT CONVERSION, + -- 'SIZE, 'ADDRESS, 'FIRST, 'FIRST (N), 'LAST, 'LAST (N), + -- 'RANGE, 'RANGE (N), 'LENGTH, 'LENGTH (N). + + -- HISTORY: + -- R.WILLIAMS 10/6/86 + -- EDWARD V. BERARD 8/10/90 ADDED CHECKS FOR MULTI-DIMENSIONAL + -- ARRAYS + -- LDC 10/10/90 CHANGED DECLARATIONS OF AD1 - AD6 TO PROCEDURE + -- CALLS OF FA1 - FA6 TO ADDRESS_CHECK AS SUGGESTED + -- BY THE CRG. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH SYSTEM ; + WITH REPORT ; + + PROCEDURE CC1224A IS + + SHORT_START : CONSTANT := -10 ; + SHORT_END : CONSTANT := 10 ; + + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + SHORT_LENGTH : CONSTANT NATURAL := (SHORT_END - SHORT_START + 1) ; + + MEDIUM_START : CONSTANT := 1 ; + MEDIUM_END : CONSTANT := 15 ; + + TYPE MEDIUM_RANGE IS RANGE MEDIUM_START .. MEDIUM_END ; + MEDIUM_LENGTH : CONSTANT NATURAL := + (MEDIUM_END - MEDIUM_START + 1) ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (AUG, 10, 1990) ; + + TYPE FIRST_TEMPLATE IS ARRAY (SHORT_RANGE RANGE <>, + MEDIUM_RANGE RANGE <>) OF DATE ; + + TYPE SECOND_TEMPLATE IS ARRAY (SHORT_RANGE, MEDIUM_RANGE) + OF DATE ; + + FIRST_ARRAY : FIRST_TEMPLATE (-10 .. 10, 6 .. 10) ; + SECOND_ARRAY : FIRST_TEMPLATE (0 .. 7, 1 .. 15) ; + THIRD_ARRAY : SECOND_TEMPLATE ; + FOURTH_ARRAY : SECOND_TEMPLATE ; + + SUBTYPE SUBINT IS INTEGER RANGE REPORT.IDENT_INT (1) .. + REPORT.IDENT_INT (6); + + TYPE ARRA IS ARRAY (SUBINT) OF SUBINT; + A1 : ARRA := (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => 1); + A2 : ARRA := (A1'RANGE => 2); + + TYPE ARRB IS ARRAY (SUBINT RANGE <>) OF DATE ; + A3 : ARRB (1 .. 6) := + (REPORT.IDENT_INT (1) .. REPORT.IDENT_INT (6) => TODAY); + + TYPE ARRC IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF SUBINT; + A4 : CONSTANT ARRC := (1 .. 6 => (1 .. 6 => 4)); + + TYPE ARRD IS ARRAY (SUBINT, SUBINT) OF SUBINT; + A5 : ARRD := (A4'RANGE (1) => (A4'RANGE (2) => 5)); + + TYPE ARRE IS ARRAY (SUBINT) OF DATE ; + A6 : ARRE := (A1'RANGE => TODAY); + + FUNCTION "=" (LEFT : IN SYSTEM.ADDRESS ; + RIGHT : IN SYSTEM.ADDRESS ) RETURN BOOLEAN + RENAMES SYSTEM."=" ; + + GENERIC + + TYPE T1 IS (<>); + TYPE T2 IS PRIVATE; + X2 : T2; + + TYPE FARR1 IS ARRAY (SUBINT) OF T1; + FA1 : FARR1; + + TYPE FARR2 IS ARRAY (SUBINT) OF SUBINT; + FA2 : FARR2; + + TYPE FARR3 IS ARRAY (SUBINT RANGE <>) OF T2; + FA3 : FARR3; + + TYPE FARR4 IS ARRAY (SUBINT RANGE <>, SUBINT RANGE <>) OF T1; + FA4 : FARR4; + + TYPE FARR5 IS ARRAY (SUBINT, SUBINT) OF SUBINT; + FA5 : FARR5; + + TYPE FARR6 IS ARRAY (T1) OF T2; + FA6 : FARR6; + + TYPE FARR7 IS ARRAY (T1) OF T2; + FA7 : FARR7; + + PROCEDURE P ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE UNCONSTRAINED_ARRAY IS ARRAY + (FIRST_INDEX RANGE <>, SECOND_INDEX RANGE <>) OF DATE ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + TYPE CONSTRAINED_ARRAY IS ARRAY + (FIRST_INDEX,SECOND_INDEX) OF COMPONENT_TYPE ; + + PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN CONSTRAINED_ARRAY ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) ; + + + PROCEDURE P IS + + IN1 : INTEGER := FA1'SIZE; + IN2 : INTEGER := FA2'SIZE; + IN3 : INTEGER := FA3'SIZE; + IN4 : INTEGER := FA4'SIZE; + IN5 : INTEGER := FA5'SIZE; + IN6 : INTEGER := FA6'SIZE; + + B1 : FARR1; + + B2 : FARR2; + + SUBTYPE SARR3 IS FARR3 (FA3'RANGE); + B3 : SARR3; + + SUBTYPE SARR4 IS FARR4 (FA4'RANGE (1), FA4'RANGE (2)); + B4 : SARR4; + + B5 : FARR5; + + B6 : FARR6 ; + + PROCEDURE ADDRESS_CHECK(ADDRESS : SYSTEM.ADDRESS) IS + + BEGIN + IF REPORT.EQUAL(1, REPORT.IDENT_INT(2)) THEN + REPORT.COMMENT("DON'T OPTIMIZE OUT ADDRESS_CHECK"); + END IF; + END ADDRESS_CHECK; + + BEGIN -- P + + ADDRESS_CHECK(FA1'ADDRESS); + ADDRESS_CHECK(FA2'ADDRESS); + ADDRESS_CHECK(FA3'ADDRESS); + ADDRESS_CHECK(FA4'ADDRESS); + ADDRESS_CHECK(FA5'ADDRESS); + ADDRESS_CHECK(FA6'ADDRESS); + + B1 := FA1; + + IF B1 /= FARR1 (FA1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 1" ); + END IF; + + B2 := FA2; + + IF B2 /= FARR2 (A2) THEN + REPORT.FAILED ("INCORRECT RESULTS - 2" ); + END IF; + + B3 := FA3; + + IF B3 /= FARR3 (FA3) THEN + REPORT.FAILED ("INCORRECT RESULTS - 3" ); + END IF; + + B4 := FA4; + + IF B4 /= FARR4 (FA4) THEN + REPORT.FAILED ("INCORRECT RESULTS - 4" ); + END IF; + + B5 := FA5; + + IF B5 /= FARR5 (A5) THEN + REPORT.FAILED ("INCORRECT RESULTS - 5" ); + END IF; + + B6 := FA6; + + IF B6 /= FARR6 (FA6) THEN + REPORT.FAILED ("INCORRECT RESULTS - 6" ); + END IF; + + IF FA7 /= FARR7 (FA6) THEN + REPORT.FAILED ("INCORRECT RESULTS - 7" ); + END IF; + + B1 := FARR1'(FA1'RANGE => T1'VAL (1)); + + IF B1 (1) /= FA1 (1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 8" ); + END IF; + + B1 := FARR1'(1 => T1'VAL (1), 2 => T1'VAL (1), + 3 .. 6 => T1'VAL (2)); + + IF B1 (1) /= FA1 (1) THEN + REPORT.FAILED ("INCORRECT RESULTS - 9" ); + END IF; + + B2 := FARR2'(FA2'RANGE => 2); + + IF B2 (2) /= FA2 (2) THEN + REPORT.FAILED ("INCORRECT RESULTS - 10" ); + END IF; + + B3 := FARR3'(1|2|3 => X2, 4|5|6 => X2); + + IF B3 (3) /= FA3 (3) THEN + REPORT.FAILED ("INCORRECT RESULTS - 11" ); + END IF; + + B4 := FARR4'(FA5'RANGE (1) => (FA5'RANGE (2) => T1'VAL (4))); + + IF B4 (4, 4) /= FA4 (4, 4) THEN + REPORT.FAILED ("INCORRECT RESULTS - 12" ); + END IF; + + B5 := FARR5'(REPORT.IDENT_INT (1) .. + REPORT.IDENT_INT (6) => (1 .. 6 => 5)); + + IF B5 (5, 5) /= FA5 (5, 5) THEN + REPORT.FAILED ("INCORRECT RESULTS - 13" ); + END IF; + + B6 := FARR6'(FA6'RANGE => X2); + + IF B6 (T1'FIRST) /= FA6 (T1'FIRST) THEN + REPORT.FAILED ("INCORRECT RESULTS - 14" ); + END IF; + + IF B1 NOT IN FARR1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 15" ); + END IF; + + IF FA2 NOT IN FARR2 THEN + REPORT.FAILED ("INCORRECT RESULTS - 16" ); + END IF; + + IF FA3 NOT IN FARR3 THEN + REPORT.FAILED ("INCORRECT RESULTS - 17" ); + END IF; + + IF B4 NOT IN FARR4 THEN + REPORT.FAILED ("INCORRECT RESULTS - 18" ); + END IF; + + IF B5 NOT IN FARR5 THEN + REPORT.FAILED ("INCORRECT RESULTS - 19" ); + END IF; + + IF FA6 NOT IN FARR6 THEN + REPORT.FAILED ("INCORRECT RESULTS - 20" ); + END IF; + + IF FA1'LENGTH /= FA1'LAST - FA1'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 27" ); + END IF; + + IF FA2'LENGTH /= FA2'LAST - FA2'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 28" ); + END IF; + + IF FA3'LENGTH /= FA3'LAST - FA3'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 29" ); + END IF; + + IF FA4'LENGTH /= FA4'LAST - FA4'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 30" ); + END IF; + + IF FA4'LENGTH (2) /= FA4'LAST (2) - FA4'FIRST (2) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 31" ); + END IF; + + IF FA5'LENGTH /= FA5'LAST - FA5'FIRST + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 32" ); + END IF; + + IF FA5'LENGTH (2) /= FA5'LAST (2) - FA5'FIRST (2) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 33" ); + END IF; + + IF FA6'LENGTH /= T1'POS (FA6'LAST) - + T1'POS (FA6'FIRST) + 1 THEN + REPORT.FAILED ("INCORRECT RESULTS - 34" ); + END IF; + + END P ; + + PROCEDURE TEST_PROCEDURE (FIRST : IN UNCONSTRAINED_ARRAY ; + FFIFS : IN FIRST_INDEX ; + FFILS : IN FIRST_INDEX ; + FSIFS : IN SECOND_INDEX ; + FSILS : IN SECOND_INDEX ; + FFLEN : IN NATURAL ; + FSLEN : IN NATURAL ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN UNCONSTRAINED_ARRAY ; + SFIFS : IN FIRST_INDEX ; + SFILS : IN FIRST_INDEX ; + SSIFS : IN SECOND_INDEX ; + SSILS : IN SECOND_INDEX ; + SFLEN : IN NATURAL ; + SSLEN : IN NATURAL ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- TEST_PROCEDURE + + IF (FIRST'FIRST /= FFIFS) OR + (FIRST'FIRST (1) /= FFIFS) OR + (FIRST'FIRST (2) /= FSIFS) OR + (SECOND'FIRST /= SFIFS) OR + (SECOND'FIRST (1) /= SFIFS) OR + (SECOND'FIRST (2) /= SSIFS) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FFILS) OR + (FIRST'LAST (1) /= FFILS) OR + (FIRST'LAST (2) /= FSILS) OR + (SECOND'LAST /= SFILS) OR + (SECOND'LAST (1) /= SFILS) OR + (SECOND'LAST (2) /= SSILS) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= FFLEN) OR + (FIRST'LENGTH (1) /= FFLEN) OR + (FIRST'LENGTH (2) /= FSLEN) OR + (SECOND'LENGTH /= SFLEN) OR + (SECOND'LENGTH (1) /= SFLEN) OR + (SECOND'LENGTH (2) /= SSLEN) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " & + REMARKS) ; + END IF ; + + END TEST_PROCEDURE ; + + PROCEDURE CTEST_PROCEDURE (FIRST : IN CONSTRAINED_ARRAY ; + FFIRT : IN FIRST_INDEX ; + FSIRT : IN SECOND_INDEX ; + SECOND : IN CONSTRAINED_ARRAY ; + SFIRT : IN FIRST_INDEX ; + SSIRT : IN SECOND_INDEX ; + REMARKS : IN STRING) IS + + BEGIN -- CTEST_PROCEDURE + + IF (FIRST'FIRST /= FIRST_INDEX'FIRST) OR + (FIRST'FIRST (1) /= FIRST_INDEX'FIRST) OR + (FIRST'FIRST (2) /= SECOND_INDEX'FIRST) OR + (SECOND'FIRST /= FIRST_INDEX'FIRST) OR + (SECOND'FIRST (1) /= FIRST_INDEX'FIRST) OR + (SECOND'FIRST (2) /= SECOND_INDEX'FIRST) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST. " & REMARKS) ; + END IF ; + + IF (FIRST'LAST /= FIRST_INDEX'LAST) OR + (FIRST'LAST (1) /= FIRST_INDEX'LAST) OR + (FIRST'LAST (2) /= SECOND_INDEX'LAST) OR + (SECOND'LAST /= FIRST_INDEX'LAST) OR + (SECOND'LAST (1) /= FIRST_INDEX'LAST) OR + (SECOND'LAST (2) /= SECOND_INDEX'LAST) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST. " & REMARKS) ; + END IF ; + + IF (FIRST'LENGTH /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (FIRST'LENGTH (1) /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (FIRST'LENGTH (2) /= + SECOND_INDEX'POS (SECOND_INDEX'LAST) + - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) OR + (SECOND'LENGTH /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (SECOND'LENGTH (1) /= + FIRST_INDEX'POS (FIRST_INDEX'LAST) + - FIRST_INDEX'POS (FIRST_INDEX'FIRST) + 1) OR + (SECOND'LENGTH (2) /= + SECOND_INDEX'POS (SECOND_INDEX'LAST) + - SECOND_INDEX'POS (SECOND_INDEX'FIRST) + 1) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH. " & REMARKS) ; + END IF ; + + IF (FFIRT NOT IN FIRST'RANGE (1)) OR + (FFIRT NOT IN FIRST'RANGE) OR + (SFIRT NOT IN SECOND'RANGE (1)) OR + (SFIRT NOT IN SECOND'RANGE) OR + (FSIRT NOT IN FIRST'RANGE (2)) OR + (SSIRT NOT IN SECOND'RANGE (2)) THEN + REPORT.FAILED ("INCORRECT HANDLING OF 'RANGE ATTRIBUE. " & + REMARKS) ; + END IF ; + + IF CONSTRAINED_ARRAY'SIZE <= 0 THEN + REPORT.FAILED ("PROBLEMS WITH THE 'SIZE ATTRIBUTE. " & + REMARKS) ; + END IF ; + + IF FIRST'ADDRESS = SECOND'ADDRESS THEN + REPORT.FAILED ("PROBLEMS WITH THE 'ADDRESS ATTRIBUTE. " & + REMARKS) ; + END IF ; + + END CTEST_PROCEDURE ; + + PROCEDURE FIRST_TEST_PROCEDURE IS NEW TEST_PROCEDURE + (FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + UNCONSTRAINED_ARRAY => FIRST_TEMPLATE) ; + + PROCEDURE NEW_CTEST_PROCEDURE IS NEW CTEST_PROCEDURE + (FIRST_INDEX => SHORT_RANGE, + SECOND_INDEX => MEDIUM_RANGE, + COMPONENT_TYPE => DATE, + CONSTRAINED_ARRAY => SECOND_TEMPLATE) ; + + PROCEDURE NP IS NEW P (SUBINT, DATE, TODAY, ARRA, A1, + ARRA, A2, ARRB, A3, ARRC, A4, ARRD, + A5, ARRE, A6, ARRE, A6); + + BEGIN -- CC1224A + + REPORT.TEST ("CC1224A", "FOR ARRAY TYPES WITH A NONLIMITED " & + "COMPONENT TYPE (OF A FORMAL AND NONFORMAL GENERIC " & + "TYPE), CHECK THAT THE FOLLOWING OPERATIONS " & + "ARE IMPLICITY DECLARED AND ARE, THEREFORE, " & + "AVAILABLE WITHIN THE GENERIC -- UNIT: " & + "ASSIGNMENT, THE OPERATION ASSOCIATED WITH " & + "AGGREGATE NOTATION, MEMBERSHIP TESTS, THE " & + "OPERATION ASSOCIATED WITH INDEXED " & + "COMPONENTS, QUALIFICATION, EXPLICIT " & + "CONVERSION, 'SIZE, 'ADDRESS, 'FIRST, " & + "'FIRST (N), 'LAST, 'LAST (N), 'RANGE, " & + "'RANGE (N), 'LENGTH, 'LENGTH (N)" ) ; + + NP ; + + FIRST_TEST_PROCEDURE (FIRST => FIRST_ARRAY, + FFIFS => -10, + FFILS => 10, + FSIFS => 6, + FSILS => 10, + FFLEN => 21, + FSLEN => 5, + FFIRT => 0, + FSIRT => 8, + SECOND => SECOND_ARRAY, + SFIFS => 0, + SFILS => 7, + SSIFS => 1, + SSILS => 15, + SFLEN => 8, + SSLEN => 15, + SFIRT => 5, + SSIRT => 13, + REMARKS => "FIRST_TEST_PROCEDURE") ; + + NEW_CTEST_PROCEDURE (FIRST => THIRD_ARRAY, + FFIRT => -5, + FSIRT => 11, + SECOND => FOURTH_ARRAY, + SFIRT => 0, + SSIRT => 14, + REMARKS => "NEW_CTEST_PROCEDURE") ; + + REPORT.RESULT ; + + END CC1224A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1225a.tst 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- CC1225A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A FORMAL ACCESS TYPE, THAT ALL ALLOWABLE OPERATIONS + -- ARE IMPLICITLY DECLARED. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- BCB 03/29/88 CREATED ORIGINAL TEST. + -- RDH 04/09/90 ADDED 'STORAGE_SIZE CLAUSES. CHANGED EXTENSION TO + -- 'TST'. + -- LDC 09/26/90 REMOVED 'USE PACK' AFTER THE WITH SINCE IT ISN'T + -- NEEDED, ADDED CHECK FOR NULL AFTER ASSIGMENT TO + -- NULL, ADDED CHECKS FOR OTHER RELATION OPERATORS, + -- CHANGED CHECK FOR 'ADDRESS TO A PROCEDURE CALL. + -- LDC 10/13/90 CHANGED CHECK FOR 'SIZE TO ONLY CHECK FOR + -- AVAILABILITY. CHANGED CHECK FOR 'ADDRESS TO A + -- MEMBERSHIP TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CC1225A IS + + TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE AI IS ACCESS INTEGER; + + TYPE ACCINTEGER IS ACCESS INTEGER; + + TYPE REC IS RECORD + COMP : INTEGER; + END RECORD; + + TYPE DISCREC (DISC : INTEGER := 1) IS RECORD + COMPD : INTEGER; + END RECORD; + + TYPE AREC IS ACCESS REC; + + TYPE ADISCREC IS ACCESS DISCREC; + + TYPE ARR IS ARRAY(1..2,1..2) OF INTEGER; + + TYPE ONEDIM IS ARRAY(1..10) OF INTEGER; + + TYPE AA IS ACCESS ARR; + + TYPE AONEDIM IS ACCESS ONEDIM; + + TYPE ENUM IS (ONE, TWO, THREE); + + TASK TYPE T IS + ENTRY HERE(VAL : IN OUT INTEGER); + END T; + + TYPE ATASK IS ACCESS T; + + TYPE ANOTHERTASK IS ACCESS T; + FOR ANOTHERTASK'STORAGE_SIZE USE 2 * TASK_STORAGE_SIZE; + + TASK TYPE T1 IS + ENTRY HERE1(ENUM)(VAL1 : IN OUT INTEGER); + END T1; + + TYPE ATASK1 IS ACCESS T1; + + TASK BODY T IS + BEGIN + ACCEPT HERE(VAL : IN OUT INTEGER) DO + VAL := VAL * 2; + END HERE; + END T; + + TASK BODY T1 IS + BEGIN + SELECT + ACCEPT HERE1(ONE)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 1; + END HERE1; + OR + ACCEPT HERE1(TWO)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 2; + END HERE1; + OR + ACCEPT HERE1(THREE)(VAL1 : IN OUT INTEGER) DO + VAL1 := VAL1 * 3; + END HERE1; + END SELECT; + END T1; + + GENERIC + TYPE FORM IS (<>); + TYPE ACCFORM IS ACCESS FORM; + TYPE ACC IS ACCESS INTEGER; + TYPE ACCREC IS ACCESS REC; + TYPE ACCDISCREC IS ACCESS DISCREC; + TYPE ACCARR IS ACCESS ARR; + TYPE ACCONE IS ACCESS ONEDIM; + TYPE ACCTASK IS ACCESS T; + TYPE ACCTASK1 IS ACCESS T1; + TYPE ANOTHERTASK1 IS ACCESS T; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + AF : ACCFORM; + TYPE DER_ACC IS NEW ACC; + A, B : ACC; + DERA : DER_ACC; + R : ACCREC; + DR : ACCDISCREC; + C : ACCARR; + D, E : ACCONE; + F : ACCTASK; + G : ACCTASK1; + INT : INTEGER := 5; + + BEGIN + TEST ("CC1225A", "CHECK, FOR A FORMAL ACCESS TYPE, THAT " & + "ALL ALLOWABLE OPERATIONS ARE IMPLICITLY " & + "DECLARED"); + + IF AF'ADDRESS NOT IN ADDRESS THEN + FAILED ("IMPROPER RESULT FROM AF'ADDRESS TEST"); + END IF; + + DECLARE + AF_SIZE : INTEGER := ACCFORM'SIZE; + BEGIN + IF AF_SIZE NOT IN INTEGER THEN + FAILED ("IMPROPER RESULT FROM AF'SIZE"); + END IF; + END; + + IF ANOTHERTASK1'STORAGE_SIZE < TASK_STORAGE_SIZE THEN + FAILED ("IMPROPER VALUE FOR ANOTHERTASK1'STORAGE_SIZE"); + END IF; + + B := NEW INTEGER'(25); + + A := B; + + IF A.ALL /= 25 THEN + FAILED ("IMPROPER VALUE FOR ASSIGNMENT OF VARIABLE " & + "OF A FORMAL ACCESS TYPE FROM ANOTHER " & + "VARIABLE OF A FORMAL ACCESS TYPE"); + END IF; + + A := NEW INTEGER'(10); + + IF A.ALL /= 10 THEN + FAILED ("IMPROPER VALUE FOR VARIABLE OF FORMAL ACCESS " & + "TYPE"); + END IF; + + IF A NOT IN ACC THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + B := ACC'(A); + + IF B.ALL /= 10 THEN + FAILED ("IMPROPER VALUE FROM QUALIFICATION"); + END IF; + + DERA := NEW INTEGER'(10); + A := ACC(DERA); + + IF A.ALL /= IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE FROM EXPLICIT CONVERSION"); + END IF; + + IF A.ALL > IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE USED IN LESS THAN"); + END IF; + + IF A.ALL < IDENT_INT(10) THEN + FAILED ("IMPROPER VALUE USED IN GREATER THAN"); + END IF; + + IF A.ALL >= IDENT_INT(11) THEN + FAILED ("IMPROPER VALUE USED IN LESS THAN OR EQUAL"); + END IF; + + IF A.ALL <= IDENT_INT(9) THEN + FAILED ("IMPROPER VALUE USED IN GREATER THAN OR EQUAL"); + END IF; + + IF NOT (A.ALL + A.ALL = IDENT_INT(20)) THEN + FAILED ("IMPROPER VALUE FROM ADDITION"); + END IF; + + IF NOT (A.ALL - IDENT_INT(2) = IDENT_INT(8)) THEN + FAILED ("IMPROPER VALUE FROM SUBTRACTION"); + END IF; + + IF NOT (A.ALL * IDENT_INT(3) = IDENT_INT(30)) THEN + FAILED ("IMPROPER VALUE FROM MULTIPLICATION"); + END IF; + + IF NOT (A.ALL / IDENT_INT(3) = IDENT_INT(3)) THEN + FAILED ("IMPROPER VALUE FROM DIVISION"); + END IF; + + IF NOT (A.ALL MOD IDENT_INT(3) = IDENT_INT(1)) THEN + FAILED ("IMPROPER VALUE FROM MODULO"); + END IF; + + IF NOT (A.ALL REM IDENT_INT(7) = IDENT_INT(3)) THEN + FAILED ("IMPROPER VALUE FROM REMAINDER"); + END IF; + + IF NOT (A.ALL ** IDENT_INT(2) = IDENT_INT(100)) THEN + FAILED ("IMPROPER VALUE FROM EXPONENTIATION"); + END IF; + + IF NOT (+A.ALL = IDENT_INT(10)) THEN + FAILED ("IMPROPER VALUE FROM IDENTITY"); + END IF; + + IF NOT (-A.ALL = IDENT_INT(-10)) THEN + FAILED ("IMPROPER VALUE FROM NEGATION"); + END IF; + + A := NULL; + + IF A /= NULL THEN + FAILED ("IMPROPER VALUE FROM ACCESS SET TO NULL"); + END IF; + + IF A'ADDRESS NOT IN ADDRESS THEN + FAILED ("IMPROPER RESULT FROM A'ADDRESS TEST"); + END IF; + + + DECLARE + ACC_SIZE : INTEGER := ACC'SIZE; + BEGIN + IF ACC_SIZE NOT IN INTEGER THEN + FAILED ("IMPROPER RESULT FROM ACC'SIZE"); + END IF; + END; + + R := NEW REC'(COMP => 5); + + IF NOT EQUAL(R.COMP,5) THEN + FAILED ("IMPROPER VALUE FOR RECORD COMPONENT"); + END IF; + + DR := NEW DISCREC'(DISC => 1, COMPD => 5); + + IF NOT EQUAL(DR.DISC,1) OR NOT EQUAL(DR.COMPD,5) THEN + FAILED ("IMPROPER VALUES FOR DISCRIMINATED RECORD " & + "COMPONENTS"); + END IF; + + C := NEW ARR'(1 => (1,2), 2 => (3,4)); + + IF C(1,1) /= 1 OR C(1,2) /= 2 OR C(2,1) /= 3 OR C(2,2) /= 4 + THEN FAILED ("IMPROPER ARRAY COMPONENT VALUES"); + END IF; + + D := NEW ONEDIM'(1,2,3,4,5,6,7,8,9,10); + E := NEW ONEDIM'(10,9,8,7,6,5,4,3,2,1); + + D(1..5) := E(1..5); + + IF D(1) /= 10 OR D(2) /= 9 OR D(3) /= 8 + OR D(4) /= 7 OR D(5) /= 6 THEN + FAILED ("IMPROPER RESULTS FROM SLICE ASSIGNMENT"); + END IF; + + IF C'FIRST /= 1 OR C'FIRST(2) /= 1 THEN + FAILED ("IMPROPER LOWER BOUNDS FOR CONSTRAINED ARRAY"); + END IF; + + IF C'LAST /= 2 OR C'LAST(2) /= 2 THEN + FAILED ("IMPROPER UPPER BOUNDS FOR CONSTRAINED ARRAY"); + END IF; + + IF 1 NOT IN C'RANGE THEN + FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 1"); + END IF; + + IF 1 NOT IN C'RANGE(2) THEN + FAILED ("IMPROPER RANGE FOR CONSTRAINED ARRAY - 2"); + END IF; + + IF C'LENGTH /= 2 THEN + FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " & + "ARRAY - 1"); + END IF; + + IF C'LENGTH(2) /= 2 THEN + FAILED ("IMPROPER NUMBER OF VALUES FOR CONSTRAINED " & + "ARRAY - 2"); + END IF; + + F := NEW T; + + F.HERE(INT); + + IF NOT EQUAL(INT,IDENT_INT(10)) THEN + FAILED ("IMPROPER RESULTS FROM ENTRY SELECTION"); + END IF; + + G := NEW T1; + + G.HERE1(TWO)(INT); + + IF NOT EQUAL(INT,IDENT_INT(20)) THEN + FAILED ("IMPROPER RESULTS FROM FAMILY ENTRY SELECTION"); + END IF; + + RESULT; + END P; + + PACKAGE PACK IS NEW P(INTEGER,ACCINTEGER,AI,AREC,ADISCREC, + AA,AONEDIM,ATASK,ATASK1,ANOTHERTASK); + + BEGIN + NULL; + END CC1225A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1226b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- CC1226B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR A FORMAL NONLIMITED PRIVATE TYPE, THAT ALL ALLOWABLE + -- OPERATIONS ARE IMPLICITLY DECLARED. + + -- HISTORY: + -- BCB 04/04/88 CREATED ORIGINAL TEST. + -- RJW 03/28/90 INITIALIZED PREVIOUSLY UNINITIALIZED VARIABLES. + -- LDC 09/19/90 INITALIZED NLPVAR & NLPVAR2 TO DIFFERENT VALUES, + -- REMOVED USE CLAUSE. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CC1226B IS + + TYPE DISCREC(DISC1 : INTEGER := 1; + DISC2 : BOOLEAN := FALSE) IS RECORD + NULL; + END RECORD; + + GENERIC + TYPE NLP IS PRIVATE; + TYPE NLPDISC(DISC1 : INTEGER; + DISC2 : BOOLEAN) IS PRIVATE; + WITH PROCEDURE INITIALIZE (N : OUT NLPDISC); + WITH FUNCTION INITIALIZE RETURN NLP; + WITH FUNCTION INITIALIZE_2 RETURN NLP; + PACKAGE P IS + FUNCTION IDENT(X : NLP) RETURN NLP; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS; + END P; + + PACKAGE BODY P IS + TYPE DER_NLP IS NEW NLP; + NLPVAR : NLP := INITIALIZE_2; + NLPVAR2, NLPVAR3 : NLP := INITIALIZE; + DERNLP : DER_NLP := DER_NLP (INITIALIZE); + NDVAR : NLPDISC(DISC1 => 5, DISC2 => TRUE); + NLPVARADDRESS : ADDRESS; + NLPSIZE : INTEGER; + NLPBASESIZE : INTEGER; + + FUNCTION IDENT(X : NLP) RETURN NLP IS + Z : NLP := INITIALIZE; + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN Z; + END IDENT; + + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS + I : INTEGER; + Z : ADDRESS := I'ADDRESS; + BEGIN + IF EQUAL(3,3) THEN + RETURN Y; + END IF; + RETURN Z; + END IDENT_ADR; + + BEGIN + TEST ("CC1226B", "CHECK, FOR A FORMAL NONLIMITED PRIVATE " & + "TYPE THAT ALL ALLOWABLE OPERATIONS ARE " & + "IMPLICITLY DECLARED"); + + INITIALIZE (NDVAR); + + NLPVAR := NLPVAR2; + + IF NLPVAR /= NLPVAR2 THEN + FAILED ("IMPROPER VALUE FROM ASSIGNMENT"); + END IF; + + IF NLPVAR NOT IN NLP THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + NLPVAR := NLP'(NLPVAR2); + + IF NLPVAR /= NLPVAR2 THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION"); + END IF; + + NLPVAR := NLP(DERNLP); + + IF NLPVAR /= IDENT(NLP(DERNLP)) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION"); + END IF; + + NLPSIZE := IDENT_INT(NLP'SIZE); + + IF NLPSIZE /= INTEGER(NLP'SIZE) THEN + FAILED ("IMPROPER VALUE FOR NLP'SIZE"); + END IF; + + NLPVARADDRESS := NLPVAR'ADDRESS; + + IF NLPVAR'ADDRESS /= IDENT_ADR(NLPVARADDRESS) THEN + FAILED ("IMPROPER VALUE FOR NLPVAR'ADDRESS"); + END IF; + + IF NDVAR.DISC1 /= IDENT_INT(5) THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - 1"); + END IF; + + IF NOT NDVAR.DISC2 THEN + FAILED ("IMPROPER DISCRIMINANT VALUE - 2"); + END IF; + + IF NOT NDVAR'CONSTRAINED THEN + FAILED ("IMPROPER VALUE FOR NDVAR'CONSTRAINED"); + END IF; + + NLPVAR := NLPVAR3; + + IF NOT (NLPVAR = IDENT(NLPVAR3)) THEN + FAILED ("IMPROPER VALUE FROM EQUALITY OPERATION"); + END IF; + + IF NLPVAR /= IDENT(NLPVAR3) THEN + FAILED ("IMPROPER VALUE FROM INEQUALITY OPERATION"); + END IF; + + RESULT; + END P; + + PROCEDURE INITIALIZE (I : OUT DISCREC) IS + BEGIN + I := (5, TRUE); + END INITIALIZE; + + FUNCTION INITIALIZE RETURN INTEGER IS + BEGIN + RETURN 5; + END INITIALIZE; + + FUNCTION INITIALIZE_OTHER RETURN INTEGER IS + BEGIN + RETURN 3; + END INITIALIZE_OTHER; + + PACKAGE PACK IS NEW P(INTEGER, + DISCREC, + INITIALIZE, + INITIALIZE, + INITIALIZE_OTHER); + + BEGIN + NULL; + END CC1226B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1227a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,289 ---- + -- CC1227A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, WHEN DERIVING FROM A FORMAL TYPE, THAT ALL THE PREDEFINED + -- OPERATIONS ASSOCIATED WITH THE CLASS OF THE FORMAL TYPE ARE + -- DECLARED FOR THE DERIVED TYPE. + + -- HISTORY: + -- BCB 04/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CC1227A IS + + GENERIC + TYPE FORM IS RANGE <>; + PACKAGE P IS + TYPE DER_FORM IS NEW FORM; + FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS; + END P; + + PACKAGE BODY P IS + DER_VAR : DER_FORM; + DER_FORM_BASE_FIRST : DER_FORM; + DER_FORM_FIRST : DER_FORM; + DER_FORM_LAST : DER_FORM; + DER_FORM_SIZE : DER_FORM; + DER_FORM_WIDTH : DER_FORM; + DER_FORM_POS : DER_FORM; + DER_FORM_VAL : DER_FORM; + DER_FORM_SUCC : DER_FORM; + DER_FORM_PRED : DER_FORM; + DER_FORM_IMAGE : STRING(1..5); + DER_FORM_VALUE : DER_FORM; + DER_VAR_SIZE : DER_FORM; + DER_VAR_ADDRESS : ADDRESS; + DER_EQUAL, DER_UNEQUAL : DER_FORM; + DER_GREATER : DER_FORM; + DER_MOD, DER_REM : DER_FORM; + DER_ABS, DER_EXP : DER_FORM; + INT : INTEGER := 5; + FUNCTION IDENT_DER(X : DER_FORM) RETURN DER_FORM IS + BEGIN + IF EQUAL(3,3) THEN + RETURN X; + END IF; + RETURN 0; + END IDENT_DER; + FUNCTION IDENT_ADR(Y : ADDRESS) RETURN ADDRESS IS + X : DER_FORM; + BEGIN + IF EQUAL(3,3) THEN + RETURN Y; + END IF; + RETURN X'ADDRESS; + END IDENT_ADR; + BEGIN + TEST ("CC1227A", "CHECK, WHEN DERIVING FROM A FORMAL TYPE, " & + "THAT ALL THE PREDEFINED OPERATIONS " & + "ASSOCIATED WITH THE CLASS OF THE FORMAL " & + "TYPE ARE DECLARED FOR THE DERIVED TYPE"); + + DER_VAR := IDENT_DER(1); + + IF DER_VAR /= 1 THEN + FAILED ("IMPROPER VALUE FROM ASSIGNMENT OPERATION"); + END IF; + + IF DER_VAR NOT IN DER_FORM THEN + FAILED ("IMPROPER RESULT FROM MEMBERSHIP TEST"); + END IF; + + DER_VAR := DER_FORM'(2); + + IF DER_VAR /= IDENT_DER(2) THEN + FAILED ("IMPROPER RESULT FROM QUALIFICATION"); + END IF; + + DER_VAR := DER_FORM(INT); + + IF DER_VAR /= IDENT_DER(5) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " & + "INTEGER"); + END IF; + + DER_VAR := DER_FORM(3.0); + + IF DER_VAR /= IDENT_DER(3) THEN + FAILED ("IMPROPER RESULT FROM EXPLICIT CONVERSION - " & + "FLOAT"); + END IF; + + DER_VAR := 1_000; + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM IMPLICIT CONVERSION"); + END IF; + + DER_FORM_BASE_FIRST := DER_FORM'BASE'FIRST; + + DER_FORM_FIRST := DER_FORM'FIRST; + + IF DER_FORM_BASE_FIRST /= IDENT_DER(DER_FORM_FIRST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'BASE'FIRST"); + END IF; + + IF DER_FORM_FIRST /= IDENT_DER(DER_FORM'FIRST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'FIRST"); + END IF; + + DER_FORM_LAST := DER_FORM'LAST; + + IF DER_FORM_LAST /= IDENT_DER(DER_FORM'LAST) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'LAST"); + END IF; + + DER_FORM_SIZE := DER_FORM(DER_FORM'SIZE); + + IF DER_FORM_SIZE /= IDENT_DER(DER_FORM(DER_FORM'SIZE)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'SIZE"); + END IF; + + DER_FORM_WIDTH := DER_FORM(DER_FORM'WIDTH); + + IF DER_FORM_WIDTH /= IDENT_DER(DER_FORM(DER_FORM'WIDTH)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'WIDTH"); + END IF; + + DER_FORM_POS := DER_FORM(DER_FORM'POS(DER_VAR)); + + IF DER_FORM_POS /= IDENT_DER(DER_FORM(DER_FORM'POS(DER_VAR))) + THEN FAILED ("IMPROPER VALUE FOR DER_FORM'POS(DER_VAR)"); + END IF; + + DER_FORM_VAL := DER_FORM'VAL(DER_VAR); + + IF DER_FORM_VAL /= IDENT_DER(DER_FORM'VAL(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'VAL(DER_VAR)"); + END IF; + + DER_FORM_SUCC := DER_FORM'SUCC(DER_VAR); + + IF DER_FORM_SUCC /= IDENT_DER(DER_FORM'SUCC(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'SUCC(DER_VAR)"); + END IF; + + DER_FORM_PRED := DER_FORM'PRED(DER_VAR); + + IF DER_FORM_PRED /= IDENT_DER(DER_FORM'PRED(DER_VAR)) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'PRED(DER_VAR)"); + END IF; + + DER_FORM_IMAGE := DER_FORM'IMAGE(DER_VAR); + + IF DER_FORM_IMAGE(2..5) /= "1000" THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'IMAGE(DER_VAR)"); + END IF; + + DER_FORM_VALUE := DER_FORM'VALUE(DER_FORM_IMAGE); + + IF DER_FORM_VALUE /= IDENT_DER(1000) THEN + FAILED ("IMPROPER VALUE FOR DER_FORM'VALUE" & + "(DER_FORM_IMAGE)"); + END IF; + + DER_VAR_SIZE := DER_FORM(DER_VAR'SIZE); + + IF DER_VAR_SIZE /= IDENT_DER(DER_FORM(DER_VAR'SIZE)) THEN + FAILED ("IMPROPER VALUE FOR DER_VAR'SIZE"); + END IF; + + DER_VAR_ADDRESS := DER_VAR'ADDRESS; + + IF DER_VAR_ADDRESS /= IDENT_ADR(DER_VAR'ADDRESS) THEN + FAILED ("IMPROPER VALUE FOR DER_VAR'ADDRESS"); + END IF; + + DER_EQUAL := IDENT_DER(1000); + + IF DER_VAR /= DER_EQUAL THEN + FAILED ("IMPROPER RESULT FROM INEQUALITY OPERATOR"); + END IF; + + DER_UNEQUAL := IDENT_DER(500); + + IF DER_VAR = DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM EQUALITY OPERATOR"); + END IF; + + IF DER_VAR < DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OPERATOR"); + END IF; + + IF DER_VAR <= DER_UNEQUAL THEN + FAILED ("IMPROPER RESULT FROM LESS THAN OR EQUAL TO " & + "OPERATOR"); + END IF; + + DER_GREATER := IDENT_DER(1500); + + IF DER_VAR > DER_GREATER THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OPERATOR"); + END IF; + + IF DER_VAR >= DER_GREATER THEN + FAILED ("IMPROPER RESULT FROM GREATER THAN OR EQUAL " & + "TO OPERATOR"); + END IF; + + DER_VAR := DER_VAR + DER_EQUAL; + + IF DER_VAR /= IDENT_DER(2000) THEN + FAILED ("IMPROPER RESULT FROM ADDITION OPERATOR"); + END IF; + + DER_VAR := DER_VAR - DER_EQUAL; + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM SUBTRACTION OPERATOR"); + END IF; + + DER_VAR := DER_VAR * IDENT_DER(2); + + IF DER_VAR /= IDENT_DER(2000) THEN + FAILED ("IMPROPER RESULT FROM MULTIPLICATION OPERATOR"); + END IF; + + DER_VAR := DER_VAR / IDENT_DER(2); + + IF DER_VAR /= IDENT_DER(1000) THEN + FAILED ("IMPROPER RESULT FROM DIVISION OPERATOR"); + END IF; + + DER_MOD := DER_GREATER MOD DER_VAR; + + IF DER_MOD /= IDENT_DER(500) THEN + FAILED ("IMPROPER RESULT FROM MOD OPERATOR"); + END IF; + + DER_REM := DER_GREATER REM DER_VAR; + + IF DER_REM /= IDENT_DER(500) THEN + FAILED ("IMPROPER RESULT FROM REM OPERATOR"); + END IF; + + DER_ABS := ABS(IDENT_DER(-1500)); + + IF DER_ABS /= IDENT_DER(DER_GREATER) THEN + FAILED ("IMPROPER RESULT FROM ABS OPERATOR"); + END IF; + + DER_EXP := IDENT_DER(2) ** IDENT_INT(2); + + IF DER_EXP /= IDENT_DER(4) THEN + FAILED ("IMPROPER RESULT FROM EXPONENTIATION OPERATOR"); + END IF; + + RESULT; + END P; + + PACKAGE PACK IS NEW P(INTEGER); + + BEGIN + NULL; + END CC1227A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1301a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CC1301A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DEFAULT GENERIC SUBPROGRAM PARAMETERS WORK CORRECTLY, + -- INCLUDING OVERLOADED AND PREDEFINED OPERATOR_SYMBOLS, + -- AND SUBPROGRAMS HIDDEN AT THE INSTANTIATION. + -- BOTH KINDS OF DEFAULTS ARE TESTED, FOR BOTH PROCEDURES + -- AND FUNCTIONS. + + -- DAT 8/14/81 + -- JBG 5/5/83 + -- JBG 8/3/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1301A IS + + FUNCTION "-" (R, S : INTEGER) RETURN INTEGER; + + FUNCTION NEXT (X : INTEGER) RETURN INTEGER; + + PROCEDURE BUMP (X : IN OUT INTEGER); + + GENERIC + WITH FUNCTION "*" (A, B : INTEGER) RETURN INTEGER IS "-"; + WITH FUNCTION "+" (R, S: INTEGER) RETURN INTEGER IS + STANDARD."+"; + WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION NEXTO (Q : INTEGER) RETURN INTEGER IS NEXT ; + WITH PROCEDURE BUMPO (A : IN OUT INTEGER) IS BUMP; + WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ; + WITH PROCEDURE BUMP (Q : IN OUT INTEGER) IS <> ; + TYPE INTEGER IS RANGE <> ; + WITH FUNCTION "*" (A , B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION "-" (A, B : INTEGER) RETURN INTEGER IS <> ; + WITH FUNCTION NEXT (Q : INTEGER) RETURN INTEGER IS <> ; + WITH PROCEDURE BUMP (Z : IN OUT INTEGER) IS <> ; + PACKAGE PKG IS + SUBTYPE INT IS STANDARD.INTEGER; + DIFF : INT := -999; + END PKG; + + TYPE NEWINT IS NEW INTEGER RANGE -1000 .. 1000; + + FUNCTION PLUS (Q1, Q2 : INTEGER) RETURN INTEGER RENAMES "+"; + + FUNCTION "+" (X, Y : INTEGER) RETURN INTEGER IS + BEGIN + RETURN PLUS (X, PLUS (Y, -10)); + -- (X + Y - 10) + END "+"; + + FUNCTION "-" (R, S : INTEGER) RETURN INTEGER IS + BEGIN + RETURN - R + S; + -- (-R + S - 10) + END "-"; + + FUNCTION NEXT (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN X + 1; + -- (X + 1 - 10) + -- (X - 9) + END NEXT; + + PROCEDURE BUMP (X : IN OUT INTEGER) IS + BEGIN + X := NEXT (X); + -- (X := X - 9) + END BUMP; + + PACKAGE BODY PKG IS + W : INTEGER; + WI : INT; + BEGIN + W := NEXT (INTEGER'(3) * 4 - 2); + -- (W := (4 ** 3 - 2) - 1) + -- (W := 61) + BUMP (W); + -- (W := 61 + 7) + -- (W := 68) + WI := NEXT (INT'(3) * 4 - 2 + NEXTO (0)); + -- (3 * 4) => (3 - 4) => (-3 + 4 - 10) = -9 + -- ((-9) - 2) => (2 + 2 - (-9) - 20) = -7 + -- (-7 + (-9)) => -16 + -- (WI := 7 - (-16)) => (WI := 23) + BUMPO (WI); + -- (WI := 23 - 9) (= 14) + BUMP (WI); + -- (WI := 14 - 9) (= 5) + DIFF := STANDARD."-" (INT(W), WI); + -- (DIFF := 68 - 5) (= 63) + END PKG; + + FUNCTION "*" (Y, X : NEWINT) RETURN NEWINT IS + BEGIN + RETURN X ** INTEGER(Y); + -- (X,Y) (Y ** X) + END "*"; + + FUNCTION NEXT (Z : NEWINT) RETURN NEWINT IS + BEGIN + RETURN Z - 1; + -- (Z - 1) + END NEXT; + + PROCEDURE BUMP (ZZ : IN OUT NEWINT) IS + BEGIN + FAILED ("WRONG PROCEDURE CALLED"); + END BUMP; + BEGIN + TEST ("CC1301A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS"); + + DECLARE + PROCEDURE BUMP (QQQ : IN OUT NEWINT) IS + BEGIN + QQQ := QQQ + 7; + -- (QQQ + 7) + END BUMP; + + FUNCTION NEXT (Q7 : INTEGER) RETURN INTEGER IS + BEGIN + RETURN Q7 - 17; + -- (-Q7 + 17 - 10) + -- (7 - Q7) + END NEXT; + + FUNCTION "-" (Q3, Q4 : INTEGER) RETURN INTEGER IS + BEGIN + RETURN -Q3 + Q4 + Q4; + -- (-Q3 + Q4 - 10 + Q4 - 10) = (Q4 + Q4 - Q3 - 20) + END "-"; + + PACKAGE P1 IS NEW PKG (INTEGER => NEWINT); + + BEGIN + IF P1.DIFF /= 63 THEN + FAILED ("WRONG DEFAULT SUBPROGRAM PARAMETERS"); + END IF; + END; + + RESULT; + END CC1301A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1302a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- CC1302A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC DEFAULT SUBPROGRAM PARAMETERS MAY BE ATTRIBUTES + -- OF TYPES, INCLUDING GENERIC FORMAL TYPES IN SAME GENERIC PART, + -- OR IN GENERIC PART OF ENCLOSING UNIT. + + -- DAT 8/27/81 + -- SPS 2/9/83 + -- JBG 2/15/83 + -- JBG 4/29/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1302A IS + BEGIN + TEST ("CC1302A", "GENERIC DEFAULT SUBPROGRAMS MAY BE" + & " FUNCTION ATTRIBUTES OF TYPES"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + T_LAST : T; + WITH FUNCTION SUCC (X : T) RETURN T IS T'SUCC; + PACKAGE PK1 IS + END PK1; + + SUBTYPE CH IS CHARACTER RANGE CHARACTER'FIRST .. '~'; + SUBTYPE BL IS BOOLEAN RANGE FALSE .. FALSE; + SUBTYPE INT IS INTEGER RANGE -10 .. 10; + + PACKAGE BODY PK1 IS + GENERIC + TYPE TT IS ( <> ); + TT_LAST : TT; + WITH FUNCTION PRED (X : TT) RETURN TT IS TT'PRED; + WITH FUNCTION IM(X : T) RETURN STRING IS T'IMAGE; + WITH FUNCTION VAL(X : STRING) RETURN TT IS TT'VALUE; + PACKAGE PK2 IS END PK2; + + PACKAGE BODY PK2 IS + BEGIN + + -- CHECK THAT 'LAST GIVES RIGHT ANSWER + IF T'LAST /= T_LAST THEN + FAILED ("T'LAST INCORRECT"); + END IF; + + IF TT'LAST /= TT_LAST THEN + FAILED ("TT'LAST INCORRECT"); + END IF; + + -- CHECK SUCC FUNCTION + BEGIN + IF T'PRED(SUCC(T'LAST)) /= T'LAST THEN + FAILED ("'PRED OR SUCC GIVES WRONG " & + "RESULT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("SUCC HAS CONSTRAINTS OF " & + "SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 1"); + END; + + -- CHECK 'SUCC ATTRIBUTE + BEGIN + IF T'PRED(T'SUCC(T'LAST)) /= T'LAST THEN + FAILED ("'PRED OR 'SUCC GIVES WRONG " & + "RESULT"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("'PRED OR 'SUCC HAS CONSTRAINTS "& + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 2"); + END; + + -- CHECK VAL ATTRIBUTE + BEGIN + IF T'VAL(T'POS(T'SUCC(T'LAST))) /= + T'VAL(T'POS(T'LAST)+1) THEN + FAILED ("VAL OR POS ATTRIBUTE HAS " & + "INCONSISTENT RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("VAL OR POS ATTRIBUTE HAS " & + "CONSTRAINTS OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 4"); + END; + + -- CHECK VAL FUNCTION + BEGIN + IF TT'VAL(TT'POS(TT'SUCC(TT'LAST))) /= + TT'VAL(TT'POS(TT'LAST)+1) THEN + FAILED ("VAL FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("VAL FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 6"); + END; + + -- CHECK IM FUNCTION + BEGIN + IF T'IMAGE(T'SUCC(T'LAST)) /= + IM (T'SUCC(T'LAST)) THEN + FAILED ("IM FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("IM FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 7"); + END; + + -- CHECK PRED FUNCTION + BEGIN + IF PRED(TT'SUCC(TT'LAST)) /= TT'LAST THEN + FAILED ("PRED FUNCTION GIVES INCORRECT " & + "RESULTS"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("PRED FUNCTION HAS CONSTRAINTS " & + "OF SUBTYPE"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 8"); + END; + + END PK2; + + PACKAGE PK3 IS NEW PK2 (T, T'LAST); + END PK1; + + PACKAGE PKG1 IS NEW PK1 (CH, CH'LAST); + PACKAGE PKG2 IS NEW PK1 (BL, BL'LAST); + PACKAGE PKG3 IS NEW PK1 (INT, INT'LAST); + BEGIN + NULL; + END; + + RESULT; + END CC1302A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1304a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CC1304A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER + -- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL + -- TYPE. + + -- DAT 8/27/81 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1304A IS + BEGIN + TEST ("CC1304A", "GENERIC FORMAL SUBPROGRAMS MAY HAVE PARAMETERS" + & " OF (AND RETURN) A FORMAL TYPE"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + WITH FUNCTION S (P : T) RETURN T; + WITH PROCEDURE P (P : T); + PROCEDURE PR (PARM : T); + + PROCEDURE PR (PARM: T) IS + BEGIN + P(P=>S(P=>PARM)); + END PR; + BEGIN + DECLARE + C : CHARACTER := 'A'; + B : BOOLEAN := FALSE; + I : INTEGER := 5; + TYPE ENUM IS (E1, E2, E3); + E : ENUM := E2; + + FUNCTION FC (P : CHARACTER) RETURN CHARACTER IS + BEGIN + RETURN 'B'; + END FC; + + FUNCTION FB (P : BOOLEAN) RETURN BOOLEAN IS + BEGIN + RETURN NOT P; + END FB; + + FUNCTION FI (P : INTEGER) RETURN INTEGER IS + BEGIN + RETURN P + 1; + END FI; + + FUNCTION FE (P : ENUM) RETURN ENUM IS + BEGIN + RETURN ENUM'SUCC (P); + END FE; + + PROCEDURE PC (P : CHARACTER) IS + BEGIN + C := P; + END PC; + + PROCEDURE PB (P : BOOLEAN) IS + BEGIN + B := P; + END PB; + + PROCEDURE PI (P : INTEGER) IS + BEGIN + I := P; + END PI; + + PROCEDURE PE (P : ENUM) IS + BEGIN + E := P; + END PE; + + PACKAGE PKG2 IS + PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC); + PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB); + PROCEDURE P3 IS NEW PR (INTEGER, FI, PI); + PROCEDURE P4 IS NEW PR (ENUM, FE, PE); + END PKG2; + + PACKAGE BODY PKG2 IS + BEGIN + P1 (C); + P2 (B); + P3 (I); + P4 (E); + END PKG2; + BEGIN + IF C /= 'B' + OR B /= TRUE + OR I /= 6 + OR E /= E3 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES"); + END IF; + END; + END; + + RESULT; + END CC1304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1304b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + -- CC1304B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GENERIC FORMAL SUBPROGRAMS MAY HAVE A PARAMETER + -- OF A GENERIC FORMAL TYPE, AND MAY RETURN A GENERIC FORMAL + -- TYPE. CHECK MODES IN OUT AND OUT. + + -- HISTORY: + -- BCB 08/04/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1304B IS + + BEGIN + TEST ("CC1304B", "GENERIC FORMAL SUBPROGRAMS MAY HAVE A " & + "PARAMETER OF A GENERIC FORMAL TYPE, AND MAY " & + "RETURN A GENERIC FORMAL TYPE. CHECK MODES IN " & + "OUT AND OUT"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + WITH PROCEDURE S (P : OUT T); + WITH PROCEDURE P (P : IN OUT T); + WITH FUNCTION L RETURN T; + PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T); + + PROCEDURE PR (PARM1, PARM2, PARM3 : IN OUT T) IS + BEGIN + S (P => PARM1); + P (P => PARM2); + PARM3 := L; + END PR; + BEGIN + DECLARE + C : CHARACTER := 'A'; + C1 : CHARACTER := 'Y'; + C2 : CHARACTER := 'I'; + B : BOOLEAN := FALSE; + B1 : BOOLEAN := TRUE; + B2 : BOOLEAN := FALSE; + I : INTEGER := 5; + I1 : INTEGER := 10; + I2 : INTEGER := 0; + TYPE ENUM IS (E1, E2, E3); + F : ENUM := E2; + F1 : ENUM := E1; + F2 : ENUM := E2; + + PROCEDURE FC (P : OUT CHARACTER) IS + BEGIN + P := 'B'; + END FC; + + PROCEDURE FB (P : OUT BOOLEAN) IS + BEGIN + P := NOT B; + END FB; + + PROCEDURE FI (P : OUT INTEGER) IS + BEGIN + P := I + 1; + END FI; + + PROCEDURE FE (P : OUT ENUM) IS + BEGIN + P := ENUM'SUCC (F); + END FE; + + PROCEDURE PC (P : IN OUT CHARACTER) IS + BEGIN + P := 'Z'; + END PC; + + PROCEDURE PB (P : IN OUT BOOLEAN) IS + BEGIN + P := NOT B1; + END PB; + + PROCEDURE PI (P : IN OUT INTEGER) IS + BEGIN + P := I1 + 1; + END PI; + + PROCEDURE PE (P : IN OUT ENUM) IS + BEGIN + P := ENUM'SUCC (F1); + END PE; + + FUNCTION LC RETURN CHARACTER IS + BEGIN + RETURN 'J'; + END LC; + + FUNCTION LB RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END LB; + + FUNCTION LI RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(5); + END LI; + + FUNCTION LE RETURN ENUM IS + BEGIN + RETURN ENUM'SUCC(F2); + END LE; + + PACKAGE PKG2 IS + PROCEDURE P1 IS NEW PR (CHARACTER, FC, PC, LC); + PROCEDURE P2 IS NEW PR (BOOLEAN, FB, PB, LB); + PROCEDURE P3 IS NEW PR (INTEGER, FI, PI, LI); + PROCEDURE P4 IS NEW PR (ENUM, FE, PE, LE); + END PKG2; + + PACKAGE BODY PKG2 IS + BEGIN + P1 (C,C1,C2); + P2 (B,B1,B2); + P3 (I,I1,I2); + P4 (F,F1,F2); + END PKG2; + BEGIN + IF C /= 'B' OR B /= TRUE OR I /= 6 OR F /= E3 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " & + "MODE OUT"); + END IF; + + IF C1 /= 'Z' OR B1 /= FALSE OR I1 /= 11 OR F1 /= E2 THEN + FAILED ("SUBPROGRAM PARAMETERS OF FORMAL TYPES - " & + "MODE IN OUT"); + END IF; + + IF C2 /= 'J' OR B2 /= TRUE OR I2 /= 5 OR F2 /= E3 THEN + FAILED ("GENERIC FORMAL SUBPROGRAMS RETURNING A " & + "GENERIC FORMAL TYPE"); + END IF; + END; + END; + + RESULT; + END CC1304B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1307a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- CC1307A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SUBPROGRAM PARAMETERS MAY HAVE AN OPERATOR_SYMBOL DEFAULT, + -- WHICH LOOKS THE SAME AS A DEFAULT STRING PARAMETER. + + -- DAT 9/8/81 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1307A IS + BEGIN + TEST ("CC1307A", "GENERIC SUBPROGRAM AND STRING DEFAULT PARAMETERS" + & " MAY LOOK THE SAME"); + + DECLARE + GENERIC + WITH FUNCTION CAT (X, Y : STRING) RETURN STRING + IS "&"; + S : STRING := "&"; + PACKAGE PK IS + VAL : CONSTANT STRING := CAT (S, S); + END PK; + + PACKAGE PK1 IS NEW PK; + BEGIN + IF PK1.VAL /= "&&" THEN + FAILED ("INCORRECT GENERIC INSTANTIATION WITH DEFAULTS"); + END IF; + END; + + RESULT; + END CC1307A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1307b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CC1307B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION LITERAL (BOTH AN IDENTIFIER AND A + -- CHARACTER LITERAL) MAY BE USED AS A DEFAULT SUBPROGRAM NAME + -- AND AS A DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER. + + -- HISTORY: + -- BCB 08/09/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1307B IS + + TYPE ENUM IS (R, 'S', R1); + + BEGIN + TEST ("CC1307B", "CHECK THAT AN ENUMERATION LITERAL (BOTH AN " & + "IDENTIFIER AND A CHARACTER LITERAL) MAY BE " & + "USED AS A DEFAULT SUBPROGRAM NAME AND AS A " & + "DEFAULT INITIAL VALUE FOR AN OBJECT PARAMETER"); + + DECLARE + GENERIC + WITH FUNCTION J RETURN ENUM IS R; + WITH FUNCTION K RETURN ENUM IS 'S'; + OBJ1 : ENUM := R; + OBJ2 : ENUM := 'S'; + PACKAGE P IS + END P; + + PACKAGE BODY P IS + VAR1, VAR2 : ENUM := R1; + BEGIN + VAR1 := J; + + IF VAR1 /= R THEN + FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " & + "NAME - IDENTIFIER"); + END IF; + + VAR2 := K; + + IF VAR2 /= 'S' THEN + FAILED ("WRONG VALUE FOR DEFAULT SUBPROGRAM " & + "NAME - CHARACTER LITERAL"); + END IF; + + IF OBJ1 /= R THEN + FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " & + "IDENTIFIER"); + END IF; + + IF OBJ2 /= 'S' THEN + FAILED ("WRONG VALUE FOR OBJECT PARAMETER - " & + "CHARACTER LITERAL"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P; + BEGIN + NULL; + END; + + RESULT; + END CC1307B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1308a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- CC1308A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FORMAL SUBPROGRAM PARAMETERS MAY OVERLOAD EACH OTHER + -- AND OTHER VISIBLE SUBPROGRAMS AND ENUMERATION LITERALS WITHIN AND + -- OUTSIDE OF THE GENERIC UNIT. + + -- HISTORY: + -- DAT 09/08/81 CREATED ORIGINAL TEST. + -- SPS 10/26/82 + -- SPS 02/09/83 + -- BCB 08/09/88 REPLACED THE OLD TEST WITH A VERSION BASED ON + -- AIG 6.6/T2. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1308A IS + + TYPE ENUM IS (F1,F2,F3,F4,F5,F6,F7); + + FUNCTION F1 (X : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 2*X; + END F1; + + PROCEDURE F1 (X : IN OUT INTEGER) IS + BEGIN + X := 3*X; + END F1; + + PROCEDURE F2 (Y : IN OUT INTEGER; Z : IN OUT BOOLEAN) IS + BEGIN + Y := 2*Y; + Z := NOT Z; + END F2; + + PROCEDURE F2 (Y : IN OUT INTEGER) IS + BEGIN + Y := 3*Y; + END F2; + + PROCEDURE F3 (B : BOOLEAN := FALSE; A : IN OUT INTEGER) IS + BEGIN + A := 2*A; + END F3; + + PROCEDURE F3 (A : IN OUT INTEGER) IS + BEGIN + A := 3*A; + END F3; + + PROCEDURE F4 (C : IN OUT INTEGER) IS + BEGIN + C := 2*C; + END F4; + + PROCEDURE F4 (C : IN OUT BOOLEAN) IS + BEGIN + C := NOT C; + END F4; + + PROCEDURE F5 (D : IN OUT INTEGER; E : IN OUT BOOLEAN) IS + BEGIN + D := 2*D; + E := NOT E; + END F5; + + PROCEDURE F5 (E : IN OUT BOOLEAN; D : IN OUT INTEGER) IS + BEGIN + E := NOT E; + D := 3*D; + END F5; + + FUNCTION F6 (G : INTEGER) RETURN INTEGER IS + BEGIN + RETURN 2*G; + END F6; + + FUNCTION F6 (G : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END F6; + + FUNCTION F7 RETURN INTEGER IS + BEGIN + RETURN 25; + END F7; + + FUNCTION F7 RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END F7; + + BEGIN + TEST ("CC1308A", "CHECK THAT FORMAL SUBPROGRAM PARAMETERS MAY " & + "OVERLOAD EACH OTHER AND OTHER VISIBLE " & + "SUBPROGRAMS AND ENUMERATION LITERALS WITHIN " & + "AND OUTSIDE OF THE GENERIC UNIT"); + + DECLARE + GENERIC + WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER; + WITH PROCEDURE F1 (X : IN OUT INTEGER); + + WITH PROCEDURE F2 (Y : IN OUT INTEGER; + Z : IN OUT BOOLEAN); + WITH PROCEDURE F2 (Y : IN OUT INTEGER); + + WITH PROCEDURE F3 (B : BOOLEAN := FALSE; + A : IN OUT INTEGER); + WITH PROCEDURE F3 (A : IN OUT INTEGER); + + WITH PROCEDURE F4 (C : IN OUT INTEGER); + WITH PROCEDURE F4 (C : IN OUT BOOLEAN); + + WITH PROCEDURE F5 (D : IN OUT INTEGER; + E : IN OUT BOOLEAN); + WITH PROCEDURE F5 (E : IN OUT BOOLEAN; + D : IN OUT INTEGER); + + WITH FUNCTION F6 (G : INTEGER) RETURN INTEGER; + WITH FUNCTION F6 (G : INTEGER) RETURN BOOLEAN; + + WITH FUNCTION F7 RETURN INTEGER; + WITH FUNCTION F7 RETURN BOOLEAN; + PACKAGE P IS + TYPE EN IS (F1,F2,F3,F4,F5,F6,F7); + END P; + + PACKAGE BODY P IS + X1, X2, Y1, Y2, A1, A2, C1, D1, D2, G1 + : INTEGER := IDENT_INT(5); + + VAL : INTEGER := IDENT_INT(0); + + Z1, B1, C2, E1, E2, BOOL : BOOLEAN := IDENT_BOOL(FALSE); + BEGIN + VAL := F1(X1); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("CASE 1 - WRONG VALUE RETURNED FROM " & + "FUNCTION"); + END IF; + + F1(X2); + + IF NOT EQUAL(X2,15) THEN + FAILED ("CASE 1 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F2(Y1,Z1); + + IF NOT EQUAL(Y1,10) OR Z1 /= TRUE THEN + FAILED ("CASE 2 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F2(Y2); + + IF NOT EQUAL(Y2,15) THEN + FAILED ("CASE 2 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F3(B1,A1); + + IF NOT EQUAL(A1,10) OR B1 /= FALSE THEN + FAILED ("CASE 3 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F3(A2); + + IF NOT EQUAL(A2,15) THEN + FAILED ("CASE 3 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE"); + END IF; + + F4(C1); + + IF NOT EQUAL(C1,10) THEN + FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE - BASE TYPE INTEGER"); + END IF; + + F4(C2); + + IF C2 /= TRUE THEN + FAILED ("CASE 4 - WRONG VALUE ASSIGNED INSIDE " & + "PROCEDURE - BASE TYPE BOOLEAN"); + END IF; + + F5(D1,E1); + + IF NOT EQUAL(D1,10) OR E1 /= TRUE THEN + FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE - ORDER WAS INTEGER, BOOLEAN"); + END IF; + + F5(E2,D2); + + IF E2 /= TRUE OR NOT EQUAL(D2,15) THEN + FAILED ("CASE 5 - WRONG VALUES ASSIGNED INSIDE " & + "PROCEDURE - ORDER WAS BOOLEAN, INTEGER"); + END IF; + + VAL := F6(G1); + + IF NOT EQUAL(VAL,10) THEN + FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " & + "FUNCTION - TYPE INTEGER"); + END IF; + + BOOL := F6(G1); + + IF BOOL /= TRUE THEN + FAILED ("CASE 6 - WRONG VALUE RETURNED FROM " & + "FUNCTION - TYPE BOOLEAN"); + END IF; + + VAL := F7; + + IF NOT EQUAL(VAL,25) THEN + FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " & + "PARAMETERLESS FUNCTION - TYPE INTEGER"); + END IF; + + BOOL := F7; + + IF BOOL /= FALSE THEN + FAILED ("CASE 7 - WRONG VALUE RETURNED FROM " & + "PARAMETERLESS FUNCTION - TYPE BOOLEAN"); + END IF; + END P; + + PACKAGE NEW_P IS NEW P (F1, F1, F2, F2, F3, F3, + F4, F4, F5, F5, F6, F6, F7, F7); + BEGIN + NULL; + END; + + RESULT; + END CC1308A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1310a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CC1310A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE ENTRIES. + + -- DAT 9/8/81 + -- SPS 2/7/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC1310A IS + BEGIN + TEST ("CC1310A", "DEFAULT GENERIC SUBPROGRAM PARAMETERS MAY BE" + & " ENTRIES"); + + DECLARE + TASK T IS + ENTRY ENT1; + ENTRY ENT2 (I : IN INTEGER); + END T; + + PROCEDURE P1 RENAMES T.ENT1; + + PROCEDURE P4 (I : IN INTEGER) RENAMES T.ENT2; + + INT : INTEGER := 0; + + TASK BODY T IS + BEGIN + ACCEPT ENT1; + ACCEPT ENT2 (I : IN INTEGER) DO + INT := INT + I; + END ENT2; + ACCEPT ENT2 (I : IN INTEGER) DO + INT := INT + I; + END ENT2; + ACCEPT ENT1; + END T; + + BEGIN + DECLARE + GENERIC + WITH PROCEDURE P1 IS <> ; + WITH PROCEDURE P2 IS T.ENT1; + WITH PROCEDURE P3 (I : IN INTEGER) IS T.ENT2; + WITH PROCEDURE P4 (I : IN INTEGER) IS <> ; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + BEGIN + P1; + P4 (3); + P3 (6); + P2; + END PKG; + + PACKAGE PP IS NEW PKG; + + BEGIN + IF INT /= 9 THEN + FAILED ("ENTRIES AS DEFAULT GENERIC PARAMETERS"); + END IF; + END; + END; + + RESULT; + END CC1310A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1311a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,480 ---- + -- CC1311A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE DEFAULT EXPRESSIONS OF THE PARAMETERS OF A FORMAL + -- SUBPROGRAM ARE USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE + -- ACTUAL SUBPROGRAM PARAMETER. + + -- HISTORY: + -- RJW 06/05/86 CREATED ORIGINAL TEST. + -- VCL 08/18/87 CHANGED A COUPLE OF STATIC DEFAULT EXPRESSIONS FOR + -- FORMAL SUBPROGRAM PARAMETERS TO DYNAMIC + -- EXPRESSIONS VIA THE USE OF THE IDENTITY FUNCTION. + -- EDWARD V. BERARD 08/13/90 + -- ADDED CHECKS FOR MULTI-DIMENSIONAL ARRAYS. + + WITH REPORT ; + + PROCEDURE CC1311A IS + + TYPE NUMBERS IS (ZERO, ONE ,TWO); + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PROCEDURE PROC_WITH_3D_FUNC ; + + PROCEDURE PROC_WITH_3D_FUNC IS + + BEGIN -- PROC_WITH_3D_FUNC + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + PACKAGE PKG_WITH_3D_FUNC IS + END PKG_WITH_3D_FUNC ; + + PACKAGE BODY PKG_WITH_3D_FUNC IS + BEGIN -- PKG_WITH_3D_FUNC + + REPORT.TEST("CC1311A","CHECK THAT THE DEFAULT EXPRESSIONS " & + "OF THE PARAMETERS OF A FORMAL SUBPROGRAM ARE " & + "USED INSTEAD OF THE DEFAULTS (IF ANY) OF THE " & + "ACTUAL SUBPROGRAM PARAMETER" ) ; + + IF FUN /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, FUNCTION, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH FUNCTION FUN (FIRST : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE)))) + RETURN CUBE ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_FUNC RETURN BOOLEAN IS + BEGIN -- FUNC_WITH_3D_FUNC + + RETURN FUN = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_FUNC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PROCEDURE PROC_WITH_3D_PROC ; + + PROCEDURE PROC_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PROC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PROCEDURE.") ; + END IF ; + + END PROC_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + PACKAGE PKG_WITH_3D_PROC IS + END PKG_WITH_3D_PROC ; + + PACKAGE BODY PKG_WITH_3D_PROC IS + + RESULTS : CUBE ; + + BEGIN -- PKG_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + + IF RESULTS /= CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL " & + "ARRAY, PROCEDURE, AND PACKAGE.") ; + END IF ; + + END PKG_WITH_3D_PROC ; + + GENERIC + + TYPE FIRST_INDEX IS (<>) ; + TYPE SECOND_INDEX IS (<>) ; + TYPE THIRD_INDEX IS (<>) ; + TYPE COMPONENT_TYPE IS PRIVATE ; + DEFAULT_VALUE : IN COMPONENT_TYPE ; + TYPE CUBE IS ARRAY (FIRST_INDEX, + SECOND_INDEX, + THIRD_INDEX) OF COMPONENT_TYPE ; + WITH PROCEDURE PROC (INPUT : IN CUBE := (CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => + DEFAULT_VALUE))) ; + OUTPUT : OUT CUBE) ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN ; + + FUNCTION FUNC_WITH_3D_PROC RETURN BOOLEAN IS + + RESULTS : CUBE ; + + BEGIN -- FUNC_WITH_3D_PROC + + PROC (OUTPUT => RESULTS) ; + RETURN RESULTS = CUBE'(CUBE'RANGE => + (CUBE'RANGE (2) => + (CUBE'RANGE (3) => DEFAULT_VALUE))) ; + + END FUNC_WITH_3D_PROC ; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + FUNCTION FUNC1 RETURN BOOLEAN; + + FUNCTION FUNC1 RETURN BOOLEAN IS + BEGIN -- FUNC1 + RETURN F = T'VAL (0); + END FUNC1; + + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (REPORT.IDENT_INT(0))) + RETURN T; + PACKAGE PKG1 IS END PKG1; + + PACKAGE BODY PKG1 IS + BEGIN -- PKG1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PACKAGE 'PKG1'" ); + END IF; + END PKG1; + GENERIC + TYPE T IS (<>); + WITH FUNCTION F (X : T := T'VAL (0)) RETURN T; + PROCEDURE PROC1; + + PROCEDURE PROC1 IS + BEGIN -- PROC1 + IF F /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "FUNCTION 'F' AND PROCEDURE 'PROC1'" ); + END IF; + END PROC1; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T ; + X : T := T'VAL (0)) ; + FUNCTION FUNC2 RETURN BOOLEAN; + + FUNCTION FUNC2 RETURN BOOLEAN IS + RESULTS : T; + BEGIN -- FUNC2 + P (RESULTS); + RETURN RESULTS = T'VAL (0); + END FUNC2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS : OUT T; + X : T := T'VAL(REPORT.IDENT_INT(0))); + PACKAGE PKG2 IS END PKG2 ; + + PACKAGE BODY PKG2 IS + RESULTS : T; + BEGIN -- PKG2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PACKAGE 'PKG2'" ); + END IF; + END PKG2; + + GENERIC + TYPE T IS (<>); + WITH PROCEDURE P (RESULTS :OUT T; X : T := T'VAL (0)); + PROCEDURE PROC2; + + PROCEDURE PROC2 IS + RESULTS : T; + BEGIN -- PROC2 + P (RESULTS); + IF RESULTS /= T'VAL (0) THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE WITH " & + "PROCEDURE 'P' AND PROCEDURE 'PROC2'" ); + END IF; + END PROC2; + + FUNCTION F1 (A : NUMBERS := ONE) RETURN NUMBERS IS + BEGIN -- F1 + RETURN A; + END; + + PROCEDURE P2 (OUTVAR : OUT NUMBERS; INVAR : NUMBERS := TWO) IS + BEGIN -- P2 + OUTVAR := INVAR; + END; + + FUNCTION TD_FUNC (FIRST : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE)))) + RETURN THREE_DIMENSIONAL IS + + BEGIN -- TD_FUNC + + RETURN FIRST ; + + END TD_FUNC ; + + PROCEDURE TD_PROC (INPUT : IN THREE_DIMENSIONAL := + (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + FIRST_DATE))) ; + OUTPUT : OUT THREE_DIMENSIONAL) IS + BEGIN -- TD_PROC + + OUTPUT := INPUT ; + + END TD_PROC ; + + PROCEDURE NEW_PROC_WITH_3D_FUNC IS NEW + PROC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PACKAGE NEW_PKG_WITH_3D_FUNC IS NEW + PKG_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + FUNCTION NEW_FUNC_WITH_3D_FUNC IS NEW + FUNC_WITH_3D_FUNC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + FUN => TD_FUNC) ; + + PROCEDURE NEW_PROC_WITH_3D_PROC IS NEW + PROC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + PACKAGE NEW_PKG_WITH_3D_PROC IS NEW + PKG_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NEW_FUNC_WITH_3D_PROC IS NEW + FUNC_WITH_3D_PROC (FIRST_INDEX => REALLY_SHORT, + SECOND_INDEX => FIRST_HALF, + THIRD_INDEX => FIRST_FIVE, + COMPONENT_TYPE => DATE, + DEFAULT_VALUE => TODAY, + CUBE => THREE_DIMENSIONAL, + PROC => TD_PROC) ; + + FUNCTION NFUNC1 IS NEW FUNC1 (NUMBERS, F1); + PACKAGE NPKG1 IS NEW PKG1 (NUMBERS, F1); + PROCEDURE NPROC1 IS NEW PROC1 (NUMBERS, F1); + + FUNCTION NFUNC2 IS NEW FUNC2 (NUMBERS, P2); + PACKAGE NPKG2 IS NEW PKG2 (NUMBERS, P2); + PROCEDURE NPROC2 IS NEW PROC2 (NUMBERS, P2); + + BEGIN -- CC1311A + + IF NOT NFUNC1 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC1'" ) ; + END IF ; + + IF NOT NFUNC2 THEN + REPORT.FAILED ("INCORRECT DEFAULT VALUE " & + "WITH FUNCTION 'NFUNC2'" ) ; + END IF ; + + NPROC1 ; + NPROC2 ; + + NEW_PROC_WITH_3D_FUNC ; + + IF NOT NEW_FUNC_WITH_3D_FUNC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND FUNCTION.") ; + END IF ; + + NEW_PROC_WITH_3D_PROC ; + + IF NOT NEW_FUNC_WITH_3D_PROC THEN + REPORT.FAILED ("PROBLEMS WITH THREE DIMENSIONAL ARRAY, " & + "FUNCTION, AND PROCEDURE.") ; + END IF ; + + REPORT.RESULT ; + + END CC1311A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc1311b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,332 ---- + -- CC1311B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF PARAMETERS OF DEFAULT AND FORMAL SUBPROGRAMS HAVE + -- THE SAME TYPE BUT NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES OF + -- THE SUBPROGRAM DENOTED BY THE DEFAULT ARE USED INSTEAD OF + -- SUBTYPES SPECIFIED IN THE FORMAL SUBPROGRAM DECLARATION. + + -- HISTORY: + -- RJW 06/11/86 CREATED ORIGINAL TEST. + -- DHH 10/20/86 CORRECTED RANGE ERRORS. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + -- PWN 10/27/95 REMOVED CHECKS AGAINST ARRAY SLIDING RULES THAT + -- HAVE BEEN RELAXED. + -- PWN 10/25/96 RESTORED CHECKS WITH NEW ADA 95 EXPECTED RESULTS. + + WITH REPORT; USE REPORT; + + PROCEDURE CC1311B IS + + BEGIN + TEST ("CC1311B", "CHECK THAT IF PARAMETERS OF DEFAULT AND " & + "FORMAL SUBPROGRAMS HAVE THE SAME TYPE BUT " & + "NOT THE SAME SUBTYPE, THE PARAMETER SUBTYPES " & + "OF THE SUBPROGRAM DENOTED BY THE DEFAULT ARE " & + "USED INSTEAD OF SUBTYPES SPECIFIED IN THE " & + "FORMAL SUBPROGRAM DECLARATION" ); + + DECLARE + TYPE NUMBERS IS (ZERO, ONE ,TWO); + SUBTYPE ZERO_TWO IS NUMBERS; + SUBTYPE ZERO_ONE IS NUMBERS RANGE ZERO .. ONE; + + FUNCTION FSUB (X : ZERO_ONE) RETURN ZERO_ONE IS + BEGIN + RETURN NUMBERS'VAL (IDENT_INT (NUMBERS'POS (ONE))); + END FSUB; + + GENERIC + WITH FUNCTION F (X : ZERO_TWO := TWO) RETURN ZERO_TWO + IS FSUB; + FUNCTION FUNC RETURN ZERO_TWO; + + FUNCTION FUNC RETURN ZERO_TWO IS + BEGIN + RETURN F; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN ZERO; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "NFUNC1" ); + RETURN ZERO; + END FUNC; + + FUNCTION NFUNC1 IS NEW FUNC; + + BEGIN + IF NFUNC1 = ONE THEN + FAILED ( "NO EXCEPTION RAISED WITH NFUNC1" ); + END IF; + END; + + DECLARE + TYPE GENDER IS (MALE, FEMALE); + + TYPE PERSON (SEX : GENDER) IS + RECORD + CASE SEX IS + WHEN MALE => + BEARDED : BOOLEAN; + WHEN FEMALE => + CHILDREN : INTEGER; + END CASE; + END RECORD; + + SUBTYPE MAN IS PERSON (SEX => MALE); + SUBTYPE TESTWRITER IS PERSON (FEMALE); + + ROSA : TESTWRITER := (FEMALE, 4); + + FUNCTION F (X : MAN) RETURN PERSON IS + TOM : PERSON (MALE) := (MALE, FALSE); + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN TOM; + END IF; + END F; + + GENERIC + TYPE T IS PRIVATE; + X1 : T; + WITH FUNCTION F (X : T) RETURN T IS <> ; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF F(X1) = X1 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE " & + "'PKG' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE " & + "'PKG' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PACKAGE 'PKG'" ); + END PKG; + + PACKAGE NPKG IS NEW PKG (TESTWRITER, ROSA); + + BEGIN + COMMENT ( "PACKAGE BODY ELABORATED - 1" ); + END; + + DECLARE + TYPE VECTOR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + SUBTYPE SUBV1 IS VECTOR (1 .. 5); + SUBTYPE SUBV2 IS VECTOR (2 .. 6); + + V1 : SUBV1 := (1, 2, 3, 4, 5); + + FUNCTION FSUB (Y : SUBV2) RETURN VECTOR IS + Z : SUBV2; + BEGIN + FOR I IN Y'RANGE LOOP + Z (I) := IDENT_INT (Y (I)); + END LOOP; + RETURN Z; + END; + + GENERIC + WITH FUNCTION F (X : SUBV1 := V1) RETURN SUBV1 IS FSUB; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF F = V1 THEN + COMMENT ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC' - 1" ); + ELSE + COMMENT ( "NO EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ( "CONSTRAINT_ERROR RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC'" ); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "FUNCTION 'F' AND PROCEDURE " & + "'PROC'" ); + END PROC; + + PROCEDURE NPROC IS NEW PROC; + BEGIN + NPROC; + END; + + DECLARE + + TYPE ACC IS ACCESS STRING; + + SUBTYPE INDEX1 IS INTEGER RANGE 1 .. 5; + SUBTYPE INDEX2 IS INTEGER RANGE 2 .. 6; + + SUBTYPE ACC1 IS ACC (INDEX1); + SUBTYPE ACC2 IS ACC (INDEX2); + + AC2 : ACC2 := NEW STRING'(2 .. 6 => 'A'); + AC : ACC; + + PROCEDURE P (RESULTS : OUT ACC1; X : ACC1) IS + BEGIN + RESULTS := NULL; + END P; + + GENERIC + WITH PROCEDURE P1 (RESULTS : OUT ACC2; X : ACC2 := AC2) + IS P; + FUNCTION FUNC RETURN ACC; + + FUNCTION FUNC RETURN ACC IS + RESULTS : ACC; + BEGIN + P1 (RESULTS); + RETURN RESULTS; + EXCEPTION + WHEN CONSTRAINT_ERROR => + RETURN NEW STRING'("ABCDE"); + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "NFUNC2" ); + RETURN NULL; + END FUNC; + + FUNCTION NFUNC2 IS NEW FUNC; + + BEGIN + AC := NFUNC2; + IF AC = NULL OR ELSE AC.ALL /= "ABCDE" THEN + FAILED ( "NO OR WRONG EXCEPTION RAISED WITH NFUNC2" ); + END IF; + END; + + DECLARE + SUBTYPE FLOAT1 IS FLOAT RANGE -1.0 .. 0.0; + SUBTYPE FLOAT2 IS FLOAT RANGE 0.0 .. 1.0; + + PROCEDURE PSUB (RESULTS : OUT FLOAT2; X : FLOAT2) IS + BEGIN + IF EQUAL (3, 3) THEN + RESULTS := X; + ELSE + RESULTS := 0.0; + END IF; + END PSUB; + + GENERIC + WITH PROCEDURE P (RESULTS : OUT FLOAT1; + X : FLOAT1 := -0.0625) IS PSUB; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + RESULTS : FLOAT1; + BEGIN + P (RESULTS); + IF RESULTS = 1.0 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE " & + "'PKG' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE " & + "'PKG' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PACKAGE 'PKG'" ); + END PKG; + + PACKAGE NPKG IS NEW PKG; + BEGIN + COMMENT ( "PACKAGE BODY ELABORATED - 2" ); + END; + + DECLARE + TYPE FIXED IS DELTA 0.125 RANGE -1.0 .. 1.0; + SUBTYPE FIXED1 IS FIXED RANGE -0.5 .. 0.0; + SUBTYPE FIXED2 IS FIXED RANGE 0.0 .. 0.5; + + PROCEDURE P (RESULTS : OUT FIXED1; X : FIXED1) IS + BEGIN + IF EQUAL (3, 3) THEN + RESULTS := X; + ELSE + RESULTS := X; + END IF; + END P; + + GENERIC + TYPE F IS DELTA <>; + F1 : F; + WITH PROCEDURE P (RESULTS : OUT F; X : F) IS <> ; + PROCEDURE PROC; + + PROCEDURE PROC IS + RESULTS : F; + BEGIN + P (RESULTS, F1); + IF RESULTS = 0.0 THEN + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC' - 1" ); + ELSE + FAILED ( "NO EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC' - 2" ); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ( "WRONG EXCEPTION RAISED WITH " & + "PROCEDURE 'P' AND PROCEDURE " & + "'PROC'" ); + END PROC; + + PROCEDURE NPROC IS NEW PROC (FIXED2, 0.125); + + BEGIN + NPROC; + END; + + RESULT; + + END CC1311B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc2002a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CC2002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE ELABORATION OF A GENERIC BODY HAS NO EFFECT OTHER + -- THAN TO ESTABLISH THE TEMPLATE BODY TO BE USED FOR THE + -- CORRESPONDING INSTANTIATIONS. + + -- ASL 09/02/81 + -- EG 10/30/85 ELIMINATE THE USE OF NUMERIC_ERROR IN TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC2002A IS + + GLOBAL : INTEGER := 0; + Q : INTEGER RANGE 1..1 := 1; + BEGIN + TEST ("CC2002A","NO SIDE EFFECTS OF ELABORATION OF GENERIC BODY"); + + BEGIN + DECLARE + GENERIC + PACKAGE P IS + END P; + + GENERIC PROCEDURE PROC; + + PROCEDURE PROC IS + C : CONSTANT INTEGER RANGE 1 .. 1 := 2; + BEGIN + RAISE PROGRAM_ERROR; + END PROC; + + PACKAGE BODY P IS + C : CONSTANT BOOLEAN := + BOOLEAN'SUCC(IDENT_BOOL(TRUE)); + BEGIN + GLOBAL := 1; + Q := Q + 1; + END P; + BEGIN + NULL; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING ELABORATION OF " & + "GENERIC BODY"); + END; + + IF GLOBAL /= 0 THEN + FAILED ("VALUE OF GLOBAL VARIABLE CHANGED BY ELABORATION " & + "OF GENERIC BODY"); + END IF; + + RESULT; + END CC2002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc30001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc30001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc30001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc30001.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,219 ---- + -- CC30001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if a non-overriding primitive subprogram is declared for + -- a type derived from a formal derived tagged type, the copy of that + -- subprogram in an instance can override a subprogram inherited from the + -- actual type. + -- + -- TEST DESCRIPTION: + -- User writes program to handle both mail messages and system messages. + -- + -- Mail messages are created by instantiating a generic "mail" package + -- with a root message type. System messages are created by + -- instantiating the generic with a system message type derived from the + -- root in a separate package. The system message type has a primitive + -- subprogram called Send. + -- + -- Inside the generic, a "mail" type is derived from the generic formal + -- derived type, and a "Send" operation is declared. + -- + -- Declare a root tagged type T. Declare a generic package with a formal + -- derived type using the root tagged type as ancestor. In the generic, + -- derive a type from the formal derived type and declare a primitive + -- subprogram for it. In a separate package, declare a derivative DT of + -- the root tagged type T and declare a primitive subprogram which is + -- type conformant with (and hence, overridable for) the primitive + -- declared in the generic. Instantiate the generic for DT. Make both + -- dispatching and non-dispatching calls to the primitive subprogram. In + -- both cases the version of the subprogram in the instance should be + -- called (since it overrides the implementation inherited from the + -- actual). + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 13 Apr 95 SAIC Replaced call involving instance for root tagged + -- type with a dispatching call involving instance + -- for derived type. Updated commentary. Moved + -- instantiations (and related commentary) to + -- library-level to avoid accessibility violation. + -- Commented out instantiation for root tagged type. + -- 27 Feb 97 PWB.CTA Added elaboration pragma. + --! + + package CC30001_0 is -- Root message type. + + type Msg_Type is tagged record + Text : String (1 .. 20); + Message_Sent : Boolean; + end record; + + end CC30001_0; + + + --==================================================================-- + + + with CC30001_0; -- Root message type. + generic -- Generic "mail" package. + type Message is new CC30001_0.Msg_Type with private; + package CC30001_1 is + + type Mail_Type is new Message with record -- Derived from formal type. + To : String (1 .. 8); + end record; + + procedure Send (M : in out Mail_Type); -- For this test, this version + -- of Send should be called in + -- ... Other operations. -- all cases. + + end CC30001_1; + + + --==================================================================-- + + + package body CC30001_1 is + + procedure Send (M : in out Mail_Type) is + begin + -- ... Code to send message omitted for brevity. + M.Message_Sent := True; + end Send; + + end CC30001_1; + + + --==================================================================-- + + + with CC30001_0; -- Root message type. + package CC30001_2 is -- System message type and operations. + + type Signal_Type is (Note, Warning, Error); + + type Sys_Message is new CC30001_0.Msg_Type with record -- Derived from + Signal : Signal_Type := Warning; -- root type. + end record; + + procedure Send (Item : in out Sys_Message); -- For this test, this version + -- of Send should never be + -- ... Other operations. -- called (it will have been + -- overridden). + end CC30001_2; + + + --==================================================================-- + + + package body CC30001_2 is + + procedure Send (Item : in out Sys_Message) is + begin + -- ... Code to send message omitted for brevity. + Item.Message_Sent := False; -- Ensure this procedure gives a different + end Send; -- result than CC30001_1.Send. + + end CC30001_2; + + + --==================================================================-- + + + -- User first sets up support for mail messages by instantiating the + -- generic mail package for the root message type. An operation "Send" is + -- declared for the mail message type in the instance. + -- + -- with CC30001_0; -- Root message type. + -- with CC30001_1; -- Generic "mail" package. + -- package Mail_Messages is new CC30001_1 (CC30001_0.Msg_Type); + + + --==================================================================-- + + + -- Next, the user sets up support for system messages by instantiating the + -- generic mail package with the system message type. An operation "Send" + -- is declared for the "system" mail message type in the instance. This + -- operation overrides the "Send" operation inherited from the system + -- message type actual (a situation the user may not have intended). + + with CC30001_1; -- Generic "mail" package. + with CC30001_2; -- System message type and operations. + pragma Elaborate (CC30001_1); + package CC30001_3 is new CC30001_1 (CC30001_2.Sys_Message); + + + --==================================================================-- + + with CC30001_2; -- System message type and operations. + with CC30001_3; -- Instance with mail type and operations. + + with Report; + procedure CC30001 is + + package System_Messages renames CC30001_3; + + + Sys_Msg1 : System_Messages.Mail_Type := (Text => "System shutting down", + Signal => CC30001_2.Warning, + To => "AllUsers", + Message_Sent => False); + + Sys_Msg2 : System_Messages.Mail_Type'Class := Sys_Msg1; + + + use System_Messages, CC30001_2; -- All versions of "Send" + -- directly visible. + + begin + + Report.Test ("CC30001", "Check that if a non-overriding primitive " & + "subprogram is declared for a type derived from a formal " & + "derived tagged type, the copy of that subprogram in an " & + "instance can override a subprogram inherited from the " & + "actual type"); + + + Send (Sys_Msg1); -- Calls version declared in instance (version declared + -- in CC30001_2 has been overridden). + + if not Sys_Msg1.Message_Sent then + Report.Failed ("Non-dispatching call: instance operation not called"); + end if; + + + Send (Sys_Msg2); -- Calls version declared in instance (version declared + -- in CC30001_2 has been overridden). + + if not Sys_Msg2.Message_Sent then + Report.Failed ("Dispatching call: instance operation not called"); + end if; + + + Report.Result; + end CC30001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc30002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc30002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc30002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc30002.a 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,349 ---- + -- CC30002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an explicit declaration in the private part of an instance + -- does not override an implicit declaration in the instance, unless the + -- corresponding explicit declaration in the generic overrides a + -- corresponding implicit declaration in the generic. Check for primitive + -- subprograms of tagged types. + -- + -- TEST DESCRIPTION: + -- Consider the following: + -- + -- type Ancestor is tagged null record; + -- procedure R (X: in Ancestor); + -- + -- generic + -- type Formal is new Ancestor with private; + -- package G is + -- type T is new Formal with null record; + -- -- Implicit procedure R (X: in T); + -- procedure P (X: in T); -- (1) + -- private + -- procedure Q (X: in T); -- (2) + -- procedure R (X: in T); -- (3) Overrides implicit R in generic. + -- end G; + -- + -- type Actual is new Ancestor with null record; + -- procedure P (X: in Actual); + -- procedure Q (X: in Actual); + -- procedure R (X: in Actual); + -- + -- package Instance is new G (Formal => Actual); + -- + -- In the instance, the copy of P at (1) overrides Actual's P, since it + -- is declared in the visible part of the instance. The copy of Q at (2) + -- does not override anything. The copy of R at (3) overrides Actual's + -- R, even though it is declared in the private part, because within + -- the generic the explicit declaration of R overrides an implicit + -- declaration. + -- + -- Thus, for calls involving a parameter with tag T: + -- - Calls to P will execute the body declared for T. + -- - Calls to Q from within Instance will execute the body declared + -- for T. + -- - Calls to Q from outside Instance will execute the body declared + -- for Actual. + -- - Calls to R will execute the body declared for T. + -- + -- Verify this behavior for both dispatching and nondispatching calls to + -- Q and R. + -- + -- + -- CHANGE HISTORY: + -- 24 Feb 95 SAIC Initial prerelease version. + -- + --! + + package CC30002_0 is + + type TC_Body_Kind is (Body_Of_Ancestor, Body_In_Instance, + Body_Of_Actual, Initial_Value); + + type Camera is tagged record + -- ... Camera components. + TC_Focus_Called : TC_Body_Kind := Initial_Value; + TC_Shutter_Called : TC_Body_Kind := Initial_Value; + end record; + + procedure Focus (C: in out Camera); + + -- ...Other operations. + + end CC30002_0; + + + --==================================================================-- + + + package body CC30002_0 is + + procedure Focus (C: in out Camera) is + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_Of_Ancestor; + end Focus; + + end CC30002_0; + + + --==================================================================-- + + + with CC30002_0; + use CC30002_0; + generic + type Camera_Type is new CC30002_0.Camera with private; + package CC30002_1 is + + type Speed_Camera is new Camera_Type with record + Diag_Code: Positive; + -- ...Other components. + end record; + + -- Implicit procedure Focus (C: in out Speed_Camera) declared in generic. + procedure Self_Test_NonDisp (C: in out Speed_Camera); + procedure Self_Test_Disp (C: in out Speed_Camera'Class); + + private + + -- The following explicit declaration of Set_Shutter_Speed does NOT override + -- a corresponding implicit declaration in the generic. Therefore, its copy + -- does NOT override the implicit declaration (inherited from the actual) + -- in the instance. + + procedure Set_Shutter_Speed (C: in out Speed_Camera); + + -- The following explicit declaration of Focus DOES override a + -- corresponding implicit declaration (inherited from the parent) in the + -- generic. Therefore, its copy overrides the implicit declaration + -- (inherited from the actual) in the instance. + + procedure Focus (C: in out Speed_Camera); -- Overrides implicit Focus + -- in generic. + end CC30002_1; + + + --==================================================================-- + + + package body CC30002_1 is + + procedure Self_Test_NonDisp (C: in out Speed_Camera) is + begin + -- Nondispatching calls: + Focus (C); + Set_Shutter_Speed (C); + end Self_Test_NonDisp; + + procedure Self_Test_Disp (C: in out Speed_Camera'Class) is + begin + -- Dispatching calls: + Focus (C); + Set_Shutter_Speed (C); + end Self_Test_Disp; + + procedure Set_Shutter_Speed (C: in out Speed_Camera) is + begin + -- Artificial for testing purposes. + C.TC_Shutter_Called := Body_In_Instance; + end Set_Shutter_Speed; + + procedure Focus (C: in out Speed_Camera) is + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_In_Instance; + end Focus; + + end CC30002_1; + + + --==================================================================-- + + + with CC30002_0; + package CC30002_2 is + + type Aperture_Camera is new CC30002_0.Camera with record + FStop: Natural; + -- ...Other components. + end record; + + procedure Set_Shutter_Speed (C: in out Aperture_Camera); + procedure Focus (C: in out Aperture_Camera); + + end CC30002_2; + + + --==================================================================-- + + + package body CC30002_2 is + + procedure Set_Shutter_Speed (C: in out Aperture_Camera) is + use CC30002_0; + begin + -- Artificial for testing purposes. + C.TC_Shutter_Called := Body_Of_Actual; + end Set_Shutter_Speed; + + procedure Focus (C: in out Aperture_Camera) is + use CC30002_0; + begin + -- Artificial for testing purposes. + C.TC_Focus_Called := Body_Of_Actual; + end Focus; + + end CC30002_2; + + + --==================================================================-- + + + -- Instance declaration. + + with CC30002_1; + with CC30002_2; + package CC30002_3 is new CC30002_1 (Camera_Type => CC30002_2.Aperture_Camera); + + + --==================================================================-- + + + with CC30002_0; + with CC30002_1; + with CC30002_2; + with CC30002_3; -- Instance. + + with Report; + procedure CC30002 is + + package Speed_Cameras renames CC30002_3; + + use CC30002_0; + + TC_Camera1: Speed_Cameras.Speed_Camera; + TC_Camera2: Speed_Cameras.Speed_Camera'Class := TC_Camera1; + TC_Camera3: Speed_Cameras.Speed_Camera; + TC_Camera4: Speed_Cameras.Speed_Camera; + + begin + Report.Test ("CC30002", "Check that an explicit declaration in the " & + "private part of an instance does not override an implicit " & + "declaration in the instance, unless the corresponding " & + "explicit declaration in the generic overrides a " & + "corresponding implicit declaration in the generic. Check " & + "for primitive subprograms of tagged types"); + + -- + -- Check non-dispatching calls outside instance: + -- + + -- Non-overriding primitive operation: + + Speed_Cameras.Set_Shutter_Speed (TC_Camera1); + if TC_Camera1.TC_Shutter_Called /= Body_Of_Actual then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Set_Shutter_Speed outside instance"); + end if; + + + -- Overriding primitive operation: + + Speed_Cameras.Focus (TC_Camera1); + if TC_Camera1.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Focus outside instance"); + end if; + + + -- + -- Check dispatching calls outside instance: + -- + + -- Non-overriding primitive operation: + + Speed_Cameras.Set_Shutter_Speed (TC_Camera2); + if TC_Camera2.TC_Shutter_Called /= Body_Of_Actual then + Report.Failed ("Wrong body executed: dispatching call to " & + "Set_Shutter_Speed outside instance"); + end if; + + + -- Overriding primitive operation: + + Speed_Cameras.Focus (TC_Camera2); + if TC_Camera2.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Focus outside instance"); + end if; + + + + -- + -- Check non-dispatching calls within instance: + -- + + Speed_Cameras.Self_Test_NonDisp (TC_Camera3); + + -- Non-overriding primitive operation: + + if TC_Camera3.TC_Shutter_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Set_Shutter_Speed inside instance"); + end if; + + -- Overriding primitive operation: + + if TC_Camera3.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: non-dispatching call to " & + "Focus inside instance"); + end if; + + + + -- + -- Check dispatching calls within instance: + -- + + Speed_Cameras.Self_Test_Disp (TC_Camera4); + + -- Non-overriding primitive operation: + + if TC_Camera4.TC_Shutter_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Set_Shutter_Speed inside instance"); + end if; + + -- Overriding primitive operation: + + if TC_Camera4.TC_Focus_Called /= Body_In_Instance then + Report.Failed ("Wrong body executed: dispatching call to " & + "Focus inside instance"); + end if; + + Report.Result; + end CC30002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3004a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CC3004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT ACTUAL PARAMETERS IN A NAMED GENERIC ACTUAL PARAMETER + -- ASSOCIATION MAY BE OUT OF ORDER, AND ARE ASSOCIATED WITH THE + -- CORRECT FORMALS. + + -- DAT 9/16/81 + -- SPS 10/26/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3004A IS + BEGIN + TEST ("CC3004A", "ORDER OF NAMED GENERIC ACTUAL PARAMETERS"); + + DECLARE + GENERIC + A,B : INTEGER; + C : INTEGER; + D : INTEGER; + PACKAGE P1 IS END P1; + + TYPE AI IS ACCESS INTEGER; + + GENERIC + TYPE D IS ( <> ); + VD : D; + TYPE AD IS ACCESS D; + VA : AD; + PACKAGE P2 IS END P2; + + X : AI := NEW INTEGER '(IDENT_INT(23)); + Y : AI := NEW INTEGER '(IDENT_INT(77)); + + PACKAGE BODY P1 IS + BEGIN + IF A /= IDENT_INT(4) OR + B /= IDENT_INT(12) OR + C /= IDENT_INT(11) OR + D /= IDENT_INT(-33) + THEN + FAILED ("WRONG GENERIC PARAMETER ASSOCIATIONS"); + END IF; + END P1; + + PACKAGE BODY P2 IS + BEGIN + IF VA.ALL /= VD THEN + FAILED ("WRONG GENERIC PARM ASSOCIATIONS 2"); + END IF; + END P2; + + PACKAGE N1 IS NEW P1 (C => 11, A => 4, D => -33, B => 12); + + PACKAGE N2 IS NEW P2 (VA => X, AD => AI, D => INTEGER, + VD => 23); + + PACKAGE N3 IS NEW P2 (INTEGER, 77, VA => Y, AD => AI); + + BEGIN + NULL; + END; + + RESULT; + END CC3004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3007a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CC3007A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NAMES IN A GENERIC DECLARATIONS ARE STATICALLY BOUND. + + -- DAT 9/18/81 + -- SPS 2/7/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3007A IS + BEGIN + TEST ("CC3007A", "NAMES IN GENERICS ARE STATICALLY BOUND"); + + DECLARE + I : INTEGER := 1; + EX : EXCEPTION; + IA : INTEGER := I'SIZE; + + FUNCTION F (X : INTEGER) RETURN INTEGER; + + PACKAGE P IS + Q : INTEGER := 1; + END P; + + GENERIC + J : IN OUT INTEGER; + WITH FUNCTION FP (X : INTEGER) RETURN INTEGER IS F; + PACKAGE GP IS + V1 : INTEGER := F(I); + V2 : INTEGER := FP(I); + END GP; + + GENERIC + TYPE T IS RANGE <> ; + WITH FUNCTION F1 (X : INTEGER) RETURN INTEGER IS F; + INP : IN T := T (I'SIZE); + FUNCTION F1 (X : T) RETURN T; + + FUNCTION F1 (X : T) RETURN T IS + BEGIN + IF INP /= T(IA) THEN + FAILED ("INCORRECT GENERIC BINDING 2"); + END IF; + I := I + 1; + RETURN 2 * T (F1 (F (INTEGER (X) + I + P.Q))); + END F1; + + PACKAGE BODY GP IS + PACKAGE P IS + Q : INTEGER := I + 1; + END P; + I : INTEGER := 1000; + FUNCTION F IS NEW F1 (INTEGER); + FUNCTION F2 IS NEW F1 (INTEGER); + BEGIN + P.Q := F2 (J + P.Q + V1 + 2 * V2); + J := P.Q; + RAISE EX; + END GP; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + I := I + 2; + RETURN X + I; + END; + BEGIN + DECLARE + I : INTEGER := 1000; + EX : EXCEPTION; + FUNCTION F IS NEW F1 (INTEGER); + V : INTEGER := F (3); + BEGIN + BEGIN + DECLARE + PACKAGE P IS NEW GP (V); + BEGIN + FAILED ("EX NOT RAISED"); + END; + EXCEPTION + WHEN EX => + FAILED ("WRONG EXCEPTION RAISED"); + WHEN OTHERS => + IF V /= 266 THEN + FAILED ("WRONG BINDING IN GENERICS"); + END IF; + RAISE; + END; + + END; + EXCEPTION + WHEN EX => NULL; + WHEN OTHERS => FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + RESULT; + END CC3007A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3007b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,397 ---- + -- CC3007B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE NAMES IN A GENERIC INSTANTIATION ARE STATICALLY + -- IDENTIFIED (I.E., BOUND) AT THE TEXTUAL POINT OF THE INSTANTIA- + -- TION, AND ARE BOUND BEFORE BEING "SUBSTITUTED" FOR THE COR- + -- RESPONDING GENERIC FORMAL PARAMETERS IN THE SPECIFICATION AND + -- BODY TEMPLATES. + -- + -- SEE AI-00365/05-BI-WJ. + + -- HISTORY: + -- EDWARD V. BERARD, 15 AUGUST 1990 + -- DAS 08 OCT 90 CHANGED INSTANTIATIONS TO USE VARIABLES + -- M1 AND M2 IN THE FIRST_BLOCK INSTANTIA- + -- TION AND TO ASSIGN THIRD_DATE AND + -- FOURTH_DATE VALUES BEFORE AND AFTER THE + -- SECOND_BLOCK INSTANTIATION. + + WITH REPORT; + + PROCEDURE CC3007B IS + + INCREMENTED_VALUE : NATURAL := 0; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC); + TYPE DAY_TYPE IS RANGE 1 .. 31; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE; + DAY : DAY_TYPE; + YEAR : YEAR_TYPE; + END RECORD; + + TYPE DATE_ACCESS IS ACCESS DATE; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990); + + CHRISTMAS : DATE := (MONTH => DEC, + DAY => 25, + YEAR => 1948); + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989); + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949); + + FIRST_DUE_DATE : DATE := (MONTH => JAN, + DAY => 23, + YEAR => 1990); + + LAST_DUE_DATE : DATE := (MONTH => DEC, + DAY => 20, + YEAR => 1990); + + THIS_MONTH : MONTH_TYPE := AUG; + + STORED_RECORD : DATE := TODAY; + + STORED_INDEX : MONTH_TYPE := AUG; + + FIRST_DATE : DATE_ACCESS := NEW DATE'(WALL_DATE); + SECOND_DATE : DATE_ACCESS := FIRST_DATE; + + THIRD_DATE : DATE_ACCESS := NEW DATE'(BIRTH_DATE); + FOURTH_DATE : DATE_ACCESS := NEW DATE'(CHRISTMAS); + + TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE; + REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990), + (MAR, 23, 1990), (APR, 23, 1990), + (MAY, 23, 1990), (JUN, 22, 1990), + (JUL, 23, 1990), (AUG, 23, 1990), + (SEP, 24, 1990), (OCT, 23, 1990), + (NOV, 23, 1990), (DEC, 20, 1990)); + + GENERIC + + NATURALLY : IN NATURAL; + FIRST_RECORD : IN OUT DATE; + SECOND_RECORD : IN OUT DATE; + TYPE RECORD_POINTER IS ACCESS DATE; + POINTER : IN OUT RECORD_POINTER; + TYPE ARRAY_TYPE IS ARRAY (MONTH_TYPE) OF DATE; + THIS_ARRAY : IN OUT ARRAY_TYPE; + FIRST_ARRAY_ELEMENT : IN OUT DATE; + SECOND_ARRAY_ELEMENT : IN OUT DATE; + INDEX_ELEMENT : IN OUT MONTH_TYPE; + POINTER_TEST : IN OUT DATE; + ANOTHER_POINTER_TEST : IN OUT DATE; + + PACKAGE TEST_ACTUAL_PARAMETERS IS + + PROCEDURE EVALUATE_FUNCTION; + PROCEDURE CHECK_RECORDS; + PROCEDURE CHECK_ACCESS; + PROCEDURE CHECK_ARRAY; + PROCEDURE CHECK_ARRAY_ELEMENTS; + PROCEDURE CHECK_SCALAR; + PROCEDURE CHECK_POINTERS; + + END TEST_ACTUAL_PARAMETERS; + + PACKAGE BODY TEST_ACTUAL_PARAMETERS IS + + PROCEDURE EVALUATE_FUNCTION IS + BEGIN -- EVALUATE_FUNCTION + + IF (INCREMENTED_VALUE = 0) OR + (NATURALLY /= INCREMENTED_VALUE) THEN + REPORT.FAILED ("PROBLEMS EVALUATING FUNCTION " & + "PARAMETER."); + END IF; + + END EVALUATE_FUNCTION; + + PROCEDURE CHECK_RECORDS IS + + STORE : DATE; + + BEGIN -- CHECK_RECORDS + + IF STORED_RECORD /= FIRST_RECORD THEN + REPORT.FAILED ("PROBLEM WITH RECORD TYPES"); + ELSE + STORED_RECORD := SECOND_RECORD; + STORE := FIRST_RECORD; + FIRST_RECORD := SECOND_RECORD; + SECOND_RECORD := STORE; + END IF; + + END CHECK_RECORDS; + + PROCEDURE CHECK_ACCESS IS + BEGIN -- CHECK_ACCESS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF POINTER.ALL /= DATE'(WALL_DATE) THEN + REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " & + "- 1"); + ELSE + POINTER.ALL := DATE'(BIRTH_DATE); + END IF; + ELSE + IF POINTER.ALL /= DATE'(BIRTH_DATE) THEN + REPORT.FAILED ("PROBLEM WITH ACCESS TYPES " & + "- 2"); + ELSE + POINTER.ALL := DATE'(WALL_DATE); + END IF; + END IF; + + END CHECK_ACCESS; + + PROCEDURE CHECK_ARRAY IS + + STORE : DATE; + + BEGIN -- CHECK_ARRAY + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF THIS_ARRAY (THIS_ARRAY'FIRST) /= FIRST_DUE_DATE + THEN + REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 1"); + ELSE + THIS_ARRAY (THIS_ARRAY'FIRST) := LAST_DUE_DATE; + THIS_ARRAY (THIS_ARRAY'LAST) := FIRST_DUE_DATE; + END IF; + ELSE + IF THIS_ARRAY (THIS_ARRAY'FIRST) /= LAST_DUE_DATE + THEN + REPORT.FAILED ("PROBLEM WITH ARRAY TYPES - 2"); + ELSE + THIS_ARRAY (THIS_ARRAY'FIRST) := + FIRST_DUE_DATE; + THIS_ARRAY (THIS_ARRAY'LAST) := LAST_DUE_DATE; + END IF; + END IF; + + END CHECK_ARRAY; + + PROCEDURE CHECK_ARRAY_ELEMENTS IS + + STORE : DATE; + + BEGIN -- CHECK_ARRAY_ELEMENTS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF (FIRST_ARRAY_ELEMENT.MONTH /= MAY) OR + (SECOND_ARRAY_ELEMENT.DAY /= 22) THEN + REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " & + "- 1"); + ELSE + STORE := FIRST_ARRAY_ELEMENT; + FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT; + SECOND_ARRAY_ELEMENT := STORE; + END IF; + ELSE + IF (FIRST_ARRAY_ELEMENT.MONTH /= JUN) OR + (SECOND_ARRAY_ELEMENT.DAY /= 23) THEN + REPORT.FAILED ("PROBLEM WITH ARRAY ELEMENTS " & + "- 2"); + ELSE + STORE := FIRST_ARRAY_ELEMENT; + FIRST_ARRAY_ELEMENT := SECOND_ARRAY_ELEMENT; + SECOND_ARRAY_ELEMENT := STORE; + END IF; + END IF; + + END CHECK_ARRAY_ELEMENTS; + + PROCEDURE CHECK_SCALAR IS + BEGIN -- CHECK_SCALAR + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF INDEX_ELEMENT /= STORED_INDEX THEN + REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 1"); + ELSE + INDEX_ELEMENT := + MONTH_TYPE'SUCC(INDEX_ELEMENT); + STORED_INDEX := INDEX_ELEMENT; + END IF; + ELSE + IF INDEX_ELEMENT /= STORED_INDEX THEN + REPORT.FAILED ("PROBLEM WITH INDEX TYPES - 2"); + ELSE + INDEX_ELEMENT := + MONTH_TYPE'PRED (INDEX_ELEMENT); + STORED_INDEX := INDEX_ELEMENT; + END IF; + END IF; + + END CHECK_SCALAR; + + PROCEDURE CHECK_POINTERS IS + + STORE : DATE; + + BEGIN -- CHECK_POINTERS + + IF ((INCREMENTED_VALUE / 2) * 2) /= INCREMENTED_VALUE + THEN + IF (POINTER_TEST /= DATE'(OCT, 3, 1949)) OR + (ANOTHER_POINTER_TEST /= DATE'(DEC, 25, 1948)) + THEN + REPORT.FAILED ("PROBLEM WITH POINTER TEST " & + "- 1"); + ELSE + STORE := POINTER_TEST; + POINTER_TEST := ANOTHER_POINTER_TEST; + ANOTHER_POINTER_TEST := STORE; + END IF; + ELSE + IF (POINTER_TEST /= DATE'(DEC, 25, 1948)) OR + (ANOTHER_POINTER_TEST /= DATE'(OCT, 3, 1949)) + THEN + REPORT.FAILED ("PROBLEM WITH POINTER TEST " & + "- 2"); + ELSE + STORE := POINTER_TEST; + POINTER_TEST := ANOTHER_POINTER_TEST; + ANOTHER_POINTER_TEST := STORE; + END IF; + END IF; + + END CHECK_POINTERS; + + END TEST_ACTUAL_PARAMETERS; + + FUNCTION INC RETURN NATURAL IS + BEGIN -- INC + INCREMENTED_VALUE := NATURAL'SUCC (INCREMENTED_VALUE); + RETURN INCREMENTED_VALUE; + END INC; + + BEGIN -- CC3007B + + REPORT.TEST ("CC3007B", "CHECK THAT THE NAMES IN A GENERIC " & + "INSTANTIATION ARE STAICALLY IDENTIFIED (I.E., " & + "BOUND) AT THE TEXTUAL POINT OF THE INSTANTIATION" & + ", AND ARE BOUND BEFORE BEING SUBSTITUTED FOR " & + "THE CORRESPONDING GENERIC FORMAL PARAMETERS IN " & + "THE SPECIFICATION AND BODY TEMPLATES. " & + "SEE AI-00365/05-BI-WJ."); + + FIRST_BLOCK: + + DECLARE + + M1 : MONTH_TYPE := MAY; + M2 : MONTH_TYPE := JUN; + + PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS + NEW TEST_ACTUAL_PARAMETERS ( + NATURALLY => INC, + FIRST_RECORD => TODAY, + SECOND_RECORD => CHRISTMAS, + RECORD_POINTER => DATE_ACCESS, + POINTER => SECOND_DATE, + ARRAY_TYPE => DUE_DATES, + THIS_ARRAY => REPORT_DATES, + FIRST_ARRAY_ELEMENT => REPORT_DATES (M1), + SECOND_ARRAY_ELEMENT => REPORT_DATES (M2), + INDEX_ELEMENT => THIS_MONTH, + POINTER_TEST => THIRD_DATE.ALL, + ANOTHER_POINTER_TEST => FOURTH_DATE.ALL); + + BEGIN -- FIRST_BLOCK + + REPORT.COMMENT ("ENTERING FIRST BLOCK"); + NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR; + M1 := SEP; + M2 := OCT; + -- NEW_TEST_ACTUAL_PARAMETERS SHOULD USE THE PREVIOUS + -- VALUES OF MAY AND JUN. + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS; + + END FIRST_BLOCK; + + SECOND_BLOCK: + + DECLARE + + SAVE_THIRD_DATE : DATE_ACCESS := THIRD_DATE; + SAVE_FOURTH_DATE : DATE_ACCESS := FOURTH_DATE; + + PACKAGE NEW_TEST_ACTUAL_PARAMETERS IS + NEW TEST_ACTUAL_PARAMETERS ( + NATURALLY => INC, + FIRST_RECORD => TODAY, + SECOND_RECORD => CHRISTMAS, + RECORD_POINTER => DATE_ACCESS, + POINTER => SECOND_DATE, + ARRAY_TYPE => DUE_DATES, + THIS_ARRAY => REPORT_DATES, + FIRST_ARRAY_ELEMENT => REPORT_DATES (MAY), + SECOND_ARRAY_ELEMENT => REPORT_DATES (JUN), + INDEX_ELEMENT => THIS_MONTH, + POINTER_TEST => THIRD_DATE.ALL, + ANOTHER_POINTER_TEST => FOURTH_DATE.ALL); + + BEGIN -- SECOND_BLOCK + + REPORT.COMMENT ("ENTERING SECOND BLOCK"); + NEW_TEST_ACTUAL_PARAMETERS.EVALUATE_FUNCTION; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_SCALAR; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ARRAY_ELEMENTS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_ACCESS; + NEW_TEST_ACTUAL_PARAMETERS.CHECK_RECORDS; + + THIRD_DATE := NEW DATE'(JUL, 13, 1951); + FOURTH_DATE := NEW DATE'(JUL, 4, 1976); + NEW_TEST_ACTUAL_PARAMETERS.CHECK_POINTERS; + THIRD_DATE := SAVE_THIRD_DATE; + FOURTH_DATE := SAVE_FOURTH_DATE; + + END SECOND_BLOCK; + + REPORT.RESULT; + + END CC3007B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3011a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- CC3011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT SUBPROGRAMS THAT WOULD HAVE THE SAME SPECIFICATION + -- AFTER GENERIC INSTANTIATION MAY BE DECLARED IN THE SAME + -- DECLARATIVE PART, AND THAT CALLS WITHIN THE INSTANTIATED UNIT ARE + -- UNAMBIGUOUS. CHECK THAT CALLS FROM OUTSIDE THE UNIT ARE UNAMBIGUOUS + -- IF FORMAL PARAMETER NAMES ARE USED OR IF ONLY ONE OF THE EQUIVALENT + -- PROGRAMS APPEARS IN THE VISIBLE PART OF THE PACKAGE. + + -- DAT 9/18/81 + -- SPS 10/19/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3011A IS + BEGIN + TEST ("CC3011A", "CHECK SUBPROGRAMS IN GENERIC PACKAGES WITH SAME" + & " SPECIFICATION AFTER GENERIC PARAMETER SUBSTITUTION"); + + DECLARE + C : INTEGER := 0; + + GENERIC + TYPE S IS ( <> ); + TYPE T IS PRIVATE; + TYPE U IS RANGE <> ; + VT : T; + PACKAGE PKG IS + PROCEDURE P1 (X : S); + PRIVATE + PROCEDURE P1 (X : T); + VS : S := S'FIRST; + VU : U := U'FIRST; + END PKG; + + GENERIC + TYPE S IS (<>); + TYPE T IS RANGE <>; + PACKAGE PP IS + PROCEDURE P1 (D: S); + PROCEDURE P1 (X: T); + END PP; + + PACKAGE BODY PKG IS + PROCEDURE P1 (X : S) IS + BEGIN + C := C + 1; + END P1; + PROCEDURE P1 (X : T) IS + BEGIN + C := C + 2; + END P1; + PROCEDURE P1 (X : U) IS + BEGIN + C := C + 4; + END P1; + BEGIN + C := 0; + P1 (VS); + IF C /= IDENT_INT (1) THEN + FAILED ("WRONG P1 CALLED -S"); + END IF; + C := 0; + P1 (VT); + IF C /= IDENT_INT (2) THEN + FAILED ("WRONG P1 CALLED -T"); + END IF; + C := 0; + P1 (VU); + IF C /= IDENT_INT (4) THEN + FAILED ("WRONG P1 CALLED -U"); + END IF; + C := 0; + END PKG; + + PACKAGE BODY PP IS + PROCEDURE P1 (D: S) IS + BEGIN + C := C + 3; + END P1; + PROCEDURE P1 (X: T) IS + BEGIN + C := C + 5; + END P1; + BEGIN + NULL; + END PP; + + PACKAGE NP IS NEW PKG (INTEGER, INTEGER, INTEGER, 7); + PACKAGE NPP IS NEW PP (INTEGER, INTEGER); + BEGIN + NP.P1 (4); + IF C /= IDENT_INT (1) THEN + FAILED ("INCORRECT OVERLOADING ON FORMAL TYPES"); + END IF; + C := 0; + NPP.P1 (D => 3); + IF C /= IDENT_INT (3) THEN + FAILED ("INCORRECT CALL TO P1 WITH D PARAMETER"); + END IF; + C := 0; + NPP.P1 (X => 7); + IF C /= IDENT_INT (5) THEN + FAILED ("INCORRECT CALL TO P1 WITH X PARAMETER"); + END IF; + END; + + RESULT; + END CC3011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3011d.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CC3011D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC PACKAGE INSTANTIATION CONTAINS DECLARATIONS + -- OF SUBPROGRAMS WITH THE SAME SPECIFICATIONS, THE CALLS TO THE + -- SUBPROGRAMS ARE NOT AMBIGIOUS WITHIN THE GENERIC BODY. + + -- SPS 5/7/82 + -- SPS 2/7/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3011D IS + BEGIN + TEST ("CC3011D", "SUBPROGRAMS WITH SAME SPECIFICATIONS NOT" + & " AMBIGIOUS WITHIN GENERIC BODY"); + + DECLARE + TYPE FLAG IS (PRT,PRS); + XX : FLAG; + + GENERIC + TYPE S IS PRIVATE; + TYPE T IS PRIVATE; + V1 : S; + V2 : T; + PACKAGE P1 IS + PROCEDURE PR(X : S); + PROCEDURE PR(X : T); + END P1; + + PACKAGE BODY P1 IS + PROCEDURE PR (X : S) IS + BEGIN + XX := PRS; + END; + + PROCEDURE PR (X : T ) IS + BEGIN + XX := PRT; + END; + + BEGIN + XX := PRT; + PR (V1); + IF XX /= PRS THEN + FAILED ("WRONG BINDING FOR PR WITH TYPE S"); + END IF; + XX := PRS; + PR (V2); + IF XX /= PRT THEN + FAILED ("WRONG BINDING FOR PR WITH TYPE T"); + END IF; + END P1; + + PACKAGE PAK IS NEW P1 (INTEGER, INTEGER, 1, 2); + + BEGIN + NULL; + END; + + RESULT; + END CC3011D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3012a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,247 ---- + -- CC3012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC INSTANCES MAY BE OVERLOADED. + + -- CHECK THAT THEY MAY OVERLOAD PREVIOUSLY DECLARED SUBPROGRAMS AND + -- ENUMERATION LITERALS. + + -- DAT 9/16/81 + -- SPS 10/19/82 + -- SPS 2/8/83 + -- PWN 11/30/94 REMOVED PART OF TEST INVALID FOR ADA 9X. + + + WITH REPORT; USE REPORT; + + PROCEDURE CC3012A IS + BEGIN + TEST ("CC3012A", "CHECK THAT GENERIC INSTANCES MAY OVERLOAD " & + "OTHER IDENTIFIERS"); + + DECLARE + GENERIC + TYPE T IS ( <> ); + V : IN T; + PROCEDURE GP (X : IN OUT T); + + GENERIC + TYPE T IS ( <> ); + FUNCTION LESS (X, Y : T) RETURN BOOLEAN; + + GENERIC + TYPE T IS ( <> ); + FUNCTION PLUS (X, Y : T) RETURN T; + + GENERIC + TYPE T IS PRIVATE; + Z : T; + FUNCTION F1 RETURN T; + + TYPE DC IS NEW CHARACTER RANGE IDENT_CHAR ('A') .. 'Z'; + TYPE DI IS NEW INTEGER; + TYPE ENUM IS (E1, E2, E3, E4); + + VC : CHARACTER := 'A'; + VI : INTEGER := 5; + VB : BOOLEAN := TRUE; + VE : ENUM := E2; + + TYPE DENUM IS NEW ENUM RANGE E2 .. ENUM'LAST; + + VDE : DENUM := E4; + VDC : DC := 'A'; + VDI : DI := 7; + + PROCEDURE GP (X : IN OUT T) IS + BEGIN + X := V; + END GP; + + FUNCTION LESS (X, Y : T) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END LESS; + + FUNCTION PLUS (X, Y : T) RETURN T IS + BEGIN + RETURN T'FIRST; + END PLUS; + + FUNCTION F1 RETURN T IS + BEGIN + RETURN Z; + END F1; + + FUNCTION E5 RETURN INTEGER IS + BEGIN + RETURN 1; + END E5; + + PACKAGE PKG IS + + PROCEDURE P IS NEW GP (CHARACTER, 'Q'); + PROCEDURE P IS NEW GP (INTEGER, -14); + PROCEDURE P IS NEW GP (BOOLEAN, FALSE); + PROCEDURE P IS NEW GP (ENUM, E4); + PROCEDURE P IS NEW GP (DC, 'W'); + PROCEDURE P IS NEW GP (DI, -33); + PROCEDURE P IS NEW GP (DENUM, E2); + + FUNCTION "<" IS NEW LESS (CHARACTER); + FUNCTION "<" IS NEW LESS (INTEGER); + FUNCTION "<" IS NEW LESS (BOOLEAN); + FUNCTION "<" IS NEW LESS (ENUM); + FUNCTION "<" IS NEW LESS (DC); + FUNCTION "<" IS NEW LESS (DI); + -- NOT FOR DENUM. + + FUNCTION "+" IS NEW PLUS (CHARACTER); + FUNCTION "+" IS NEW PLUS (INTEGER); + FUNCTION "+" IS NEW PLUS (BOOLEAN); + FUNCTION "+" IS NEW PLUS (ENUM); + FUNCTION "+" IS NEW PLUS (DC); + -- NOT FOR DI. + FUNCTION "+" IS NEW PLUS (DENUM); + + FUNCTION E2 IS NEW F1 (BOOLEAN, FALSE); + FUNCTION E5 IS NEW F1 (DC, 'M'); + + END PKG; + + PACKAGE BODY PKG IS + BEGIN + P (VC); + P (VI); + P (VB); + P (VE); + P (X => VDE); + P (X => VDC); + P (X => VDI); + + IF VC /= 'Q' THEN + FAILED ("OVERLOADED PROCEDURE - 1"); + END IF; + + IF VI /= -14 THEN + FAILED ("OVERLOADED PROCEDURE - 2"); + END IF; + + IF VB /= FALSE THEN + FAILED ("OVERLOADED PROCEDURE - 3"); + END IF; + + IF VE /= E4 THEN + FAILED ("OVERLOADED PROCEDURE - 4"); + END IF; + + IF VDE /= E2 THEN + FAILED ("OVERLOADED PROCEDURE - 5"); + END IF; + + IF VDC /= 'W' THEN + FAILED ("OVERLOADED PROCEDURE - 6"); + END IF; + + IF VDI /= -33 THEN + FAILED ("OVERLOADED PROCEDURE - 7"); + END IF; + + IF VC < ASCII.DEL THEN + FAILED ("OVERLOADED LESS THAN - 1"); + END IF; + + IF VI < 1E3 THEN + FAILED ("OVERLOADED LESS THAN - 2"); + END IF; + + IF FALSE < TRUE THEN + FAILED ("OVERLOADED LESS THAN - 3"); + END IF; + + IF E1 < VE THEN + FAILED ("OVERLOADED LESS THAN - 4"); + END IF; + + IF VDC < 'Z' THEN + FAILED ("OVERLOADED LESS THAN - 5"); + END IF; + + IF VDI < 0 THEN + FAILED ("OVERLOADED LESS THAN - 6"); + END IF; + + + IF -14 + 5 /= -9 THEN + FAILED ("OVERLOADED PLUS - 2"); + END IF; + + IF VI + 5 /= INTEGER'FIRST THEN + FAILED ("OVERLOADED PLUS - 3"); + END IF; + + IF VB + TRUE /= FALSE THEN + FAILED ("OVERLOADED PLUS - 4"); + END IF; + + IF VE + E2 /= E1 THEN + FAILED ("OVERLOADED PLUS - 5"); + END IF; + + IF DENUM'(E3) + E2 /= E2 THEN + FAILED ("OVERLOADED PLUS - 6"); + END IF; + + IF VDC + 'B' /= 'A' THEN + FAILED ("OVERLOADED PLUS - 7"); + END IF; + + IF VDI + 14 /= -19 THEN -- -33 + 14 + FAILED ("OVERLOADED PLUS - 8"); + END IF; + + VI := E5; + VDC := E5; + VE := E2; + VB := E2; + IF VI /= 1 OR + VDC /= 'M' OR + VE /= ENUM'VAL(IDENT_INT(1)) OR + VB /= FALSE THEN + FAILED ("OVERLOADING OF ENUMERATION LITERALS " & + "AND PREDEFINED SUBPROGRAMS"); + END IF; + END PKG; + BEGIN + DECLARE + USE PKG; + BEGIN + IF NOT (VI + 5 < 11) THEN + FAILED ("INCORRECT VISIBILITY OF GENERIC OVERLOADING"); + END IF; + END; + END; + + RESULT; + END CC3012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3015a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CC3015A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC PACKAGE INSTANTIATION IS ELABORATED, + -- STATEMENTS IN ITS PACKAGE BODY ARE EXECUTED AND EXPRESSIONS + -- REQUIRING EVALUATION ARE EVALUATED (E.G., DEFAULTS FOR OBJECT + -- DECLARATIONS ARE EVALUATED). + + -- RJW 6/11/86 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3015A IS + BOOL1, BOOL2 : BOOLEAN := FALSE; + + TYPE ENUM IS (BEFORE, AFTER); + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + BOOL2 := TRUE; + RETURN I; + END; + + FUNCTION CHECK (E : ENUM) RETURN CHARACTER IS + BEGIN + IF E = BEFORE THEN + IF BOOL1 THEN + FAILED ( "STATEMENT EXECUTED BEFORE " & + "INSTANTIATION" ); + END IF; + IF BOOL2 THEN + FAILED ( "DEFAULT EXPRESSION EVALUATED " & + "BEFORE INSTANTIATION" ); + END IF; + ELSE + IF BOOL1 THEN + NULL; + ELSE + FAILED ( "STATEMENT NOT EXECUTED AT " & + "INSTANTIATION" ); + END IF; + IF BOOL2 THEN + NULL; + ELSE + FAILED ( "DEFAULT EXPRESSION NOT EVALUATED " & + "AT INSTANTIATION" ); + END IF; + END IF; + RETURN 'A'; + END; + + GENERIC + TYPE INT IS RANGE <>; + PACKAGE PKG IS END PKG; + + PACKAGE BODY PKG IS + I : INT := INT'VAL (F(0)); + BEGIN + BOOL1 := TRUE; + END; + + BEGIN + TEST ("CC3015A", "CHECK THAT WHEN A GENERIC PACKAGE " & + "INSTANTIATION IS ELABORATED, STATEMENTS " & + "IN ITS PACKAGE BODY ARE EXECUTED AND " & + "EXPRESSIONS REQUIRING EVALUATION ARE " & + "EVALUATED (E.G., DEFAULTS FOR OBJECT " & + "DECLARATIONS ARE EVALUATED)" ); + + + DECLARE + A : CHARACTER := CHECK (BEFORE); + + PACKAGE NPKG IS NEW PKG (INTEGER); + + B : CHARACTER := CHECK (AFTER); + + BEGIN + NULL; + END; + + RESULT; + END CC3015A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,396 ---- + -- CC3016B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INSTANCE OF A GENERIC PACKAGE MUST DECLARE A + -- PACKAGE. CHECK THAT THE DECLARATIVE ITEMS IN AN INSTANTIATION + -- OF A GENERIC PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER + -- DECLARED. + + -- HISTORY: + -- EDWARD V. BERARD, 8 AUGUST 1990 + + WITH REPORT ; + + PROCEDURE CC3016B IS + + WHEN_ELABORATED : NATURAL := 0 ; + + TYPE REAL IS DIGITS 6 ; + REAL_VALUE : REAL := 3.14159 ; + + TRUE_VALUE : BOOLEAN := TRUE ; + + CHARACTER_VALUE : CHARACTER := 'Z' ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + + THIS_MONTH : MONTH_TYPE := AUG ; + THIS_YEAR : YEAR_TYPE := 1990 ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE_ACCESS := NEW DATE'(DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + TYPE DUE_DATES IS ARRAY (MONTH_TYPE RANGE JAN .. DEC) OF DATE ; + REPORT_DATES : DUE_DATES := ((JAN, 23, 1990), (FEB, 23, 1990), + (MAR, 23, 1990), (APR, 23, 1990), + (MAY, 23, 1990), (JUN, 22, 1990), + (JUL, 23, 1990), (AUG, 23, 1990), + (SEP, 24, 1990), (OCT, 23, 1990), + (NOV, 23, 1990), (DEC, 20, 1990)) ; + + TYPE LIST_INDEX IS RANGE 1 .. 16 ; + TYPE LIST IS ARRAY (LIST_INDEX) OF NATURAL ; + ORDER_LIST : LIST := (OTHERS => 0) ; + + GENERIC + + TYPE RETURN_TYPE IS PRIVATE ; + RETURN_VALUE : IN OUT RETURN_TYPE ; + POSITION : IN NATURAL ; + OFFSET : IN NATURAL ; + WHEN_ELAB : IN OUT NATURAL ; + TYPE INDEX IS RANGE <> ; + TYPE LIST IS ARRAY (INDEX) OF NATURAL ; + ORDER_LIST : IN OUT LIST ; + + FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE ; + + FUNCTION NAME (VALUE : IN NATURAL) RETURN RETURN_TYPE IS + + BEGIN -- NAME + + IF (VALUE = POSITION) THEN + WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ; + ORDER_LIST (INDEX (POSITION)) := WHEN_ELAB ; + RETURN RETURN_VALUE ; + ELSIF (VALUE = (POSITION + OFFSET)) THEN + WHEN_ELAB := NATURAL'SUCC (WHEN_ELAB) ; + ORDER_LIST (INDEX (POSITION + OFFSET)) := WHEN_ELAB ; + RETURN RETURN_VALUE ; + END IF ; + + END NAME ; + + GENERIC + + TYPE FIRST_TYPE IS PRIVATE ; + WITH FUNCTION FIRST (POSITION : IN NATURAL) + RETURN FIRST_TYPE ; + FIRST_VALUE : IN NATURAL ; + TYPE SECOND_TYPE IS PRIVATE ; + WITH FUNCTION SECOND (POSITION : IN NATURAL) + RETURN SECOND_TYPE ; + SECOND_VALUE : IN NATURAL ; + TYPE THIRD_TYPE IS PRIVATE ; + WITH FUNCTION THIRD (POSITION : IN NATURAL) + RETURN THIRD_TYPE ; + THIRD_VALUE : IN NATURAL ; + TYPE FOURTH_TYPE IS PRIVATE ; + WITH FUNCTION FOURTH (POSITION : IN NATURAL) + RETURN FOURTH_TYPE ; + FOURTH_VALUE : IN NATURAL ; + TYPE FIFTH_TYPE IS PRIVATE ; + WITH FUNCTION FIFTH (POSITION : IN NATURAL) + RETURN FIFTH_TYPE ; + FIFTH_VALUE : IN NATURAL ; + TYPE SIXTH_TYPE IS PRIVATE ; + WITH FUNCTION SIXTH (POSITION : IN NATURAL) + RETURN SIXTH_TYPE ; + SIXTH_VALUE : IN NATURAL ; + TYPE SEVENTH_TYPE IS PRIVATE ; + WITH FUNCTION SEVENTH (POSITION : IN NATURAL) + RETURN SEVENTH_TYPE ; + SEVENTH_VALUE : IN NATURAL ; + TYPE EIGHTH_TYPE IS PRIVATE ; + WITH FUNCTION EIGHTH (POSITION : IN NATURAL) + RETURN EIGHTH_TYPE ; + EIGHTH_VALUE : IN NATURAL ; + TYPE NINTH_TYPE IS PRIVATE ; + WITH FUNCTION NINTH (POSITION : IN NATURAL) + RETURN NINTH_TYPE ; + NINTH_VALUE : IN NATURAL ; + TYPE TENTH_TYPE IS PRIVATE ; + WITH FUNCTION TENTH (POSITION : IN NATURAL) + RETURN TENTH_TYPE ; + TENTH_VALUE : IN NATURAL ; + TYPE ELEVENTH_TYPE IS PRIVATE ; + WITH FUNCTION ELEVENTH (POSITION : IN NATURAL) + RETURN ELEVENTH_TYPE ; + ELEVENTH_VALUE : IN NATURAL ; + TYPE TWELFTH_TYPE IS PRIVATE ; + WITH FUNCTION TWELFTH (POSITION : IN NATURAL) + RETURN TWELFTH_TYPE ; + TWELFTH_VALUE : IN NATURAL ; + TYPE THIRTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION THIRTEENTH (POSITION : IN NATURAL) + RETURN THIRTEENTH_TYPE ; + THIRTEENTH_VALUE : IN NATURAL ; + TYPE FOURTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION FOURTEENTH (POSITION : IN NATURAL) + RETURN FOURTEENTH_TYPE ; + FOURTEENTH_VALUE : IN NATURAL ; + TYPE FIFTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION FIFTEENTH (POSITION : IN NATURAL) + RETURN FIFTEENTH_TYPE ; + FIFTEENTH_VALUE : IN NATURAL ; + TYPE SIXTEENTH_TYPE IS PRIVATE ; + WITH FUNCTION SIXTEENTH (POSITION : IN NATURAL) + RETURN SIXTEENTH_TYPE ; + SIXTEENTH_VALUE : IN NATURAL ; + + PACKAGE ORDER_PACKAGE IS + + A : FIRST_TYPE := FIRST (FIRST_VALUE) ; + B : SECOND_TYPE := SECOND (SECOND_VALUE) ; + C : THIRD_TYPE := THIRD (THIRD_VALUE) ; + D : FOURTH_TYPE := FOURTH (FOURTH_VALUE) ; + E : FIFTH_TYPE := FIFTH (FIFTH_VALUE) ; + F : SIXTH_TYPE := SIXTH (SIXTH_VALUE) ; + G : SEVENTH_TYPE := SEVENTH (SEVENTH_VALUE) ; + H : EIGHTH_TYPE := EIGHTH (EIGHTH_VALUE) ; + I : NINTH_TYPE := NINTH (NINTH_VALUE) ; + J : TENTH_TYPE := TENTH (TENTH_VALUE) ; + K : ELEVENTH_TYPE := ELEVENTH (ELEVENTH_VALUE) ; + L : TWELFTH_TYPE := TWELFTH (TWELFTH_VALUE) ; + M : THIRTEENTH_TYPE := THIRTEENTH (THIRTEENTH_VALUE) ; + N : FOURTEENTH_TYPE := FOURTEENTH (FOURTEENTH_VALUE) ; + O : FIFTEENTH_TYPE := FIFTEENTH (FIFTEENTH_VALUE) ; + P : SIXTEENTH_TYPE := SIXTEENTH (SIXTEENTH_VALUE) ; + + END ORDER_PACKAGE ; + + + FUNCTION BOOL IS NEW NAME (RETURN_TYPE => BOOLEAN, + RETURN_VALUE => TRUE_VALUE, + POSITION => 1, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION INT IS NEW NAME (RETURN_TYPE => YEAR_TYPE, + RETURN_VALUE => THIS_YEAR, + POSITION => 2, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION FLOAT IS NEW NAME (RETURN_TYPE => REAL, + RETURN_VALUE => REAL_VALUE, + POSITION => 3, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION CHAR IS NEW NAME (RETURN_TYPE => CHARACTER, + RETURN_VALUE => CHARACTER_VALUE, + POSITION => 4, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION ENUM IS NEW NAME (RETURN_TYPE => MONTH_TYPE, + RETURN_VALUE => THIS_MONTH, + POSITION => 5, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + FUNCTION ARRY IS NEW NAME (RETURN_TYPE => DUE_DATES, + RETURN_VALUE => REPORT_DATES, + POSITION => 6, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + + FUNCTION RCRD IS NEW NAME (RETURN_TYPE => DATE, + RETURN_VALUE => TODAY, + POSITION => 7, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + + FUNCTION ACSS IS NEW NAME (RETURN_TYPE => DATE_ACCESS, + RETURN_VALUE => FIRST_DATE, + POSITION => 8, + OFFSET => 8, + WHEN_ELAB => WHEN_ELABORATED, + INDEX => LIST_INDEX, + LIST => LIST, + ORDER_LIST => ORDER_LIST) ; + + PACKAGE ELABORATION_ORDER IS NEW ORDER_PACKAGE + (FIRST_TYPE => BOOLEAN, + FIRST => BOOL, + FIRST_VALUE => 1, + THIRD_TYPE => REAL, + THIRD => FLOAT, + THIRD_VALUE => 3, + SECOND_TYPE => YEAR_TYPE, -- ORDERING OF PARAMETERS + SECOND => INT, -- IS DELIBERATE. + SECOND_VALUE => 2, + FOURTH_TYPE => CHARACTER, + FOURTH => CHAR, + FOURTH_VALUE => 4, + FIFTH_TYPE => MONTH_TYPE, + FIFTH => ENUM, + FIFTH_VALUE => 5, + SIXTH_TYPE => DUE_DATES, + SIXTH => ARRY, + SIXTH_VALUE => 6, + SEVENTH_TYPE => DATE, + SEVENTH => RCRD, + SEVENTH_VALUE => 7, + EIGHTH_TYPE => DATE_ACCESS, + EIGHTH => ACSS, + EIGHTH_VALUE => 8, + NINTH_TYPE => BOOLEAN, + NINTH => BOOL, + NINTH_VALUE => 9, + TENTH_TYPE => YEAR_TYPE, + TENTH => INT, + TENTH_VALUE => 10, + ELEVENTH_TYPE => REAL, + ELEVENTH => FLOAT, + ELEVENTH_VALUE => 11, + TWELFTH_TYPE => CHARACTER, + TWELFTH => CHAR, + TWELFTH_VALUE => 12, + THIRTEENTH_TYPE => MONTH_TYPE, + THIRTEENTH => ENUM, + THIRTEENTH_VALUE => 13, + FOURTEENTH_TYPE => DUE_DATES, + FOURTEENTH => ARRY, + FOURTEENTH_VALUE => 14, + FIFTEENTH_TYPE => DATE, + FIFTEENTH => RCRD, + FIFTEENTH_VALUE => 15, + SIXTEENTH_TYPE => DATE_ACCESS, + SIXTEENTH => ACSS, + SIXTEENTH_VALUE => 16) ; + + BEGIN + REPORT.TEST("CC3016B", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PACKAGE MUST DECLARE A PACKAGE. CHECK THAT THE " & + "DECLARATIVE ITEMS IN AN INSTANTIATION OF A GENERIC " & + "PACKAGE SPECIFICATION ARE ELABORATED IN THE ORDER " & + "DECLARED."); + + IF ORDER_LIST(1) /= REPORT.IDENT_INT(1) THEN + REPORT.FAILED("BOOLEAN 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(2) /= REPORT.IDENT_INT(2) THEN + REPORT.FAILED("INTEGER TYPE 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(3) /= REPORT.IDENT_INT(3) THEN + REPORT.FAILED("REAL 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(4) /= REPORT.IDENT_INT(4) THEN + REPORT.FAILED("CHARACTER 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(5) /= REPORT.IDENT_INT(5) THEN + REPORT.FAILED("ENUMERATION 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(6) /= REPORT.IDENT_INT(6) THEN + REPORT.FAILED("ARRAY 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(7) /= REPORT.IDENT_INT(7) THEN + REPORT.FAILED("RECORD 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(8) /= REPORT.IDENT_INT(8) THEN + REPORT.FAILED("ACCESS 1 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(9) /= REPORT.IDENT_INT(9) THEN + REPORT.FAILED("BOOLEAN 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(10) /= REPORT.IDENT_INT(10) THEN + REPORT.FAILED("INTEGER TYPE 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(11) /= REPORT.IDENT_INT(11) THEN + REPORT.FAILED("REAL 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(12) /= REPORT.IDENT_INT(12) THEN + REPORT.FAILED("CHARACTER 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(13) /= REPORT.IDENT_INT(13) THEN + REPORT.FAILED("ENUMERATION 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(14) /= REPORT.IDENT_INT(14) THEN + REPORT.FAILED("ARRAY 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(15) /= REPORT.IDENT_INT(15) THEN + REPORT.FAILED("RECORD 2 ELABORATED OUT OF ORDER"); + END IF; + + IF ORDER_LIST(16) /= REPORT.IDENT_INT(16) THEN + REPORT.FAILED("ACCESS 2 ELABORATED OUT OF ORDER"); + END IF; + + REPORT.RESULT ; + + END CC3016B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- CC3016C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INSTANCE OF A GENERIC PACKAGE MUST DECLARE A + -- PACKAGE. CHECK THAT THE STATEMENTS IN AN INSTANTIATED GENERIC + -- PACKAGE BODY ARE EXECUTED AFTER THE ELABORATION OF THE + -- DECLARATIONS (IN SPEC AND IN BODY). + + -- HISTORY: + -- EDWARD V. BERARD, 8 AUGUST 1990 + + WITH REPORT; + + PROCEDURE CC3016C IS + + GENERIC + + TYPE SOME_TYPE IS PRIVATE ; + FIRST_INITIAL_VALUE : IN SOME_TYPE ; + SECOND_INITIAL_VALUE : IN SOME_TYPE ; + WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE THIRD_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + FIRST_EXPECTED_RESULT : IN SOME_TYPE ; + SECOND_EXPECTED_RESULT : IN SOME_TYPE ; + THIRD_EXPECTED_RESULT : IN SOME_TYPE ; + FOURTH_EXPECTED_RESULT : IN SOME_TYPE ; + FIFTH_EXPECTED_RESULT : IN SOME_TYPE ; + SIXTH_EXPECTED_RESULT : IN SOME_TYPE ; + + PACKAGE OUTER IS + + VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ; + + FUNCTION INNER_VARIABLE RETURN SOME_TYPE ; + + GENERIC + + INITIAL_VALUE : IN SOME_TYPE ; + WITH PROCEDURE CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + WITH PROCEDURE SECOND_CHANGE (FIRST : IN SOME_TYPE ; + RESULT : OUT SOME_TYPE) ; + FIRST_EXPECTED_RESULT : IN SOME_TYPE ; + SECOND_EXPECTED_RESULT : IN SOME_TYPE ; + THIRD_EXPECTED_RESULT : IN SOME_TYPE ; + FOURTH_EXPECTED_RESULT : IN SOME_TYPE ; + + PACKAGE INNER IS + VARIABLE : SOME_TYPE := INITIAL_VALUE ; + END INNER ; + + END OUTER ; + + + PACKAGE BODY OUTER IS + + ANOTHER_VARIABLE : SOME_TYPE := FIRST_INITIAL_VALUE ; + + PACKAGE BODY INNER IS + ANOTHER_VARIABLE : SOME_TYPE := INITIAL_VALUE ; + BEGIN -- INNER + + CHANGE (FIRST => VARIABLE, + RESULT => VARIABLE) ; + CHANGE (FIRST => ANOTHER_VARIABLE, + RESULT => ANOTHER_VARIABLE) ; + OUTER.SECOND_CHANGE (FIRST => OUTER.VARIABLE, + RESULT => OUTER.VARIABLE) ; + OUTER.CHANGE (FIRST => OUTER.ANOTHER_VARIABLE, + RESULT => OUTER.ANOTHER_VARIABLE) ; + + IF (VARIABLE /= FIRST_EXPECTED_RESULT) OR + (ANOTHER_VARIABLE /= SECOND_EXPECTED_RESULT) OR + (OUTER.VARIABLE + /= THIRD_EXPECTED_RESULT) OR + (OUTER.ANOTHER_VARIABLE + /= FOURTH_EXPECTED_RESULT) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF INNER") ; + END IF; + + END INNER ; + + PACKAGE NEW_INNER IS NEW INNER + (INITIAL_VALUE => SECOND_INITIAL_VALUE, + CHANGE => CHANGE, + SECOND_CHANGE => THIRD_CHANGE, + FIRST_EXPECTED_RESULT => FIRST_EXPECTED_RESULT, + SECOND_EXPECTED_RESULT => SECOND_EXPECTED_RESULT, + THIRD_EXPECTED_RESULT => THIRD_EXPECTED_RESULT, + FOURTH_EXPECTED_RESULT => FOURTH_EXPECTED_RESULT) ; + + FUNCTION INNER_VARIABLE RETURN SOME_TYPE IS + BEGIN + RETURN NEW_INNER.VARIABLE ; + END INNER_VARIABLE ; + + BEGIN -- OUTER + + SECOND_CHANGE (FIRST => VARIABLE, + RESULT => VARIABLE) ; + SECOND_CHANGE (FIRST => ANOTHER_VARIABLE, + RESULT => ANOTHER_VARIABLE) ; + + IF (VARIABLE /= FIFTH_EXPECTED_RESULT) OR + (ANOTHER_VARIABLE /= SIXTH_EXPECTED_RESULT) OR + (NEW_INNER.VARIABLE /= FIRST_EXPECTED_RESULT) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - BODY OF OUTER") ; + END IF; + + END OUTER ; + + PROCEDURE DOUBLE (THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- DOUBLE + GIVING_THIS_RESULT := 2 * THIS_VALUE ; + END DOUBLE ; + + PROCEDURE ADD_20 (TO_THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- ADD_20 + GIVING_THIS_RESULT := TO_THIS_VALUE + 20 ; + END ADD_20 ; + + PROCEDURE TIMES_FIVE (THIS_VALUE : IN INTEGER; + GIVING_THIS_RESULT : OUT INTEGER) IS + BEGIN -- TIMES_FIVE + GIVING_THIS_RESULT := 5 * THIS_VALUE ; + END TIMES_FIVE ; + + BEGIN -- CC3016C + + REPORT.TEST ("CC3016C" , "CHECK THAT AN INSTANCE OF A GENERIC PACKAGE " & + "MUST DECLARE A PACKAGE. CHECK THAT THE STATEMENTS IN AN " & + "INSTANTIATED GENERIC PACKAGE BODY ARE EXECUTED AFTER THE " & + "ELABORATION OF THE DECLARATIONS (IN SPEC AND IN BODY).") ; + + LOCAL_BLOCK: + + DECLARE + + PACKAGE NEW_OUTER IS NEW OUTER + (SOME_TYPE => INTEGER, + FIRST_INITIAL_VALUE => 7, + SECOND_INITIAL_VALUE => 11, + CHANGE => DOUBLE, + SECOND_CHANGE => ADD_20, + THIRD_CHANGE => TIMES_FIVE, + FIRST_EXPECTED_RESULT => 22, + SECOND_EXPECTED_RESULT => 22, + THIRD_EXPECTED_RESULT => 27, + FOURTH_EXPECTED_RESULT => 14, + FIFTH_EXPECTED_RESULT => 47, + SIXTH_EXPECTED_RESULT => 34) ; + + BEGIN -- LOCAL_BLOCK + + IF (NEW_OUTER.VARIABLE /= 47) OR + (NEW_OUTER.INNER_VARIABLE /= 22) THEN + REPORT.FAILED("ASSIGNED VALUES INCORRECT - " & + "BODY OF MAIN PROGRAM") ; + END IF; + + END LOCAL_BLOCK ; + + REPORT.RESULT; + + END CC3016C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016f.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- CC3016F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OFFICE, 3E 114, THE PENTAGON, WASHINGTON DC 20301-3081. + + -- OBJECTIVE: + -- CHECK THAT AN INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED + -- OF A PACKAGE. + + -- CHECK THAT IF THE PARENT TYPE IN A DERIVED TYPE DEFINITION IS + -- A GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE DERIVED + -- TYPE IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE + -- FORMAL TYPE. THE OPERATIONS DECLARED FOR DERIVED TYPE IN THE + -- INSTANCE ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL + -- PARAMETER. SEE AI-00398. + + -- HISTORY: + -- DAS 8 OCT 90 INITIAL VERSION. + -- JRL 02/19/93 ADDED USE CLAUSES FOR INSTANCES TO ENSURE DIRECT + -- OPERATOR VISIBILITY. CHANGED NT4'LAST TO P4.NT4'LAST + -- IN ASSIGNMENT STATEMENT FOR P4.X IN EXAMPLE_4. + -- CORRECTED ABE ERRORS IN EXAMPLE_2 AND EXAMPLE_3. + -- CHANGED R3."+" FROM MULTIPLICATION TO SUBTRACTION TO + -- AVOID CONSTRAINT_ERROR. + + WITH REPORT; + + PROCEDURE CC3016F IS + BEGIN + REPORT.TEST ("CC3016F", "CHECK THAT IF THE PARENT TYPE IN A " & + "DERIVED TYPE DEFINITION IS A GENERIC " & + "FORMAL TYPE, THE OPERATIONS DECLARED " & + "FOR THE DERIVED TYPE IN THE TEMPLATE " & + "ARE DETERMINED BY THE DECLARATION OF " & + "THE FORMAL TYPE, AND THAT THE " & + "OPERATIONS DECLARED FOR THE DERIVED " & + "TYPE IN THE INSTANCE ARE DETERMINED BY " & + "THE ACTUAL TYPE DENOTED BY THE FORMAL " & + "PARAMETER (AI-00398)"); + EXAMPLE_2: + DECLARE + GENERIC + TYPE PRIV IS PRIVATE; + PACKAGE GP2 IS + TYPE NT2 IS NEW PRIV; + END GP2; + + PACKAGE R2 IS + TYPE T2 IS RANGE 1..10; + FUNCTION F RETURN T2; + END R2; + + PACKAGE P2 IS NEW GP2 (PRIV => R2.T2); + USE P2; + + XX1 : P2.NT2; + XX2 : P2.NT2; + XX3 : P2.NT2; + + PACKAGE BODY R2 IS + FUNCTION F RETURN T2 IS + BEGIN + RETURN T2'LAST; + END F; + END R2; + BEGIN + XX1 := 5; -- IMPLICIT CONVERSION FROM + -- UNIVERSAL INTEGER TO P2.NT2 + -- IN P2. + XX2 := XX1 + XX1; -- PREDEFINED "+" DECLARED FOR + -- P2.NT2. + XX3 := P2.F; -- FUNCTION F DERIVED WITH THE + -- INSTANCE. + + END EXAMPLE_2; + + EXAMPLE_3: + DECLARE + GENERIC + TYPE T3 IS RANGE <>; + PACKAGE GP3 IS + TYPE NT3 IS NEW T3; + X : NT3 := 5; + Y : NT3 := X + 3; -- USES PREDEFINED "+" EVEN IN + -- INSTANCES + END GP3; + + PACKAGE R3 IS + TYPE S IS RANGE 1..10; + FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S; + END R3; + + PACKAGE P3 IS NEW GP3 ( T3 => R3.S ); + USE P3; + + Z : P3.NT3; + + PACKAGE BODY R3 IS + FUNCTION "+" (LEFT : IN S; RIGHT : IN S) RETURN S IS + BEGIN -- IMPLEMENT AS SUBTRACTION, NOT ADDITION + RETURN LEFT - RIGHT; + END "+"; + END R3; + BEGIN + Z := P3.X + 3; -- USES REDEFINED "+" + + IF ( P3.Y /= P3.NT3'(8) ) THEN + REPORT.FAILED ("PREDEFINED ""+"" NOT USED TO COMPUTE " & + "P3.Y"); + END IF; + + IF (Z /= P3.NT3'(2) ) THEN + REPORT.FAILED ("REDEFINED ""+"" NOT USED TO COMPUTE Z"); + END IF; + END EXAMPLE_3; + + EXAMPLE_4: + DECLARE + GENERIC + TYPE T4 IS LIMITED PRIVATE; + PACKAGE GP4 IS + TYPE NT4 IS NEW T4; + X : NT4; + END GP4; + + PACKAGE P4 IS NEW GP4 (BOOLEAN); + USE P4; + + BEGIN + P4.X := P4.NT4'LAST; + IF ( P4.X OR (NOT P4.X) ) THEN + REPORT.COMMENT ("P4.X CORRECTLY HAS A BOOLEAN TYPE"); + END IF; + END EXAMPLE_4; + + EXAMPLE_5: + DECLARE + GENERIC + TYPE T5 (D : POSITIVE) IS PRIVATE; + PACKAGE GP5 IS + TYPE NT5 IS NEW T5; + X : NT5 (D => 5); + Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5 + END GP5; + + TYPE REC (A : POSITIVE) IS + RECORD + D : POSITIVE := 7; + END RECORD; + PACKAGE P5 IS NEW GP5 (T5 => REC); + -- P5.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION + -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE + -- T5 WHICH DENOTES REC. + + W1 : POSITIVE := P5.X.D; -- VALUE IS 7 + W2 : POSITIVE := P5.X.A; -- VALUE IS 5 + W3 : POSITIVE := P5.Y; -- VALUE IS 5; + BEGIN + IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN + REPORT.FAILED ("INCORRECT COMPONENT SELECTION"); + END IF; + END EXAMPLE_5; + + REPORT.RESULT; + + END CC3016F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3016i.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CC3016I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INSTANTIATED PACKAGE HAS THE PROPERTIES REQUIRED + -- OF A PACKAGE. + + -- CHECK THAT IF THE DESIGNATED TYPE OF AN ACCESS TYPE IS A GENERIC + -- FORMAL TYPE, OR IS A TYPE DERIVED DIRECTLY OR INDIRECTLY FROM A + -- GENERIC FORMAL TYPE, THE OPERATIONS DECLARED FOR THE ACCESS TYPE + -- IN THE TEMPLATE ARE DETERMINED BY THE DECLARATION OF THE FORMAL + -- TYPE. THE OPERATIONS DECLARED FOR ACCESS TYPE IN THE INSTANCE + -- ARE DETERMINED BY THE ACTUAL TYPE DENOTED BY THE FORMAL PARAMETER. + -- SEE AI-00398. + + -- HISTORY: + -- DAS 8 OCT 90 INITIAL VERSION. + + + WITH REPORT; USE REPORT; + + PROCEDURE CC3016I IS + BEGIN + TEST("CC3016I", "CHECK THAT AN INSTANTIATED PACKAGE HAS THE " & + "PROPERTIES REQUIRED OF A PACKAGE."); + + EXAMPLE_5A: + DECLARE + GENERIC + TYPE T5A (D : POSITIVE) IS PRIVATE; + PACKAGE GP5A IS + TYPE NT5A IS NEW T5A; + X : NT5A (D => 5); + Y : POSITIVE := X.D; -- REFERS TO DISCRIMINANT OF NT5A + END GP5A; + + TYPE REC (A : POSITIVE) IS + RECORD + D : POSITIVE := 7; + END RECORD; + PACKAGE P5A IS NEW GP5A (T5A => REC); + -- P5A.Y INITIALIZED WITH VALUE USING COMPONENT SELECTION + -- OPERATION FOR THE DISCRIMINANT, I.E. FOR PARENT TYPE + -- T5A WHICH DENOTES REC. + + W1 : POSITIVE := P5A.X.D; -- VALUE IS 7 + W2 : POSITIVE := P5A.X.A; -- VALUE IS 5 + W3 : POSITIVE := P5A.Y; -- VALUE IS 5; + BEGIN + IF ( ( W1 /= 7 ) OR ( W2 /= 5 ) OR (W3 /= 5 ) ) THEN + FAILED ("INCORRECT COMPONENT SELECTION - ACCESS"); + END IF; + END EXAMPLE_5A; + + RESULT; + + END CC3016I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3017b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,470 ---- + -- CC3017B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A + -- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST + -- DECLARE A FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT RAISED + -- IF THE DEFAULT VALUE FOR A FORMAL PARAMETER DOES NOT SATISFY + -- THE CONSTRAINTS OF THE SUBTYPE_INDICATION WHEN THE + -- DECLARATION IS ELABORATED, ONLY WHEN THE DEFAULT IS USED. + + -- SUBTESTS ARE: + -- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND + -- INITIALIZED WITH A STATIC AGGREGATE. + -- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS + -- INITIALIZED WITH A STATIC VALUE. + -- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC + -- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + -- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- + -- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + -- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT + -- INITIALIZED WITH A STATIC AGGREGATE. + + -- EDWARD V. BERARD, 7 AUGUST 1990 + + WITH REPORT; + + PROCEDURE CC3017B IS + + BEGIN + + REPORT.TEST ("CC3017B", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " & + "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " & + "FUNCTION. CHECK THAT CONSTRAINT_ERROR IS NOT " & + "RAISED IF AN INITIALIZATION VALUE DOES NOT SATISFY " & + "CONSTRAINTS ON A FORMAL PARAMETER"); + + -------------------------------------------------- + + NONSTAT_ARRAY_PARMS: + + DECLARE + + -- (A) ARRAY PARAMETERS CONSTRAINED WITH NONSTATIC BOUNDS AND + -- INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE ; + + PROCEDURE PA (FIRST : IN INTEGER_TYPE ; + SECOND : IN INTEGER_TYPE) ; + + PROCEDURE PA (FIRST : IN INTEGER_TYPE ; + SECOND : IN INTEGER_TYPE) IS + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE LOWER .. FIRST, + INTEGER_TYPE RANGE LOWER .. SECOND) + OF INTEGER_TYPE; + + PROCEDURE PA1 (A : A1 := ((LOWER,UPPER),(UPPER,UPPER))) + IS + BEGIN + REPORT.FAILED ("BODY OF PA1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PA1"); + END PA1; + + BEGIN -- PA + PA1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PA1"); + END PA; + + PROCEDURE NEW_PA IS NEW PA (INTEGER_TYPE => NUMBER, + LOWER => 1, + UPPER => 50) ; + + BEGIN -- NONSTAT_ARRAY_PARMS + + NEW_PA (FIRST => NUMBER (25), + SECOND => NUMBER (75)); + + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PA"); + + END NONSTAT_ARRAY_PARMS ; + + -------------------------------------------------- + + SCALAR_NON_STATIC: + + DECLARE + + -- (B) A SCALAR PARAMETER WITH NON-STATIC RANGE CONSTRAINTS + -- INITIALIZED WITH A STATIC VALUE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PB (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PB (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE INT IS INTEGER_TYPE RANGE LOWER .. UPPER ; + + PROCEDURE PB1 (I : INT := STATIC_VALUE) IS + BEGIN -- PB1 + REPORT.FAILED ("BODY OF PB1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PB1"); + END PB1; + + BEGIN -- PB + PB1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PB1"); + END PB; + + PROCEDURE NEW_PB IS NEW PB (INTEGER_TYPE => NUMBER, + STATIC_VALUE => 20) ; + + BEGIN -- SCALAR_NON_STATIC + + NEW_PB (LOWER => NUMBER (25), + UPPER => NUMBER (75)); + + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PB"); + END SCALAR_NON_STATIC ; + + -------------------------------------------------- + + REC_NON_STAT_COMPS: + + DECLARE + + -- (C) A RECORD PARAMETER WHOSE COMPONENTS HAVE NON-STATIC + -- CONSTRAINTS INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PC (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PC (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF + SUBINTEGER_TYPE ; + TYPE REC IS + RECORD + FIRST : SUBINTEGER_TYPE ; + SECOND : AR1 ; + END RECORD; + + PROCEDURE PC1 (R : REC := (F_STATIC_VALUE, + (S_STATIC_VALUE, + T_STATIC_VALUE, + L_STATIC_VALUE))) IS + BEGIN -- PC1 + REPORT.FAILED ("BODY OF PC1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PC1"); + END PC1; + + BEGIN -- PC + PC1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PC1"); + END PC; + + PROCEDURE NEW_PC IS NEW PC (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 15, + S_STATIC_VALUE => 19, + T_STATIC_VALUE => 85, + L_STATIC_VALUE => 99) ; + + BEGIN -- REC_NON_STAT_COMPS + NEW_PC (LOWER => 20, + UPPER => 80); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PC"); + END REC_NON_STAT_COMPS ; + + -------------------------------------------------- + + FIRST_STATIC_ARRAY: + + DECLARE + + -- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- + -- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + A_STATIC_VALUE : IN INTEGER_TYPE ; + B_STATIC_VALUE : IN INTEGER_TYPE ; + C_STATIC_VALUE : IN INTEGER_TYPE ; + D_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE P1D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE P1D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE + F_STATIC_VALUE .. S_STATIC_VALUE, + INTEGER_TYPE RANGE + T_STATIC_VALUE .. L_STATIC_VALUE) + OF SUBINTEGER_TYPE ; + + PROCEDURE P1D1 (A : A1 := + ((A_STATIC_VALUE, B_STATIC_VALUE), + (C_STATIC_VALUE, D_STATIC_VALUE))) IS + BEGIN -- P1D1 + REPORT.FAILED ("BODY OF P1D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN P1D1"); + END P1D1; + + BEGIN -- P1D + P1D1 ; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - P1D1"); + END P1D; + + PROCEDURE NEW_P1D IS NEW P1D (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 21, + S_STATIC_VALUE => 37, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + A_STATIC_VALUE => 11, + B_STATIC_VALUE => 88, + C_STATIC_VALUE => 87, + D_STATIC_VALUE => 13) ; + + BEGIN -- FIRST_STATIC_ARRAY + NEW_P1D (LOWER => 10, + UPPER => 90); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P1D"); + END FIRST_STATIC_ARRAY ; + + -------------------------------------------------- + + SECOND_STATIC_ARRAY: + + DECLARE + + -- (D) AN ARRAY PARAMETER CONSTRAINED WITH STATIC BOUNDS ON SUB- + -- SCRIPTS AND NON-STATIC BOUNDS ON COMPONENTS, INITIALIZED + -- WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + A_STATIC_VALUE : IN INTEGER_TYPE ; + B_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE P2D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE P2D (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + + TYPE A1 IS ARRAY (INTEGER_TYPE RANGE + F_STATIC_VALUE .. S_STATIC_VALUE, + INTEGER_TYPE RANGE + T_STATIC_VALUE .. L_STATIC_VALUE) + OF SUBINTEGER_TYPE ; + + PROCEDURE P2D1 (A : A1 := + (F_STATIC_VALUE .. S_STATIC_VALUE => + (A_STATIC_VALUE, B_STATIC_VALUE))) IS + BEGIN -- P2D1 + REPORT.FAILED ("BODY OF P2D1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN P2D1"); + END P2D1; + + BEGIN -- P2D + P2D1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - P2D1"); + END P2D; + + PROCEDURE NEW_P2D IS NEW P2D (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 21, + S_STATIC_VALUE => 37, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + A_STATIC_VALUE => 7, + B_STATIC_VALUE => 93) ; + + BEGIN -- SECOND_STATIC_ARRAY + NEW_P2D (LOWER => 5, + UPPER => 95); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_P2D"); + END SECOND_STATIC_ARRAY ; + + -------------------------------------------------- + + REC_NON_STATIC_CONS: + + DECLARE + + -- (E) A RECORD PARAMETER WITH A NON-STATIC CONSTRAINT + -- INITIALIZED WITH A STATIC AGGREGATE. + + TYPE NUMBER IS RANGE 1 .. 100 ; + + GENERIC + + TYPE INTEGER_TYPE IS RANGE <> ; + F_STATIC_VALUE : IN INTEGER_TYPE ; + S_STATIC_VALUE : IN INTEGER_TYPE ; + T_STATIC_VALUE : IN INTEGER_TYPE ; + L_STATIC_VALUE : IN INTEGER_TYPE ; + D_STATIC_VALUE : IN INTEGER_TYPE ; + + PROCEDURE PE (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) ; + + PROCEDURE PE (LOWER : IN INTEGER_TYPE ; + UPPER : IN INTEGER_TYPE) IS + + SUBTYPE SUBINTEGER_TYPE IS INTEGER_TYPE + RANGE LOWER .. UPPER ; + TYPE AR1 IS ARRAY (INTEGER RANGE 1..3) OF + SUBINTEGER_TYPE ; + + TYPE REC (DISCRIM : SUBINTEGER_TYPE) IS + RECORD + FIRST : SUBINTEGER_TYPE ; + SECOND : AR1 ; + END RECORD ; + + SUBTYPE REC4 IS REC (LOWER) ; + + PROCEDURE PE1 (R : REC4 := (D_STATIC_VALUE, + F_STATIC_VALUE, + (S_STATIC_VALUE, + T_STATIC_VALUE, + L_STATIC_VALUE))) IS + BEGIN -- PE1 + REPORT.FAILED ("BODY OF PE1 EXECUTED"); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN PE1"); + END PE1; + + BEGIN -- PE + PE1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - PE1"); + END PE; + + PROCEDURE NEW_PE IS NEW PE (INTEGER_TYPE => NUMBER, + F_STATIC_VALUE => 37, + S_STATIC_VALUE => 21, + T_STATIC_VALUE => 67, + L_STATIC_VALUE => 79, + D_STATIC_VALUE => 44) ; + + BEGIN -- REC_NON_STATIC_CONS + NEW_PE (LOWER => 2, + UPPER => 99); + EXCEPTION + WHEN OTHERS => + REPORT.FAILED ("EXCEPTION RAISED IN CALL TO NEW_PE"); + END REC_NON_STATIC_CONS ; + + -------------------------------------------------- + + REPORT.RESULT; + + END CC3017B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3017c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,336 ---- + -- CC3017C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN INSTANCE OF A GENERIC PROCEDURE MUST DECLARE A + -- PROCEDURE AND THAT AN INSTANCE OF A GENERIC FUNCTION MUST + -- DECLARE A FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS + -- ARE COPIED. + -- + -- SUBTESTS ARE: + -- (A) SCALAR PARAMETERS TO PROCEDURES. + -- (B) SCALAR PARAMETERS TO FUNCTIONS. + -- (C) ACCESS PARAMETERS TO PROCEDURES. + -- (D) ACCESS PARAMETERS TO FUNCTIONS. + + -- HISTORY: + -- EDWARD V. BERARD, 7 AUGUST 1990 + -- CJJ 10/16/90 ADJUSTED LINES THAT WERE TOO LONG; REFORMATTED + -- HEADER TO CONFORM TO ACVC STANDARDS. + -- + + WITH REPORT; + PROCEDURE CC3017C IS + + BEGIN + REPORT.TEST ("CC3017C", "CHECK THAT AN INSTANCE OF A GENERIC " & + "PROCEDURE MUST DECLARE A PROCEDURE AND THAT AN " & + "INSTANCE OF A GENERIC FUNCTION MUST DECLARE A " & + "FUNCTION. CHECK THAT SCALAR AND ACCESS PARAMETERS " & + "ARE COPIED"); + + -------------------------------------------------- + + SCALAR_TO_PROCS: + + DECLARE + + -- (A) SCALAR PARAMETERS TO PROCEDURES. + + TYPE NUMBER IS RANGE 0 .. 120 ; + VALUE : NUMBER ; + E : EXCEPTION ; + + GENERIC + + TYPE SCALAR_ITEM IS RANGE <> ; + + PROCEDURE P (P_IN : IN SCALAR_ITEM ; + P_OUT : OUT SCALAR_ITEM ; + P_IN_OUT : IN OUT SCALAR_ITEM) ; + + PROCEDURE P (P_IN : IN SCALAR_ITEM ; + P_OUT : OUT SCALAR_ITEM ; + P_IN_OUT : IN OUT SCALAR_ITEM) IS + + STORE : SCALAR_ITEM ; + + BEGIN -- P + + STORE := P_IN; -- SAVE VALUE OF P_IN AT PROC ENTRY. + + P_OUT := 10; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_IN_OUT := P_IN_OUT + 100; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + VALUE := VALUE + 1; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P; + + PROCEDURE NEW_P IS NEW P (SCALAR_ITEM => NUMBER) ; + + BEGIN -- SCALAR_TO_PROCS + VALUE := 0; -- INITIALIZE VALUE SO VARIOUS CASES CAN BE DETECTED. + + NEW_P (P_IN => VALUE, + P_OUT => VALUE, + P_IN_OUT => VALUE); + + REPORT.FAILED ("EXCEPTION NOT RAISED - SCALARS TO PROCEDURES"); + EXCEPTION + WHEN E => + IF (VALUE /= 1) THEN + CASE VALUE IS + WHEN 11 => + REPORT.FAILED ("OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 101 => + REPORT.FAILED ("IN OUT ACTUAL SCALAR " & + "PARAMETER CHANGED GLOBAL VALUE"); + WHEN 111 => + REPORT.FAILED ("OUT AND IN OUT ACTUAL " & + "SCALAR PARAMETERS CHANGED " & + "GLOBAL VALUE"); + WHEN OTHERS => + REPORT.FAILED ("UNDETERMINED CHANGE TO " & + "GLOBAL VALUE"); + END CASE; + END IF; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - SCALARS TO PROCEDURES"); + END SCALAR_TO_PROCS ; + + -------------------------------------------------- + + SCALAR_TO_FUNCS: + + DECLARE + + -- (B) SCALAR PARAMETERS TO FUNCTIONS. + + TYPE NUMBER IS RANGE 0 .. 101 ; + FIRST : NUMBER ; + SECOND : NUMBER ; + + GENERIC + + TYPE ITEM IS RANGE <> ; + + FUNCTION F (F_IN : IN ITEM) RETURN ITEM ; + + FUNCTION F (F_IN : IN ITEM) RETURN ITEM IS + + STORE : ITEM := F_IN; + + BEGIN -- F + + FIRST := FIRST + 1; + IF (F_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO SCALAR GLOBAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (100); + END F; + + FUNCTION NEW_F IS NEW F (ITEM => NUMBER) ; + + BEGIN -- SCALAR_TO_FUNCS + FIRST := 100 ; + SECOND := NEW_F (FIRST) ; + END SCALAR_TO_FUNCS ; + + -------------------------------------------------- + + ACCESS_TO_PROCS: + + DECLARE + + -- (C) ACCESS PARAMETERS TO PROCEDURES. + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + DATE_POINTER : DATE_ACCESS ; + + E : EXCEPTION; + + GENERIC + + TYPE ITEM IS PRIVATE ; + TYPE ACCESS_ITEM IS ACCESS ITEM ; + + PROCEDURE P (P_IN : IN ACCESS_ITEM ; + P_OUT : OUT ACCESS_ITEM ; + P_IN_OUT : IN OUT ACCESS_ITEM) ; + + PROCEDURE P (P_IN : IN ACCESS_ITEM ; + P_OUT : OUT ACCESS_ITEM ; + P_IN_OUT : IN OUT ACCESS_ITEM) IS + + STORE : ACCESS_ITEM ; + + BEGIN -- P + + STORE := P_IN ; -- SAVE VALUE OF P_IN AT PROC ENTRY. + + DATE_POINTER := NEW DATE'(YEAR => 1990, + DAY => 7, + MONTH => AUG) ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_OUT := NEW ITEM ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + STORE := P_IN; -- RESET STORE FOR NEXT CASE. + END IF; + + P_IN_OUT := NEW ITEM ; + IF (P_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS IN OUT " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RAISE E; -- CHECK EXCEPTION HANDLING. + END P ; + + PROCEDURE NEW_P IS NEW P (ITEM => DATE, + ACCESS_ITEM => DATE_ACCESS) ; + + BEGIN -- ACCESS_TO_PROCS + DATE_POINTER := NEW DATE'(MONTH => DEC, + DAY => 25, + YEAR => 2000) ; + + NEW_P (P_IN => DATE_POINTER, + P_OUT => DATE_POINTER, + P_IN_OUT => DATE_POINTER) ; + + REPORT.FAILED ("EXCEPTION NOT RAISED - ACCESS TO PROCEDURES"); + EXCEPTION + WHEN E => + IF (DATE_POINTER.ALL /= (AUG, 7, 1990)) THEN + REPORT.FAILED ("OUT OR IN OUT ACTUAL PROCEDURE " & + "PARAMETER VALUE CHANGED DESPITE " & + "RAISED EXCEPTION"); + END IF; + WHEN OTHERS => + REPORT.FAILED ("WRONG EXCEPTION RAISED - ACCESS TO PROCEDURES"); + END ACCESS_TO_PROCS ; + + -------------------------------------------------- + + ACCESS_TO_FUNCS: + + DECLARE + + -- (D) ACCESS PARAMETERS TO FUNCTIONS. + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TYPE DATE_ACCESS IS ACCESS DATE ; + DATE_POINTER : DATE_ACCESS ; + NEXT_DATE : DATE_ACCESS ; + + GENERIC + + TYPE ITEM IS PRIVATE ; + TYPE ACCESS_ITEM IS ACCESS ITEM ; + + FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM ; + + FUNCTION F (F_IN : IN ACCESS_ITEM) RETURN ACCESS_ITEM IS + + STORE : ACCESS_ITEM := F_IN ; + + BEGIN -- F + + DATE_POINTER := NEW DATE'(YEAR => 1990, + DAY => 7, + MONTH => AUG) ; + IF (F_IN /= STORE) THEN + REPORT.FAILED ("ASSIGNMENT TO ACCESS GLOBAL FUNCTION " & + "PARAMETER CHANGES THE VALUE OF " & + "INPUT PARAMETER"); + END IF; + + RETURN (NULL); + END F ; + + FUNCTION NEW_F IS NEW F (ITEM => DATE, + ACCESS_ITEM => DATE_ACCESS) ; + + BEGIN -- ACCESS_TO_FUNCS + DATE_POINTER := NULL ; + NEXT_DATE := NEW_F(F_IN => DATE_POINTER) ; + END ACCESS_TO_FUNCS ; + + -------------------------------------------------- + + REPORT.RESULT; + + END CC3017C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,173 ---- + -- CC3019A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT INSTANTIATIONS OF NESTED GENERIC UNITS ARE PROCESSED + -- CORRECTLY. + + -- JBG 11/6/85 + + GENERIC + TYPE ELEMENT_TYPE IS PRIVATE; + PACKAGE CC3019A_QUEUES IS + + TYPE QUEUE_TYPE IS PRIVATE; + + PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE; + VALUE : ELEMENT_TYPE); + + GENERIC + WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE); + PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE); + + PRIVATE + + TYPE CONTENTS_TYPE IS ARRAY (1..3) OF ELEMENT_TYPE; + TYPE QUEUE_TYPE IS + RECORD + CONTENTS : CONTENTS_TYPE; + SIZE : NATURAL := 0; + END RECORD; + + END CC3019A_QUEUES; + + PACKAGE BODY CC3019A_QUEUES IS + + PROCEDURE ADD (TO_Q : IN OUT QUEUE_TYPE; + VALUE : ELEMENT_TYPE) IS + BEGIN + TO_Q.SIZE := TO_Q.SIZE + 1; + TO_Q.CONTENTS(TO_Q.SIZE) := VALUE; + END ADD; + + -- GENERIC + -- WITH PROCEDURE APPLY (VAL : ELEMENT_TYPE); + PROCEDURE ITERATOR (TO_Q : QUEUE_TYPE) IS + BEGIN + FOR I IN TO_Q.CONTENTS'FIRST .. TO_Q.SIZE LOOP + APPLY (TO_Q.CONTENTS(I)); + END LOOP; + END ITERATOR; + + END CC3019A_QUEUES; + + WITH REPORT; USE REPORT; + WITH CC3019A_QUEUES; + PROCEDURE CC3019A IS + + SUBTYPE STR6 IS STRING (1..6); + + TYPE STR6_ARR IS ARRAY (1..3) OF STR6; + STR6_VALS : STR6_ARR := ("111111", "222222", + IDENT_STR("333333")); + CUR_STR_INDEX : NATURAL := 1; + + TYPE INT_ARR IS ARRAY (1..3) OF INTEGER; + INT_VALS : INT_ARR := (-1, 3, IDENT_INT(3)); + CUR_INT_INDEX : NATURAL := 1; + + -- THIS PROCEDURE IS CALLED ONCE FOR EACH ELEMENT OF THE QUEUE + -- + PROCEDURE CHECK_STR (VAL : STR6) IS + BEGIN + IF VAL /= STR6_VALS(CUR_STR_INDEX) THEN + FAILED ("STR6 ITERATOR FOR INDEX =" & + INTEGER'IMAGE(CUR_STR_INDEX) & " WITH VALUE " & + """" & VAL & """"); + END IF; + CUR_STR_INDEX := CUR_STR_INDEX + 1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("STR6 - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("STR6 - UNEXPECTED EXCEPTION"); + END CHECK_STR; + + PROCEDURE CHECK_INT (VAL : INTEGER) IS + BEGIN + IF VAL /= INT_VALS(CUR_INT_INDEX) THEN + FAILED ("INTEGER ITERATOR FOR INDEX =" & + INTEGER'IMAGE(CUR_INT_INDEX) & " WITH VALUE " & + """" & INTEGER'IMAGE(VAL) & """"); + END IF; + CUR_INT_INDEX := CUR_INT_INDEX + 1; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("INTEGER - CONSTRAINT_ERROR RAISED"); + WHEN OTHERS => + FAILED ("INTEGER - UNEXPECTED EXCEPTION"); + END CHECK_INT; + + PACKAGE STR6_QUEUE IS NEW CC3019A_QUEUES (STR6); + USE STR6_QUEUE; + + PACKAGE INT_QUEUE IS NEW CC3019A_QUEUES (INTEGER); + USE INT_QUEUE; + + BEGIN + + TEST ("CC3019A", "CHECK NESTED GENERICS - ITERATORS"); + + DECLARE + Q1 : STR6_QUEUE.QUEUE_TYPE; + + PROCEDURE CHK_STR IS NEW STR6_QUEUE.ITERATOR (CHECK_STR); + + BEGIN + + ADD (Q1, "111111"); + ADD (Q1, "222222"); + ADD (Q1, "333333"); + + CUR_STR_INDEX := 1; + CHK_STR (Q1); + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - Q1"); + END; + + -- REPEAT FOR INTEGERS + + DECLARE + Q2 : INT_QUEUE.QUEUE_TYPE; + + PROCEDURE CHK_INT IS NEW INT_QUEUE.ITERATOR (CHECK_INT); + + BEGIN + + ADD (Q2, -1); + ADD (Q2, 3); + ADD (Q2, 3); + + CUR_INT_INDEX := 1; + CHK_INT (Q2); + + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION - Q2"); + END; + + RESULT; + + END CC3019A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- CC3019B0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF + -- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE CC3019B0_LIST_CLASS IS + + TYPE LIST IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN ; + + PRIVATE + + TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ; + + TYPE LIST IS RECORD + LENGTH : NATURAL := 0 ; + ACTUAL_LIST : LIST_TABLE ; + END RECORD ; + + END CC3019B0_LIST_CLASS ; + + PACKAGE BODY CC3019B0_LIST_CLASS IS + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- ADD + + IF TO_THIS_LIST.LENGTH >= 10 THEN + RAISE OVERFLOW ; + ELSE + TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ; + ASSIGN ( + SOURCE => THIS_ELEMENT, + DESTINATION => + TO_THIS_LIST.ACTUAL_LIST (TO_THIS_LIST.LENGTH)); + END IF ; + + END ADD ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) IS + + BEGIN -- DELETE + + IF FROM_THIS_LIST.LENGTH <= 0 THEN + RAISE UNDERFLOW ; + ELSE + ASSIGN ( + SOURCE => + FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH), + DESTINATION => THIS_ELEMENT) ; + FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ; + END IF ; + + END DELETE ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- COPY + + TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ; + FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP + ASSIGN ( + SOURCE => THIS_LIST.ACTUAL_LIST (INDEX), + DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX)) ; + END LOOP ; + + END COPY ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS + + BEGIN -- CLEAR + + THIS_LIST.LENGTH := 0 ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS + + CONTINUE : BOOLEAN := TRUE ; + FINISHED : NATURAL := 0 ; + + BEGIN -- ITERATE + + WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH) + LOOP + FINISHED := FINISHED + 1 ; + PROCESS (THIS_ELEMENT => + OVER_THIS_LIST.ACTUAL_LIST (FINISHED), + CONTINUE => CONTINUE) ; + END LOOP ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN IN_THIS_LIST.LENGTH ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN IS + + RESULT : BOOLEAN := TRUE ; + INDEX : NATURAL := 0 ; + + BEGIN -- "=" + + IF LEFT.LENGTH /= RIGHT.LENGTH THEN + RESULT := FALSE ; + ELSE + WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP + INDEX := INDEX + 1 ; + IF LEFT.ACTUAL_LIST (INDEX) /= + RIGHT.ACTUAL_LIST (INDEX) THEN + RESULT := FALSE ; + END IF ; + END LOOP ; + END IF ; + + RETURN RESULT ; + + END "=" ; + + END CC3019B0_LIST_CLASS ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + -- CC3019B1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF + -- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED + -- BY THE MAIN PROCEDURE, I.E., CC3019B2M.ADA. + -- + -- *** THIS FILE MUST BE COMPILED AFTER CC3019B0.ADA HAS BEEN + -- *** COMPILED. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + WITH CC3019B0_LIST_CLASS ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE CC3019B1_STACK_CLASS IS + + TYPE STACK IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN ; + + PRIVATE + + PACKAGE NEW_LIST_CLASS IS + NEW CC3019B0_LIST_CLASS (ELEMENT => ELEMENT, + ASSIGN => ASSIGN, + "=" => "=") ; + + TYPE STACK IS NEW NEW_LIST_CLASS.LIST ; + + END CC3019B1_STACK_CLASS ; + + PACKAGE BODY CC3019B1_STACK_CLASS IS + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- PUSH + + NEW_LIST_CLASS.ADD ( + THIS_ELEMENT => THIS_ELEMENT, + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ; + + END PUSH ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) IS + + BEGIN -- POP + + NEW_LIST_CLASS.DELETE ( + THIS_ELEMENT => THIS_ELEMENT, + FROM_THIS_LIST => + NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ; + + END POP ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- COPY + + NEW_LIST_CLASS.COPY ( + THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK), + TO_THIS_LIST => NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ; + + END COPY ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS + + BEGIN -- CLEAR + + NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS + + PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE + (PROCESS => PROCESS) ; + + BEGIN -- ITERATE + + STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS + (IN_THIS_LIST => NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN IS + + BEGIN -- "=" + + RETURN NEW_LIST_CLASS."=" ( + LEFT => NEW_LIST_CLASS.LIST (LEFT), + RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ; + + END "=" ; + + END CC3019B1_STACK_CLASS ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019b2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,300 ---- + -- CC3019B2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G., + -- TO SUPPORT ITERATORS. THIS TEST SPECIFICALLY CHECKS THAT A + -- NESTING LEVEL OF 2 IS SUPPORTED FOR GENERICS. + -- + -- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE + -- *** SOURCE CODE IN FILES CC3019B0.ADA AND CC3019B1.ADA HAVE + -- *** BEEN COMPILED. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + WITH REPORT ; + WITH CC3019B1_STACK_CLASS ; + + PROCEDURE CC3019B2M IS + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + STORE_DATE : DATE ; + + TODAY : DATE := (MONTH => AUG, + DAY => 31, + YEAR => 1990) ; + + FIRST_DATE : DATE := (MONTH => JUN, + DAY => 4, + YEAR => 1967) ; + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN ; + + PACKAGE DATE_STACK IS + NEW CC3019B1_STACK_CLASS (ELEMENT => DATE, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_DATE_STACK : DATE_STACK.STACK ; + SECOND_DATE_STACK : DATE_STACK.STACK ; + THIRD_DATE_STACK : DATE_STACK.STACK ; + + FUNCTION "=" (LEFT : IN DATE_STACK.STACK ; + RIGHT : IN DATE_STACK.STACK) RETURN BOOLEAN + RENAMES DATE_STACK."=" ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) IS + + BEGIN -- ASSIGN + + TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + RETURN (LEFT.MONTH = RIGHT.MONTH) AND + (LEFT.DAY = RIGHT.DAY) AND + (LEFT.YEAR = RIGHT.YEAR) ; + + END IS_EQUAL ; + + BEGIN -- CC3019B2M + + REPORT.TEST ("CC3019B2M", + "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " & + "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " & + "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF " & + "2 IS SUPPORTED FOR GENERICS.") ; + + DATE_STACK.CLEAR (THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 1 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => FIRST_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ; + END IF ; + + DATE_STACK.PUSH (THIS_ELEMENT => BIRTH_DATE, + ON_TO_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 3 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => FIRST_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_DATE_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ; + END IF ; + + IF STORE_DATE /= BIRTH_DATE THEN + REPORT.FAILED ( + "IMPROPER VALUE REMOVED FROM STACK - 1") ; + END IF ; + + DATE_STACK.CLEAR (THIS_STACK => SECOND_DATE_STACK) ; + IF DATE_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => SECOND_DATE_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ; + END IF ; + + DATE_STACK.COPY (THIS_STACK => FIRST_DATE_STACK, + TO_THIS_STACK => SECOND_DATE_STACK) ; + + IF FIRST_DATE_STACK /= SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH COPY OR TEST FOR EQUALITY") ; + END IF ; + + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => SECOND_DATE_STACK) ; + DATE_STACK.PUSH (THIS_ELEMENT => WALL_DATE, + ON_TO_THIS_STACK => SECOND_DATE_STACK) ; + IF FIRST_DATE_STACK = SECOND_DATE_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH POP OR TEST FOR EQUALITY") ; + END IF ; + + UNDERFLOW_EXCEPTION_TEST: + + BEGIN -- UNDERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + DATE_STACK.POP (THIS_ELEMENT => STORE_DATE, + OFF_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "UNDERFLOW EXCEPTION TEST") ; + + END UNDERFLOW_EXCEPTION_TEST ; + + OVERFLOW_EXCEPTION_TEST: + + BEGIN -- OVERFLOW_EXCEPTION_TEST + + DATE_STACK.CLEAR (THIS_STACK => THIRD_DATE_STACK) ; + FOR INDEX IN 1 .. 10 LOOP + DATE_STACK.PUSH ( THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + END LOOP ; + + DATE_STACK.PUSH (THIS_ELEMENT => TODAY, + ON_TO_THIS_STACK => THIRD_DATE_STACK) ; + REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN DATE_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "OVERFLOW EXCEPTION TEST") ; + + END OVERFLOW_EXCEPTION_TEST ; + + LOCAL_BLOCK: + + DECLARE + + TYPE DATE_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF DATE ; + + FIRST_DATE_TABLE : DATE_TABLE ; + + TABLE_INDEX : POSITIVE := 1 ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE SHOW_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => SHOW_DATES) ; + + PROCEDURE STORE_DATE_ITERATE IS NEW + DATE_STACK.ITERATE (PROCESS => STORE_DATES) ; + + PROCEDURE SHOW_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- SHOW_DATES + + REPORT.COMMENT ("THE MONTH IS " & + MONTH_TYPE'IMAGE (THIS_DATE.MONTH)) ; + REPORT.COMMENT ("THE DAY IS " & + DAY_TYPE'IMAGE (THIS_DATE.DAY)) ; + REPORT.COMMENT ("THE YEAR IS " & + YEAR_TYPE'IMAGE (THIS_DATE.YEAR)) ; + + CONTINUE := TRUE ; + + END SHOW_DATES ; + + PROCEDURE STORE_DATES (THIS_DATE : IN DATE ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- STORE_DATES + + FIRST_DATE_TABLE (TABLE_INDEX) := THIS_DATE ; + TABLE_INDEX := TABLE_INDEX + 1 ; + + CONTINUE := TRUE ; + + END STORE_DATES ; + + BEGIN -- LOCAL_BLOCK + + REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + + REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ; + SHOW_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + + STORE_DATE_ITERATE (OVER_THIS_STACK => FIRST_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= FIRST_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ; + END IF ; + + TABLE_INDEX := 1 ; + STORE_DATE_ITERATE (OVER_THIS_STACK => SECOND_DATE_STACK) ; + IF (FIRST_DATE_TABLE (1) /= TODAY) OR + (FIRST_DATE_TABLE (2) /= WALL_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + + END CC3019B2M ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c0.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- CC3019C0.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE + -- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF + -- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE CC3019C0_LIST_CLASS IS + + TYPE LIST IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN ; + + PRIVATE + + TYPE LIST_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF ELEMENT ; + + TYPE LIST IS RECORD + LENGTH : NATURAL := 0 ; + ACTUAL_LIST : LIST_TABLE ; + END RECORD ; + + END CC3019C0_LIST_CLASS ; + + PACKAGE BODY CC3019C0_LIST_CLASS IS + + PROCEDURE ADD (THIS_ELEMENT : IN OUT ELEMENT ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- ADD + + IF TO_THIS_LIST.LENGTH >= 10 THEN + RAISE OVERFLOW ; + ELSE + TO_THIS_LIST.LENGTH := TO_THIS_LIST.LENGTH + 1 ; + ASSIGN ( + SOURCE => THIS_ELEMENT, + DESTINATION => + TO_THIS_LIST.ACTUAL_LIST(TO_THIS_LIST.LENGTH)); + END IF ; + + END ADD ; + + PROCEDURE DELETE (THIS_ELEMENT : IN OUT ELEMENT ; + FROM_THIS_LIST : IN OUT LIST) IS + + BEGIN -- DELETE + + IF FROM_THIS_LIST.LENGTH <= 0 THEN + RAISE UNDERFLOW ; + ELSE + ASSIGN ( + SOURCE => + FROM_THIS_LIST.ACTUAL_LIST(FROM_THIS_LIST.LENGTH), + DESTINATION => THIS_ELEMENT) ; + FROM_THIS_LIST.LENGTH := FROM_THIS_LIST.LENGTH - 1 ; + END IF ; + + END DELETE ; + + PROCEDURE COPY (THIS_LIST : IN OUT LIST ; + TO_THIS_LIST : IN OUT LIST) IS + + BEGIN -- COPY + + TO_THIS_LIST.LENGTH := THIS_LIST.LENGTH ; + FOR INDEX IN TO_THIS_LIST.ACTUAL_LIST'RANGE LOOP + ASSIGN (SOURCE => THIS_LIST.ACTUAL_LIST (INDEX), + DESTINATION => TO_THIS_LIST.ACTUAL_LIST (INDEX)); + END LOOP ; + + END COPY ; + + PROCEDURE CLEAR (THIS_LIST : IN OUT LIST) IS + + BEGIN -- CLEAR + + THIS_LIST.LENGTH := 0 ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_LIST : IN LIST) IS + + CONTINUE : BOOLEAN := TRUE ; + FINISHED : NATURAL := 0 ; + + BEGIN -- ITERATE + + WHILE (CONTINUE = TRUE) AND (FINISHED < OVER_THIS_LIST.LENGTH) + LOOP + FINISHED := FINISHED + 1 ; + PROCESS (THIS_ELEMENT => + OVER_THIS_LIST.ACTUAL_LIST (FINISHED), + CONTINUE => CONTINUE) ; + END LOOP ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (IN_THIS_LIST : IN LIST) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN IN_THIS_LIST.LENGTH ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN LIST ; + RIGHT : IN LIST) RETURN BOOLEAN IS + + RESULT : BOOLEAN := TRUE ; + INDEX : NATURAL := 0 ; + + BEGIN -- "=" + + IF LEFT.LENGTH /= RIGHT.LENGTH THEN + RESULT := FALSE ; + ELSE + WHILE (INDEX < LEFT.LENGTH) AND RESULT LOOP + INDEX := INDEX + 1 ; + IF LEFT.ACTUAL_LIST (INDEX) /= + RIGHT.ACTUAL_LIST (INDEX) THEN + RESULT := FALSE ; + END IF ; + END LOOP ; + END IF ; + + RETURN RESULT ; + + END "=" ; + + END CC3019C0_LIST_CLASS ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c1.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,331 ---- + -- CC3019C1.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- THIS IS GENERIC PACKAGE WHICH IS USED TO CHECK THE LEVEL OF + -- NESTED GENERICS SUPPORTED BY AN IMPLEMENTATION. IT IS USED + -- BY MAIN PROCEDURE CC3019C2M.ADA. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + WITH CC3019C0_LIST_CLASS ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE CC3019C1_NESTED_GENERICS IS + + TYPE NESTED_GENERICS_TYPE IS LIMITED PRIVATE ; + + PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; + DESTINATION : IN OUT NESTED_GENERICS_TYPE) ; + + PROCEDURE SET_ELEMENT + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_ELEMENT : IN OUT ELEMENT) ; + + PROCEDURE SET_NUMBER + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_NUMBER : IN NATURAL) ; + + FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; + RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN ; + + FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN ELEMENT ; + + FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN NATURAL ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + PACKAGE GENERIC_TASK IS + + TASK TYPE PROTECTED_AREA IS + + ENTRY STORE (ITEM : IN OUT ELEMENT) ; + ENTRY GET (ITEM : IN OUT ELEMENT) ; + + END PROTECTED_AREA ; + + END GENERIC_TASK ; + + GENERIC + + TYPE ELEMENT IS LIMITED PRIVATE ; + + WITH PROCEDURE ASSIGN (SOURCE : IN OUT ELEMENT ; + DESTINATION : IN OUT ELEMENT) ; + + WITH FUNCTION "=" (LEFT : IN ELEMENT ; + RIGHT : IN ELEMENT) RETURN BOOLEAN ; + + PACKAGE STACK_CLASS IS + + TYPE STACK IS LIMITED PRIVATE ; + + OVERFLOW : EXCEPTION ; + UNDERFLOW : EXCEPTION ; + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) ; + + GENERIC + + WITH PROCEDURE PROCESS (THIS_ELEMENT : IN ELEMENT ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN ; + + PRIVATE + + PACKAGE NEW_LIST_CLASS IS NEW + CC3019C0_LIST_CLASS (ELEMENT => ELEMENT, + ASSIGN => ASSIGN, + "=" => "=") ; + + TYPE STACK IS NEW NEW_LIST_CLASS.LIST ; + + END STACK_CLASS ; + + PRIVATE + + TYPE NESTED_GENERICS_TYPE IS RECORD + FIRST : ELEMENT ; + SECOND : NATURAL ; + END RECORD ; + + END CC3019C1_NESTED_GENERICS ; + + PACKAGE BODY CC3019C1_NESTED_GENERICS IS + + PROCEDURE COPY (SOURCE : IN OUT NESTED_GENERICS_TYPE ; + DESTINATION : IN OUT NESTED_GENERICS_TYPE) IS + + BEGIN -- COPY + + ASSIGN (SOURCE => SOURCE.FIRST, + DESTINATION => DESTINATION.FIRST) ; + + DESTINATION.SECOND := SOURCE.SECOND ; + + END COPY ; + + PROCEDURE SET_ELEMENT + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_ELEMENT : IN OUT ELEMENT) IS + + BEGIN -- SET_ELEMENT + + ASSIGN (SOURCE => TO_THIS_ELEMENT, + DESTINATION => FOR_THIS_NGT_OBJECT.FIRST) ; + + END SET_ELEMENT ; + + PROCEDURE SET_NUMBER + (FOR_THIS_NGT_OBJECT : IN OUT NESTED_GENERICS_TYPE ; + TO_THIS_NUMBER : IN NATURAL) IS + + BEGIN -- SET_NUMBER + + FOR_THIS_NGT_OBJECT.SECOND := TO_THIS_NUMBER ; + + END SET_NUMBER ; + + FUNCTION "=" (LEFT : IN NESTED_GENERICS_TYPE ; + RIGHT : IN NESTED_GENERICS_TYPE) RETURN BOOLEAN IS + + BEGIN -- "=" + + IF (LEFT.FIRST = RIGHT.FIRST) AND + (LEFT.SECOND = RIGHT.SECOND) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END "=" ; + + FUNCTION ELEMENT_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN ELEMENT IS + + BEGIN -- ELEMENT_OF + + RETURN THIS_NGT_OBJECT.FIRST ; + + END ELEMENT_OF ; + + FUNCTION NUMBER_OF (THIS_NGT_OBJECT : IN NESTED_GENERICS_TYPE) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF + + RETURN THIS_NGT_OBJECT.SECOND ; + + END NUMBER_OF ; + + PACKAGE BODY GENERIC_TASK IS + + TASK BODY PROTECTED_AREA IS + + LOCAL_STORE : ELEMENT ; + + BEGIN -- PROTECTED_AREA + + LOOP + SELECT + ACCEPT STORE (ITEM : IN OUT ELEMENT) DO + ASSIGN (SOURCE => ITEM, + DESTINATION => LOCAL_STORE) ; + END STORE ; + OR + ACCEPT GET (ITEM : IN OUT ELEMENT) DO + ASSIGN (SOURCE => LOCAL_STORE, + DESTINATION => ITEM) ; + END GET ; + OR + TERMINATE ; + END SELECT ; + END LOOP ; + + END PROTECTED_AREA ; + + END GENERIC_TASK ; + + PACKAGE BODY STACK_CLASS IS + + PROCEDURE PUSH (THIS_ELEMENT : IN OUT ELEMENT ; + ON_TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- PUSH + + NEW_LIST_CLASS.ADD ( + THIS_ELEMENT => THIS_ELEMENT, + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_TO_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.OVERFLOW => RAISE OVERFLOW ; + + END PUSH ; + + PROCEDURE POP (THIS_ELEMENT : IN OUT ELEMENT ; + OFF_THIS_STACK : IN OUT STACK) IS + + BEGIN -- POP + + NEW_LIST_CLASS.DELETE ( + THIS_ELEMENT => THIS_ELEMENT, + FROM_THIS_LIST => + NEW_LIST_CLASS.LIST (OFF_THIS_STACK)) ; + + EXCEPTION + + WHEN NEW_LIST_CLASS.UNDERFLOW => RAISE UNDERFLOW ; + + END POP ; + + PROCEDURE COPY (THIS_STACK : IN OUT STACK ; + TO_THIS_STACK : IN OUT STACK) IS + + BEGIN -- COPY + + NEW_LIST_CLASS.COPY ( + THIS_LIST => NEW_LIST_CLASS.LIST (THIS_STACK), + TO_THIS_LIST => + NEW_LIST_CLASS.LIST (TO_THIS_STACK)) ; + + END COPY ; + + PROCEDURE CLEAR (THIS_STACK : IN OUT STACK) IS + + BEGIN -- CLEAR + + NEW_LIST_CLASS.CLEAR (NEW_LIST_CLASS.LIST (THIS_STACK)) ; + + END CLEAR ; + + PROCEDURE ITERATE (OVER_THIS_STACK : IN STACK) IS + + PROCEDURE STACK_ITERATE IS NEW NEW_LIST_CLASS.ITERATE + (PROCESS => PROCESS) ; + + BEGIN -- ITERATE + + STACK_ITERATE (NEW_LIST_CLASS.LIST (OVER_THIS_STACK)) ; + + END ITERATE ; + + FUNCTION NUMBER_OF_ELEMENTS (ON_THIS_STACK : IN STACK) + RETURN NATURAL IS + + BEGIN -- NUMBER_OF_ELEMENTS + + RETURN NEW_LIST_CLASS.NUMBER_OF_ELEMENTS + (IN_THIS_LIST => + NEW_LIST_CLASS.LIST (ON_THIS_STACK)) ; + + END NUMBER_OF_ELEMENTS ; + + FUNCTION "=" (LEFT : IN STACK ; + RIGHT : IN STACK) RETURN BOOLEAN IS + + BEGIN -- "=" + + RETURN NEW_LIST_CLASS."=" ( + LEFT => NEW_LIST_CLASS.LIST (LEFT), + RIGHT => NEW_LIST_CLASS.LIST (RIGHT)) ; + + END "=" ; + + END STACK_CLASS ; + + END CC3019C1_NESTED_GENERICS ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3019c2.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,457 ---- + -- CC3019C2M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC UNITS, E.G. + -- TO SUPPORT ITERATORS. + + -- THIS TEST SPECIFICALLY CHECKS THAT A + -- NESTING LEVEL OF 3 IS SUPPORTED FOR GENERICS: + -- INSTANTIATE CC3019C1_NESTED_GENERICS IN THE MAIN + -- PROCEDURE, THE INSTANTIATION OF CC3019C0_LIST_CLASS + -- IN GENERIC PACKAGE CC3019C1_NESTED_GENERICS, AND + -- THE INSTANTIATION OF NEW_LIST_CLASS.ITERATE IN + -- PROCEDURE ITERATE IN PACKAGE BODY STACK_CLASS. + -- + -- *** THIS IS THE MAIN PROGRAM. IT MUST BE COMPILED AFTER THE + -- *** SOURCE CODE IN FILES CC3019C0.ADA AND CC3019C1.ADA HAVE + -- *** BEEN COMPILED. + -- + -- HISTORY: + -- EDWARD V. BERARD, 31 AUGUST 1990 + + WITH REPORT ; + WITH CC3019C1_NESTED_GENERICS ; + + PROCEDURE CC3019C2M IS + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + STORE_DATE : DATE ; + + TODAY : DATE := (MONTH => AUG, + DAY => 31, + YEAR => 1990) ; + + FIRST_DATE : DATE := (MONTH => JUN, + DAY => 4, + YEAR => 1967) ; + + BIRTH_DATE : DATE := (MONTH => OCT, + DAY => 3, + YEAR => 1949) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + TYPE SEX IS (MALE, FEMALE) ; + + TYPE PERSON IS RECORD + BIRTH_DATE : DATE ; + GENDER : SEX ; + NAME : STRING (1 .. 10) ; + END RECORD ; + + FIRST_PERSON : PERSON ; + SECOND_PERSON : PERSON ; + + MYSELF : PERSON := (BIRTH_DATE => BIRTH_DATE, + GENDER => MALE, + NAME => "ED ") ; + + FRIEND : PERSON := (BIRTH_DATE => DATE'(DEC, 27, 1949), + GENDER => MALE, + NAME => "DENNIS ") ; + + FATHER : PERSON := (BIRTH_DATE => DATE'(JUL, 5, 1925), + GENDER => MALE, + NAME => "EDWARD ") ; + + DAUGHTER : PERSON := (BIRTH_DATE => DATE'(DEC, 10, 1980), + GENDER => FEMALE, + NAME => "CHRISSY ") ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ; + TO_THIS_PERSON : IN OUT PERSON) ; + + FUNCTION IS_EQUAL (LEFT : IN PERSON ; + RIGHT : IN PERSON) RETURN BOOLEAN ; + + -- INSTANTIATE OUTER GENERIC PACKAGE + + PACKAGE NEW_NESTED_GENERICS IS NEW + CC3019C1_NESTED_GENERICS (ELEMENT => DATE, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + SECOND_NNG : NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + + FUNCTION "=" (LEFT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE ; + RIGHT : IN NEW_NESTED_GENERICS.NESTED_GENERICS_TYPE) + RETURN BOOLEAN RENAMES NEW_NESTED_GENERICS."=" ; + + -- INSTANTIATE NESTED TASK PACKAGE + + PACKAGE NEW_GENERIC_TASK IS NEW + NEW_NESTED_GENERICS.GENERIC_TASK (ELEMENT => PERSON, + ASSIGN => ASSIGN) ; + + FIRST_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ; + SECOND_GENERIC_TASK : NEW_GENERIC_TASK.PROTECTED_AREA ; + + -- INSTANTIATE NESTED STACK PACKAGE + + PACKAGE PERSON_STACK IS NEW + NEW_NESTED_GENERICS.STACK_CLASS (ELEMENT => PERSON, + ASSIGN => ASSIGN, + "=" => IS_EQUAL) ; + + FIRST_PERSON_STACK : PERSON_STACK.STACK ; + SECOND_PERSON_STACK : PERSON_STACK.STACK ; + THIRD_PERSON_STACK : PERSON_STACK.STACK ; + + FUNCTION "=" (LEFT : IN PERSON_STACK.STACK ; + RIGHT : IN PERSON_STACK.STACK) RETURN BOOLEAN + RENAMES PERSON_STACK."=" ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_DATE : IN OUT DATE ; + TO_THIS_DATE : IN OUT DATE) IS + + BEGIN -- ASSIGN + + TO_THIS_DATE := THE_VALUE_OF_THIS_DATE ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN DATE ; + RIGHT : IN DATE) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + IF (LEFT.MONTH = RIGHT.MONTH) AND (LEFT.DAY = RIGHT.DAY) + AND (LEFT.YEAR = RIGHT.YEAR) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END IS_EQUAL ; + + PROCEDURE ASSIGN (THE_VALUE_OF_THIS_PERSON : IN OUT PERSON ; + TO_THIS_PERSON : IN OUT PERSON) IS + + BEGIN -- ASSIGN + + TO_THIS_PERSON := THE_VALUE_OF_THIS_PERSON ; + + END ASSIGN ; + + FUNCTION IS_EQUAL (LEFT : IN PERSON ; + RIGHT : IN PERSON) RETURN BOOLEAN IS + + BEGIN -- IS_EQUAL + + IF (LEFT.BIRTH_DATE = RIGHT.BIRTH_DATE) AND + (LEFT.GENDER = RIGHT.GENDER) AND + (LEFT.NAME = RIGHT.NAME) THEN + RETURN TRUE ; + ELSE + RETURN FALSE ; + END IF ; + + END IS_EQUAL ; + + BEGIN -- CC3019C2M + + REPORT.TEST ("CC3019C2M", + "CHECK INSTANTIATIONS OF UNITS WITHIN GENERIC " & + "UNITS, E.G., TO SUPPORT ITERATORS. THIS TEST " & + "SPECIFICALLY CHECKS THAT A NESTING LEVEL OF 3 " & + "IS SUPPORTED FOR GENERICS.") ; + + -- CHECK THE OUTERMOST GENERIC (NEW_NESTED_GENERICS) + + NEW_NESTED_GENERICS.SET_ELEMENT ( + FOR_THIS_NGT_OBJECT => FIRST_NNG, + TO_THIS_ELEMENT => TODAY) ; + NEW_NESTED_GENERICS.SET_NUMBER ( + FOR_THIS_NGT_OBJECT => FIRST_NNG, + TO_THIS_NUMBER => 1) ; + + NEW_NESTED_GENERICS.SET_ELEMENT ( + FOR_THIS_NGT_OBJECT => SECOND_NNG, + TO_THIS_ELEMENT => FIRST_DATE) ; + NEW_NESTED_GENERICS.SET_NUMBER ( + FOR_THIS_NGT_OBJECT => SECOND_NNG, + TO_THIS_NUMBER => 2) ; + + IF FIRST_NNG = SECOND_NNG THEN + REPORT.FAILED ("PROBLEMS WITH TESTING EQUALITY FOR " & + "OUTERMOST GENERIC") ; + END IF ; + + IF (NEW_NESTED_GENERICS.ELEMENT_OF (THIS_NGT_OBJECT => FIRST_NNG) + /= TODAY) OR + (NEW_NESTED_GENERICS.ELEMENT_OF ( + THIS_NGT_OBJECT => SECOND_NNG) + /= FIRST_DATE) THEN + REPORT.FAILED ("PROBLEMS WITH EXTRACTING ELEMENTS IN " & + "OUTERMOST GENERIC") ; + END IF ; + + IF (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => FIRST_NNG) + /= 1) OR + (NEW_NESTED_GENERICS.NUMBER_OF (THIS_NGT_OBJECT => SECOND_NNG) + /= 2) THEN + REPORT.FAILED ("PROBLEMS WITH EXTRACTING NUMBERS IN " & + "OUTERMOST GENERIC") ; + END IF ; + + NEW_NESTED_GENERICS.COPY (SOURCE => FIRST_NNG, + DESTINATION => SECOND_NNG) ; + + IF FIRST_NNG /= SECOND_NNG THEN + REPORT.FAILED ("PROBLEMS WITH COPYING OR TESTING EQUALITY " & + "IN OUTERMOST GENERIC") ; + END IF ; + + -- CHECK THE FIRST NESTED GENERIC (GENERIC_TASK) + + FIRST_GENERIC_TASK.STORE (ITEM => MYSELF) ; + SECOND_GENERIC_TASK.STORE (ITEM => FRIEND) ; + + FIRST_GENERIC_TASK.GET (ITEM => FIRST_PERSON) ; + SECOND_GENERIC_TASK.GET (ITEM => SECOND_PERSON) ; + + IF (FIRST_PERSON /= MYSELF) OR (SECOND_PERSON /= FRIEND) THEN + REPORT.FAILED ("PROBLEMS WITH NESTED TASK GENERIC") ; + END IF ; + + -- CHECK THE SECOND NESTED GENERIC (STACK_CLASS) + + PERSON_STACK.CLEAR (THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 1") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 1 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 2") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => FRIEND, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 3") ; + END IF ; + + PERSON_STACK.PUSH (THIS_ELEMENT => FATHER, + ON_TO_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 3 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 4") ; + END IF ; + + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => FIRST_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => FIRST_PERSON_STACK) /= 2 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 5") ; + END IF ; + + IF FIRST_PERSON /= FATHER THEN + REPORT.FAILED ( + "IMPROPER VALUE REMOVED FROM STACK - 1") ; + END IF ; + + PERSON_STACK.CLEAR (THIS_STACK => SECOND_PERSON_STACK) ; + IF PERSON_STACK.NUMBER_OF_ELEMENTS + (ON_THIS_STACK => SECOND_PERSON_STACK) /= 0 THEN + REPORT.FAILED ( + "IMPROPER VALUE RETURNED FROM NUMBER_OF_ELEMENTS - 6") ; + END IF ; + + PERSON_STACK.COPY (THIS_STACK => FIRST_PERSON_STACK, + TO_THIS_STACK => SECOND_PERSON_STACK) ; + + IF FIRST_PERSON_STACK /= SECOND_PERSON_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH COPY OR TEST FOR EQUALITY (STACK)") ; + END IF ; + + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => SECOND_PERSON_STACK) ; + PERSON_STACK.PUSH (THIS_ELEMENT => DAUGHTER, + ON_TO_THIS_STACK => SECOND_PERSON_STACK) ; + IF FIRST_PERSON_STACK = SECOND_PERSON_STACK THEN + REPORT.FAILED ( + "PROBLEMS WITH POP OR TEST FOR EQUALITY (STACK)") ; + END IF ; + + UNDERFLOW_EXCEPTION_TEST: + + BEGIN -- UNDERFLOW_EXCEPTION_TEST + + PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ; + PERSON_STACK.POP (THIS_ELEMENT => FIRST_PERSON, + OFF_THIS_STACK => THIRD_PERSON_STACK) ; + REPORT.FAILED ("UNDERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN PERSON_STACK.UNDERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "UNDERFLOW EXCEPTION TEST") ; + + END UNDERFLOW_EXCEPTION_TEST ; + + OVERFLOW_EXCEPTION_TEST: + + BEGIN -- OVERFLOW_EXCEPTION_TEST + + PERSON_STACK.CLEAR (THIS_STACK => THIRD_PERSON_STACK) ; + FOR INDEX IN 1 .. 10 LOOP + PERSON_STACK.PUSH ( + THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => THIRD_PERSON_STACK) ; + END LOOP ; + + PERSON_STACK.PUSH (THIS_ELEMENT => MYSELF, + ON_TO_THIS_STACK => THIRD_PERSON_STACK) ; + REPORT.FAILED ("OVERFLOW EXCEPTION NOT RAISED") ; + + EXCEPTION + + WHEN PERSON_STACK.OVERFLOW => NULL ; -- CORRECT EXCEPTION + -- RAISED + WHEN OTHERS => + REPORT.FAILED ("INCORRECT EXCEPTION RAISED IN " & + "OVERFLOW EXCEPTION TEST") ; + + END OVERFLOW_EXCEPTION_TEST ; + + LOCAL_BLOCK: + + DECLARE + + TYPE PERSON_TABLE IS ARRAY (POSITIVE RANGE 1 .. 10) OF PERSON; + + FIRST_PERSON_TABLE : PERSON_TABLE ; + + TABLE_INDEX : POSITIVE := 1 ; + + PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) ; + + PROCEDURE GATHER_PERSON_ITERATE IS NEW + PERSON_STACK.ITERATE (PROCESS => GATHER_PEOPLE) ; + + PROCEDURE SHOW_PERSON_ITERATE IS NEW + PERSON_STACK.ITERATE (PROCESS => SHOW_PEOPLE) ; + + PROCEDURE GATHER_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) IS + BEGIN -- GATHER_PEOPLE + + FIRST_PERSON_TABLE (TABLE_INDEX) := THIS_PERSON ; + TABLE_INDEX := TABLE_INDEX + 1 ; + + CONTINUE := TRUE ; + + END GATHER_PEOPLE ; + + PROCEDURE SHOW_PEOPLE (THIS_PERSON : IN PERSON ; + CONTINUE : OUT BOOLEAN) IS + + BEGIN -- SHOW_PEOPLE + + REPORT.COMMENT ("THE BIRTH MONTH IS " & + MONTH_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.MONTH)) ; + REPORT.COMMENT ("THE BIRTH DAY IS " & + DAY_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.DAY)) ; + REPORT.COMMENT ("THE BIRTH YEAR IS " & + YEAR_TYPE'IMAGE (THIS_PERSON.BIRTH_DATE.YEAR)) ; + REPORT.COMMENT ("THE GENDER IS " & + SEX'IMAGE (THIS_PERSON.GENDER)) ; + REPORT.COMMENT ("THE NAME IS " & THIS_PERSON.NAME) ; + + CONTINUE := TRUE ; + + END SHOW_PEOPLE ; + + BEGIN -- LOCAL_BLOCK + + REPORT.COMMENT ("CONTENTS OF THE FIRST STACK") ; + SHOW_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK) ; + + REPORT.COMMENT ("CONTENTS OF THE SECOND STACK") ; + SHOW_PERSON_ITERATE (OVER_THIS_STACK => SECOND_PERSON_STACK) ; + + GATHER_PERSON_ITERATE (OVER_THIS_STACK => FIRST_PERSON_STACK); + IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR + (FIRST_PERSON_TABLE (2) /= FRIEND) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 1") ; + END IF ; + + TABLE_INDEX := 1 ; + GATHER_PERSON_ITERATE(OVER_THIS_STACK => SECOND_PERSON_STACK); + IF (FIRST_PERSON_TABLE (1) /= MYSELF) OR + (FIRST_PERSON_TABLE (2) /= DAUGHTER) THEN + REPORT.FAILED ("PROBLEMS WITH ITERATION - 2") ; + END IF ; + + END LOCAL_BLOCK ; + + REPORT.RESULT ; + + END CC3019C2M ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3106b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- CC3106B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE FORMAL PARAMETER DENOTES THE ACTUAL + -- IN AN INSTANTIATION. + + -- HISTORY: + -- LDC 06/20/88 CREATED ORIGINAL TEST + -- EDWARD V. BERARD, 10 AUGUST 1990 ADDED CHECKS FOR MULTI- + -- DIMENSIONAL ARRAYS + + WITH REPORT ; + + PROCEDURE CC3106B IS + + BEGIN -- CC3106B + + REPORT.TEST("CC3106B","CHECK THAT THE FORMAL PARAMETER DENOTES " & + "THE ACTUAL IN AN INSTANTIATION"); + + LOCAL_BLOCK: + + DECLARE + + SUBTYPE SM_INT IS INTEGER RANGE 0..15 ; + TYPE PCK_BOL IS ARRAY (5..18) OF BOOLEAN ; + PRAGMA PACK(PCK_BOL) ; + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + TD_ARRAY : THREE_DIMENSIONAL := (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + TODAY))) ; + + TASK TYPE TSK IS + ENTRY ENT_1; + ENTRY ENT_2; + ENTRY ENT_3; + END TSK; + + GENERIC + + TYPE GEN_TYPE IS (<>); + GEN_BOLARR : IN OUT PCK_BOL; + GEN_TYP : IN OUT GEN_TYPE; + GEN_TSK : IN OUT TSK; + TEST_VALUE : IN DATE ; + TEST_CUBE : IN OUT THREE_DIMENSIONAL ; + + PACKAGE P IS + PROCEDURE GEN_PROC1 ; + PROCEDURE GEN_PROC2 ; + PROCEDURE GEN_PROC3 ; + PROCEDURE ARRAY_TEST ; + END P; + + ACT_BOLARR : PCK_BOL := (OTHERS => FALSE); + SI : SM_INT := 0 ; + T : TSK; + + PACKAGE BODY P IS + + PROCEDURE GEN_PROC1 IS + BEGIN -- GEN_PROC1 + GEN_BOLARR(14) := REPORT.IDENT_BOOL(TRUE); + GEN_TYP := GEN_TYPE'VAL(4); + IF ACT_BOLARR(14) /= TRUE OR SI /= REPORT.IDENT_INT(4) + THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN " & + "INSTANTIATED VALUES"); + END IF; + END GEN_PROC1; + + PROCEDURE GEN_PROC2 IS + BEGIN -- GEN_PROC2 + IF GEN_BOLARR(9) /= REPORT.IDENT_BOOL(TRUE) OR + GEN_TYPE'POS(GEN_TYP) /= REPORT.IDENT_INT(2) THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN " & + "VALUES ASSIGNED IN THE MAIN " & + "PROCEDURE"); + END IF; + GEN_BOLARR(18) := TRUE; + GEN_TYP := GEN_TYPE'VAL(9); + END GEN_PROC2; + + PROCEDURE GEN_PROC3 IS + BEGIN -- GEN_PROC3 + GEN_TSK.ENT_2; + END GEN_PROC3 ; + + PROCEDURE ARRAY_TEST IS + BEGIN -- ARRAY_TEST + + TEST_CUBE (0, JUN, 'C') := TEST_VALUE ; + + IF (TD_ARRAY (0, JUN, 'C') /= TEST_VALUE) OR + (TEST_CUBE (-5, MAR, 'A') /= WALL_DATE) THEN + REPORT.FAILED ("MULTI-DIMENSIONAL ARRAY VALUES ARE " & + "DIFFERENT THAN THE VALUES ASSIGNED " & + "IN THE MAIN AND ARRAY_TEST PROCEDURES.") ; + END IF ; + + END ARRAY_TEST ; + + END P ; + + TASK BODY TSK IS + BEGIN -- TSK + ACCEPT ENT_1 DO + REPORT.COMMENT("TASK ENTRY 1 WAS CALLED"); + END; + ACCEPT ENT_2 DO + REPORT.COMMENT("TASK ENTRY 2 WAS CALLED"); + END; + ACCEPT ENT_3 DO + REPORT.COMMENT("TASK ENTRY 3 WAS CALLED"); + END; + END TSK; + + PACKAGE INSTA1 IS NEW P (GEN_TYPE => SM_INT, + GEN_BOLARR => ACT_BOLARR, + GEN_TYP => SI, + GEN_TSK => T, + TEST_VALUE => FIRST_DATE, + TEST_CUBE => TD_ARRAY) ; + + BEGIN -- LOCAL_BLOCK + + INSTA1.GEN_PROC1; + ACT_BOLARR(9) := TRUE; + SI := 2; + INSTA1.GEN_PROC2; + IF ACT_BOLARR(18) /= REPORT.IDENT_BOOL(TRUE) OR + SI /= REPORT.IDENT_INT(9) THEN + REPORT.FAILED("VALUES ARE DIFFERENT THAN VALUES " & + "ASSIGNED IN THE GENERIC PROCEDURE"); + END IF; + + T.ENT_1; + INSTA1.GEN_PROC3; + T.ENT_3; + + TD_ARRAY (-5, MAR, 'A') := WALL_DATE ; + INSTA1.ARRAY_TEST ; + + END LOCAL_BLOCK; + + REPORT.RESULT; + + END CC3106B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3120a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,180 ---- + -- CC3120A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT GENERIC IN PARAMETERS ARE ALWAYS COPIED, AND THAT + -- GENERIC IN OUT PARAMETERS ARE ALWAYS RENAMED. + + -- DAT 8/10/81 + -- SPS 10/21/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3120A IS + BEGIN + TEST ("CC3120A", "GENERIC IN PARMS ARE COPIED, GENERIC IN OUT" + & " PARMS ARE RENAMED"); + + DECLARE + S1, S2 : INTEGER; + A1, A2, A3 : STRING (1 .. IDENT_INT (3)); + + TYPE REC IS RECORD + C1, C2 : INTEGER := 1; + END RECORD; + + R1, R2 : REC; + + PACKAGE P IS + TYPE PRIV IS PRIVATE; + PROCEDURE SET_PRIV (P : IN OUT PRIV); + PRIVATE + TYPE PRIV IS NEW REC; + END P; + USE P; + + P1, P2 : PRIV; + EX : EXCEPTION; + + GENERIC + TYPE T IS PRIVATE; + P1 : IN OUT T; + P2 : IN T; + PROCEDURE GP; + + B_ARR : ARRAY (1..10) OF BOOLEAN; + + PACKAGE BODY P IS + PROCEDURE SET_PRIV (P : IN OUT PRIV) IS + BEGIN + P.C1 := 3; + END SET_PRIV; + END P; + + PROCEDURE GP IS + BEGIN + IF P1 = P2 THEN + FAILED ("PARAMETER SCREW_UP SOMEWHERE"); + END IF; + P1 := P2; + IF P1 /= P2 THEN + FAILED ("ASSIGNMENT SCREW_UP SOMEWHERE"); + END IF; + RAISE EX; + FAILED ("RAISE STATEMENT DOESN'T WORK"); + END GP; + BEGIN + S1 := 4; + S2 := 5; + A1 := "XYZ"; + A2 := "ABC"; + A3 := "DEF"; + R1.C1 := 4; + R2.C1 := 5; + B_ARR := (1|3|5|7|9 => TRUE, 2|4|6|8|10 => FALSE); + SET_PRIV (P2); + + IF S1 = S2 + OR A1 = A3 + OR R1 = R2 + OR P1 = P2 THEN + FAILED ("WRONG ASSIGNMENT"); + END IF; + BEGIN + DECLARE + PROCEDURE PR IS NEW GP (INTEGER, S1, S2); + BEGIN + S2 := S1; + PR; -- OLD S2 ASSIGNED TO S1, SO S1 /= S2 NOW + FAILED ("EX NOT RAISED 1"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + SUBTYPE STR_1_3 IS STRING (IDENT_INT (1)..3); + PROCEDURE PR IS NEW GP (STR_1_3, A1, A3); + BEGIN + A3 := A1; + PR; + FAILED ("EX NOT RAISED 2"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (REC, R1, R2); + BEGIN + R2 := R1; + PR; + FAILED ("EX NOT RAISED 3"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (PRIV, P1, P2); + BEGIN + P2 := P1; + PR; + FAILED ("EX NOT RAISED 4"); + EXCEPTION + WHEN EX => NULL; + END; + DECLARE + PROCEDURE PR IS NEW GP (CHARACTER, + A3(IDENT_INT(2)), + A3(IDENT_INT(3))); + BEGIN + A3(3) := A3(2); + PR; + FAILED ("EX NOT RAISED 5"); + EXCEPTION + WHEN EX => NULL; + END; + + DECLARE + PROCEDURE PR IS NEW GP (BOOLEAN, + B_ARR(IDENT_INT(2)), + B_ARR(IDENT_INT(3))); + BEGIN + B_ARR(3) := B_ARR(2); + PR; + FAILED ("EX NOT RAISED 6"); + EXCEPTION + WHEN EX => NULL; + END; + END; + + IF S1 = S2 + OR A1 = A2 + OR R1 = R2 + OR P1 = P2 + OR A3(2) = A3(3) + OR B_ARR(2) = B_ARR(3) THEN + FAILED ("ASSIGNMENT FAILED 2"); + END IF; + END; + + RESULT; + END CC3120A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3120b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- CC3120B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT TASKS ARE NOT COPIED AS GENERIC IN OUT PARMS. + + -- DAT 8/27/81 + -- SPS 4/6/82 + -- JBG 3/23/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3120B IS + BEGIN + TEST ("CC3120B", "TASKS ARE NOT COPIED AS GENERIC PARAMETERS"); + + DECLARE + PACKAGE P IS + TYPE T IS LIMITED PRIVATE; + PROCEDURE UPDT (TPARM: IN T; I : IN OUT INTEGER); + PRIVATE + TASK TYPE T1 IS + ENTRY GET (I : OUT INTEGER); + ENTRY PUT (I : IN INTEGER); + END T1; + TYPE T IS RECORD + C : T1; + END RECORD; + END P; + USE P; + TT : T; + GENERIC + TYPE T IS LIMITED PRIVATE; + T1 : IN OUT T; + WITH PROCEDURE UPDT (TPARM : IN T; I: IN OUT INTEGER) + IS <> ; + PROCEDURE PR; + + PROCEDURE PR IS + I : INTEGER; + BEGIN + I := 5; + -- PR.I + -- UPDT.I UPDT.T1.I + -- 5 4 + UPDT (T1, I); + -- 4 5 + IF I /= 4 THEN + FAILED ("BAD VALUE 1"); + END IF; + I := 6; + -- 6 5 + UPDT (T1, I); + -- 5 6 + IF I /= 5 THEN + FAILED ("BAD VALUE 3"); + END IF; + RAISE TASKING_ERROR; + FAILED ("INCORRECT RAISE STATEMENT"); + END PR; + + PACKAGE BODY P IS + PROCEDURE UPDT (TPARM : IN T; I : IN OUT INTEGER) IS + V : INTEGER := I; + -- UPDT.I => V + -- T1.I => UPDT.I + -- V => T1.I + BEGIN + TPARM.C.GET (I); + TPARM.C.PUT (V); + END UPDT; + + TASK BODY T1 IS + I : INTEGER; + BEGIN + I := 1; + LOOP + SELECT + ACCEPT GET (I : OUT INTEGER) DO + I := T1.I; + END GET; + OR + ACCEPT PUT (I : IN INTEGER) DO + T1.I := I; + END PUT; + OR + TERMINATE; + END SELECT; + END LOOP; + END T1; + END P; + BEGIN + DECLARE + X : INTEGER := 2; + PROCEDURE PPP IS NEW PR (T, TT); + BEGIN + -- X + -- UPDT.I UPDT.T1.I + -- 2 1 + UPDT (TT, X); + -- 1 2 + X := X + 3; + -- 4 2 + UPDT (TT, X); + -- 2 4 + IF X /= 2 THEN + FAILED ("WRONG VALUE FOR X"); + END IF; + BEGIN + PPP; + FAILED ("PPP NOT CALLED"); + EXCEPTION + WHEN TASKING_ERROR => NULL; + END; + X := 12; + -- 12 6 + UPDT (TT, X); + -- 6 12 + IF X /= 6 THEN + FAILED ("WRONG FINAL VALUE IN TASK"); + END IF; + END; + END; + + RESULT; + END CC3120B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3121a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- CC3121A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN UNCONSTRAINED FORMAL GENERIC PARAMETER OF MODE "IN" + -- HAVING AN ARRAY TYPE OR A TYPE WITH DISCRIMINANTS HAS THE CONSTRAINTS + -- OF THE ACTUAL PARAMETER. + + -- TBN 9/29/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3121A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 10; + + TYPE ARRAY1 IS ARRAY (INT RANGE <>) OF INTEGER; + + TYPE REC1 (D : INT) IS + RECORD + VAR1 : INTEGER := 1; + END RECORD; + + TYPE REC2 (D : INT := 2) IS + RECORD + A : ARRAY1 (D .. IDENT_INT(4)); + B : REC1 (D); + C : INTEGER := 1; + END RECORD; + + TYPE ARRAY2 IS ARRAY (INT RANGE <>) OF REC2; + + BEGIN + TEST ("CC3121A", "CHECK THAT AN UNCONSTRAINED FORMAL GENERIC " & + "PARAMETER OF MODE 'IN' HAVING AN ARRAY TYPE " & + "OR A TYPE WITH DISCRIMINANTS HAS THE " & + "CONSTRAINTS OF THE ACTUAL PARAMETER"); + + DECLARE + OBJ_ARA1 : ARRAY1 (IDENT_INT(2) .. 5); + + GENERIC + VAR : ARRAY1; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF VAR'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FOR VAR'FIRST"); + END IF; + IF VAR'LAST /= IDENT_INT(5) THEN + FAILED ("INCORRECT RESULTS FOR VAR'LAST"); + END IF; + END PROC; + + PROCEDURE PROC1 IS NEW PROC (OBJ_ARA1); + BEGIN + PROC1; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_REC2 : REC2; + + GENERIC + VAR : REC2; + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + IF VAR.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.D"); + END IF; + IF VAR.A'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST"); + END IF; + IF VAR.A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'LAST"); + END IF; + IF VAR.B.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR.B.D"); + END IF; + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION FUNC1 IS NEW FUNC (OBJ_REC2); + + BEGIN + IF FUNC1 /= IDENT_INT(1) THEN + FAILED ("INCORRECT RESULTS FROM FUNC1 CALL"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_ARA2 : ARRAY2 (IDENT_INT(6) .. 8); + + GENERIC + VAR : ARRAY2; + PROCEDURE PROC; + + PROCEDURE PROC IS + BEGIN + IF VAR'FIRST /= IDENT_INT(6) THEN + FAILED ("INCORRECT RESULTS FOR VAR'FIRST"); + END IF; + IF VAR'LAST /= IDENT_INT(8) THEN + FAILED ("INCORRECT RESULTS FOR VAR'LAST"); + END IF; + IF VAR(6).D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).D"); + END IF; + IF VAR(6).A'FIRST /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).A'FIRST"); + END IF; + IF VAR(6).A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).A'LAST"); + END IF; + IF VAR(6).B.D /= IDENT_INT(2) THEN + FAILED ("INCORRECT RESULTS FROM VAR(6).B.D"); + END IF; + END PROC; + + PROCEDURE PROC2 IS NEW PROC (OBJ_ARA2); + BEGIN + PROC2; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_REC3 : REC2 (3); + + GENERIC + VAR : REC2; + PACKAGE PAC IS + PAC_VAR : INTEGER := 1; + END PAC; + + PACKAGE BODY PAC IS + BEGIN + IF VAR.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.D"); + END IF; + IF VAR.A'FIRST /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'FIRST"); + END IF; + IF VAR.A'LAST /= IDENT_INT(4) THEN + FAILED ("INCORRECT RESULTS FROM VAR.A'LAST"); + END IF; + IF VAR.B.D /= IDENT_INT(3) THEN + FAILED ("INCORRECT RESULTS FROM VAR.B.D"); + END IF; + END PAC; + + PACKAGE PAC1 IS NEW PAC (OBJ_REC3); + + BEGIN + NULL; + END; + + ------------------------------------------------------------------- + + RESULT; + END CC3121A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3123a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- CC3123A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN PARAMETERS ARE ONLY + -- EVALUATED IF THERE ARE NO ACTUAL PARAMETERS. + + -- TBN 12/01/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3123A IS + + BEGIN + TEST ("CC3123A", "CHECK THAT DEFAULT EXPRESSIONS FOR GENERIC IN " & + "PARAMETERS ARE ONLY EVALUATED IF THERE ARE " & + "NO ACTUAL PARAMETERS"); + DECLARE + TYPE ENUM IS (I, II, III); + OBJ_INT : INTEGER := 1; + OBJ_ENUM : ENUM := I; + + GENERIC + GEN_INT : IN INTEGER := IDENT_INT(2); + GEN_BOOL : IN BOOLEAN := IDENT_BOOL(FALSE); + GEN_ENUM : IN ENUM := II; + PACKAGE P IS + PAC_INT : INTEGER := GEN_INT; + PAC_BOOL : BOOLEAN := GEN_BOOL; + PAC_ENUM : ENUM := GEN_ENUM; + END P; + + PACKAGE P1 IS NEW P; + PACKAGE P2 IS + NEW P (IDENT_INT(OBJ_INT), GEN_ENUM => OBJ_ENUM); + PACKAGE P3 IS NEW P (GEN_BOOL => IDENT_BOOL(TRUE)); + BEGIN + IF P1.PAC_INT /= 2 OR P1.PAC_BOOL OR P1.PAC_ENUM /= II THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED"); + END IF; + IF P2.PAC_INT /= 1 OR P2.PAC_BOOL OR P2.PAC_ENUM /= I THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " & + "- 1"); + END IF; + IF P3.PAC_INT /= 2 OR NOT(P3.PAC_BOOL) OR + P3.PAC_ENUM /= II THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED CORRECTLY " & + "- 2"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + OBJ_INT1 : INTEGER := 3; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER; + + GENERIC + GEN_INT1 : IN INTEGER := FUNC (1); + GEN_INT2 : IN INTEGER := FUNC (GEN_INT1 + 1); + PROCEDURE PROC; + + PROCEDURE PROC IS + PROC_INT1 : INTEGER := GEN_INT1; + PROC_INT2 : INTEGER := GEN_INT2; + BEGIN + IF PROC_INT1 /= 3 THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 3"); + END IF; + IF PROC_INT2 /= 4 THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 4"); + END IF; + END PROC; + + FUNCTION FUNC (X : INTEGER) RETURN INTEGER IS + BEGIN + IF X /= IDENT_INT(4) THEN + FAILED ("DEFAULT VALUES WERE NOT EVALUATED " & + "CORRECTLY - 5"); + END IF; + RETURN IDENT_INT(X); + END FUNC; + + PROCEDURE NEW_PROC IS NEW PROC (GEN_INT1 => OBJ_INT1); + + BEGIN + NEW_PROC; + END; + + ------------------------------------------------------------------- + DECLARE + TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER; + TYPE REC IS + RECORD + ANS : BOOLEAN; + ARA : ARA_TYP; + END RECORD; + TYPE ARA_REC IS ARRAY (1 .. 5) OF REC; + + FUNCTION F (X : INTEGER) RETURN INTEGER; + + OBJ_REC : REC := (FALSE, (3, 4)); + OBJ_ARA : ARA_REC := (1 .. 5 => (FALSE, (3, 4))); + + GENERIC + GEN_OBJ1 : IN ARA_TYP := (F(1), 2); + GEN_OBJ2 : IN REC := (TRUE, GEN_OBJ1); + GEN_OBJ3 : IN ARA_REC := (1 .. F(5) => (TRUE, (1, 2))); + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION F (X : INTEGER) RETURN INTEGER IS + BEGIN + FAILED ("DEFAULT VALUES WERE EVALUATED - 1"); + RETURN IDENT_INT(X); + END F; + + FUNCTION NEW_FUNC IS NEW FUNC ((3, 4), OBJ_REC, OBJ_ARA); + + BEGIN + IF NOT EQUAL (NEW_FUNC, 1) THEN + FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 1"); + END IF; + END; + + ------------------------------------------------------------------- + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 5; + TYPE ARA_TYP IS ARRAY (1 .. 2) OF INTEGER; + TYPE COLOR IS (RED, WHITE); + TYPE CON_REC (D : INT) IS + RECORD + A : COLOR; + B : ARA_TYP; + END RECORD; + TYPE UNCON_OR_CON_REC (D : INT := 2) IS + RECORD + A : COLOR; + B : ARA_TYP; + END RECORD; + FUNCTION F (X : COLOR) RETURN COLOR; + + OBJ_CON1 : CON_REC (1) := (1, WHITE, (3, 4)); + OBJ_UNCON : UNCON_OR_CON_REC := (2, WHITE, (3, 4)); + OBJ_CON2 : UNCON_OR_CON_REC (3) := (3, WHITE, (3, 4)); + + GENERIC + GEN_CON1 : IN CON_REC := (2, F(RED), (1, 2)); + GEN_UNCON : IN UNCON_OR_CON_REC := (2, F(RED), (1, 2)); + GEN_CON2 : IN UNCON_OR_CON_REC := GEN_UNCON; + FUNCTION FUNC RETURN INTEGER; + + FUNCTION FUNC RETURN INTEGER IS + BEGIN + RETURN IDENT_INT(1); + END FUNC; + + FUNCTION F (X : COLOR) RETURN COLOR IS + BEGIN + FAILED ("DEFAULT VALUES WERE EVALUATED - 2"); + RETURN WHITE; + END F; + + FUNCTION NEW_FUNC IS NEW FUNC (OBJ_CON1, OBJ_UNCON, OBJ_CON2); + + BEGIN + IF NOT EQUAL (NEW_FUNC, 1) THEN + FAILED ("INCORRECT RESULT FROM GENERIC FUNCTION - 2"); + END IF; + END; + + RESULT; + END CC3123A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CC3125A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE INITIAL VALUE OF A + -- GENERIC IN PARAMETER DOES NOT SATISFY ITS SUBTYPE CONSTRAINT. + + -- THIS TEST CHECKS PARAMETERS OF A NON-GENERIC TYPE. + + -- DAT 8/10/81 + -- SPS 4/14/82 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3125A IS + + BEGIN + TEST ("CC3125A","GENERIC PARAMETER DEFAULTS OF " & + "NON-GENERIC TYPE EVALUATED AND CHECKED WHEN " & + "DECLARATION IS INSTANTIATED AND DEFAULT USED"); + + FOR I IN 1 .. 3 LOOP + COMMENT ("LOOP ITERATION"); + BEGIN + + DECLARE + SUBTYPE T IS INTEGER RANGE 1 .. IDENT_INT(1); + SUBTYPE I_1_2 IS INTEGER RANGE + IDENT_INT (1) .. IDENT_INT (2); + + GENERIC + P,Q : T := I_1_2'(I); + PACKAGE PKG IS + R: T := P; + END PKG; + + BEGIN + + BEGIN + DECLARE + PACKAGE P1 IS NEW PKG; + BEGIN + IF I = IDENT_INT(1) THEN + IF P1.R /= IDENT_INT(1) + THEN FAILED ("BAD INITIAL"& + " VALUE"); + END IF; + ELSIF I = 2 THEN + FAILED ("SUBTYPE NOT CHECKED AT " & + "INSTANTIATION"); + ELSE + FAILED ("DEFAULT NOT EVALUATED AT " & + "INSTANTIATION"); + END IF; + EXCEPTION + WHEN OTHERS => FAILED ("WRONG HANDLER"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + CASE I IS + WHEN 1 => + FAILED ("INCORRECT EXCEPTION"); + WHEN 2 => + COMMENT ("CONSTRAINT CHECKED" & + " ON INSTANTIATION"); + WHEN 3 => + COMMENT ("DEFAULT EVALUATED " & + "ON INSTANTIATION"); + END CASE; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("WRONG EXCEPTION"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + CASE I IS + WHEN 1 => + FAILED ("NO EXCEPTION SHOULD BE RAISED"); + WHEN 2 => + FAILED ("DEFAULT CHECKED AGAINST " & + "SUBTYPE AT DECLARATION"); + WHEN 3 => + FAILED ("DEFAULT EVALUATED AT " & + "DECLARATION"); + END CASE; + END; + END LOOP; + + RESULT; + END CC3125A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125b.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- CC3125B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER + -- HAVING AN ENUMERATION TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL + -- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + + -- TBN 12/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3125B IS + + TYPE COLOR IS (GREEN, RED, WHITE, BLUE, ORANGE, PINK); + SUBTYPE FLAG IS COLOR RANGE RED .. BLUE; + + FUNCTION IDENT_COL (X : COLOR) RETURN COLOR IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN GREEN; + END IDENT_COL; + + BEGIN + TEST ("CC3125B", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING AN ENUMERATION " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_COL : IN FLAG; + PACKAGE P IS + PAC_COL : FLAG := GEN_COL; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_COL(RED)); + BEGIN + IF P1.PAC_COL /= IDENT_COL(RED) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_COL(GREEN)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_COL(PINK)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS (<>); + GEN_COL : IN GEN_TYP; + PACKAGE Q IS + PAC_COL : GEN_TYP := GEN_COL; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FLAG, IDENT_COL(BLUE)); + BEGIN + IF Q1.PAC_COL /= IDENT_COL(BLUE) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FLAG, IDENT_COL(GREEN)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FLAG, IDENT_COL(PINK)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; + END CC3125B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125c.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- CC3125C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER + -- HAVING A FLOATING POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL + -- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + + -- TBN 12/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3125C IS + + TYPE FLT IS DIGITS 5 RANGE -10.0 .. 10.0; + SUBTYPE FLO IS FLT RANGE -5.0 .. 5.0; + + FUNCTION IDENT_FLT (X : FLT) RETURN FLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0.0; + END IDENT_FLT; + + BEGIN + TEST ("CC3125C", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING A FLOATING POINT " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_FLO : IN FLO; + PACKAGE P IS + PAC_FLO : FLT := GEN_FLO; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_FLT(-5.0)); + BEGIN + IF P1.PAC_FLO /= IDENT_FLT(-5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_FLT(-5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_FLT(5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS DIGITS <>; + GEN_FLO : IN GEN_TYP; + PACKAGE Q IS + PAC_FLO : GEN_TYP := GEN_FLO; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FLO, IDENT_FLT(5.0)); + BEGIN + IF Q1.PAC_FLO /= IDENT_FLT(5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FLO, IDENT_FLT(-5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FLO, IDENT_FLT(5.1)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; + END CC3125C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3125d.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- CC3125D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A GENERIC IN PARAMETER + -- HAVING A FIXED POINT TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL + -- PARAMETER LIES OUTSIDE THE RANGE OF THE FORMAL PARAMETER. + + -- TBN 12/15/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3125D IS + + TYPE FIXED IS DELTA 0.125 RANGE -10.0 .. 10.0; + SUBTYPE FIX IS FIXED RANGE -5.0 .. 5.0; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + END IF; + RETURN 0.0; + END IDENT_FIX; + + BEGIN + TEST ("CC3125D", "CHECK THAT CONSTRAINT_ERROR IS RAISED FOR A " & + "GENERIC IN PARAMETER HAVING A FIXED POINT " & + "TYPE IF AND ONLY IF THE VALUE OF THE ACTUAL " & + "PARAMETER LIES OUTSIDE THE RANGE OF THE " & + "FORMAL PARAMETER"); + DECLARE + GENERIC + GEN_FIX : IN FIX; + PACKAGE P IS + PAC_FIX : FIXED := GEN_FIX; + END P; + BEGIN + BEGIN + DECLARE + PACKAGE P1 IS NEW P(IDENT_FIX(-5.0)); + BEGIN + IF P1.PAC_FIX /= IDENT_FIX(-5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 1"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 1"); + END; + + BEGIN + DECLARE + PACKAGE P2 IS NEW P(IDENT_FIX(-5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DECLARE + PACKAGE P3 IS NEW P(IDENT_FIX(5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 3"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + END; + ------------------------------------------------------------------- + + DECLARE + GENERIC + TYPE GEN_TYP IS DELTA <>; + GEN_FIX : IN GEN_TYP; + PACKAGE Q IS + PAC_FIX : GEN_TYP := GEN_FIX; + END Q; + BEGIN + BEGIN + DECLARE + PACKAGE Q1 IS NEW Q(FIX, IDENT_FIX(5.0)); + BEGIN + IF Q1.PAC_FIX /= IDENT_FIX(5.0) THEN + FAILED ("INCORRECT VALUE PASSED - 4"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 4"); + END; + + BEGIN + DECLARE + PACKAGE Q2 IS NEW Q(FIX, IDENT_FIX(-5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 5"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 5"); + END; + + BEGIN + DECLARE + PACKAGE Q3 IS NEW Q(FIX, IDENT_FIX(5.2)); + BEGIN + FAILED ("NO EXCEPTION RAISED - 6"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 6"); + END; + END; + + RESULT; + END CC3125D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3126a.ada 2003-10-27 11:28:55.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- CC3126A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL + -- PARAMETER DOES NOT HAVE THE SAME NUMBER OF COMPONENTS + -- (PER DIMENSION) AS THE FORMAL PARAMETER. ALSO THAT FOR NULL + -- ARRAYS NO ERROR IS RAISED. + + -- HISTORY: + -- LB 12/02/86 + -- DWC 08/11/87 CHANGED HEADING FORMAT. + -- RJW 10/26/89 INITIALIZED VARIABLE H. + + WITH REPORT; USE REPORT; + + PROCEDURE CC3126A IS + + BEGIN + TEST ("CC3126A","GENERIC ACTUAL PARAMETER MUST HAVE THE SAME "& + "NUMBER OF COMPONENTS (PER DIMENSION) AS THE "& + "GENERIC FORMAL PARMETER"); + BEGIN + DECLARE + TYPE ARRY1 IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE ARR IS ARRY1 (1 .. 10); + + GENERIC + GARR : IN ARR; + PACKAGE P IS + NARR : ARR := GARR; + END P; + + BEGIN + BEGIN + DECLARE + X : ARRY1 (2 .. 11) := (2 .. 11 => 0); + PACKAGE Q IS NEW P(X); + BEGIN + Q.NARR(2) := 1; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + S : ARRY1 (1 .. 11) := (1 .. 11 => 0); + PACKAGE R IS NEW P(S); + BEGIN + FAILED ("EXCEPTION NOT RAISED 2"); + R.NARR(1) := IDENT_INT(R.NARR(1)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 2"); + END; + + BEGIN + DECLARE + G : ARRY1 (1 .. 9) := (1 .. 9 => 0); + PACKAGE K IS NEW P(G); + BEGIN + FAILED ("EXCEPTION NOT RAISED 3"); + IF EQUAL(3,3) THEN + K.NARR(1) := IDENT_INT(K.NARR(1)); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + S : ARRY1 (1 .. 11) := (1 .. 11 => 0); + PACKAGE F IS NEW P(S(2 .. 11)); + BEGIN + F.NARR(2) := IDENT_INT(F.NARR(2)); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 4"); + END; + END; + + DECLARE + SUBTYPE STR IS STRING(1 .. 20); + + GENERIC + GVAR : IN STR; + PACKAGE M IS + NVAR : STR := GVAR; + END M; + + BEGIN + BEGIN + DECLARE + L : STRING (2 .. 15); + PACKAGE U IS NEW M(L); + BEGIN + FAILED ("EXCEPTION NOT RAISED 5"); + U.NVAR(2) := IDENT_CHAR(U.NVAR(2)); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 5"); + END; + + BEGIN + DECLARE + H : STRING (1 .. 20) := (OTHERS => 'R'); + PACKAGE J IS NEW M(H); + BEGIN + IF EQUAL(3,3) THEN + J.NVAR(2) := IDENT_CHAR(J.NVAR(2)); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 6"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED STRINGS"); + END; + + DECLARE + TYPE NARRY IS ARRAY (INTEGER RANGE <>) OF INTEGER; + SUBTYPE SNARRY IS NARRY (2 .. 0); + + GENERIC + RD : IN SNARRY; + PACKAGE JA IS + CD : SNARRY := RD; + END JA; + BEGIN + BEGIN + DECLARE + AD : NARRY(1 .. 0); + PACKAGE PA IS NEW JA(AD); + BEGIN + IF NOT EQUAL(0,PA.CD'LAST) THEN + FAILED ("PARAMETER ATTRIBUTE INCORRECT"); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 7"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ARRAYS "& + "WITH NULL RANGES"); + END; + END; + + RESULT; + + END CC3126A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3127a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- CC3127A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A CONSTRAINED IN FORMAL PARAMETER HAVING A RECORD OR PRIVATE + -- TYPE WITH DISCRIMINANTS, CHECK THAT CONSTRAINT_ERROR IS RAISED + -- IF AND ONLY IF CORRESPONDING DISCRIMINANTS OF THE ACTUAL AND + -- FORMAL PARAMETER DO NOT HAVE THE SAME VALUES. + + -- HISTORY: + -- LB 12/04/86 CREATED ORIGINAL TEST. + -- VCL 08/19/87 CORRECTED THE FORMAT OF THIS HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE CC3127A IS + + TYPE INT IS RANGE 1 .. 20; + + BEGIN + TEST ("CC3127A","CORRESPONDING DISCRIMINANTS OF THE GENERIC "& + "ACTUAL PARAMETER AND THE GENERIC FORMAL "& + "PARAMETER MUST HAVE THE SAME VALUES."); + BEGIN + DECLARE + TYPE REC (A : INT) IS + RECORD + RINT : POSITIVE := 2; + END RECORD; + SUBTYPE CON_REC IS REC(4); + + GENERIC + GREC : IN CON_REC; + PACKAGE PA IS + NREC : CON_REC := GREC; + END PA; + BEGIN + BEGIN + DECLARE + RVAR : REC(3); + PACKAGE AB IS NEW PA(RVAR); + BEGIN + FAILED ("EXCEPTION NOT RAISED 1"); + AB.NREC.RINT := IDENT_INT(AB.NREC.RINT); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 1"); + END; + + BEGIN + DECLARE + SVAR : REC(4); + PACKAGE CD IS NEW PA(SVAR); + BEGIN + IF EQUAL(3,3) THEN + CD.NREC.RINT := IDENT_INT(CD.NREC.RINT); + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 2"); + END; + END; + + DECLARE + PACKAGE EF IS + TYPE PRI_REC (G : INT) IS PRIVATE; + PRIVATE + TYPE PRI_REC (G : INT) IS + RECORD + PINT : POSITIVE := 2; + END RECORD; + END EF; + SUBTYPE CPRI_REC IS EF.PRI_REC(4); + + GENERIC + GEN_REC : IN CPRI_REC; + PACKAGE GH IS + NGEN_REC : CPRI_REC := GEN_REC; + END GH; + + BEGIN + BEGIN + DECLARE + PVAR : EF.PRI_REC(4); + PACKAGE LM IS NEW GH(PVAR); + BEGIN + IF EQUAL(3,3) THEN + LM.NGEN_REC := LM.NGEN_REC; + END IF; + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED 3"); + END; + + BEGIN + DECLARE + PTVAR : EF.PRI_REC(5); + PACKAGE PAC IS NEW GH(PTVAR); + BEGIN + FAILED ("EXCEPTION NOT RAISED 4"); + IF EQUAL(3,5) THEN + COMMENT ("DISCRIMINANT OF PAC.NGEN_REC IS "& + INT'IMAGE(PAC.NGEN_REC.G)); + END IF; + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED 4"); + END; + END; + END; + + RESULT; + + END CC3127A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3128a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,358 ---- + -- CC3128A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR A CONSTRAINED IN FORMAL PARAMETER HAVING AN ACCESS TYPE, + -- CONSTRAINT_ERROR IS RAISED IF AND ONLY IF THE ACTUAL PARAMETER IS NOT + -- NULL AND THE OBJECT DESIGNATED BY THE ACTUAL PARAMETER DOES NOT SATISFY + -- THE FORMAL PARAMETER'S CONSTRAINTS. + + -- HISTORY: + -- RJW 10/28/88 CREATED ORIGINAL TEST. + -- JRL 02/28/96 Removed cases where the designated subtypes of the formal + -- and actual do not statically match. Corrected commentary. + + WITH REPORT; USE REPORT; + PROCEDURE CC3128A IS + + BEGIN + TEST ("CC3128A", "FOR A CONSTRAINED IN FORMAL PARAMETER HAVING " & + "AN ACCESS TYPE, CONSTRAINT_ERROR IS RAISED " & + "IF AND ONLY IF THE ACTUAL PARAMETER IS NOT " & + "NULL AND THE OBJECT DESIGNATED BY THE ACTUAL " & + "PARAMETER DOES NOT SATISFY FORMAL PARAMETER'S " & + "CONSTRAINTS"); + + DECLARE + TYPE REC (D : INTEGER := 10) IS + RECORD + NULL; + END RECORD; + + TYPE ACCREC IS ACCESS REC; + + SUBTYPE LINK IS ACCREC (5); + + GENERIC + LINK1 : LINK; + FUNCTION F (I : INTEGER) RETURN INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO CALL TO FUNCTION F - 1"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1.D, LINK1.D) THEN + COMMENT ("DISREGARD"); + END IF; + RETURN I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 1"); + RETURN I + 1; + END F; + + GENERIC + TYPE PRIV (D : INTEGER) IS PRIVATE; + PRIV1 : PRIV; + PACKAGE GEN IS + TYPE ACCPRIV IS ACCESS PRIV; + SUBTYPE LINK IS ACCPRIV (5); + GENERIC + LINK1 : LINK; + I : IN OUT INTEGER; + PACKAGE P IS END P; + END GEN; + + PACKAGE BODY GEN IS + PACKAGE BODY P IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO PACKAGE BODY P - 1"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1.D, LINK1.D) THEN + COMMENT ("DISREGARD"); + END IF; + I := I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN " & + "PACKAGE P - 1"); + I := I + 1; + END P; + + BEGIN + BEGIN + DECLARE + AR10 : ACCPRIV; + I : INTEGER := IDENT_INT (5); + PACKAGE P1 IS NEW P (AR10, I); + BEGIN + IF I /= 6 THEN + FAILED ("INCORRECT RESULT - " & + "PACKAGE P1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P1 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION " & + "OF PACKAGE P1 WITH NULL ACCESS " & + "VALUE"); + END; + + BEGIN + DECLARE + AR10 : ACCPRIV := NEW PRIV'(PRIV1); + I : INTEGER := IDENT_INT (0); + PACKAGE P1 IS NEW P (AR10, I); + BEGIN + FAILED ("NO EXCEPTION RAISED BY " & + "INSTANTIATION OF PACKAGE P1"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P1 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF PACKAGE P1"); + END; + END GEN; + + PACKAGE NEWGEN IS NEW GEN (REC, (D => 10)); + + BEGIN + BEGIN + DECLARE + I : INTEGER := IDENT_INT (5); + AR10 : ACCREC; + FUNCTION F1 IS NEW F (AR10); + BEGIN + I := F1 (I); + IF I /= 6 THEN + FAILED ("INCORRECT RESULT RETURNED BY " & + "FUNCTION F1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F1 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & + "FUNCTION F1 WITH NULL ACCESS VALUE"); + END; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (0); + AR10 : ACCREC := NEW REC'(D => 10); + FUNCTION F1 IS NEW F (AR10); + BEGIN + FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & + "OF FUNCTION F1"); + I := F1 (I); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F1 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF FUNCTION F1"); + END; + END; + + DECLARE + TYPE ARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + + TYPE ACCARR IS ACCESS ARR; + + SUBTYPE LINK IS ACCARR (1 .. 5); + + GENERIC + LINK1 : LINK; + FUNCTION F (I : INTEGER) RETURN INTEGER; + + FUNCTION F (I : INTEGER) RETURN INTEGER IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO CALL TO FUNCTION F - 2"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT EQUAL (LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) + THEN + COMMENT ("DISREGARD"); + END IF; + RETURN I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN FUNCTION F - 2"); + RETURN I + 1; + END F; + + GENERIC + TYPE GENARR IS ARRAY (POSITIVE RANGE <>) OF INTEGER; + PACKAGE GEN IS + TYPE ACCGENARR IS ACCESS GENARR; + SUBTYPE LINK IS ACCGENARR (1 .. 5); + GENERIC + LINK1 : LINK; + I : IN OUT INTEGER; + PACKAGE P IS END P; + END GEN; + + PACKAGE BODY GEN IS + PACKAGE BODY P IS + BEGIN + IF I /= 5 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED PRIOR " & + "TO PACKAGE BODY P - 2"); + END IF; + IF NOT EQUAL (I, 5) AND THEN + NOT + EQUAL(LINK1(IDENT_INT (3)),LINK1(IDENT_INT (3))) + THEN + COMMENT ("DISREGARD"); + END IF; + I := I + 1; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED WITHIN " & + "PACKAGE P - 2"); + I := I + 1; + END P; + + BEGIN + BEGIN + DECLARE + AR26 : ACCGENARR (2 .. 6); + I : INTEGER := IDENT_INT (5); + PACKAGE P2 IS NEW P (AR26, I); + BEGIN + IF I /= 6 THEN + FAILED ("INCORRECT RESULT - " & + "PACKAGE P2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P2 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION " & + "OF PACKAGE P2 WITH NULL ACCESS " & + "VALUE"); + END; + + BEGIN + DECLARE + AR26 : ACCGENARR + (IDENT_INT (2) .. IDENT_INT (6)) := + NEW GENARR'(1,2,3,4,5); + I : INTEGER := IDENT_INT (0); + PACKAGE P2 IS NEW P (AR26, I); + BEGIN + FAILED ("NO EXCEPTION RAISED BY " & + "INSTANTIATION OF PACKAGE P2"); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED TOO LATE - " & + "PACKAGE P2 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF PACKAGE P2"); + END; + END GEN; + + PACKAGE NEWGEN IS NEW GEN (ARR); + + BEGIN + BEGIN + DECLARE + I : INTEGER := IDENT_INT (5); + AR26 : ACCARR (IDENT_INT (2) .. IDENT_INT (6)); + FUNCTION F2 IS NEW F (AR26); + BEGIN + I := F2 (I); + IF I /= 6 THEN + FAILED ("INCORRECT RESULT RETURNED BY " & + "FUNCTION F2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F2 - 1"); + END; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT INSTANTIATION OF " & + "FUNCTION F2 WITH NULL ACCESS VALUE"); + END; + + BEGIN + DECLARE + I : INTEGER := IDENT_INT (0); + AR26 : ACCARR (2 .. 6) := NEW ARR'(1,2,3,4,5); + FUNCTION F2 IS NEW F (AR26); + BEGIN + FAILED ("NO EXCEPTION RAISED BY INSTANTIATION " & + "OF FUNCTION F2"); + I := F2 (I); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED AT CALL TO " & + "FUNCTION F2 - 2"); + END; + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT " & + "INSTANTIATION OF FUNCTION F2"); + END; + END; + RESULT; + END CC3128A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3203a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CC3203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FORMAL LIMITED/NON LIMITED PRIVATE TYPE HAS + -- DISCRIMINANTS, THE ACTUAL PARAMETER CAN HAVE DEFAULT DISCRIMINANT + -- VALUES. + + -- SPS 7/9/82 + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3203A IS + BEGIN + TEST ("CC3203A", "CHECK DEFAULT VALUES FOR LIMITED/" & + "NON LIMITED GENERIC FORMAL PRIVATE TYPES"); + DECLARE + SD : INTEGER := IDENT_INT(0); + + FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER; + + TYPE REC (D : INTEGER := 3) IS + RECORD NULL; END RECORD; + + TYPE RC(C : INTEGER := INIT_RC (1)) IS + RECORD NULL; END RECORD; + + GENERIC + TYPE PV(X : INTEGER) IS PRIVATE; + TYPE LP(X : INTEGER) IS LIMITED PRIVATE; + PACKAGE PACK IS + SUBTYPE NPV IS PV; + SUBTYPE NLP IS LP; + END PACK; + + FUNCTION INIT_RC (X: INTEGER) RETURN INTEGER IS + BEGIN + SD := SD + X; + RETURN SD; + END INIT_RC; + + PACKAGE P1 IS NEW PACK (REC, RC); + + PACKAGE P2 IS + P1VP : P1.NPV; + P1VL : P1.NLP; + P1VL2 : P1.NLP; + END P2; + USE P2; + BEGIN + + IF P1VP.D /= IDENT_INT(3) THEN + FAILED ("DEFAULT DISCRIMINANT VALUE WRONG"); + END IF; + + IF P1VL.C /= 1 THEN + FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT"); + END IF; + + IF P1VL2.C /= IDENT_INT(2) THEN + FAILED ("DID NOT EVALUATE DEFAULT DISCRIMINANT " & + "WHEN NEEDED"); + END IF; + END; + + RESULT; + + END CC3203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3207b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CC3207B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INSTANTIATION IS LEGAL IF A FORMAL + -- PARAMETER HAVING A LIMITED PRIVATE TYPE WITHOUT + -- A DISCRIMINANT IS USED TO DECLARE AN ACCESS + -- TYPE IN A BLOCK THAT CONTAINS A SELECTIVE WAIT + -- WITH A TERMINATE ALTERNATIVE, AND ACTUAL + -- PARAMETER'S BASE IS A TASK TYPE OR TYPE WITH A + -- SUBCOMPONENT OF A TASK TYPE. + + -- HISTORY: + -- LDC 06/24/88 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3207B IS + BEGIN + TEST("CC3207B","CHECK THAT INSTANTIATION IS LEGAL IF A " & + "FORMAL PARAMETER HAVING A LIMITED PRIVATE " & + "TYPE WITHOUT A DISCRIMINANT IS USED TO " & + "DECLARE AN ACCESS TYPE IN A BLOCK THAT " & + "CONTAINS A SELECTIVE WAIT WITH A TERMINATE " & + "ALTERNATIVE, AND ACTUAL PARAMETER'S BASE " & + "A TASK TYPE OR TYPE WITH A SUBCOMPONENT OF " & + "A TASK TYPE. "); + + DECLARE + TASK TYPE TT IS + ENTRY E; + END TT; + + TYPE TT_ARR IS ARRAY (1..2) OF TT; + + TYPE TT_REC IS RECORD + COMP : TT_ARR; + END RECORD; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE GEN IS + TASK TSK IS + ENTRY ENT(A : OUT INTEGER); + END TSK; + END GEN; + + INT : INTEGER; + + TASK BODY TT IS + BEGIN + SELECT + ACCEPT E; + OR + TERMINATE; + END SELECT; + END TT; + + PACKAGE BODY GEN IS + TASK BODY TSK IS + BEGIN + DECLARE + TYPE ACC_T IS ACCESS T; + TA : ACC_T := NEW T; + BEGIN + SELECT + ACCEPT ENT(A : OUT INTEGER) DO + A := IDENT_INT(7); + END; + OR + TERMINATE; + END SELECT; + END; + END TSK; + END GEN; + + PACKAGE GEN_TSK IS NEW GEN(TT); + PACKAGE GEN_TSK_SUB IS NEW GEN(TT_REC); + + BEGIN + GEN_TSK.TSK.ENT(INT); + + IF INT /= IDENT_INT(7) THEN + FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK"); + END IF; + + INT := 0; + GEN_TSK_SUB.TSK.ENT(INT); + + IF INT /= IDENT_INT(7) THEN + FAILED("THE WRONG VALUE WAS RETURNED BY THE TASK, " & + "WITH ACTUAL PARAMETER'S BASE IS A SUB" & + "COMPONENT OF A TASK TYPE"); + END IF; + RESULT; + END; + END CC3207B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3220a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- CC3220A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A DISCRETE FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND + -- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING + -- OPERATIONS OF THE ACTUAL TYPE. + + -- TBN 10/08/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3220A IS + + GENERIC + TYPE T IS (<>); + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + BEGIN + TEST ("CC3220A", "CHECK THAT A DISCRETE FORMAL TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT + 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + END; + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW P (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + END; + + DECLARE + OBJ_CHR : CHARACTER := 'A'; + + PACKAGE P3 IS NEW P (CHARACTER); + USE P3; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + ARA_NEWT : ARRAY (1 .. 5) OF NEW_T; + BEGIN + PAC_VAR := SUB_T'('A'); + IF (PAC_VAR < OBJ_CHR) OR (PAC_VAR > OBJ_CHR) THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF PAC_VAR NOT IN CHARACTER THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + IF OBJ_CHR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 17"); + END IF; + IF CHARACTER'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 18"); + END IF; + OBJ_CHR := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS('A') /= 65 AND THEN OBJ_CHR /= 'A' THEN + FAILED ("INCORRECT RESULTS - 19"); + END IF; + OBJ_NEWT := 'C'; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 20"); + END IF; + IF NEW_T'IMAGE('A') /= "'A'" THEN + FAILED ("INCORRECT RESULTS - 21"); + END IF; + ARA_NEWT := "HELLO"; + IF (NEW_T'('H') & NEW_T'('I')) /= "HI" THEN + FAILED ("INCORRECT RESULTS - 22"); + END IF; + END; + + RESULT; + END CC3220A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3221a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- CC3221A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT AN INTEGER FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, AND + -- OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING + -- OPERATIONS OF THE ACTUAL TYPE. + + -- TBN 10/09/86 + + WITH REPORT; USE REPORT; + PROCEDURE CC3221A IS + + GENERIC + TYPE T IS RANGE <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + BEGIN + TEST ("CC3221A", "CHECK THAT AN INTEGER FORMAL TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + END; + + RESULT; + END CC3221A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3222a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- CC3222A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FLOATING POINT FORMAL TYPE DENOTES ITS ACTUAL + -- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED WITH + -- CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + + -- HISTORY: + -- TBN 10/09/86 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3222A IS + + TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS DIGITS <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FLO; + + BEGIN + TEST ("CC3222A", "CHECK THAT A FLOATING POINT FORMAL TYPE " & + "DENOTES ITS ACTUAL PARAMETER, AND OPERATIONS " & + "OF THE FORMAL TYPE ARE IDENTIFIED WITH " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW P (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3222A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3223a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + -- CC3223A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FIXED POINT FORMAL TYPE DENOTES ITS ACTUAL + -- PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED + -- WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + + -- HISTORY: + -- TBN 10/09/86 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3223A IS + + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS DELTA <>; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FIX; + + BEGIN + TEST ("CC3223A", "CHECK THAT A FIXED POINT FORMAL TYPE DENOTES " & + "ITS ACTUAL PARAMETER, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3223A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3224a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,313 ---- + -- CC3224A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT A FORMAL ARRAY TYPE DENOTES ITS ACTUAL + -- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE + -- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + + -- HISTORY: + -- DHH 09/19/88 CREATED ORIGINAL TEST. + -- EDWARD V. BERARD, 14 AUGUST 1990 ADDED CHECKS FOR MULTI- + -- DIMENSIONAL ARRAYS + -- PWN 11/30/94 REMOVED 'BASE USE ILLEGAL IN ADA 9X. + + WITH REPORT ; + + PROCEDURE CC3224A IS + + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE B_ARR IS ARRAY(1 .. 3) OF BOOLEAN; + + Q : ARR; + R : B_ARR; + + GENERIC + TYPE T IS ARRAY(INT) OF INTEGER; + PACKAGE P IS + SUBTYPE SUB_T IS T; + X : SUB_T := (1, 2, 3); + END P; + + GENERIC + TYPE T IS ARRAY(INT) OF BOOLEAN; + PACKAGE BOOL IS + SUBTYPE SUB_T IS T; + END BOOL; + + SHORT_START : CONSTANT := -100 ; + SHORT_END : CONSTANT := 100 ; + TYPE SHORT_RANGE IS RANGE SHORT_START .. SHORT_END ; + + SUBTYPE REALLY_SHORT IS SHORT_RANGE RANGE -9 .. 0 ; + + TYPE MONTH_TYPE IS (JAN, FEB, MAR, APR, MAY, JUN, JUL, AUG, + SEP, OCT, NOV, DEC) ; + + SUBTYPE FIRST_HALF IS MONTH_TYPE RANGE JAN .. JUN ; + + TYPE DAY_TYPE IS RANGE 1 .. 31 ; + TYPE YEAR_TYPE IS RANGE 1904 .. 2050 ; + TYPE DATE IS RECORD + MONTH : MONTH_TYPE ; + DAY : DAY_TYPE ; + YEAR : YEAR_TYPE ; + END RECORD ; + + TODAY : DATE := (MONTH => AUG, + DAY => 8, + YEAR => 1990) ; + + FIRST_DATE : DATE := (DAY => 6, + MONTH => JUN, + YEAR => 1967) ; + + WALL_DATE : DATE := (MONTH => NOV, + DAY => 9, + YEAR => 1989) ; + + SUBTYPE FIRST_FIVE IS CHARACTER RANGE 'A' .. 'E' ; + + TYPE THREE_DIMENSIONAL IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + TD_ARRAY : THREE_DIMENSIONAL ; + SECOND_TD_ARRAY : THREE_DIMENSIONAL ; + + GENERIC + + TYPE CUBE IS ARRAY (REALLY_SHORT, + FIRST_HALF, + FIRST_FIVE) OF DATE ; + + PACKAGE TD_ARRAY_PACKAGE IS + + SUBTYPE SUB_CUBE IS CUBE ; + TEST_3D_ARRAY : SUB_CUBE := (THREE_DIMENSIONAL'RANGE => + (THREE_DIMENSIONAL'RANGE (2) => + (THREE_DIMENSIONAL'RANGE (3) => + TODAY))) ; + + END TD_ARRAY_PACKAGE ; + + + BEGIN -- CC3224A + + REPORT.TEST ("CC3224A", "CHECK THAT A FORMAL ARRAY TYPE DENOTES " & + "ITS ACTUAL PARAMETER, AND THAT OPERATIONS OF " & + "THE FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + ONE_DIMENSIONAL: + + DECLARE + + PACKAGE P1 IS NEW P (ARR); + + TYPE NEW_T IS NEW P1.SUB_T; + OBJ_NEWT : NEW_T; + + BEGIN -- ONE_DIMENSIONAL + + IF NEW_T'FIRST /= ARR'FIRST THEN + REPORT.FAILED("'FIRST ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LAST /= ARR'LAST THEN + REPORT.FAILED("'LAST ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'FIRST(1) /= ARR'FIRST(1) THEN + REPORT.FAILED("'FIRST(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NOT (NEW_T'LAST(1) = ARR'LAST(1)) THEN + REPORT.FAILED("'LAST(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF 2 NOT IN NEW_T'RANGE THEN + REPORT.FAILED("'RANGE ATTRIBUTE REPORT.FAILED"); + END IF; + + IF 3 NOT IN NEW_T'RANGE(1) THEN + REPORT.FAILED("'RANGE(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LENGTH /= ARR'LENGTH THEN + REPORT.FAILED("'LENGTH ATTRIBUTE REPORT.FAILED"); + END IF; + + IF NEW_T'LENGTH(1) /= ARR'LENGTH(1) THEN + REPORT.FAILED("'LENGTH(N) ATTRIBUTE REPORT.FAILED"); + END IF; + + OBJ_NEWT := (1, 2, 3); + IF REPORT.IDENT_INT(3) /= OBJ_NEWT(3) THEN + REPORT.FAILED("ASSIGNMENT REPORT.FAILED"); + END IF; + + IF NEW_T'(1, 2, 3) NOT IN NEW_T THEN + REPORT.FAILED("QUALIFIED EXPRESSION REPORT.FAILED"); + END IF; + + Q := (1, 2, 3); + IF NEW_T(Q) /= OBJ_NEWT THEN + REPORT.FAILED("EXPLICIT CONVERSION REPORT.FAILED"); + END IF; + + IF Q(1) /= OBJ_NEWT(1) THEN + REPORT.FAILED("INDEXING REPORT.FAILED"); + END IF; + + IF (1, 2) /= OBJ_NEWT(1 .. 2) THEN + REPORT.FAILED("SLICE REPORT.FAILED"); + END IF; + + IF (1, 2) & OBJ_NEWT(3) /= NEW_T(Q)THEN + REPORT.FAILED("CATENATION REPORT.FAILED"); + END IF; + + IF NOT (P1.X IN ARR) THEN + REPORT.FAILED ("FORMAL DOES NOT DENOTE ACTUAL"); + END IF; + + END ONE_DIMENSIONAL ; + + BOOLEAN_ONE_DIMENSIONAL: + + DECLARE + + PACKAGE B1 IS NEW BOOL (B_ARR); + + TYPE NEW_T IS NEW B1.SUB_T; + OBJ_NEWT : NEW_T; + + BEGIN -- BOOLEAN_ONE_DIMENSIONAL + + OBJ_NEWT := (TRUE, TRUE, TRUE); + R := (TRUE, TRUE, TRUE); + + IF (NEW_T'((TRUE, TRUE, TRUE)) XOR OBJ_NEWT) /= + NEW_T'((FALSE, FALSE, FALSE)) THEN + REPORT.FAILED("XOR REPORT.FAILED - BOOLEAN") ; + END IF; + + IF (NEW_T'((FALSE, FALSE, TRUE)) AND OBJ_NEWT) /= + NEW_T'((FALSE, FALSE, TRUE)) THEN + REPORT.FAILED("AND REPORT.FAILED - BOOLEAN") ; + END IF; + + IF (NEW_T'((FALSE, FALSE, FALSE)) OR OBJ_NEWT) /= + NEW_T'((TRUE, TRUE, TRUE)) THEN + REPORT.FAILED("OR REPORT.FAILED - BOOLEAN") ; + END IF ; + + END BOOLEAN_ONE_DIMENSIONAL ; + + THREE_DIMENSIONAL_TEST: + + DECLARE + + PACKAGE TD IS NEW TD_ARRAY_PACKAGE (CUBE => THREE_DIMENSIONAL) ; + + TYPE NEW_CUBE IS NEW TD.SUB_CUBE ; + NEW_CUBE_OBJECT : NEW_CUBE ; + + BEGIN -- THREE_DIMENSIONAL_TEST + + IF (NEW_CUBE'FIRST /= THREE_DIMENSIONAL'FIRST) OR + (NEW_CUBE'FIRST (1) /= THREE_DIMENSIONAL'FIRST) OR + (NEW_CUBE'FIRST (2) /= THREE_DIMENSIONAL'FIRST (2)) OR + (NEW_CUBE'FIRST (3) /= THREE_DIMENSIONAL'FIRST (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'FIRST FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (NEW_CUBE'LAST /= THREE_DIMENSIONAL'LAST) OR + (NEW_CUBE'LAST (1) /= THREE_DIMENSIONAL'LAST) OR + (NEW_CUBE'LAST (2) /= THREE_DIMENSIONAL'LAST (2)) OR + (NEW_CUBE'LAST (3) /= THREE_DIMENSIONAL'LAST (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'LAST FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (-5 NOT IN NEW_CUBE'RANGE) OR + (-3 NOT IN NEW_CUBE'RANGE (1)) OR + (FEB NOT IN NEW_CUBE'RANGE (2)) OR + ('C' NOT IN NEW_CUBE'RANGE (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'RANGE FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + IF (NEW_CUBE'LENGTH /= THREE_DIMENSIONAL'LENGTH) OR + (NEW_CUBE'LENGTH (1) /= THREE_DIMENSIONAL'LENGTH) OR + (NEW_CUBE'LENGTH (2) /= THREE_DIMENSIONAL'LENGTH (2)) OR + (NEW_CUBE'LENGTH (3) /= THREE_DIMENSIONAL'LENGTH (3)) THEN + REPORT.FAILED ("PROBLEMS WITH 'LENGTH FOR MULTI-" & + "DIMENSIONAL ARRAYS.") ; + END IF ; + + NEW_CUBE_OBJECT := (NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + FIRST_DATE))) ; + IF FIRST_DATE /= NEW_CUBE_OBJECT (-3, MAR, 'D') THEN + REPORT.FAILED ("ASSIGNMENT FOR MULTI-DIMENSIONAL " & + "ARRAYS FAILED.") ; + END IF ; + + IF NEW_CUBE'(NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + WALL_DATE))) NOT IN NEW_CUBE THEN + REPORT.FAILED ("QUALIFIED EXPRESSION FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + SECOND_TD_ARRAY := (NEW_CUBE'RANGE => + (NEW_CUBE'RANGE (2) => + (NEW_CUBE'RANGE (3) => + FIRST_DATE))) ; + IF NEW_CUBE (SECOND_TD_ARRAY) /= NEW_CUBE_OBJECT THEN + REPORT.FAILED ("EXPLICIT CONVERSION FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + IF SECOND_TD_ARRAY (-2, FEB, 'B') + /= NEW_CUBE_OBJECT (-2, FEB, 'B') THEN + REPORT.FAILED ("INDEXING FOR MULTI-" & + "DIMENSIONAL ARRAYS FAILED.") ; + END IF ; + + IF NOT (TD.TEST_3D_ARRAY IN THREE_DIMENSIONAL) THEN + REPORT.FAILED ("FORMAL MULTI-DIMENSIONAL ARRAY " & + "DOES NOT DENOTE ACTUAL.") ; + END IF ; + + END THREE_DIMENSIONAL_TEST ; + + REPORT.RESULT ; + + END CC3224A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3225a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- CC3225A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FORMAL ACCESS TYPE DENOTES ITS ACTUAL + -- PARAMETER, AND THAT OPERATIONS OF THE FORMAL TYPE ARE THOSE + -- IDENTIFIED WITH THE CORRESPONDING OPERATIONS OF THE ACTUAL TYPE. + + -- HISTORY: + -- DHH 10/21/88 CREATED ORIGINAL TEST. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3225A IS + + GENERIC + TYPE NODE IS PRIVATE; + TYPE T IS ACCESS NODE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : SUB_T; + END P; + + BEGIN + TEST ("CC3225A", "CHECK THAT A FORMAL ACCESS TYPE DENOTES ITS " & + "ACTUAL PARAMETER, AND THAT OPERATIONS OF THE " & + "FORMAL TYPE ARE THOSE IDENTIFIED WITH THE " & + "CORRESPONDING OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + TYPE ARR IS ARRAY(1 .. 3) OF INTEGER; + TYPE ACC_ARR IS ACCESS ARR; + + Q : ACC_ARR := NEW ARR; + + PACKAGE P1 IS NEW P (ARR, ACC_ARR); + USE P1; + + BEGIN + PAC_VAR := NEW ARR'(1, 2, 3); + IF PAC_VAR'FIRST /= Q'FIRST THEN + FAILED("'FIRST ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LAST /= Q'LAST THEN + FAILED("'LAST ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'FIRST(1) /= Q'FIRST(1) THEN + FAILED("'FIRST(N) ATTRIBUTE FAILED"); + END IF; + IF NOT (PAC_VAR'LAST(1) = Q'LAST(1)) THEN + FAILED("'LAST(N) ATTRIBUTE FAILED"); + END IF; + IF 2 NOT IN PAC_VAR'RANGE THEN + FAILED("'RANGE ATTRIBUTE FAILED"); + END IF; + IF 3 NOT IN PAC_VAR'RANGE(1) THEN + FAILED("'RANGE(N) ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LENGTH /= Q'LENGTH THEN + FAILED("'LENGTH ATTRIBUTE FAILED"); + END IF; + IF PAC_VAR'LENGTH(1) /= Q'LENGTH(1) THEN + FAILED("'LENGTH(N) ATTRIBUTE FAILED"); + END IF; + + PAC_VAR.ALL := (1, 2, 3); + IF IDENT_INT(3) /= PAC_VAR(3) THEN + FAILED("ASSIGNMENT FAILED"); + END IF; + + IF SUB_T'(PAC_VAR) NOT IN SUB_T THEN + FAILED("QUALIFIED EXPRESSION FAILED"); + END IF; + + Q.ALL := PAC_VAR.ALL; + IF SUB_T(Q) = PAC_VAR THEN + FAILED("EXPLICIT CONVERSION FAILED"); + END IF; + IF Q(1) /= PAC_VAR(1) THEN + FAILED("INDEXING FAILED"); + END IF; + IF (1, 2) /= PAC_VAR(1 .. 2) THEN + FAILED("SLICE FAILED"); + END IF; + IF (1, 2) & PAC_VAR(3) /= PAC_VAR.ALL THEN + FAILED("CATENATION FAILED"); + END IF; + END; + + DECLARE + TASK TYPE TSK IS + ENTRY ONE; + END TSK; + + GENERIC + TYPE T IS ACCESS TSK; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : SUB_T; + END P; + + TYPE ACC_TSK IS ACCESS TSK; + + PACKAGE P1 IS NEW P(ACC_TSK); + USE P1; + + GLOBAL : INTEGER := 5; + + TASK BODY TSK IS + BEGIN + ACCEPT ONE DO + GLOBAL := 1; + END ONE; + END; + BEGIN + PAC_VAR := NEW TSK; + PAC_VAR.ONE; + IF GLOBAL /= 1 THEN + FAILED("TASK ENTRY SELECTION FAILED"); + END IF; + END; + + DECLARE + TYPE REC IS + RECORD + I : INTEGER; + B : BOOLEAN; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + + PACKAGE P1 IS NEW P (REC, ACC_REC); + USE P1; + + BEGIN + PAC_VAR := NEW REC'(4, (PAC_VAR IN ACC_REC)); + IF PAC_VAR.I /= IDENT_INT(4) AND NOT PAC_VAR.B THEN + FAILED("RECORD COMPONENT SELECTION FAILED"); + END IF; + END; + + DECLARE + TYPE REC(B : BOOLEAN := FALSE) IS + RECORD + NULL; + END RECORD; + + TYPE ACC_REC IS ACCESS REC; + + PACKAGE P1 IS NEW P (REC, ACC_REC); + USE P1; + + BEGIN + PAC_VAR := NEW REC'(B => PAC_VAR IN ACC_REC); + IF NOT PAC_VAR.B THEN + FAILED("DISCRIMINANT SELECTION FAILED"); + END IF; + END; + + RESULT; + END CC3225A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3230a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- CC3230A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER AN ENUMERATION TYPE, AND OPERATIONS OF THE + -- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE + -- ACTUAL TYPE. + + -- HISTORY: + -- TBN 09/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3230A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + BEGIN + TEST ("CC3230A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ENUMERATION TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW P (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + END; + + DECLARE + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + OBJ_ENU : ENUM := RED; + + PACKAGE P2 IS NEW LP (ENUM); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(RED); + IF (PAC_VAR < OBJ_ENU) OR (PAC_VAR > OBJ_ENU) THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF PAC_VAR NOT IN ENUM THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF OBJ_ENU NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF ENUM'VAL(0) /= SUB_T'VAL(0) THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + OBJ_ENU := SUB_T'SUCC(PAC_VAR); + IF SUB_T'POS(RED) /= 0 AND THEN OBJ_ENU /= BLUE THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_NEWT := BLUE; + OBJ_NEWT := NEW_T'PRED(OBJ_NEWT); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + IF NEW_T'WIDTH /= 6 THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + END; + + RESULT; + END CC3230A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3231a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,177 ---- + -- CC3231A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER AN INTEGER TYPE, AND OPERATIONS OF THE FORMAL + -- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL + -- TYPE. + + -- HISTORY: + -- TBN 09/14/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3231A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + BEGIN + TEST ("CC3231A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "INTEGER TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW LP (INTEGER); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1); + IF PAC_VAR /= OBJ_INT THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + OBJ_INT := PAC_VAR + OBJ_INT; + IF OBJ_INT <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + PAC_VAR := PAC_VAR * OBJ_INT; + IF PAC_VAR NOT IN INTEGER THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + IF OBJ_INT NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF INTEGER'POS(2) /= SUB_T'POS(2) THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + PAC_VAR := 1; + OBJ_FIX := PAC_VAR * OBJ_FIX; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 17"); + END IF; + OBJ_INT := 1; + OBJ_FIX := OBJ_FIX / OBJ_INT; + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 18"); + END IF; + OBJ_INT := OBJ_INT ** PAC_VAR; + IF OBJ_INT /= 1 THEN + FAILED ("INCORRECT RESULTS - 19"); + END IF; + OBJ_FLO := OBJ_FLO ** PAC_VAR; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 20"); + END IF; + OBJ_NEWT := 1; + OBJ_NEWT := OBJ_NEWT - 1; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 21"); + END IF; + IF NEW_T'SUCC(2) /= 3 THEN + FAILED ("INCORRECT RESULTS - 22"); + END IF; + END; + + RESULT; + END CC3231A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3232a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- CC3232A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER A FLOATING POINT TYPE, AND OPERATIONS OF THE + -- FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE + -- ACTUAL TYPE. + + -- HISTORY: + -- TBN 09/15/88 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3232A IS + + TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + FUNCTION IDENT_FLO (X : FLOAT) RETURN FLOAT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FLO; + + BEGIN + TEST ("CC3232A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER A " & + "FLOATING POINT TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW P (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FLO : FLOAT := 1.0; + + PACKAGE P1 IS NEW LP (FLOAT); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FLO THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FLO := IDENT_FLO (PAC_VAR) + IDENT_FLO (OBJ_FLO); + IF OBJ_FLO <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := PAC_VAR * OBJ_FLO; + IF PAC_VAR NOT IN FLOAT THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FLO NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := 1.0; + OBJ_FLO := PAC_VAR * OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_FLO := 1.0; + OBJ_FLO := OBJ_FLO / OBJ_FLO; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := 1.0; + OBJ_FLO := PAC_VAR ** OBJ_INT; + IF OBJ_FLO /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF SUB_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF NEW_T'DIGITS /= 5 THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3232A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3233a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,175 ---- + -- CC3233A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER, A FIXED POINT TYPE AND OPERATIONS OF THE FORMAL + -- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL + -- TYPE. + + -- HISTORY: + -- TBN 09/15/88 CREATED ORIGINAL TEST. + -- PWN 01/31/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3233A IS + + TYPE FIXED IS DELTA 0.125 RANGE 0.0 .. 10.0; + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + FUNCTION IDENT_FIX (X : FIXED) RETURN FIXED IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN X; + ELSE + RETURN (0.0); + END IF; + END IDENT_FIX; + + BEGIN + TEST ("CC3233A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER, A " & + "FIXED POINT TYPE AND OPERATIONS OF THE FORMAL " & + "TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW P (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + OBJ_INT : INTEGER := 1; + OBJ_FIX : FIXED := 1.0; + + PACKAGE P1 IS NEW LP (FIXED); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1.0); + IF PAC_VAR /= OBJ_FIX THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_FIX := IDENT_FIX (PAC_VAR) + IDENT_FIX (OBJ_FIX); + IF OBJ_FIX <= PAC_VAR THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR := OBJ_INT * OBJ_FIX; + IF PAC_VAR NOT IN FIXED THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_FIX NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF SUB_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_NEWT := 1.0; + OBJ_NEWT := OBJ_NEWT - 1.0; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF NEW_T'DELTA /= 0.125 THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + OBJ_NEWT := NEW_T'SMALL + 1.0; + OBJ_FIX := 1.0; + OBJ_FIX := FIXED (OBJ_FIX * OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_FIX := 1.0; + OBJ_FIX := SUB_T (OBJ_FIX / OBJ_FIX); + IF OBJ_FIX /= 1.0 THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF FIXED'SMALL /= NEW_T'SMALL THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3233A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3234a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CC3234A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER AN ARRAY TYPE, AND OPERATIONS OF THE FORMAL + -- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL + -- TYPE. + + -- HISTORY: + -- TBN 09/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3234A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + BEGIN + TEST ("CC3234A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ARRAY TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER; + + OBJ_ARR : ARRAY_TYPE := (OTHERS => 1); + + PACKAGE P1 IS NEW P (ARRAY_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + IF PAC_VAR /= OBJ_ARR THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1); + IF OBJ_ARR(1) <= PAC_VAR(1) THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3); + IF PAC_VAR NOT IN ARRAY_TYPE THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF OBJ_ARR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + OBJ_ARR(1..5) := PAC_VAR(6..10); + IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2); + OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + OBJ_NEWT := NEW_T(PAC_VAR); + IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE ARRAY_TYPE IS ARRAY (1..10) OF INTEGER; + + OBJ_ARR : ARRAY_TYPE := (OTHERS => 1); + + PACKAGE P1 IS NEW LP (ARRAY_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := SUB_T'(1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + IF PAC_VAR /= OBJ_ARR THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_ARR(1) := PAC_VAR(2) + OBJ_ARR(1); + IF OBJ_ARR(1) <= PAC_VAR(1) THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + PAC_VAR(1) := PAC_VAR(1) * OBJ_ARR(3); + IF PAC_VAR NOT IN ARRAY_TYPE THEN + FAILED ("INCORRECT RESULTS - 11"); + END IF; + IF OBJ_ARR NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 12"); + END IF; + IF ARRAY_TYPE'FIRST /= SUB_T'FIRST THEN + FAILED ("INCORRECT RESULTS - 13"); + END IF; + OBJ_ARR(1..5) := PAC_VAR(6..10); + IF OBJ_ARR(1..5) /= (1, 1, 1, 1, 1) THEN + FAILED ("INCORRECT RESULTS - 14"); + END IF; + PAC_VAR := (1, 1, 1, 1, 1, 2, 2, 2, 2, 2); + OBJ_NEWT := (1, 1, 1, 1, 1, 1, 1, 1, 1, 1); + OBJ_NEWT := NEW_T(PAC_VAR); + IF OBJ_NEWT(3..7) /= (1, 1, 1, 2, 2) THEN + FAILED ("INCORRECT RESULTS - 15"); + END IF; + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 16"); + END IF; + END; + + RESULT; + END CC3234A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3235a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- CC3235A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PRIVATE OR LIMITED PRIVATE FORMAL TYPE DENOTES ITS + -- ACTUAL PARAMETER AN ACCESS TYPE, AND OPERATIONS OF THE FORMAL + -- TYPE ARE IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL + -- TYPE. + + -- HISTORY: + -- TBN 09/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3235A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + BEGIN + TEST ("CC3235A", "CHECK THAT A PRIVATE OR LIMITED PRIVATE " & + "FORMAL TYPE DENOTES ITS ACTUAL PARAMETER AN " & + "ACCESS TYPE, AND OPERATIONS OF THE " & + "FORMAL TYPE ARE IDENTIFIED WITH CORRESPONDING " & + "OPERATIONS OF THE ACTUAL TYPE"); + + DECLARE -- PRIVATE TYPE. + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + + TYPE ACCESS_TYPE IS ACCESS ENUM; + + OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED); + + PACKAGE P1 IS NEW P (ACCESS_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := NEW ENUM'(RED); + IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR + (PAC_VAR.ALL > OBJ_ACC.ALL) THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN ACCESS_TYPE THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_ACC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL)); + IF OBJ_ACC.ALL /= YELLOW THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + OBJ_NEWT := NEW ENUM'(BLUE); + OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL)); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 5"); + END IF; + END; + + DECLARE -- LIMITED PRIVATE TYPE. + TYPE ENUM IS (RED, YELLOW, GREEN, BLUE); + + TYPE ACCESS_TYPE IS ACCESS ENUM; + + OBJ_ACC : ACCESS_TYPE := NEW ENUM'(RED); + + PACKAGE P1 IS NEW LP (ACCESS_TYPE); + USE P1; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T; + BEGIN + PAC_VAR := NEW ENUM'(RED); + IF (PAC_VAR.ALL < OBJ_ACC.ALL) OR + (PAC_VAR.ALL > OBJ_ACC.ALL) THEN + FAILED ("INCORRECT RESULTS - 6"); + END IF; + IF PAC_VAR NOT IN ACCESS_TYPE THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF OBJ_ACC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + OBJ_ACC := NEW ENUM'(ENUM'SUCC(PAC_VAR.ALL)); + IF OBJ_ACC.ALL /= YELLOW THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + OBJ_NEWT := NEW ENUM'(BLUE); + OBJ_NEWT := NEW ENUM'(ENUM'PRED(OBJ_NEWT.ALL)); + IF OBJ_NEWT NOT IN NEW_T THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3235A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3236a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CC3236A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FORMAL PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS + -- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE + -- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE + -- WHEN THE ACTUAL PARAMETER IS A TYPE WITH DISCRIMINANTS. + + -- HISTORY: + -- DHH 10/24/88 CREATED ORIGINAL TEST. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CC3236A IS + + GENERIC + TYPE T IS PRIVATE; + PACKAGE P IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END P; + + GENERIC + TYPE T IS LIMITED PRIVATE; + PACKAGE LP IS + SUBTYPE SUB_T IS T; + PAC_VAR : T; + END LP; + + BEGIN + TEST ("CC3236A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " & + "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " & + "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " & + "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " & + "TYPE, WHEN THE ACTUAL PARAMETER IS A TYPE " & + "WITH DISCRIMINANTS"); + + DECLARE + TYPE REC(X : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + OBJ_REC : REC(4); + + PACKAGE P2 IS NEW P (REC); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T(4); + BEGIN + PAC_VAR := SUB_T'((X => 4)); + IF PAC_VAR /= OBJ_REC THEN + FAILED ("INCORRECT RESULTS - 1"); + END IF; + IF PAC_VAR NOT IN REC THEN + FAILED ("INCORRECT RESULTS - 2"); + END IF; + IF OBJ_REC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 3"); + END IF; + IF PAC_VAR.X /= OBJ_NEWT.X THEN + FAILED ("INCORRECT RESULTS - 4"); + END IF; + END; + + DECLARE + TYPE REC(X : INTEGER := 5) IS + RECORD + NULL; + END RECORD; + OBJ_REC : REC(4); + + PACKAGE P2 IS NEW LP (REC); + USE P2; + + TYPE NEW_T IS NEW SUB_T; + OBJ_NEWT : NEW_T(4); + BEGIN + PAC_VAR := SUB_T'(X => 4); + IF PAC_VAR /= OBJ_REC THEN + FAILED ("INCORRECT RESULTS - 7"); + END IF; + IF PAC_VAR NOT IN REC THEN + FAILED ("INCORRECT RESULTS - 8"); + END IF; + IF OBJ_REC NOT IN SUB_T THEN + FAILED ("INCORRECT RESULTS - 9"); + END IF; + IF PAC_VAR.X /= OBJ_NEWT.X THEN + FAILED ("INCORRECT RESULTS - 10"); + END IF; + END; + + RESULT; + END CC3236A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3240a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CC3240A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FORMAL PRIVATE AND LIMITED PRIVATE TYPE DENOTES ITS + -- ACTUAL PARAMETER, AND OPERATIONS OF THE FORMAL TYPE ARE + -- IDENTIFIED WITH CORRESPONDING OPERATIONS OF THE ACTUAL TYPE + -- WHEN THE FORMAL TYPE IS A TYPE WITH DISCRIMINANTS. + + -- HISTORY: + -- RJW 10/13/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3240A IS + + BEGIN + TEST ("CC3240A", "CHECK THAT A FORMAL PRIVATE OR LIMITED " & + "PRIVATE TYPE DENOTES ITS ACTUAL PARAMETER AND " & + "OPERATIONS OF THE FORMAL TYPE ARE IDENTIFIED " & + "WITH CORRESPONDING OPERATIONS OF THE ACTUAL " & + "TYPE, WHEN THE FORMAL TYPE IS A TYPE " & + "WITH DISCRIMINANTS"); + + DECLARE + + GENERIC + TYPE T(A : INTEGER) IS PRIVATE; + PACKAGE P IS + SUBTYPE S IS T; + TX : T(5); + END P; + + TYPE REC (L : INTEGER) IS + RECORD + A : INTEGER; + END RECORD; + + PACKAGE P1 IS NEW P (REC); + USE P1; + + BEGIN + TX := (L => 5, A => 7); + IF NOT (TX IN REC) THEN + FAILED ("MEMBERSHIP TEST - PRIVATE"); + END IF; + + IF TX.A /= 7 OR TX.L /= 5 THEN + FAILED ("SELECTED COMPONENTS - PRIVATE"); + END IF; + + IF S(TX) /= REC(TX) THEN + FAILED ("EXPLICIT CONVERSION - PRIVATE"); + END IF; + + IF NOT TX'CONSTRAINED THEN + FAILED ("'CONSTRAINED - PRIVATE"); + END IF; + END; + + DECLARE + TYPE REC(L : INTEGER) IS + RECORD + A : INTEGER; + END RECORD; + + GENERIC + TYPE T(A : INTEGER) IS LIMITED PRIVATE; + TX : IN OUT T; + PACKAGE LP IS + SUBTYPE S IS T; + END LP; + + R : REC (5) := (5, 7); + + PACKAGE BODY LP IS + BEGIN + IF (TX IN S) /= (R IN REC) THEN + FAILED ("MEMBERSHIP TEST - LIMITED PRIVATE"); + END IF; + + IF TX.A /= 5 THEN + FAILED ("SELECTED COMPONENTS - LIMITED PRIVATE"); + END IF; + + IF (S(TX) IN S) /= (REC(R) IN REC) THEN + FAILED ("EXPLICIT CONVERSION - LIMITED PRIVATE"); + END IF; + + IF NOT TX'CONSTRAINED THEN + FAILED ("'CONSTRAINED - LIMITED PRIVATE"); + END IF; + END LP; + + PACKAGE P1 IS NEW LP (REC, R); + USE P1; + BEGIN + NULL; + END; + + RESULT; + END CC3240A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CC3305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF + -- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + + -- CHECK WHEN THE SCALAR TYPE IS DEFINED BY (<>). + + -- SPS 7/15/82 + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3305A IS + BEGIN + + TEST ("CC3305A", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM (<>)"); + + DECLARE + TYPE COLOR IS (RED, BLUE, YELLOW, ORANGE, GREEN, PURPLE); + SUBTYPE P_COLOR IS COLOR RANGE BLUE .. ORANGE; + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + SUBTYPE ATOC IS CHARACTER RANGE CHARACTER'VAL(1) .. + CHARACTER'VAL(3); + + GENERIC + TYPE GFT IS (<>); + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT'VAL (I); + IF I = 0 OR I = 4 THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= 0 AND I /= 4 THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + COMMENT ("INSTANTIATION WITH P_COLOR"); + DECLARE + PACKAGE NPC IS NEW PK (P_COLOR); + BEGIN + NULL; + END; + + COMMENT ("INSTANTIATION WITH INT"); + + DECLARE + PACKAGE NPI IS NEW PK (INT); + BEGIN + NULL; + END; + + COMMENT ("INSTANTIATION WITH ATOC"); + + DECLARE + PACKAGE NPA IS NEW PK (ATOC); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; + END CC3305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CC3305B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF + -- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + + -- CHECK WHEN THE SCALAR TYPE IS DEFINED BY RANGE <>. + + -- SPS 7/15/82 + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3305B IS + BEGIN + + TEST ("CC3305B", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM RANGE <>"); + + DECLARE + SUBTYPE INT IS INTEGER RANGE 1 .. 3; + + GENERIC + TYPE GFT IS RANGE <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT(I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NPI IS NEW PK (INT); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; + END CC3305B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CC3305C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF + -- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + + -- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DIGITS <>. + + -- SPS 7/15/82 + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3305C IS + BEGIN + + TEST ("CC3305C", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM DIGITS <>"); + + DECLARE + SUBTYPE FL IS FLOAT RANGE 1.0 .. 3.0; + + GENERIC + TYPE GFT IS DIGITS <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT (I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NP IS NEW PK (FL); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; + END CC3305C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3305d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CC3305D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT WHEN A GENERIC FORMAL TYPE IS A SCALAR TYPE, THE BOUNDS OF + -- THE ACTUAL PARAMETER ARE USED WITHIN THE INSTANTIATED UNIT. + + -- CHECK WHEN THE SCALAR TYPE IS DEFINED BY DELTA <>. + + -- SPS 7/15/82 + + WITH REPORT; + USE REPORT; + + PROCEDURE CC3305D IS + BEGIN + + TEST ("CC3305D", "TEST THE BOUNDS OF GENERIC FORMAL SCALAR " & + "TYPES OF THE FORM DELTA <>"); + + DECLARE + TYPE FX IS DELTA 0.1 RANGE 1.0 .. 3.0; + + GENERIC + TYPE GFT IS DELTA <>; + PACKAGE PK IS END PK; + + PACKAGE BODY PK IS + BEGIN + FOR I IN IDENT_INT(0) .. IDENT_INT(4) LOOP + COMMENT ("START OF ITERATION"); + DECLARE + VAR : GFT; + BEGIN + VAR := GFT (I); + IF I = IDENT_INT(0) OR I = IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF I /= IDENT_INT(0) AND + I /= IDENT_INT(4) THEN + FAILED ("CONSTRAINT_ERROR RAISED " & + "INAPPROPRIATELY"); + END IF; + END; + END LOOP; + END PK; + + BEGIN + + DECLARE + PACKAGE NP IS NEW PK (FX); + BEGIN + NULL; + END; + + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED ON INSTANTIATION"); + END; + + RESULT; + END CC3305D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3601a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,251 ---- + -- CC3601A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PREDEFINED OPERATORS MAY BE PASSED AS ACTUAL + -- GENERIC SUBPROGRAM PARAMETERS (CHECKS FOR "=" AND "/=" ARE IN + -- CC3601C). + + -- R.WILLIAMS 10/9/86 + -- JRL 11/15/95 Added unknown discriminant part to all formal + -- private types. + + + WITH REPORT; USE REPORT; + PROCEDURE CC3601A IS + + GENERIC + TYPE T (<>) IS PRIVATE; + V, V1 : T; + KIND : STRING; + WITH FUNCTION F1 (X : IN T) RETURN T; + PACKAGE GP1 IS + R : BOOLEAN := F1 (V) = V1; + END GP1; + + PACKAGE BODY GP1 IS + BEGIN + IF NOT (IDENT_BOOL(R)) THEN + FAILED ( "INCORRECT VALUE FOR UNARY OP - " & KIND); + END IF; + END GP1; + + GENERIC + TYPE T (<>) IS PRIVATE; + V, V1, V2 : IN T; + KIND : STRING; + WITH FUNCTION F1 (P1 : IN T; P2 : IN T) RETURN T; + PACKAGE GP2 IS + R : BOOLEAN := V /= F1 (V1, V2); + END GP2; + + PACKAGE BODY GP2 IS + BEGIN + IF IDENT_BOOL (R) THEN + FAILED ( "INCORRECT VALUE FOR BINARY OP - " & KIND); + END IF; + END GP2; + + + GENERIC + TYPE T1 (<>) IS PRIVATE; + TYPE T2 (<>) IS PRIVATE; + V1 : T1; + V2 : T2; + KIND : STRING; + WITH FUNCTION F1 (X : IN T1) RETURN T2; + PACKAGE GP3 IS + R : BOOLEAN := F1 (V1) = V2; + END GP3; + + PACKAGE BODY GP3 IS + BEGIN + IF NOT (IDENT_BOOL(R)) THEN + FAILED ( "INCORRECT VALUE FOR OP - " & KIND); + END IF; + END GP3; + + BEGIN + TEST ( "CC3601A", "CHECK THAT PREDEFINED OPERATORS MAY BE " & + "PASSED AS ACTUAL GENERIC SUBPROGRAM " & + "PARAMETERS" ); + + + BEGIN -- CHECKS WITH RELATIONAL OPERATORS AND LOGICAL OPERATORS AS + -- ACTUAL PARAMETERS. + + FOR I1 IN BOOLEAN LOOP + + FOR I2 IN BOOLEAN LOOP + COMMENT ( "B1 = " & BOOLEAN'IMAGE (I1) & " AND " & + "B2 = " & BOOLEAN'IMAGE (I2) ); + DECLARE + B1 : BOOLEAN := IDENT_BOOL (I1); + B2 : BOOLEAN := IDENT_BOOL (I2); + + PACKAGE P1 IS + NEW GP1 (BOOLEAN, NOT B2, B2, + """NOT"" - 1", "NOT"); + PACKAGE P2 IS + NEW GP2 (BOOLEAN, B1 OR B2, B1, B2, + "OR", "OR"); + PACKAGE P3 IS + NEW GP2 (BOOLEAN, B1 AND B2, B2, B1, + "AND", "AND"); + PACKAGE P4 IS + NEW GP2 (BOOLEAN, B1 /= B2, B1, B2, + "XOR", "XOR"); + PACKAGE P5 IS + NEW GP2 (BOOLEAN, B1 < B2, B1, B2, + "<", "<"); + PACKAGE P6 IS + NEW GP2 (BOOLEAN, B1 <= B2, B1, B2, + "<=", "<="); + PACKAGE P7 IS + NEW GP2 (BOOLEAN, B1 > B2, B1, B2, + ">", ">"); + PACKAGE P8 IS + NEW GP2 (BOOLEAN, B1 >= B2, B1, B2, + ">=", ">="); + + TYPE AB IS ARRAY (BOOLEAN RANGE <> ) + OF BOOLEAN; + AB1 : AB (BOOLEAN) := (B1, B2); + AB2 : AB (BOOLEAN) := (B2, B1); + T : AB (B1 .. B2) := (B1 .. B2 => TRUE); + F : AB (B1 .. B2) := (B1 .. B2 => FALSE); + VB1 : AB (B1 .. B1) := (B1 => B2); + VB2 : AB (B2 .. B2) := (B2 => B1); + + PACKAGE P9 IS + NEW GP1 (AB, AB1, NOT AB1, + """NOT"" - 2", "NOT"); + PACKAGE P10 IS + NEW GP1 (AB, T, F, + """NOT"" - 3", "NOT"); + PACKAGE P11 IS + NEW GP1 (AB, VB2, (B2 => NOT B1), + """NOT"" - 4", "NOT"); + PACKAGE P12 IS + NEW GP2 (AB, AB1 AND AB2, AB1, AB2, + "AND", "AND"); + BEGIN + NULL; + END; + END LOOP; + END LOOP; + END; + + DECLARE -- CHECKS WITH ADDING AND MULTIPLYING OPERATORS, "**", + -- AND "ABS". + + PACKAGE P1 IS NEW GP1 (INTEGER, -4, -4, """+"" - 1", "+"); + + PACKAGE P2 IS NEW GP1 (FLOAT, 4.0, 4.0, """+"" - 2", "+"); + + PACKAGE P3 IS NEW GP1 (DURATION, -4.0, -4.0, """+"" - 3", + "+"); + PACKAGE P4 IS NEW GP1 (INTEGER, -4, 4, """-"" - 1", "-"); + + PACKAGE P5 IS NEW GP1 (FLOAT, 0.0, 0.0, """-"" - 2", "-"); + + PACKAGE P6 IS NEW GP1 (DURATION, 1.0, -1.0, """-"" - 3", + "-"); + PACKAGE P7 IS NEW GP2 (INTEGER, 6, 1, 5, """+"" - 1", "+"); + + PACKAGE P8 IS NEW GP2 (FLOAT, 6.0, 1.0, 5.0, """+"" - 2", + "+"); + PACKAGE P9 IS NEW GP2 (DURATION, 6.0, 1.0, 5.0, """+"" - 3", + "+"); + PACKAGE P10 IS NEW GP2 (INTEGER, 1, 6, 5, """-"" - 1", + "-" ); + PACKAGE P11 IS NEW GP2 (DURATION, 11.0, 6.0,-5.0, + """-"" - 2", "-"); + PACKAGE P12 IS NEW GP2 (FLOAT, 1.0, 6.0, 5.0, """-"" - 3", + "-"); + + SUBTYPE SUBINT IS INTEGER RANGE 0 .. 2; + TYPE STR IS ARRAY (SUBINT RANGE <>) OF CHARACTER; + VSTR : STR (0 .. 1) := "AB"; + + PACKAGE P13 IS NEW GP2 (STR, VSTR (0 .. 0) & + VSTR (1 .. 1), + VSTR (0 .. 0), + VSTR (1 .. 1), """&"" - 1", "&"); + + PACKAGE P14 IS NEW GP2 (STR, VSTR (1 .. 1) & + VSTR (0 .. 0), + VSTR (1 .. 1), + VSTR (0 .. 0), """&"" - 2", "&"); + + PACKAGE P15 IS NEW GP2 (INTEGER, 0, -1, 0, """*"" - 1", "*"); + + PACKAGE P16 IS NEW GP2 (FLOAT, 6.0, 3.0, 2.0, """*"" - 2", + "*"); + PACKAGE P17 IS NEW GP2 (INTEGER, 0, 0, 6, """/"" - 1", "/"); + + PACKAGE P18 IS NEW GP2 (FLOAT, 3.0, 6.0, 2.0, """/"" - 2", + "/"); + PACKAGE P19 IS NEW GP2 (INTEGER, -1, -11, 5, "REM", "REM"); + + PACKAGE P20 IS NEW GP2 (INTEGER, 4, -11, 5, "MOD", "MOD"); + + PACKAGE P21 IS NEW GP1 (INTEGER, 5, 5, """ABS"" - 1", "ABS"); + + PACKAGE P22 IS NEW GP1 (FLOAT, -5.0, 5.0, """ABS"" - 2", + "ABS"); + + PACKAGE P23 IS NEW GP1 (DURATION, 0.0, 0.0, """ABS"" - 3", + "ABS"); + + PACKAGE P24 IS NEW GP2 (INTEGER, 9, 3, 2, """**"" - 1", + "**"); + + PACKAGE P25 IS NEW GP2 (INTEGER, 1, 5, 0, """**"" - 2", + "**"); + + BEGIN + NULL; + END; + + DECLARE -- CHECKS WITH ATTRIBUTES. + + TYPE WEEKDAY IS (MON, TUES, WED, THUR, FRI); + + PACKAGE P1 IS NEW GP1 (WEEKDAY, TUES, WED, "WEEKDAY'SUCC", + WEEKDAY'SUCC); + + PACKAGE P2 IS NEW GP1 (WEEKDAY, TUES, MON, "WEEKDAY'PRED", + WEEKDAY'PRED); + + PACKAGE P3 IS NEW GP3 (WEEKDAY, STRING, THUR, "THUR", + "WEEKDAY'IMAGE", WEEKDAY'IMAGE); + + PACKAGE P4 IS NEW GP3 (STRING, WEEKDAY, "FRI", FRI, + "WEEKDAY'VALUE", WEEKDAY'VALUE); + BEGIN + NULL; + END; + + RESULT; + END CC3601A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3601c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- CC3601C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT "/=" MAY BE PASSED AS A GENERIC ACTUAL FUNCTION + -- PARAMETER. + + -- DAT 10/6/81 + -- SPS 10/27/82 + -- JRK 2/9/83 + + WITH REPORT; USE REPORT; + + PROCEDURE CC3601C IS + BEGIN + TEST ("CC3601C", "/= AS GENERIC ACTUAL PARAMETER"); + + DECLARE + PACKAGE PK IS + TYPE LP IS LIMITED PRIVATE; + FUNCTION "=" (X, Y : LP) RETURN BOOLEAN;-- RETURNS FALSE. + TYPE INT IS NEW INTEGER; + PRIVATE + TASK TYPE LP; + END PK; + USE PK; + + V1, V2 : LP; + + TYPE REC IS RECORD + C : LP; + END RECORD; + + R1, R2 : REC; + + TYPE INT IS NEW INTEGER; + + B1 : BOOLEAN := TRUE; + B2 : BOOLEAN := TRUE; + INTEGER_3 : INTEGER := 3; + INTEGER_4 : INTEGER := 4; + INT_3 : INT := 3; + INT_4 : INT := 4; + INT_5 : INT := 5; + PK_INT_M1 : PK.INT := -1; + PK_INT_M2 : PK.INT := -2; + PK_INT_1 : PK.INT := 1; + PK_INT_2 : PK.INT := 2; + PK_INT_3 : PK.INT := 3; + + FUNCTION "=" (Q, R : LP) RETURN BOOLEAN;-- RETURNS TRUE. + + GENERIC + TYPE T IS LIMITED PRIVATE; + V1, V2 : IN OUT T; + WITH FUNCTION NE (ZA : IN T; ZB : T) RETURN BOOLEAN; + VALUE : IN BOOLEAN; -- SHOULD BE VALUE OF NE(V1,V2). + STR : STRING; + PACKAGE GP IS END GP; + + FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN; + + FUNCTION NE (Q : INT; R : IN INT) RETURN BOOLEAN + RENAMES "/="; + + FUNCTION NE (Q : PK.INT; R : IN PK.INT) RETURN BOOLEAN + RENAMES "/="; + + PACKAGE BODY GP IS + BEGIN + IF IDENT_BOOL(VALUE) /= NE (V1, V2) THEN + FAILED ("WRONG /= ACTUAL GENERIC PARAMETER " + & STR); + END IF; + END GP; + + FUNCTION "=" (Q, R : IN REC) RETURN BOOLEAN IS + BEGIN + RETURN FALSE; + END "="; + + FUNCTION "=" (Q, R : LP) RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END "="; + + PACKAGE BODY PK IS + FUNCTION "=" (X, Y : LP) RETURN BOOLEAN IS + BEGIN + RETURN R1 = R1; -- FALSE. + END "="; + TASK BODY LP IS BEGIN NULL; END; + END PK; + + PACKAGE P1 IS NEW GP (LP, V1, V2, "/=", FALSE, "1"); + + FUNCTION "NOT" (X : BOOLEAN) RETURN BOOLEAN IS + BEGIN RETURN X; END "NOT"; -- ENSURES USE OF PREDEFINED "NOT" + + PACKAGE P2 IS NEW GP (LP, V1, V2, "/=", FALSE, "2"); + PACKAGE P3 IS NEW GP (LP, V1, V2, PK."/=", TRUE, "3"); + PACKAGE P4 IS NEW GP (PK.LP, V1, V2, "/=", FALSE, "4"); + PACKAGE P5 IS NEW GP (PK.LP, V1, V2, PK."/=", TRUE, "5"); + PACKAGE P6 IS NEW GP (REC, R1, R2, "/=", TRUE, "6"); + PACKAGE P7 IS NEW GP (INTEGER, INTEGER_3, INTEGER_4, "/=", + TRUE, "7"); + PACKAGE P8 IS NEW GP (BOOLEAN, B1, B2, "/=", FALSE,"8"); + PACKAGE P9 IS NEW GP (INT, INT_3, INT_5, "/=", TRUE, "9"); + PACKAGE P10 IS NEW GP (INT, INT_3, INT_3, "/=", FALSE, "10"); + PACKAGE P11 IS NEW GP (INT, INT_3, INT_4, NE, TRUE, "11"); + PACKAGE P12 IS NEW GP (INT, INT_3, INT_3, NE, FALSE, "12"); + PACKAGE P13 IS NEW GP (PK.INT, PK_INT_3, PK_INT_3, NE, + FALSE, "13"); + PACKAGE P14 IS NEW GP (PK.INT, PK_INT_M1, PK_INT_M2, NE, + TRUE, "14"); + PACKAGE P15 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, "/=", + FALSE, "15"); + PACKAGE P16 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, "/=", + TRUE, "16"); + PACKAGE P17 IS NEW GP (PK.INT, PK_INT_1, PK_INT_1, PK."/=", + FALSE, "17"); + PACKAGE P18 IS NEW GP (PK.INT, PK_INT_1, PK_INT_2, PK."/=", + TRUE, "18"); + BEGIN + NULL; + END; + + RESULT; + END CC3601C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3602a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- CC3602A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ENTRIES MAY BE PASSED AS GENERIC SUBPROGRAM + -- PARAMETERS. + + -- HISTORY: + -- DAT 9/25/81 CREATED ORIGINAL TEST. + -- LDC 10/6/88 REVISED; CHECKED THAT DEFAULT NAME CAN BE + -- IDENTIFIED WITH ENTRY. + + + WITH REPORT; USE REPORT; + + PROCEDURE CC3602A IS + COUNTER : INTEGER := 0; + BEGIN + TEST ("CC3602A", "ENTRIES AS GENERIC SUBPROGRAM PARAMETERS"); + + DECLARE + TASK TSK IS + ENTRY ENT; + END TSK; + + GENERIC + WITH PROCEDURE P; + PROCEDURE GP; + + GENERIC + WITH PROCEDURE P; + PACKAGE PK IS END PK; + + + PROCEDURE E1 RENAMES TSK.ENT; + + GENERIC + WITH PROCEDURE P IS TSK.ENT; + PROCEDURE GP_DEF1; + + GENERIC + WITH PROCEDURE P IS E1; + PROCEDURE GP_DEF2; + + GENERIC + WITH PROCEDURE P IS TSK.ENT; + PACKAGE PK_DEF1 IS END PK_DEF1; + + GENERIC + WITH PROCEDURE P IS E1; + PACKAGE PK_DEF2 IS END PK_DEF2; + + PROCEDURE GP IS + BEGIN + P; + END GP; + + PACKAGE BODY PK IS + BEGIN + P; + END PK; + + + PROCEDURE GP_DEF1 IS + BEGIN + P; + END GP_DEF1; + + PROCEDURE GP_DEF2 IS + BEGIN + P; + END GP_DEF2; + + PACKAGE BODY PK_DEF1 IS + BEGIN + P; + END PK_DEF1; + + PACKAGE BODY PK_DEF2 IS + BEGIN + P; + END PK_DEF2; + + TASK BODY TSK IS + BEGIN + LOOP + SELECT + ACCEPT ENT DO + COUNTER := COUNTER + 1; + END ENT; + OR + TERMINATE; + END SELECT; + END LOOP; + END TSK; + + BEGIN + DECLARE + PROCEDURE P1 IS NEW GP (TSK.ENT); + PROCEDURE E RENAMES TSK.ENT; + PROCEDURE P2 IS NEW GP (E); + PACKAGE PK1 IS NEW PK (TSK.ENT); + PACKAGE PK2 IS NEW PK (E); + + PROCEDURE P3 IS NEW GP_DEF1; + PROCEDURE P4 IS NEW GP_DEF2; + PACKAGE PK3 IS NEW PK_DEF1; + PACKAGE PK4 IS NEW PK_DEF2; + BEGIN + P1; + P2; + TSK.ENT; + E; + P3; + P4; + END; + TSK.ENT; + END; + + IF COUNTER /= 11 THEN + FAILED ("INCORRECT CALL OF ENTRY AS GENERIC PARAMETER"); + END IF; + + RESULT; + END CC3602A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3603a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- CC3603A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ENUMERATION LITERALS (BOTH IDENTIFIERS AND CHARACTER + -- LITERALS) MAY BE PASSED AS ACTUALS CORRESPONDING TO GENERIC + -- FORMAL SUBPROGRAMS. + + -- HISTORY: + -- RJW 06/11/86 CREATED ORIGINAL TEST. + -- VCL 08/18/87 CHANGED THE SECOND ACTUAL GENERIC PARAMETER IN THE + -- INSTANTIATION OF PROCEDURE NP3 TO + -- 'IDENT_CHAR('X')'. + + WITH REPORT; USE REPORT; + + PROCEDURE CC3603A IS + + BEGIN + TEST ("CC3603A", "CHECK THAT ENUMERATION LITERALS (BOTH " & + "IDENTIFIERS AND CHARACTER LITERALS) MAY " & + "BE PASSED AS ACTUALS CORRESPONDING TO " & + "GENERIC FORMAL SUBPROGRAMS" ); + + DECLARE + + TYPE ENUM1 IS ('A', 'B'); + TYPE ENUM2 IS (C, D); + + GENERIC + TYPE E IS (<>); + E1 : E; + WITH FUNCTION F RETURN E; + PROCEDURE P; + + PROCEDURE P IS + BEGIN + IF F /= E1 THEN + FAILED ( "WRONG VALUE FOR " & E'IMAGE (E1) & + " AS ACTUAL PARAMETER" ); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED INSIDE OF P WITH " & + E'IMAGE (E1) & + " AS ACTUAL PARAMETER" ); + END P; + + PROCEDURE NP1 IS NEW P (ENUM1, 'A', 'A'); + PROCEDURE NP2 IS NEW P (ENUM2, D, D); + PROCEDURE NP3 IS NEW P (CHARACTER, IDENT_CHAR('X'), 'X'); + BEGIN + BEGIN + NP1; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP1 CALLED" ); + END; + + BEGIN + NP2; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP2 CALLED" ); + END; + + BEGIN + NP3; + EXCEPTION + WHEN OTHERS => + FAILED ( "EXCEPTION RAISED WHEN NP3 CALLED" ); + END; + END; + RESULT; + + END CC3603A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3605a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,381 ---- + -- CC3605A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SOME DIFFERENCES BETWEEN THE FORMAL AND THE + -- ACTUAL SUBPROGRAMS DO NOT INVALIDATE A MATCH. + -- 1) CHECK DIFFERENT PARAMETER NAMES. + -- 2) CHECK DIFFERENT PARAMETER CONSTRAINTS. + -- 3) CHECK ONE PARAMETER CONSTRAINED AND THE OTHER + -- UNCONSTRAINED (WITH ARRAY, RECORD, ACCESS, AND + -- PRIVATE TYPES). + -- 4) CHECK PRESENCE OR ABSENCE OF AN EXPLICIT "IN" MODE + -- INDICATOR. + -- 5) DIFFERENT TYPE MARKS USED TO SPECIFY THE TYPE OF + -- PARAMETERS. + + -- HISTORY: + -- LDC 10/04/88 CREATED ORIGINAL TEST. + + PACKAGE CC3605A_PACK IS + + SUBTYPE INT IS INTEGER RANGE -100 .. 100; + + TYPE PRI_TYPE (SIZE : INT) IS PRIVATE; + + SUBTYPE PRI_CONST IS PRI_TYPE (2); + + PRIVATE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + TYPE PRI_TYPE (SIZE : INT) IS + RECORD + SUB_A : ARR_TYPE (1 .. SIZE); + END RECORD; + + END CC3605A_PACK; + + + WITH REPORT; + USE REPORT; + WITH CC3605A_PACK; + USE CC3605A_PACK; + + PROCEDURE CC3605A IS + + SUBTYPE ZERO_TO_TEN IS INTEGER + RANGE IDENT_INT (0) .. IDENT_INT (10); + + SUBTYPE ONE_TO_FIVE IS INTEGER + RANGE IDENT_INT (1) .. IDENT_INT (5); + + SUBPRG_ACT : BOOLEAN := FALSE; + BEGIN + TEST + ("CC3605A", "CHECK THAT SOME DIFFERENCES BETWEEN THE " & + "FORMAL AND THE ACTUAL PARAMETERS DO NOT " & + "INVALIDATE A MATCH"); + + ---------------------------------------------------------------------- + -- DIFFERENT PARAMETER NAMES + ---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (DIFF_NAME_PARM : ONE_TO_FIVE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ONE_TO_FIVE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (ONE_TO_FIVE'FIRST); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("DIFFERENT PARAMETER NAMES MADE MATCH INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- DIFFERENT PARAMETER CONSTRAINTS + ---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (PARM : ONE_TO_FIVE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ZERO_TO_TEN); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (ONE_TO_FIVE'FIRST); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("DIFFERENT PARAMETER CONSTRAINTS MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- ONE PARAMETER CONSTRAINED (ARRAY) + ---------------------------------------------------------------------- + + DECLARE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST .. + ONE_TO_FIVE'LAST); + + PASSED_PARM : ARR_CONST := (OTHERS => TRUE); + + PROCEDURE ACT_PROC (PARM : ARR_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ARR_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE ARRAY PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- ONE PARAMETER CONSTRAINED (RECORDS) + ---------------------------------------------------------------------- + + DECLARE + + TYPE REC_TYPE (BOL : BOOLEAN) IS + RECORD + SUB_A : INTEGER; + CASE BOL IS + WHEN TRUE => + DSCR_A : INTEGER; + + WHEN FALSE => + DSCR_B : BOOLEAN; + + END CASE; + END RECORD; + + SUBTYPE REC_CONST IS REC_TYPE (TRUE); + + PASSED_PARM : REC_CONST := (TRUE, 1, 2); + + PROCEDURE ACT_PROC (PARM : REC_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : REC_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE RECORD PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- ONE PARAMETER CONSTRAINED (ACCESS) + ---------------------------------------------------------------------- + + DECLARE + + TYPE ARR_TYPE IS ARRAY (INTEGER RANGE <>) OF BOOLEAN; + + SUBTYPE ARR_CONST IS ARR_TYPE (ONE_TO_FIVE'FIRST .. + ONE_TO_FIVE'LAST); + + TYPE ARR_ACC_TYPE IS ACCESS ARR_TYPE; + + SUBTYPE ARR_ACC_CONST IS ARR_ACC_TYPE (1 .. 3); + + PASSED_PARM : ARR_ACC_TYPE := NULL; + + PROCEDURE ACT_PROC (PARM : ARR_ACC_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : ARR_ACC_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE ACCESS PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- ONE PARAMETER CONSTRAINED (PRIVATE) + ---------------------------------------------------------------------- + + DECLARE + PASSED_PARM : PRI_CONST; + + PROCEDURE ACT_PROC (PARM : PRI_CONST) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : PRI_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (PASSED_PARM); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("ONE PRIVATE PARAMETER CONSTRAINED MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- PRESENCE (OR ABSENCE) OF AN EXPLICIT "IN" MODE + ---------------------------------------------------------------------- + + DECLARE + + PROCEDURE ACT_PROC (PARM : INTEGER) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM : IN INTEGER); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (1); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED + ("PRESENCE OF AN EXPLICIT 'IN' MODE MADE MATCH " & + "INVALID"); + END IF; + END; + + ---------------------------------------------------------------------- + -- DIFFERENT TYPE MARKS + ---------------------------------------------------------------------- + + DECLARE + + SUBTYPE MARK_1_TYPE IS INTEGER; + + SUBTYPE MARK_2_TYPE IS INTEGER; + + PROCEDURE ACT_PROC (PARM1 : IN MARK_1_TYPE) IS + BEGIN + SUBPRG_ACT := TRUE; + END ACT_PROC; + + GENERIC + + WITH PROCEDURE PASSED_PROC (PARM2 : MARK_2_TYPE); + + PROCEDURE GEN_PROC; + + PROCEDURE GEN_PROC IS + BEGIN + PASSED_PROC (1); + END GEN_PROC; + + PROCEDURE INST_PROC IS NEW GEN_PROC (ACT_PROC); + BEGIN + SUBPRG_ACT := FALSE; + INST_PROC; + IF NOT SUBPRG_ACT THEN + FAILED ("DIFFERENT TYPE MARKS MADE MATCH INVALID"); + END IF; + END; + RESULT; + END CC3605A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3606a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CC3606A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DEFAULT EXPRESSIONS OF A FORMAL SUBPROGRAM'S + -- FORMAL PARAMETERS ARE USED WHEN THE FORMAL SUBPROGRAM IS + -- CALLED IN THE INSTANTIATED UNIT (RATHER THAN ANY DEFAULT + -- ASSOCIATED WITH ACTUAL SUBPROGRAM'S PARAMETERS). + + -- HISTORY: + -- BCB 09/29/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CC3606A IS + + X : BOOLEAN; + Y : BOOLEAN; + + FUNCTION FUNC (A : INTEGER := 35) RETURN BOOLEAN IS + BEGIN + RETURN (A = 7); + END FUNC; + + PROCEDURE PROC (B : INTEGER := 35) IS + BEGIN + IF B /= 7 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "PROCEDURE NOT USED - 1"); + END IF; + END PROC; + + FUNCTION FUNC1 (C : INTEGER := 35) RETURN BOOLEAN IS + BEGIN + RETURN (C = 7); + END FUNC1; + + PROCEDURE PROC3 (D : INTEGER := 35) IS + BEGIN + IF D /= 7 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "PROCEDURE NOT USED - 2"); + END IF; + END PROC3; + + GENERIC + WITH FUNCTION FUNC (A : INTEGER := 7) RETURN BOOLEAN; + FUNCTION GENFUNC RETURN BOOLEAN; + + FUNCTION GENFUNC RETURN BOOLEAN IS + BEGIN + IF NOT FUNC THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "FUNCTION NOT USED - 1"); + END IF; + RETURN TRUE; + END GENFUNC; + + GENERIC + WITH PROCEDURE PROC (B : INTEGER := 7); + PACKAGE PKG IS + END PKG; + + PACKAGE BODY PKG IS + BEGIN + PROC; + END PKG; + + GENERIC + WITH FUNCTION FUNC1 (C : INTEGER := 7) RETURN BOOLEAN; + PROCEDURE PROC2; + + PROCEDURE PROC2 IS + BEGIN + IF NOT FUNC1 THEN + FAILED ("DEFAULT EXPRESSION OF FORMAL PARAMETER " & + "FUNCTION NOT USED - 2"); + END IF; + END PROC2; + + GENERIC + WITH PROCEDURE PROC3 (D : INTEGER := 7) IS <>; + FUNCTION GENFUNC1 RETURN BOOLEAN; + + FUNCTION GENFUNC1 RETURN BOOLEAN IS + BEGIN + PROC3; + RETURN TRUE; + END GENFUNC1; + + FUNCTION NEWFUNC IS NEW GENFUNC(FUNC); + + PACKAGE PACK IS NEW PKG(PROC); + + PROCEDURE PROC4 IS NEW PROC2(FUNC1); + + FUNCTION NEWFUNC1 IS NEW GENFUNC1; + + BEGIN + + TEST ("CC3606A", "CHECK THAT THE DEFAULT EXPRESSIONS OF A " & + "FORMAL SUBPROGRAM'S FORMAL PARAMETERS ARE " & + "USED WHEN THE FORMAL SUBPROGRAM IS CALLED IN " & + "THE INSTANTIATED UNIT (RATHER THAN ANY " & + "DEFAULT ASSOCIATED WITH ACTUAL SUBPROGRAM'S " & + "PARAMETERS)"); + + X := NEWFUNC; + Y := NEWFUNC1; + PROC4; + + RESULT; + END CC3606A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3606b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CC3606B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT ANY CONSTRAINTS SPECIFIED FOR THE ACTUAL + -- SUBPROGRAM'S PARAMETERS ARE USED IN PLACE OF THOSE + -- ASSOCIATED WITH THE FORMAL SUBPROGRAM'S PARAMETERS + -- (INCLUDING PARAMETERS SPECIFIED WITH A FORMAL GENERIC TYPE). + + -- HISTORY: + -- LDC 06/30/88 CREATED ORIGINAL TEST. + -- PWN 05/31/96 Corrected spelling problems. + + WITH REPORT; USE REPORT; + + PROCEDURE CC3606B IS + + SUBTYPE ONE_TO_TEN IS + INTEGER RANGE IDENT_INT (1) .. IDENT_INT (10); + SUBTYPE ONE_TO_FIVE IS + INTEGER RANGE IDENT_INT (1) .. IDENT_INT (5); + + BEGIN + TEST ( "CC3606B", "CHECK THAT ANY CONSTRAINTS SPECIFIED FOR " & + "THE ACTUAL SUBPROGRAM'S PARAMETERS ARE USED " & + "IN PLACE OF THOSE ASSOCIATED WITH THE " & + "FORMAL SUBPROGRAM'S PARAMETERS (INCLUDING " & + "PARAMETERS SPECIFIED WITH A FORMAL GENERIC " & + "TYPE)"); + DECLARE + GENERIC + BRIAN : IN OUT INTEGER; + WITH PROCEDURE PASSED_PROC(LYNN :IN OUT ONE_TO_TEN); + PACKAGE GEN IS + END GEN; + + DOUG : INTEGER := 10; + + PACKAGE BODY GEN IS + BEGIN + PASSED_PROC(BRIAN); + FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN GEN"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS RAISED FOR ACTUAL " & + "PARAMETER"); + END GEN; + + PROCEDURE PROC(JODIE : IN OUT ONE_TO_FIVE) IS + JOHN : ONE_TO_TEN; + BEGIN + JOHN := IDENT_INT(JODIE); + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + END PROC; + + PACKAGE GEN_PCK IS NEW GEN( DOUG, PROC); + + BEGIN + NULL; + END; + DECLARE + TYPE ENUM IS (DAYTON, BEAVERCREEK, CENTERVILLE, ENGLEWOOD, + FAIRBORN, HUBER_HEIGHTS, KETTERING, MIAMISBURG, + OAKWOOD, RIVERSIDE, TROTWOOD, WEST_CARROLLTON, + VANDALIA); + SUBTYPE SUB_ENUM IS ENUM RANGE CENTERVILLE..FAIRBORN; + + GENERIC + TYPE T_TYPE IS (<>); + BRIAN : T_TYPE; + WITH FUNCTION PASSED_FUNC(LYNN : T_TYPE) + RETURN T_TYPE; + + PACKAGE GEN_TWO IS + END GEN_TWO; + + DOUG : ENUM := ENUM'FIRST; + + PACKAGE BODY GEN_TWO IS + + DAVE : T_TYPE; + + BEGIN + DAVE := PASSED_FUNC(BRIAN); + FAILED("WRONG CONSTRAINTS FOR ACTUAL PARAMETER IN " & + "GEN_TWO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("OTHER EXCEPTION WAS " & + "RAISED FOR ACTUAL " & + "PARAMETER"); + END GEN_TWO; + + FUNCTION FUNC(JODIE : SUB_ENUM) RETURN SUB_ENUM IS + BEGIN + RETURN ENUM'VAL(IDENT_INT(ENUM'POS(JODIE))); + EXCEPTION + WHEN OTHERS => + FAILED("EXCEPTION RAISED INSIDE PROCEDURE"); + END FUNC; + + PACKAGE GEN_PCK_TWO IS NEW GEN_TWO( ENUM, DOUG, FUNC); + + BEGIN + RESULT; + END; + END CC3606B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc3607b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- CC3607B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A DEFAULT SUBPROGRAM IS SPECIFIED WITH A BOX, A + -- SUBPROGRAM DIRECTLY VISIBLE AT THE POINT OF INSTANTIATION + -- IS USED. + + -- HISTORY: + -- LDC 08/23/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CC3607B IS + + BEGIN + TEST ("CC3607B", "CHECK THAT WHEN A DEFAULT SUBPROGRAM IS " & + "SPECIFIED WITH A BOX, A SUBPROGRAM DIRECTLY " & + "VISIBLE AT THE POINT OF INSTANTIATION IS USED"); + DECLARE + PACKAGE PROC_PACK IS + PROCEDURE PROC; + + GENERIC + WITH PROCEDURE PROC IS <>; + PACKAGE GEN_PACK IS + PROCEDURE DO_PROC; + END GEN_PACK; + END PROC_PACK; + USE PROC_PACK; + + PACKAGE BODY PROC_PACK IS + PROCEDURE PROC IS + BEGIN + FAILED("WRONG SUBPROGRAM WAS USED"); + END PROC; + + PACKAGE BODY GEN_PACK IS + PROCEDURE DO_PROC IS + BEGIN + PROC; + END DO_PROC; + END GEN_PACK; + END PROC_PACK; + + PROCEDURE PROC IS + BEGIN + COMMENT ("SUBPROGRAM VISIBLE AT INSTANTIATION WAS " & + "USED"); + END PROC; + + PACKAGE NEW_PACK IS NEW GEN_PACK; + + BEGIN + NEW_PACK.DO_PROC; + END; + + RESULT; + END CC3607B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc40001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc40001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc40001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc40001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,403 ---- + -- CC40001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that adjust is called on the value of a constant object created + -- by the evaluation of a generic association for a formal object of + -- mode in. + -- + -- Check that those values are also subsequently finalized. + -- + -- TEST DESCRIPTION: + -- Create a backdrop of a controlled type sufficient to check that the + -- correct operations get called at appropriate times. Create a generic + -- unit that takes a formal parameter of a formal type. Create instances + -- of this generic using various "levels" of the controlled type. Check + -- the same case for a generic child unit. + -- + -- The cases tested are where the type of the formal object is: + -- a visible classwide type : CC40001_2 + -- a formal private type : CC40001_3 + -- a formal tagged type : CC40001_4 + -- + -- To more fully take advantage of the features of the language, and + -- present a test which is "user oriented" this test utilizes multiple + -- aspects of the language in combination. Using Ada.Strings.Unbounded + -- in combination with Ada.Finalization and Ada.Calendar to build layers + -- of an object oriented system will likely be very common in actual + -- practice. A common paradigm in the language will also be the use of + -- a parent package defining "basic" tagged types, and child packages + -- will expand on those types via derivation. The model used in this + -- test is a simple type containing a character identity (used in the + -- identity). The next level of type add a timestamp. Further levels + -- might add location information, etc. however for the purposes of this + -- test we stop at the second layer, as it is sufficient to test the + -- stated objective. + -- + -- + -- CHANGE HISTORY: + -- 06 FEB 96 SAIC Initial version + -- 30 APR 96 SAIC Added finalization checks for 2.1 + -- 13 FEB 97 PWB.CTA Moved global objects into bodies, after Initialize + -- body is elaborated; counted finalizations correctly. + --! + + ----------------------------------------------------------------- CC40001_0 + + with Ada.Finalization; + with Ada.Strings.Unbounded; + package CC40001_0 is + + type States is ( Erroneous, Defaulted, Initialized, Reset, Adjusted ); + + type Simple_Object(ID: Character) is + new Ada.Finalization.Controlled with + record + TC_Current_State : States := Defaulted; + Name : Ada.Strings.Unbounded.Unbounded_String; + end record; + + procedure User_Operation( COB: in out Simple_Object; Name : String ); + procedure Initialize( COB: in out Simple_Object ); + procedure Adjust ( COB: in out Simple_Object ); + procedure Finalize ( COB: in out Simple_Object ); + + Finalization_Count : Natural; + + end CC40001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body CC40001_0 is + + procedure User_Operation( COB: in out Simple_Object; Name : String ) is + begin + COB.Name := Ada.Strings.Unbounded.To_Unbounded_String(Name); + end User_Operation; + + procedure Initialize( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Initialized; + end Initialize; + + procedure Adjust ( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Adjusted; + TCTouch.Touch('A'); -------------------------------------------------- A + TCTouch.Touch(COB.ID); ------------------------------------------------ ID + -- note that the calls to touch will not be directly validated, it is + -- expected that some number > 0 of calls will be made to this procedure, + -- the subtests then clear (Flush) the Touch buffer and perform actions + -- where an incorrect implementation might call this procedure. Such a + -- call will fail on the attempt to "Validate" the null string. + end Adjust; + + procedure Finalize ( COB: in out Simple_Object ) is + begin + COB.TC_Current_State := Erroneous; + Finalization_Count := Finalization_Count +1; + end Finalize; + + TC_Global_Object : Simple_Object('G'); + + end CC40001_0; + + ----------------------------------------------------------------- CC40001_1 + + with Ada.Calendar; + package CC40001_0.CC40001_1 is + + type Object_In_Time(ID: Character) is + new Simple_Object(ID) with + record + Birth : Ada.Calendar.Time; + Activity : Ada.Calendar.Time; + end record; + + procedure User_Operation( COB: in out Object_In_Time; + Name: String ); + + procedure Initialize( COB: in out Object_In_Time ); + procedure Adjust ( COB: in out Object_In_Time ); + procedure Finalize ( COB: in out Object_In_Time ); + + end CC40001_0.CC40001_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body CC40001_0.CC40001_1 is + + procedure Initialize( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Initialized; + COB.Birth := Ada.Calendar.Clock; + end Initialize; + + procedure Adjust ( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Adjusted; + TCTouch.Touch('a'); ------------------------------------------------ a + TCTouch.Touch(COB.ID); ------------------------------------------------ ID + end Adjust; + + procedure Finalize ( COB: in out Object_In_Time ) is + begin + COB.TC_Current_State := Erroneous; + Finalization_Count := Finalization_Count +1; + end Finalize; + + procedure User_Operation( COB: in out Object_In_Time; + Name: String ) is + begin + CC40001_0.User_Operation( Simple_Object(COB), Name ); + COB.Activity := Ada.Calendar.Clock; + COB.TC_Current_State := Reset; + end User_Operation; + + TC_Time_Object : Object_In_Time('g'); + + end CC40001_0.CC40001_1; + + ----------------------------------------------------------------- CC40001_2 + + generic + TC_Check_Object : in CC40001_0.Simple_Object'Class; + package CC40001_0.CC40001_2 is + procedure TC_Verify_State; + end CC40001_0.CC40001_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CC40001_0.CC40001_2 is + + procedure TC_Verify_State is + begin + if TC_Check_Object.TC_Current_State /= Adjusted then + Report.Failed( "CC40001_2 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + + end CC40001_0.CC40001_2; + + ----------------------------------------------------------------- CC40001_3 + + generic + type Formal_Private(<>) is private; + TC_Check_Object : in Formal_Private; + with function Bad_Status( O: Formal_Private ) return Boolean; + package CC40001_0.CC40001_3 is + procedure TC_Verify_State; + end CC40001_0.CC40001_3; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CC40001_0.CC40001_3 is + + procedure TC_Verify_State is + begin + if Bad_Status( TC_Check_Object ) then + Report.Failed( "CC40001_3 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + + end CC40001_0.CC40001_3; + + ----------------------------------------------------------------- CC40001_4 + + generic + type Formal_Tagged_Private(<>) is tagged private; + TC_Check_Object : in Formal_Tagged_Private; + with function Bad_Status( O: Formal_Tagged_Private ) return Boolean; + package CC40001_0.CC40001_4 is + procedure TC_Verify_State; + end CC40001_0.CC40001_4; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CC40001_0.CC40001_4 is + + procedure TC_Verify_State is + begin + if Bad_Status( TC_Check_Object ) then + Report.Failed( "CC40001_4 : Formal Object not adjusted" ); + end if; + end TC_Verify_State; + + end CC40001_0.CC40001_4; + + ------------------------------------------------------------------- CC40001 + + with Report; + with TCTouch; + with CC40001_0.CC40001_1; + with CC40001_0.CC40001_2; + with CC40001_0.CC40001_3; + with CC40001_0.CC40001_4; + procedure CC40001 is + + function Not_Adjusted( CO : CC40001_0.Simple_Object ) + return Boolean is + use type CC40001_0.States; + begin + return CO.TC_Current_State /= CC40001_0.Adjusted; + end Not_Adjusted; + + function Not_Adjusted( CO : CC40001_0.CC40001_1.Object_In_Time ) + return Boolean is + use type CC40001_0.States; + begin + return CO.TC_Current_State /= CC40001_0.Adjusted; + end Not_Adjusted; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 1 + + procedure Subtest_1 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_1_1 is + new CC40001_0.CC40001_2( Object_0 ); -- classwide generic formal object + + package Subtest_1_2 is + new CC40001_0.CC40001_2( Object_1 ); -- classwide generic formal object + begin + TCTouch.Flush; -- clear out all "A" and "T" entries, no further calls + -- to Touch should occur before the call to Validate + + -- set the objects TC_Current_State to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 1" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 1" ); + + -- check that the objects TC_Current_State is "Adjusted" + Subtest_1_1.TC_Verify_State; + Subtest_1_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 1" ); + + end Subtest_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 2 + + procedure Subtest_2 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_2_1 is -- generic formal object is discriminated private + new CC40001_0.CC40001_3( CC40001_0.Simple_Object, + Object_0, + Not_Adjusted ); + + package Subtest_2_2 is -- generic formal object is discriminated private + new CC40001_0.CC40001_3( CC40001_0.CC40001_1.Object_In_Time, + Object_1, + Not_Adjusted ); + + begin + TCTouch.Flush; -- clear out all "A" and "T" entries + + -- set the objects state to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 2" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 2" ); + + Subtest_2_1.TC_Verify_State; + Subtest_2_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 2" ); + + end Subtest_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- Subtest 3 + + procedure Subtest_3 is + Object_0 : CC40001_0.Simple_Object('T'); + Object_1 : CC40001_0.CC40001_1.Object_In_Time('t'); + + package Subtest_3_1 is -- generic formal object is discriminated tagged + new CC40001_0.CC40001_4( CC40001_0.Simple_Object, + Object_0, + Not_Adjusted ); + + package Subtest_3_2 is -- generic formal object is discriminated tagged + new CC40001_0.CC40001_4( CC40001_0.CC40001_1.Object_In_Time, + Object_1, + Not_Adjusted ); + begin + TCTouch.Flush; -- clear out all "A" and "T" entries + + -- set the objects state to "Reset" + CC40001_0.User_Operation( Object_0, "Subtest 3" ); + CC40001_0.CC40001_1.User_Operation( Object_1, "Subtest 3" ); + + Subtest_3_1.TC_Verify_State; + Subtest_3_2.TC_Verify_State; + + TCTouch.Validate( "", "No actions should occur here, subtest 3" ); + + end Subtest_3; + + begin -- Main test procedure. + + Report.Test ("CC40001", "Check that adjust and finalize are called on " & + "the constant object created by the " & + "evaluation of a generic association for a " & + "formal object of mode in" ); + + -- check that the created constant objects are properly adjusted + -- and subsequently finalized + + CC40001_0.Finalization_Count := 0; + + Subtest_1; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 1"); + end if; + + CC40001_0.Finalization_Count := 0; + + Subtest_2; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 2"); + end if; + + CC40001_0.Finalization_Count := 0; + + Subtest_3; + + if CC40001_0.Finalization_Count < 4 then + Report.Failed("Insufficient Finalizations for Subtest 3"); + end if; + + Report.Result; + + end CC40001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- CC50001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in an instance, each implicit declaration of a predefined + -- operator of a formal tagged private type declares a view of the + -- corresponding predefined operator of the actual type (even if the + -- operator has been overridden for the actual type). Check that the + -- body executed is determined by the type and tag of the operands. + -- + -- TEST DESCRIPTION: + -- The formal tagged private type has an unknown discriminant part, and + -- is thus indefinite. This allows both definite and indefinite types + -- to be passed as actuals. For tagged types, definite implies + -- nondiscriminated, and indefinite implies discriminated (with known + -- or unknown discriminants). + -- + -- Only nonlimited tagged types are tested, since equality operators + -- are not predefined for limited types. + -- + -- A tagged type is passed as an actual to a generic formal tagged + -- private type. The tagged type overrides the predefined equality + -- operator. A subprogram within the generic calls the equality operator + -- of the formal type. In an instance, the equality operator denotes + -- a view of the predefined operator of the actual type, but the + -- call dispatches to the body of the overriding operator. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected expected result on + -- calls to "=" within the instance. Modified + -- commentary. + -- + --! + + package CC50001_0 is + + type Count_Type is tagged record -- Nondiscriminated + Count : Integer := 0; -- tagged type. + end record; + + function "="(Left, Right : Count_Type) -- User-defined + return Boolean; -- equality operator. + + + subtype Str_Len is Natural range 0 .. 100; + subtype Stu_ID is String (1 .. 5); + subtype Dept_ID is String (1 .. 4); + subtype Emp_ID is String (1 .. 9); + type Status is (Student, Faculty, Staff); + + type Person_Type (Stat : Status; -- Discriminated + NameLen, AddrLen : Str_Len) is -- tagged type. + tagged record + Name : String (1 .. NameLen); + Address : String (1 .. AddrLen); + case Stat is + when Student => + Student_ID : Stu_ID; + when Faculty => + Department : Dept_ID; + when Staff => + Employee_ID : Emp_ID; + end case; + end record; + + function "="(Left, Right : Person_Type) -- User-defined + return Boolean; -- equality operator. + + + -- Testing entities: ------------------------------------------------ + + TC_Count_Item : constant Count_Type := (Count => 111); + + TC_Person_Item : constant Person_Type := + (Faculty, 18, 17, "Eccles, John Scott", "Popham House, Lee", "0931"); + + --------------------------------------------------------------------- + + + end CC50001_0; + + + --===================================================================-- + + + package body CC50001_0 is + + function "="(Left, Right : Count_Type) return Boolean is + begin + return False; -- Return FALSE even if Left = Right. + end "="; + + + function "="(Left, Right : Person_Type) return Boolean is + begin + return False; -- Return FALSE even if Left = Right. + end "="; + + end CC50001_0; + + + --===================================================================-- + + + with CC50001_0; -- Tagged (actual) type declarations. + generic -- Generic stack abstraction. + + type Item (<>) is tagged private; -- Formal tagged private type. + + package CC50001_1 is + + -- Simulate a generic stack abstraction. In a real application, the + -- second operand of Push might be of type Stack, and type Stack + -- would have at least one component (pointing to the top stack item). + + type Stack is private; + + procedure Push (I : in Item; TC_Check : out Boolean); + + -- ... Other stack operations. + + private + + -- ... Stack and ancillary type declarations. + + type Stack is record -- Artificial. + null; + end record; + + end CC50001_1; + + + --===================================================================-- + + + package body CC50001_1 is + + -- For the sake of brevity, the implementation of Push is completely + -- artificial; the goal is to model a call of the equality operator within + -- the generic. + -- + -- A real application might implement Push such that it does not add new + -- items to the stack if they are identical to the top item; in that + -- case, the equality operator would be called as part of an "if" + -- condition. + + procedure Push (I : in Item; TC_Check : out Boolean) is + begin + TC_Check := not (I = I); -- Call user-defined "="; should + -- return FALSE. Negation of + -- result makes TC_Check TRUE. + end Push; + + end CC50001_1; + + + --==================================================================-- + + + with CC50001_0; -- Tagged (actual) type declarations. + with CC50001_1; -- Generic stack abstraction. + + use CC50001_0; -- Overloaded "=" directly visible. + + with Report; + procedure CC50001 is + + package Count_Stacks is new CC50001_1 (CC50001_0.Count_Type); + package Person_Stacks is new CC50001_1 (CC50001_0.Person_Type); + + User_Defined_Op_Called : Boolean; + + begin + Report.Test ("CC50001", "Check that, in an instance, each implicit " & + "declaration of a primitive subprogram of a formal tagged " & + "private type declares a view of the corresponding " & + "predefined operator of the actual type (even if the " & + "operator has been overridden or hidden for the actual type)"); + + -- + -- Test which "=" is called inside generic: + -- + + User_Defined_Op_Called := False; + + Count_Stacks.Push (CC50001_0.TC_Count_Item, + User_Defined_Op_Called); + + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called inside generic for Count"); + end if; + + + User_Defined_Op_Called := False; + + Person_Stacks.Push (CC50001_0.TC_Person_Item, + User_Defined_Op_Called); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called inside generic " & + "for Person"); + end if; + + + -- + -- Test which "=" is called outside generic: + -- + + User_Defined_Op_Called := False; + + User_Defined_Op_Called := + not (CC50001_0.TC_Count_Item = CC50001_0.TC_Count_Item); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called outside generic "& + "for Count"); + end if; + + + User_Defined_Op_Called := False; + + User_Defined_Op_Called := + not (CC50001_0.TC_Person_Item = CC50001_0.TC_Person_Item); + + if not User_Defined_Op_Called then + Report.Failed ("User-defined ""="" not called outside generic "& + "for Person"); + end if; + + + Report.Result; + end CC50001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,313 ---- + -- CC50A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a formal parameter of a library-level generic unit may be + -- a formal tagged private type. Check that a nonlimited tagged type may + -- be passed as an actual. Check that if the formal type is indefinite, + -- both indefinite and definite types may be passed as actuals. + -- + -- TEST DESCRIPTION: + -- The generic package declares a formal tagged private type (this can + -- be considered the parent "mixin" class). This type is extended in + -- the generic to provide support for stacks of items of any nonlimited + -- tagged type. Stacks are modeled as singly linked lists, with the list + -- nodes being objects of the extended type. + -- + -- A generic testing procedure pushes items onto a stack, and pops them + -- back off, verifying the state of the stack at various points along the + -- way. The push and pop routines exercise functionality important to + -- tagged types, such as type conversion toward the root of the derivation + -- class and extension aggregates. + -- + -- The formal tagged private type has an unknown discriminant part, and + -- is thus indefinite. This allows both definite and indefinite types + -- to be passed as actuals. For tagged types, definite implies + -- nondiscriminated, and indefinite implies discriminated (with known + -- or unknown discriminants). + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FC50A00.A + -- -> CC50A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiations of + -- BC50A01_0 to library level. + -- 11 Aug 96 SAIC ACVC 2.1: Updated prologue. Added pragma + -- Elaborate to context clauses for CC50A01_2 & _3. + -- + --! + + with FC50A00; -- Tagged (actual) type declarations. + generic -- Generic stack abstraction. + + type Item (<>) is tagged private; -- Formal tagged private type. + TC_Default_Value : Item; -- Needed in View_Top (see + -- below). + package CC50A01_0 is + + type Stack is private; + + -- Note that because the actual type corresponding to Item may be + -- unconstrained, the functions of removing the top item from the stack and + -- returning the value of the top item of the stack have been separated into + -- Pop and View_Top, respectively. This is necessary because otherwise the + -- returned value would have to be an out parameter of Pop, which would + -- require the user (in the unconstrained case) to create an uninitialized + -- unconstrained object to serve as the actual, which is illegal. + + procedure Push (I : in Item; S : in out Stack); + procedure Pop (S : in out Stack); + function View_Top (S : Stack) return Item; + + function Size_Of (S : Stack) return Natural; + + private + + type Stack_Item; + type Stack_Ptr is access Stack_Item; + + type Stack_Item is new Item with record -- Extends formal type. + Next : Stack_Ptr := null; + end record; + + type Stack is record + Top : Stack_Ptr := null; + Size : Natural := 0; + end record; + + end CC50A01_0; + + + --==================================================================-- + + + package body CC50A01_0 is + + -- Link NewItem in at the top of the stack (the extension aggregate within + -- the allocator initializes the inherited portion of NewItem to equal I, + -- and NewItem.Next to point to what S.Top points to). + + procedure Push (I : in Item; S : in out Stack) is + NewItem : Stack_Ptr; + begin + NewItem := new Stack_Item'(I with S.Top); -- Extension aggregate. + S.Top := NewItem; + S.Size := S.Size + 1; + end Push; + + + -- Remove item from top of stack. This procedure only updates the state of + -- the stack; it does not return the value of the popped item. Hence, in + -- order to accomplish a "true" pop, both View_Top and Pop must be called + -- consecutively. + -- + -- If the stack is empty, the Pop is ignored (for simplicity; in a true + -- application this might be treated as an error condition). + + procedure Pop (S : in out Stack) is + begin + if S.Top = null then -- Stack is empty. + null; + -- Raise exception. + else + S.Top := S.Top.Next; + S.Size := S.Size - 1; + -- Deallocate discarded node. + end if; + end Pop; + + + -- Return the value of the top item on the stack. This procedure only + -- returns the value; it does not remove the top item from the stack. + -- Hence, in order to accomplish a "true" pop, both View_Top and Pop must + -- be called consecutively. + -- + -- Since items on the stack are of a type (Stack_Item) derived from Item, + -- which is a (tagged) private type, type conversion toward the root is the + -- only way to get a value of type Item for return to the caller. + -- + -- If the stack is empty, View_Top returns a pre-specified default value. + -- (In a true application, an exception might be raised instead). + + function View_Top (S : Stack) return Item is + begin + if S.Top = null then -- Stack is empty. + return TC_Default_Value; -- Testing artifice. + -- Raise exception. + else + return Item(S.Top.all); -- Type conversion. + end if; + end View_Top; + + + function Size_Of (S : Stack) return Natural is + begin + return (S.Size); + end Size_Of; + + + end CC50A01_0; + + + --==================================================================-- + + + -- The formal package Stacker below is needed to gain access to the + -- appropriate version of the "generic" type Stack. It is provided with an + -- explicit actual part in order to restrict the packages that can be passed + -- as actuals to those which have been instantiated with the same actuals + -- which this generic procedure has been instantiated with. + + with CC50A01_0; -- Generic stack abstraction. + generic + type Item_Type (<>) is tagged private; -- Formal tagged private type. + Default : Item_Type; + with package Stacker is new CC50A01_0 (Item_Type, Default); + procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type); + + + --==================================================================-- + + -- + -- This generic procedure performs all of the testing of the + -- stack abstraction. + -- + + with Report; + procedure CC50A01_1 (S : in out Stacker.Stack; I : in Item_Type) is + begin + Stacker.Push (I, S); -- Push onto empty stack. + Stacker.Push (I, S); -- Push onto nonempty stack. + + if Stacker.Size_Of (S) /= 2 then + Report.Failed (" Wrong stack size after 2 Pushes"); + end if; + + -- Calls to View_Top must initialize a declared object of type Item_Type + -- because the type may be unconstrained. + + declare + Buffer1 : Item_Type := Stacker.View_Top (S); + begin + Stacker.Pop (S); -- Pop item off nonempty stack. + if Buffer1 /= I then + Report.Failed (" Wrong stack item value after 1st Pop"); + end if; + end; + + declare + Buffer2 : Item_Type := Stacker.View_Top (S); + begin + Stacker.Pop (S); -- Pop last item off stack. + if Buffer2 /= I then + Report.Failed (" Wrong stack item value after 2nd Pop"); + end if; + end; + + if Stacker.Size_Of (S) /= 0 then + Report.Failed (" Wrong stack size after 2 Pops"); + end if; + + declare + Buffer3 : Item_Type := Stacker.View_Top (S); + begin + if Buffer3 /= Default then + Report.Failed (" Wrong result after Pop of empty stack"); + end if; + Stacker.Pop (S); -- Pop off empty stack. + end; + + end CC50A01_1; + + + --==================================================================-- + + + with FC50A00; + + with CC50A01_0; + pragma Elaborate (CC50A01_0); + + package CC50A01_2 is new CC50A01_0 (FC50A00.Count_Type, + FC50A00.TC_Default_Count); + + + --==================================================================-- + + + with FC50A00; + + with CC50A01_0; + pragma Elaborate (CC50A01_0); + + package CC50A01_3 is new CC50A01_0 (FC50A00.Person_Type, + FC50A00.TC_Default_Person); + + + --==================================================================-- + + + with FC50A00; -- Tagged (actual) type declarations. + with CC50A01_0; -- Generic stack abstraction. + with CC50A01_1; -- Generic stack testing procedure. + with CC50A01_2; + with CC50A01_3; + + with Report; + procedure CC50A01 is + + package Count_Stacks renames CC50A01_2; + package Person_Stacks renames CC50A01_3; + + + procedure TC_Count_Test is new CC50A01_1 (FC50A00.Count_Type, + FC50A00.TC_Default_Count, + Count_Stacks); + Count_Stack : Count_Stacks.Stack; + + + procedure TC_Person_Test is new CC50A01_1 (FC50A00.Person_Type, + FC50A00.TC_Default_Person, + Person_Stacks); + Person_Stack : Person_Stacks.Stack; + + begin + Report.Test ("CC50A01", "Check that a formal parameter of a " & + "library-level generic unit may be a formal tagged " & + "private type"); + + Report.Comment ("Testing definite tagged type.."); + TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item); + + Report.Comment ("Testing indefinite tagged type.."); + TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item); + + Report.Result; + end CC50A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc50a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc50a02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,227 ---- + -- CC50A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a nonlimited tagged type may be passed as an actual to a + -- formal (non-tagged) private type. Check that if the formal type has + -- an unknown discriminant part, a class-wide type may also be passed as + -- an actual. + -- + -- TEST DESCRIPTION: + -- A generic package declares a formal private type and defines a + -- stack abstraction. Stacks are modeled as singly linked lists of + -- pointers to elements. Pointers are used because the elements may + -- be unconstrained. + -- + -- A generic testing procedure pushes an item onto a stack, then views + -- the item on top of the stack. + -- + -- The formal private type has an unknown discriminant part, and + -- is thus indefinite. This allows both definite and indefinite types + -- (including class-wide types) to be passed as actuals. For tagged types, + -- definite implies nondiscriminated, and indefinite implies discriminated + -- (with known/unknown discriminants). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC50A00.A + -- -> CC50A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Nov 95 SAIC ACVC 2.0.1 fixes: Removed use of formal package + -- exception name in exception choice. + -- + --! + + generic -- Generic stack abstraction. + type Item (<>) is private; -- Formal private type. + package CC50A02_0 is + + type Stack is private; + + procedure Push (I : in Item; S : in out Stack); + function View_Top (S : Stack) return Item; + + -- ...Other stack operations... + + Stack_Empty : exception; + + private + + type Item_Ptr is access Item; + + type Stack_Item; + type Stack_Ptr is access Stack_Item; + + type Stack_Item is record + Item : Item_Ptr; + Next : Stack_Ptr; + end record; + + type Stack is record + Top : Stack_Ptr := null; + Size : Natural := 0; + end record; + + end CC50A02_0; + + + --==================================================================-- + + + package body CC50A02_0 is + + -- Link NewItem in at the top of the stack. + + procedure Push (I : in Item; S : in out Stack) is + NewItem : Item_Ptr := new Item'(I); + Element : Stack_Ptr := new Stack_Item'(Item => NewItem, Next => S.Top); + begin + S.Top := Element; + S.Size := S.Size + 1; + end Push; + + + -- Return (copy) of top item on stack. Do NOT remove from stack. + + function View_Top (S : Stack) return Item is + begin + if S.Top = null then + raise Stack_Empty; + else + return S.Top.Item.all; + end if; + end View_Top; + + end CC50A02_0; + + + --==================================================================-- + + + -- The formal package Stacker below is needed to gain access to the + -- appropriate version of the "generic" type Stack. It is provided with an + -- explicit actual part in order to restrict the packages that can be passed + -- as actuals to those which have been instantiated with the same actuals + -- which this generic procedure has been instantiated with. + + with CC50A02_0; -- Generic stack abstraction. + generic + type Item_Type (<>) is private; -- Formal private type. + with package Stacker is new CC50A02_0 (Item_Type); + procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type); + + + --==================================================================-- + + -- + -- This generic procedure performs all of the testing of the + -- stack abstraction. + -- + + with Report; + procedure CC50A02_1 (S : in out Stacker.Stack; I : in Item_Type) is + begin + Stacker.Push (I, S); -- Push onto empty stack. + + -- Calls to View_Top must initialize a declared object of type Item_Type + -- because the type may be unconstrained. + + declare + Buffer : Item_Type := Stacker.View_Top (S); + begin + if Buffer /= I then + Report.Failed (" Expected item not on stack"); + end if; + exception + when Constraint_Error => + Report.Failed (" Unexpected error: Tags of pushed and popped " & + "items don't match"); + end; + + + exception + when others => + Report.Failed (" Unexpected error: Item not pushed onto stack"); + end CC50A02_1; + + + --==================================================================-- + + + with FC50A00; -- Tagged (actual) type declarations. + with CC50A02_0; -- Generic stack abstraction. + with CC50A02_1; -- Generic stack testing procedure. + + with Report; + procedure CC50A02 is + + -- + -- Pass a nondiscriminated tagged actual: + -- + + package Count_Stacks is new CC50A02_0 (FC50A00.Count_Type); + procedure TC_Count_Test is new CC50A02_1 (FC50A00.Count_Type, + Count_Stacks); + Count_Stack : Count_Stacks.Stack; + + + -- + -- Pass a discriminated tagged actual: + -- + + package Person_Stacks is new CC50A02_0 (FC50A00.Person_Type); + procedure TC_Person_Test is new CC50A02_1 (FC50A00.Person_Type, + Person_Stacks); + Person_Stack : Person_Stacks.Stack; + + + -- + -- Pass a class-wide actual: + -- + + package People_Stacks is new CC50A02_0 (FC50A00.Person_Type'Class); + procedure TC_People_Test is new CC50A02_1 (FC50A00.Person_Type'Class, + People_Stacks); + People_Stack : People_Stacks.Stack; + + begin + Report.Test ("CC50A02", "Check that tagged actuals may be passed " & + "to a formal (nontagged) private type"); + + Report.Comment ("Testing definite tagged type.."); + TC_Count_Test (Count_Stack, FC50A00.TC_Count_Item); + + Report.Comment ("Testing indefinite tagged type.."); + TC_Person_Test (Person_Stack, FC50A00.TC_Person_Item); + + Report.Comment ("Testing class-wide type.."); + TC_People_Test (People_Stack, FC50A00.TC_VIPerson_Item); + + Report.Result; + end CC50A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,186 ---- + -- CC51001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a formal parameter of a generic package may be a formal + -- derived type. Check that the formal derived type may have an unknown + -- discriminant part. Check that the ancestor type in a formal derived + -- type definition may be a tagged type, and that the actual parameter + -- may be a descendant of the ancestor type. Check that the formal derived + -- type belongs to the derivation class rooted at the ancestor type; + -- specifically, that components of the ancestor type may be referenced + -- within the generic. Check that if a formal derived subtype is + -- indefinite then the actual may be either definite or indefinite. + -- + -- TEST DESCRIPTION: + -- Define a class of tagged types with a definite root type. Extend the + -- root type with a discriminated component. Since discriminants of + -- tagged types may not have defaults, the type is indefinite. + -- + -- Extend the extension with a second discriminated component, but with + -- a new discriminant part. Declare a generic package with a formal + -- derived type using the root type of the class as ancestor, and an + -- unknown discriminant part. Declare an operation in the generic which + -- accesses the common component of types in the class. + -- + -- In the main program, instantiate the generic with each type in the + -- class and verify that the operation correctly accesses the common + -- component. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CC51001_0 is -- Root type for message class. + + subtype Msg_String is String (1 .. 20); + + type Msg_Type is tagged record -- Root type of + Text : Msg_String := (others => ' '); -- class (definite). + end record; + + end CC51001_0; + + + -- No body for CC51001_0. + + + --==================================================================-- + + + with CC51001_0; -- Root type for message class. + package CC51001_1 is -- Extensions to message class. + + subtype Source_Length is Natural range 0 .. 10; + + type From_Msg_Type (SLen : Source_Length) is -- Direct derivative + new CC51001_0.Msg_Type with record -- of root type + From : String (1 .. SLen); -- (indefinite). + end record; + + subtype Dest_Length is Natural range 0 .. 10; + + + + type To_From_Msg_Type (DLen : Dest_Length) is -- Indirect + new From_Msg_Type (SLen => 10) with record -- derivative of + To : String (1 .. DLen); -- root type + end record; -- (indefinite). + + end CC51001_1; + + + -- No body for CC51001_1. + + + --==================================================================-- + + + with CC51001_0; -- Root type for message class. + generic -- I/O operations for message class. + type Message_Type (<>) is new CC51001_0.Msg_Type with private; + package CC51001_2 is + + -- This subprogram contains an artificial result for testing purposes: + -- the function returns the text of the message to the caller as a string. + + function Print_Message (M : in Message_Type) return String; + + -- ... Other operations. + + end CC51001_2; + + + --==================================================================-- + + + package body CC51001_2 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Print_Message (M : in Message_Type) return String is + begin + return M.Text; + end Print_Message; + + end CC51001_2; + + + --==================================================================-- + + + with CC51001_0; -- Root type for message class. + with CC51001_1; -- Extensions to message class. + with CC51001_2; -- I/O operations for message class. + + with Report; + procedure CC51001 is + + -- Instantiate for various types in the class: + + package Msgs is new CC51001_2 (CC51001_0.Msg_Type); -- Definite. + package FMsgs is new CC51001_2 (CC51001_1.From_Msg_Type); -- Indefinite. + package TFMsgs is new CC51001_2 (CC51001_1.To_From_Msg_Type); -- Indefinite. + + + + Msg : CC51001_0.Msg_Type := (Text => "This is message #001"); + FMsg : CC51001_1.From_Msg_Type := (Text => "This is message #002", + SLen => 2, + From => "Me"); + TFMsg : CC51001_1.To_From_Msg_Type := (Text => "This is message #003", + From => "You ", + DLen => 4, + To => "Them"); + + Expected_Msg : constant String := "This is message #001"; + Expected_FMsg : constant String := "This is message #002"; + Expected_TFMsg : constant String := "This is message #003"; + + begin + Report.Test ("CC51001", "Check that the formal derived type may have " & + "an unknown discriminant part. Check that the ancestor " & + "type in a formal derived type definition may be a " & + "tagged type, and that the actual parameter may be any " & + "definite or indefinite descendant of the ancestor type"); + + if (Msgs.Print_Message (Msg) /= Expected_Msg) then + Report.Failed ("Wrong result for definite root type"); + end if; + + if (FMsgs.Print_Message (FMsg) /= Expected_FMsg) then + Report.Failed ("Wrong result for direct indefinite derivative"); + end if; + + if (TFMsgs.Print_Message (TFMsg) /= Expected_TFMsg) then + Report.Failed ("Wrong result for Indirect indefinite derivative"); + end if; + + Report.Result; + end CC51001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- CC51002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for formal derived tagged types, the formal parameter + -- names and default expressions for a primitive subprogram in an + -- instance are determined by the primitive subprogram of the ancestor + -- type, but that the primitive subprogram body executed is that of the + -- actual type. + -- + -- TEST DESCRIPTION: + -- Define a root tagged type in a library-level package and give it a + -- primitive subprogram. Provide a default expression for a non-tagged + -- parameter of the subprogram. Declare a library-level generic subprogram + -- with a formal derived type using the root type as ancestor. Call + -- the primitive subprogram of the root type using named association for + -- the tagged parameter, and provide no actual for the defaulted + -- parameter. Extend the root type in a second package and override the + -- root type's subprogram with one which has different parameter names + -- and no default expression for the non-tagged parameter. Instantiate + -- the generic subprogram for each of the tagged types in the class and + -- call the instances. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CC51002_0 is -- Root message type and operations. + + type Recipients is (None, Root, Sysop, Local, Remote); + + type Msg_Type is tagged record -- Root type of + Text : String (1 .. 10); -- class. + end record; + + function Send (Msg : in Msg_Type; -- Primitive + To : Recipients := Local) return Boolean; -- subprogram. + + -- ...Other message operations. + + end CC51002_0; + + + --==================================================================-- + + + package body CC51002_0 is + + -- The implementation of Send is purely artificial; the validity of + -- its implementation in the context of the abstraction is irrelevant to + -- the feature being tested. + + function Send (Msg : in Msg_Type; + To : Recipients := Local) return Boolean is + begin + return (Msg.Text = "Greetings!" and To = Local); + end Send; + + end CC51002_0; + + + --==================================================================-- + + + with CC51002_0; -- Root message type and operations. + generic -- Message class function. + type Msg_Block is new CC51002_0.Msg_Type with private; + function CC51002_1 (M : in Msg_Block) return Boolean; + + + --==================================================================-- + + + function CC51002_1 (M : in Msg_Block) return Boolean is + Okay : Boolean := False; + begin + + -- The call to Send below uses the ancestor type's parameter name, which + -- should be legal even if the actual subprogram called does not have a + -- parameter of that name. Furthermore, it uses the ancestor type's default + -- expression for the second parameter, which should be legal even if the + -- the actual subprogram called has no such default expression. + + Okay := Send (Msg => M); + -- ...Other processing. + return Okay; + + end CC51002_1; + + + --==================================================================-- + + + with CC51002_0; -- Root message type and operations. + package CC51002_2 is -- Extended message type and operations. + + type Sender_Type is (Inside, Outside); + + type Who_Msg_Type is new CC51002_0.Msg_Type with record -- Derivative of + From : Sender_Type; -- root type of + end record; -- class. + + + -- Note: this overriding version of Send has different parameter names + -- from the root type's function. It also has no default expression. + + function Send (M : Who_Msg_Type; -- Overrides + R : CC51002_0.Recipients) return Boolean; -- root type's + -- operation. + -- ...Other extended message operations. + + end CC51002_2; + + + --==================================================================-- + + + package body CC51002_2 is + + -- The implementation of Send is purely artificial; the validity of + -- its implementation in the context of the abstraction is irrelevant to + -- the feature being tested. + + function Send (M : Who_Msg_Type; R : CC51002_0.Recipients) return Boolean is + use type CC51002_0.Recipients; + begin + return (M.Text = "Willkommen" and + M.From = Outside and + R = CC51002_0.Local); + end Send; + + end CC51002_2; + + + --==================================================================-- + + + with CC51002_0; -- Root message type and operations. + with CC51002_1; -- Message class function. + with CC51002_2; -- Extended message type and operations. + + with Report; + procedure CC51002 is + + function Send_Msg is new CC51002_1 (CC51002_0.Msg_Type); + function Send_WMsg is new CC51002_1 (CC51002_2.Who_Msg_Type); + + Mess : CC51002_0.Msg_Type := (Text => "Greetings!"); + WMess : CC51002_2.Who_Msg_Type := (Text => "Willkommen", + From => CC51002_2.Outside); + + TC_Okay_MStatus : Boolean := False; + TC_Okay_WMStatus : Boolean := False; + + begin + Report.Test ("CC51002", "Check that, for formal derived tagged types, " & + "the formal parameter names and default expressions for " & + "a primitive subprogram in an instance are determined by " & + "the primitive subprogram of the ancestor type, but that " & + "the primitive subprogram body executed is that of the" & + "actual type"); + + TC_Okay_MStatus := Send_Msg (Mess); + if not TC_Okay_MStatus then + Report.Failed ("Wrong result from call to root type's operation"); + end if; + + TC_Okay_WMStatus := Send_WMsg (WMess); + if not TC_Okay_WMStatus then + Report.Failed ("Wrong result from call to derived type's operation"); + end if; + + Report.Result; + end CC51002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51003.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- CC51003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the ancestor type of a formal derived type is a composite + -- type that is not an array type, the formal type inherits components, + -- including discriminants, from the ancestor type. + -- + -- Check for the case where the ancestor type is a record type, and the + -- formal derived type is declared in a generic subprogram. + -- + -- TEST DESCRIPTION: + -- Define a discriminated record type in a package. Declare a + -- library-level generic subprogram with a formal derived type using the + -- record type as ancestor. Give the generic subprogram an in out + -- parameter of the formal derived type. Inside the generic, use the + -- discriminant component and modify the remaining components of the + -- record parameter. In the main program, declare record objects with two + -- different discriminant values. Derive an indefinite type from the + -- record type with a new discriminant part. Instantiate the generic + -- subprogram for the root record subtype and the derived subtype. Call + -- the root subtype instance with actual parameters having the two + -- discriminant values. Also call the derived subtype instance with + -- an appropriate actual. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 03 Jan 95 SAIC Removed unknown discriminant part from formal + -- derived type. + -- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype + -- instantiation and associated declarations. + -- Modified commentary. + -- + --! + + + -- Simulate a fragment of a matrix manipulation application. + + package CC51003_0 is -- Matrix types. + + type Matrix is array (Natural range <>, Natural range <>) of Integer; + + type Square (Side : Natural) is record + Mat : Matrix (1 .. Side, 1 .. Side); + end record; + + type Double_Square (Number : Natural) is record + Left : Square (Number); + Right : Square (Number); + end record; + + end CC51003_0; + + + -- No body for CC51003_0; + + + --==================================================================-- + + + with CC51003_0; -- Matrix types. + generic -- Generic double-matrix "clear" operation. + type Dbl_Square is new CC51003_0.Double_Square; -- Indefinite + procedure CC51003_1 (Dbl : in out Dbl_Square); -- formal. + + + --==================================================================-- + + + procedure CC51003_1 (Dbl : in out Dbl_Square) is + begin + for I in 1 .. Dbl.Number loop -- Discriminants inherited from ancestor + for J in 1 .. Dbl.Number loop -- type (should work even for derived type + -- declaring new discriminant part). + Dbl.Left.Mat (I, J) := 0; -- Other components inherited from + Dbl.Right.Mat (I, J) := 0; -- ancestor type. + + end loop; + end loop; + end CC51003_1; + + + --==================================================================-- + + + with CC51003_0; -- Matrix types. + with CC51003_1; -- Generic double-matrix "clear" operation. + + with Report; + procedure CC51003 is + + use CC51003_0; -- "/=" operator directly visible for Double_Square. + + -- Matrices of root type: + + Mat_2x2 : Square(Side => 2) := (Side => 2, + Mat => ( (1, 2), (3, 4) )); + Dbl_Mat_2x2 : Double_Square(Number => 2) := (2, Mat_2x2, Mat_2x2); + + + Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) )); + Expected_2x2 : constant Double_Square(2) := (Number => 2, + others => Zero_2x2); + + + + Mat_3x3 : Square(Side => 3) := (Side => 3, + Mat => (1 => (1, 4, 9), + others => (1 => 5, + others => 7))); + Dbl_Mat_3x3 : Double_Square(3) := (Number => 3, others => Mat_3x3); + + + Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0))); + Expected_3x3 : constant Double_Square(Number => 3) := + (3, Zero_3x3, Zero_3x3); + + + -- Derived type with new discriminant part (which constrains parent): + + type New_Dbl_Sq (Num : Natural) is new Double_Square(Num); + + New_Dbl_2x2 : New_Dbl_Sq (Num => 2) := (2, Mat_2x2, Mat_2x2); + Expected_New_2x2 : constant New_Dbl_Sq := (Num => 2, others => Zero_2x2); + + + + -- Instantiations: + + procedure Clr_Dbl is new CC51003_1 (Double_Square); + procedure Clr_New_Dbl is new CC51003_1 (New_Dbl_Sq); + + + begin + Report.Test ("CC51003", "Check that a formal derived record type " & + "inherits components, including discriminants, " & + "from its ancestor type"); + + -- Simulate use of matrix manipulation operations. + + Clr_Dbl (Dbl_Mat_2x2); + + if (Dbl_Mat_2x2 /= Expected_2x2) then + Report.Failed ("Wrong result for root type (2x2 matrix)"); + end if; + + + Clr_Dbl (Dbl_Mat_3x3); + + if (Dbl_Mat_3x3 /= Expected_3x3) then + Report.Failed ("Wrong result for root type (3x3 matrix)"); + end if; + + + Clr_New_Dbl (New_Dbl_2x2); + + if (New_Dbl_2x2 /= Expected_New_2x2) then + Report.Failed ("Wrong result for derived type (2x2 matrix)"); + end if; + + + Report.Result; + + end CC51003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51004.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,181 ---- + -- CC51004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if the ancestor type of a formal derived type is a composite + -- type that is not an array type, the formal type inherits components, + -- including discriminants, from the ancestor type. + -- + -- Check for the case where the ancestor type is a tagged type, and the + -- formal derived type is declared in a generic subprogram. + -- + -- TEST DESCRIPTION: + -- Define a discriminated tagged type in a package. Declare a + -- library-level generic subprogram with a formal derived type using the + -- tagged type as ancestor. Give the generic subprogram an in out + -- parameter of the formal derived type. Inside the generic, use the + -- discriminant component and modify the remaining components of the + -- tagged parameter. In the main program, declare tagged record objects + -- with two different discriminant values. Derive an indefinite type from + -- the tagged type with a new discriminant part. Instantiate the + -- generic subprogram for the root tagged subtype and the derived subtype. + -- Call the root subtype instance with actual parameters having the two + -- discriminant values. Also call the derived subtype instance with an + -- appropriate actual. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 05 Jan 94 SAIC Removed unknown discriminant part from formal + -- derived type. Moved declaration of type + -- New_Dbl_Sq from main subprogram to CC51004_0. + -- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Removed constrained subtype + -- instantiation and associated declarations. + -- Modified commentary. + -- + --! + + -- Simulate a fragment of a matrix manipulation application. + + package CC51004_0 is -- Matrix types. + + type Matrix is array (Natural range <>, Natural range <>) of Integer; + + type Square (Side : Natural) is record + Mat : Matrix (1 .. Side, 1 .. Side); + end record; + + type Sq_Type (Num1 : Natural) is tagged record + One : Square (Num1); + end record; + + -- Extended type with new discriminant part (which constrains parent): + + type New_Dbl_Sq (Num2 : Natural) is new Sq_Type(Num2) with record + Two : Square (Num2); + end record; + + end CC51004_0; + + + -- No body for CC51004_0; + + + --==================================================================-- + + + with CC51004_0; -- Matrix types. + generic -- Generic matrix "clear" operation. + type Squares is new CC51004_0.Sq_Type with private; -- Indefinite + procedure CC51004_1 (Sq : in out Squares); -- formal. + + + --==================================================================-- + + + procedure CC51004_1 (Sq : in out Squares) is + begin + for I in 1 .. Sq.Num1 loop -- Discriminants inherited from ancestor + for J in 1 .. Sq.Num1 loop -- type (should work even for derived type + -- declaring new discriminant part). + Sq.One.Mat (I, J) := 0; -- Other components inherited from + -- ancestor type. + end loop; + end loop; + end CC51004_1; + + + --==================================================================-- + + + with CC51004_0; -- Matrix types. + with CC51004_1; -- Generic double-matrix "clear" operation. + + with Report; + procedure CC51004 is + + use CC51004_0; -- "/=" operator directly visible for Sq_Type. + + -- Matrices of root type: + + Mat_2x2 : Square(Side => 2) := (Side => 2, Mat => ( (1, 2), (3, 4) )); + One_Mat_2x2 : Sq_Type(Num1 => 2) := (2, Mat_2x2); + + Zero_2x2 : constant Square(2) := (2, Mat => ( (0, 0), (0, 0) )); + Expected_2x2 : constant Sq_Type(2) := (Num1 => 2, One => Zero_2x2); + + + Mat_3x3 : Square(Side => 3) := (Side => 3, + Mat => (1 => (5, 2, 7), + others => (1 => 4, + others => 9))); + One_Mat_3x3 : Sq_Type(3) := (Num1 => 3, One => Mat_3x3); + + Zero_3x3 : constant Square(3) := (3, Mat => (others => (0,0,0))); + Expected_3x3 : constant Sq_Type(Num1 => 3) := (3, Zero_3x3); + + + New_Dbl_2x2 : New_Dbl_Sq(Num2 => 2) := (2, others => Mat_2x2); + Expected_New_2x2 : constant New_Dbl_Sq := (2, Zero_2x2, Mat_2x2); + + + + -- Instantiations: + + procedure Clr_Mat is new CC51004_1 (Sq_Type); + procedure Clr_New_Dbl is new CC51004_1 (New_Dbl_Sq); + + + begin + Report.Test ("CC51004", "Check that a formal derived tagged type " & + "inherits components, including discriminants, " & + "from its ancestor type"); + + -- Simulate use of matrix manipulation operations. + + + Clr_Mat (One_Mat_2x2); + + if (One_Mat_2x2 /= Expected_2x2) then + Report.Failed ("Wrong result root type (2x2 matrix)"); + end if; + + + Clr_Mat (One_Mat_3x3); + + if (One_Mat_3x3 /= Expected_3x3) then + Report.Failed ("Wrong result root type (3x3 matrix)"); + end if; + + + Clr_New_Dbl (New_Dbl_2x2); + + if (New_Dbl_2x2 /= Expected_New_2x2) then + Report.Failed ("Wrong result extended type (2x2 matrix)"); + end if; + + + Report.Result; + end CC51004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51006.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,224 ---- + -- CC51006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in an instance, each implicit declaration of a primitive + -- subprogram of a formal (nontagged) derived type declares a view of + -- the corresponding primitive subprogram of the ancestor type, even if + -- the subprogram has been overridden for the actual type. Check that for + -- a formal derived type with no discriminant part, if the ancestor + -- subtype is an unconstrained scalar subtype then the actual may be + -- either constrained or unconstrained. + -- + -- TEST DESCRIPTION: + -- The formal derived type has no discriminant part, but the ancestor + -- subtype is unconstrained, making the formal type unconstrained. Since + -- the ancestor subtype is a scalar subtype (not an access or composite + -- subtype), the actual may be either constrained or unconstrained. + -- + -- Declare a root type of a class as an unconstrained scalar (use floating + -- point). Declare a primitive subprogram of the root type. Declare a + -- generic package which has a formal derived type with the scalar root + -- type as ancestor. Inside the generic, declare an operation which calls + -- the ancestor type's primitive subprogram. Derive both constrained and + -- unconstrained types from the root type and override the primitive + -- subprogram for each. Declare a constrained subtype of the unconstrained + -- derivative. Instantiate the generic package for the derived types and + -- the subtype and call the "generic" operation for each one. Confirm that + -- in all cases the root type's implementation of the primitive + -- subprogram is called. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + package CC51006_0 is -- Weight class. + + type Weight_Type is digits 3; -- Root type of class (unconstrained). + + function Weight_To_String (Wt : Weight_Type) return String; + + -- ... Other operations. + + end CC51006_0; + + + --==================================================================-- + + + package body CC51006_0 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Weight_To_String (Wt : Weight_Type) return String is + begin + if Wt > 0.0 then -- Always true for this test. + return ("Root type's implementation called"); + else + return ("Unexpected result "); + end if; + end Weight_To_String; + + end CC51006_0; + + + --==================================================================-- + + + with CC51006_0; -- Weight class. + generic -- Generic weight operations. + type Weight is new CC51006_0.Weight_Type; + package CC51006_1 is + + procedure Output_Weight (Wt : in Weight; TC_Return : out String); + + -- ... Other operations. + + end CC51006_1; + + + --==================================================================-- + + + package body CC51006_1 is + + + -- The implementation of this procedure is purely artificial, and contains + -- an artificial parameter for testing purposes: the procedure returns the + -- weight string to the caller. + + procedure Output_Weight (Wt : in Weight; TC_Return : out String) is + begin + TC_Return := Weight_To_String (Wt); -- Should always call root type's + end Output_Weight; -- implementation. + + + end CC51006_1; + + + --==================================================================-- + + + with CC51006_0; -- Weight class. + use CC51006_0; + package CC51006_2 is -- Extensions to weight class. + + type Grams is new Weight_Type; -- Unconstrained + -- derivative. + + function Weight_To_String (Wt : Grams) return String; -- Overrides root + -- type's operation. + + subtype Milligrams is Grams -- Constrained + range 0.0 .. 0.999; -- subtype (of der.). + + type Pounds is new Weight_Type -- Constrained + range 0.0 .. 500.0; -- derivative. + + function Weight_To_String (Wt : Pounds) return String; -- Overrides root + -- type's operation. + + end CC51006_2; + + + --==================================================================-- + + + package body CC51006_2 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Weight_To_String (Wt : Grams) return String is + begin + return ("GRAMS: Should never be called "); + end Weight_To_String; + + + function Weight_To_String (Wt : Pounds) return String is + begin + return ("POUNDS: Should never be called "); + end Weight_To_String; + + end CC51006_2; + + + --==================================================================-- + + + with CC51006_1; -- Generic weight operations. + with CC51006_2; -- Extensions to weight class. + + with Report; + procedure CC51006 is + + package Metric_Wts_G is new CC51006_1 (CC51006_2.Grams); -- Unconstr. + package Metric_Wts_MG is new CC51006_1 (CC51006_2.Milligrams); -- Constr. + package US_Wts is new CC51006_1 (CC51006_2.Pounds); -- Constr. + + Gms : CC51006_2.Grams := 113.451; + Mgm : CC51006_2.Milligrams := 0.549; + Lbs : CC51006_2.Pounds := 24.52; + + + subtype TC_Buffers is String (1 .. 33); + + TC_Expected : constant TC_Buffers := "Root type's implementation called"; + TC_Buffer : TC_Buffers; + + begin + Report.Test ("CC51006", "Check that, in an instance, each implicit " & + "declaration of a primitive subprogram of a formal " & + "(nontagged) type declares a view of the corresponding " & + "primitive subprogram of the ancestor type"); + + + Metric_Wts_G.Output_Weight (Gms, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for unconstrained derivative"); + end if; + + + Metric_Wts_MG.Output_Weight (Mgm, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for constrained subtype"); + end if; + + + US_Wts.Output_Weight (Lbs, TC_Buffer); + + if TC_Buffer /= TC_Expected then + Report.Failed ("Root operation not called for constrained derivative"); + end if; + + Report.Result; + end CC51006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51007.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,305 ---- + -- CC51007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a generic formal derived tagged type is a private extension. + -- Specifically, check that, for a generic formal derived type whose + -- ancestor type has abstract primitive subprograms, neither the formal + -- derived type nor its descendants need be abstract. Check that objects + -- and components of the formal derived type and its nonabstract + -- descendants may be declared and allocated, as may nonabstract + -- functions returning these types, and that aggregates of nonabstract + -- descendants of the formal derived type are legal. Check that calls to + -- the abstract primitive subprograms of the ancestor dispatch to the + -- bodies corresponding to the tag of the actual parameters. + -- + -- TEST DESCRIPTION: + -- Although the ancestor type is abstract and has abstract primitive + -- subprograms, these subprograms, when inherited by a formal nonabstract + -- derived type, are not abstract, since the formal derived type is a + -- nonabstract private extension. + -- + -- Thus, derivatives of the formal derived type need not be abstract, + -- and both the formal derived type and its derivatives are considered + -- nonabstract types. + -- + -- This test verifies that the restrictions placed on abstract types do + -- not apply to the formal derived type or its derivatives. Specifically, + -- objects of, components of, allocators of, and nonabstract functions + -- returning the formal derived type or its derivatives are legal. In + -- addition, the test verifies that a call within the instance to a + -- primitive subprogram of the (abstract) ancestor type dispatches to + -- the body corresponding to the tag of the actual parameter. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 23 Dec 94 SAIC Deleted illegal extension aggregate. Corrected + -- dispatching call. Editorial changes to commentary. + -- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Moved instantiation of CC51007_3 + -- to library level. + -- 11 Aug 96 SAIC ACVC 2.1: Added pragma Elaborate to context + -- clauses of CC51007_1 and CC51007_4. + -- + --! + + package CC51007_0 is + + Max_Length : constant := 10; + type Text is new String(1 .. Max_Length); + + type Alert is abstract tagged record -- Root type of class + Message : Text := (others => '*'); -- (abstract). + end record; + + procedure Handle (A: in out Alert) is abstract; -- Abstract dispatching + -- operation. + + end CC51007_0; + + -- No body for CC51007_0; + + + --===================================================================-- + + + with CC51007_0; + + with Ada.Calendar; + pragma Elaborate (Ada.Calendar); + + package CC51007_1 is + + type Low_Alert is new CC51007_0.Alert with record + Time_Of_Arrival : Ada.Calendar.Time := Ada.Calendar.Time_Of (1901, 8, 1); + end record; + + procedure Handle (A: in out Low_Alert); -- Overrides parent's + -- implementation. + Low : Low_Alert; + + end CC51007_1; + + + --===================================================================-- + + + package body CC51007_1 is + + procedure Handle (A: in out Low_Alert) is -- Artificial for + begin -- testing. + A.Time_Of_Arrival := Ada.Calendar.Time_Of (1984, 1, 1); + A.Message := "Low Alert!"; + end Handle; + + end CC51007_1; + + + --===================================================================-- + + + with CC51007_1; + package CC51007_2 is + + type Person is (OOD, CO, CinC); + + type Medium_Alert is new CC51007_1.Low_Alert with record + Action_Officer : Person := OOD; + end record; + + procedure Handle (A: in out Medium_Alert); -- Overrides parent's + -- implementation. + Med : Medium_Alert; + + end CC51007_2; + + + --===================================================================-- + + + with Ada.Calendar; + package body CC51007_2 is + + procedure Handle (A: in out Medium_Alert) is -- Artificial for + begin -- testing. + A.Action_Officer := CO; + A.Time_Of_Arrival := Ada.Calendar.Time_Of (2001, 1, 1); + A.Message := "Med Alert!"; + end Handle; + + end CC51007_2; + + + --===================================================================-- + + + with CC51007_0; + generic + type Alert_Type is new CC51007_0.Alert with private; + Initial_State : in Alert_Type; + package CC51007_3 is + + function Clear_Message (A: Alert_Type) -- Function returning + return Alert_Type; -- formal type. + + + Max_Note : Natural := 10; + type Note is new String (1 .. Max_Note); + + type Extended_Alert is new Alert_Type with record + Addendum : Note := (others => '*'); + end record; + + -- In instance, inherits version of Handle from + -- actual corresponding to formal type. + + function Annotate_Alert (A: in Alert_Type'Class) -- Function returning + return Extended_Alert; -- derived type. + + + Init_Ext_Alert : constant Extended_Alert := -- Object declaration. + (Initial_State with Addendum => "----------"); -- Aggregate. + + + type Alert_Type_Ptr is access constant Alert_Type; + type Ext_Alert_Ptr is access Extended_Alert; + + Init_Alert_Ptr : Alert_Type_Ptr := + new Alert_Type'(Initial_State); -- Allocator. + + Init_Ext_Alert_Ptr : Ext_Alert_Ptr := + new Extended_Alert'(Init_Ext_Alert); -- Allocator. + + + type Alert_Pair is record + A : Alert_Type; -- Component. + EA : Extended_Alert; -- Component. + end record; + + end CC51007_3; + + + --===================================================================-- + + + package body CC51007_3 is + + function Clear_Message (A: Alert_Type) return Alert_Type is + Temp : Alert_Type := A; -- Object declaration. + begin + Temp.Message := (others => '-'); + return Temp; + end Clear_Message; + + function Annotate_Alert (A: in Alert_Type'Class) return Extended_Alert is + Temp : Alert_Type'Class := A; + begin + Handle (Temp); -- Dispatching call to + -- operation of ancestor. + return (Alert_Type(Temp) with Addendum => "No comment"); + end Annotate_Alert; + + end CC51007_3; + + + --===================================================================-- + + + with CC51007_1; + + with CC51007_3; + pragma Elaborate (CC51007_3); + + package CC51007_4 is new CC51007_3 (CC51007_1.Low_Alert, CC51007_1.Low); + + + --===================================================================-- + + + with CC51007_1; + with CC51007_2; + with CC51007_3; + with CC51007_4; + + with Ada.Calendar; + with Report; + procedure CC51007 is + + package Alert_Support renames CC51007_4; + + Ext : Alert_Support.Extended_Alert; + + TC_Result : Alert_Support.Extended_Alert; + + TC_Low_Expected : constant Alert_Support.Extended_Alert := + (Time_Of_Arrival => Ada.Calendar.Time_Of (1984, 1, 1), + Message => "Low Alert!", + Addendum => "No comment"); + + TC_Med_Expected : constant Alert_Support.Extended_Alert := + (Time_Of_Arrival => Ada.Calendar.Time_Of (2001, 1, 1), + Message => "Med Alert!", + Addendum => "No comment"); + + TC_Ext_Expected : constant Alert_Support.Extended_Alert := TC_Low_Expected; + + + use type Alert_Support.Extended_Alert; + + begin + Report.Test ("CC51007", "Check that, for a generic formal derived type " & + "whose ancestor type has abstract primitive subprograms, " & + "neither the formal derived type nor its descendants need " & + "be abstract, and that objects of, components of, " & + "allocators of, aggregates of, and nonabstract functions " & + "returning these types are legal. Check that calls to the " & + "abstract primitive subprograms of the ancestor dispatch " & + "to the bodies corresponding to the tag of the actual " & + "parameters"); + + + TC_Result := Alert_Support.Annotate_Alert (CC51007_1.Low); -- Dispatching + -- call. + if TC_Result /= TC_Low_Expected then + Report.Failed ("Wrong results from dispatching call (Low_Alert)"); + end if; + + + TC_Result := Alert_Support.Annotate_Alert (CC51007_2.Med); -- Dispatching + -- call. + if TC_Result /= TC_Med_Expected then + Report.Failed ("Wrong results from dispatching call (Medium_Alert)"); + end if; + + + TC_Result := Alert_Support.Annotate_Alert (Ext); -- Results in dispatching + -- call. + if TC_Result /= TC_Ext_Expected then + Report.Failed ("Wrong results from dispatching call (Extended_Alert)"); + end if; + + + Report.Result; + end CC51007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51008.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CC51008.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE ACAA MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that operations are inherited for a formal derived type whose + -- ancestor is also a formal type as described in the corrigendum. + -- (Defect Report 8652/0038, as reflected in Technical Corrigendum 1, + -- RM95 12.5.1(21/1)). + -- + -- CHANGE HISTORY: + -- 29 Jan 2001 PHL Initial version. + -- 30 Apr 2002 RLB Readied for release. + -- + --! + package CC51008_0 is + + type R0 is + record + C : Float; + end record; + + procedure S (X : R0); + + end CC51008_0; + + with Report; + use Report; + package body CC51008_0 is + procedure S (X : R0) is + begin + Comment ("CC51008_0.S called"); + end S; + end CC51008_0; + + with CC51008_0; + generic + type F1 is new CC51008_0.R0; + type F2 is new F1; + package CC51008_1 is + procedure G (O1 : F1; O2 : F2); + end CC51008_1; + + package body CC51008_1 is + procedure G (O1 : F1; O2 : F2) is + begin + S (O1); + S (O2); + end G; + end CC51008_1; + + with CC51008_0; + package CC51008_2 is + type R2 is new CC51008_0.R0; + procedure S (X : out R2); + end CC51008_2; + + with Report; + use Report; + package body CC51008_2 is + procedure S (X : out R2) is + begin + Failed ("CC51008_2.S called"); + end S; + end CC51008_2; + + with CC51008_2; + package CC51008_3 is + type R3 is new CC51008_2.R2; + procedure S (X : R3); + end CC51008_3; + + with Report; + use Report; + package body CC51008_3 is + procedure S (X : R3) is + begin + Failed ("CC51008_3.S called"); + end S; + end CC51008_3; + + with CC51008_1; + with CC51008_2; + with CC51008_3; + with Report; + use Report; + procedure CC51008 is + + package Inst is new CC51008_1 (CC51008_2.R2, + CC51008_3.R3); + + X2 : constant CC51008_2.R2 := (C => 2.0); + X3 : constant CC51008_3.R3 := (C => 3.0); + + begin + Test ("CC51008", + "Check that operations are inherited for a formal derived " & + "type whose ancestor is also a formal type as described in " & + "RM95 12.5.1(21/1)"); + Inst.G (X2, X3); + Result; + end CC51008; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,193 ---- + -- CC51A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in an instance, each implicit declaration of a user-defined + -- subprogram of a formal derived record type declares a view of the + -- corresponding primitive subprogram of the ancestor, even if the + -- primitive subprogram has been overridden for the actual type. + -- + -- TEST DESCRIPTION: + -- Declare a "fraction" type abstraction in a package (foundation code). + -- Declare a "fraction" I/O routine in a generic package with a formal + -- derived type whose ancestor type is the fraction type declared in + -- the first package. Within the I/O routine, call other operations of + -- ancestor type. Derive from the root fraction type in another package + -- and override one of the operations called in the generic I/O routine. + -- Derive from the derivative of the root fraction type. Instantiate + -- the generic package for each of the three types and call the I/O + -- routine. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC51A00.A + -- CC51A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FC51A00; -- Fraction type abstraction. + generic -- Fraction I/O support. + type Fraction is new FC51A00.Fraction_Type; -- Formal derived type of a + package CC51A01_0 is -- (private) record type. + + -- Simulate writing a fraction to standard output. In a real application, + -- this subprogram might be a procedure which uses Text_IO routines. For + -- the purposes of the test, the "output" is returned to the caller as a + -- string. + function Put (Item : in Fraction) return String; + + -- ... Other I/O operations for fractions. + + end CC51A01_0; + + + --==================================================================-- + + + package body CC51A01_0 is + + function Put (Item : in Fraction) return String is + Num : constant String := -- Fraction's primitive subprograms + Integer'Image (Numerator (Item)); -- are inherited from its parent + Den : constant String := -- (FC51A00.Fraction_Type) and NOT + Integer'Image (Denominator (Item)); -- from the actual type. + begin + return (Num & '/' & Den); + end Put; + + end CC51A01_0; + + + --==================================================================-- + + + with FC51A00; -- Fraction type abstraction. + package CC51A01_1 is + + -- Derive directly from the root type of the class and override one of the + -- primitive subprograms. + + type Pos_Fraction is new FC51A00.Fraction_Type; -- Derived directly from + -- root type of class. + -- Inherits "/" from root type. + -- Inherits "-" from root type. + -- Inherits Numerator from root type. + -- Inherits Denominator from root type. + + -- Return absolute value of numerator as integer. + function Numerator (Frac : Pos_Fraction) -- Overrides parent's + return Integer; -- operation. + + end CC51A01_1; + + + --==================================================================-- + + + package body CC51A01_1 is + + -- This body should never be called. + -- + -- The test sends the function Numerator a fraction with a negative + -- numerator, and expects this negative numerator to be returned. This + -- version of the function returns the absolute value of the numerator. + -- Thus, a call to this version is detectable by examining the sign + -- of the return value. + + function Numerator (Frac : Pos_Fraction) return Integer is + Converted_Frac : FC51A00.Fraction_Type := FC51A00.Fraction_Type (Frac); + Orig_Numerator : Integer := FC51A00.Numerator (Converted_Frac); + begin + return abs (Orig_Numerator); + end Numerator; + + end CC51A01_1; + + + --==================================================================-- + + + with FC51A00; -- Fraction type abstraction. + with CC51A01_0; -- Fraction I/O support. + with CC51A01_1; -- Positive fraction type abstraction. + + with Report; + procedure CC51A01 is + + type Distance is new CC51A01_1.Pos_Fraction; -- Derived indirectly from + -- root type of class. + -- Inherits "/" indirectly from root type. + -- Inherits "-" indirectly from root type. + -- Inherits Numerator directly from parent type. + -- Inherits Denominator indirectly from root type. + + use FC51A00, CC51A01_1; -- All primitive subprograms + -- directly visible. + + package Fraction_IO is new CC51A01_0 (Fraction_Type); + package Pos_Fraction_IO is new CC51A01_0 (Pos_Fraction); + package Distance_IO is new CC51A01_0 (Distance); + + -- For each of the instances above, the subprogram "Put" should produce + -- the same result. That is, the primitive subprograms called by Put + -- should in all cases be those of the type Fraction_Type, which is the + -- ancestor type for the formal derived type in the generic unit. In + -- particular, for Pos_Fraction_IO and Distance_IO, the versions of + -- Numerator called should NOT be those of the actual types, which override + -- Fraction_Type's version. + + TC_Expected_Result : constant String := "-3/ 16"; + + TC_Root_Type_Of_Class : Fraction_Type := -3/16; + TC_Direct_Derivative : Pos_Fraction := -3/16; + TC_Indirect_Derivative : Distance := -3/16; + + begin + Report.Test ("CC51A01", "Check that, in an instance, each implicit " & + "declaration of a user-defined subprogram of a formal " & + "derived record type declares a view of the corresponding " & + "primitive subprogram of the ancestor, even if the " & + "primitive subprogram has been overridden for the actual " & + "type"); + + if (Fraction_IO.Put (TC_Root_Type_Of_Class) /= TC_Expected_Result) then + Report.Failed ("Wrong result for root type"); + end if; + + if (Pos_Fraction_IO.Put (TC_Direct_Derivative) /= TC_Expected_Result) then + Report.Failed ("Wrong result for direct derivative"); + end if; + + if (Distance_IO.Put (TC_Indirect_Derivative) /= TC_Expected_Result) then + Report.Failed ("Wrong result for INdirect derivative"); + end if; + + Report.Result; + end CC51A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51b03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51b03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51b03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51b03.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,258 ---- + -- CC51B03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the attribute S'Definite, where S is an indefinite formal + -- private or derived type, returns true if the actual corresponding to + -- S is definite, and returns false otherwise. + -- + -- TEST DESCRIPTION: + -- A definite subtype is any subtype which is not indefinite. An + -- indefinite subtype is either: + -- a) An unconstrained array subtype. + -- b) A subtype with unknown discriminants (this includes class-wide + -- types). + -- c) A subtype with unconstrained discriminants without defaults. + -- + -- The possible forms of indefinite formal subtype are as follows: + -- + -- Formal derived types: + -- X - Ancestor is an unconstrained array type + -- * - Ancestor is a discriminated record type without defaults + -- X - Ancestor is a discriminated tagged type + -- * - Ancestor type has unknown discriminants + -- - Formal type has an unknown discriminant part + -- * - Formal type has a known discriminant part + -- + -- Formal private types: + -- - Formal type has an unknown discriminant part + -- * - Formal type has a known discriminant part + -- + -- The formal subtypes preceded by an 'X' above are not covered, because + -- other rules prevent a definite subtype from being passed as an actual. + -- The formal subtypes preceded by an '*' above are not covered, because + -- 'Definite is less likely to be used for these formals. + -- + -- The following kinds of actuals are passed to various of the formal + -- types listed above: + -- + -- - Undiscriminated type + -- - Type with defaulted discriminants + -- - Type with undefaulted discriminants + -- - Class-wide type + -- + -- A typical usage of S'Definite might be algorithm selection in a + -- generic I/O package, e.g., the use of fixed-length or variable-length + -- records depending on whether the actual is definite or indefinite. + -- In such situations, S'Definite would appear in if conditions or other + -- contexts requiring a boolean expression. This test checks S'Definite + -- in such usage contexts but, for brevity, omits any surrounding + -- usage code. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC51B00.A + -- -> CC51B03.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FC51B00; -- Indefinite subtype declarations. + package CC51B03_0 is + + -- + -- Formal private type cases: + -- + + generic + type Formal (<>) is private; -- Formal has unknown + package PrivateFormalUnknownDiscriminants is -- discriminant part. + function Is_Definite return Boolean; + end PrivateFormalUnknownDiscriminants; + + + -- + -- Formal derived type cases: + -- + + generic + type Formal (<>) is new FC51B00.Vector -- Formal has an unknown disc. + with private; -- part; ancestor is tagged. + package TaggedAncestorUnknownDiscriminants is + function Is_Definite return Boolean; + end TaggedAncestorUnknownDiscriminants; + + + end CC51B03_0; + + + --==================================================================-- + + + package body CC51B03_0 is + + package body PrivateFormalUnknownDiscriminants is + function Is_Definite return Boolean is + begin + if Formal'Definite then -- Attribute used in "if" + -- ...Execute algorithm #1... -- condition inside subprogram. + return True; + else + -- ...Execute algorithm #2... + return False; + end if; + end Is_Definite; + end PrivateFormalUnknownDiscriminants; + + + package body TaggedAncestorUnknownDiscriminants is + function Is_Definite return Boolean is + begin + return Formal'Definite; -- Attribute used in return + end Is_Definite; -- statement inside subprogram. + end TaggedAncestorUnknownDiscriminants; + + + end CC51B03_0; + + + --==================================================================-- + + + with FC51B00; + package CC51B03_1 is + + subtype Spin_Type is Natural range 0 .. 3; + + type Extended_Vector (Spin : Spin_Type) is -- Tagged type with + new FC51B00.Vector with null record; -- discriminant (indefinite). + + + end CC51B03_1; + + + --==================================================================-- + + + with FC51B00; -- Indefinite subtype declarations. + with CC51B03_0; -- Generic package declarations. + with CC51B03_1; + + with Report; + procedure CC51B03 is + + -- + -- Instances for formal private type with unknown discriminants: + -- + + package PrivateFormal_UndiscriminatedTaggedActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector); + + package PrivateFormal_ClassWideActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Vector'Class); + + package PrivateFormal_DiscriminatedTaggedActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square_Pair); + + package PrivateFormal_DiscriminatedUndefaultedRecordActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (FC51B00.Square); + + + subtype Length is Natural range 0 .. 20; + type Message (Len : Length := 0) is record -- Record type with defaulted + Text : String (1 .. Len); -- discriminant (definite). + end record; + + package PrivateFormal_DiscriminatedDefaultedRecordActual is new + CC51B03_0.PrivateFormalUnknownDiscriminants (Message); + + + -- + -- Instances for formal derived tagged type with unknown discriminants: + -- + + package DerivedFormal_UndiscriminatedTaggedActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector); + + package DerivedFormal_ClassWideActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (FC51B00.Vector'Class); + + package DerivedFormal_DiscriminatedTaggedActual is new + CC51B03_0.TaggedAncestorUnknownDiscriminants (CC51B03_1.Extended_Vector); + + + begin + Report.Test ("CC51B03", "Check that S'Definite returns true if the " & + "actual corresponding to S is definite, and false otherwise"); + + + if not PrivateFormal_UndiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for undiscriminated tagged actual"); + end if; + + if PrivateFormal_ClassWideActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for class-wide actual"); + end if; + + if PrivateFormal_DiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong " & + "result for discriminated tagged actual"); + end if; + + if PrivateFormal_DiscriminatedUndefaultedRecordActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong result " & + "for record actual with undefaulted discriminants"); + end if; + + if not PrivateFormal_DiscriminatedDefaultedRecordActual.Is_Definite then + Report.Failed ("Formal private/unknown discriminants: wrong result " & + "for record actual with defaulted discriminants"); + end if; + + + if not DerivedFormal_UndiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for undiscriminated tagged actual"); + end if; + + if DerivedFormal_ClassWideActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for class-wide actual"); + end if; + + if DerivedFormal_DiscriminatedTaggedActual.Is_Definite then + Report.Failed ("Formal derived/unknown discriminants: wrong result " & + "for discriminated tagged actual"); + end if; + + + Report.Result; + end CC51B03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51d01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51d01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51d01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51d01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,262 ---- + -- CC51D01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in an instance, each implicit declaration of a user-defined + -- subprogram of a formal private extension declares a view of the + -- corresponding primitive subprogram of the ancestor, and that if the + -- tag in a call is statically determined to be that of the formal type, + -- the body executed will be that corresponding to the actual type. + -- + -- Check subprograms declared within a generic formal package. Check for + -- the case where the actual type passed to the formal private extension + -- is a specific tagged type. Check for several types in the same class. + -- + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type (foundation code). Declare a package + -- which declares a tagged type and a type derived from it. Declare an + -- operation for the root tagged type and override it for the derived + -- type. Derive a type from this derived type, but do not override the + -- operation. Declare a generic subprogram which operates on lists of + -- elements of tagged types. Provide the generic subprogram with two + -- formal parameters: (1) a formal derived tagged type which represents a + -- list element type, and (2) a generic formal package with the list + -- abstraction package as template. Use the formal derived type as the + -- generic formal actual part for the formal package. Within the generic + -- subprogram, call the operation of the root tagged type. In the main + -- program, instantiate the generic list package and the generic + -- subprogram with the root tagged type and each derivative, then call + -- each instance with an object of the appropriate type. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC51D00.A + -- -> CC51D01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 04 Jan 95 SAIC Moved declaration of type Ranked_ID_Type from + -- main subprogram to package CC51D01_0. Removed + -- case passing class-wide actual to instance. + -- Updated test description and modified comments. + -- + --! + + package CC51D01_0 is -- This package simulates support for a personnel + -- database. + + type SSN_Type is new String (1 .. 9); + + type Blind_ID_Type is tagged record -- Root type of + SSN : SSN_Type; -- class. + -- ... Other components. + end record; + + procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. + + -- ... Other operations. + + + type Name_Type is new String (1 .. 9); + + type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative + Name : Name_Type := "Doe "; -- of root type. + -- ... Other components. + end record; + + -- Inherits Update_ID from parent. + + procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's + -- implementation. + + + type Ranked_ID_Type is new Named_ID_Type with record + Level : Integer := 0; -- Indirect derivative + -- ... Other components. -- of root type. + end record; + + -- Inherits Update_ID from parent. + + end CC51D01_0; + + + --==================================================================-- + + + package body CC51D01_0 is + + -- The implementations of Update_ID are purely artificial; the validity of + -- their implementations in the context of the abstraction is irrelevant to + -- the feature being tested. + + procedure Update_ID (Item : in out Blind_ID_Type) is + begin + Item.SSN := "111223333"; + end Update_ID; + + + procedure Update_ID (Item : in out Named_ID_Type) is + begin + Item.SSN := "444556666"; + -- ... Other stuff. + end Update_ID; + + end CC51D01_0; + + + --==================================================================-- + + + -- -- + -- Formal package used here. -- + -- -- + + with FC51D00; -- Generic list abstraction. + with CC51D01_0; -- Tagged type declarations. + generic -- This procedure simulates a generic operation for types + -- in the class rooted at Blind_ID_Type. + type Elem_Type is new CC51D01_0.Blind_ID_Type with private; + with package List_Mgr is new FC51D00 (Elem_Type); + procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); + + + --==================================================================-- + + + -- The implementation of CC51D01_1 is purely artificial; the validity + -- of its implementation in the context of the abstraction is irrelevant + -- to the feature being tested. + -- + -- The expected behavior here is as follows: for each actual type corresponding + -- to Elem_Type, the call to Update_ID should invoke the actual type's + -- implementation, which updates the object's SSN field. Write_Element then + -- adds the object to the list. + + procedure CC51D01_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is + Element : Elem_Type := E; -- Can't update IN parameter. + begin + Update_ID (Element); -- Executes actual type's version. + List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version. + end CC51D01_1; + + + --==================================================================-- + + + with FC51D00; -- Generic list abstraction. + with CC51D01_0; -- Tagged type declarations. + with CC51D01_1; -- Generic operation. + + with Report; + procedure CC51D01 is + + use CC51D01_0; -- All types & ops + -- directly visible. + + -- Begin test code declarations: ----------------------- + + TC_Expected_1 : Blind_ID_Type := (SSN => "111223333"); + TC_Expected_2 : Named_ID_Type := ("444556666", "Doe "); + TC_Expected_3 : Ranked_ID_Type := ("444556666", "Doe ", 0); + + TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); + TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); + TC_Initial_3 : Ranked_ID_Type := ("777889999", "Doe ", 0); + + -- End test code declarations. ------------------------- + + + -- Begin instantiations and list declarations: --------- + + -- At this point in an application, the generic list package would be + -- instantiated for one of the visible tagged types. Next, the generic + -- subprogram would be instantiated for the same tagged type and the + -- preceding list package instance. + -- + -- In order to cover all the important cases, this test instantiates several + -- packages and subprograms (probably more than would typically appear + -- in user code). + + -- Support for lists of blind IDs: + + package Blind_Lists is new FC51D00 (Blind_ID_Type); + procedure Update_and_Write is new CC51D01_1 (Blind_ID_Type, Blind_Lists); + Blind_List : Blind_Lists.List_Type; + + + -- Support for lists of named IDs: + + package Named_Lists is new FC51D00 (Named_ID_Type); + procedure Update_and_Write is new -- Overloads subprog + CC51D01_1 (Elem_Type => Named_ID_Type, -- for Blind_ID_Type. + List_Mgr => Named_Lists); + Named_List : Named_Lists.List_Type; + + + -- Support for lists of ranked IDs: + + package Ranked_Lists is new FC51D00 (Ranked_ID_Type); + procedure Update_and_Write is new -- Overloads. + CC51D01_1 (Elem_Type => Ranked_ID_Type, + List_Mgr => Ranked_Lists); + Ranked_List : Ranked_Lists.List_Type; + + -- End instantiations and list declarations. ----------- + + + begin + Report.Test ("CC51D01", "Formal private extension, specific tagged " & + "type actual: body of primitive subprogram executed is " & + "that of actual type. Check for subprograms declared in " & + "a formal package"); + + + Update_and_Write (Blind_List, TC_Initial_1); + + if (Blind_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then + Report.Failed ("Wrong result for root tagged type"); + end if; + + + Update_and_Write (Named_List, TC_Initial_2); + + if (Named_Lists.View_Element (1, Named_List) /= TC_Expected_2) then + Report.Failed ("Wrong result for type derived directly from root"); + end if; + + + Update_and_Write (Ranked_List, TC_Initial_3); + + if (Ranked_Lists.View_Element (1, Ranked_List) /= TC_Expected_3) then + Report.Failed ("Wrong result for type derived indirectly from root"); + end if; + + + Report.Result; + end CC51D01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51d02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51d02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc51d02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc51d02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,244 ---- + -- CC51D02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, in an instance, each implicit declaration of a user-defined + -- subprogram of a formal private extension declares a view of the + -- corresponding primitive subprogram of the ancestor, and that if the + -- tag in a call is statically determined to be that of the formal type, + -- the body executed will be that corresponding to the actual type. + -- + -- Check subprograms declared within a generic formal package. Check for + -- the case where the actual type passed to the formal private extension + -- is a class-wide type. Check for several types in the same class. + -- + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type (foundation code). Declare a package + -- which declares a tagged type and a derivative. Declare an operation + -- for the root tagged type and override it for the derivative. Declare + -- a generic subprogram which operates on lists of elements of tagged + -- types. Provide the generic subprogram with two formal parameters: (1) + -- a formal derived tagged type which represents a list element type, and + -- (2) a generic formal package with the list abstraction package as + -- template. Use the formal derived type as the generic formal actual + -- part for the formal package. Within the generic subprogram, call the + -- operation of the root tagged type. In the main program, instantiate + -- the generic list package and the generic subprogram with the class-wide + -- type for the root tagged type. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC51D00.A + -- -> CC51D02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 05 Jan 95 SAIC Changed types of TC_Expected_1 and TC_Expected_2 + -- from specific to class-wide. Eliminated (illegal) + -- assignment step prior to comparison of + -- TC_Expected_X with item on stack. + -- + --! + + package CC51D02_0 is -- This package simulates support for a personnel + -- database. + + type SSN_Type is new String (1 .. 9); + + type Blind_ID_Type is tagged record -- Root type of + SSN : SSN_Type; -- class. + -- ... Other components. + end record; + + procedure Update_ID (Item : in out Blind_ID_Type); -- Parent operation. + + -- ... Other operations. + + + type Name_Type is new String (1 .. 9); + + type Named_ID_Type is new Blind_ID_Type with record -- Direct derivative + Name : Name_Type := "Doe "; -- of root type. + -- ... Other components. + end record; + + -- Inherits Update_ID from parent. + + procedure Update_ID (Item : in out Named_ID_Type); -- Overrides parent's + -- implementation. + + end CC51D02_0; + + + --==================================================================-- + + + package body CC51D02_0 is + + -- The implementations of Update_ID are purely artificial; the validity of + -- their implementations in the context of the abstraction is irrelevant to + -- the feature being tested. + + procedure Update_ID (Item : in out Blind_ID_Type) is + begin + Item.SSN := "111223333"; + end Update_ID; + + + procedure Update_ID (Item : in out Named_ID_Type) is + begin + Item.SSN := "444556666"; + -- ... Other stuff. + end Update_ID; + + end CC51D02_0; + + + --==================================================================-- + + + -- -- + -- Formal package used here. -- + -- -- + + with FC51D00; -- Generic list abstraction. + with CC51D02_0; -- Tagged type declarations. + generic -- This procedure simulates a generic operation for types + -- in the class rooted at Blind_ID_Type. + type Elem_Type (<>) is new CC51D02_0.Blind_ID_Type with private; + with package List_Mgr is new FC51D00 (Elem_Type); + procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type); + + + --==================================================================-- + + + -- The implementation of CC51D02_1 is purely artificial; the validity + -- of its implementation in the context of the abstraction is irrelevant + -- to the feature being tested. + -- + -- The expected behavior here is as follows: for each actual type corresponding + -- to Elem_Type, the call to Update_ID should invoke the actual type's + -- implementation (based on the tag of the actual), which updates the object's + -- SSN field. Write_Element then adds the object to the list. + + procedure CC51D02_1 (L : in out List_Mgr.List_Type; E : in Elem_Type) is + Element : Elem_Type := E; -- Can't update IN parameter. + -- Initialization of unconstrained variable. + begin + Update_ID (Element); -- Executes actual type's version + -- (for this test, this will be a + -- dispatching call). + List_Mgr.Write_Element (1, L, Element); -- Executes actual type's version + -- (for this test, this will be a + -- class-wide operation). + end CC51D02_1; + + + --==================================================================-- + + + with FC51D00; -- Generic list abstraction. + with CC51D02_0; -- Tagged type declarations. + with CC51D02_1; -- Generic operation. + + with Report; + procedure CC51D02 is + + use CC51D02_0; -- All types & ops + -- directly visible. + + -- Begin test code declarations: ----------------------- + + TC_Expected_1 : Blind_ID_Type'Class := + Blind_ID_Type'(SSN => "111223333"); + TC_Expected_2 : Blind_ID_Type'Class := + Named_ID_Type'("444556666", "Doe "); + + + TC_Initial_1 : Blind_ID_Type := (SSN => "777889999"); + TC_Initial_2 : Named_ID_Type := ("777889999", "Doe "); + TC_Initial_3 : Blind_ID_Type'Class := TC_Initial_2; + + -- End test code declarations. ------------------------- + + + package ID_Class_Lists is new FC51D00 (Blind_ID_Type'Class); + + procedure Update_and_Write is new CC51D02_1 (Blind_ID_Type'Class, + ID_Class_Lists); + + Blind_List : ID_Class_Lists.List_Type; + Named_List : ID_Class_Lists.List_Type; + Maimed_List : ID_Class_Lists.List_Type; + + + begin + Report.Test ("CC51D02", "Formal private extension, class-wide actual: " & + "body of primitive subprogram executed is that of actual " & + "type. Check for subprograms declared in formal package"); + + + Update_and_Write (Blind_List, TC_Initial_1); -- Test root type actual. + + if (ID_Class_Lists.View_Element (1, Blind_List) not in Blind_ID_Type) then + Report.Failed ("Result for root type actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Blind_List) /= TC_Expected_1) then + Report.Failed ("Wrong result for root type actual"); + end if; + + + Update_and_Write (Named_List, TC_Initial_2); -- Test derived type actual. + + if (ID_Class_Lists.View_Element (1, Named_List) not in Named_ID_Type) then + Report.Failed ("Result for derived type actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Named_List)/= TC_Expected_2) then + Report.Failed ("Wrong result for derived type actual"); + end if; + + + -- In the subtest below, an object of a class-wide type (TC_Initial_3) is + -- passed to Update_and_Write. It has been initialized with an object of + -- type Named_ID_Type, so the result should be identical to + -- that of the Named_ID_Type subtest (namely TC_Expected_2). Note that + -- a new list of Named IDs is used (Maimed_List). This is to assure test + -- validity, since Named_List has already been updated by a previous + -- subtest. + + Update_and_Write (Maimed_List, TC_Initial_3); -- Test class-wide actual. + + if (ID_Class_Lists.View_Element (1, Maimed_List) not in Named_ID_Type) then + Report.Failed ("Result for class-wide actual is not in proper class"); + elsif (ID_Class_Lists.View_Element (1, Maimed_List) /= TC_Expected_2) then + Report.Failed ("Wrong result for class-wide actual"); + end if; + + + Report.Result; + end CC51D02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- CC54001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a general access-to-constant type may be passed as an + -- actual to a generic formal access-to-constant type. + -- + -- TEST DESCRIPTION: + -- The generic implements a stack of access objects as an array. The + -- designated type of the formal access type is itself a formal private + -- type declared in the same generic formal part. + -- + -- The generic is instantiated with an unconstrained subtype of String, + -- which results in a stack which can accommodate strings of varying + -- lengths (ragged array). Furthermore, the access objects to be pushed + -- onto the stack are created both statically and dynamically, utilizing + -- allocators and the 'Access attribute. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause + -- preceding CC54001_1. + -- + --! + + generic + Size : in Positive; + type Element_Type (<>) is private; + type Element_Ptr is access constant Element_Type; + package CC54001_0 is -- Generic stack of pointers. + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr); + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr); + + -- ... Other operations. + + private + + subtype Index is Positive range 1 .. (Size + 1); + type Stack_Type is array (Index) of Element_Ptr; -- Last element unused. + + Top : Index := 1; + + end CC54001_0; + + + --===================================================================-- + + + package body CC54001_0 is + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr) is + begin + Stack(Top) := Elem_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr) is + begin + Top := Top - 1; -- Artificial: no Constraint_Error protection. + Elem_Ptr := Stack(Top); + end Pop; + + end CC54001_0; + + + --===================================================================-- + + + with CC54001_0; -- Generic stack of pointers. + pragma Elaborate (CC54001_0); + + package CC54001_1 is + + subtype Message is String; + type Message_Ptr is access constant Message; + + Message_Count : constant := 4; + + Message_0 : aliased constant Message := "Hello"; + Message_1 : aliased constant Message := "Doctor"; + Message_2 : aliased constant Message := "Name"; + Message_3 : aliased constant Message := "Continue"; + + + package Stack_of_Messages is new CC54001_0 + (Element_Type => Message, + Element_Ptr => Message_Ptr, + Size => Message_Count); + + Message_Stack : Stack_Of_Messages.Stack_Type; + + + procedure Create_Message_Stack; + + end CC54001_1; + + + --===================================================================-- + + + package body CC54001_1 is + + procedure Create_Message_Stack is + -- Push access objects onto stack. Note that some are statically + -- allocated, and some are dynamically allocated (using an aliased + -- object to initialize). + begin + Stack_Of_Messages.Push (Message_Stack, Message_0'Access); -- Static. + Stack_Of_Messages.Push (Message_Stack, + new Message'(Message_1)); -- Dynamic. + Stack_Of_Messages.Push (Message_Stack, Message_2'Access); -- Static. + Stack_Of_Messages.Push (Message_Stack, -- Dynamic. + new Message'(Message_3)); + end Create_Message_Stack; + + end CC54001_1; + + + --===================================================================-- + + + with CC54001_1; + + with Report; + procedure CC54001 is + + package Messages renames CC54001_1.Stack_Of_Messages; + + Msg0, Msg1, Msg2, Msg3 : CC54001_1.Message_Ptr; + + begin + Report.Test ("CC54001", "Check that a general access-to-constant type " & + "may be passed as an actual to a generic formal " & + "access-to-constant type"); + + CC54001_1.Create_Message_Stack; + + Messages.Pop (CC54001_1.Message_Stack, Msg3); -- Pop items off stack in the + Messages.Pop (CC54001_1.Message_Stack, Msg2); -- reverse order that they + Messages.Pop (CC54001_1.Message_Stack, Msg1); -- were pushed. + Messages.Pop (CC54001_1.Message_Stack, Msg0); + + if Msg0.all /= CC54001_1.Message_0 or else + Msg1.all /= CC54001_1.Message_1 or else + Msg2.all /= CC54001_1.Message_2 or else + Msg3.all /= CC54001_1.Message_3 + then + Report.Failed ("Items popped off of stack do not match those pushed"); + end if; + + Report.Result; + end CC54001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,223 ---- + -- CC54002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a general access-to-variable type may be passed as an + -- actual to a generic formal general access-to-variable type. Check that + -- designated objects may be read and updated through the access value. + -- + -- TEST DESCRIPTION: + -- The generic implements a List of access objects as an array, which + -- is itself a component of a record. The designated type of the formal + -- access type is a formal private type declared in the same generic + -- formal part. + -- + -- The access objects to be placed in the List are created both + -- statically and dynamically, utilizing allocators and the 'Access + -- attribute. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause + -- preceding CC54002_1. + -- + --! + + generic + Size : in Positive; + type Element_Type (<>) is private; + type Element_Ptr is access all Element_Type; + package CC54002_0 is -- Generic list of pointers. + + subtype Index is Positive range 1 .. (Size + 1); + + type List_Array is array (Index) of Element_Ptr; + + type List_Type is record + Elements : List_Array; + Next : Index := 1; -- Next available "slot" in list. + end record; + + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index); + + procedure Get (List : in out List_Type; + Elem_Ptr : out Element_Ptr; + Location : in Index); + + -- ... Other operations. + + end CC54002_0; + + + --===================================================================-- + + + package body CC54002_0 is + + procedure Put (List : in out List_Type; + Elem_Ptr : in Element_Ptr; + Location : in Index) is + begin + List.Elements(Location) := Elem_Ptr; + end Put; + + + procedure Get (List : in out List_Type; + Elem_Ptr : out Element_Ptr; + Location : in Index) is + begin -- Artificial: no provision for getting "empty" element. + Elem_Ptr := List.Elements(Location); + end Get; + + end CC54002_0; + + + --===================================================================-- + + + with CC54002_0; -- Generic List of pointers. + pragma Elaborate (CC54002_0); + + package CC54002_1 is + + subtype Lengths is Natural range 0 .. 50; + + type Subscriber (NLen, ALen: Lengths := 50) is record + Name : String(1 .. NLen); + Address : String(1 .. ALen); + -- ... Other components. + end record; + + type Subscriber_Ptr is access all Subscriber; -- General access-to- + -- variable type. + + package District_Subscription_Lists is new CC54002_0 + (Element_Type => Subscriber, + Element_Ptr => Subscriber_Ptr, + Size => 100); + + District_01_Subscribers : District_Subscription_Lists.List_Type; + + + New_Subscriber_01 : aliased CC54002_1.Subscriber := + (12, 23, "Brown, Silas", "King's Pyland, Dartmoor"); + + New_Subscriber_02 : aliased CC54002_1.Subscriber := + (16, 23, "Hatherly, Victor", "16A Victoria St. London"); + + end CC54002_1; + + -- No body for CC54002_1. + + + --===================================================================-- + + + with CC54002_1; + + with Report; + procedure CC54002 is + + Mod_Subscriber_01 : constant CC54002_1.Subscriber := + (12, 23, "Brown, Silas", "Mapleton, Dartmoor "); + + TC_Actual_01, TC_Actual_02 : CC54002_1.Subscriber_Ptr; + + + use type CC54002_1.Subscriber; -- "/=" directly visible. + + begin + Report.Test ("CC54002", "Check that a general access-to-variable type " & + "may be passed as an actual to a generic formal " & + "access-to-variable type"); + + + -- Add elements to the list: + + CC54002_1.District_Subscription_Lists.Put -- Element created statically. + (List => CC54002_1.District_01_Subscribers, + Elem_Ptr => CC54002_1.New_Subscriber_01'Access, + Location => 1); + + CC54002_1.District_Subscription_Lists.Put -- Element created dynamically. + (List => CC54002_1.District_01_Subscribers, + Elem_Ptr => new CC54002_1.Subscriber'(CC54002_1.New_Subscriber_02), + Location => 2); + + + -- Manipulation of the objects on the list is performed below directly + -- through the access objects. Although such manipulation is artificial + -- from the perspective of this usage model, it is not artificial in + -- general and is necessary in order to test the objective. + + + -- Modify the first list element through the access object: + + CC54002_1.District_01_Subscribers.Elements(1).Address := -- Update + "Mapleton, Dartmoor "; -- Implicit dereference. -- through the + -- access + -- object. + -- Retrieve elements of the list: + + CC54002_1.District_Subscription_Lists.Get + (CC54002_1.District_01_Subscribers, + TC_Actual_01, + 1); + + CC54002_1.District_Subscription_Lists.Get + (CC54002_1.District_01_Subscribers, + TC_Actual_02, + 2); + + -- Verify list contents in two ways: 1st verify the directly-dereferenced + -- access objects against the dereferenced access objects returned by Get; + -- 2nd verify them against objects the expected values: + + -- Read + -- through the + -- access + -- objects. + + if CC54002_1.District_01_Subscribers.Elements(1).all /= TC_Actual_01.all + or else + CC54002_1.District_01_Subscribers.Elements(2).all /= TC_Actual_02.all + then + Report.Failed ("Wrong results returned by Get"); + + elsif CC54002_1.District_01_Subscribers.Elements(1).all /= + Mod_Subscriber_01 + or + CC54002_1.District_01_Subscribers.Elements(2).all /= + CC54002_1.New_Subscriber_02 + then + Report.Failed ("List elements do not have expected values"); + end if; + + Report.Result; + end CC54002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54003.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,234 ---- + -- CC54003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a general access-to-subprogram type may be passed as an + -- actual to a generic formal access-to-subprogram type. Check that + -- designated subprograms may be called by dereferencing the access + -- values. + -- + -- TEST DESCRIPTION: + -- The generic implements a stack of access-to-subprogram objects as an + -- array. The profile of the access-to-subprogram formal corresponds to + -- a function which accepts a parameter of some type and returns an + -- object of the same type. + -- + -- For this test, the functions for which access values will be pushed + -- onto the stack accept a parameter of type access-to-string, lengthen + -- the pointed-to string, then return an access object pointing to this + -- lengthened string. + -- + -- The instance declares a function Execute_Stack which executes each + -- subprogram on the stack in sequence. This function accepts some initial + -- access-to-string, then returns an access object pointing to the + -- lengthened string resulting from the execution of the stacked + -- subprograms. Access-to-string objects are used rather than strings + -- themselves because the initial string "grows" during each iteration. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause + -- preceding CC54003_2. + -- + --! + + generic + + Size : in Positive; + + type Item_Type (<>) is private; + type Item_Ptr is access Item_Type; + + type Function_Ptr is access function (Item : Item_Ptr) + return Item_Ptr; + + package CC54003_0 is -- Generic stack of pointers. + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr); + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr; + + -- ... Other operations. + + private + + subtype Index is Positive range 1 .. (Size + 1); + type Stack_Type is array (Index) of Function_Ptr; -- Last slot unused. + + Top : Index := 1; -- Top refers to the next available slot. + + end CC54003_0; + + + --===================================================================-- + + + package body CC54003_0 is + + procedure Push (Stack : in out Stack_Type; + Func_Ptr : in Function_Ptr) is + begin + Stack(Top) := Func_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + -- Call each subprogram on the stack in sequence. For the first call, pass + -- Initial_Input. For succeeding calls, pass the result of the previous + -- call. + + function Execute_Stack (Stack : Stack_Type; + Initial_Input : Item_Ptr) return Item_Ptr is + Result : Item_Ptr := Initial_Input; + begin + for I in reverse Index'First .. (Top - 1) loop -- Artificial: no C_E + Result := Stack(I)(Result); -- protection. + end loop; + return Result; + end Execute_Stack; + + end CC54003_0; + + + --===================================================================-- + + + package CC54003_1 is + + subtype Message is String; + type Message_Ptr is access Message; + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr; + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr; + + -- ...Other operations. + + end CC54003_1; + + + --===================================================================-- + + + package body CC54003_1 is + + function Add_Prefix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Sender : constant String := "Dummy: "; -- Artificial; in a real + -- application Sender might + New_Msg : Message := Sender & Msg_Ptr.all; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Prefix; + + + function Add_Suffix (Msg_Ptr : Message_Ptr) return Message_Ptr is + Time : constant String := " (12:03pm)"; -- Artificial; in a real + -- application Time might be a + New_Msg : Message := Msg_Ptr.all & Time; -- be a call to a function. + begin + return new Message'(New_Msg); + end Add_Suffix; + + end CC54003_1; + + + --===================================================================-- + + + with CC54003_0; -- Generic stack of pointers. + pragma Elaborate (CC54003_0); + + with CC54003_1; -- Message abstraction. + + package CC54003_2 is + + type Operation_Ptr is access function (Msg_Ptr : CC54003_1.Message_Ptr) + return CC54003_1.Message_Ptr; + + Maximum_Ops : constant := 4; -- Arbitrary. + + package Stack_of_Ops is new CC54003_0 + (Item_Type => CC54003_1.Message, + Item_Ptr => CC54003_1.Message_Ptr, + Function_Ptr => Operation_Ptr, + Size => Maximum_Ops); + + Operation_Stack : Stack_Of_Ops.Stack_Type; + + + procedure Create_Operation_Stack; + + end CC54003_2; + + --===================================================================-- + + + package body CC54003_2 is + + procedure Create_Operation_Stack is + begin + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Prefix'Access); + Stack_Of_Ops.Push (Operation_Stack, CC54003_1.Add_Suffix'Access); + end Create_Operation_Stack; + + end CC54003_2; + + + --===================================================================-- + + + with CC54003_1; -- Message abstraction. + with CC54003_2; -- Message-operation stack. + + with Report; + procedure CC54003 is + + package Msg_Ops renames CC54003_2.Stack_Of_Ops; + + Msg : CC54003_1.Message_Ptr := new CC54003_1.Message'("Hello there"); + Expected : CC54003_1.Message := "Dummy: Hello there (12:03pm)"; + + begin + Report.Test ("CC54003", "Check that a general access-to-subprogram type " & + "may be passed as an actual to a generic formal " & + "access-to-subprogram type"); + + CC54003_2.Create_Operation_Stack; + + declare + Actual : CC54003_1.Message_Ptr := + Msg_Ops.Execute_Stack (CC54003_2.Operation_Stack, Msg); + begin + if Actual.all /= Expected then + Report.Failed ("Wrong result from dereferenced subprogram execution"); + end if; + end; + + Report.Result; + end CC54003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc54004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc54004.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,295 ---- + -- CC54004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the designated type of a generic formal pool-specific + -- access type may be class-wide. Check that calls to primitive + -- subprograms in the instance dispatch to the appropriate bodies when + -- the controlling operand is a dereference of an object of the access- + -- to-class-wide type. + -- + -- TEST DESCRIPTION: + -- A hierarchy of types is declared in two packages. The root type of + -- the class is declared as abstract in a separate package. It possesses + -- an abstract primitive subprogram Handle. A concrete type extends the + -- root type in a second package with a component of an enumeration type. + -- A second type extends this extension in the same package. Both + -- derivatives override the root type's primitive subprogram with a + -- non-abstract subprogram. + -- + -- The generic implements a heterogeneous stack of access-to-class-wide + -- objects in the root type's class. A subprogram declared in the + -- generic calls Handle using dereferences of each of the class-wide + -- objects on the stack as operand. Each call to Handle should dispatch + -- to the appropriate body based on the tag of the operand. The + -- overriding versions of Handle each set the component of the type to + -- a different value. The value of the component is checked to verify + -- that the calls dispatched correctly. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 96 SAIC ACVC 2.1: Added pragma Elaborate to context clause + -- preceding CC54004_3. + -- + --! + + package CC54004_0 is + + -- The types and operations defined here are artificial. The component + -- TC_Code is the only component required for testing purposes. + + type TC_Code_Type is (None, Low, Medium); + + type Alert is abstract tagged record -- Abstract type. + TC_Code : TC_Code_Type; -- Testing flag. + end record; + + procedure Handle (A : in out Alert); -- Non-abstract primitive + -- subprogram. + -- ...Other operations. + + type Alert_Ptr is access Alert'Class; -- Access-to-class-wide + -- type. + end CC54004_0; + + + --===================================================================-- + + + package body CC54004_0 is + + procedure Handle (A : in out Alert) is + begin + A.TC_Code := None; + end Handle; + + end CC54004_0; + + + --===================================================================-- + + + with CC54004_0; + use CC54004_0; + package CC54004_1 is + + type Low_Alert is new CC54004_0.Alert with record + C1 : String (1 .. 5) := "Dummy"; + -- ...Other components. + end record; + + procedure Handle (A : in out Low_Alert); -- Overrides parent's + -- operations. + --...Other operations. + + + type Medium_Alert is new Low_Alert with record + C : Integer := 6; + -- ...Other components. + end record; + + procedure Handle (A : in out Medium_Alert); -- Overrides parent's + -- operations. + --...Other operations. + + end CC54004_1; + + + --===================================================================-- + + package body CC54004_1 is + + procedure Handle (A : in out Low_Alert) is + begin + A.TC_Code := Low; + end Handle; + + procedure Handle (A : in out Medium_Alert) is + begin + A.TC_Code := Medium; + end Handle; + + end CC54004_1; + + + --===================================================================-- + + + with CC54004_0; + generic + type Element_Type is abstract new CC54004_0.Alert with private; + type Element_Ptr is access Element_Type'Class; + package CC54004_2 is + + type Stack_Type is private; + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr); + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr); + + procedure Process_Stack (Stack : in out Stack_Type); + + -- ... Other operations. + + private + + subtype Index is Positive range 1 .. 5; + type Stack_Type is array (Index) of Element_Ptr; + + Top : Index := 1; + + end CC54004_2; + + + --===================================================================-- + + + package body CC54004_2 is + + procedure Push (Stack : in out Stack_Type; + Elem_Ptr : in Element_Ptr) is + begin + Stack(Top) := Elem_Ptr; + Top := Top + 1; -- Artificial: no Constraint_Error protection. + end Push; + + + procedure Pop (Stack : in out Stack_Type; + Elem_Ptr : out Element_Ptr)is + begin + Top := Top - 1; -- Artificial: no Constraint_Error protection. + Elem_Ptr := Stack(Top); + end Pop; + + + -- Call Handle for each element on the stack. Since the dereferenced access + -- object is of a class-wide type, all calls to Handle are dispatching. The + -- version of Handle called will be that declared for the type + -- corresponding to the tag of the operand. + + procedure Process_Stack (Stack : in out Stack_Type) is + begin -- Artificial: no Constraint_Error protection. + for I in reverse Index'First .. (Top - 1) loop + Handle (Stack(I).all); -- Call dispatches based on + end loop; -- tag of operand. + end Process_Stack; + + end CC54004_2; + + + --===================================================================-- + + + with CC54004_0; + with CC54004_1; + with CC54004_2; + pragma Elaborate (CC54004_2); + + package CC54004_3 is + + package Alert_Stacks is new CC54004_2 (Element_Type => CC54004_0.Alert, + Element_Ptr => CC54004_0.Alert_Ptr); + + -- All overriding versions of Handle visible at the point of instantiation. + + Alert_List : Alert_Stacks.Stack_Type; + + procedure TC_Create_Alert_Stack; + + end CC54004_3; + + + --===================================================================-- + + + package body CC54004_3 is + + procedure TC_Create_Alert_Stack is + begin + Alert_Stacks.Push (Alert_List, new CC54004_1.Low_Alert); + Alert_Stacks.Push (Alert_List, new CC54004_1.Medium_Alert); + end TC_Create_Alert_Stack; + + end CC54004_3; + + + --===================================================================-- + + + with CC54004_0; + with CC54004_1; + with CC54004_3; + + with Report; + procedure CC54004 is + TC_Low_Ptr, TC_Med_Ptr : CC54004_0.Alert_Ptr; + TC_Low_Actual : CC54004_1.Low_Alert; + TC_Med_Actual : CC54004_1.Medium_Alert; + + use type CC54004_0.TC_Code_Type; + begin + Report.Test ("CC54004", "Check that the designated type of a generic " & + "formal pool-specific access type may be class-wide"); + + + -- Create stack of elements: + + CC54004_3.TC_Create_Alert_Stack; + + + -- Commence dispatching operations on stack elements: + + CC54004_3.Alert_Stacks.Process_Stack (CC54004_3.Alert_List); + + + -- Pop "handled" alerts off stack: + + CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Med_Ptr); + CC54004_3.Alert_Stacks.Pop (CC54004_3.Alert_List, TC_Low_Ptr); + + + -- Verify results: + + if TC_Low_Ptr.all not in CC54004_1.Low_Alert or else + TC_Med_Ptr.all not in CC54004_1.Medium_Alert + then + Report.Failed ("Class-wide objects do not have expected tags"); + + -- The explicit dereference of the "Pop"ed pointers results in views of + -- the designated objects, the nominal subtypes of which are class-wide. + -- In order to be able to reference the component TC_Code, these views + -- must be converted to a specific type possessing that component. + + elsif CC54004_1.Low_Alert(TC_Low_Ptr.all).TC_Code /= CC54004_0.Low or + CC54004_1.Medium_Alert(TC_Med_Ptr.all).TC_Code /= CC54004_0.Medium + then + Report.Failed ("Calls did not dispatch to expected operations"); + end if; + + Report.Result; + end CC54004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,309 ---- + -- CC70001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the template for a generic formal package may be a child + -- package, and that a child instance which is an instance of the + -- template may be passed as an actual to the formal package. Check that + -- the visible part of the generic formal package includes the first list + -- of basic declarative items of the package specification. + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type. Declare a generic child package of + -- this package which defines additional list operations. Declare a + -- generic subprogram which operates on lists of elements of discrete + -- types. Provide the generic subprogram with three formal parameters: + -- (1) a formal discrete type which represents a list element type, (2) + -- a generic formal package with the parent list generic as template, and + -- (3) a generic formal package with the child list generic as template. + -- Use the formal discrete type as the generic formal actual part for the + -- parent formal package. In the main program, declare an instance of + -- parent, then declare an instance of the child which is itself a child + -- the parent's instance. Pass these instances as actuals to the generic + -- subprogram instance. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 05 Nov 95 SAIC ACVC 2.0.1 fixes: Corrected syntax of formal + -- package declaration. + -- 27 Feb 97 PWB.CTA Added an elaboration pragma. + --! + + generic + type Element_Type is private; -- List elems may be of any nonlimited type. + package CC70001_0 is -- List abstraction. + + type List_Type is limited private; + + + -- Return true if current element is last in the list. + function End_Of_List (L : List_Type) return Boolean; + + -- Set "current" pointer to first list element. + procedure Reset (L : in out List_Type); + + private + + type Node_Type; + type Node_Pointer is access Node_Type; + + type Node_Type is record + Item : Element_Type; + Next : Node_Pointer; + end record; + + type List_Type is record + First : Node_Pointer; + Current : Node_Pointer; + Last : Node_Pointer; + end record; + + end CC70001_0; + + + --==================================================================-- + + + package body CC70001_0 is + + function End_Of_List (L : List_Type) return Boolean is + begin + return (L.Current = null); + end End_Of_List; + + + procedure Reset (L : in out List_Type) is + begin + L.Current := L.First; -- Set "current" pointer to first + end Reset; -- list element. + + end CC70001_0; + + + --==================================================================-- + + + -- Child must be generic since parent is generic. A formal parameter for + -- "element type" can not be provided here, because then the type of list + -- element assumed by these new operations would be different from that + -- defined by the list type declared in the parent. + + generic + package CC70001_0.CC70001_1 is -- Additional list operations. + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out List_Type; E : out Element_Type); + + -- Write to current element and advance "current" pointer. + procedure Write_Element (L : in out List_Type; E : in Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out List_Type; E : in Element_Type); + + end CC70001_0.CC70001_1; + + + --==================================================================-- + + + package body CC70001_0.CC70001_1 is + + procedure Read_Element (L : in out List_Type; E : out Element_Type) is + begin + -- ... Error-checking code omitted for brevity. + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Read_Element; + + + procedure Write_Element (L : in out List_Type; E : in Element_Type) is + begin + -- ... Error-checking code omitted for brevity. + L.Current.Item := E; -- Write to current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end Write_Element; + + + procedure Add_Element (L : in out List_Type; E : in Element_Type) is + New_Node : Node_Pointer := new Node_Type'(E, null); + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + end CC70001_0.CC70001_1; + + + --==================================================================-- + + + with CC70001_0.CC70001_1; -- Generic list abstraction + additional operations. + generic + + -- Import the list abstraction defined in CC70001_0, as well as the + -- additional operations defined in CC70001_0.CC70001_1. Declare a formal + -- discrete type. Restrict this generic procedure to operate only on lists + -- of discrete elements by passing the formal discrete type as an actual + -- parameter to the formal (parent) package. + + type Elem_Type is (<>); -- Discrete types only. + with package List_Mgr is new CC70001_0 (Elem_Type); + with package List_Ops is new List_Mgr.CC70001_1 (<>); + + procedure CC70001_2 (L : in out List_Mgr.List_Type); + + + --==================================================================-- + + + procedure CC70001_2 (L : in out List_Mgr.List_Type) is + begin + List_Mgr.Reset (L); + while not List_Mgr.End_Of_List (L) loop + List_Ops.Write_Element (L, Elem_Type'First); + end loop; + end CC70001_2; + + + --==================================================================-- + + + package CC70001_3 is + + type Points is range 0 .. 10; + + -- ... Various other types used by the application. + + end CC70001_3; + + + -- No body for CC70001_3; + + + --==================================================================-- + + + -- Declare instances of the generic list packages for the discrete type. + -- In order to establish that the type passed as an actual to the parent + -- generic (CC70001_0) is the one utilized by the child generic (CC70001_1), + -- the instance of the child must itself be declared as a child of the + -- instance of the parent. Since only library units may have or be children, + -- both instances must be library units. + + with CC70001_0; -- Generic list abstraction. + with CC70001_3; -- Package containing discrete type declaration. + pragma Elaborate (CC70001_0); + package CC70001_4 is new CC70001_0 (CC70001_3.Points); + + with CC70001_0.CC70001_1; -- Generic extension to list abstraction. + with CC70001_4; + package CC70001_4.CC70001_5 is new CC70001_4.CC70001_1; + + + --==================================================================-- + + + with CC70001_2; -- Generic "zeroing" op for lists of discrete types. + with CC70001_3; -- Types for application. + with CC70001_4.CC70001_5; -- Discrete list abstraction + additional ops. + + with Report; + procedure CC70001 is + + package Lists_Of_Scores renames CC70001_4; + package Score_Ops renames CC70001_4.CC70001_5; + + Scores : Lists_Of_Scores.List_Type; -- List of points. + + procedure Reset_All_Scores is new CC70001_2 -- Operation on lists of + (Elem_Type => CC70001_3.Points, -- points. + List_Mgr => Lists_Of_Scores, + List_Ops => Score_Ops); + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of CC70001_3.Points; + + TC_Initial_Values : constant TC_Score_Array := (2, 4, 6); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6. + Score_Ops.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_of_Scores.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Score_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + + begin + Report.Test ("CC70001", "Check that the template for a generic formal " & + "package may be a child package, and that a child instance " & + "which is an instance of the template may be passed as an " & + "actual to the formal package. Check that the visible part " & + "of the generic formal package includes the first list of " & + "basic declarative items of the package specification"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Reset_All_Scores (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; + end CC70001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,241 ---- + -- CC70002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a formal package actual part may specify actual parameters + -- for a generic formal package. Check that these actual parameters may + -- be formal types, formal objects, and formal subprograms. Check that + -- the visible part of the generic formal package includes the first list + -- of basic declarative items of the package specification, and that if + -- the formal package actual part is (<>), it also includes the generic + -- formal part of the template for the formal package. + -- + -- TEST DESCRIPTION: + -- Declare a generic package which defines a "signature" for mathematical + -- groups. Declare a second generic package which defines a + -- two-dimensional matrix abstraction. Declare a third generic package + -- which provides mathematical group operations for two-dimensional + -- matrices. Provide this third generic with two formal parameters: (1) + -- a generic formal package with the second generic as template and a + -- (<>) actual part, and (2) a generic formal package with the first + -- generic as template and an actual part that takes a formal type, + -- object, and subprogram from the first formal package as actuals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic -- Mathematical group signature. + + type Group_Type is private; + + Identity : in Group_Type; + + with function Operation (Left, Right : Group_Type) return Group_Type; + -- with function Inverse... (omitted for brevity). + + package CC70002_0 is + + function Power (Left : Group_Type; Right : Integer) return Group_Type; + + -- ... Other group operations. + + end CC70002_0; + + + --==================================================================-- + + + package body CC70002_0 is + + -- The implementation of Power is purely artificial; the validity of its + -- implementation in the context of the abstraction is irrelevant to the + -- feature being tested. + + function Power (Left : Group_Type; Right : Integer) return Group_Type is + Result : Group_Type := Identity; + begin + Result := Operation (Result, Left); -- All this really does is add + return Result; -- one to each matrix element. + end Power; + + end CC70002_0; + + + --==================================================================-- + + + generic -- 2D matrix abstraction. + type Element_Type is range <>; + + type Abscissa is range <>; + type Ordinate is range <>; + + type Matrix_2D is array (Abscissa, Ordinate) of Element_Type; + package CC70002_1 is + + Add_Ident : constant Matrix_2D := (Abscissa => (others => 1)); + -- Artificial for + -- testing purposes. + -- ... Other identity matrices. + + + function "+" (A, B : Matrix_2D) return Matrix_2D; + + -- ... Other operations. + + end CC70002_1; + + + --==================================================================-- + + + package body CC70002_1 is + + function "+" (A, B : Matrix_2D) return Matrix_2D is + C : Matrix_2D; + begin + for I in Abscissa loop + for J in Ordinate loop + C(I,J) := A(I,J) + B(I,J); + end loop; + end loop; + return C; + end "+"; + + end CC70002_1; + + + --==================================================================-- + + + with CC70002_0; -- Mathematical group signature. + with CC70002_1; -- 2D matrix abstraction. + + generic -- Mathematical 2D matrix addition group. + + with package Matrix_Ops is new CC70002_1 (<>); + + -- Although the restriction of the formal package below to signatures + -- describing addition groups, and then only for 2D matrices, is rather + -- artificial in the context of this "application," the passing of types, + -- objects, and subprograms as actuals to a formal package is not. + + with package Math_Sig is new CC70002_0 + (Group_Type => Matrix_Ops.Matrix_2D, + Identity => Matrix_Ops.Add_Ident, + Operation => Matrix_Ops."+"); + + package CC70002_2 is + + -- Add two matrices that are to be multiplied by coefficients: + -- [ ] = CA*[ ] + CB*[ ]. + + function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D; + CA : Integer; + B : Matrix_Ops.Matrix_2D; + CB : Integer) + return Matrix_Ops.Matrix_2D; + + -- ...Other operations. + + end CC70002_2; + + + --==================================================================-- + + + package body CC70002_2 is + + function Add_Matrices_With_Coefficients (A : Matrix_Ops.Matrix_2D; + CA : Integer; + B : Matrix_Ops.Matrix_2D; + CB : Integer) + return Matrix_Ops.Matrix_2D is + Left, Right : Matrix_Ops.Matrix_2D; + begin + Left := Math_Sig.Power (A, CA); -- Multiply 1st array by its coeff. + Right := Math_Sig.Power (B, CB); -- Multiply 2nd array by its coeff. + return (Matrix_Ops."+" (Left, Right));-- Add these two arrays. + end Add_Matrices_With_Coefficients; + + end CC70002_2; + + + --==================================================================-- + + + with CC70002_0; -- Mathematical group signature. + with CC70002_1; -- 2D matrix abstraction. + with CC70002_2; -- Mathematical 2D matrix addition group. + + with Report; + procedure CC70002 is + + subtype Cell_Type is Positive range 1 .. 3; + subtype Category_Type is Positive range 1 .. 2; + + type Data_Points is new Natural range 0 .. 100; + + type Table_Type is array (Cell_Type, Category_Type) of Data_Points; + + package Data_Table_Support is new CC70002_1 (Data_Points, + Cell_Type, + Category_Type, + Table_Type); + + package Data_Table_Addition_Group is new CC70002_0 + (Group_Type => Table_Type, + Identity => Data_Table_Support.Add_Ident, + Operation => Data_Table_Support."+"); + + package Table_Add_Ops is new CC70002_2 + (Data_Table_Support, Data_Table_Addition_Group); + + + Scores_Table : Table_Type := ( ( 12, 0), + ( 21, 33), + ( 49, 9) ); + Expected : Table_Type := ( ( 26, 2), + ( 44, 68), + ( 100, 20) ); + + begin + Report.Test ("CC70002", "Check that a generic formal package actual " & + "part may specify formal objects, formal subprograms, " & + "and formal types"); + + Scores_Table := Table_Add_Ops.Add_Matrices_With_Coefficients + (Scores_Table, 2, + Scores_Table, 1); + + if (Scores_Table /= Expected) then + Report.Failed ("Incorrect result for multi-dimensional array"); + end if; + + Report.Result; + end CC70002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70003.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,212 ---- + -- CC70003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the actual passed to a formal package may be a formal + -- access-to-subprogram type. Check that the visible part of the generic + -- formal package includes the first list of basic declarative items of + -- the package specification. + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type (foundation code). Declare a generic + -- package which supports the execution of lists of operations. Provide + -- the generic package with two formal parameters: (1) a formal access- + -- to-function type, and (2) a generic formal package with the list + -- abstraction package as template. Within a procedure declared in the + -- list-execution package, utilize information about the profile of + -- the functions in the list. Declare a package which declares functions + -- matching the profile of the formal access-to-subprogram type. In the + -- main program, create a list of pointers to the functions declared in + -- the package, instantiate the list abstraction and list-execution + -- packages, and use the list-execution procedure to call each of the + -- functions in the list in sequence. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic + type Element_Type is private; + package CC70003_0 is -- This package simulates a generic list abstraction. + + -- The definition of List_Type below is purely artificial; its validity + -- in the context of the abstraction is irrelevant to the feature being + -- tested. + + type Element_Ptr is access Element_Type; + + subtype List_Size is Natural range 1 .. 2; + type List_Type is array (List_Size) of Element_Ptr; + + function View_Element (I : List_Size; L : List_Type) return Element_Type; + + procedure Write_Element (I : in List_Size; + L : in out List_Type; + E : in Element_Type); + + -- ... Other list operations for Element_Type. + + end CC70003_0; + + + --==================================================================-- + + + package body CC70003_0 is + + -- The implementations of the operations below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function View_Element (I : List_Size; L : List_Type) return Element_Type is + begin + return L(I).all; + end View_Element; + + + procedure Write_Element (I : in List_Size; + L : in out List_Type; + E : in Element_Type) is + begin + L(I) := new Element_Type'(E); + end Write_Element; + + end CC70003_0; + + + --==================================================================-- + + + with CC70003_0; -- Generic list abstraction. + generic + type Elem_Type is access function (F : Float) return Float; + with package List_Mgr is new CC70003_0 (Elem_Type); + package CC70003_1 is -- This package simulates support for executing lists + -- of operations. + + procedure Execute_List (L : List_Mgr.List_Type; F : in out Float); + + -- ... Other operations. + + end CC70003_1; + + + --==================================================================-- + + + package body CC70003_1 is + + procedure Execute_List (L : List_Mgr.List_Type; F : in out Float) is + begin + for I in L'Range loop + F := List_Mgr.View_Element(I, L)(F); -- Execute next operation in + end loop; -- list with current value of + end Execute_List; -- F as operand. + + + end CC70003_1; + + + --==================================================================-- + + + package CC70003_2 is + + function Sine (F : Float) return Float; + function Exp (F : Float) return Float; + + -- ... Other math functions. + + end CC70003_2; + + + --==================================================================-- + + + package body CC70003_2 is + + -- The implementations of the functions below are purely artificial; the + -- validity of their implementations in the context of the abstraction is + -- irrelevant to the feature being tested. + + function Sine (F : Float) return Float is + begin + return (-0.15); + end Sine; + + function Exp (F : Float) return Float is + begin + if (F = 0.0) then + return (-0.69); + else + return (2.0); -- This branch should be taken. + end if; + end Exp; + + end CC70003_2; + + + --==================================================================-- + + + with CC70003_0; -- Generic list abstraction. + with CC70003_1; -- Generic operation-list abstraction. + with CC70003_2; -- Math library. + + with Report; + procedure CC70003 is + + type Math_Op is access function (F : Float) return Float; + + package Math_Op_Lists is new CC70003_0 (Math_Op); + package Math_Op_List_Support is new CC70003_1 (Math_Op, Math_Op_Lists); + + Sin_Ptr : Math_Op := CC70003_2.Sine'Access; + Exp_Ptr : Math_Op := CC70003_2.Exp'Access; + + Op_List : Math_Op_Lists.List_Type; + + Operand : Float := 0.0; + Expected : Float := 2.0; + + + begin + Report.Test ("CC70003", "Check that the actual passed to a formal " & + "package may be a formal access-to-subprogram type"); + + Math_Op_Lists.Write_Element (1, Op_List, Sin_Ptr); + Math_Op_Lists.Write_Element (2, Op_List, Exp_Ptr); + + Math_Op_List_Support.Execute_List (Op_List, Operand); + + if (Operand /= Expected) then + Report.Failed ("Incorrect results from indirect function calls"); + end if; + + Report.Result; + end CC70003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,208 ---- + -- CC70A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the visible part of a generic formal package includes the + -- first list of basic declarative items of the package specification. + -- Check for a generic package which declares a formal package with (<>) + -- as its actual part. + -- + -- TEST DESCRIPTION: + -- The "first list of basic declarative items" of a package specification + -- is the visible part of the package. Thus, the declarations in the + -- visible part of the actual instance corresponding to a formal + -- package are available in the generic which declares the formal package. + -- + -- Declare a generic package which simulates a complex integer abstraction + -- (foundation code). + -- + -- Declare a second, library-level generic package which utilizes the + -- first generic package as a generic formal package (with a (<>) + -- actual_part). In the second generic package, declare objects, types, + -- and operations in terms of the objects, types, and operations declared + -- in the first generic package. + -- + -- In the main program, instantiate the first generic package, then + -- instantiate the second generic package and pass the first instance + -- to it as a generic actual parameter. Check that the operations in + -- the second instance perform as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FC70A00; -- Generic complex integer operations. + + generic -- Generic complex matrix operations. + with package Complex_Package is new FC70A00 (<>); + package CC70A01_0 is + + type Complex_Matrix_Type is -- 1st index is matrix + array (Positive range <>, Positive range <>) -- row, 2nd is column. + of Complex_Package.Complex_Type; + Dimension_Mismatch : exception; + + + function Identity_Matrix (Size : Positive) -- Create identity matrix + return Complex_Matrix_Type; -- of specified size. + + function "*" (Left : Complex_Matrix_Type; -- Multiply two complex + Right : Complex_Matrix_Type) -- matrices. + return Complex_Matrix_Type; + + end CC70A01_0; + + + --==================================================================-- + + + package body CC70A01_0 is -- Generic complex matrix operations. + + use Complex_Package; + + --==============================================-- + + function Inner_Product (Left, Right : Complex_Matrix_Type; + Row, Column : Positive) -- Compute inner product + return Complex_Package.Complex_Type is -- for matrix-multiply. + + Result : Complex_Type := Zero; + subtype Vector_Size is Positive range Left'Range(2); + + begin -- Inner_Product. + for I in Vector_Size loop + Result := Result + -- Complex_Package."+". + (Left(Row, I) * Right(I, Column)); -- Complex_Package."*". + end loop; + return (Result); + end Inner_Product; + + --==============================================-- + + function Identity_Matrix (Size : Positive) return Complex_Matrix_Type is + Result : Complex_Matrix_Type (1 .. Size, 1 .. Size) := + (others => (others => Zero)); -- Zeroes everywhere... + begin + for I in 1 .. Size loop + Result (I, I) := One; -- Ones on the diagonal. + end loop; + return (Result); + end Identity_Matrix; + + --==============================================-- + + function "*" (Left : Complex_Matrix_Type; Right : Complex_Matrix_Type) + return Complex_Matrix_Type is + + subtype Rows is Positive range Left'Range(1); + subtype Columns is Positive range Right'Range(2); + + Result : Complex_Matrix_Type(Rows, Columns); + begin + if Left'Length(2) /= Right'Length(1) then -- # columns of Left must + -- match # rows of Right. + raise Dimension_Mismatch; + else + for I in Rows loop + for J in Columns loop + Result(I, J) := Inner_Product (Left, Right, I, J); + end loop; + end loop; + return (Result); + end if; + end "*"; + + end CC70A01_0; + + + --==================================================================-- + + + with Report; + + with FC70A00; -- Generic complex integer operations. + with CC70A01_0; -- Generic complex matrix operations. + + procedure CC70A01 is + + type My_Integer is range -100 .. 100; + + package My_Complex_Package is new FC70A00 (My_Integer); + package My_Matrix_Package is new CC70A01_0 (My_Complex_Package); + + use My_Complex_Package, -- All user-defined + My_Matrix_Package; -- operators directly + -- visible. + + subtype Matrix_2x2 is Complex_Matrix_Type (1 .. 2, 1 .. 2); + subtype Matrix_2x3 is Complex_Matrix_Type (1 .. 2, 1 .. 3); + + function C (Real, Imag : My_Integer) return Complex_Type renames Complex; + + begin -- Main program. + + Report.Test ("CC70A01", "Check that the visible part of a generic " & + "formal package includes the first list of basic " & + "declarative items of the package specification. Check " & + "for a generic package where formal package has (<>) " & + "actual part"); + + declare + Identity_2x2 : Matrix_2x2 := Identity_Matrix (Size => 2); + Operand_2x3 : Matrix_2x3 := ( ( C(1, 2), C(3, 6), C(5, 1) ), + ( C(0, 3), C(7, 9), C(3, 4) ) ); + Result_2x3 : Matrix_2x3 := ( others => ( others => Zero ) ); + begin + + begin -- Block #1. + Result_2x3 := Identity_2x2 * Operand_2x3; -- Should return + -- Operand_2x3. + if (Result_2x3 /= Operand_2x3) then + Report.Failed ("Incorrect results from matrix multiplication"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised - Block #1"); + end; -- Block #1. + + + begin -- Block #2. + Result_2x3 := Operand_2x3 * Identity_2x2; -- Can't multiply 2x3 + -- by 2x2. + Report.Failed ("Exception Dimension_Mismatch not raised"); + exception + when Dimension_Mismatch => + null; + when others => + Report.Failed ("Unexpected exception raised - Block #2"); + end; -- Block #2. + + end; + + Report.Result; + + end CC70A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70a02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,193 ---- + -- CC70A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the visible part of a generic formal package includes the + -- first list of basic declarative items of the package specification. + -- Check for a generic subprogram which declares a formal package with + -- (<>) as its actual part. + -- + -- TEST DESCRIPTION: + -- The "first list of basic declarative items" of a package specification + -- is the visible part of the package. Thus, the declarations in the + -- visible part of the actual instance corresponding to a formal + -- package are available in the generic which declares the formal package. + -- + -- Declare a generic package which simulates a complex integer abstraction + -- (foundation code). + -- + -- Declare a second generic package which defines a "signature" for + -- mathematical groups. Declare a generic function within a package + -- which utilizes the second generic package as a generic formal package + -- (with a (<>) actual_part). + -- + -- In the main program, instantiate the first generic package, then + -- instantiate the second generic package with objects, types, and + -- operations declared in the first instance. + -- + -- Instantiate the generic function and pass the second instance + -- to it as a generic actual parameter. Check that the instance of the + -- generic function performs as expected. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic -- Mathematical group signature. + + type Group_Type is private; + + Identity : in Group_Type; + + with function Operation (Left, Right : Group_Type) return Group_Type; + with function Inverse (Right : Group_Type) return Group_Type; + + package CC70A02_0 is end; + + -- No body for CC70A02_0. + + + --==================================================================-- + + + with CC70A02_0; -- Mathematical group signature. + + package CC70A02_1 is -- Mathematical group operations. + + -- -- + -- Generic formal package used here -- + -- -- + + generic -- Powers for mathematical groups. + with package Group is new CC70A02_0 (<>); + function Power (Left : Group.Group_Type; Right : Integer) + return Group.Group_Type; + + + end CC70A02_1; + + + --==================================================================-- + + + package body CC70A02_1 is -- Mathematical group operations. + + + + function Power (Left : Group.Group_Type; Right : Integer) + return Group.Group_Type is + Result : Group.Group_Type := Group.Identity; + begin + for I in 1 .. abs(Right) loop -- Repeat group operations + Result := Group.Operation (Result, Left); -- the specified number of + end loop; -- times. + + if Right < 0 then -- If specified power is + return Group.Inverse (Result); -- negative, return the + else -- inverse of the result. + return Result; -- If it is zero, return + end if; -- the identity. + end Power; + + + end CC70A02_1; + + + --==================================================================-- + + + with Report; + + with FC70A00; -- Complex integer abstraction. + with CC70A02_0; -- Mathematical group signature. + with CC70A02_1; -- Mathematical group operations. + + procedure CC70A02 is + + -- Declare an instance of complex integers: + + type My_Integer is range -100 .. 100; + package Complex_Integers is new FC70A00 (My_Integer); + + + -- Define an addition group for complex integers: + + package Complex_Addition_Group is new CC70A02_0 + (Group_Type => Complex_Integers.Complex_Type, -- For complex integers... + Identity => Complex_Integers.Zero, -- Additive identity. + Operation => Complex_Integers."+", -- Additive operation. + Inverse => Complex_Integers."-"); -- Additive inverse. + + function Complex_Multiplication is new -- Multiplication of a + CC70A02_1.Power(Complex_Addition_Group); -- complex integer by a + -- constant. + + + -- Define a multiplication group for complex integers: + + package Complex_Multiplication_Group is new CC70A02_0 + (Group_Type => Complex_Integers.Complex_Type, -- For complex integers... + Identity => Complex_Integers.One, -- Multiplicative identity. + Operation => Complex_Integers."*", -- Multiplicative oper. + Inverse => Complex_Integers.Reciprocal); -- Multiplicative inverse. + + function Complex_Exponentiation is new -- Exponentiation of a + CC70A02_1.Power(Complex_Multiplication_Group); -- complex integer by a + -- constant. + + use Complex_Integers; + + + begin -- Main program. + + Report.Test ("CC70A02", "Check that the visible part of a generic " & + "formal package includes the first list of basic " & + "declarative items of the package specification. Check " & + "for a generic subprogram where formal package has (<>) " & + "actual part"); + + declare + Mult_Operand : constant Complex_Type := Complex ( -4, 9); + Exp_Operand : constant Complex_Type := Complex ( 0, -7); + + Expected_Mult_Result : constant Complex_Type := Complex ( 28, -63); + Expected_Exp_Result : constant Complex_Type := Complex (-49, 0); + begin + + if Complex_Multiplication (Mult_Operand, -7) /= Expected_Mult_Result then + Report.Failed ("Incorrect results from complex multiplication"); + end if; + + if Complex_Exponentiation (Exp_Operand, 2) /= Expected_Exp_Result then + Report.Failed ("Incorrect results from complex exponentiation"); + end if; + + end; + + Report.Result; + + end CC70A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70b01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70b01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70b01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70b01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,170 ---- + -- CC70B01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a formal package actual part may specify actual parameters + -- for a generic formal package. Check that a use clause in the generic + -- formal part provides direct visibility of declarations within the + -- generic formal package. Check that the scope of such a use clause + -- extends to the generic subprogram body. Check that the visible part of + -- the generic formal package includes the first list of basic + -- declarative items of the package specification. + -- + -- Check the case where the formal package is declared in a generic + -- subprogram. + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type (foundation code). Declare a generic + -- subprogram which operates on lists of elements of discrete types. + -- Provide the generic subprogram with two formal parameters: (1) a + -- formal discrete type which represents a list element type, and (2) a + -- generic formal package with the list abstraction package as template. + -- Use the formal discrete type as the generic formal actual part for the + -- formal package. Include a use clause for the formal package in the + -- generic subprogram formal part. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC70B00.A + -- CC70B01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + -- Declare a generic subprogram which performs an operation on lists of + -- discrete objects. + + with FC70B00; -- Generic list abstraction. + generic + + -- Import the list abstraction defined in FC70B00. To ensure that only + -- list abstraction instances defining lists of *discrete* elements will be + -- accepted as actuals to this generic, declare a formal discrete type and + -- pass it as an actual parameter to the formal package. + -- + -- Only instances declared for the same discrete type as that used to + -- instantiate this generic subprogram will be accepted. + + type Elem_Type is (<>); -- Discrete types only. + with package List_Mgr is new FC70B00 (Elem_Type); + + use List_Mgr; -- Use clause for formal package. + + procedure CC70B01_0 (L : in out List_Type); -- List_Mgr.List_Type directly + -- visible. + + + --==================================================================-- + + + procedure CC70B01_0 (L : in out List_Type) is -- Declarations in List_Mgr + begin -- still directly visible. + Reset (L); + while not End_Of_List (L) loop + Write_Element (L, Elem_Type'First); -- This statement assumes + end loop; -- Elem_Type is discrete. + end CC70B01_0; + + + --==================================================================-- + + + with FC70B00; -- Generic list abstraction. + with CC70B01_0; -- Generic "zeroing" operation for lists of discrete types. + + with Report; + procedure CC70B01 is + + type Points is range 0 .. 10; -- Discrete type. + package Lists_of_Scores is new FC70B00 (Points); -- List-of-points + -- abstraction. + Scores : Lists_of_Scores.List_Type; -- List of points. + + procedure Reset_All_Scores is new -- Operation on lists of + CC70B01_0 (Points, Lists_of_Scores); -- points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_Initial_Values : constant TC_Score_Array := (2, 4, 6); + TC_Final_Values : constant TC_Score_Array := (0, 0, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_of_Scores.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 2, 4, and 6. + Lists_of_Scores.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_of_Scores.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_of_Scores.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Lists_of_Scores.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + + begin + Report.Test ("CC70B01", "Check that a library-level generic subprogram " & + "may have a formal package as a formal parameter, and that " & + "the generic formal actual part may specify explicit actual " & + "parameters. Check that a use clause is legal in the " & + "generic formal part"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Reset_All_Scores (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; + end CC70B01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70b02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70b02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70b02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70b02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,222 ---- + -- CC70B02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a formal package actual part may specify actual parameters + -- for a generic formal package. Check that such an actual parameter may + -- be a formal parameter of a previously declared formal package + -- (with a (<>) actual part). Check that a use clause in the generic + -- formal part provides direct visibility of declarations within the + -- generic formal package, including formal parameters (if the formal + -- package has a (<>) actual part). Check that the scope of such a use + -- clause extends to the generic subprogram body. Check that the visible + -- part of the generic formal package includes the first list of basic + -- declarative items of the package specification. + -- + -- Check the case where the formal package is declared in a generic + -- package. + -- + -- TEST DESCRIPTION: + -- Declare a list abstraction in a generic package which manages lists of + -- elements of any nonlimited type (foundation code). Declare a second + -- generic package which declares operations on discrete types. Declare + -- a third generic package which combines the abstractions of the first + -- two generics and declares operations on lists of elements of discrete + -- types. Provide the third generic package with two formal parameters: + -- (1) a generic formal package with the discrete operation package as + -- template, and (2) a generic formal package with the list abstraction + -- package as template. Use the formal discrete type of the discrete + -- operations generic as the generic formal actual part for the second + -- formal package. Include a use clause for the first formal package in + -- the third generic package formal part. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC70B00.A + -- CC70B02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + generic + type Discrete_Type is (<>); -- Discrete types only. + package CC70B02_0 is -- Discrete type operations. + + procedure Double (Object : in out Discrete_Type); + + -- ... Other operations on discrete objects. + + end CC70B02_0; + + + --==================================================================-- + + + package body CC70B02_0 is + + procedure Double (Object : in out Discrete_Type) is + Doubled_Position : Integer := Discrete_Type'Pos (Object) * 2; + begin + -- ... Error-checking code omitted for brevity. + Object := Discrete_Type'Val (Doubled_Position); + end Double; + + end CC70B02_0; + + + --==================================================================-- + + + with CC70B02_0; -- Discrete type operations. + with FC70B00; -- List abstraction. + generic + + -- Import both the discrete-operation and list abstractions. To ensure that + -- only list abstraction instances defining lists of *discrete* elements + -- will be accepted as actuals to this generic, pass the formal discrete + -- type from the discrete-operation abstraction as an actual parameter to + -- the list-abstraction formal package. + -- + -- Only list instances declared for the same discrete type as that used + -- to instantiate the discrete-operation package will be accepted. + + with package Discrete_Ops is new CC70B02_0 (<>); + + use Discrete_Ops; -- Discrete_Ops directly visible. + + with package List_Mgr is new FC70B00 (Discrete_Type); -- Discrete_Type is + -- formal parameter + -- of template for + -- Discrete_Ops. + package CC70B02_1 is -- Discrete list operations. + + procedure Double_List (L : in out List_Mgr.List_Type); + + -- ... Other operations on lists of discrete objects. + + end CC70B02_1; + + + --==================================================================-- + + + package body CC70B02_1 is + + procedure Double_List (L : in out List_Mgr.List_Type) is + Element : Discrete_Type; -- Formal part of Discrete_Ops template + begin -- is directly visible here. + List_Mgr.Reset (L); + while not List_Mgr.End_Of_List (L) loop + List_Mgr.View_Element (L, Element); + Double (Element); + List_Mgr.Write_Element (L, Element); + end loop; + end Double_List; + + end CC70B02_1; + + + --==================================================================-- + + + with FC70B00; -- Generic list abstraction. + with CC70B02_0; -- Generic discrete type operations. + with CC70B02_1; -- Generic discrete list operations. + + with Report; + procedure CC70B02 is + + type Points is range 0 .. 100; -- Discrete type. + + package Points_Ops is new CC70B02_0 (Points); -- Points-type operations. + package Lists_of_Points is new FC70B00 (Points); -- Points lists. + package Points_List_Ops is new -- Points-list operations. + CC70B02_1 (Points_Ops, Lists_Of_Points); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_Initial_Values : constant TC_Score_Array := (23, 15, 0); + TC_Final_Values : constant TC_Score_Array := (46, 30, 0); + + TC_Correct_Initial_Values : Boolean := False; + TC_Correct_Final_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Lists_Of_Points.Add_Element (L, TC_Initial_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin -- Verify that all scores have been + Lists_Of_Points.Reset (L); -- set to zero. + for I in TC_Score_Array'Range loop + Lists_Of_Points.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + + begin + Report.Test ("CC70B02", "Check that a library-level generic package " & + "may have a formal package as a formal parameter, and that " & + "the generic formal actual part may specify explicit actual " & + "parameters (including a formal parameter of a previously " & + "declared formal package). Check that a use clause is legal " & + "in the generic formal part"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_Initial_Values, TC_Correct_Initial_Values); + + if not TC_Correct_Initial_Values then + Report.Failed ("List contains incorrect initial values"); + end if; + + Points_List_Ops.Double_List (Scores); + TC_Verify_List (Scores, TC_Final_Values, TC_Correct_Final_Values); + + if not TC_Correct_Final_Values then + Report.Failed ("List contains incorrect final values"); + end if; + + Report.Result; + end CC70B02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70c01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70c01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70c01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70c01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- CC70C01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a generic formal package is an instance. Specifically, + -- check that a generic formal package may be passed as an actual + -- parameter in an instantiation of a generic package. Check that the + -- visible part of the generic formal package includes the first list of + -- basic declarative items of the package specification. + -- + -- TEST DESCRIPTION: + -- A generic formal package is a package, and is an instance. + -- + -- Declare a list type in a generic package for lists of elements of any + -- nonlimited type (foundation code). Declare a second generic package + -- which declares operations for the list type, and parameterize it with + -- a generic formal package with the list-type package as template + -- (foundation code). Declare a third generic package which declares + -- additional operations for the list type, and parameterize it just like + -- the second generic package. Declare an instance of the second generic + -- in the spec of the third generic, passing the formal package as the + -- actual. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC70C00.A + -- CC70C01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FC70C00_0; -- List abstraction. + with FC70C00_1; -- Basic list operations. + generic + with package Lists is new FC70C00_0 (<>); + package CC70C01_0 is -- Additional list operations. + + -- Instantiate a generic package (FC70C00_1) with a generic formal package + -- (Lists). This ensures that the package passed as an actual corresponding + -- to Lists is the same one passed as an actual to FC70C00_1. Thus, all list + -- operations from both FC70C00_1 and this package operate on lists of the + -- same element type. + + package Basic_List_Ops is new FC70C00_1 (Lists); + + + End_of_List_Reached : exception; + + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type); + + end CC70C01_0; + + + --==================================================================-- + + + package body CC70C01_0 is + + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type) is + begin + if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous + raise End_Of_List_Reached; -- generic package. + else + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end if; + end Read_Element; + + + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type) is + New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null); + use type Lists.Node_Pointer; + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + + end CC70C01_0; + + + --==================================================================-- + + + with FC70C00_0; -- Generic list abstraction. + with CC70C01_0; -- Additional generic list operations. + + with Report; + procedure CC70C01 is + + type Points is range 0 .. 100; -- Discrete type. + + package Lists_of_Points is new FC70C00_0 (Points); -- Points lists. + + package Points_List_Ops is new -- Points-list ops. + CC70C01_0 (Lists_Of_Points); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_List_Values : constant TC_Score_Array := (23, 15, 0); + + TC_Correct_List_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Points_List_Ops.Add_Element (L, TC_List_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin + Points_List_Ops.Basic_List_Ops.Reset (L); + for I in TC_Score_Array'Range loop + Points_List_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + + begin + + Report.Test ("CC70C01", "Check that a generic formal package may be " & + "passed as an actual in an instantiation of a generic " & + "package"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values); + + if not TC_Correct_List_Values then + Report.Failed ("List contains incorrect values"); + end if; + + Report.Result; + + end CC70C01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70c02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70c02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cc/cc70c02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cc/cc70c02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- CC70C02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a generic formal package is an instance. Specifically, + -- check that a generic formal package may be passed as an actual + -- parameter to another generic formal package. Check that the + -- visible part of the generic formal package includes the first list of + -- basic declarative items of the package specification. + -- + -- TEST DESCRIPTION: + -- A generic formal package is a package, and is an instance. + -- + -- Declare a list type in a generic package for lists of elements of any + -- nonlimited type (foundation code). Declare a second generic package + -- which declares operations for the list type, and parameterize it with + -- a generic formal package with the list-type package as template + -- (foundation code). Declare a third generic package which declares + -- additional operations for the list type, and parameterize it with two + -- generic formal packages, one with the list-type package as template, + -- the other with the second generic package as template. Use the first + -- formal package as the generic formal actual part for the second formal + -- package. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FC70C00.A + -- CC70C02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FC70C00_0; -- List abstraction. + with FC70C00_1; -- Basic list operations. + generic + + -- Import both the list-type abstraction defined in FC70C00_0 and the basic + -- list operations defined in FC70C00_1. To ensure that only basic operation + -- instances for lists of the same element type as that used to instantiate + -- the list type are accepted as actuals to this generic, pass the list-type + -- formal package as an actual parameter to the list-operation formal + -- package. + + with package Lists is new FC70C00_0 (<>); + with package Basic_List_Ops is new FC70C00_1 (Lists); + package CC70C02_0 is -- Additional list operations. + + End_of_List_Reached : exception; + + + -- Read from current element and advance "current" pointer. + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type); + + -- Add element to end of list. + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type); + + end CC70C02_0; + + + --==================================================================-- + + + package body CC70C02_0 is + + procedure Read_Element (L : in out Lists.List_Type; + E : out Lists.Element_Type) is + begin + if Basic_List_Ops.End_Of_List (L) then -- Use of op from the previous + raise End_Of_List_Reached; -- generic package. + else + E := L.Current.Item; -- Retrieve current element. + L.Current := L.Current.Next; -- Advance "current" pointer. + end if; + end Read_Element; + + + procedure Add_Element (L : in out Lists.List_Type; + E : in Lists.Element_Type) is + New_Node : Lists.Node_Pointer := new Lists.Node_Type'(E, null); + use type Lists.Node_Pointer; + begin + if L.First = null then -- No elements in list, so add new + L.First := New_Node; -- element at beginning of list. + else + L.Last.Next := New_Node; -- Add new element at end of list. + end if; + L.Last := New_Node; -- Set last-in-list pointer. + end Add_Element; + + + end CC70C02_0; + + + --==================================================================-- + + + with FC70C00_0; -- Generic list type abstraction. + with FC70C00_1; -- Generic list operations. + with CC70C02_0; -- Additional generic list operations. + + with Report; + procedure CC70C02 is + + type Points is range 0 .. 100; -- Discrete type. + + package Lists_of_Points is new FC70C00_0 (Points); -- Points lists. + + package Basic_Point_Ops is new -- Basic points-list ops. + FC70C00_1 (Lists_Of_Points); + + package Points_List_Ops is new -- More points-list ops. + CC70C02_0 (Lists => Lists_Of_Points, + Basic_List_Ops => Basic_Point_Ops); + + Scores : Lists_of_Points.List_Type; -- List of points. + + + -- Begin test code declarations: ----------------------- + + type TC_Score_Array is array (1 .. 3) of Points; + + TC_List_Values : constant TC_Score_Array := (23, 15, 0); + + TC_Correct_List_Values : Boolean := False; + + + procedure TC_Initialize_List (L : in out Lists_Of_Points.List_Type) is + begin -- Initial list contains 3 scores + for I in TC_Score_Array'Range loop -- with the values 23, 15, and 0. + Points_List_Ops.Add_Element (L, TC_List_Values(I)); + end loop; + end TC_Initialize_List; + + + procedure TC_Verify_List (L : in out Lists_Of_Points.List_Type; + Expected : in TC_Score_Array; + OK : out Boolean) is + Actual : TC_Score_Array; + begin + Basic_Point_Ops.Reset (L); + for I in TC_Score_Array'Range loop + Points_List_Ops.Read_Element (L, Actual(I)); + end loop; + OK := (Actual = Expected); + end TC_Verify_List; + + -- End test code declarations. ------------------------- + + + begin + + Report.Test ("CC70C02", "Check that a generic formal package may be " & + "passed as an actual to another formal package"); + + TC_Initialize_List (Scores); + TC_Verify_List (Scores, TC_List_Values, TC_Correct_List_Values); + + if not TC_Correct_List_Values then + Report.Failed ("List contains incorrect values"); + end if; + + Report.Result; + + end CC70C02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd10001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd10001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd10001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd10001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,300 ---- + -- CD10001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that representation items may contain nonstatic expressions + -- in the case that each expression in the representation item is a + -- name that statically denotes a constant declared before the entity. + -- + -- + -- TEST DESCRIPTION: + -- For each of the specific items in the objective, this test checks + -- an example of each of the categories of representation specification + -- that are applicable to that objective, to wit: + -- address clause ....................... Expressions need not be static + -- alignment clause ..................... Expressions must be static + -- bit order clause ..................... Not tested + -- component size clause ................ Expressions must be static + -- enumeration representation clause .... Expressions must be static + -- external tag clause .................. Expressions must be static + -- Import, Export and Convention pragmas Not tested + -- input clause ......................... Not tested + -- output clause ........................ Not tested + -- Pack pragma .......................... Not tested + -- read clause .......................... Not tested + -- record representation clause ......... Expressions must be static + -- size clause .......................... Expressions must be static + -- small clause ......................... Expressions must be static + -- storage pool clause .................. Not tested + -- storage size clause .................. Expressions must be static + -- write clause ......................... Not tested + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute. + -- + -- For implementations not validating against Annex C: + -- if this test compiles without error messages at compilation, + -- it must bind and execute. + -- + -- PASS/FAIL CRITERIA: + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute, report PASSED, and complete normally, + -- otherwise the test FAILS + -- + -- For implementations not validating against Annex C: + -- PASSING behavior is: + -- this test executes, reports PASSED, and completes normally + -- or + -- this test executes and reports NOT_APPLICABLE + -- or + -- this test produces at least one error message at compilation, and + -- the error message is associated with one of the items marked: + -- -- N/A => ERROR. + -- + -- All other behaviors are FAILING. + -- + + -- CHANGE HISTORY: + -- 11 JUL 95 SAIC Initial version + -- 10 MAR 97 PWB.CTA Made Nonstatic_Entity nonstatic; changed + -- Tenths'Small from 1.0/32.0 to 1.0/10.0, + -- as expected by the later check; improved + -- internal documentation. + -- 16 FEB 98 EDS Modified test documentation. + -- 24 NOV 98 RLB Changed Tenths'Small to 1.0/32.0, as this is + -- necessary so that all implementations can + -- process this test. (3.5.9(21) means non-binary + -- smalls are optional.) + -- 11 MAR 99 RLB Merged versions. Most EDS changes removed (as + -- they made the test less applicable than the ACAA + -- version). + --! + + ----------------------------------------------------------------- CD10001_0 + + with System; + with System.Storage_Elements; + with Impdef; + with SPPRT13; + package CD10001_0 is + + -- a few types and objects to work with. + + type Int is range -2048 .. 2047; + My_Int : Int := 1024; + + type Enumeration is (First, Second, Third, Fourth, Fifth); + + -- a few names that statically denote constants: + + Nonstatic_Entity : constant System.Address := -- Non-static + System.Storage_Elements."+" + ( SPPRT13.Variable_Address, + System.Storage_Elements.Storage_Offset'(0) ); + + Tag_String : constant String := Impdef.External_Tag_Value; -- Static + -- Check to ensure that Tag_String is static + Tag_String_Length : constant := Tag_String'Length; + + A_Reasonable_Size_Value : constant := System.Storage_Unit; -- Static + + Zero : constant := 0; -- Static + One : constant := 1; -- Static + Two : constant := 2; -- Static + Three : constant := 3; -- Static + Four : constant := 4; -- Static + Five : constant := 5; -- Static + + K : constant Int := My_Int; -- Non-Static + + -- Check that representation items containing nonstatic expressions are + -- supported in the case that the representation item is a name that + -- statically denotes a constant declared before the entity. + -- + -- address clause + -- Expression must be static - RM 13.3(12) + + Object_Address : Enumeration; + for Object_Address'Address use Nonstatic_Entity; -- N/A => ERROR. + + -- alignment clause + -- Expression must be static - RM 13.3(25) + + Object_Alignment : Enumeration; + for Object_Alignment'Alignment use One; -- N/A => ERROR. + + -- bit order clause + -- no interesting test can be specified + + -- component size clause + -- Expression must be static - RM 13.3(69) + + type Array_With_Components is array(1..10) of Enumeration; + for Array_With_Components'Component_Size + use A_Reasonable_Size_Value; -- N/A => ERROR. + + -- enumeration representation clause + -- Expressions must be static - RM 13.4(6) + + type Enumeration_1 is (First, Second, Third); + for Enumeration_1 use (First => One, Second => Two, Third => Three); + + -- external tag clause + -- Expression must be static - RM 13.3(75) + + type Some_Tagged_Type is tagged null record; + for Some_Tagged_Type'External_Tag use Tag_String; -- N/A => ERROR. + + -- Import, Export and Convention pragmas + -- no interesting test can be specified + + -- input clause + -- no interesting test can be specified + + -- output clause + -- no interesting test can be specified + + -- Pack pragma + -- no interesting test can be specified + + -- read clause + -- no interesting test can be specified + + -- record representation clause + -- Expressions must be static - RM 13.3(10) + + type Record_To_Layout is record + Bit_0 : Boolean; + Bit_1 : Boolean; + end record; + for Record_To_Layout use record -- N/A => ERROR. + Bit_0 at Zero range Zero..Zero; -- N/A => ERROR. + Bit_1 at Zero range Four..Four; -- N/A => ERROR. + end record; -- N/A => ERROR. + + -- size clause + -- Expression must be static - RM 13.3(41) + + Object_Size : Enumeration; + for Object_Size'Size use A_Reasonable_Size_Value; -- N/A => ERROR. + + -- small clause + -- Expression must be static - RM 3.5.10(2) + + type Tenths is delta 0.1 range 0.0..10.0; + for Tenths'Small use 1.0 / (Two ** Five); -- N/A => ERROR. + + -- storage pool clause + -- Not tested + + -- storage size clause + -- Expression may be non-static - RM 13.11(15) + type Reference is access Record_To_Layout; + for Reference'Storage_Size use Four * K; -- N/A => ERROR. + + + -- write clause + -- no interesting test can be specified + + procedure TC_Check_Values; + + end CD10001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body CD10001_0 is + + use type System.Address; + + procedure Assert( Truth : Boolean; Message: String ) is + begin + if not Truth then + TCTouch.Implementation_Check( Message ); + end if; + end Assert; + + procedure TC_Check_Values is + Record_Object : Record_To_Layout; + begin + + Assert(Object_Address'Address = Nonstatic_Entity, + "Object not at specified address"); + + Assert(Object_Alignment'Alignment >= One, + "Object not at specified alignment"); + + Assert(Array_With_Components'Component_Size = A_Reasonable_Size_Value, + "Array Components not specified size"); + + -- I don't see how to reliably check this one: + -- + -- type Enumeration_1 is (First, Second, Third); + -- for Enumeration_1 use (First => One, Second => Two, Third => Three); + + Assert(Some_Tagged_Type'External_Tag = Tag_String, + "External_Tag not specified value"); + Assert(Record_Object.Bit_0'First_Bit = Zero, + "Record object First_Bit not zero"); + + Assert(Record_Object.Bit_1'Last_Bit = Four, + "Record object Last_Bit not four"); + + Assert(Object_Size'Size = A_Reasonable_Size_Value, + "Object size not specified value"); + + Assert(Tenths'Small = 1.0 / Two ** Five, + "Tenths small not specified value"); + + Assert(Reference'Storage_Size = 4096, -- Four * K, + "Reference storage size not specified value"); + + end TC_Check_Values; + + end CD10001_0; + + ------------------------------------------------------------------- CD10001 + + with Report; + with CD10001_0; + + procedure CD10001 is + + begin -- Main test procedure. + + Report.Test ("CD10001", "Check that representation items containing " & + "nonstatic expressions are supported in the " & + "case that the representation item is a name " & + "that statically denotes a constant declared " & + "before the entity" ); + + CD10001_0.TC_Check_Values; + + Report.Result; + + end CD10001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd10002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd10002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd10002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd10002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,1198 ---- + -- CD10002.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that operational items are allowed in some contexts where + -- representation items are not: + -- + -- 1 - Check that the name of an incompletely defined type can be used + -- when specifying an operational item. (RM95/TC1 7.3(5)). + -- + -- 2 - Check that operational items can be specified for a descendant of + -- a generic formal untagged type. (RM95/TC1 13.1(10)). + -- + -- 3 - Check that operational items can be specified for a derived + -- untagged type even if the parent type is a by-reference type or + -- has user-defined primitive subprograms. (RM95/TC1 13.1(11/1)). + -- + -- (Defect Report 8652/0009, as reflected in Technical Corrigendum 1). + -- + -- CHANGE HISTORY: + -- 19 JAN 2001 PHL Initial version. + -- 3 DEC 2001 RLB Reformatted for ACATS. + -- 3 OCT 2002 RLB Corrected incorrect type derivations. + -- + --! + with Ada.Streams; + use Ada.Streams; + package CD10002_0 is + + type Kinds is (Read, Write, Input, Output); + type Counts is array (Kinds) of Natural; + + generic + type T is private; + package Nonlimited_Stream_Ops is + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T); + function Input (Stream : access Root_Stream_Type'Class) return T; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T); + + function Get_Counts return Counts; + + end Nonlimited_Stream_Ops; + + generic + type T (<>) is limited private; -- Should be self-initializing. + C : in out T; + package Limited_Stream_Ops is + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T); + function Input (Stream : access Root_Stream_Type'Class) return T; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T); + + function Get_Counts return Counts; + + end Limited_Stream_Ops; + + end CD10002_0; + + + package body CD10002_0 is + + package body Nonlimited_Stream_Ops is + Cnts : Counts := (others => 0); + X : T; -- Initialized by Write/Output. + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is + begin + X := Item; + Cnts (Write) := Cnts (Write) + 1; + end Write; + + function Input (Stream : access Root_Stream_Type'Class) return T is + begin + Cnts (Input) := Cnts (Input) + 1; + return X; + end Input; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is + begin + Cnts (Read) := Cnts (Read) + 1; + Item := X; + end Read; + + procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is + begin + X := Item; + Cnts (Output) := Cnts (Output) + 1; + end Output; + + function Get_Counts return Counts is + begin + return Cnts; + end Get_Counts; + + end Nonlimited_Stream_Ops; + + package body Limited_Stream_Ops is + Cnts : Counts := (others => 0); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Write) := Cnts (Write) + 1; + end Write; + + function Input (Stream : access Root_Stream_Type'Class) return T is + begin + Cnts (Input) := Cnts (Input) + 1; + return C; + end Input; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T) is + begin + Cnts (Read) := Cnts (Read) + 1; + end Read; + + procedure Output (Stream : access Root_Stream_Type'Class; Item : T) is + begin + Cnts (Output) := Cnts (Output) + 1; + end Output; + + function Get_Counts return Counts is + begin + return Cnts; + end Get_Counts; + + end Limited_Stream_Ops; + + end CD10002_0; + + + with Ada.Streams; + use Ada.Streams; + package CD10002_1 is + + type Dummy_Stream is new Root_Stream_Type with null record; + procedure Read (Stream : in out Dummy_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + procedure Write (Stream : in out Dummy_Stream; + Item : Stream_Element_Array); + + end CD10002_1; + + + with Report; + use Report; + package body CD10002_1 is + + procedure Read (Stream : in out Dummy_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + Failed ("Unexpected call to the Read operation of Dummy_Stream"); + end Read; + + procedure Write (Stream : in out Dummy_Stream; + Item : Stream_Element_Array) is + begin + Failed ("Unexpected call to the Write operation of Dummy_Stream"); + end Write; + + end CD10002_1; + + + with Ada.Streams; + use Ada.Streams; + with CD10002_0; + package CD10002_Deriv is + + -- Parent has user-defined subprograms. + + type T1 is new Boolean; + function Is_Odd (X : Integer) return T1; + + type T2 is + record + F : Float; + end record; + procedure Print (X : T2); + + type T3 is array (Boolean) of Duration; + function "+" (L, R : T3) return T3; + + -- Parent is by-reference. No need to check the case where the parent + -- is tagged, because the defect report only deals with untagged types. + + task type T4 is + end T4; + + protected type T5 is + end T5; + + type T6 (D : access Integer := new Integer'(2)) is limited null record; + + type T7 is array (Character) of T6; + + package P is + type T8 is limited private; + private + type T8 is new T5; + end P; + + type Nt1 is new T1; + type Nt2 is new T2; + type Nt3 is new T3; + type Nt4 is new T4; + type Nt5 is new T5; + type Nt6 is new T6; + type Nt7 is new T7; + type Nt8 is new P.T8; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt1'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2); + function Input (Stream : access Root_Stream_Type'Class) return Nt2; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3); + function Input (Stream : access Root_Stream_Type'Class) return Nt3; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4); + function Input (Stream : access Root_Stream_Type'Class) return Nt4; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5); + function Input (Stream : access Root_Stream_Type'Class) return Nt5; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6); + function Input (Stream : access Root_Stream_Type'Class) return Nt6; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7); + function Input (Stream : access Root_Stream_Type'Class) return Nt7; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8); + function Input (Stream : access Root_Stream_Type'Class) return Nt8; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8); + + for Nt1'Write use Write; + for Nt1'Read use Read; + for Nt1'Output use Output; + for Nt1'Input use Input; + + for Nt2'Write use Write; + for Nt2'Read use Read; + for Nt2'Output use Output; + for Nt2'Input use Input; + + for Nt3'Write use Write; + for Nt3'Read use Read; + for Nt3'Output use Output; + for Nt3'Input use Input; + + for Nt4'Write use Write; + for Nt4'Read use Read; + for Nt4'Output use Output; + for Nt4'Input use Input; + + for Nt5'Write use Write; + for Nt5'Read use Read; + for Nt5'Output use Output; + for Nt5'Input use Input; + + for Nt6'Write use Write; + for Nt6'Read use Read; + for Nt6'Output use Output; + for Nt6'Input use Input; + + for Nt7'Write use Write; + for Nt7'Read use Read; + for Nt7'Output use Output; + for Nt7'Input use Input; + + for Nt8'Write use Write; + for Nt8'Read use Read; + for Nt8'Output use Output; + for Nt8'Input use Input; + + -- All these variables are self-initializing. + C4 : Nt4; + C5 : Nt5; + C6 : Nt6; + C7 : Nt7; + C8 : Nt8; + + package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base); + package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2); + package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3); + package Nt4_Ops is new CD10002_0.Limited_Stream_Ops (Nt4, C4); + package Nt5_Ops is new CD10002_0.Limited_Stream_Ops (Nt5, C5); + package Nt6_Ops is new CD10002_0.Limited_Stream_Ops (Nt6, C6); + package Nt7_Ops is new CD10002_0.Limited_Stream_Ops (Nt7, C7); + package Nt8_Ops is new CD10002_0.Limited_Stream_Ops (Nt8, C8); + + end CD10002_Deriv; + + + package body CD10002_Deriv is + + function Is_Odd (X : Integer) return T1 is + begin + return True; + end Is_Odd; + procedure Print (X : T2) is + begin + null; + end Print; + function "+" (L, R : T3) return T3 is + begin + return (False => L (False) + R (True), True => L (True) + R (False)); + end "+"; + task body T4 is + begin + null; + end T4; + protected body T5 is + end T5; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base + renames Nt1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base) + renames Nt1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2) + renames Nt2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt2 + renames Nt2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2) + renames Nt2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2) + renames Nt2_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3) + renames Nt3_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt3 + renames Nt3_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3) + renames Nt3_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3) + renames Nt3_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4) + renames Nt4_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt4 + renames Nt4_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4) + renames Nt4_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4) + renames Nt4_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5) + renames Nt5_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt5 + renames Nt5_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5) + renames Nt5_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5) + renames Nt5_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6) + renames Nt6_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt6 + renames Nt6_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6) + renames Nt6_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6) + renames Nt6_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt7 + renames Nt7_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7) + renames Nt7_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8) + renames Nt8_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt8 + renames Nt8_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8) + renames Nt8_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8) + renames Nt8_Ops.Output; + + end CD10002_Deriv; + + + with Ada.Streams; + use Ada.Streams; + with CD10002_0; + generic + type T1 is (<>); + type T2 is range <>; + type T3 is mod <>; + type T4 is digits <>; + type T5 is delta <>; + type T6 is delta <> digits <>; + type T7 is access T3; + type T8 is new Boolean; + type T9 is private; + type T10 (<>) is limited private; -- Should be self-initializing. + C10 : in out T10; + type T11 is array (T1) of T2; + package CD10002_Gen is + + -- Direct descendants. + type Nt1 is new T1; + type Nt2 is new T2; + type Nt3 is new T3; + type Nt4 is new T4; + type Nt5 is new T5; + type Nt6 is new T6; + type Nt7 is new T7; + type Nt8 is new T8; + type Nt9 is new T9; + type Nt10 is new T10; + type Nt11 is new T11; + + -- Indirect descendants (only pick two, a limited one and a non-limited + -- one). + type Nt12 is new Nt10; + type Nt13 is new Nt11; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt1'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt2'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt3'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt4'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt5'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt6'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7); + function Input (Stream : access Root_Stream_Type'Class) return Nt7; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base); + function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base; + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Nt8'Base); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9); + function Input (Stream : access Root_Stream_Type'Class) return Nt9; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10); + function Input (Stream : access Root_Stream_Type'Class) return Nt10; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11); + function Input (Stream : access Root_Stream_Type'Class) return Nt11; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12); + function Input (Stream : access Root_Stream_Type'Class) return Nt12; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13); + function Input (Stream : access Root_Stream_Type'Class) return Nt13; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13); + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13); + + for Nt1'Write use Write; + for Nt1'Read use Read; + for Nt1'Output use Output; + for Nt1'Input use Input; + + for Nt2'Write use Write; + for Nt2'Read use Read; + for Nt2'Output use Output; + for Nt2'Input use Input; + + for Nt3'Write use Write; + for Nt3'Read use Read; + for Nt3'Output use Output; + for Nt3'Input use Input; + + for Nt4'Write use Write; + for Nt4'Read use Read; + for Nt4'Output use Output; + for Nt4'Input use Input; + + for Nt5'Write use Write; + for Nt5'Read use Read; + for Nt5'Output use Output; + for Nt5'Input use Input; + + for Nt6'Write use Write; + for Nt6'Read use Read; + for Nt6'Output use Output; + for Nt6'Input use Input; + + for Nt7'Write use Write; + for Nt7'Read use Read; + for Nt7'Output use Output; + for Nt7'Input use Input; + + for Nt8'Write use Write; + for Nt8'Read use Read; + for Nt8'Output use Output; + for Nt8'Input use Input; + + for Nt9'Write use Write; + for Nt9'Read use Read; + for Nt9'Output use Output; + for Nt9'Input use Input; + + for Nt10'Write use Write; + for Nt10'Read use Read; + for Nt10'Output use Output; + for Nt10'Input use Input; + + for Nt11'Write use Write; + for Nt11'Read use Read; + for Nt11'Output use Output; + for Nt11'Input use Input; + + for Nt12'Write use Write; + for Nt12'Read use Read; + for Nt12'Output use Output; + for Nt12'Input use Input; + + for Nt13'Write use Write; + for Nt13'Read use Read; + for Nt13'Output use Output; + for Nt13'Input use Input; + + type Null_Record is null record; + + package Nt1_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt1'Base); + package Nt2_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt2'Base); + package Nt3_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt3'Base); + package Nt4_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt4'Base); + package Nt5_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt5'Base); + package Nt6_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt6'Base); + package Nt7_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt7); + package Nt8_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt8'Base); + package Nt9_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt9); + package Nt11_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt11); + package Nt13_Ops is new CD10002_0.Nonlimited_Stream_Ops (Nt13); + + function Get_Nt10_Counts return CD10002_0.Counts; + function Get_Nt12_Counts return CD10002_0.Counts; + + end CD10002_Gen; + + + package body CD10002_Gen is + + use CD10002_0; + + Nt10_Cnts : Counts := (others => 0); + Nt12_Cnts : Counts := (others => 0); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt1'Base + renames Nt1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt1'Base) + renames Nt1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt1'Base) + renames Nt1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt2'Base) + renames Nt2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt2'Base + renames Nt2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt2'Base) + renames Nt2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt2'Base) + renames Nt2_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt3'Base) + renames Nt3_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt3'Base + renames Nt3_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt3'Base) + renames Nt3_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt3'Base) + renames Nt3_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt4'Base) + renames Nt4_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt4'Base + renames Nt4_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt4'Base) + renames Nt4_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt4'Base) + renames Nt4_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt5'Base) + renames Nt5_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt5'Base + renames Nt5_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt5'Base) + renames Nt5_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt5'Base) + renames Nt5_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt6'Base) + renames Nt6_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt6'Base + renames Nt6_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt6'Base) + renames Nt6_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt6'Base) + renames Nt6_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt7 + renames Nt7_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt7) + renames Nt7_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt7) + renames Nt7_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt8'Base) + renames Nt8_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt8'Base + renames Nt8_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt8'Base) + renames Nt8_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt8'Base) + renames Nt8_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt9) + renames Nt9_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt9 + renames Nt9_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt9) + renames Nt9_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt9) + renames Nt9_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt10) is + begin + Nt10_Cnts (Write) := Nt10_Cnts (Write) + 1; + end Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt10 is + begin + Nt10_Cnts (Input) := Nt10_Cnts (Input) + 1; + return Nt10 (C10); + end Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt10) is + begin + Nt10_Cnts (Read) := Nt10_Cnts (Read) + 1; + end Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt10) is + begin + Nt10_Cnts (Output) := Nt10_Cnts (Output) + 1; + end Output; + function Get_Nt10_Counts return CD10002_0.Counts is + begin + return Nt10_Cnts; + end Get_Nt10_Counts; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt11) + renames Nt11_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt11 + renames Nt11_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt11) + renames Nt11_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt11) + renames Nt11_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt12) is + begin + Nt12_Cnts (Write) := Nt12_Cnts (Write) + 1; + end Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt12 is + begin + Nt12_Cnts (Input) := Nt12_Cnts (Input) + 1; + return Nt12 (C10); + end Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt12) is + begin + Nt12_Cnts (Read) := Nt12_Cnts (Read) + 1; + end Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt12) is + begin + Nt12_Cnts (Output) := Nt12_Cnts (Output) + 1; + end Output; + function Get_Nt12_Counts return CD10002_0.Counts is + begin + return Nt12_Cnts; + end Get_Nt12_Counts; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : Nt13) + renames Nt13_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Nt13 + renames Nt13_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Nt13) + renames Nt13_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Nt13) + renames Nt13_Ops.Output; + + end CD10002_Gen; + + + with Ada.Streams; + use Ada.Streams; + with CD10002_0; + package CD10002_Priv is + + External_Tag_1 : constant String := "Isaac Newton"; + External_Tag_2 : constant String := "Albert Einstein"; + + type T1 is tagged private; + type T2 is tagged + record + C : T1; + end record; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T1); + function Input (Stream : access Root_Stream_Type'Class) return T1; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T1); + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T2); + function Input (Stream : access Root_Stream_Type'Class) return T2; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2); + procedure Output (Stream : access Root_Stream_Type'Class; Item : T2); + + for T1'Write use Write; + for T1'Input use Input; + + for T2'Read use Read; + for T2'Output use Output; + for T2'External_Tag use External_Tag_2; + + function Get_T1_Counts return CD10002_0.Counts; + function Get_T2_Counts return CD10002_0.Counts; + + private + + for T1'Read use Read; + for T1'Output use Output; + for T1'External_Tag use External_Tag_1; + + for T2'Write use Write; + for T2'Input use Input; + + type T1 is tagged null record; + + package T1_Ops is new CD10002_0.Nonlimited_Stream_Ops (T1); + package T2_Ops is new CD10002_0.Nonlimited_Stream_Ops (T2); + + end CD10002_Priv; + + + package body CD10002_Priv is + procedure Write (Stream : access Root_Stream_Type'Class; Item : T1) + renames T1_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return T1 + renames T1_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T1) + renames T1_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : T1) + renames T1_Ops.Output; + + procedure Write (Stream : access Root_Stream_Type'Class; Item : T2) + renames T2_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return T2 + renames T2_Ops.Input; + procedure Read (Stream : access Root_Stream_Type'Class; Item : out T2) + renames T2_Ops.Read; + procedure Output (Stream : access Root_Stream_Type'Class; Item : T2) + renames T2_Ops.Output; + + function Get_T1_Counts return CD10002_0.Counts renames T1_Ops.Get_Counts; + function Get_T2_Counts return CD10002_0.Counts renames T2_Ops.Get_Counts; + end CD10002_Priv; + + + with Ada.Streams; + use Ada.Streams; + with Report; + use Report; + with System; + with CD10002_0; + with CD10002_1; + with CD10002_Deriv; + with CD10002_Gen; + with CD10002_Priv; + procedure CD10002 is + + package Deriv renames CD10002_Deriv; + generic package Gen renames CD10002_Gen; + package Priv renames CD10002_Priv; + + type Stream_Ops is (Read, Write, Input, Output); + type Counts is array (Stream_Ops) of Natural; + + S : aliased CD10002_1.Dummy_Stream; + + begin + Test ("CD10002", + "Check that operational items are allowed in some contexts " & + "where representation items are not"); + + Test_Priv: + declare + X1 : Priv.T1; + X2 : Priv.T2; + use CD10002_0; + begin + Comment + ("Check that the name of an incompletely defined type can be " & + "used when specifying an operational item"); + + -- Partial view of a private type. + Priv.T1'Write (S'Access, X1); + Priv.T1'Read (S'Access, X1); + Priv.T1'Output (S'Access, X1); + X1 := Priv.T1'Input (S'Access); + + if Priv.Get_T1_Counts /= (1, 1, 1, 1) then + Failed ("Incorrect calls to the stream attributes for Priv.T1"); + elsif Priv.T1'External_Tag /= Priv.External_Tag_1 then + Failed ("Incorrect external tag for Priv.T1"); + end if; + + -- Incompletely defined but not private. + Priv.T2'Write (S'Access, X2); + Priv.T2'Read (S'Access, X2); + Priv.T2'Output (S'Access, X2); + X2 := Priv.T2'Input (S'Access); + + if Priv.Get_T2_Counts /= (1, 1, 1, 1) then + Failed ("Incorrect calls to the stream attributes for Priv.T2"); + elsif Priv.T2'External_Tag /= Priv.External_Tag_2 then + Failed ("Incorrect external tag for Priv.T2"); + end if; + + end Test_Priv; + + Test_Gen: + declare + + type Modular is mod System.Max_Binary_Modulus; + type Decimal is delta 1.0 digits 1; + type Access_Modular is access Modular; + type R9 is null record; + type R10 (D : access Integer) is limited null record; + type Arr is array (Character) of Integer; + + C10 : R10 (new Integer'(19)); + + package Inst is new Gen (T1 => Character, + T2 => Integer, + T3 => Modular, + T4 => Float, + T5 => Duration, + T6 => Decimal, + T7 => Access_Modular, + T8 => Boolean, + T9 => R9, + T10 => R10, + C10 => C10, + T11 => Arr); + + X1 : Inst.Nt1 := 'a'; + X2 : Inst.Nt2 := 0; + X3 : Inst.Nt3 := 0; + X4 : Inst.Nt4 := 0.0; + X5 : Inst.Nt5 := 0.0; + X6 : Inst.Nt6 := 0.0; + X7 : Inst.Nt7 := null; + X8 : Inst.Nt8 := Inst.False; + X9 : Inst.Nt9 := (null record); + X10 : Inst.Nt10 (D => new Integer'(5)); + Y10 : Integer; + X11 : Inst.Nt11 := (others => 0); + X12 : Inst.Nt12 (D => new Integer'(7)); + Y12 : Integer; + X13 : Inst.Nt13 := (others => 0); + use CD10002_0; + begin + Comment ("Check that operational items can be specified for a " & + "descendant of a generic formal untagged type"); + + Inst.Nt1'Write (S'Access, X1); + Inst.Nt1'Read (S'Access, X1); + Inst.Nt1'Output (S'Access, X1); + X1 := Inst.Nt1'Input (S'Access); + + if Inst.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt1"); + end if; + + Inst.Nt2'Write (S'Access, X2); + Inst.Nt2'Read (S'Access, X2); + Inst.Nt2'Output (S'Access, X2); + X2 := Inst.Nt2'Input (S'Access); + + if Inst.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt2"); + end if; + + Inst.Nt3'Write (S'Access, X3); + Inst.Nt3'Read (S'Access, X3); + Inst.Nt3'Output (S'Access, X3); + X3 := Inst.Nt3'Input (S'Access); + + if Inst.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt3"); + end if; + + Inst.Nt4'Write (S'Access, X4); + Inst.Nt4'Read (S'Access, X4); + Inst.Nt4'Output (S'Access, X4); + X4 := Inst.Nt4'Input (S'Access); + + if Inst.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt4"); + end if; + + Inst.Nt5'Write (S'Access, X5); + Inst.Nt5'Read (S'Access, X5); + Inst.Nt5'Output (S'Access, X5); + X5 := Inst.Nt5'Input (S'Access); + + if Inst.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt5"); + end if; + + Inst.Nt6'Write (S'Access, X6); + Inst.Nt6'Read (S'Access, X6); + Inst.Nt6'Output (S'Access, X6); + X6 := Inst.Nt6'Input (S'Access); + + if Inst.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt6"); + end if; + + Inst.Nt7'Write (S'Access, X7); + Inst.Nt7'Read (S'Access, X7); + Inst.Nt7'Output (S'Access, X7); + X7 := Inst.Nt7'Input (S'Access); + + if Inst.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt7"); + end if; + + Inst.Nt8'Write (S'Access, X8); + Inst.Nt8'Read (S'Access, X8); + Inst.Nt8'Output (S'Access, X8); + X8 := Inst.Nt8'Input (S'Access); + + if Inst.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt8"); + end if; + + Inst.Nt9'Write (S'Access, X9); + Inst.Nt9'Read (S'Access, X9); + Inst.Nt9'Output (S'Access, X9); + X9 := Inst.Nt9'Input (S'Access); + + if Inst.Nt9_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt9"); + end if; + + Inst.Nt10'Write (S'Access, X10); + Inst.Nt10'Read (S'Access, X10); + Inst.Nt10'Output (S'Access, X10); + Y10 := Inst.Nt10'Input (S'Access).D.all; + + if Inst.Get_Nt10_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt10"); + end if; + + Inst.Nt11'Write (S'Access, X11); + Inst.Nt11'Read (S'Access, X11); + Inst.Nt11'Output (S'Access, X11); + X11 := Inst.Nt11'Input (S'Access); + + if Inst.Nt11_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt11"); + end if; + + Inst.Nt12'Write (S'Access, X12); + Inst.Nt12'Read (S'Access, X12); + Inst.Nt12'Output (S'Access, X12); + Y12 := Inst.Nt12'Input (S'Access).D.all; + + if Inst.Get_Nt12_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt12"); + end if; + + Inst.Nt13'Write (S'Access, X13); + Inst.Nt13'Read (S'Access, X13); + Inst.Nt13'Output (S'Access, X13); + X13 := Inst.Nt13'Input (S'Access); + + if Inst.Nt13_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Inst.Nt13"); + end if; + end Test_Gen; + + Test_Deriv: + declare + X1 : Deriv.Nt1 := Deriv.False; + X2 : Deriv.Nt2 := (others => 0.0); + X3 : Deriv.Nt3 := (others => 0.0); + X4 : Deriv.Nt4; + Y4 : Boolean; + X5 : Deriv.Nt5; + Y5 : System.Address; + X6 : Deriv.Nt6; + Y6 : Integer; + X7 : Deriv.Nt7; + Y7 : Integer; + X8 : Deriv.Nt8; + Y8 : Integer; + use CD10002_0; + begin + Comment ("Check that operational items can be specified for a " & + "derived untagged type even if the parent type is a " & + "by-reference type, or has user-defined primitive " & + "subprograms"); + + Deriv.Nt1'Write (S'Access, X1); + Deriv.Nt1'Read (S'Access, X1); + Deriv.Nt1'Output (S'Access, X1); + X1 := Deriv.Nt1'Input (S'Access); + + if Deriv.Nt1_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt1"); + end if; + + Deriv.Nt2'Write (S'Access, X2); + Deriv.Nt2'Read (S'Access, X2); + Deriv.Nt2'Output (S'Access, X2); + X2 := Deriv.Nt2'Input (S'Access); + + if Deriv.Nt2_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt2"); + end if; + + Deriv.Nt3'Write (S'Access, X3); + Deriv.Nt3'Read (S'Access, X3); + Deriv.Nt3'Output (S'Access, X3); + X3 := Deriv.Nt3'Input (S'Access); + + if Deriv.Nt3_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt3"); + end if; + + Deriv.Nt4'Write (S'Access, X4); + Deriv.Nt4'Read (S'Access, X4); + Deriv.Nt4'Output (S'Access, X4); + Y4 := Deriv.Nt4'Input (S'Access)'Terminated; + + if Deriv.Nt4_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt4"); + end if; + + Deriv.Nt5'Write (S'Access, X5); + Deriv.Nt5'Read (S'Access, X5); + Deriv.Nt5'Output (S'Access, X5); + Y5 := Deriv.Nt5'Input (S'Access)'Address; + + if Deriv.Nt5_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt5"); + end if; + + Deriv.Nt6'Write (S'Access, X6); + Deriv.Nt6'Read (S'Access, X6); + Deriv.Nt6'Output (S'Access, X6); + Y6 := Deriv.Nt6'Input (S'Access).D.all; + + if Deriv.Nt6_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt6"); + end if; + + Deriv.Nt7'Write (S'Access, X7); + Deriv.Nt7'Read (S'Access, X7); + Deriv.Nt7'Output (S'Access, X7); + Y7 := Deriv.Nt7'Input (S'Access) ('a').D.all; + + if Deriv.Nt7_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt7"); + end if; + + Deriv.Nt8'Write (S'Access, X8); + Deriv.Nt8'Read (S'Access, X8); + Deriv.Nt8'Output (S'Access, X8); + Y8 := Deriv.Nt8'Input (S'Access)'Size; + + if Deriv.Nt8_Ops.Get_Counts /= (1, 1, 1, 1) then + Failed + ("Incorrect calls to the stream attributes for Deriv.Nt8"); + end if; + end Test_Deriv; + + Result; + end CD10002; + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- CD1009A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR AN INTEGER TYPE DECLARED IN + -- THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 09/18/87 CREATED ORIGINAL TEST. + -- DHH 03/31/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED + -- CHECK FOR REPRESENTATION CLAUSES, AND CHANGED + -- SPECIFIED_SIZE TO 5. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1009A IS + BEGIN + TEST ("CD1009A", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR AN INTEGER " & + "TYPE DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE CHECK_TYPE_1 IS RANGE -8 .. 7; + FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE; + TYPE PACK_ARY IS ARRAY(1 .. 6) OF CHECK_TYPE_1; + PRAGMA PACK (PACK_ARY); + OBJ1 : PACK_ARY := (OTHERS => -7); + + TYPE CHECK_TYPE_2 IS RANGE -8 .. 7; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + OBJ2 : CHECK_TYPE_2 := -7; + PROCEDURE CHECK1 IS NEW LENGTH_CHECK (CHECK_TYPE_1); + PROCEDURE CHECK2 IS NEW LENGTH_CHECK (CHECK_TYPE_2); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK1 (OBJ1(IDENT_INT(1)), 5, "CHECK_TYPE_1"); + CHECK2 (OBJ2, 5, "CHECK_TYPE_2"); + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE"); + END IF; + END; + + RESULT; + END CD1009A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- CD1009B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION TYPE DECLARED + -- IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009B IS + BEGIN + TEST ("CD1009B", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR AN " & + "ENUMERATION TYPE DECLARED IN THE VISIBLE " & + "PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2; + + TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3); + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + + TYPE CHECK_TYPE_2 IS (A0, A1, A2, A3); + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + X : CHECK_TYPE_1 := A0; + Y : CHECK_TYPE_2 := A2; + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT'SIZE IS TOO SMALL --" & + CHECK_TYPE_1'IMAGE(X)); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT'SIZE IS TOO SMALL --" & + CHECK_TYPE_2'IMAGE(Y)); + END IF; + + END; + + RESULT; + END CD1009B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD1009D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED IN + -- THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009D IS + BEGIN + TEST ("CD1009D", "A 'SIZE CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "FIXED POINT TYPE DECLARED IN THE VISIBLE " & + "PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0; + + SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE; + + TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + + TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + X: CHECK_TYPE_1 := 0.5; + Y: CHECK_TYPE_2 := 0.5; + + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE IS TOO SMALL -- " & + "VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) ); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE IS TOO SMALL -- " & + "VALUE IS" & INTEGER'IMAGE ( INTEGER(Y) ) ); + END IF; + + END; + + RESULT; + END CD1009D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CD1009E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR A ONE-DIMENSIONAL ARRAY TYPE + -- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009E IS + BEGIN + TEST ("CD1009E", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "ONE-DIMENSIONAL ARRAY TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 5; + + TYPE CHECK_TYPE_1 IS ARRAY (1 ..5) OF INTEGER; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + X : CHECK_TYPE_1 := (OTHERS => IDENT_INT(1)); + + TYPE CHECK_TYPE_2 IS ARRAY (1 ..5) OF INTEGER; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + Y : CHECK_TYPE_2 := (OTHERS => IDENT_INT(5)); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "FIRST VALUE IS" & + INTEGER'IMAGE( X( IDENT_INT(1) ) ) ); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " & + "FIRST VALUE IS" & + INTEGER'IMAGE( Y( IDENT_INT(1) ) ) ); + END IF; + END; + + RESULT; + END CD1009E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CD1009F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR A TWO-DIMENSIONAL ARRAY TYPE + -- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009F IS + BEGIN + TEST ("CD1009F", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "TWO-DIMENSIONAL ARRAY TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 25; + + TYPE CHECK_TYPE_1 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + X : CHECK_TYPE_1 := ( OTHERS => + ( OTHERS => IDENT_INT(1) ) ); + + TYPE CHECK_TYPE_2 IS ARRAY (1 .. 5, 1 .. 5) OF INTEGER; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + Y : CHECK_TYPE_2 := ( OTHERS => + ( OTHERS => IDENT_INT(5) ) ); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "REPRESENTATIVE VALUE IS" & + INTEGER'IMAGE( X( IDENT_INT(1), IDENT_INT(2) ) ) ); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " & + INTEGER'IMAGE( Y( IDENT_INT(1), IDENT_INT(2) ) ) ); + END IF; + END; + + RESULT; + END CD1009F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- CD1009G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' SPECIFICATION MAY BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE DECLARED IN + -- THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009G IS + BEGIN + TEST ("CD1009G", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE; + + TYPE CHECK_TYPE_1 IS + RECORD + I : INTEGER; + END RECORD; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + X : CHECK_TYPE_1 := ( I => IDENT_INT (1) ); + + TYPE CHECK_TYPE_2 IS + RECORD + I : INTEGER; + END RECORD; + PRIVATE + FOR CHECK_TYPE_2'SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + Y : CHECK_TYPE_2 := ( I => IDENT_INT (5) ); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & INTEGER'IMAGE( IDENT_INT( X.I) ) ); + END IF; + + IF CHECK_TYPE_2'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'SIZE IS INCORRECT"); + END IF; + + IF Y'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_2. " & + "VALUE IS" & INTEGER'IMAGE( IDENT_INT(Y.I) ) ); + END IF; + END; + + RESULT; + END CD1009G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009h.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- CD1009H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE + -- PART OF A PACKAGE FOR A PRIVATE TYPE DECLARED IN THE VISIBLE + -- PART OF THE SAME PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 09/18/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009H IS + BEGIN + TEST ("CD1009H", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A PRIVATE " & + "TYPE DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2; + + TYPE CHECK_TYPE_1 IS PRIVATE; + C1 : CONSTANT CHECK_TYPE_1; + FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING; + PRIVATE + TYPE CHECK_TYPE_1 IS RANGE 0 .. 7; + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + C1 : CONSTANT CHECK_TYPE_1 := CHECK_TYPE_1(IDENT_INT(1)); + END PACK; + + USE PACK; + X : CHECK_TYPE_1 := C1; + + PACKAGE BODY PACK IS + FUNCTION IMAGE ( A : CHECK_TYPE_1 ) RETURN STRING IS + BEGIN + RETURN INTEGER'IMAGE ( INTEGER (A) ); + END IMAGE; + END PACK; + + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & IMAGE(X)); + END IF; + + END; + + RESULT; + END CD1009H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- CD1009I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE + -- PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE DECLARED IN THE + -- VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 09/18/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK FOR + -- REPRESENTATION CLAUSES AND CHANGED THE TEST + -- EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1009I IS + BEGIN + TEST ("CD1009I", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A LIMITED-" & + "PRIVATE TYPE DECLARED IN THE VISIBLE PART " & + "OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE CHECK_TYPE_1 IS LIMITED PRIVATE; + PRIVATE + TYPE CHECK_TYPE_1 IS RANGE -8 .. 7; + FOR CHECK_TYPE_1'SIZE USE SPECIFIED_SIZE; + OBJ_CHECK : CHECK_TYPE_1 := -7; + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE_1); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (OBJ_CHECK, 5, "CHECK_TYPE_1"); + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE"); + END IF; + END; + + RESULT; + END CD1009I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009j.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CD1009J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE + -- VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ACCESS TYPE + -- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/07/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009J IS + BEGIN + TEST ("CD1009J", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN " & + "ACCESS TYPE DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10; + + TYPE CHECK_TYPE_1 IS ACCESS INTEGER; + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + + TYPE CHECK_TYPE_2 IS ACCESS INTEGER; + PRIVATE + FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL"); + END IF; + + IF CHECK_TYPE_2'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL"); + END IF; + END; + + RESULT; + END CD1009J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009k.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- CD1009K.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE + -- VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TASK TYPE DECLARED IN + -- THE VISIBLE PART OF THE SAME PACKAGE. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- VCL 10/08/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + -- TMB 02/29/96 EFFECT OF SETTING 'STORAGE_SIZE IS IMPLEMENTATION + -- DEPENDENT. + -- ONLY GUARANTEE WHEN EXAMINING 'STORAGE_SIZE IS THAT + -- IT IS NOT NEGATIVE. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009K IS + BEGIN + TEST ("CD1009K", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " & + "TASK TYPE DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TASK TYPE CHECK_TYPE_1 IS + END CHECK_TYPE_1; + + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + + TASK TYPE CHECK_TYPE_2 IS + END CHECK_TYPE_2; + + PRIVATE + FOR CHECK_TYPE_2'STORAGE_SIZE USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + TASK BODY CHECK_TYPE_1 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_1; + + TASK BODY CHECK_TYPE_2 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_2; + + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < 0 THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL"); + END IF; + + IF CHECK_TYPE_2'STORAGE_SIZE < 0 THEN + FAILED ("CHECK_TYPE_2'STORAGE_SIZE IS TOO SMALL"); + END IF; + END; + + RESULT; + END CD1009K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009l.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- CD1009L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE OR + -- PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED + -- IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/08/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CHANGED + -- COMMENT FROM FLOATING POINT TO FIXED POINT. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009L IS + BEGIN + TEST ("CD1009L", "A 'SMALL' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A " & + "FIXED POINT TYPE DECLARED IN THE VISIBLE " & + "PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE SPECIFIED IS DELTA 2.0 ** (-2) RANGE 0.0 .. 1.0; + + SPECIFIED_SMALL : CONSTANT := SPECIFIED'SMALL; + + TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0; + FOR CHECK_TYPE_1'SMALL + USE SPECIFIED_SMALL; + + TYPE CHECK_TYPE_2 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 1.0; + PRIVATE + FOR CHECK_TYPE_2'SMALL USE SPECIFIED_SMALL; + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SMALL /= SPECIFIED_SMALL THEN + FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_1'SMALL"); + END IF; + + IF CHECK_TYPE_2'SMALL /= SPECIFIED_SMALL THEN + FAILED ("INCORRECT RESULTS FOR CHECK_TYPE_2'SMALL"); + END IF; + END; + + RESULT; + END CD1009L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009m.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- CD1009M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN + -- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR AN ENUMERATION + -- TYPE DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/08/87 CREATED ORIGINAL TEST. + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1009M IS + BEGIN + TEST ("CD1009M", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " & + "GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR AN ENUMERATION TYPE DECLARED IN " & + "THE VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8); + FOR CHECK_TYPE_1 USE (A0 => 0, + A2 => 1, + A4 => 2, + A8 => 3); + + TYPE CHECK_TYPE_2 IS (A0, A2, A4, A8); + TYPE INT1 IS RANGE 0 .. 3; + FOR INT1'SIZE USE CHECK_TYPE_1'SIZE; + + TYPE INT2 IS RANGE 2 .. 8; + + PRIVATE + FOR CHECK_TYPE_2 USE (A0 => 2, + A2 => 4, + A4 => 6, + A8 => 8); + FOR INT2'SIZE USE CHECK_TYPE_2'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(CHECK_TYPE_2, INT2); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (A4, 2, "CHECK_TYPE_1"); + CHECK_2 (A8, 8, "CHECK_TYPE_2"); + END PACK; + + USE PACK; + BEGIN + NULL; + END; + + RESULT; + END CD1009M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009n.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CD1009N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE MAY BE GIVEN + -- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A RECORD TYPE + -- DECLARED IN THE VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/08/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED + -- CHECKS FOR FAILURE. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD1009N IS + BEGIN + TEST ("CD1009N", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " & + "IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " & + "FOR A RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_TYPE_1 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + FOR CHECK_TYPE_1 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + + TYPE CHECK_TYPE_2 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + + PRIVATE + FOR CHECK_TYPE_2 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + END PACK; + + USE PACK; + + R1 : CHECK_TYPE_1; + + R2 : CHECK_TYPE_2; + BEGIN + IF R1.I1'FIRST_BIT /= 0 OR + R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I1"); + END IF; + + IF R1.B1'FIRST_BIT /= 0 OR + R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B1"); + END IF; + + IF R1.B2'FIRST_BIT /= 0 OR + R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B2"); + END IF; + + IF R1.I2'FIRST_BIT /= 0 OR + R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I2"); + END IF; + + + IF R2.I1'FIRST_BIT /= 0 OR + R2.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R2.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R2.I1"); + END IF; + + IF R2.B1'FIRST_BIT /= 0 OR + R2.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R2.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R2.B1"); + END IF; + + IF R2.B2'FIRST_BIT /= 0 OR + R2.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R2.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R2.B2"); + END IF; + + IF R2.I2'FIRST_BIT /= 0 OR + R2.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R2.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R2.I2"); + END IF; + END; + + RESULT; + END CD1009N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009o.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- CD1009O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART + -- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION + -- IS AN INTEGER TYPE, DECLARED IN THE VISIBLE PART OF THE SAME + -- PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/08/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009O IS + BEGIN + TEST ("CD1009O", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE " & + "PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " & + "WHOSE FULL DECLARATION IS AN INTEGER " & + "TYPE, DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS RANGE 0 .. 7; + + PRIVATE + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + X : CHECK_TYPE_1 := CHECK_TYPE_1 (IDENT_INT(1)); + + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & CHECK_TYPE_1'IMAGE(X)); + END IF; + + END; + + RESULT; + END CD1009O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009p.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CD1009P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE PART + -- OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION + -- IS AN ENUMERATION TYPE, DECLARED IN THE VISIBLE PART OF THE SAME + -- PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/09/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009P IS + BEGIN + TEST ("CD1009P", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE VISIBLE " & + "PART OF A PACKAGE FOR AN INCOMPLETE TYPE, " & + "WHOSE FULL DECLARATION IS AN ENUMERATION " & + "TYPE, DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS (A0, A1, A2, A3); + + PRIVATE + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'SIZE > SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS TOO LARGE"); + END IF; + END; + + RESULT; + END CD1009P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009q.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- CD1009Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'SIZE' SPECIFICATION MAY BE GIVEN IN THE PRIVATE + -- PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL DECLARATION + -- IS A FIXED POINT TYPE, DECLARED IN THE VISIBLE PART OF THE SAME + -- PACKAGE. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/21/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009Q IS + BEGIN + TEST ("CD1009Q", "A 'SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A AN " & + "INCOMPLETE TYPE, WHOSE FULL DECLARATION IS A " & + "FIXED POINT TYPE, DECLARED IN THE VISIBLE " & + "PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE SPECIFIED IS DELTA 2.0 ** (-4) RANGE 0.0 .. 10.0; + + SPECIFIED_SIZE : CONSTANT := SPECIFIED'SIZE; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS DELTA 2.0 ** (-1) RANGE 0.0 .. 2.0; + PRIVATE + FOR CHECK_TYPE_1'SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + + X : CHECK_TYPE_1 := CHECK_TYPE_1 ( IDENT_INT (1) ); + BEGIN + IF CHECK_TYPE_1'SIZE /= SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'SIZE IS INCORRECT"); + END IF; + + IF X'SIZE < SPECIFIED_SIZE THEN + FAILED ("OBJECT SIZE TOO SMALL -- CHECK_TYPE_1. " & + "VALUE IS" & INTEGER'IMAGE ( INTEGER(X) ) ); + END IF; + + END; + + RESULT; + END CD1009Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009r.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- CD1009R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE + -- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL + -- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART OF + -- THE SAME PACKAGE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/21/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009R IS + BEGIN + TEST ("CD1009R", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " & + "TYPE, WHOSE FULL TYPE DECLARATION IS AN " & + "ACCESS TYPE, DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS ACCESS INTEGER; + PRIVATE + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL"); + END IF; + END; + + RESULT; + END CD1009R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009s.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- CD1009S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE + -- PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE + -- DECLARATION IS AN ACCESS TYPE, DECLARED IN THE VISIBLE PART + -- OF THE SAME PACKAGE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- VCL 10/09/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009S IS + BEGIN + TEST ("CD1009S", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, " & + "WHOSE FULL TYPE DECLARATION IS AN ACCESS " & + "TYPE, DECLARED IN THE VISIBLE PART OF THE " & + "SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE * 10; + + TYPE CHECK_TYPE_1 IS PRIVATE; + + PROCEDURE P; + PRIVATE + TYPE CHECK_TYPE_1 IS ACCESS INTEGER; + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " & + "SMALL"); + END IF; + END P; + END PACK; + + USE PACK; + BEGIN + P; + END; + + RESULT; + END CD1009S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009t.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CD1009T.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE + -- PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL + -- TYPE DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE + -- PART OF THE SAME PACKAGE. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- VCL 10/21/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009T IS + BEGIN + TEST ("CD1009T", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE " & + "TYPE, WHOSE FULL TYPE DECLARATION IS A " & + "TASK TYPE, DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TASK TYPE CHECK_TYPE_1 IS END CHECK_TYPE_1; + PRIVATE + FOR CHECK_TYPE_1'STORAGE_SIZE + USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + TASK BODY CHECK_TYPE_1 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_1; + END PACK; + + USE PACK; + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO SMALL"); + END IF; + END; + + RESULT; + END CD1009T; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009u.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD1009U.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE PRIVATE + -- PART OF A PACKAGE FOR A LIMITED PRIVATE TYPE, WHOSE FULL TYPE + -- DECLARATION IS A TASK TYPE, DECLARED IN THE VISIBLE PART OF THE + -- SAME PACKAGE. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- VCL 10/09/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + + WITH REPORT; USE REPORT; + PROCEDURE CD1009U IS + BEGIN + TEST ("CD1009U", "A 'STORAGE_SIZE' CLAUSE MAY BE GIVEN IN THE " & + "PRIVATE PART OF A PACKAGE FOR A LIMITED " & + "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " & + "A TASK TYPE, DECLARED IN THE VISIBLE PART OF " & + "THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TYPE CHECK_TYPE_1 IS LIMITED PRIVATE; + + PROCEDURE P; + PRIVATE + TASK TYPE CHECK_TYPE_1 IS + END CHECK_TYPE_1; + + FOR CHECK_TYPE_1'STORAGE_SIZE USE SPECIFIED_SIZE; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + BEGIN + IF CHECK_TYPE_1'STORAGE_SIZE < SPECIFIED_SIZE THEN + FAILED ("CHECK_TYPE_1'STORAGE_SIZE IS TOO " & + "SMALL"); + END IF; + END P; + + TASK BODY CHECK_TYPE_1 IS + I : INTEGER; + BEGIN + NULL; + END CHECK_TYPE_1; + END PACK; + + USE PACK; + BEGIN + P; + END; + + RESULT; + END CD1009U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009v.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD1009V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN + -- THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE + -- FULL TYPE DECLARATION IS AN ENUMERATION TYPE DECLARED IN THE + -- VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/21/87 CREATED ORIGINAL TEST. + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1009V IS + BEGIN + TEST ("CD1009V", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " & + "GIVEN IN THE PRIVATE PART OF A " & + "PACKAGE FOR AN INCOMPLETE TYPE, WHOSE FULL " & + "TYPE DECLARATION IS AN ENUMERATION TYPE, " & + "DECLARED IN THE VISIBLE PART OF THE SAME " & + "PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8); + PRIVATE + + FOR CHECK_TYPE_1 USE (A0 => 9, + A2 => 13, + A4 => 15, + A8 => 18); + TYPE INT1 IS RANGE 9 .. 18; + FOR INT1'SIZE USE CHECK_TYPE_1'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (A2, 13, "CHECK_TYPE_1"); + END PACK; + + USE PACK; + BEGIN + NULL; + END; + + RESULT; + END CD1009V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009w.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CD1009W.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE MAY BE GIVEN IN + -- THE PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL + -- TYPE DECLARATION IS AN ENUMERATION TYPE, DECLARED IN THE + -- VISIBLE PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/09/87 CREATED ORIGINAL TEST. + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1009W IS + BEGIN + TEST ("CD1009W", "AN ENUMERATION REPRESENTATION CLAUSE MAY BE " & + "GIVEN IN THE PRIVATE PART OF A PACKAGE FOR " & + "A PRIVATE TYPE, WHOSE FULL TYPE DECLARATION " & + "IS AN ENUMERATION TYPE, DECLARED IN " & + "THE VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + TYPE CHECK_TYPE_1 IS PRIVATE; + PRIVATE + TYPE CHECK_TYPE_1 IS (A0, A2, A4, A8); + FOR CHECK_TYPE_1 USE (A0 => 0, + A2 => 2, + A4 => 4, + A8 => 16); + TYPE INT1 IS RANGE 0 .. 16; + FOR INT1'SIZE USE CHECK_TYPE_1'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(CHECK_TYPE_1, INT1); + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (A8, 16, "CHECK_TYPE_1"); + END PACK; + + USE PACK; + BEGIN + NULL; + END; + + RESULT; + END CD1009W; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009x.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CD1009X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE MAY BE GIVEN + -- IN THE PRIVATE PART OF A PACKAGE FOR AN INCOMPLETE TYPE, WHOSE + -- FULL TYPE DECLARATION IS A RECORD TYPE DECLARED IN THE VISIBLE + -- PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/21/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED + -- CHECKS FOR FAILURE. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD1009X IS + BEGIN + TEST ("CD1009X", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE FOR AN " & + "INCOMPLETE TYPE, WHOSE FULL TYPE DECLARATION " & + "IS A RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_TYPE_1; + TYPE ACC IS ACCESS CHECK_TYPE_1; + + TYPE CHECK_TYPE_1 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + PRIVATE + FOR CHECK_TYPE_1 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + END PACK; + + USE PACK; + + R1 : CHECK_TYPE_1; + BEGIN + IF R1.I1'FIRST_BIT /= 0 OR + R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I1"); + END IF; + + IF R1.B1'FIRST_BIT /= 0 OR + R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B1'POSITION /= 1 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B1"); + END IF; + + IF R1.B2'FIRST_BIT /= 0 OR + R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B2'POSITION /= 2 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B2"); + END IF; + + IF R1.I2'FIRST_BIT /= 0 OR + R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I2'POSITION /= 3 * UNITS_PER_INTEGER THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I2"); + END IF; + END; + + RESULT; + END CD1009X; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009y.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CD1009Y.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE + -- PRIVATE PART OF A PACKAGE FOR A PRIVATE TYPE, WHOSE FULL TYPE + -- DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE PART + -- OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/09/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED + -- CHECKS FOR FAILURE. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD1009Y IS + BEGIN + TEST ("CD1009Y", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE FOR A " & + "PRIVATE TYPE, WHOSE FULL TYPE DECLARATION IS " & + "A RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_TYPE_1 IS PRIVATE; + + PROCEDURE P; + PRIVATE + TYPE CHECK_TYPE_1 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + FOR CHECK_TYPE_1 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + R1 : CHECK_TYPE_1; + BEGIN + IF R1.I1'FIRST_BIT /= 0 OR + R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I1"); + END IF; + + IF R1.B1'FIRST_BIT /= 0 OR + R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B1'POSITION /= 1 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B1"); + END IF; + + IF R1.B2'FIRST_BIT /= 0 OR + R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B2'POSITION /= 2 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B2"); + END IF; + + IF R1.I2'FIRST_BIT /= 0 OR + R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I2'POSITION /= 3 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I2"); + END IF; + END P; + END PACK; + + USE PACK; + + BEGIN + P; + END; + + RESULT; + END CD1009Y; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1009z.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CD1009Z.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE MAY BE GIVEN IN THE + -- PRIVATE PART OF A PACKAGE FOR A LIMITED-PRIVATE TYPE, WHOSE + -- FULL TYPE DECLARATION IS A RECORD TYPE, DECLARED IN THE VISIBLE + -- PART OF THE SAME PACKAGE. + + -- HISTORY: + -- VCL 10/09/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED + -- CHECKS FOR FAILURE. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD1009Z IS + BEGIN + TEST ("CD1009Z", "A RECORD REPRESENTATION CLAUSE MAY BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE FOR A " & + "LIMITED PRIVATE TYPE, WHOSE FULL TYPE " & + "DECLARATION IS A RECORD TYPE DECLARED IN THE " & + "VISIBLE PART OF THE SAME PACKAGE"); + DECLARE + PACKAGE PACK IS + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_TYPE_1 IS LIMITED PRIVATE; + + PROCEDURE P; + PRIVATE + TYPE CHECK_TYPE_1 IS + RECORD + I1 : INTEGER RANGE 0 .. 255; + B1 : BOOLEAN; + B2 : BOOLEAN; + I2 : INTEGER RANGE 0 .. 15; + END RECORD; + FOR CHECK_TYPE_1 USE + RECORD + I1 AT 0 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + B1 AT 1 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + B2 AT 2 * UNITS_PER_INTEGER + RANGE 0 .. BOOLEAN'SIZE - 1; + I2 AT 3 * UNITS_PER_INTEGER + RANGE 0 .. INTEGER'SIZE - 1; + END RECORD; + END PACK; + + PACKAGE BODY PACK IS + PROCEDURE P IS + R1 : CHECK_TYPE_1; + BEGIN + IF R1.I1'FIRST_BIT /= 0 OR + R1.I1'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I1'POSITION /= 0 THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I1"); + END IF; + + IF R1.B1'FIRST_BIT /= 0 OR + R1.B1'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B1'POSITION /= 1 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B1"); + END IF; + + IF R1.B2'FIRST_BIT /= 0 OR + R1.B2'LAST_BIT /= BOOLEAN'SIZE - 1 OR + R1.B2'POSITION /= 2 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.B2"); + END IF; + + IF R1.I2'FIRST_BIT /= 0 OR + R1.I2'LAST_BIT /= INTEGER'SIZE - 1 OR + R1.I2'POSITION /= 3 * UNITS_PER_INTEGER + THEN + FAILED ("INCORRECT REPRESENTATION FOR R1.I2"); + END IF; + END P; + END PACK; + + USE PACK; + + BEGIN + P; + END; + + RESULT; + END CD1009Z; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD1C03A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SIZE OF A DERIVED TYPE IS INHERITED FROM THE + -- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A SIZE + -- CLAUSE. + + -- HISTORY: + -- JET 09/16/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO 5, ADDED CHECK ON + -- REPRESENTATION CLAUSES, AND CHANGED THE TEST + -- EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1C03A IS + + SPECIFIED_SIZE : CONSTANT := 5; + + TYPE PARENT_TYPE IS RANGE -8 .. 7; + + FOR PARENT_TYPE'SIZE USE SPECIFIED_SIZE; + PT : PARENT_TYPE := -7; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + DT : DERIVED_TYPE := -7; + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_TYPE); + PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (PARENT_TYPE); + + BEGIN + + TEST("CD1C03A", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " & + "INHERITED FROM THE PARENT IF THE SIZE OF " & + "THE PARENT WAS DETERMINED BY A SIZE CLAUSE"); + + IF PARENT_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'SIZE /= " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE /= " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'SIZE)); + END IF; + + IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DT'SIZE)); + END IF; + + CHECK_1 (DT, 5, "DERIVED_TYPE"); + CHECK_2 (PT, 5, "PARENT_TYPE"); + RESULT; + + END CD1C03A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CD1C03B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SIZE OF A DERIVED TYPE IS INHERITED FROM THE + -- PARENT IF THE SIZE OF THE PARENT WAS DETERMINED BY A PRAGMA + -- PACK. + + -- HISTORY: + -- JET 09/16/87 CREATED ORIGINAL TEST. + -- PWB 03/27/89 MODIFIED COMPARISON OF OBJECT SIZE TO PARENT SIZE. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C03B IS + + TYPE ENUM IS (E1, E2, E3); + + TYPE NORMAL_TYPE IS ARRAY (1 .. 100) OF ENUM; + + TYPE PARENT_TYPE IS ARRAY (1 .. 100) OF ENUM; + PRAGMA PACK (PARENT_TYPE); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + X : DERIVED_TYPE := (OTHERS => ENUM'FIRST); + + BEGIN + + TEST("CD1C03B", "CHECK THAT THE SIZE OF A DERIVED TYPE IS " & + "INHERITED FROM THE PARENT IF THE SIZE OF " & + "THE PARENT WAS DETERMINED BY A PRAGMA PACK"); + + IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN + COMMENT ("PRAGMA PACK HAD NO EFFECT ON THE SIZE OF " & + "PARENT_TYPE, WHICH IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + ELSIF PARENT_TYPE'SIZE > IDENT_INT (NORMAL_TYPE'SIZE) THEN + FAILED ("PARENT_TYPE'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(NORMAL_TYPE'SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'SIZE > IDENT_INT (PARENT_TYPE'SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(PARENT_TYPE'SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'SIZE)); + END IF; + + IF X'SIZE < DERIVED_TYPE'SIZE THEN + FAILED ("OBJECT SIZE TOO LARGE. FIRST VALUE IS " & + ENUM'IMAGE ( X(1) ) ); + END IF; + + RESULT; + + END CD1C03B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CD1C03C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE COLLECTION SIZE OF A DERIVED TYPE IS + -- INHERITED FROM THE PARENT IF THE COLLECTION SIZE OF + -- THE PARENT WAS DETERMINED BY A COLLECTION SIZE CLAUSE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/16/87 CREATED ORIGINAL TEST. + -- RJW 02/10/88 RENAMED FROM CD1C03C.TST. REMOVED MACRO - + -- ACC_SIZE. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C03C IS + + SPECIFIED_SIZE : CONSTANT := 512; + + TYPE PARENT_TYPE IS ACCESS STRING; + + FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + BEGIN + + TEST("CD1C03C", "CHECK THAT THE COLLECTION SIZE OF A " & + "DERIVED TYPE IS INHERITED FROM THE PARENT " & + "IF THE COLLECTION SIZE OF THE PARENT WAS " & + "DETERMINED BY A COLLECTION SIZE CLAUSE"); + + IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN SPECIFIED_SIZE. " & + "ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE /= + IDENT_INT (PARENT_TYPE'STORAGE_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD BE " & + "EQUAL TO PARENT_TYPE'STORAGE_SIZE. " & + "ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + RESULT; + + END CD1C03C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03e.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CD1C03E.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE STORAGE SIZE OF A DERIVED TASK TYPE IS + -- INHERITED FROM THE PARENT IF THE STORAGE SIZE OF THE + -- PARENT WAS DETERMINED BY A TASK STORAGE SIZE CLAUSE. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- JET 09/16/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C03E IS + + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + TASK TYPE PARENT_TYPE IS + ENTRY E; + END PARENT_TYPE; + + FOR PARENT_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + TASK BODY PARENT_TYPE IS + BEGIN + ACCEPT E DO + COMMENT ("ENTRY E ACCEPTED"); + END E; + END PARENT_TYPE; + + BEGIN + + TEST("CD1C03E", "CHECK THAT THE STORAGE SIZE OF A DERIVED " & + "TASK TYPE IS INHERITED FROM THE PARENT IF " & + "THE STORAGE SIZE OF THE PARENT WAS " & + "DETERMINED BY A TASK STORAGE SIZE CLAUSE"); + + IF PARENT_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'STORAGE_SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE LESS THAN " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + RESULT; + + END CD1C03E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD1C03F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE VALUE OF 'SMALL FOR A DERIVED FIXED POINT TYPE + -- IS INHERITED FROM THE PARENT IF THE VALUE OF 'SMALL FOR THE + -- PARENT WAS DETERMINED BY A 'SMALL SPECIFICATION CLAUSE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C03F IS + + SPECIFIED_SMALL : CONSTANT := 0.25; + + TYPE FLT IS NEW FLOAT; + + TYPE PARENT_TYPE IS DELTA 1.0 RANGE 0.0 .. 100.0; + + FOR PARENT_TYPE'SMALL USE SPECIFIED_SMALL; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + FUNCTION IDENT_FLT (F : FLT) RETURN FLT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN F; + ELSE + RETURN 0.0; + END IF; + END; + + BEGIN + + TEST("CD1C03F", "CHECK THAT THE VALUE OF 'SMALL FOR A " & + "DERIVED FIXED POINT TYPE IS INHERITED " & + "FROM THE PARENT IF THE VALUE OF 'SMALL " & + "FOR THE PARENT WAS DETERMINED BY A 'SMALL " & + "SPECIFICATION CLAUSE"); + + IF PARENT_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN + FAILED ("PARENT_TYPE'SMALL SHOULD BE EQUAL TO " & + "THE SPECIFIED VALUE"); + END IF; + + IF DERIVED_TYPE'SMALL /= IDENT_FLT (SPECIFIED_SMALL) THEN + FAILED ("DERIVED_TYPE'SMALL SHOULD BE EQUAL TO " & + "THE SPECIFIED VALUE"); + END IF; + + RESULT; + + END CD1C03F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- CD1C03G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SIZE OF A DERIVED ENUMERATION TYPE IS + -- INHERITED FROM THE PARENT IF THE SIZE OF THE PARENT WAS + -- DETERMINED BY AN ENUMERATION REPRESENTATION CLAUSE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C03G IS + + TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW); + + TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW); + + FOR PARENT_TYPE USE + (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + BEGIN + + TEST("CD1C03G", "CHECK THAT THE SIZE OF A DERIVED ENUMERATION " & + "TYPE IS INHERITED FROM THE PARENT IF THE " & + "SIZE OF THE PARENT WAS DETERMINED BY AN " & + "ENUMERATION REPRESENTATION CLAUSE"); + + IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN + COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " & + "REPRESENTATION CLAUSE"); + END IF; + + IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + RESULT; + + END CD1C03G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03h.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CD1C03H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE RECORD SIZE AND THE COMPONENT POSITIONS AND + -- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE + -- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY A + -- RECORD REPRESENTATION CLAUSE. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD1C03H IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE E_TYPE IS (RED, BLUE, GREEN); + + TYPE PARENT_TYPE IS + RECORD + I : INTEGER RANGE 0 .. 127 := 127; + C : CHARACTER := 'S'; + B : BOOLEAN := FALSE; + E : E_TYPE := BLUE; + END RECORD; + + FOR PARENT_TYPE USE + RECORD + C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1; + B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1; + I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1; + E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1; + END RECORD; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + P_REC : PARENT_TYPE; + REC : DERIVED_TYPE; + + BEGIN + + TEST("CD1C03H", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " & + "POSITIONS AND SIZES OF A DERIVED RECORD " & + "TYPE ARE INHERITED FROM THE PARENT IF THOSE " & + "ASPECTS OF THE PARENT WERE DETERMINED BY " & + "A RECORD REPRESENTATION CLAUSE"); + + IF DERIVED_TYPE'SIZE /= IDENT_INT (PARENT_TYPE'SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + IF REC.I'SIZE /= P_REC.I'SIZE OR + REC.C'SIZE /= P_REC.C'SIZE OR + REC.B'SIZE /= P_REC.B'SIZE OR + REC.E'SIZE /= P_REC.E'SIZE THEN + FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + REC := (12, 'T', TRUE, RED); + + IF (REC.I /= 12) OR (REC.C /= 'T') OR + (NOT REC.B) OR (REC.E /= RED) THEN + FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " & + "INCORRECT"); + END IF; + + IF REC.I'POSITION /= P_REC.I'POSITION OR + REC.C'POSITION /= P_REC.C'POSITION OR + REC.B'POSITION /= P_REC.B'POSITION OR + REC.E'POSITION /= P_REC.E'POSITION THEN + FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR + REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR + REC.B'FIRST_BIT /= P_REC.B'FIRST_BIT OR + REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN + FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR + REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR + REC.B'LAST_BIT /= P_REC.B'LAST_BIT OR + REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN + FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + RESULT; + + END CD1C03H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c03i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CD1C03I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE RECORD SIZE AND THE COMPONENT POSITIONS AND + -- SIZES OF A DERIVED RECORD TYPE ARE INHERITED FROM THE + -- PARENT IF THOSE ASPECTS OF THE PARENT WERE DETERMINED BY THE + -- PRAGMA PACK. + + -- HISTORY: + -- JET 09/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + + PROCEDURE CD1C03I IS + + TYPE E_TYPE IS (RED, BLUE, GREEN); + + TYPE PARENT_TYPE IS + RECORD + B1: BOOLEAN := TRUE; + I : INTEGER RANGE 0 .. 127 := 127; + C : CHARACTER := 'S'; + B2: BOOLEAN := FALSE; + E : E_TYPE := BLUE; + END RECORD; + + PRAGMA PACK (PARENT_TYPE); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + P_REC : PARENT_TYPE; + REC : DERIVED_TYPE; + + BEGIN + + TEST("CD1C03I", "CHECK THAT THE RECORD SIZE AND THE COMPONENT " & + "POSITIONS AND SIZES OF A DERIVED RECORD " & + "TYPE ARE INHERITED FROM THE PARENT IF THOSE " & + "ASPECTS OF THE PARENT WERE DETERMINED BY " & + "THE PRAGMA PACK"); + + IF DERIVED_TYPE'SIZE /= PARENT_TYPE'SIZE THEN + FAILED ("DERIVED_TYPE'SIZE WAS NOT INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + IF REC.I'SIZE /= P_REC.I'SIZE OR + REC.C'SIZE /= P_REC.C'SIZE OR + REC.B1'SIZE /= P_REC.B1'SIZE OR + REC.B2'SIZE /= P_REC.B2'SIZE OR + REC.E'SIZE /= P_REC.E'SIZE THEN + FAILED ("THE SIZES OF DERIVED_TYPE ELEMENTS WERE NOT " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + REC := (FALSE, 12, 'T', TRUE, RED); + + IF (REC.I /= 12) OR (REC.C /= 'T') OR + REC.B1 OR (NOT REC.B2) OR (REC.E /= RED) THEN + FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " & + "INCORRECT"); + END IF; + + IF REC.I'POSITION /= P_REC.I'POSITION OR + REC.C'POSITION /= P_REC.C'POSITION OR + REC.B1'POSITION /= P_REC.B1'POSITION OR + REC.B2'POSITION /= P_REC.B2'POSITION OR + REC.E'POSITION /= P_REC.E'POSITION THEN + FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'FIRST_BIT /= P_REC.I'FIRST_BIT OR + REC.C'FIRST_BIT /= P_REC.C'FIRST_BIT OR + REC.B1'FIRST_BIT /= P_REC.B1'FIRST_BIT OR + REC.B2'FIRST_BIT /= P_REC.B2'FIRST_BIT OR + REC.E'FIRST_BIT /= P_REC.E'FIRST_BIT THEN + FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'LAST_BIT /= P_REC.I'LAST_BIT OR + REC.C'LAST_BIT /= P_REC.C'LAST_BIT OR + REC.B1'LAST_BIT /= P_REC.B1'LAST_BIT OR + REC.B2'LAST_BIT /= P_REC.B2'LAST_BIT OR + REC.E'LAST_BIT /= P_REC.E'LAST_BIT THEN + FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "NOT INHERITED FROM PARENT_TYPE"); + END IF; + + RESULT; + + END CD1C03I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CD1C04A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SIZE CLAUSE CAN BE GIVEN FOR A DERIVED TYPE, A + -- DERIVED PRIVATE TYPE, AND A DERIVED LIMITED PRIVATE TYPE EVEN + -- IF THE SIZE IS INHERITED FROM THE PARENT, AND THAT THE SIZE + -- CLAUSES FOR THE DERIVED TYPES OVERRIDE THE PARENTS'. + + -- HISTORY: + -- PWB 03/25/89 MODIFIED METHOD OF CHECKING OBJECT SIZE AGAINST + -- TYPE SIZE; CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/16/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C04A IS + + SPECIFIED_SIZE : CONSTANT := INTEGER'SIZE / 2; + + TYPE PARENT_TYPE IS RANGE 0 .. 100; + + FOR PARENT_TYPE'SIZE USE INTEGER'SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + FOR DERIVED_TYPE'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE PRIVATE_PARENT IS PRIVATE; + TYPE LIM_PRIV_PARENT IS LIMITED PRIVATE; + PRIVATE + TYPE PRIVATE_PARENT IS RANGE 0 .. 100; + FOR PRIVATE_PARENT'SIZE USE INTEGER'SIZE; + TYPE LIM_PRIV_PARENT IS RANGE 0 .. 100; + FOR LIM_PRIV_PARENT'SIZE USE INTEGER'SIZE; + END P; + + USE P; + + TYPE DERIVED_PRIVATE_TYPE IS NEW PRIVATE_PARENT; + + FOR DERIVED_PRIVATE_TYPE'SIZE USE SPECIFIED_SIZE; + + TYPE DERIVED_LIM_PRIV_TYPE IS NEW LIM_PRIV_PARENT; + + FOR DERIVED_LIM_PRIV_TYPE'SIZE USE SPECIFIED_SIZE; + + DT : DERIVED_TYPE := 100; + DPT : DERIVED_PRIVATE_TYPE; + DLPT : DERIVED_LIM_PRIV_TYPE; + + BEGIN + + TEST("CD1C04A", "CHECK THAT A SIZE CLAUSE CAN BE GIVEN FOR " & + "A DERIVED TYPE, A DERIVED PRIVATE TYPE, AND " & + "A DERIVED LIMITED PRIVATE TYPE EVEN IF THE " & + "SIZE IS INHERITED FROM THE PARENT, AND THAT " & + "THE SIZE CLAUSES FOR THE DERIVED TYPES " & + "OVERRIDE THE PARENTS'"); + + IF PARENT_TYPE'SIZE /= IDENT_INT (INTEGER'SIZE) THEN + FAILED ("PARENT_TYPE'SIZE SHOULD BE " & + INTEGER'IMAGE(INTEGER'SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT_TYPE'SIZE)); + END IF; + + IF DERIVED_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE SHOULD BE " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'SIZE)); + END IF; + + IF DT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DT'SIZE)); + END IF; + + IF PRIVATE_PARENT'SIZE < IDENT_INT (INTEGER'SIZE) THEN + FAILED ("PRIVATE_PARENT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(INTEGER'SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PRIVATE_PARENT'SIZE)); + END IF; + + IF DERIVED_PRIVATE_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_PRIVATE_TYPE'SIZE SHOULD BE " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_TYPE'SIZE)); + END IF; + + IF DPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DPT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DPT'SIZE)); + END IF; + + IF LIM_PRIV_PARENT'SIZE /= IDENT_INT (INTEGER'SIZE) THEN + FAILED ("LIM_PRIV_PARENT'SIZE SHOULD BE" & + INTEGER'IMAGE(INTEGER'SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(LIM_PRIV_PARENT'SIZE)); + END IF; + + IF DERIVED_LIM_PRIV_TYPE'SIZE /= IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_LIM_PRIV_TYPE'SIZE SHOULD BE " & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_LIM_PRIV_TYPE'SIZE)); + END IF; + + IF DLPT'SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DLPT'SIZE SHOULD NOT BE LESS THAN" & + INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DLPT'SIZE)); + END IF; + + RESULT; + + END CD1C04A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- CD1C04D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN + -- FOR A DERIVED ENUMERATION TYPE EVEN IF THE REPRESENTATION IS + -- INHERITED FROM THE PARENT, AND THAT THE CLAUSE FOR THE DERIVED + -- TYPE OVERRIDES THAT OF THE PARENT. + + -- HISTORY: + -- JET 09/21/87 CREATED ORIGINAL TEST. + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSE. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD1C04D IS + + TYPE NORMAL_TYPE IS (RED, BLUE, GREEN, YELLOW); + + TYPE PARENT_TYPE IS (RED, BLUE, GREEN, YELLOW); + + FOR PARENT_TYPE USE + (RED => 256, BLUE => 257, GREEN => 258, YELLOW => 259); + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + FOR DERIVED_TYPE USE + (RED => 16, BLUE => 17, GREEN => 18, YELLOW => 19); + + TYPE INT1 IS RANGE 16 .. 19; + FOR INT1'SIZE USE DERIVED_TYPE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(DERIVED_TYPE, INT1); + + BEGIN + + TEST("CD1C04D", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED ENUMERATION " & + "TYPE EVEN IF THE REPRESENTATION IS INHERITED " & + "FROM THE PARENT, AND THAT THE CLAUSE FOR THE " & + "DERIVED TYPE OVERRIDES THAT OF THE PARENT"); + + IF PARENT_TYPE'SIZE = IDENT_INT (NORMAL_TYPE'SIZE) THEN + COMMENT ("PARENT_TYPE'SIZE WAS NOT AFFECTED BY THE " & + "REPRESENTATION CLAUSE"); + END IF; + + IF DERIVED_TYPE'SIZE >= IDENT_INT (PARENT_TYPE'SIZE) THEN + COMMENT ("THE SPECIFICATION OF SMALLER VALUES FOR THE " & + "REPRESENTATION OF DERIVED_TYPE DID NOT " & + "REDUCE THE SIZE OF DERIVED_TYPE"); + END IF; + + CHECK_1 (DERIVED_TYPE'(GREEN), 18, "DERIVED_TYPE"); + + RESULT; + + END CD1C04D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c04e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CD1C04E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR + -- A DERIVED RECORD TYPE EVEN IF THE REPRESENTATION IS INHERITED + -- FROM THE PARENT, AND THAT THE REPRESENTATION CLAUSE FOR THE + -- DERIVED TYPE OVERRIDES THAT OF THE PARENT TYPE. + + -- HISTORY: + -- PWB 03/25/89 DELETED CHECKS OF COMPONENT'SIZE; CHANGED + -- EXTENSION FROM '.ADA' TO '.DEP'. + -- JET 09/21/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD1C04E IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE E_TYPE IS (RED, BLUE, GREEN); + + TYPE PARENT_TYPE IS + RECORD + I : INTEGER RANGE 0 .. 127 := 127; + C : CHARACTER := 'S'; + B : BOOLEAN := FALSE; + E : E_TYPE := BLUE; + END RECORD; + + FOR PARENT_TYPE USE + RECORD + C AT 0 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1; + B AT 1 * UNITS_PER_INTEGER RANGE 0 .. BOOLEAN'SIZE - 1; + I AT 2 * UNITS_PER_INTEGER RANGE 0 .. INTEGER'SIZE/2 - 1; + E AT 3 * UNITS_PER_INTEGER RANGE 0 .. CHARACTER'SIZE - 1; + END RECORD; + + TYPE DERIVED_TYPE IS NEW PARENT_TYPE; + + FOR DERIVED_TYPE USE + RECORD + C AT 1 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1; + B AT 3 * UNITS_PER_INTEGER RANGE 1 .. BOOLEAN'SIZE + 1; + I AT 5 * UNITS_PER_INTEGER RANGE 1 .. INTEGER'SIZE/2 + 1; + E AT 7 * UNITS_PER_INTEGER RANGE 1 .. CHARACTER'SIZE + 1; + END RECORD; + + P_REC : PARENT_TYPE; + REC : DERIVED_TYPE; + + BEGIN + + TEST("CD1C04E", "CHECK THAT A RECORD REPRESENTATION CLAUSE " & + "CAN BE GIVEN FOR A DERIVED RECORD TYPE EVEN " & + "IF THE REPRESENTATION IS INHERITED FROM " & + "THE PARENT, AND THAT THE REPRESENTATION " & + "CLAUSE FOR THE DERIVED TYPE OVERRIDES THAT " & + "OF THE PARENT TYPE"); + + IF DERIVED_TYPE'SIZE = IDENT_INT (PARENT_TYPE'SIZE) THEN + FAILED ("DERIVED_TYPE'SIZE WAS INHERITED FROM " & + "PARENT_TYPE"); + END IF; + + REC := (12, 'T', TRUE, RED); + + IF (REC.I /= 12) OR (REC.C /= 'T') OR + (NOT REC.B) OR (REC.E /= RED) THEN + FAILED ("THE VALUES OF DERIVED_TYPE COMPONENTS WERE " & + "INCORRECT"); + END IF; + + IF REC.I'POSITION = P_REC.I'POSITION OR + REC.C'POSITION = P_REC.C'POSITION OR + REC.B'POSITION = P_REC.B'POSITION OR + REC.E'POSITION = P_REC.E'POSITION THEN + FAILED ("THE POSITIONS OF DERIVED_TYPE COMPONENTS WERE " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'FIRST_BIT = P_REC.I'FIRST_BIT OR + REC.C'FIRST_BIT = P_REC.C'FIRST_BIT OR + REC.B'FIRST_BIT = P_REC.B'FIRST_BIT OR + REC.E'FIRST_BIT = P_REC.E'FIRST_BIT THEN + FAILED ("THE FIRST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + IF REC.I'LAST_BIT = P_REC.I'LAST_BIT OR + REC.C'LAST_BIT = P_REC.C'LAST_BIT OR + REC.B'LAST_BIT = P_REC.B'LAST_BIT OR + REC.E'LAST_BIT = P_REC.E'LAST_BIT THEN + FAILED ("THE LAST_BITS OF DERIVED_TYPE COMPONENTS WERE " & + "INHERITED FROM PARENT_TYPE"); + END IF; + + RESULT; + + END CD1C04E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd1c06a.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + -- CD1C06A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE + -- IS NOT EVALUATED AGAIN WHEN A DERIVED TYPE INHERITS THE + -- STORAGE SIZE OF THE PARENT. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY: + -- JET 09/21/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED SPECIFIED_SIZE TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + + WITH REPORT; USE REPORT; + PROCEDURE CD1C06A IS + + I : INTEGER := 0; + + SPECIFIED_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + FUNCTION COUNT_SIZE RETURN INTEGER IS + BEGIN + I := I + 1; + RETURN SPECIFIED_SIZE * I; + END; + + BEGIN + + TEST("CD1C06A", "CHECK THAT THE EXPRESSION IN A TASK STORAGE " & + "SIZE CLAUSE IS NOT EVALUATED AGAIN WHEN A " & + "DERIVED TYPE INHERITS THE STORAGE SIZE OF " & + "THE PARENT"); + + DECLARE + + TASK TYPE PARENT IS + ENTRY E; + END PARENT; + + FOR PARENT'STORAGE_SIZE USE COUNT_SIZE; + + TYPE DERIVED_TYPE IS NEW PARENT; + + TASK BODY PARENT IS + BEGIN + ACCEPT E DO + COMMENT ("ENTRY E ACCEPTED"); + END E; + END PARENT; + + BEGIN + IF PARENT'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("PARENT'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN" & INTEGER'IMAGE (SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(PARENT'STORAGE_SIZE)); + END IF; + + IF DERIVED_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("DERIVED_TYPE'STORAGE_SIZE SHOULD NOT BE " & + "LESS THAN" & INTEGER'IMAGE(SPECIFIED_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_TYPE'STORAGE_SIZE)); + END IF; + + IF I > IDENT_INT (1) THEN + FAILED ("THE EXPRESSION FOR THE STORAGE SIZE " & + "SPECIFICATION WAS EVALUATED MORE THAN ONCE"); + END IF; + + END; + + RESULT; + + END CD1C06A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd20001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd20001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd20001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd20001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,275 ---- + -- CD20001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for packed records the components are packed as tightly + -- as possible subject to the Size of the component subtypes. + -- Specifically check that Boolean objects are packed one to a bit. + -- + -- Check that the Component_Size for a packed array type is less than + -- or equal to the smallest of those factors of the word size that are + -- greater than or equal to the Size of the component subtype. + -- + -- TEST DESCRIPTION: + -- This test defines and packs several types, and checks that the sizes + -- of the resulting objects is as expected. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as + -- inapplicable. Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 08 MAY 96 SAIC Strengthened for 2.1 + -- 29 JAN 98 EDS Deleted check that Component_Size is really a + -- factor of Word_Size. + --! + + ----------------------------------------------------------------- CD20001_0 + + with System; + package CD20001_0 is + + type Wordlong_Bool_Array is array(1..System.Word_Size) of Boolean; + pragma Pack(Wordlong_Bool_Array); -- ANX-C RQMT + + type Def_Rep_Components is range 0..2**(System.Storage_Unit-2); + + type Spec_Rep_Components is range 0..2**(System.Storage_Unit-2); + for Spec_Rep_Components'Size use System.Storage_Unit; -- ANX-C RQMT + + type Packed_Array_Def_Components is array(1..32) of Def_Rep_Components; + pragma Pack(Packed_Array_Def_Components); -- ANX-C RQMT + + type Packed_Array_Spec_Components is array(1..32) of Spec_Rep_Components; + pragma Pack(Packed_Array_Spec_Components); -- ANX-C RQMT + + procedure TC_Check_Values; + + end CD20001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body CD20001_0 is + + procedure TC_Check_Values is + My_Word : Wordlong_Bool_Array := (others => False); + + Cited_Unit : Spec_Rep_Components := 0; + + Packed_Array : Packed_Array_Def_Components := (others => 0); + + Cited_Packed : Packed_Array_Spec_Components := (others => 0); + + begin + TCTouch.Assert( My_Word'Size = System.Word_Size, + "pragma Pack on array of Booleans does not pack one Boolean per bit" ); + + TCTouch.Assert( My_Word'Component_Size = 1, + "size of Boolean array component not 1 bit"); + + TCTouch.Assert( Cited_Unit'Size = System.Storage_Unit, + "Object specified to be Storage_Unit bits not " & + "Storage_Unit bits in size"); + + TCTouch.Assert( Packed_Array'Component_Size <= System.Storage_Unit, + "Packed array component expected to be less than or " & + "equal to Storage_Unit bits in size is greater than " & + "Storage_Unit bits in size"); + + TCTouch.Assert( Cited_Packed'Component_Size = System.Storage_Unit, + "Array component specified to be Storage_Unit " & + "bits not Storage_Unit bits in size"); + + end TC_Check_Values; + + end CD20001_0; + + ----------------------------------------------------------------- CD20001_1 + + with System; + package CD20001_1 is + + type Bits_2 is range 0..2**2-1; + for Bits_2'Size use 2; -- ANX-C RQMT + + type Bits_3 is range 0..2**3-1; + for Bits_3'Size use 3; -- ANX-C RQMT + + type Bits_7 is range 0..2**7-1; + for Bits_7'Size use 7; -- ANX-C RQMT + + type Bits_8 is range 0..2**8-1; + for Bits_8'Size use 8; -- ANX-C RQMT + + type Bits_9 is range 0..2**9-1; + for Bits_9'Size use 9; -- ANX-C RQMT + + type Bits_15 is range 0..2**15-1; + for Bits_15'Size use 15; -- ANX-C RQMT + + type Pact_Aray_2 is array(0..31) of Bits_2; + pragma Pack( Pact_Aray_2 ); -- ANX-C RQMT + + type Pact_Aray_3 is array(0..31) of Bits_3; + pragma Pack( Pact_Aray_3 ); -- ANX-C RQMT + + type Pact_Aray_7 is array(0..31) of Bits_7; + pragma Pack( Pact_Aray_7 ); -- ANX-C RQMT + + type Pact_Aray_8 is array(0..31) of Bits_8; + pragma Pack( Pact_Aray_8 ); -- ANX-C RQMT + + type Pact_Aray_9 is array(0..31) of Bits_9; + pragma Pack( Pact_Aray_9 ); -- ANX-C RQMT + + type Pact_Aray_15 is array(0..31) of Bits_15; + pragma Pack( Pact_Aray_15 ); -- ANX-C RQMT + + + procedure TC_Check_Values; + + end CD20001_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with TCTouch; + package body CD20001_1 is + + function Next_Factor ( Value : Positive ) return Integer is + -- Returns the factor of Word_Size that is next larger than Value. + -- If Value is greater than Word_Size, then returns Word_Size. + Test : Integer := Value; + Found : Boolean := False; + begin -- Next_Factor + while not Found and Test <= System.Word_Size loop + if System.Word_Size mod Test = 0 then + Found := True; + else + Test := Test + 1; + end if; + end loop; + if Found then + return Test; + else + return System.Word_Size; + end if; + end Next_Factor; + + procedure TC_Check_Values is + begin + + if Pact_Aray_2'Component_Size > Next_Factor ( Bits_2'Size ) then + Report.Failed + ( "2 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_2'Component_Size <= Pact_Aray_2'Size, + "2 bit Component_Size greater than array size" ); + + if Pact_Aray_3'Component_Size > Next_Factor ( Bits_3'Size ) then + Report.Failed + ( "3 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_3'Component_Size <= Pact_Aray_3'Size, + "3 bit Component_Size greater than array size" ); + + if Pact_Aray_7'Component_Size > Next_Factor ( Bits_7'Size ) then + Report.Failed + ( "7 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_7'Component_Size <= Pact_Aray_7'Size, + "7 bit Component_Size greater than array size" ); + + if Pact_Aray_8'Component_Size > Next_Factor ( Bits_8'Size ) then + Report.Failed + ( "8 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_8'Component_Size <= Pact_Aray_8'Size, + "8 bit Component_Size greater than array size" ); + + if System.Word_Size > 8 then + + if Pact_Aray_9'Component_Size > Next_Factor ( Bits_9'Size ) then + Report.Failed + ( "9 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_9'Component_Size <= Pact_Aray_9'Size, + "9 bit Component_Size greater than array size" ); + + if Pact_Aray_15'Component_Size > Next_Factor ( Bits_15'Size ) then + Report.Failed + ( "15 bit element Packed Array'Component_Size too big" ); + end if; + + TCTouch.Assert( Pact_Aray_15'Component_Size <= Pact_Aray_15'Size, + "15 bit Component_Size greater than array size" ); + + end if; + + end TC_Check_Values; + + end CD20001_1; + + ------------------------------------------------------------------- CD20001 + + with Report; + with CD20001_0; + with CD20001_1; + + procedure CD20001 is + + begin -- Main test procedure. + + Report.Test ("CD20001", "Check that packed records are packed as tightly " & + "as possible. Check that Boolean objects are " & + "packed one to a bit. " & + "Check that the Component_Size for a packed " & + "array type is the value which is less than or " & + "equal to the Size of the component type, " & + "rounded up to the nearest factor of word_size" ); + + CD20001_0.TC_Check_Values; + + CD20001_1.TC_Check_Values; + + Report.Result; + + end CD20001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- CD2A21A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 07/28/87 CREATED ORIGINAL TEST. + -- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- JRL 03/26/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALLED TO 'FAILED'. + PROCEDURE CD2A21A IS + + BASIC_SIZE : CONSTANT := INTEGER'SIZE/2; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((CI0 < IDENT (ONE)) AND + (IDENT (CI2) > IDENT (CIO1)) AND + (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1"); + END IF; + + IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR + CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1"); + END IF; + + IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A21A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN ENUMERATION TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (ZERO, TWO, C1, C2, C2); + CHECK_1 (TWO, INTEGER'SIZE/2, "CHECK_TYPE"); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (ONE) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3"); + END IF; + + IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3"); + END IF; + + IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4"); + END IF; + + IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4"); + END IF; + + RESULT; + END CD2A21A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- CD2A21C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SIZE SPECIFICATION CAN BE GIVEN FOR AN ENUMERATION + -- TYPE: + -- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE + -- DECLARED IN THE VISIBLE PART; + -- FOR A DERIVED ENUMERATION TYPE; + -- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS + -- AN ENUMERATION TYPE. + + -- HISTORY: + -- PWB 06/17/87 CREATED ORIGINAL TEST. + -- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- JRL 03/26/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A21C IS + + TYPE BASIC_ENUM IS (A, B, C, D, E); + SPECIFIED_SIZE : CONSTANT := BASIC_ENUM'SIZE; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + TYPE DERIVED_ENUM IS NEW BASIC_ENUM; + FOR DERIVED_ENUM'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE ENUM_IN_P IS (A1, B1, C1, D1, E1, F1, G1); + FOR ENUM_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_ENUM IS PRIVATE; + TYPE ALT_ENUM_IN_P IS (A2, B2, C2, D2, E2, F2, G2); + PRIVATE + TYPE PRIVATE_ENUM IS (A3, B3, C3, D3, E3, F3, G3); + FOR ALT_ENUM_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + TYPE DERIVED_PRIVATE_ENUM IS NEW P.PRIVATE_ENUM; + FOR DERIVED_PRIVATE_ENUM'SIZE USE SPECIFIED_SIZE; + + USE P; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_ENUM); + PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (ENUM_IN_P); + PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_ENUM_IN_P); + + BEGIN + + TEST("CD2A21C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN " & + "IN THE VISIBLE OR PRIVATE PART OF A PACKAGE " & + "FOR ENUMERATION TYPES DECLARED IN THE VISIBLE " & + "PART, AND FOR DERIVED ENUMERATION " & + "TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " & + "DECLARATIONS ARE AS ENUMERATION TYPES"); + + CHECK_1 (C, SPECIFIED_SIZE, "DERIVED_ENUM"); + CHECK_2 (C1, SPECIFIED_SIZE, "ENUM_IN_P"); + CHECK_3 (C2, SPECIFIED_SIZE, "ALT_ENUM_IN_P"); + + IF DERIVED_ENUM'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_ENUM'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_ENUM'SIZE)); + END IF; + + IF ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ENUM_IN_P'SIZE)); + END IF; + + IF ALT_ENUM_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_ENUM_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ALT_ENUM_IN_P'SIZE)); + END IF; + + IF DERIVED_PRIVATE_ENUM'SIZE /= MINIMUM_SIZE THEN + + FAILED ("DERIVED_PRIVATE_ENUM'SIZE SHOULD NOT BE GREATER " & + "THAN " & INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_ENUM'SIZE)); + END IF; + + RESULT; + + END CD2A21C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a21e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- CD2A21E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- ENUMERATION TYPE, THEN SUCH A TYPE CAN + -- BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC PROCEDURE. + + -- HISTORY: + -- JET 08/18/87 CREATED ORIGINAL TEST. + -- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE + -- SPECIFICATION IS OBEYED. + -- LDC 10/03/90 ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION, + -- AND EXPLICIT CONVERSION. + -- JRL 03/26/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A21E IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := INTEGER'SIZE / 2; + + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A21E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN ENUMERATION TYPE, " & + "THEN SUCH A TYPE CAN BE " & + "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " & + "PROCEDURE"); + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + C3 : GPARM; + + CHECKVAR : CHECK_TYPE; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + CHECKVAR := IDENT (C0); + + CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE"); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (IDENT(C0) NOT IN IDENT (C1) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE"); + END IF; + + CHECKVAR := CHECK_TYPE'VALUE ("ONE"); + C3 := GPARM(CHECKVAR); + IF C3 /= IDENT(C1) THEN + FAILED ("INCORRECT VALUE FOR CONVERSION"); + END IF; + + CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM"); + + + IF CHECK_TYPE'(C2) /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR QUALIFICATION"); + END IF; + + C3 := CHECK_TYPE'VALUE ("TWO"); + IF C3 /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR ASSIGNMENT"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + + END CD2A21E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + -- CD2A22A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + + -- CHECK THAT IF A SIZE SPECIFICATION INDICATING THE SMALLEST SIZE + -- APPROPRIATE FOR A SIGNED REPRESENTATION IS GIVEN FOR AN + -- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 07/28/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A22A IS + + BASIC_SIZE : CONSTANT := 3; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((CI0 < IDENT (ONE)) AND + (IDENT (CI2) > IDENT (CIO1)) AND + (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1"); + END IF; + + IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR + CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1"); + END IF; + + IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A22A", "CHECK THAT IF A SIZE SPECIFICATION " & + "INDICATING THE SMALLEST SIZE APPROPRIATE " & + "FOR A SIGNED REPRESENTATION IS GIVEN " & + "FOR AN ENUMERATION TYPE, THEN OPERATIONS " & + "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " & + "BY THE REPRESENTATION CLAUSE"); + + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (ONE) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3"); + END IF; + + IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3"); + END IF; + + IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3"); + END IF; + + IF CHREC.COMP1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP1'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4"); + END IF; + + IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4"); + END IF; + + RESULT; + END CD2A22A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- CD2A22E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + + -- CHECK THAT IF A SIZE CLAUSE SPECIFYING THE SMALLEST SIZE + -- APPROPRIATE FOR AN UNSIGNED REPRESENTATION IS GIVEN FOR AN + -- ENUMERATION TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A22E IS + + BASIC_SIZE : CONSTANT := 2; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF CIO1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CIO1'SIZE"); + END IF; + + IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND + (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR + CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR + CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1"); + END IF; + + IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR + CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A22E", "CHECK THAT IF A SIZE CLAUSE " & + "SPECIFYING THE SMALLEST SIZE APPROPRIATE " & + "FOR AN UNSIGNED REPRESENTATION IS GIVEN " & + "FOR AN ENUMERATION TYPE, THEN OPERATIONS " & + "ON VALUES OF SUCH A TYPE ARE NOT AFFECTED " & + "BY THE REPRESENTATION CLAUSE"); + + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (TWO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3"); + END IF; + + IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4"); + END IF; + + IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4"); + END IF; + + IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4"); + END IF; + + RESULT; + END CD2A22E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- CD2A22I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A SIZE CLAUSE SPECIFIES THE SMALLEST APPROPRIATE + -- SIZE FOR A SIGNED REPRESENTATION FOR AN ENUMERATION TYPE, + -- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN + -- INSTANTIATION. + + -- HISTORY: + -- JET 08/13/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A22I IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 3; + + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A22I", "CHECK THAT IF A SIZE CLAUSE SPECIFIES THE " & + "SMALLEST APPROPRIATE SIZE FOR A SIGNED " & + "REPRESENTATION FOR AN ENUMERATION TYPE, THEN " & + "THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN " & + "AN INSTANTIATION"); + + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (C1) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + + END CD2A22I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a22j.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- CD2A22J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- ENUMERATION TYPE, THEN SUCH A TYPE OF THE SMALLEST APPROPRIATE + -- UNSIGNED SIZE CAN BE PASSED AS AN ACTUAL PARAMETER TO A GENERIC + -- PROCEDURE. + + -- HISTORY: + -- JET 08/13/87 CREATED ORIGINAL TEST. + -- DHH 04/17/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A22J IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 2; + + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A22J", "CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN " & + "FOR AN ENUMERATION TYPE, THEN SUCH A TYPE OF " & + "THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE " & + "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " & + "PROCEDURE"); + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + BEGIN -- GENPROC. + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (C1)) AND + (IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (C0) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + END CD2A22J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a23a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,221 ---- + -- CD2A23A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT AFFECTED + -- BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 07/28/87 CREATED ORIGINAL TEST. + -- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A23A IS + + BASIC_SIZE : CONSTANT := INTEGER'SIZE/2; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND + (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR + CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR + CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1"); + END IF; + + IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR + CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A23A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " & + "AN ENUMERATION REPRESENTATION CLAUSE ARE " & + "GIVEN FOR AN ENUMERATION TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + PROC (ZERO, TWO, C1, C2, C2); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (TWO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3"); + END IF; + + IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4"); + END IF; + + IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4"); + END IF; + + IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4"); + END IF; + + + RESULT; + + END CD2A23A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a23e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- CD2A23E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL PARAMETER TO A + -- GENERIC PROCEDURE. + + -- HISTORY: + -- JET 08/18/87 CREATED ORIGINAL TEST. + -- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- BCB 03/05/90 ADDED CALL TO LENGTH_CHECK TO VERIFY THAT THE SIZE + -- SPECIFICATION IS OBEYED. + -- LDC 10/03/90 ADDED EXCEPTION HANDER FOR CHECK OF 'SUCC, 'PRED, + -- ADDED CASES FOR >=, /=, ASSIGNMENT, QUALIFICATION, + -- AND EXPLICIT CONVERSION. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A23E IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 8; + + FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, TWO => 5); + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A23E", "CHECK THAT WHEN A SIZE SPECIFICATION AND AN " & + "ENUMERATION REPRESENTATION CLAUSE ARE " & + "GIVEN FOR AN ENUMERATION TYPE, " & + "THEN SUCH A TYPE CAN BE " & + "PASSED AS AN ACTUAL PARAMETER TO A GENERIC " & + "PROCEDURE"); + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + C3 : GPARM; + + CHECKVAR : CHECK_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + + BEGIN -- GENPROC. + + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + + CHECKVAR := IDENT (C0); + + CHECK_1 (CHECKVAR, CHECK_TYPE'SIZE, "CHECK_TYPE"); + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT(C0) < IDENT (C1)) AND + (IDENT(C2) > IDENT (C1)) AND + (IDENT(C1) <= IDENT (C1)) AND + (IDENT(C2) = IDENT (C2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (C0) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC"); + END IF; + + BEGIN + IF CHECK_TYPE'SUCC (IDENT(C2)) /= IDENT (C1) THEN + FAILED ("CONSTRAINT ERROR NOT RAISED FOR " & + "CHECK_TYPE'SUCC"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF 3 /= IDENT_INT(3) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION -1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "CHECK_TYPE'SUCC"); + END; + + BEGIN + IF CHECK_TYPE'PRED(IDENT(C0)) /= IDENT (C1) THEN + FAILED ("CONSTRAINT ERROR NOT RAISED FOR " & + "CHECK_TYPE'PRED"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF 3 /= IDENT_INT(3) THEN + COMMENT ("DON'T OPTIMIZE EXCEPTION -2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "CHECK_TYPE'PRED"); + END; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE"); + END IF; + + CHECKVAR := CHECK_TYPE'VALUE ("ONE"); + C3 := GPARM(CHECKVAR); + IF C3 /= IDENT(C1) THEN + FAILED ("INCORRECT VALUE FOR CONVERSION"); + END IF; + + CHECK_1 (IDENT(C0), BASIC_SIZE, "CHECK_ENUM"); + + + IF CHECK_TYPE'(C2) /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR QUALIFICATION"); + END IF; + + C3 := CHECK_TYPE'VALUE ("TWO"); + IF C3 /= IDENT(C2) THEN + FAILED ("INCORRECT VALUE FOR ASSIGNMENT"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + + END CD2A23E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- CD2A24A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- THEN OPERATIONS ON VALUES OF SUCH A TYPE WITH THE SMALLEST + -- APPROPRIATE SIGNED SIZE ARE NOT AFFECTED BY THE + -- REPRESENTATION CLAUSE. + + -- HISTORY: + -- JET 08/19/87 CREATED ORIGINAL TEST. + -- DHH 04/18/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND ADDED CHECK ON + -- REPRESENTATION CLAUSE. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A24A IS + + BASIC_SIZE : CONSTANT := 4; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, TWO => 5); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (CHECK_TYPE); + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((IDENT (CIO1) IN CIO1 .. CIO2) AND + (CI0 NOT IN IDENT (ONE) .. CIO2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CI0) OR + CHECK_TYPE'VAL (1) /= IDENT (CIO1) OR + CHECK_TYPE'VAL (2) /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 1"); + END IF; + + IF CHECK_TYPE'PRED (CIO1) /= IDENT (CI0) OR + CHECK_TYPE'PRED (CIO2) /= IDENT (CIO1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 1"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CI0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CIO1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CIO2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 1"); + END IF; + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A24A", "CHECK THAT WHEN A SIZE SPECIFICATION AND " & + "AN ENUMERATION REPRESENTATION CLAUSE ARE " & + "GIVEN FOR AN ENUMERATION TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE WITH " & + "THE SMALLEST APPROPRIATE SIGNED SIZE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (C0, BASIC_SIZE, "CHECK_TYPE"); + PROC (ZERO, TWO, C1, C2, C2); + + IF C1 /= ONE OR C2 /= TWO THEN + FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (ONE)) AND(IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (ONE)) AND(IDENT (TWO) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (TWO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST - 2"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 2"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 2"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VAL (1) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VAL (2) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 3"); + END IF; + + IF CHECK_TYPE'PRED (CHARRAY (1)) /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'PRED (CHARRAY (2)) /= IDENT (CHARRAY (1)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 3"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHARRAY (0)) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'POS (CHREC.COMP0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHREC.COMP1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHREC.COMP2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 4"); + END IF; + + IF CHECK_TYPE'SUCC (CHREC.COMP0) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'SUCC (CHREC.COMP1) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 4"); + END IF; + + IF CHECK_TYPE'IMAGE (CHREC.COMP0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHREC.COMP1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHREC.COMP2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 4"); + END IF; + + + RESULT; + + END CD2A24A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,220 ---- + -- CD2A24E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A SIZE CLAUSE AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- AND THE SMALLEST SIZE APPROPRIATE FOR AN UNSIGNED REPRESENTATION + -- IS SPECIFIED, THEN OPERATIONS ON THE TYPE ARE NOT AFFECTED. + + -- HISTORY: + -- JET 08/19/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A24E IS + + BASIC_SIZE : CONSTANT := 3; + + TYPE CHECK_TYPE IS (ZERO, ONE, TWO); + + FOR CHECK_TYPE USE (ZERO => 3, ONE => 4, + TWO => 5); + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + C0 : CHECK_TYPE := ZERO; + C1 : CHECK_TYPE := ONE; + C2 : CHECK_TYPE := TWO; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 2) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := (ZERO, ONE, TWO); + + TYPE REC_TYPE IS RECORD + COMP0 : CHECK_TYPE := ZERO; + COMP1 : CHECK_TYPE := ONE; + COMP2 : CHECK_TYPE := TWO; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN ONE; + END IF; + END IDENT; + + PROCEDURE PROC (CI0, CI2 : CHECK_TYPE; + CIO1, CIO2 : IN OUT CHECK_TYPE; + CO2 : OUT CHECK_TYPE) IS + BEGIN + IF NOT ((CI0 < IDENT (ONE)) AND + (IDENT (CI2) > IDENT (CIO1)) AND + (CIO1 <= IDENT (ONE)) AND(IDENT (TWO) = CI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 1"); + END IF; + + IF CHECK_TYPE'POS (CI0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CIO1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CI2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 1"); + END IF; + + IF CHECK_TYPE'SUCC (CI0) /= IDENT (CIO1) OR + CHECK_TYPE'SUCC (CIO1) /= IDENT (CI2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 1"); + END IF; + + IF CHECK_TYPE'IMAGE (CI0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CIO1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CI2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 1"); + END IF; + + + CO2 := TWO; + + END PROC; + + BEGIN + TEST ("CD2A24E", "CHECK THAT IF A SIZE CLAUSE AND AN ENUMERATION " & + "REPRESENTATION CLAUSE ARE GIVEN FOR AN " & + "ENUMERATION TYPE, AND THE SMALLEST SIZE " & + "APPROPRIATE FOR AN UNSIGNED REPRESENTATION " & + "IS SPECIFIED, THEN OPERATIONS ON THE TYPE " & + "ARE NOT AFFECTED"); + + PROC (ZERO, TWO, C1, C2, C2); + + IF C1 /= ONE OR C2 /= TWO THEN + FAILED ("INCORRECT VALUE RETURNED BY PROCEDURE"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (ONE) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (ZERO) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST - 2"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 2"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 2"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF NOT ((CHARRAY (0) < IDENT (ONE)) AND + (IDENT (CHARRAY (2)) > IDENT (CHARRAY (1))) AND + (CHARRAY (1) <= IDENT (ONE)) AND + (IDENT (TWO) = CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF NOT ((IDENT (CHARRAY (1)) IN CHARRAY (1) .. CHARRAY (2)) AND + (CHARRAY (0) NOT IN IDENT (ONE) .. CHARRAY (2))) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF CHECK_TYPE'POS (CHARRAY (0)) /= IDENT_INT (0) OR + CHECK_TYPE'POS (CHARRAY (1)) /= IDENT_INT (1) OR + CHECK_TYPE'POS (CHARRAY (2)) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS - 3"); + END IF; + + IF CHECK_TYPE'SUCC (CHARRAY (0)) /= IDENT (CHARRAY (1)) OR + CHECK_TYPE'SUCC (CHARRAY (1)) /= IDENT (CHARRAY (2)) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC - 3"); + END IF; + + IF CHECK_TYPE'IMAGE (CHARRAY (0)) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (CHARRAY (1)) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (CHARRAY (2)) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE - 3"); + END IF; + + IF CHREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMP2'SIZE"); + END IF; + + IF NOT ((CHREC.COMP0 < IDENT (ONE)) AND + (IDENT (CHREC.COMP2) > IDENT (CHREC.COMP1)) AND + (CHREC.COMP1 <= IDENT (ONE)) AND + (IDENT (TWO) = CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF NOT ((IDENT (CHREC.COMP1) IN CHREC.COMP1 .. CHREC.COMP2) AND + (CHREC.COMP0 NOT IN IDENT (ONE) .. CHREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VAL (1) /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VAL (2) /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL - 4"); + END IF; + + IF CHECK_TYPE'PRED (CHREC.COMP1) /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'PRED (CHREC.COMP2) /= IDENT (CHREC.COMP1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED - 4"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (CHREC.COMP0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (CHREC.COMP1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (CHREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE - 4"); + END IF; + + RESULT; + END CD2A24E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- CD2A24I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE + -- SIZE FOR A SIGNED REPRESENTATION) AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN + -- INSTANTIATION. + + -- HISTORY: + -- JET 08/19/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A24I IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 4; + + FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, + TWO => 5); + + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A24I", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " & + "SMALLEST APPROPRIATE SIZE FOR A SIGNED " & + "REPRESENTATION) AND AN ENUMERATION " & + "REPRESENTATION CLAUSE ARE GIVEN FOR AN " & + "ENUMERATION TYPE, THEN THE TYPE CAN BE USED " & + "AS AN ACTUAL PARAMETER IN AN INSTANTIATION"); + + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((C0 < IDENT (C1)) AND + (IDENT (C2) > IDENT (C1)) AND + (C1 <= IDENT (C1)) AND (IDENT (C2) = C2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'FIRST /= IDENT (C0) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'POS (C0) /= IDENT_INT (0) OR + CHECK_TYPE'POS (C1) /= IDENT_INT (1) OR + CHECK_TYPE'POS (C2) /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'POS"); + END IF; + + IF CHECK_TYPE'SUCC (C0) /= IDENT (C1) OR + CHECK_TYPE'SUCC (C1) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SUCC"); + END IF; + + IF CHECK_TYPE'IMAGE (C0) /= IDENT_STR ("ZERO") OR + CHECK_TYPE'IMAGE (C1) /= IDENT_STR ("ONE") OR + CHECK_TYPE'IMAGE (C2) /= IDENT_STR ("TWO") THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'IMAGE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + + END CD2A24I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a24j.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CD2A24J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE SMALLEST APPROPRIATE + -- SIZE FOR AN UNSIGNED REPRESENTATION) AND AN ENUMERATION + -- REPRESENTATION CLAUSE ARE GIVEN FOR AN ENUMERATION TYPE, + -- THEN THE TYPE CAN BE USED AS AN ACTUAL PARAMETER IN AN + -- INSTANTIATION. + + -- HISTORY: + -- JET 08/19/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- WMC 03/27/92 ELIMINATED TEST REDUNDANCIES. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A24J IS + + TYPE BASIC_ENUM IS (ZERO, ONE, TWO); + BASIC_SIZE : CONSTANT := 3; + + FOR BASIC_ENUM USE (ZERO => 3, ONE => 4, + TWO => 5); + FOR BASIC_ENUM'SIZE USE BASIC_SIZE; + + BEGIN + TEST ("CD2A24J", "CHECK THAT IF A SIZE CLAUSE (SPECIFYING THE " & + "SMALLEST APPROPRIATE SIZE FOR AN UNSIGNED " & + "REPRESENTATION) AND AN ENUMERATION " & + "REPRESENTATION CLAUSE ARE GIVEN FOR AN " & + "ENUMERATION TYPE, THEN THE TYPE CAN BE USED " & + "AS AN ACTUAL PARAMETER IN AN INSTANTIATION"); + + + DECLARE -- TYPE DECLARATION GIVEN WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS (<>); + PROCEDURE GENPROC (C0, C1, C2: GPARM); + + PROCEDURE GENPROC (C0, C1, C2: GPARM) IS + + SUBTYPE CHECK_TYPE IS GPARM; + + FUNCTION IDENT (CH : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN CH; + ELSE + RETURN C1; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF C0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR C0'SIZE"); + END IF; + + IF NOT ((IDENT (C1) IN C1 .. C2) AND + (C0 NOT IN IDENT (C1) .. C2)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + + IF CHECK_TYPE'LAST /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'VAL (0) /= IDENT (C0) OR + CHECK_TYPE'VAL (1) /= IDENT (C1) OR + CHECK_TYPE'VAL (2) /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VAL"); + END IF; + + IF CHECK_TYPE'PRED (C1) /= IDENT (C0) OR + CHECK_TYPE'PRED (C2) /= IDENT (C1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'PRED"); + END IF; + + IF CHECK_TYPE'VALUE ("ZERO") /= IDENT (C0) OR + CHECK_TYPE'VALUE ("ONE") /= IDENT (C1) OR + CHECK_TYPE'VALUE ("TWO") /= IDENT (C2) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_ENUM); + + BEGIN + + NEWPROC (ZERO, ONE, TWO); + + END; + + RESULT; + + END CD2A24J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- CD2A31A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- JET 08/06/87 CREATED ORIGINAL TEST. + -- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION + -- CLAUSE CHECK. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A31A IS + + BASIC_SIZE : CONSTANT := 9; + + TYPE INT IS RANGE -100 .. 100; + + FOR INT'SIZE USE BASIC_SIZE; + + I1 : INT := -100; + I2 : INT := 0; + I3 : INT := 100; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT; + INTARRAY : ARRAY_TYPE := (-100, 0, 100); + + TYPE REC_TYPE IS RECORD + COMPN : INT := -100; + COMPZ : INT := 0; + COMPP : INT := 100; + END RECORD; + + IREC : REC_TYPE; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT); + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE PROC (PIN, PIP : INT; + PIOZ, PIOP : IN OUT INT; + POP : OUT INT) IS + + BEGIN + IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PIN'SIZE"); + END IF; + + IF NOT ((PIN < IDENT (0)) AND + (IDENT (PIP) > IDENT (PIOZ)) AND + (PIOZ <= IDENT (1)) AND + (IDENT (100) = PIP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF NOT (((PIN + PIP) = PIOZ) AND + ((PIP - PIOZ) = PIOP) AND + ((PIOP * PIOZ) = PIOZ) AND + ((PIOZ / PIN) = PIOZ) AND + ((PIN ** 1) = PIN) AND + ((PIN REM 9) = IDENT (-1)) AND + ((PIP MOD 9) = IDENT (1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'VAL (-100) /= IDENT (PIN) OR + INT'VAL (0) /= IDENT (PIOZ) OR + INT'VAL (100) /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 1"); + END IF; + + IF INT'PRED (PIOZ) /= IDENT (-1) OR + INT'PRED (PIP) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 1"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (PIN) OR + INT'VALUE ("0") /= IDENT (PIOZ) OR + INT'VALUE ("100") /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 1"); + END IF; + + POP := 100; + + END PROC; + + BEGIN + TEST ("CD2A31A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (I1, 9, "INT"); + PROC (-100, 100, I2, I3, I3); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I1) .. IDENT (I3) LOOP + IF NOT (I IN I1 .. I3) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + END LOOP; + + IF NOT ((+I1 = I1) AND + (-I3 = I1) AND + (ABS I1 = I3)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'FIRST /= IDENT (-100) THEN + FAILED ("INCORRECT VALUE FOR INT'FIRST - 2"); + END IF; + + IF INT'POS (I1) /= IDENT_INT (-100) OR + INT'POS (I2) /= IDENT_INT ( 0) OR + INT'POS (I3) /= IDENT_INT ( 100) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 2"); + END IF; + + IF INT'SUCC (I1) /= IDENT (-99) OR + INT'SUCC (I2) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 2"); + END IF; + + IF INT'IMAGE (I1) /= IDENT_STR ("-100") OR + INT'IMAGE (I2) /= IDENT_STR (" 0") OR + INT'IMAGE (I3) /= IDENT_STR (" 100") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2"); + END IF; + + IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE"); + END IF; + + IF NOT ((INTARRAY(-1) < IDENT (0)) AND + (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND + (INTARRAY(0) <= IDENT (0)) AND + (IDENT (100) = INTARRAY (1))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP + IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT (((INTARRAY(-1) + INTARRAY( 1)) = INTARRAY( 0)) AND + ((INTARRAY( 0) - INTARRAY( 1)) = INTARRAY(-1)) AND + ((INTARRAY( 1) * INTARRAY( 0)) = INTARRAY( 0)) AND + ((INTARRAY( 0) / INTARRAY(-1)) = INTARRAY( 0)) AND + ((INTARRAY(-1) ** 1) = INTARRAY(-1)) AND + ((INTARRAY(-1) REM 9) = IDENT (-1)) AND + ((INTARRAY( 1) MOD 9) = IDENT ( 1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'POS (INTARRAY (-1)) /= IDENT_INT (-100) OR + INT'POS (INTARRAY ( 0)) /= IDENT_INT ( 0) OR + INT'POS (INTARRAY ( 1)) /= IDENT_INT ( 100) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 3"); + END IF; + + IF INT'SUCC (INTARRAY (-1)) /= IDENT (-99) OR + INT'SUCC (INTARRAY ( 0)) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 3"); + END IF; + + IF INT'IMAGE (INTARRAY (-1)) /= IDENT_STR ("-100") OR + INT'IMAGE (INTARRAY ( 0)) /= IDENT_STR (" 0") OR + INT'IMAGE (INTARRAY ( 1)) /= IDENT_STR (" 100") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3"); + END IF; + + IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE"); + END IF; + + IF NOT ((IREC.COMPN < IDENT (0)) AND + (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND + (IREC.COMPZ <= IDENT (0)) AND + (IDENT (100) = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP + IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR + (I NOT IN IDENT(-100) .. IDENT(100)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT ((+IREC.COMPN = IREC.COMPN) AND + (-IREC.COMPP = IREC.COMPN) AND + (ABS IREC.COMPN = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'VAL (-100) /= IDENT (IREC.COMPN) OR + INT'VAL ( 0) /= IDENT (IREC.COMPZ) OR + INT'VAL ( 100) /= IDENT (IREC.COMPP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 4"); + END IF; + + IF INT'PRED (IREC.COMPZ) /= IDENT (-1) OR + INT'PRED (IREC.COMPP) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 4"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (IREC.COMPN) OR + INT'VALUE ( "0") /= IDENT (IREC.COMPZ) OR + INT'VALUE ( "100") /= IDENT (IREC.COMPP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 4"); + END IF; + + RESULT; + END CD2A31A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- CD2A31C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER 'SIZE SPECIFICATIONS CAN BE GIVEN: + -- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE + -- DECLARED IN THE VISIBLE PART; + -- FOR A DERIVED INTEGER TYPE; + -- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS + -- AN INTEGER TYPE; + -- FOR AN INTEGER TYPE IN A GENERIC UNIT. + + -- HISTORY: + -- PWB 06/17/87 CREATED ORIGINAL TEST. + -- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 9, AND ADDED REPRESENTAION + -- CLAUSE CHECK AND INCLUDED TEST FOR INTEGER IN A + -- GENERIC UNIT. + -- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + -- DTN 06/17/92 REMOVED THE LENGTH CLAUSE FOR TYPE PRIVATE_INT. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A31C IS + + TYPE BASIC_INT IS RANGE -60 .. 80; + SPECIFIED_SIZE : CONSTANT := 9; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE -125 .. 125; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE -125 .. 125; + PRIVATE + TYPE PRIVATE_INT IS RANGE -125 .. 125; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + -- SIZE SPECIFICATION GIVEN IN A GENERIC PROCEDURE. + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + TYPE CHECK_INT IS RANGE -125 .. 125; + FOR CHECK_INT'SIZE USE SPECIFIED_SIZE; + + PROCEDURE CHECK_4 IS NEW LENGTH_CHECK (CHECK_INT); + + BEGIN + + IF CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GENERIC CHECK_INT'SIZE IS INCORRECT"); + END IF; + CHECK_4 (-60, 9, "GENERIC CHECK_INT"); + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (DERIVED_INT); + PROCEDURE CHECK_2 IS NEW LENGTH_CHECK (INT_IN_P); + PROCEDURE CHECK_3 IS NEW LENGTH_CHECK (ALT_INT_IN_P); + + BEGIN + + TEST("CD2A31C", "CHECK THAT 'SIZE SPECIFICATIONS CAN BE GIVEN IN " & + "VISIBLE OR PRIVATE PART OF PACKAGE FOR INTEGER " & + "TYPE DECLARED IN VISIBLE PART, AND FOR " & + "DERIVED INTEGER TYPES " & + "AND DERIVED PRIVATE TYPES WHOSE FULL DECLARATIONS " & + "ARE AS INTEGER TYPES"); + + CHECK_1 (-60, 9, "DERIVED_INT"); + CHECK_2 (-60, 9, "INT_IN_P"); + CHECK_3 (-60, 9, "ALT_INT_IN_P"); + + NEWPROC; + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE INCORRECT"); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE INCORRECT"); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE INCORRECT"); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE INCORRECT"); + END IF; + + RESULT; + + END CD2A31C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a31e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- CD2A31E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- INTEGER TYPE, THEN SUCH A TYPE CAN BE PASSED AS AN ACTUAL + -- PARAMETER TO GENERIC PROCEDURES. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- BCB 10/18/88 MODIFIED HEADER AND ENTERED IN ACVC. + -- DHH 04/06/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 9, AND CHANGED 'SIZE CLAUSE + -- CHECKS. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2A31E IS + + TYPE BASIC_INT IS RANGE -100 .. 100; + BASIC_SIZE : CONSTANT := 9; + + FOR BASIC_INT'SIZE USE BASIC_SIZE; + + BEGIN + + TEST ("CD2A31E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN SUCH A TYPE " & + "CAN BE PASSED AS AN ACTUAL PARAMETER TO " & + "GENERIC PACKAGES AND PROCEDURES"); + + DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS RANGE <>; + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + SUBTYPE INT IS GPARM; + + I1 : INT := -100; + I2 : INT := 0; + I3 : INT := 100; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + IF NOT ((I1 < IDENT (0)) AND + (IDENT (I3) > IDENT (I2)) AND + (I2 <= IDENT (0)) AND + (IDENT (100) = I3)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF NOT (((I1 + I3) = I2) AND + ((I2 - I3) = I1) AND + ((I3 * I2) = I2) AND + ((I2 / I1) = I2) AND + ((I1 ** 1) = I1) AND + ((I1 REM 9) = IDENT (-1)) AND + ((I3 MOD 9) = IDENT (1))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS"); + END IF; + + IF INT'LAST /= IDENT (100) THEN + FAILED ("INCORRECT VALUE FOR INT'LAST"); + END IF; + + IF INT'VAL (-100) /= IDENT (I1) OR + INT'VAL (0) /= IDENT (I2) OR + INT'VAL (100) /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL"); + END IF; + + IF INT'PRED (I2) /= IDENT (-1) OR + INT'PRED (I3) /= IDENT (99) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED"); + END IF; + + IF INT'VALUE ("-100") /= IDENT (I1) OR + INT'VALUE (" 0") /= IDENT (I2) OR + INT'VALUE (" 100") /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT); + + BEGIN + + NEWPROC; + + END; + + RESULT; + + END CD2A31E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,272 ---- + -- CD2A32A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- WITH THE SMALLEST APPROPRIATE SIGNED SIZE ARE NOT + -- AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/10/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE + -- CHECKS AND ADDED REPRESENTAION CLAUSE CHECK. + -- RJW 03/28/90 REMOVED ERRONEOUS REFERENCES TO LENGTH_CHECK. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + WITH LENGTH_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD2A32A IS + + BASIC_SIZE : CONSTANT := 7; + + TYPE INT IS RANGE -63 .. 63; + + FOR INT'SIZE USE BASIC_SIZE; + + I1 : INT := -63; + I2 : INT := 0; + I3 : INT := 63; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE -1 .. 1) OF INT; + PRAGMA PACK (ARRAY_TYPE); + INTARRAY : ARRAY_TYPE := (-63, 0, 63); + + TYPE REC_TYPE IS RECORD + COMPN : INT := -63; + COMPZ : INT := 0; + COMPP : INT := 63; + END RECORD; + PRAGMA PACK (REC_TYPE); + + IREC : REC_TYPE; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE CHECK_1 IS NEW LENGTH_CHECK (INT); + + + PROCEDURE PROC (PIN, PIP : INT; + PIOZ, PIOP : IN OUT INT; + POP : OUT INT) IS + + BEGIN + IF PIN'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PIN'SIZE"); + END IF; + + FOR P1 IN IDENT (PIN) .. IDENT (PIOP) LOOP + IF NOT (P1 IN PIN .. PIP) OR + (P1 NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 1"); + END IF; + END LOOP; + + IF NOT ((+PIP = PIOP) AND + (-PIN = PIP) AND + (ABS PIN = PIOP)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'VAL (-63) /= IDENT (PIN) OR + INT'VAL (0) /= IDENT (PIOZ) OR + INT'VAL (63) /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 1"); + END IF; + + IF INT'PRED (PIOZ) /= IDENT (-1) OR + INT'PRED (PIP) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 1"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (PIN) OR + INT'VALUE ("0") /= IDENT (PIOZ) OR + INT'VALUE ("63") /= IDENT (PIOP) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 1"); + END IF; + + POP := 63; + + END PROC; + + BEGIN + TEST ("CD2A32A", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE WITH " & + "THE SMALLEST APPROPRIATE SIGNED SIZE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + CHECK_1 (I1, 7, "INT"); + + PROC (-63, 63, I2, I3, I3); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + IF NOT ((I1 < IDENT (0)) AND + (IDENT (I3) > IDENT (I2)) AND + (I2 <= IDENT (0)) AND + (IDENT (63) = I3)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF NOT (((I1 + I3) = I2) AND + ((I2 - I3) = I1) AND + ((I3 * I2) = I2) AND + ((I2 / I1) = I2) AND + ((I1 ** 1) = I1) AND + ((I1 REM 10) = IDENT (-3)) AND + ((I3 MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'FIRST /= IDENT (-63) THEN + FAILED ("INCORRECT VALUE FOR INT'FIRST - 2"); + END IF; + + IF INT'POS (I1) /= IDENT_INT (-63) OR + INT'POS (I2) /= IDENT_INT ( 0) OR + INT'POS (I3) /= IDENT_INT ( 63) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 2"); + END IF; + + IF INT'SUCC (I1) /= IDENT (-62) OR + INT'SUCC (I2) /= IDENT (1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 2"); + END IF; + + IF INT'IMAGE (I1) /= IDENT_STR ("-63") OR + INT'IMAGE (I2) /= IDENT_STR (" 0") OR + INT'IMAGE (I3) /= IDENT_STR (" 63") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 2"); + END IF; + + IF INTARRAY(0)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(0)'SIZE"); + END IF; + + IF NOT ((INTARRAY(-1) < IDENT (0)) AND + (IDENT (INTARRAY (1)) > IDENT (INTARRAY(0))) AND + (INTARRAY(0) <= IDENT (0)) AND + (IDENT (63) = INTARRAY (1))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(-1)) .. IDENT (INTARRAY(1)) LOOP + IF NOT (I IN INTARRAY(-1) .. INTARRAY(1)) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT ((+INTARRAY(-1) = INTARRAY(-1)) AND + (-INTARRAY( 1) = INTARRAY(-1)) AND + (ABS INTARRAY(-1) = INTARRAY(1))) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'VAL (-63) /= IDENT (INTARRAY (-1)) OR + INT'VAL ( 0) /= IDENT (INTARRAY ( 0)) OR + INT'VAL ( 63) /= IDENT (INTARRAY ( 1)) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 3"); + END IF; + + IF INT'PRED (INTARRAY (0)) /= IDENT (-1) OR + INT'PRED (INTARRAY (1)) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 3"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (INTARRAY (-1)) OR + INT'VALUE ("0") /= IDENT (INTARRAY ( 0)) OR + INT'VALUE ("63") /= IDENT (INTARRAY ( 1)) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 3"); + END IF; + + IF IREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMPP'SIZE"); + END IF; + + IF NOT ((IREC.COMPN < IDENT (0)) AND + (IDENT (IREC.COMPP) > IDENT (IREC.COMPZ)) AND + (IREC.COMPZ <= IDENT (0)) AND + (IDENT (63) = IREC.COMPP)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMPN) .. IDENT (IREC.COMPP) LOOP + IF NOT (I IN IREC.COMPN .. IREC.COMPP) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT (((IREC.COMPN + IREC.COMPP) = IREC.COMPZ) AND + ((IREC.COMPZ - IREC.COMPP) = IREC.COMPN) AND + ((IREC.COMPP * IREC.COMPZ) = IREC.COMPZ) AND + ((IREC.COMPZ / IREC.COMPN) = IREC.COMPZ) AND + ((IREC.COMPN ** 1) = IREC.COMPN) AND + ((IREC.COMPN REM 10) = IDENT (-3)) AND + ((IREC.COMPP MOD 10) = IDENT ( 3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'POS (IREC.COMPN) /= IDENT_INT (-63) OR + INT'POS (IREC.COMPZ) /= IDENT_INT ( 0) OR + INT'POS (IREC.COMPP) /= IDENT_INT ( 63) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 4"); + END IF; + + IF INT'SUCC (IREC.COMPN) /= IDENT (-62) OR + INT'SUCC (IREC.COMPZ) /= IDENT ( 1) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 4"); + END IF; + + IF INT'IMAGE (IREC.COMPN) /= IDENT_STR ("-63") OR + INT'IMAGE (IREC.COMPZ) /= IDENT_STR (" 0") OR + INT'IMAGE (IREC.COMPP) /= IDENT_STR (" 63") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 4"); + END IF; + + RESULT; + END CD2A32A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- CD2A32C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SIZE SPECIFICATION FOR AN INTEGER TYPE OF THE + -- SMALLEST APPROPRIATE SIGNED SIZE CAN BE GIVEN: + -- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE + -- DECLARED IN THE VISIBLE PART; + -- FOR A DERIVED INTEGER TYPE; + -- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS + -- AN INTEGER TYPE; + -- FOR AN INTEGER TYPE IN A GENERIC UNIT. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE + -- CHECKS, ADDED REPRESENTAION CLAUSE CHECK, AND + -- ADDED CHECK ON INTEGER IN A GENERIC UNIT. + -- BCB 10/03/90 CHANGED FAILED MESSAGES FROM "SHOULD NOT BE GREATER + -- THAN" TO "MUST BE EQUAL TO". + -- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A32C IS + + TYPE BASIC_INT IS RANGE -63 .. 63; + SPECIFIED_SIZE : CONSTANT := 7; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE -63 .. 63; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE -63 .. 63; + PRIVATE + TYPE PRIVATE_INT IS RANGE -63 .. 63; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + GENERIC + PACKAGE GENPACK IS + TYPE GEN_CHECK_INT IS RANGE -63 .. 63; + FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE; + END GENPACK; + + PACKAGE NEWPACK IS NEW GENPACK; + + USE NEWPACK; + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + BEGIN + + TEST("CD2A32C", "CHECK THAT A SIZE SPECIFICATION " & + "FOR AN INTEGER TYPE OF THE SMALLEST " & + "APPROPRIATE SIGNED SIZE CAN BE GIVEN: IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR A " & + "TYPE DECLARED IN THE VISIBLE PART; FOR A " & + "DERIVED INTEGER TYPE; FOR A DERIVED PRIVATE " & + "TYPE WHOSE FULL DECLARATION IS AS AN INTEGER " & + "TYPE; FOR AN INTEGER TYPE IN A GENERIC UNIT"); + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_INT'SIZE)); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(INT_IN_P'SIZE)); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ALT_INT_IN_P'SIZE)); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE MUST BE EQUAL TO " & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE)); + END IF; + + IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GEN_CHECK_INT'SIZE MUST BE EQUAL TO" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(GEN_CHECK_INT'SIZE)); + END IF; + + RESULT; + + END CD2A32C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,263 ---- + -- CD2A32E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR AN + -- INTEGER TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- WITH THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE NOT + -- AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON + -- 'SIZE CHECKS. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A32E IS + + BASIC_SIZE : CONSTANT := 7; + + TYPE INT IS RANGE 0 .. 126; + + FOR INT'SIZE USE BASIC_SIZE; + + I0 : INT := 0; + I1 : INT := 63; + I2 : INT := 126; + + TYPE ARRAY_TYPE IS ARRAY (INTEGER RANGE 0 .. 2) OF INT; + INTARRAY : ARRAY_TYPE := (0, 63, 126); + + TYPE REC_TYPE IS RECORD + COMP0 : INT := 0; + COMP1 : INT := 63; + COMP2 : INT := 126; + END RECORD; + + IREC : REC_TYPE; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + PROCEDURE PROC (PI0, PI2 : INT; + PIO1, PIO2 : IN OUT INT; + PO2 : OUT INT) IS + + BEGIN + IF PI0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR PI0'SIZE"); + END IF; + + IF NOT ((PI0 < IDENT (1)) AND + (IDENT (PI2) > IDENT (PIO1)) AND + (PIO1 <= IDENT (63)) AND + (IDENT (126) = PI2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF NOT (((PI0 + PI2) = PIO2) AND + ((PI2 - PIO1) = PIO1) AND + ((PIO1 * IDENT (2)) = PI2) AND + ((PIO2 / PIO1) = IDENT (2)) AND + ((PIO1 ** 1) = IDENT (63)) AND + ((PIO2 REM 10) = IDENT (6)) AND + ((PIO1 MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 1"); + END IF; + + IF INT'POS (PI0) /= IDENT_INT (0) OR + INT'POS (PIO1) /= IDENT_INT (63) OR + INT'POS (PI2) /= IDENT_INT (126) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 1"); + END IF; + + IF INT'SUCC (PI0) /= IDENT (1) OR + INT'SUCC (PIO1) /= IDENT (64) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 1"); + END IF; + + IF INT'IMAGE (PI0) /= IDENT_STR (" 0") OR + INT'IMAGE (PIO1) /= IDENT_STR (" 63") OR + INT'IMAGE (PI2) /= IDENT_STR (" 126") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 1"); + END IF; + + PO2 := 126; + + END PROC; + + BEGIN + TEST ("CD2A32E", "CHECK THAT WHEN A SIZE SPECIFICATION IS " & + "GIVEN FOR AN INTEGER TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE WITH " & + "THE SMALLEST APPROPRIATE UNSIGNED SIZE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (0, 126, I1, I2, I2); + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I0) .. IDENT (I2) LOOP + IF NOT (I IN I0 .. I2) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + END LOOP; + + IF NOT ((+I2 = I2) AND + (-I1 = -63) AND + (ABS I2 = I2)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 2"); + END IF; + + IF INT'VAL (0) /= IDENT (I0) OR + INT'VAL (63) /= IDENT (I1) OR + INT'VAL (126) /= IDENT (I2) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 2"); + END IF; + + IF INT'PRED (I1) /= IDENT (62) OR + INT'PRED (I2) /= IDENT (125) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 2"); + END IF; + + IF INT'VALUE ("0") /= IDENT (I0) OR + INT'VALUE ("63") /= IDENT (I1) OR + INT'VALUE ("126") /= IDENT (I2) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 2"); + END IF; + + IF INTARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INTARRAY(1)'SIZE"); + END IF; + + IF NOT ((INTARRAY(0) < IDENT (1)) AND + (IDENT (INTARRAY(2)) > IDENT (INTARRAY(1))) AND + (INTARRAY(1) <= IDENT (63)) AND + (IDENT (126) = INTARRAY(2))) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 3"); + END IF; + + FOR I IN IDENT (INTARRAY(0)) .. IDENT (INTARRAY(2)) LOOP + IF NOT (I IN INTARRAY(0) .. INTARRAY(2)) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + END LOOP; + + IF NOT (((INTARRAY(0) + INTARRAY(2)) = INTARRAY(2)) AND + ((INTARRAY(2) - INTARRAY(1)) = INTARRAY(1)) AND + ((INTARRAY(1) * IDENT (2)) = INTARRAY(2)) AND + ((INTARRAY(2) / INTARRAY(1)) = IDENT (2)) AND + ((INTARRAY(1) ** 1) = IDENT (63)) AND + ((INTARRAY(2) REM 10) = IDENT (6)) AND + ((INTARRAY(1) MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS - 3"); + END IF; + + IF INT'POS (INTARRAY(0)) /= IDENT_INT (0) OR + INT'POS (INTARRAY(1)) /= IDENT_INT (63) OR + INT'POS (INTARRAY(2)) /= IDENT_INT (126) THEN + FAILED ("INCORRECT VALUE FOR INT'POS - 3"); + END IF; + + IF INT'SUCC (INTARRAY(0)) /= IDENT (1) OR + INT'SUCC (INTARRAY(1)) /= IDENT (64) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC - 3"); + END IF; + + IF INT'IMAGE (INTARRAY(0)) /= IDENT_STR (" 0") OR + INT'IMAGE (INTARRAY(1)) /= IDENT_STR (" 63") OR + INT'IMAGE (INTARRAY(2)) /= IDENT_STR (" 126") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE - 3"); + END IF; + + IF IREC.COMP2'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR IREC.COMP2'SIZE"); + END IF; + + IF NOT ((IREC.COMP0 < IDENT (1)) AND + (IDENT (IREC.COMP2) > IDENT (IREC.COMP1)) AND + (IREC.COMP1 <= IDENT (63)) AND + (IDENT (126) = IREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 4"); + END IF; + + FOR I IN IDENT (IREC.COMP0) .. IDENT (IREC.COMP2) LOOP + IF NOT (I IN IREC.COMP0 .. IREC.COMP2) OR + (I NOT IN IDENT(0) .. IDENT(126)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + END LOOP; + + IF NOT ((+IREC.COMP2 = IREC.COMP2) AND + (-IREC.COMP1 = -63) AND + (ABS IREC.COMP2 = IREC.COMP2)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS - 4"); + END IF; + + IF INT'VAL (0) /= IDENT (IREC.COMP0) OR + INT'VAL (63) /= IDENT (IREC.COMP1) OR + INT'VAL (126) /= IDENT (IREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL - 4"); + END IF; + + IF INT'PRED (IREC.COMP1) /= IDENT (62) OR + INT'PRED (IREC.COMP2) /= IDENT (125) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED - 4"); + END IF; + + IF INT'VALUE ("0") /= IDENT (IREC.COMP0) OR + INT'VALUE ("63") /= IDENT (IREC.COMP1) OR + INT'VALUE ("126") /= IDENT (IREC.COMP2) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE - 4"); + END IF; + + RESULT; + + END CD2A32E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- CD2A32G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SIZE SPECIFICATION FOR AN INTEGER + -- TYPE OF THE SMALLEST APPROPRIATE UNSIGNED SIZE CAN BE GIVEN: + -- IN THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE + -- DECLARED IN THE VISIBLE PART; + -- FOR A DERIVED INTEGER TYPE; + -- FOR A DERIVED PRIVATE TYPE WHOSE FULL DECLARATION IS AS + -- AN INTEGER TYPE; + -- FOR AN INTEGER TYPE GIVEN IN A GENERIC UNIT. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, CHANGED OPERATOR ON 'SIZE + -- CHECKS, AND ADDED CHECK FOR 'SIZE IN A GENERIC + -- UNIT. + -- JRL 03/27/92 REMOVED TESTING OF NONOBJECTIVE TYPES. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A32G IS + + TYPE BASIC_INT IS RANGE 0 .. 126; + SPECIFIED_SIZE : CONSTANT := 7; + + TYPE DERIVED_INT IS NEW BASIC_INT; + FOR DERIVED_INT'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE INT_IN_P IS RANGE 0 .. 126; + FOR INT_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_INT IS PRIVATE; + TYPE ALT_INT_IN_P IS RANGE 0 .. 126; + PRIVATE + TYPE PRIVATE_INT IS RANGE 0 .. 126; + FOR ALT_INT_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + TYPE DERIVED_PRIVATE_INT IS NEW PRIVATE_INT; + FOR DERIVED_PRIVATE_INT'SIZE USE SPECIFIED_SIZE; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + TYPE GEN_CHECK_INT IS RANGE 0 .. 126; + FOR GEN_CHECK_INT'SIZE USE SPECIFIED_SIZE; + + BEGIN + + IF GEN_CHECK_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("GEN_CHECK_INT'SIZE SHOULD NOT BE GREATER " & + "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(GEN_CHECK_INT'SIZE)); + END IF; + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC; + + BEGIN + + TEST("CD2A32G", "CHECK THAT SIZE SPECIFICATIONS OF THE SMALLEST " & + "APPROPRIATE UNSIGNED SIZE CAN BE GIVEN " & + "IN THE VISIBLE OR PRIVATE PART OF PACKAGE FOR " & + "AN INTEGER TYPE DECLARED IN VISIBLE PART, " & + "FOR DERIVED INTEGER " & + "TYPES AND DERIVED PRIVATE TYPES WHOSE FULL " & + "DECLARATION IS AS AN INTEGER TYPE AND FOR AN " & + "INTEGER TYPE GIVEN IN A GENERIC UNIT"); + + IF DERIVED_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_INT'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_INT'SIZE)); + END IF; + + IF INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(INT_IN_P'SIZE)); + END IF; + + IF ALT_INT_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_INT_IN_P'SIZE SHOULD NOT BE GREATER THAN" & + INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(ALT_INT_IN_P'SIZE)); + END IF; + + IF DERIVED_PRIVATE_INT'SIZE /= MINIMUM_SIZE THEN + FAILED ("DERIVED_PRIVATE_INT'SIZE SHOULD NOT BE GREATER " & + "THAN" & INTEGER'IMAGE(MINIMUM_SIZE) & + ". ACTUAL SIZE IS" & + INTEGER'IMAGE(DERIVED_PRIVATE_INT'SIZE)); + END IF; + + NEWPROC; + + RESULT; + + END CD2A32G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CD2A32I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE + -- SIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN + -- BE PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON + -- 'SIZE CHECKS. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A32I IS + + TYPE BASIC_INT IS RANGE -63 .. 63; + BASIC_SIZE : CONSTANT := 7; + + FOR BASIC_INT'SIZE USE BASIC_SIZE; + + BEGIN + + TEST ("CD2A32I", "CHECK THAT WHEN A SIZE SPECIFICATION " & + "OF THE SMALLEST APPROPRIATE SIGNED SIZE " & + "IS GIVEN FOR AN INTEGER TYPE, " & + "THE TYPE " & + "CAN BE PASSED AS AN ACTUAL PARAMETER TO " & + "GENERIC PROCEDURES"); + + DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS RANGE <>; + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + SUBTYPE INT IS GPARM; + + I1 : INT := -63; + I2 : INT := 0; + I3 : INT := 63; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I1'SIZE"); + END IF; + + FOR I IN IDENT (I1) .. IDENT (I3) LOOP + IF NOT (I IN I1 .. I3) OR + (I NOT IN IDENT(-63) .. IDENT(63)) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS"); + END IF; + END LOOP; + + IF NOT ((+I1 = I1) AND + (-I3 = I1) AND + (ABS I1 = I3)) THEN + FAILED ("INCORRECT RESULTS FOR UNARY ARITHMETIC " & + "OPERATORS"); + END IF; + + IF INT'LAST /= IDENT (63) THEN + FAILED ("INCORRECT VALUE FOR INT'LAST"); + END IF; + + IF INT'VAL (-63) /= IDENT (I1) OR + INT'VAL (0) /= IDENT (I2) OR + INT'VAL (63) /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VAL"); + END IF; + + IF INT'PRED (I2) /= IDENT (-1) OR + INT'PRED (I3) /= IDENT (62) THEN + FAILED ("INCORRECT VALUE FOR INT'PRED"); + END IF; + + IF INT'VALUE ("-63") /= IDENT (I1) OR + INT'VALUE (" 0") /= IDENT (I2) OR + INT'VALUE (" 63") /= IDENT (I3) THEN + FAILED ("INCORRECT VALUE FOR INT'VALUE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT); + + BEGIN + + NEWPROC; + + END; + + RESULT; + + END CD2A32I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a32j.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CD2A32J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION OF THE SMALLEST APPROPRIATE + -- UNSIGNED SIZE IS GIVEN FOR AN INTEGER TYPE, THE TYPE CAN BE + -- PASSED AS AN ACTUAL PARAMETER TO GENERIC PROCEDURES. + + -- HISTORY: + -- JET 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- SIZE CLAUSE VALUE TO 7, AND CHANGED OPERATOR ON + -- 'SIZE CHECKS. + -- JRL 03/27/92 ELIMINATED REDUNDANT TESTING. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2A32J IS + + TYPE BASIC_INT IS RANGE 0 .. 126; + BASIC_SIZE : CONSTANT := 7; + + FOR BASIC_INT'SIZE USE BASIC_SIZE; + + BEGIN + + TEST ("CD2A32J", "CHECK THAT WHEN A SIZE SPECIFICATION " & + "OF THE SMALLEST APPROPRIATE UNSIGNED SIZE " & + "IS GIVEN FOR AN INTEGER TYPE, THE TYPE " & + "CAN BE PASSED AS AN ACTUAL PARAMETER TO " & + "GENERIC PROCEDURES"); + + DECLARE -- TYPE DECLARATION WITHIN GENERIC PROCEDURE. + + GENERIC + TYPE GPARM IS RANGE <>; + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + SUBTYPE INT IS GPARM; + + I0 : INT := 0; + I1 : INT := 63; + I2 : INT := 126; + + FUNCTION IDENT (I : INT) RETURN INT IS + BEGIN + IF EQUAL (0,0) THEN + RETURN I; + ELSE + RETURN 0; + END IF; + END IDENT; + + BEGIN -- GENPROC. + + IF INT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR INT'SIZE"); + END IF; + + IF I0'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR I0'SIZE"); + END IF; + + IF NOT ((I0 < IDENT (1)) AND + (IDENT (I2) > IDENT (I1)) AND + (I1 <= IDENT (63)) AND + (IDENT (126) = I2)) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS"); + END IF; + + IF NOT (((I0 + I2) = I2) AND + ((I2 - I1) = I1) AND + ((I1 * IDENT (2)) = I2) AND + ((I2 / I1) = IDENT (2)) AND + ((I1 ** 1) = IDENT (63)) AND + ((I2 REM 10) = IDENT (6)) AND + ((I1 MOD 10) = IDENT (3))) THEN + FAILED ("INCORRECT RESULTS FOR BINARY ARITHMETIC " & + "OPERATORS"); + END IF; + + IF INT'POS (I0) /= IDENT_INT (0) OR + INT'POS (I1) /= IDENT_INT (63) OR + INT'POS (I2) /= IDENT_INT (126) THEN + FAILED ("INCORRECT VALUE FOR INT'POS"); + END IF; + + IF INT'SUCC (I0) /= IDENT (1) OR + INT'SUCC (I1) /= IDENT (64) THEN + FAILED ("INCORRECT VALUE FOR INT'SUCC"); + END IF; + + IF INT'IMAGE (I0) /= IDENT_STR (" 0") OR + INT'IMAGE (I1) /= IDENT_STR (" 63") OR + INT'IMAGE (I2) /= IDENT_STR (" 126") THEN + FAILED ("INCORRECT VALUE FOR INT'IMAGE"); + END IF; + + END GENPROC; + + PROCEDURE NEWPROC IS NEW GENPROC (BASIC_INT); + + BEGIN + + NEWPROC; + + END; + + RESULT; + + END CD2A32J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a51a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,193 ---- + -- CD2A51A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A SIZE SPECIFICATION IS GIVEN FOR A + -- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 08/12/87 CREATED ORIGINAL TEST. + -- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE + -- SO THAT IT IS NOT A POWER OF TWO. + -- WMC 03/31/92 ELIMINATED TEST REDUNDANCIES. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A51A IS + + BASIC_SIZE : CONSTANT := 9; + + TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + TYPE CHECK_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + CNEG1 : CHECK_TYPE := -3.5; + CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + CPOS2 : CHECK_TYPE := 3.5; + CZERO : CHECK_TYPE; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := + (-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5); + + TYPE REC_TYPE IS RECORD + COMPN1 : CHECK_TYPE := -3.5; + COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + COMPP2 : CHECK_TYPE := 3.5; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE; + N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE; + CZOUT : OUT CHECK_TYPE) IS + BEGIN + + IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR + IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "UNARY ADDING OPERATORS - 1"); + END IF; + + IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "ABSOLUTE VALUE OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + + BEGIN + TEST ("CD2A51A", "CHECK THAT WHEN A SIZE SPECICFICATION IS " & + "GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE " & + "NOT AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF IDENT (CZERO) /= 0.0 THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF CHECK_TYPE'LAST < IDENT (3.9375) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'LAST"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF CHECK_TYPE'AFT /= BASIC_TYPE'AFT THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'AFT"); + END IF; + + IF CNEG1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR + CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2"); + END IF; + + IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2"); + END IF; + + IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR + CNEG2 IN -0.25 .. 0.0 OR + IDENT (CNEG2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY (1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY (1)'SIZE"); + END IF; + + IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3"); + END IF; + + IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR + CHARRAY (1) IN -0.25 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP1'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP1'SIZE"); + END IF; + + IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN + -2.875 .. -2.8125 OR + CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4"); + END IF; + + IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN + -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR + CHREC.COMPN2 IN -0.25 .. 0.0 OR + IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RESULT; + + END CD2A51A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a53a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,217 ---- + -- CD2A53A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A + -- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE ARE + -- NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C) + -- and which support decimal small values: + -- The test must compile, bind, execute, report PASSED, and + -- complete normally. + -- + -- For other implementations: + -- This test may produce at least one error message at compilation, + -- and the error message is associated with one of the items marked: + -- -- N/A => ERROR. + -- The test will be recorded as Not_Applicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- All other behaviors are FAILING. + -- + -- HISTORY: + -- BCB 08/24/87 CREATED ORIGINAL TEST. + -- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA', CHANGED + -- OPERATORS ON 'SIZE TESTS, AND CHANGED 'SIZE CLAUSE + -- SO THAT IT IS NOT A POWER OF TWO. + -- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES. + -- RLB 11/24/98 Added Ada 95 applicability criteria. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A53A IS + BASIC_SIZE : CONSTANT := 15; + BASIC_SMALL : CONSTANT := 0.01; + + ZERO : CONSTANT := 0.0; + + TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0; + + FOR CHECK_TYPE'SMALL USE BASIC_SMALL; -- N/A => ERROR. + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; -- N/A => ERROR. + + CNEG1 : CHECK_TYPE := -2.7; + CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + CPOS2 : CHECK_TYPE := 2.7; + CZERO : CHECK_TYPE; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := + (-2.7, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 2.7); + + TYPE REC_TYPE IS RECORD + COMPF : CHECK_TYPE := -2.7; + COMPN : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + COMPP : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + COMPL : CHECK_TYPE := 2.7; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (CN1IN, CP1IN : CHECK_TYPE; + CN2INOUT,CP2INOUT : IN OUT CHECK_TYPE; + CZOUT : OUT CHECK_TYPE) IS + BEGIN + + IF IDENT (CN1IN) + CP1IN NOT IN -2.04 .. -2.03 OR + CP2INOUT - IDENT (CP1IN) NOT IN 2.03 .. 2.04 THEN + FAILED ("INCORRECT RESULTS FOR " & + "BINARY ADDING OPERATORS - 1"); + END IF; + + IF CHECK_TYPE (CN1IN * IDENT (CP1IN)) NOT IN + -1.81 .. -1.78 OR + CHECK_TYPE (IDENT (CN2INOUT) / CP2INOUT) NOT IN + -0.13 .. -0.12 THEN + FAILED ("INCORRECT RESULTS FOR " & + "MULTIPLYING OPERATORS - 1"); + END IF; + + IF IDENT (CP1IN) NOT IN 0.66 .. 0.670 OR + CN2INOUT IN -0.32 .. 0.0 OR + IDENT (CN2INOUT) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + + BEGIN + TEST ("CD2A53A", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " & + "ARE GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " & + "AFFECTED BY THE REPRESENTATION CLAUSE"); + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CZERO) /= ZERO THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF CHECK_TYPE'FIRST > IDENT (-3.99) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FIRST"); + END IF; + + IF CHECK_TYPE'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SIZE"); + END IF; + + IF CHECK_TYPE'SMALL /= BASIC_SMALL THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'SMALL"); + END IF; + + IF CHECK_TYPE'FORE /= 2 THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE'FORE"); + END IF; + + IF +IDENT (CNEG2) NOT IN -0.34 .. -0.33 OR + IDENT (-CPOS1) NOT IN -0.67 .. -0.66 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2"); + END IF; + + IF ABS IDENT (CNEG2) NOT IN 0.33 .. 0.34 OR + IDENT (ABS CPOS1) NOT IN 0.66 .. 0.670 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN + -2.04 .. -2.03 OR + CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN + 2.03 .. 2.04 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3"); + END IF; + + IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN + -1.81 .. -1.78 OR + CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN + -0.13 .. -0.12 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.66 .. 0.670 OR + CHARRAY (1) IN -0.32 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP'SIZE < IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE"); + END IF; + + IF +IDENT (CHREC.COMPN) NOT IN -0.34 .. -0.33 OR + IDENT (-CHREC.COMPP) NOT IN -0.67 .. -0.66 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4"); + END IF; + + IF ABS IDENT (CHREC.COMPN) NOT IN 0.33 .. 0.34 OR + IDENT (ABS CHREC.COMPP) NOT IN 0.66 .. 0.670 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP) NOT IN 0.66 .. 0.670 OR + CHREC.COMPN IN -0.32 .. 0.0 OR + IDENT (CHREC.COMPN) IN -1.0 .. -0.35 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RESULT; + + END CD2A53A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a53e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,235 ---- + -- CD2A53E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS ARE GIVEN FOR A + -- FIXED POINT TYPE, THEN OPERATIONS ON VALUES OF SUCH A TYPE + -- ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE WHEN THE TYPE + -- IS PASSED AS A GENERIC ACTUAL PARAMETER. + + -- HISTORY: + -- BCB 08/24/87 CREATED ORIGINAL TEST. + -- DHH 04/12/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND CHANGED + -- OPERATORS ON 'SIZE TESTS. + -- WMC 04/01/92 ELIMINATED TEST REDUNDANCIES. + -- MRM 07/16/92 FIX ALIGNMENT OF BLOCK BODY + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A53E IS + + BASIC_SIZE : CONSTANT := INTEGER'SIZE/2; + BASIC_SMALL : CONSTANT := 2.0 ** (-4); + B : BOOLEAN; + + TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0; + FOR CHECK_TYPE'SMALL USE BASIC_SMALL; + FOR CHECK_TYPE'SIZE USE BASIC_SIZE; + + BEGIN + + TEST ("CD2A53E", "CHECK THAT WHEN SIZE AND SMALL SPECIFICATIONS " & + "ARE GIVEN FOR A FIXED POINT TYPE, THEN " & + "OPERATIONS ON VALUES OF SUCH A TYPE ARE NOT " & + "AFFECTED BY THE REPRESENTATION CLAUSE WHEN " & + "THE TYPE IS PASSED AS A GENERIC ACTUAL " & + "PARAMETER"); + + DECLARE + + GENERIC + + TYPE FIXED_ELEMENT IS DELTA <>; + + FUNCTION FUNC RETURN BOOLEAN; + + FUNCTION FUNC RETURN BOOLEAN IS + + ZERO : CONSTANT := 0.0; + + TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + CNEG1 : FIXED_ELEMENT := -3.5; + CNEG2 : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0); + CPOS1 : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0); + CPOS2 : FIXED_ELEMENT := 3.5; + CZERO : FIXED_ELEMENT; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF FIXED_ELEMENT; + CHARRAY : ARRAY_TYPE := + (-3.5, FIXED_ELEMENT (-1.0/3.0), FIXED_ELEMENT + (4.0/6.0), 3.5); + + TYPE REC_TYPE IS RECORD + COMPF : FIXED_ELEMENT := -3.5; + COMPN : FIXED_ELEMENT := FIXED_ELEMENT (-1.0/3.0); + COMPP : FIXED_ELEMENT := FIXED_ELEMENT (4.0/6.0); + COMPL : FIXED_ELEMENT := 3.5; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : FIXED_ELEMENT) RETURN + FIXED_ELEMENT IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (CN1IN, CP1IN : FIXED_ELEMENT; + CN2INOUT,CP2INOUT : IN OUT FIXED_ELEMENT; + CZOUT : OUT FIXED_ELEMENT) + IS + BEGIN + + IF +IDENT (CN2INOUT) NOT IN -0.375 .. -0.3125 OR + IDENT (-CP1IN) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "UNARY ADDING OPERATORS - 1"); + END IF; + + IF ABS IDENT (CN2INOUT) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CP1IN) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "ABSOLUTE VALUE OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + + BEGIN -- FUNC + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF IDENT (CZERO) /= ZERO THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF FIXED_ELEMENT'LAST < IDENT (3.9375) THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'LAST"); + END IF; + + IF FIXED_ELEMENT'SIZE /= IDENT_INT (BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SIZE"); + END IF; + + IF FIXED_ELEMENT'SMALL /= BASIC_SMALL THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'SMALL"); + END IF; + + IF FIXED_ELEMENT'AFT /= 1 THEN + FAILED ("INCORRECT VALUE FOR FIXED_ELEMENT'AFT"); + END IF; + + IF CNEG1'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CNEG1'SIZE"); + END IF; + + IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR + CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING " & + "OPERATORS - 2"); + END IF; + + IF FIXED_ELEMENT (CNEG1 * IDENT (CPOS1)) NOT IN + -2.4375 .. -2.1875 OR + FIXED_ELEMENT (IDENT (CNEG2) / CPOS2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING " & + "OPERATORS - 2"); + END IF; + + IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR + CNEG2 IN -0.25 .. 0.0 OR + IDENT (CNEG2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 2"); + END IF; + + IF CHARRAY(1)'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHARRAY(1)'SIZE"); + END IF; + + IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING " & + "OPERATORS - 3"); + END IF; + + IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR + CHARRAY (1) IN -0.25 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 3"); + END IF; + + IF CHREC.COMPP'SIZE < IDENT_INT(BASIC_SIZE) THEN + FAILED ("INCORRECT VALUE FOR CHREC.COMPP'SIZE"); + END IF; + + IF IDENT (CHREC.COMPF) + CHREC.COMPP NOT IN + -2.875 .. -2.8125 OR + CHREC.COMPL - IDENT (CHREC.COMPP) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING " & + "OPERATORS - 4"); + END IF; + + IF FIXED_ELEMENT (CHREC.COMPF * IDENT (CHREC.COMPP)) + NOT IN -2.4375 .. -2.1875 OR + FIXED_ELEMENT (IDENT (CHREC.COMPN) / CHREC.COMPL) + NOT IN -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING " & + "OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP) NOT IN 0.625 .. 0.6875 OR + CHREC.COMPN IN -0.25 .. 0.0 OR + IDENT (CHREC.COMPN) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP " & + "OPERATORS - 4"); + END IF; + + RETURN TRUE; + + END FUNC; + + FUNCTION NEWFUNC IS NEW FUNC(CHECK_TYPE); + BEGIN + B := NEWFUNC; + END; + + RESULT; + + END CD2A53E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a83c.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- CD2A83C.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SIZE AND COLLECTION SIZE SPECIFICATIONS + -- FOR AN ACCESS TYPE CAN BE GIVEN IN THE VISIBLE OR + -- PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN + -- THE VISIBLE PART. + + -- HISTORY: + -- JET 09/01/87 CREATED ORIGINAL TEST. + -- DHH 04/11/89 CHANGED OPERATOR ON 'SIZE CHECKS AND REMOVED + -- APPLICABILITY CRITERIA. + + -- $ACC_SIZE IS THE SIZE IN BITS FOR AN ACCESS VARIABLE WHOSE + -- DESIGNATED TYPE IS A STRING TYPE. + + WITH REPORT; USE REPORT; + PROCEDURE CD2A83C IS + + SPECIFIED_SIZE : CONSTANT := $ACC_SIZE; + COLL_SIZE : CONSTANT := 256; + + TYPE CHECK_ACC IS ACCESS STRING; + + FOR CHECK_ACC'STORAGE_SIZE USE COLL_SIZE; + + FOR CHECK_ACC'SIZE USE SPECIFIED_SIZE; + + PACKAGE P IS + TYPE ACC_IN_P IS ACCESS STRING; + FOR ACC_IN_P'STORAGE_SIZE USE COLL_SIZE; + FOR ACC_IN_P'SIZE USE SPECIFIED_SIZE; + TYPE PRIVATE_ACC IS PRIVATE; + TYPE ALT_ACC_IN_P IS ACCESS STRING; + PRIVATE + TYPE PRIVATE_ACC IS ACCESS STRING; + FOR ALT_ACC_IN_P'STORAGE_SIZE USE COLL_SIZE; + FOR ALT_ACC_IN_P'SIZE USE SPECIFIED_SIZE; + END P; + + USE P; + + MINIMUM_SIZE : INTEGER := IDENT_INT(SPECIFIED_SIZE); + + BEGIN + + TEST("CD2A83C", "CHECK THAT WHEN SIZE AND COLLECTION SIZE " & + "SPECIFICATIONS FOR AN ACCESS TYPE, " & + "CAN BE GIVEN IN " & + "THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR " & + "A TYPE DECLARED IN THE VISIBLE PART"); + + IF CHECK_ACC'SIZE /= MINIMUM_SIZE THEN + FAILED ("CHECK_ACC'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF CHECK_ACC'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("CHECK_ACC'STORAGE_SIZE TOO SMALL"); + END IF; + + IF ACC_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ACC_IN_P'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("ACC_IN_P'STORAGE_SIZE TOO SMALL"); + END IF; + + IF ALT_ACC_IN_P'SIZE /= MINIMUM_SIZE THEN + FAILED ("ALT_ACC_IN_P'SIZE /= SPECIFIED_SIZE"); + END IF; + + IF ALT_ACC_IN_P'STORAGE_SIZE < COLL_SIZE THEN + FAILED ("ALT_ACC_IN_P'STORAGE_SIZE TOO SMALL"); + END IF; + + RESULT; + + END CD2A83C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2a91c.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CD2A91C.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SIZE SPECIFICATION FOR A TASK TYPE CAN BE GIVEN IN + -- THE VISIBLE OR PRIVATE PART OF A PACKAGE. + + -- MACRO SUBSTITUTION: + -- $TASK_SIZE IS THE NUMBER OF BITS NEEDED BY THE IMPLEMENTATION TO + -- HOLD ANY POSSIBLE OBJECT OF THE TASK TYPE "BASIC_TYPE". + + -- HISTORY: + -- BCB 09/08/87 CREATED ORIGINAL TEST. + -- RJW 05/12/89 MODIFIED CHECKS INVOLVING 'SIZE ATTRIBUTE. + -- REMOVED APPLICABILTY CRITERIA. + -- DTN 11/20/91 DELETED SUBPARTS (B and C). + + WITH REPORT; USE REPORT; + PROCEDURE CD2A91C IS + + BASIC_SIZE : CONSTANT := $TASK_SIZE; + + VAL : INTEGER := 1; + + TASK TYPE BASIC_TYPE IS + ENTRY HERE(NUM : IN OUT INTEGER); + END BASIC_TYPE; + + FOR BASIC_TYPE'SIZE USE BASIC_SIZE; + + BASIC_TASK : BASIC_TYPE; + + PACKAGE P IS + TASK TYPE TASK_IN_P IS + ENTRY HERE(NUM : IN OUT INTEGER); + END TASK_IN_P; + FOR TASK_IN_P'SIZE USE BASIC_SIZE; + TASK TYPE ALT_TASK_IN_P IS + ENTRY HERE(NUM : IN OUT INTEGER); + END ALT_TASK_IN_P; + PRIVATE + FOR ALT_TASK_IN_P'SIZE USE BASIC_SIZE; + END P; + + USE P; + + ALT_TASK : ALT_TASK_IN_P; + IN_TASK : TASK_IN_P; + + TASK BODY BASIC_TYPE IS + BEGIN + SELECT + ACCEPT HERE(NUM : IN OUT INTEGER) DO + NUM := 0; + END HERE; + OR + TERMINATE; + END SELECT; + END BASIC_TYPE; + + PACKAGE BODY P IS + TASK BODY TASK_IN_P IS + BEGIN + SELECT + ACCEPT HERE(NUM : IN OUT INTEGER) DO + NUM := 0; + END HERE; + OR + TERMINATE; + END SELECT; + END TASK_IN_P; + TASK BODY ALT_TASK_IN_P IS + BEGIN + SELECT + ACCEPT HERE(NUM : IN OUT INTEGER) DO + NUM := 0; + END HERE; + OR + TERMINATE; + END SELECT; + END ALT_TASK_IN_P; + END P; + + BEGIN + TEST ("CD2A91C", "CHECK THAT A SIZE SPECIFICATION FOR A TASK " & + "TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE " & + "PART OF A PACKAGE"); + + BASIC_TASK.HERE(VAL); + + IF VAL /= IDENT_INT (0) THEN + FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 1"); + END IF; + + VAL := 1; + + ALT_TASK.HERE(VAL); + + IF VAL /= IDENT_INT (0) THEN + FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 2"); + END IF; + + VAL := 1; + + IN_TASK.HERE(VAL); + + IF VAL /= IDENT_INT (0) THEN + FAILED ("INCORRECT RESULTS FROM ENTRY CALL - 3"); + END IF; + + + RESULT; + END CD2A91C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- CD2B11A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A COLLECTION SIZE SPECIFICATION CAN BE GIVEN FOR AN + -- ACCESS TYPE, THEN OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT + -- AFFECTED. + + -- HISTORY: + -- BCB 11/01/88 CREATED ORIGINAL TEST. + -- RJW 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + -- ADDED CHECK FOR UNCHECKED_DEALLOCATION. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + WITH UNCHECKED_DEALLOCATION; + PROCEDURE CD2B11A IS + + BASIC_SIZE : CONSTANT := 1024; + + TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE ACC_TYPE IS ACCESS MAINTYPE; + SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3); + + FOR ACC_TYPE'STORAGE_SIZE USE BASIC_SIZE; + + TYPE RECORD_TYPE IS RECORD + COMP : ACC_TYPE; + END RECORD; + + CHECK_TYPE1 : ACC_TYPE; + CHECK_TYPE2 : ACC_TYPE; + CHECK_TYPE3 : ACC_TYPE(1..3); + + CHECK_ARRAY : ARRAY (1..2) OF ACC_TYPE; + + CHECK_RECORD1 : RECORD_TYPE; + CHECK_RECORD2 : RECORD_TYPE; + + CHECK_PARAM1 : ACC_TYPE; + CHECK_PARAM2 : ACC_TYPE; + + CHECK_NULL : ACC_TYPE := NULL; + + PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS + + BEGIN + + IF (ACC1.ALL /= ACC2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS " & + "- 1"); + END IF; + + IF EQUAL (3,3) THEN + ACC2 := ACC1; + END IF; + + IF ACC2 /= ACC1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "-1"); + END IF; + + IF (ACC1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 1"); + END IF; + + END PROC; + + BEGIN + + TEST ("CD2B11A", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " & + "CAN BE GIVEN FOR AN ACCESS TYPE, THEN " & + "OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " & + "NOT AFFECTED"); + + CHECK_PARAM1 := NEW MAINTYPE'(25,35,45); + CHECK_PARAM2 := NEW MAINTYPE'(25,35,45); + + PROC (CHECK_PARAM1,CHECK_PARAM2); + + IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN + FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE"); + END IF; + + CHECK_TYPE1 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE2 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3); + + CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45); + CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45); + + CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45); + CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45); + + IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_TYPE2 := CHECK_TYPE1; + END IF; + + IF CHECK_TYPE2 /= CHECK_TYPE1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 2"); + END IF; + + IF (CHECK_TYPE1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2"); + END IF; + + IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_ARRAY (2) := CHECK_ARRAY (1); + END IF; + + IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 3"); + END IF; + + IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3"); + END IF; + + IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_RECORD2 := CHECK_RECORD1; + END IF; + + IF CHECK_RECORD2 /= CHECK_RECORD1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS - 4"); + END IF; + + IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4"); + END IF; + + IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST"); + END IF; + + IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST"); + END IF; + + DECLARE + TYPE ACC_CHAR IS ACCESS CHARACTER; + FOR ACC_CHAR'STORAGE_SIZE USE 128; + + LIMIT : INTEGER := + (ACC_CHAR'STORAGE_SIZE * SYSTEM.STORAGE_UNIT)/CHARACTER'SIZE; + + ACC_ARRAY : ARRAY (1 .. LIMIT + 1) OF ACC_CHAR; + PLACE : INTEGER; + + PROCEDURE FREE IS + NEW UNCHECKED_DEALLOCATION (CHARACTER, ACC_CHAR); + BEGIN + FOR I IN ACC_ARRAY'RANGE LOOP + ACC_ARRAY (IDENT_INT (I)) := + NEW CHARACTER' + (IDENT_CHAR ((CHARACTER'VAL (I MOD 128)))); + PLACE := I; + END LOOP; + FAILED ("NO EXCEPTION RAISED WHEN COLLECTION SIZE EXCEEDED"); + EXCEPTION + WHEN STORAGE_ERROR => + BEGIN + FOR I IN 1 .. PLACE LOOP + IF I MOD 2 = 0 THEN + FREE (ACC_ARRAY (IDENT_INT (I))); + END IF; + END LOOP; + + FOR I IN 1 .. PLACE LOOP + IF I MOD 2 = 1 AND THEN + IDENT_CHAR (ACC_ARRAY (I).ALL) /= + CHARACTER'VAL (I MOD IDENT_INT (128)) THEN + FAILED ("INCORRECT VALUE IN ARRAY"); + END IF; + END LOOP; + END; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + RESULT; + END CD2B11A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- CD2B11B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A COLLECTION SIZE IS SPECIFIED FOR AN + -- ACCESS TYPE IN A GENERIC UNIT, THEN OPERATIONS ON VALUES OF THE + -- ACCESS TYPE ARE NOT AFFECTED. + + -- HISTORY: + -- BCB 09/23/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2B11B IS + + BASIC_SIZE : CONSTANT := 1024; + B : BOOLEAN; + + BEGIN + + TEST ("CD2B11B", "CHECK THAT IF A COLLECTION SIZE IS SPECIFIED " & + "FOR AN ACCESS TYPE, THEN " & + "OPERATIONS ON VALUES OF THE ACCESS TYPE ARE " & + "NOT AFFECTED"); + + DECLARE + + GENERIC + FUNCTION FUNC RETURN BOOLEAN; + + FUNCTION FUNC RETURN BOOLEAN IS + + TYPE MAINTYPE IS ARRAY (INTEGER RANGE <>) OF INTEGER; + TYPE ACC_TYPE IS ACCESS MAINTYPE; + SUBTYPE ACC_RANGE IS ACC_TYPE (1 .. 3); + + FOR ACC_TYPE'STORAGE_SIZE + USE BASIC_SIZE; + + TYPE RECORD_TYPE IS RECORD + COMP : ACC_TYPE; + END RECORD; + + CHECK_TYPE1 : ACC_TYPE; + CHECK_TYPE2 : ACC_TYPE; + CHECK_TYPE3 : ACC_TYPE(1..3); + + CHECK_ARRAY : ARRAY (1..3) OF ACC_TYPE; + + CHECK_RECORD1 : RECORD_TYPE; + CHECK_RECORD2 : RECORD_TYPE; + + CHECK_PARAM1 : ACC_TYPE; + CHECK_PARAM2 : ACC_TYPE; + + CHECK_NULL : ACC_TYPE := NULL; + + PROCEDURE PROC (ACC1,ACC2 : IN OUT ACC_TYPE) IS + + BEGIN + + IF (ACC1.ALL /= ACC2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED " & + "OBJECTS - 1"); + END IF; + + IF EQUAL (3,3) THEN + ACC2 := ACC1; + END IF; + + IF ACC2 /= ACC1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL " & + "OPERATORS - 1"); + END IF; + + IF (ACC1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR " & + "MEMBERSHIP TEST - 1"); + END IF; + + END PROC; + + BEGIN -- FUNC. + + CHECK_PARAM1 := NEW MAINTYPE'(25,35,45); + CHECK_PARAM2 := NEW MAINTYPE'(25,35,45); + + PROC (CHECK_PARAM1,CHECK_PARAM2); + + IF ACC_TYPE'STORAGE_SIZE < BASIC_SIZE THEN + FAILED ("INCORRECT VALUE FOR ACCESS TYPE STORAGE_SIZE"); + END IF; + + CHECK_TYPE1 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE2 := NEW MAINTYPE'(25,35,45); + CHECK_TYPE3 := NEW MAINTYPE'(1 => 1,2 => 2,3 => 3); + + CHECK_ARRAY (1) := NEW MAINTYPE'(25,35,45); + CHECK_ARRAY (2) := NEW MAINTYPE'(25,35,45); + + CHECK_RECORD1.COMP := NEW MAINTYPE'(25,35,45); + CHECK_RECORD2.COMP := NEW MAINTYPE'(25,35,45); + + IF (CHECK_TYPE1.ALL /= CHECK_TYPE2.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 2"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_TYPE2 := CHECK_TYPE1; + END IF; + + IF CHECK_TYPE2 /= CHECK_TYPE1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 2"); + END IF; + + IF (CHECK_TYPE1 IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 2"); + END IF; + + IF (CHECK_ARRAY (1).ALL /= CHECK_ARRAY (2).ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 3"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_ARRAY (2) := CHECK_ARRAY (1); + END IF; + + IF CHECK_ARRAY (2) /= CHECK_ARRAY (1) THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 3"); + END IF; + + IF (CHECK_ARRAY (1) IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 3"); + END IF; + + IF (CHECK_RECORD1.COMP.ALL /= CHECK_RECORD2.COMP.ALL) THEN + FAILED ("INCORRECT VALUES FOR DESIGNATED OBJECTS - 4"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_RECORD2 := CHECK_RECORD1; + END IF; + + IF CHECK_RECORD2 /= CHECK_RECORD1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATORS " & + "- 4"); + END IF; + + IF (CHECK_RECORD1.COMP IN ACC_RANGE) THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP TEST - 4"); + END IF; + + IF CHECK_TYPE3'FIRST /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'FIRST"); + END IF; + + IF CHECK_TYPE3'LAST /= IDENT_INT (3) THEN + FAILED ("INCORRECT VALUE FOR CHECK_TYPE3'LAST"); + END IF; + + RETURN TRUE; + + END FUNC; + + FUNCTION NEWFUNC IS NEW FUNC; + + BEGIN + B := NEWFUNC; + END; + + RESULT; + END CD2B11B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- CD2B11D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE EXPRESSION IN A COLLECTION SIZE CLAUSE + -- FOR AN ACCESS TYPE NEED NOT BE STATIC. + + -- HISTORY: + -- BCB 09/23/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2B11D IS + + TYPE CHECK_TYPE IS ACCESS INTEGER; + FOR CHECK_TYPE'STORAGE_SIZE USE 256; + + TYPE ACC_TYPE IS ACCESS INTEGER; + FOR ACC_TYPE'STORAGE_SIZE USE IDENT_INT (256); + + BEGIN + + TEST ("CD2B11D", "CHECK THAT THE EXPRESSION IN A COLLECTION " & + "SIZE SPECIFICATION FOR AN ACCESS TYPE "& + "NEED NOT BE STATIC"); + + IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN + FAILED ("INCORRECT VALUE FOR STORAGE_SIZE"); + END IF; + + RESULT; + END CD2B11D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD2B11E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE EXPRESSION IN A COLLECTION SIZE CLAUSE + -- FOR AN ACCESS TYPE IN A GENERIC UNIT NEED NOT BE STATIC. + + -- HISTORY: + -- BCB 09/23/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2B11E IS + + B : BOOLEAN; + + BEGIN + + TEST ("CD2B11E", "CHECK THAT THE EXPRESSION IN A COLLECTION " & + "SIZE CLAUSE FOR AN ACCESS TYPE IN A " & + "GENERIC UNIT NEED NOT BE STATIC"); + + DECLARE + + GENERIC + FUNCTION FUNC RETURN BOOLEAN; + + FUNCTION FUNC RETURN BOOLEAN IS + + TYPE TEST_TYPE IS ACCESS INTEGER; + FOR TEST_TYPE'STORAGE_SIZE USE 256; + + TYPE ACC_TYPE IS ACCESS INTEGER; + FOR ACC_TYPE'STORAGE_SIZE + USE IDENT_INT (256); + + BEGIN -- FUNC. + + IF ACC_TYPE'STORAGE_SIZE < IDENT_INT (256) THEN + FAILED ("INCORRECT VALUE FOR STORAGE_SIZE"); + END IF; + + RETURN TRUE; + + END FUNC; + + FUNCTION NEWFUNC IS NEW FUNC; + + BEGIN + B := NEWFUNC; + END; + + RESULT; + END CD2B11E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b11f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CD2B11F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A COLLECTION SIZE SPECIFICATION IS GIVEN FOR AN + -- ACCESS TYPE WHOSE DESIGNATED TYPE IS A DISCRIMINATED RECORD, THEN + -- OPERATIONS ON VALUES OF THE ACCESS TYPE ARE NOT AFFECTED. + + -- HISTORY: + -- BCB 09/29/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + + PROCEDURE CD2B11F IS + + BASIC_SIZE : CONSTANT := 1024; + + TYPE RECORD_TYPE(DISC : INTEGER := 100) IS RECORD + COMP1 : INTEGER; + COMP2 : INTEGER; + COMP3 : INTEGER; + END RECORD; + + TYPE ACC_RECORD IS ACCESS RECORD_TYPE; + FOR ACC_RECORD'STORAGE_SIZE USE BASIC_SIZE; + + CHECK_RECORD1 : ACC_RECORD; + CHECK_RECORD2 : ACC_RECORD; + + BEGIN + + TEST ("CD2B11F", "CHECK THAT IF A COLLECTION SIZE SPECIFICATION " & + "IS GIVEN FOR AN ACCESS TYPE WHOSE " & + "DESIGNATED TYPE IS A DISCRIMINATED RECORD, " & + "THEN OPERATIONS ON VALUES OF THE ACCESS TYPE " & + "ARE NOT AFFECTED"); + + CHECK_RECORD1 := NEW RECORD_TYPE; + CHECK_RECORD1.COMP1 := 25; + CHECK_RECORD1.COMP2 := 25; + CHECK_RECORD1.COMP3 := 150; + + IF ACC_RECORD'STORAGE_SIZE < BASIC_SIZE THEN + FAILED ("INCORRECT VALUE FOR RECORD TYPE ACCESS " & + "STORAGE_SIZE"); + END IF; + + IF CHECK_RECORD1.DISC /= IDENT_INT (100) THEN + FAILED ("INCORRECT VALUE FOR RECORD DISCRIMINANT"); + END IF; + + IF ((CHECK_RECORD1.COMP1 /= CHECK_RECORD1.COMP2) OR + (CHECK_RECORD1.COMP1 = CHECK_RECORD1.COMP3)) THEN + FAILED ("INCORRECT VALUE FOR RECORD COMPONENT"); + END IF; + + IF EQUAL (3,3) THEN + CHECK_RECORD2 := CHECK_RECORD1; + END IF; + + IF CHECK_RECORD2 /= CHECK_RECORD1 THEN + FAILED ("INCORRECT RESULTS FOR RELATIONAL OPERATOR"); + END IF; + + RESULT; + END CD2B11F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b15c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CD2B15C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF THE COLLECTION SIZE IS LARGE ENOUGH TO HOLD SOME + -- VALUES OF THE DESIGNATED TYPE, CHECK THAT "STORAGE_ERROR" + -- IS RAISED BY AN ALLOCATOR WHEN INSUFFICIENT STORAGE IS + -- AVAILABLE. + + -- HISTORY: + -- DHH 09/23/87 CREATED ORIGINAL TEST. + -- PMW 09/19/88 MODIFIED WITHDRAWN TEST. + -- THS 03/21/90 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND + -- COMPLETELY REVISED THE TEST TO PREVENT OPTIMIZATION. + -- LDC 09/20/90 REMOVED UNUSED VARIABLE, CHANGED FAIL CALLS TO + -- COMMENT FOR 'STORAGE_SIZE /= TO SPECIFIED SIZE, + -- MOVED LOOP FOR CHECK VALUES TO EXCEPTION HANDLER. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD2B15C IS + + SPECIFIED_SIZE : CONSTANT := 1000; + + TYPE CHECK_TYPE IS ACCESS INTEGER; + FOR CHECK_TYPE'STORAGE_SIZE USE SPECIFIED_SIZE; + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / SYSTEM.STORAGE_UNIT; + + TYPE ACC_ARRAY_TYPE IS ARRAY + (INTEGER RANGE 1 .. (CHECK_TYPE'STORAGE_SIZE / + UNITS_PER_INTEGER) + 1) OF CHECK_TYPE; + ACC_ARRAY : ACC_ARRAY_TYPE; + + PLACE_I_STOPPED : INTEGER := 0; + + BEGIN + + TEST ("CD2B15C", "IF THE COLLECTION SIZE IS LARGE " & + "ENOUGH TO HOLD SOME VALUES OF " & + "THE DESIGNATED TYPE, CHECK THAT " & + "STORAGE_ERROR IS RAISED BY AN " & + "ALLOCATOR WHEN INSUFFICIENT STORAGE " & + "IS AVAILABLE"); + + IF CHECK_TYPE'STORAGE_SIZE < IDENT_INT (SPECIFIED_SIZE) THEN + FAILED ("CHECK_TYPE'STORAGE_SIZE IS LESS THEN THE VALUE " & + "SPECIFIED IN THE REPRESENTATION CLAUSE"); + + ELSIF CHECK_TYPE'STORAGE_SIZE > 2 * IDENT_INT (SPECIFIED_SIZE) THEN + COMMENT ("VALUE FOR CHECK_TYPE'STORAGE_SIZE IS MORE THEN " & + "TWICE THE SPECIFIED VALUE IN THE REPRESENTATION " & + "CLAUSE"); + END IF; + + BEGIN + + FOR I IN ACC_ARRAY'RANGE LOOP + ACC_ARRAY (I) := NEW INTEGER'(IDENT_INT (I)); + PLACE_I_STOPPED := I; + END LOOP; + + FAILED ("NO EXCEPTION RAISED WHEN RESERVED SPACE " & + "EXCEEDED"); + + EXCEPTION + WHEN STORAGE_ERROR => + FOR I IN 1 .. PLACE_I_STOPPED LOOP + IF ACC_ARRAY (I).ALL /= IDENT_INT (I) THEN + FAILED ("INCORRECT VALUE FOR ACC_ARRAY (" & + INTEGER'IMAGE (I) & ")"); + END IF; + END LOOP; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN RESERVED SPACE " & + "EXCEEDED"); + END; + + RESULT; + + END CD2B15C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2b16a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CD2B16A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF A COLLECTION SIZE CLAUSE IS GIVEN FOR A PARENT ACCESS TYPE, + -- THEN THE DERIVED TYPE HAS THE SAME COLLECTION SIZE, WHETHER THE + -- DERIVED TYPE IS DECLARED BEFORE OR AFTER THE PARENT COLLECTION + -- SIZE SPECIFICATION. + + -- HISTORY: + -- DHH 09/29/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD2B16A IS + BEGIN + TEST ("CD2B16A", "IF A COLLECTION SIZE IS GIVEN FOR A " & + "PARENT ACCESS TYPE, THEN THE DERIVED TYPE HAS " & + "THE SAME COLLECTION SIZE, WHETHER THE " & + "DERIVED TYPE IS DECLARED BEFORE OR AFTER " & + "THE PARENT COLLECTION SIZE SPECIFICATION"); + + DECLARE + + COLLECTION_SIZE : CONSTANT :=128; + TYPE V IS ARRAY(1..4) OF INTEGER; + + TYPE CELL IS + RECORD + VALUE : V; + END RECORD; + + TYPE LINK IS ACCESS CELL; + TYPE NEWLINK1 IS NEW LINK; + + FOR LINK'STORAGE_SIZE USE + COLLECTION_SIZE; + + TYPE NEWLINK2 IS NEW LINK; + + BEGIN -- ACTIVE DECLARE + + IF LINK'STORAGE_SIZE < COLLECTION_SIZE THEN + FAILED("STORAGE_SIZE SMALLER THAN STORAGE_SIZE " & + "SPECIFIED WAS ALLOCATED"); + END IF; + + IF LINK'STORAGE_SIZE /= NEWLINK1'STORAGE_SIZE THEN + FAILED("STORAGE_SIZE OF THE FIRST DERIVED TYPE" & + "IS NOT THE SAME SIZE AS THAT OF THE " & + "PARENT"); + END IF; + + IF LINK'STORAGE_SIZE /= NEWLINK2'STORAGE_SIZE THEN + FAILED("STORAGE_SIZE OF THE SECOND DERIVED TYPE" & + "IS NOT THE SAME SIZE AS THAT OF THE " & + "PARENT"); + END IF; + + END; --ACTIVE DECLARE + + RESULT; + END CD2B16A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2c11a.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + --CD2C11A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF A TASK STORAGE SIZE SPECIFICATION IS GIVEN FOR A TASK + -- TYPE, THEN OPERATIONS ON VALUES OF THE TASK TYPE ARE NOT + -- AFFECTED. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY + -- DHH 09/24/87 CREATED ORIGINAL TEST. + -- RJW 07/06/88 REVISED THE TEST TO REMOVE UNINITIALIZED 'IN OUT' + -- PARAMETER. CHANGED EXTENSION TO 'TST'. + + WITH REPORT; USE REPORT; + PROCEDURE CD2C11A IS + + TASK_STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + + BEGIN + + TEST ("CD2C11A", "IF A TASK STORAGE SIZE SPECIFICATION IS " & + "GIVEN FOR A TASK TYPE, THEN OPERATIONS " & + "ON VALUES OF THE TASK TYPE ARE NOT AFFECTED"); + + DECLARE + PACKAGE PACK IS + + TYPE FLT IS DIGITS 1; + + TASK TYPE TTYPE IS + ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER); + ENTRY MULT(Y : IN FLT; Z : IN OUT FLT); + END TTYPE; + + + M : INTEGER := 81; + N : INTEGER := 0; + V,W : FLT RANGE 1.0..512.0 := 2.0; + + FOR TTYPE'STORAGE_SIZE USE TASK_STORAGE_SIZE; + + T : TTYPE; + + END PACK; + + PACKAGE BODY PACK IS + FUNCTION IDENT_FLT(FT : FLT) RETURN FLT IS + BEGIN + IF EQUAL(5,5) THEN + RETURN FT; + ELSE + RETURN 0.0; + END IF; + END IDENT_FLT; + + TASK BODY TTYPE IS + ITEMP : INTEGER := 0; + FTEMP : FLT := 0.0; + BEGIN + ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER) DO + ITEMP := J; + IF EQUAL(3,3) THEN + K := ITEMP; + ELSE + K := 0; + END IF; + END ADD; + ACCEPT MULT(Y : IN FLT; Z : IN OUT FLT) DO + FTEMP := Y; + IF EQUAL(3,3) THEN + Z := FTEMP; + ELSE + Z := 0.0; + END IF; + END MULT; + END TTYPE; + + PROCEDURE TEST_TASK(G : IN TTYPE; + S : IN FLT; T : IN OUT FLT) IS + R : FLT := 4.0; + BEGIN + IF NOT (G'CALLABLE) OR G'TERMINATED THEN + FAILED("TASK INSIDE PROCEDURE IS SHOWING " & + "WRONG VALUE FOR 'CALLABLE OR " & + "'TERMINATED"); + END IF; + G.MULT(S,T); + END TEST_TASK; + + BEGIN + + IF TTYPE'STORAGE_SIZE < IDENT_INT(TASK_STORAGE_SIZE) THEN + FAILED("ACTUAL 'STORAGE_SIZE USED IS SMALLER " & + "THAN SIZE REQUESTED"); + END IF; + + T.ADD(M,N); + + IF M /= IDENT_INT(N) THEN + FAILED("TASK CALL PARAMETERS NOT EQUAL"); + END IF; + + V := IDENT_FLT(13.0); + TEST_TASK(T,V,W); + IF V /= IDENT_FLT(W) THEN + FAILED("TASK AS PARAMETER FAILED"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD2C11A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2c11d.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + --CD2C11D.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE NEED + -- NOT BE STATIC. + + -- MACRO SUBSTITUTION: + -- $TASK_STORAGE_SIZE IS THE NUMBER OF STORAGE_UNITS REQUIRED FOR + -- THE ACTIVATION OF A TASK. + + -- HISTORY + -- DHH 09/29/87 CREATED ORIGINAL TEST + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.TST'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD2C11D IS + + BEGIN + + TEST ("CD2C11D","THE EXPRESSION IN A TASK STORAGE SIZE CLAUSE " & + "NEED NOT BE STATIC"); + + DECLARE + + STORAGE_SIZE : CONSTANT := $TASK_STORAGE_SIZE; + PACKAGE PACK IS + TASK TYPE CHECK_TYPE; + + FOR CHECK_TYPE'STORAGE_SIZE USE + STORAGE_SIZE; + TASK TYPE TTYPE IS + ENTRY ADD(J :IN INTEGER; K : IN OUT INTEGER); + END TTYPE; + + FOR TTYPE'STORAGE_SIZE USE IDENT_INT(STORAGE_SIZE); + + END PACK; + + PACKAGE BODY PACK IS + + TASK BODY TTYPE IS + BEGIN + ACCEPT ADD(J :IN INTEGER; K : IN OUT INTEGER); + END TTYPE; + + TASK BODY CHECK_TYPE IS + BEGIN + NULL; + END CHECK_TYPE; + + BEGIN + + IF TTYPE'STORAGE_SIZE < IDENT_INT(STORAGE_SIZE) THEN + FAILED("STORAGE_SIZE SPECIFIED IS " & + "GREATER THAN MEMORY ALLOCATED"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD2C11D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2d11a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- CD2D11A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IF A SMALL SPECIFICATION IS GIVEN FOR A + -- FIXED POINT TYPE, THEN ARITHMETIC OPERATIONS ON VALUES OF THE + -- TYPE ARE NOT AFFECTED BY THE REPRESENTATION CLAUSE. + + -- HISTORY: + -- BCB 09/01/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + PROCEDURE CD2D11A IS + + BASIC_SMALL : CONSTANT := 2.0 ** (-4); + + TYPE BASIC_TYPE IS DELTA 2.0 ** (-4) RANGE -4.0 .. 4.0; + + TYPE CHECK_TYPE IS DELTA 1.0 RANGE -4.0 .. 4.0; + + FOR CHECK_TYPE'SMALL USE BASIC_SMALL; + + CNEG1 : CHECK_TYPE := -3.5; + CNEG2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + CPOS1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + CPOS2 : CHECK_TYPE := 3.5; + CZERO : CHECK_TYPE; + + TYPE ARRAY_TYPE IS ARRAY (0 .. 3) OF CHECK_TYPE; + CHARRAY : ARRAY_TYPE := + (-3.5, CHECK_TYPE (-1.0/3.0), CHECK_TYPE (4.0/6.0), 3.5); + + TYPE REC_TYPE IS RECORD + COMPN1 : CHECK_TYPE := -3.5; + COMPN2 : CHECK_TYPE := CHECK_TYPE (-1.0/3.0); + COMPP1 : CHECK_TYPE := CHECK_TYPE (4.0/6.0); + COMPP2 : CHECK_TYPE := 3.5; + END RECORD; + + CHREC : REC_TYPE; + + FUNCTION IDENT (FX : CHECK_TYPE) RETURN CHECK_TYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN FX; + ELSE + RETURN 0.0; + END IF; + END IDENT; + + PROCEDURE PROC (N1_IN, P1_IN : CHECK_TYPE; + N2_INOUT,P2_INOUT : IN OUT CHECK_TYPE; + CZOUT : OUT CHECK_TYPE) IS + BEGIN + + IF IDENT (N1_IN) + P1_IN NOT IN + -2.875 .. -2.8125 OR + P2_INOUT - IDENT (P1_IN) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "BINARY ADDING OPERATORS - 1"); + END IF; + + IF +IDENT (N2_INOUT) NOT IN -0.375 .. -0.3125 OR + IDENT (-P1_IN) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "UNARY ADDING OPERATORS - 1"); + END IF; + + IF CHECK_TYPE (N1_IN * IDENT (P1_IN)) NOT IN + -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (N2_INOUT) / P2_INOUT) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR " & + "MULTIPLYING OPERATORS - 1"); + END IF; + + IF ABS IDENT (N2_INOUT) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS P1_IN) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR " & + "ABSOLUTE VALUE OPERATORS - 1"); + END IF; + + CZOUT := 0.0; + + END PROC; + + BEGIN + TEST ("CD2D11A", "CHECK THAT IF A SMALL SPECIFICATION IS " & + "GIVEN FOR AN FIXED POINT TYPE, THEN " & + "ARITHMETIC OPERATIONS ON VALUES OF THE " & + "TYPE ARE NOT AFFECTED BY THE REPRESENTATION " & + "CLAUSE"); + + PROC (CNEG1, CPOS1, CNEG2, CPOS2, CZERO); + + IF IDENT (CZERO) /= 0.0 THEN + FAILED ("INCORRECT VALUE FOR OUT PARAMETER"); + END IF; + + IF IDENT (CNEG1) + CPOS1 NOT IN -2.875 .. -2.8125 OR + CPOS2 - IDENT (CPOS1) NOT IN 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 2"); + END IF; + + IF +IDENT (CNEG2) NOT IN -0.375 .. -0.3125 OR + IDENT (-CPOS1) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 2"); + END IF; + + IF CHECK_TYPE (CNEG1 * IDENT (CPOS1)) NOT IN -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CNEG2) / CPOS2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 2"); + END IF; + + IF ABS IDENT (CNEG2) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CPOS1) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 2"); + END IF; + + IF IDENT (CPOS1) NOT IN 0.625 .. 0.6875 OR + CNEG2 IN -0.25 .. 0.0 OR + IDENT (CNEG2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 2"); + END IF; + + IF IDENT (CHARRAY (0)) + CHARRAY (2) NOT IN + -2.875 .. -2.8125 OR + CHARRAY (3) - IDENT (CHARRAY (2)) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 3"); + END IF; + + IF +IDENT (CHARRAY (1)) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHARRAY (2)) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 3"); + END IF; + + IF CHECK_TYPE (CHARRAY (0) * IDENT (CHARRAY (2))) NOT IN + -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CHARRAY (1)) / CHARRAY (3)) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 3"); + END IF; + + IF ABS IDENT (CHARRAY (1)) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHARRAY (2)) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 3"); + END IF; + + IF IDENT (CHARRAY (2)) NOT IN 0.625 .. 0.6875 OR + CHARRAY (1) IN -0.25 .. 0.0 OR + IDENT (CHARRAY (1)) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 3"); + END IF; + + IF IDENT (CHREC.COMPN1) + CHREC.COMPP1 NOT IN + -2.875 .. -2.8125 OR + CHREC.COMPP2 - IDENT (CHREC.COMPP1) NOT IN + 2.8125 .. 2.875 THEN + FAILED ("INCORRECT RESULTS FOR BINARY ADDING OPERATORS - 4"); + END IF; + + IF +IDENT (CHREC.COMPN2) NOT IN -0.375 .. -0.3125 OR + IDENT (-CHREC.COMPP1) NOT IN -0.6875 .. -0.625 THEN + FAILED ("INCORRECT RESULTS FOR UNARY ADDING OPERATORS - 4"); + END IF; + + IF CHECK_TYPE (CHREC.COMPN1 * IDENT (CHREC.COMPP1)) NOT IN + -2.4375 .. -2.1875 OR + CHECK_TYPE (IDENT (CHREC.COMPN2) / CHREC.COMPP2) NOT IN + -0.125 .. -0.0625 THEN + FAILED ("INCORRECT RESULTS FOR MULTIPLYING OPERATORS - 4"); + END IF; + + IF ABS IDENT (CHREC.COMPN2) NOT IN 0.3125 .. 0.375 OR + IDENT (ABS CHREC.COMPP1) NOT IN 0.625 .. 0.6875 THEN + FAILED ("INCORRECT RESULTS FOR ABSOLUTE VALUE " & + "OPERATORS - 4"); + END IF; + + IF IDENT (CHREC.COMPP1) NOT IN 0.625 .. 0.6875 OR + CHREC.COMPN2 IN -0.25 .. 0.0 OR + IDENT (CHREC.COMPN2) IN -1.0 .. -0.4375 THEN + FAILED ("INCORRECT RESULTS FOR MEMBERSHIP OPERATORS - 4"); + END IF; + + RESULT; + END CD2D11A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd2d13a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CD2D13A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE + -- OR PRIVATE PART OF A PACKAGE FOR A FIXED POINT TYPE DECLARED + -- IN THE VISIBLE PART. + + -- HISTORY: + -- BCB 09/01/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; WITH TEXT_IO; + WITH REPORT; USE REPORT; + PROCEDURE CD2D13A IS + + SPECIFIED_SMALL : CONSTANT := 2.0 ** (-4); + + PACKAGE P IS + TYPE FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0; + FOR FIXED_IN_P'SMALL USE SPECIFIED_SMALL; + TYPE ALT_FIXED_IN_P IS DELTA 1.0 RANGE -4.0 .. 4.0; + PRIVATE + FOR ALT_FIXED_IN_P'SMALL USE SPECIFIED_SMALL; + END P; + + USE P; + + BEGIN + + TEST("CD2D13A", "A SMALL CLAUSE CAN BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A PACKAGE FOR A FIXED " & + "POINT TYPE DECLARED IN THE VISIBLE PART"); + + IF FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN + FAILED ("INCORRECT VALUE FOR FIXED_IN_P'SMALL"); + END IF; + + IF ALT_FIXED_IN_P'SMALL /= SPECIFIED_SMALL THEN + FAILED ("INCORRECT VALUE FOR ALT_FIXED_IN_P'SMALL"); + END IF; + + RESULT; + + END CD2D13A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,284 ---- + -- CD30001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that X'Address produces a useful result when X is an aliased + -- object. + -- Check that X'Address produces a useful result when X is an object of + -- a by-reference type. + -- Check that X'Address produces a useful result when X is an entity + -- whose Address has been specified. + -- + -- Check that aliased objects and subcomponents are allocated on storage + -- element boundaries. Check that objects and subcomponents of by + -- reference types are allocated on storage element boundaries. + -- + -- Check that for an array X, X'Address points at the first component + -- of the array, and not at the array bounds. + -- + -- TEST DESCRIPTION: + -- This test defines a data structure (an array of records) where each + -- aspect of the data structure is aliased. The test checks 'Address + -- for each "layer" of aliased objects. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 08 MAY 96 SAIC Reinforced for 2.1 + -- 16 FEB 98 EDS Modified documentation + --! + + ----------------------------------------------------------------- CD30001_0 + + with SPPRT13; + package CD30001_0 is + + -- Check that X'Address produces a useful result when X is an aliased + -- object. + -- Check that X'Address produces a useful result when X is an object of + -- a by-reference type. + -- Check that X'Address produces a useful result when X is an entity + -- whose Address has been specified. + -- (using the new form of "for X'Address use ...") + -- + -- Check that aliased objects and subcomponents are allocated on storage + -- element boundaries. Check that objects and subcomponents of by + -- reference types are allocated on storage element boundaries. + + type Simple_Enum_Type is (Just, A, Little, Bit); + + type Data is record + Aliased_Comp_1 : aliased Simple_Enum_Type; + Aliased_Comp_2 : aliased Simple_Enum_Type; + end record; + + type Array_W_Aliased_Comps is array(1..2) of aliased Data; + + Aliased_Object : aliased Array_W_Aliased_Comps; + + Specific_Object : aliased Array_W_Aliased_Comps; + for Specific_Object'Address use SPPRT13.Variable_Address2; -- ANX-C RQMT. + + procedure TC_Check_Aliased_Addresses; + + procedure TC_Check_Specific_Addresses; + + procedure TC_Check_By_Reference_Types; + + end CD30001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with System.Storage_Elements; + with System.Address_To_Access_Conversions; + package body CD30001_0 is + + package Simple_Enum_Type_Ref_Conv is + new System.Address_To_Access_Conversions(Simple_Enum_Type); + + package Data_Ref_Conv is new System.Address_To_Access_Conversions(Data); + + package Array_W_Aliased_Comps_Ref_Conv is + new System.Address_To_Access_Conversions(Array_W_Aliased_Comps); + + use type System.Address; + use type System.Storage_Elements.Integer_Address; + use type System.Storage_Elements.Storage_Offset; + + procedure TC_Check_Aliased_Addresses is + use type Simple_Enum_Type_Ref_Conv.Object_Pointer; + use type Data_Ref_Conv.Object_Pointer; + use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer; + + begin + + -- Check the object Aliased_Object + + if Aliased_Object'Address not in System.Address then + Report.Failed("Aliased_Object'Address not an address"); + end if; + + if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(Aliased_Object'Address) + /= Aliased_Object'Unchecked_Access then + Report.Failed + ("'Unchecked_Access does not match expected address value"); + end if; + + -- Check the element Aliased_Object(1) + + if Data_Ref_Conv.To_Address( Aliased_Object(1)'Access ) + /= Aliased_Object(1)'Address then + Report.Failed + ("Array element 'Access does not match expected address value"); + end if; + + -- Check that Array'Address points at the first component... + + if Array_W_Aliased_Comps_Ref_Conv.To_Address( Aliased_Object'Access ) + /= Aliased_Object(1)'Address then + Report.Failed + ("Address of array object does not equal address of first component"); + end if; + + -- Check the components of Aliased_Object(2) + + if Simple_Enum_Type_Ref_Conv.To_Address( + Aliased_Object(2).Aliased_Comp_1'Unchecked_Access) + not in System.Address then + Report.Failed("Component 2 'Unchecked_Access not a valid address"); + end if; + + if Aliased_Object(2).Aliased_Comp_2'Address not in System.Address then + Report.Failed("Component 2 not located at a valid address "); + end if; + + end TC_Check_Aliased_Addresses; + + procedure TC_Check_Specific_Addresses is + use type System.Address; + use type System.Storage_Elements.Integer_Address; + use type Simple_Enum_Type_Ref_Conv.Object_Pointer; + use type Data_Ref_Conv.Object_Pointer; + use type Array_W_Aliased_Comps_Ref_Conv.Object_Pointer; + begin + + -- Check the object Specific_Object + + if System.Storage_Elements.To_Integer(Specific_Object'Address) + /= System.Storage_Elements.To_Integer(SPPRT13.Variable_Address2) then + Report.Failed + ("Specific_Object not at address specified in representation clause"); + end if; + + if Array_W_Aliased_Comps_Ref_Conv.To_Pointer(SPPRT13.Variable_Address2) + /= Specific_Object'Unchecked_Access then + Report.Failed("Specific_Object'Unchecked_Access not expected value"); + end if; + + -- Check the element Specific_Object(1) + + if Data_Ref_Conv.To_Address( Specific_Object(1)'Access ) + /= Specific_Object(1)'Address then + Report.Failed + ("Specific Array element 'Access does not correspond to the " + & "elements 'Address"); + end if; + + -- Check that Array'Address points at the first component... + + if Array_W_Aliased_Comps_Ref_Conv.To_Address( Specific_Object'Access ) + /= Specific_Object(1)'Address then + Report.Failed + ("Address of array object does not equal address of first component"); + end if; + + -- Check the components of Specific_Object(2) + + if Simple_Enum_Type_Ref_Conv.To_Address( + Specific_Object(1).Aliased_Comp_1'Access) + not in System.Address then + Report.Failed("Access value of first record component for object at " & + "specific address not a valid address"); + end if; + + if Specific_Object(2).Aliased_Comp_2'Address not in System.Address then + Report.Failed("Second record component for object at specific " & + "address not located at a valid address"); + end if; + + end TC_Check_Specific_Addresses; + + -- Check that X'Address produces a useful result when X is an object of + -- a by-reference type. + + type Tagged_But_Not_Exciting is tagged record + A_Bit_Of_Data : Boolean; + end record; + + Tagged_Object : Tagged_But_Not_Exciting; + + procedure Muck_With_Addresses( It : in out Tagged_But_Not_Exciting; + Its_Address : in System.Address ) is + begin + if It'Address /= Its_Address then + Report.Failed("Address of object passed by reference does not " & + "match address of object passed" ); + end if; + end Muck_With_Addresses; + + procedure TC_Check_By_Reference_Types is + begin + Muck_With_Addresses( Tagged_Object, Tagged_Object'Address ); + end TC_Check_By_Reference_Types; + + end CD30001_0; + + ------------------------------------------------------------------- CD30001 + + with Report; + with CD30001_0; + procedure CD30001 is + + begin -- Main test procedure. + + Report.Test ("CD30001", + "Check that X'Address produces a useful result when X is " & + "an aliased object, or an entity whose Address has been " & + "specified" ); + + -- Check that X'Address produces a useful result when X is an aliased + -- object. + -- + -- Check that aliased objects and subcomponents are allocated on storage + -- element boundaries. Check that objects and subcomponents of by + -- reference types are allocated on storage element boundaries. + + CD30001_0.TC_Check_Aliased_Addresses; + + -- Check that X'Address produces a useful result when X is an entity + -- whose Address has been specified. + + CD30001_0.TC_Check_Specific_Addresses; + + -- Check that X'Address produces a useful result when X is an object of + -- a by-reference type. + + CD30001_0.TC_Check_By_Reference_Types; + + Report.Result; + + end CD30001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- CD30002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the implementation supports Alignments for subtypes and + -- objects specified as factors and multiples of the number of storage + -- elements per word, unless those values cannot be loaded and stored. + -- Check that the largest alignment returned by default is supported. + -- + -- Check that the implementation supports Alignments supported by the + -- target linker for stand-alone library-level objects of statically + -- constrained subtypes. + -- + -- TEST DESCRIPTION: + -- This test defines several types and objects, specifying various + -- alignments for them (as factors and multiples of the number of + -- storage elements per word). It then checks the alignments by + -- declaring some objects, and checking that the integer values of + -- their addresses is mod the specified alignment. This will not + -- prevent false passes where the lucky compiler gets it right by + -- chance, but will catch compilers that specifically do not obey + -- the alignment clauses. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 09 MAY 96 SAIC Strengthened for 2.1 + -- 26 FEB 97 PWB.CTA Allowed for unexpected word sizes + -- 16 FEB 98 EDS Modified documentation. + -- 26 SEP 98 RLB Fixed value on line 130 so check and dec. match. + -- 30 OCT 98 RLB Split Multiple_Alignment and revised the + -- calculation to work on all targets. + -- 18 JAN 99 RLB Repaired again to work on targets where word size + -- equals storage unit. + --! + + ----------------------------------------------------------------- CD30002_0 + + with Impdef; + with System.Storage_Elements; + package CD30002_0 is + + S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit; + -- Must be 1 or greater. + + Multiple_Type_Alignment : constant := + Integer'Min ( Impdef.Max_Default_Alignment, + 2 * S_Units_per_Word ); + -- Calculate a reasonable alignment, but not larger than the + -- implementation is required to support. + + Multiple_Object_Alignment : constant := + Integer'Min ( Impdef.Max_Linker_Alignment, + 2 * S_Units_per_Word ); + -- Calculate a reasonable object alignment, but not larger than + -- the implementation is required to support. + + Small_Alignment : constant := + Integer'Max ( S_Units_per_Word / 2, 1); + -- Calculate a reasonable small alignment, but not less than 1. + -- (If S_Units_per_Word = 1, 1/2 => 0 which causes problems + -- verifying alignment.) + + subtype Storage_Element is System.Storage_Elements.Storage_Element; + + type Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element; + for Some_Stuff'Alignment + use Impdef.Max_Default_Alignment; -- ANX-C RQMT. + + Library_Level_Object : Some_Stuff; + for Library_Level_Object'Alignment + use Impdef.Max_Linker_Alignment; -- ANX-C RQMT. + + type Quarter is mod 4; -- two bits + for Quarter'Alignment use Small_Alignment; -- ANX-C RQMT. + + type Half is mod 16; -- nibble + for Half'Alignment use Multiple_Type_Alignment; -- ANX-C RQMT. + + type O_Some_Stuff is array(1..S_Units_Per_Word) of Storage_Element; + + type O_Quarter is mod 4; -- two bits + + type O_Half is mod 16; -- nibble + + end CD30002_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- there is no package body CD30002_0 + + ------------------------------------------------------------------- CD30002 + + with Report; + with Impdef; + with CD30002_0; + with System.Storage_Elements; + procedure CD30002 is + + My_Stuff : CD30002_0.Some_Stuff; + -- Impdef.Max_Default_Alignment + + My_Quarter : CD30002_0.Quarter; + -- CD30002_0.S_Units_per_Word / 2 + + My_Half : CD30002_0.Half; + -- CD30002_0.S_Units_per_Word * 2 + + Stuff_Object : CD30002_0.O_Some_Stuff; + for Stuff_Object'Alignment + use Impdef.Max_Default_Alignment; -- ANX-C RQMT. + + Quarter_Object : CD30002_0.O_Quarter; + for Quarter_Object'Alignment + use CD30002_0.Small_Alignment; -- ANX-C RQMT. + + Half_Object : CD30002_0.O_Half; + for Half_Object'Alignment + use CD30002_0.Multiple_Object_Alignment; -- ANX-C RQMT. + + subtype IntAdd is System.Storage_Elements.Integer_Address; + use type System.Storage_Elements.Integer_Address; + + function A2I(Value: System.Address) return IntAdd renames + System.Storage_Elements.To_Integer; + + NAC : constant String := " not aligned correctly"; + + begin -- Main test procedure. + + Report.Test ("CD30002", "Check that the implementation supports " & + "Alignments for subtypes and objects specified " & + "as factors and multiples of the number of " & + "storage elements per word, unless those values " & + "cannot be loaded and stored. Check that the " & + "largest alignment returned by default is " & + "supported. Check that the implementation " & + "supports Alignments supported by the target " & + "linker for stand-alone library-level objects " & + "of statically constrained subtypes" ); + + if A2I(CD30002_0.Library_Level_Object'Address) + mod Impdef.Max_Linker_Alignment /= 0 then + Report.Failed("Library_Level_Object" & NAC); + end if; + + if A2I(My_Stuff'Address) mod Impdef.Max_Default_Alignment /= 0 then + Report.Failed("Max alignment subtype" & NAC); + end if; + + if A2I(My_Quarter'Address) mod (CD30002_0.Small_Alignment) /= 0 then + Report.Failed("Factor of words subtype" & NAC); + end if; + + if A2I(My_Half'Address) mod (CD30002_0.Multiple_Type_Alignment) /= 0 then + Report.Failed("Multiple of words subtype" & NAC); + end if; + + if A2I(Stuff_Object'Address) mod Impdef.Max_Default_Alignment /= 0 then + Report.Failed("Stuff alignment object" & NAC); + end if; + + if A2I(Quarter_Object'Address) + mod (CD30002_0.Small_Alignment) /= 0 then + Report.Failed("Factor of words object" & NAC); + end if; + + if A2I(Half_Object'Address) mod (CD30002_0.Multiple_Object_Alignment) /= 0 then + Report.Failed("Multiple of words object" & NAC); + end if; + + Report.Result; + + end CD30002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30003.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,227 ---- + -- CD30003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a Size clause for an object is supported if the specified + -- size is at least as large as the subtype's size, and correspond to a + -- size in storage elements that is a multiple of the object's (non-zero) + -- Alignment. RM 13.3(43) + -- + -- TEST DESCRIPTION: + -- This test defines several types and then asserts specific sizes for + -- the, it then checks that the size set is reported back. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 08 MAY 96 SAIC Corrected and strengthened for 2.1 + -- 14 FEB 97 PWB.CTA Changed 'Size specifications to multiples + -- of System.Storage_Unit; restricted 'Size spec + -- for enumeration object to max integer size. + -- 16 FEB 98 EDS Modify Documentation. + -- 25 JAN 99 RLB Repaired to properly set and check sizes. + -- 29 JAN 99 RLB Added Pack pragma needed for some implementations. + -- Corrected to support a Storage_Unit size < 8. + --! + + ------------------------------------------------------------------- CD30003 + + with Report; + with System; + procedure CD30003 is + + --------------------------------------------------------------------------- + -- types and subtypes + --------------------------------------------------------------------------- + + type Bit is mod 2**1; + for Bit'Size use 1; -- ANX-C RQMT. + + type Byte is mod 2**8; + for Byte'Size use 8; -- ANX-C RQMT. + + type Smallword is mod 2**8; + for Smallword'size use 16; -- ANX-C RQMT. + + type Byte_Array is array(1..4) of Byte; + pragma Pack(Byte_Array); -- ANX-C RQMT. + -- size should be 32 + + type Smallword_Array is array(1..4) of Smallword; + pragma Pack(Smallword_Array); -- Required if Storage_Unit > 16. -- ANX-C RQMT. + + -- Use to calulate maximum required size: + type Max_Modular is mod System.Max_Binary_Modulus; + type Max_Integer is range System.Min_Int .. System.Max_Int; + Enum_Size : constant := Integer'Min (32, + Integer'Min (Max_Modular'Size, Max_Integer'Size)); + type Transmission_Data is ( Empty, Input, Output, IO, Control ); + for Transmission_Data'Size use Enum_Size; -- ANX-C RQMT. + + -- Sizes to try: + + -- The basic sizes are based on a "normal" Storage_Unit = 8 implementation. + -- We then use formulas to insure that the specified sizes meet the + -- the minimum level of support and AI-0051. + + Modular_Single_Size : constant := Integer'Min (((8 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + -- Calulate an appropriate, legal, and required to be supported size to + -- try, which is the size of Byte. Note that object sizes must be + -- a multiple of the storage unit for the compiler. + + Modular_Double_Size : constant := Integer'Min (((16 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + + Modular_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, Max_Modular'Size); + + Array_Quad_Size : constant := ((4 * 8 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Array_Octo_Size : constant := ((4 * 16 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Rounded_Enum_Size : constant := ((Enum_Size + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit; + + Enum_Quad_Size : constant := Integer'Min (((32 + (System.Storage_Unit-1)) + /System.Storage_Unit)*System.Storage_Unit, + Integer'Min (Max_Modular'Size, Max_Integer'Size)); + + + --------------------------------------------------------------------------- + -- objects + --------------------------------------------------------------------------- + + Bit_8 : Bit :=0; + for Bit_8'Size use System.Storage_Unit; -- ANX-C RQMT. + + Bit_G : Bit :=0; + for Bit_G'Size use Modular_Double_Size; -- ANX-C RQMT. + + Byte_8 : Byte :=0; + for Byte_8'Size use Modular_Single_Size; -- ANX-C RQMT. + + Byte_G : Byte :=0; + for Byte_G'Size use Modular_Double_Size; -- ANX-C RQMT. + + Smallword_1 : Smallword :=0; + for Smallword_1'Size use Modular_Double_Size; -- ANX-C RQMT. + + Smallword_2 : Smallword :=0; + for Smallword_2'Size use Modular_Quad_Size; -- ANX-C RQMT. + + Byte_Array_1 : Byte_Array := (others=>0); + for Byte_Array_1'Size use Array_Quad_Size; -- ANX-C RQMT. + + Smallword_Array_1 : Smallword_Array := (others=>0); + for Smallword_Array_1'Size use Array_Octo_Size; -- ANX-C RQMT. + + Transmission_Data_1 : aliased Transmission_Data := Empty; + + Transmission_Data_2 : Transmission_Data := Control; + for Transmission_Data_2'Size use Enum_Quad_Size; -- ANX-C RQMT. + + begin -- Main test procedure. + + Report.Test ("CD30003", "Check that Size clauses are supported for " & + "values at least as large as the subtypes " & + "size, and correspond to a size in storage " & + "elements that is a multiple of the objects " & + "(non-zero) Alignment" ); + + if Bit_8'Size /= System.Storage_Unit then + Report.Failed("Expected Bit_8'Size =" & Integer'Image(System.Storage_Unit) + & " , actually =" & Integer'Image(Bit_8'Size)); + end if; + + if Bit_G'Size /= Modular_Double_Size then + Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size) + & " , actually =" & Integer'Image(Bit_G'Size)); + end if; + + if Byte_8'Size /= Modular_Single_Size then + Report.Failed("Expected Byte_8'Size =" & Integer'Image(Modular_Single_Size) + & " , actually =" & Integer'Image(Byte_8'Size)); + end if; + + if Byte_G'Size /= Modular_Double_Size then + Report.Failed("Expected Bit_G'Size =" & Integer'Image(Modular_Double_Size) + & " , actually =" & Integer'Image(Byte_G'Size)); + end if; + + if Smallword_1'Size /= Modular_Double_Size then + Report.Failed("Expected Smallword_1'Size =" & + Integer'Image(Modular_Double_Size) & + ", actually =" & Integer'Image(Smallword_1'Size)); + end if; + + if Smallword_2'Size /= Modular_Quad_Size then + Report.Failed("Expected Smallword_2'Size =" & + Integer'Image(Modular_Quad_Size) & + ", actually =" & Integer'Image(Smallword_2'Size)); + end if; + + if Byte_Array_1'Size /= Array_Quad_Size then + Report.Failed("Expected Byte_Array_1'Size =" & + Integer'Image(Array_Quad_Size) & + ", actually =" & Integer'Image(Byte_Array_1'Size)); + end if; + + if Smallword_Array_1'Size /= Array_Octo_Size then + Report.Failed( + "Expected Smallword_Array_1'Size =" & + Integer'Image(Array_Octo_Size) & + ", actually =" & Integer'Image(Smallword_Array_1'Size)); + end if; + + if Transmission_Data_1'Size /= Enum_Size and then + Transmission_Data_1'Size /= Rounded_Enum_Size then + Report.Failed( + "Expected Transmission_Data_1'Size =" & Integer'Image(Rounded_Enum_Size) & + ", actually =" & Integer'Image(Transmission_Data_1'Size)); + end if; + + if Transmission_Data_2'Size /= Enum_Quad_Size then + Report.Failed( + "Expected Transmission_Data_2'Size =" & Integer'Image(Enum_Quad_Size) & + ", actually =" & Integer'Image(Transmission_Data_2'Size)); + end if; + + Report.Result; + + end CD30003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd30004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd30004.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- CD30004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- + -- + -- Check that the unspecified Size of static discrete + -- subtypes is the number of bits needed to represent each value + -- belonging to the subtype using an unbiased representation, where + -- space for a sign bit is provided only in the event the subtype + -- contains negative values. Check that for first subtypes specified + -- Sizes are supported reflecting this representation. [ARM 95 13.3(55)]. + -- + -- TEST DESCRIPTION: + -- This test defines a few types that should have distinctly recognizable + -- sizes. A packed record which should result in very specific bits + -- sizes for it's components is used to check the first part of the + -- objective. The second part of the objective is checked by giving + -- sizes for a similar set of types. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 06 MAY 96 SAIC Revised for 2.1 + -- 26 FEB 97 PWB.CTA Added pragma Pack for type Check_Record + -- 16 FEB 98 EDS Modified Documentation. + -- 06 JUL 99 RLB Repaired comments, removed junk test cases. + -- Added test cases to test that appropriate Size + -- clauses are allowed. + + --! + ----------------------------------------------------------------- CD30004_0 + + package CD30004_0 is + + -- Check that the unspecified Size of static discrete and fixed point + -- subtypes are the number of bits needed to represent each value + -- belonging to the subtype using an unbiased representation, where + -- space for a sign bit is provided only in the event the subtype + -- contains negative values. Check that for first subtypes specified + -- Sizes are supported reflecting this representation. + + type Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit ); + + type Bits_3 is range 0..2**3-1; + + type Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp + + type Bits_14 is mod 2**14; + + type Check_Record is + record + B14 : Bits_14; + B2 : Bits_2; + B3 : Bits_3; + B5 : Bits_5; + C : Character; + end record; + pragma Pack ( Check_Record ); + + procedure TC_Check_Values; + procedure TC_Check_Specified_Sizes; + + end CD30004_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + with Report; + with Impdef; + package body CD30004_0 is + + procedure TC_Check_Values is + begin + + if Bits_2'Size /= 2 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_2'Size not 2 bits"); + else -- Recommended levels of support are not binding. + Report.Comment("Bits_2'Size not 2 bits"); + end if; + end if; + + if Bits_14'Size /= 14 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_14'Size not 14 bits"); + else + Report.Comment("Bits_14'Size not 14 bits"); + end if; + end if; + + if Bits_3'Size /= 3 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_3'Size not 3 bits"); + else + Report.Comment("Bits_3'Size not 3 bits"); + end if; + end if; + + if Bits_5'Size /= 5 then + if Impdef.Validating_Annex_C then + Report.Failed("Bits_5'Size not 5 bits"); + else + Report.Comment("Bits_5'Size not 5 bits"); + end if; + end if; + + if Character'Size /= 8 then + Report.Failed("Character'Size not 8 bits"); + end if; + + if Wide_Character'Size /= 16 then + Report.Failed("Wide_Character'Size not 16 bits"); + end if; + + end TC_Check_Values; + + type Spec_Bits_2 is ( Zeroth_Bit, Fiercest_Bit, Secants_Bit, Threadless_Bit ); + for Spec_Bits_2'Size use 2; -- ANX-C RQMT. + + type Spec_Bits_3 is range 0..2**3-1; + for Spec_Bits_3'Size use 3; -- ANX-C RQMT. + + type Spec_Bits_5 is range -2**4+1..2**4-1; -- allow for 1's comp + for Spec_Bits_5'Size use 5; -- ANX-C RQMT. + + type Spec_Bits_14 is mod 2**14; + for Spec_Bits_14'Size use 14; -- ANX-C RQMT. + + type Spec_Record is new Check_Record; + for Spec_Record'Size use 64; -- ANX-C RQMT. + + procedure TC_Check_Specified_Sizes is + + begin + + if Spec_Record'Size /= 64 then + Report.Failed("Spec_Record'Size not 64 bits"); + end if; + + if Spec_Bits_2'Size /= 2 then + Report.Failed("Spec_Bits_2'Size not 2 bits"); + end if; + + if Spec_Bits_14'Size /= 14 then + Report.Failed("Spec_Bits_14'Size not 14 bits"); + end if; + + if Spec_Bits_3'Size /= 3 then + Report.Failed("Spec_Bits_3'Size not 3 bits"); + end if; + + if Spec_Bits_5'Size /= 5 then + Report.Failed("Spec_Bits_5'Size not 5 bits"); + end if; + + end TC_Check_Specified_Sizes; + + end CD30004_0; + + ------------------------------------------------------------------- CD30004 + + with Report; + with CD30004_0; + + procedure CD30004 is + + begin -- Main test procedure. + + Report.Test ("CD30004", "Check that the unspecified Size of static " & + "discrete and fixed point subtypes is the number of bits " & + "needed to represent each value belonging to the subtype " & + "using an unbiased representation, where space for a sign " & + "bit is provided only in the event the subtype contains " & + "negative values. Check that for first subtypes " & + "specified Sizes are supported reflecting this " & + "representation."); + + CD30004_0.TC_Check_Values; + + CD30004_0.TC_Check_Specified_Sizes; + + Report.Result; + + end CD30004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd300050.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd300050.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd300050.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd300050.am 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- CD30005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Address clauses are supported for imported subprograms. + -- + -- TEST DESCRIPTION: + -- This test imports a simple C function and specifies it's location. + -- + -- The implementation may choose to implement + -- Impdef.CD30005_1_Foreign_Address so as to dynamically call a C + -- function that returns the appropriate address for the external + -- function identified by Impdef.CD30005_1_External_Name. + -- + -- TEST FILES: + -- CD300050.AM + -- CD300051.C -- the C function: (included below for reference) + -- + -- SPECIAL REQUIREMENTS: + -- The file CD300051.C must be compiled with a C compiler. + -- Implementation dialects of C may require alteration of the C program + -- syntax. The program is included here for reference: + -- + -- int _cd30005_1( Value ) + -- { + -- /* int Value */ + -- + -- return Value + 1; + -- } + -- + -- Implementations may require special linkage commands to include the + -- C code. + -- + -- APPLICABILITY CRITERIA: + -- This test is not applicable to implementations not providing an interface + -- to C language units. OTHERWISE: + -- + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 30 APR 96 SAIC Added commentary for 2.1 + -- 09 MAY 96 SAIC Changed reporting for 2.1 + -- 04 NOV 96 SAIC Added use type System.Address + -- 16 FEB 98 EDS Modified documentation. + -- 29 JUN 98 EDS Modified main program name. + --! + + ----------------------------------------------------------------- CD30005_0 + + with Impdef; + package CD30005_0 is + + -- Check that Address clauses are supported for imported subprograms. + + type External_Func_Ref is access function(N:Integer) return Integer; + pragma Convention( C, External_Func_Ref ); + + + function CD30005_1( I: Integer ) return Integer; + + pragma Import( C, CD30005_1, + Impdef.CD30005_1_External_Name ); -- N/A => ERROR. + + for CD30005_1'Address use + Impdef.CD30005_1_Foreign_Address; -- ANX-C RQMT. + + procedure TC_Check_Imports; + + end CD30005_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + with System.Storage_Elements; + with System.Address_To_Access_Conversions; + package body CD30005_0 is + + use type System.Address; + + procedure TC_Check_Imports is + S : External_Func_Ref := CD30005_1'Access; + I,K : Integer := 99; + begin + + K := S.all(I); + if K /= 100 then + Report.Failed("C program returned" & Integer'Image(K)); + end if; + + I := CD30005_1( I ); + if I /= 100 then + Report.Failed("C program returned" & Integer'Image(I)); + end if; + + if CD30005_1'Address /= Impdef.CD30005_1_Foreign_Address then + Report.Failed("Address not that specified"); + end if; + + end TC_Check_Imports; + + end CD30005_0; + + ------------------------------------------------------------------- CD300050 + + with Report; + with CD30005_0; + + procedure CD300050 is + + begin -- Main test procedure. + + Report.Test ("CD30005", + "Check that Address clauses are supported for imported " & + "subprograms" ); + + -- Check that Address clauses are supported for imported subprograms. + + CD30005_0.TC_Check_Imports; + + Report.Result; + + end CD300050; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd300051.c gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd300051.c *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd300051.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd300051.c 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + /* + -- CD30051.C + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FUNCTION NAME: _cd3005_1 + -- + -- FUNCTION DESCRIPTION: + -- This C function returns the sum of its parameter and 1 through + -- the function name. The parameter is unchanged. + -- + -- INPUTS: + -- This function requires that one parameter, of type int, be passed + -- to it. + -- + -- PROCESSING: + -- The function will calculate the sum of its parameter and 1 + -- and return this value as the function result through the function + -- name. + -- + -- OUTPUTS: + -- The sum of the parameter and 1 is returned through function name. + -- + -- CHANGE HISTORY: + -- 12 Oct 95 SAIC Initial prerelease version. + -- 14 Feb 97 PWB.CTA Created this file from code appearing in + -- CD30005.A (as comments). + --! + */ + int _cd30005_1( Value ) + { + /* int Value */ + + return Value + 1; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- CD3014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION TYPE WITH A REPRESENTATION CLAUSE CAN + -- BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN + -- GENERIC INSTANTIATIONS. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO + -- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. + -- REVISED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR + -- MESSAGE. + + WITH REPORT; USE REPORT; + PROCEDURE CD3014A IS + + BEGIN + + TEST ("CD3014A", "CHECK THAT AN ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE CAN BE USED CORRECTLY " & + "IN ORDERING RELATIONS, INDEXING ARRAYS, AND " & + "IN GENERIC INSTANTIATIONS"); + + DECLARE + PACKAGE PACK IS + + TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR HUE USE (RED => 8, BLUE => 9, + YELLOW => 10, 'R' => 11, + 'B' => 12, 'Y' => 13); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED); + + FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16, + YELLOW => 19, BLUE => 41, RED => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END PACK; + + PACKAGE BODY PACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'PRED(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND + 'Y' <= COLOR1 AND COLOR1 > 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND + BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND + BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD3014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CD3014C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN IN + -- THE VISIBLE OR PRIVATE PART OF A PACKAGE FOR A TYPE DECLARED IN + -- THE VISIBLE PART. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST + -- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED + -- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR + -- REPRESENTATION CLAUSE. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS CALL TO 'FAILED' + PROCEDURE CD3014C IS + + BEGIN + + TEST ("CD3014C", "CHECK THAT AN ENUMERATION " & + "REPRESENTATION CLAUSE CAN BE GIVEN IN THE " & + "VISIBLE OR PRIVATE PART OF A PACKAGE FOR " & + "A TYPE DECLARED IN THE VISIBLE PART"); + + DECLARE + PACKAGE PACK IS + + TYPE HUE IS (RED,BLUE,YELLOW); + TYPE NEWHUE IS (RED,BLUE,YELLOW); + + FOR HUE USE + (RED => 8, BLUE => 16, + YELLOW => 32); + A : HUE := BLUE; + PRIVATE + + FOR NEWHUE USE (RED => 8, BLUE => 16, YELLOW => 32); + + B : NEWHUE := RED; + + TYPE INT_HUE IS RANGE 8 .. 32; + FOR INT_HUE'SIZE USE HUE'SIZE; + + TYPE INT_NEW IS RANGE 8 .. 32; + FOR INT_NEW'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE); + PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_HUE (RED, 8, "HUE"); + CHECK_NEW (YELLOW, 32, "NEWHUE"); + END PACK; + + BEGIN + NULL; + END; + + RESULT; + END CD3014C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CD3014D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION TYPE WITH A REPRESENTATION CLAUSE IN A + -- GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING RELATIONS, + -- INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- BCB 03/07/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO + -- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. + -- REVISED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING IN HEADER AND MODIFIED FAILED ERROR + -- MESSAGE. + + WITH REPORT; USE REPORT; + PROCEDURE CD3014D IS + + BEGIN + + TEST ("CD3014D", "CHECK THAT AN ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " & + "BE USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE HUE1 IS ('Y','B','R',YELLOW,BLUE,RED); + + FOR HUE1 USE ('Y' => 10, 'B' => 14, 'R' => 16, + YELLOW => 19, BLUE => 41, RED => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'PRED(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 < BASIC1 AND BASIC1 >= 'R' AND + 'Y' <= COLOR1 AND COLOR1 > 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 6 AND BARRAY1 (BLUE) = 5 AND + BARRAY1 (YELLOW) = 4 AND BARRAY1 ('R') = 3 AND + BARRAY1 ('B') = 2 AND BARRAY1 ('Y') = 1) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; + END CD3014D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3014f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CD3014F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE CAN BE GIVEN + -- IN THE VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A + -- TYPE DECLARED IN THE VISIBLE PART. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST + -- DHH 03/29/89 CHANGED FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + -- RJW 09/18/89 REMOVED THE COMMENT "-- N/A => ERROR.". + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3014F IS + + BEGIN + + TEST ("CD3014F", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE CAN BE GIVEN IN THE VISIBLE " & + "OR PRIVATE PART OF A GENERIC PACKAGE FOR " & + "A TYPE DECLARED IN THE VISIBLE PART"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE HUE IS (RED,BLUE,YELLOW,'R','B','Y'); + TYPE NEWHUE IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + A : HUE := BLUE; + + TYPE INT1 IS RANGE 8 .. 13; + FOR INT1'SIZE USE HUE'SIZE; + + PRIVATE + + FOR NEWHUE USE (RED => 2, BLUE => 4, YELLOW => 6, + 'R' => 8, 'B' => 10, 'Y' => 12); + + B : NEWHUE := RED; + TYPE INT2 IS RANGE 2 .. 12; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + END GENPACK; + + PACKAGE BODY GENPACK IS + BEGIN + CHECK_1 ('B', 12, "HUE"); + CHECK_2 ('B', 10, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; + END CD3014F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- CD3015A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED ENUMERATION TYPE CAN BE USED CORRECTLY IN + -- ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC + -- INSTANTIATIONS, WHEN THERE IS NO ENUMERATION CLAUSE FOR THE + -- PARENT. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO + -- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. + -- REVISED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE + -- ERROR MESSAGE. + + WITH REPORT; USE REPORT; + PROCEDURE CD3015A IS + + BEGIN + + TEST ("CD3015A", "CHECK THAT A DERIVED ENUMERATION TYPE CAN BE " & + "USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC " & + "INSTANTIATIONS, WHEN THERE IS NO ENUMERATION " & + "CLAUSE FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END PACK; + + PACKAGE BODY PACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES IN PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CD3015C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED + -- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE + -- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE NO + -- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + + -- HISTORY + -- DHH 10/01/87 CREATED ORIGINAL TEST + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3015C IS + + BEGIN + + TEST ("CD3015C", "CHECK THAT AN ENUMERATION " & + "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " & + "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " & + "VISIBLE PART, WHERE NO ENUMERATION CLAUSE HAS " & + "BEEN GIVEN FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 1, BLUE => 16, YELLOW => 32); + PRIVATE + FOR NEWHUE USE (RED => 16, BLUE => 17, YELLOW => 18); + + TYPE INT1 IS RANGE 1 .. 32; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 16 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + END PACK; + + PACKAGE BODY PACK IS + + BEGIN + CHECK_1 (RED, 1, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CD3015E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN THERE IS NO ENUMERATION CLAUSE FOR THE PARENT + -- TYPE IN A GENERIC UNIT, THE DERIVED TYPE CAN BE USED CORRECTLY + -- IN ORDERING RELATIONS, INDEXING ARRAYS, AND IN GENERIC + -- INSTANTIATIONS. + + -- HISTORY + -- DHH 10/05/87 CREATED ORIGINAL TEST + -- DHH 03/30/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND ADDED + -- CHECK FOR REPRESENTATION CLAUSE. + -- RJW 03/20/90 MODIFIED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING ON FAILURE ERROR MESSAGE. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3015E IS + + BEGIN + + TEST ("CD3015E", "CHECK THAT WHEN THERE " & + "IS NO ENUMERATION CLAUSE FOR THE PARENT " & + "TYPE IN A GENERIC UNIT, THE " & + "DERIVED TYPE CAN BE USED CORRECTLY IN " & + "ORDERING RELATIONS, INDEXING ARRAYS, AND IN " & + "GENERIC INSTANTIATIONS"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + FOR HUE USE + (RED => 1, BLUE => 6, + YELLOW => 11, 'R' => 16, + 'B' => 22, 'Y' => 30); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + T : INTEGER := 1; + + TYPE INT1 IS RANGE 1 .. 30; + FOR INT1'SIZE USE HUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + IF (COLOR < BASIC OR + BASIC >= 'R' OR + 'Y' <= COLOR OR + COLOR > 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + + IF COLOR /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + FOR I IN HUE LOOP + BARRAY(I) := IDENT_INT(T); + T := T + 1; + END LOOP; + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + CHECK_1 (YELLOW, 11, "HUE"); + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- CD3015F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED + -- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A GENERIC + -- PACKAGE FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE + -- NO ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + + -- HISTORY + -- DHH 10/01/87 CREATED ORIGINAL TEST + -- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA',CHANGED + -- FROM 'A' TEST TO 'C' TEST AND ADDED CHECK FOR + -- REPRESENTATION CLAUSE. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3015F IS + + BEGIN + + TEST ("CD3015F", "CHECK THAT AN " & + "ENUMERATION REPRESENTATION CLAUSE FOR A " & + "DERIVED TYPE CAN BE GIVEN IN THE VISIBLE OR " & + "PRIVATE PART OF A GENERIC PACKAGE FOR A " & + "DERIVED TYPE DECLARED IN THE VISIBLE PART, " & + "WHERE NO ENUMERATION CLAUSE HAS BEEN GIVEN " & + "FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + PRIVATE + FOR NEWHUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE INT_HUE IS RANGE 8 .. 13; + FOR INT_HUE'SIZE USE HUE'SIZE; + + TYPE INT_NEW IS RANGE 8 .. 13; + FOR INT_NEW'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_HUE IS NEW ENUM_CHECK(HUE, INT_HUE); + PROCEDURE CHECK_NEW IS NEW ENUM_CHECK(NEWHUE, INT_NEW); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + BEGIN + CHECK_HUE (RED, 8, "HUE"); + CHECK_HUE ('R', 11, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; + END CD3015F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- CD3015G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED ENUMERATION TYPE WITH A REPRESENTATION + -- CLAUSE CAN BE USED CORRECTLY IN ORDERING RELATIONS, INDEXING + -- ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN THERE IS AN + -- ENUMERATION CLAUSE FOR THE PARENT. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO + -- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. + -- REVISED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE + -- ERROR MESSAGE. + + WITH REPORT; USE REPORT; + PROCEDURE CD3015G IS + + BEGIN + + TEST ("CD3015G", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE CAN BE USED CORRECTLY " & + "IN ORDERING RELATIONS, INDEXING ARRAYS, AND " & + "IN GENERIC INSTANTIATIONS WHEN THERE IS AN " & + "ENUMERATION CLAUSE FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3, 'R' => 4, + 'B' => 5, 'Y' => 6); + + TYPE HUE IS NEW MAIN; + FOR HUE USE (RED => 8, BLUE => 9, YELLOW => 10, + 'R' => 11, 'B' => 12, 'Y' => 13); + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END PACK; + + PACKAGE BODY PACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015h.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- CD3015H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION REPRESENTATION CLAUSE FOR A DERIVED + -- TYPE CAN BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A PACKAGE + -- FOR A DERIVED TYPE DECLARED IN THE VISIBLE PART, WHERE AN + -- ENUMERATION CLAUSE HAS BEEN GIVEN FOR THE PARENT. + + -- HISTORY + -- DHH 10/01/87 CREATED ORIGINAL TEST + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3015H IS + + BEGIN + + TEST ("CD3015H", "CHECK THAT AN ENUMERATION " & + "REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN " & + "BE GIVEN IN THE VISIBLE OR PRIVATE PART OF A " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN THE " & + "VISIBLE PART, WHERE AN ENUMERATION CLAUSE HAS " & + "BEEN GIVEN FOR THE PARENT"); + + DECLARE + PACKAGE PACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE + (RED => 8, BLUE => 9, YELLOW => 10); + + PRIVATE + + FOR NEWHUE USE (RED => 6, BLUE => 11, YELLOW => 18); + + TYPE INT1 IS RANGE 8 .. 10; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 6 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + + END PACK; + + PACKAGE BODY PACK IS + BEGIN + CHECK_1 (RED, 8, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END PACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- CD3015I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A DERIVED ENUMERATION TYPE WITH A REPRESENTATION + -- CLAUSE IN A GENERIC UNIT CAN BE USED CORRECTLY IN ORDERING + -- RELATIONS, INDEXING ARRAYS, AND IN GENERIC INSTANTIATIONS WHEN + -- THERE IS AN ENUMERATION CLAUSE FOR THE PARENT. + + -- HISTORY + -- DHH 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- BCB 03/08/90 REVISED WORDING IN HEADER COMMENT AND IN CALL TO + -- REPORT.TEST. ADDED CHECK FOR NON-CONTIGUOUS CODES. + -- REVISED CHECK FOR ARRAY INDEXING. + -- THS 09/18/90 REVISED WORDING IN HEADER COMMENT AND FIXED FAILURE + -- ERROR MESSAGE. + + WITH REPORT; USE REPORT; + PROCEDURE CD3015I IS + + BEGIN + + TEST ("CD3015I", "CHECK THAT A DERIVED ENUMERATION TYPE WITH A " & + "REPRESENTATION CLAUSE IN A GENERIC UNIT CAN " & + "BE USED CORRECTLY IN ORDERING RELATIONS, " & + "INDEXING ARRAYS, AND IN GENERIC " & + "INSTANTIATIONS WHEN THERE IS AN ENUMERATION " & + "CLAUSE FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW,'R','B','Y'); + FOR MAIN USE + (RED => 1, BLUE => 2, + YELLOW => 3, 'R' => 4, + 'B' => 5, 'Y' => 6); + + TYPE HUE IS NEW MAIN; + FOR HUE USE + (RED => 8, BLUE => 9, + YELLOW => 10, 'R' => 11, + 'B' => 12, 'Y' => 13); + + TYPE BASE IS ARRAY(HUE) OF INTEGER; + COLOR,BASIC : HUE; + BARRAY : BASE; + + TYPE HUE1 IS NEW MAIN; + FOR HUE1 USE (RED => 10, BLUE => 14, YELLOW => 16, + 'R' => 19, 'B' => 41, 'Y' => 46); + + TYPE BASE1 IS ARRAY(HUE1) OF INTEGER; + COLOR1,BASIC1 : HUE1; + BARRAY1 : BASE1; + + GENERIC + TYPE ENUM IS (<>); + PROCEDURE CHANGE(X,Y : IN OUT ENUM); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + PROCEDURE CHANGE(X,Y : IN OUT ENUM) IS + T : ENUM; + BEGIN + T := X; + X := Y; + Y := T; + END CHANGE; + + PROCEDURE PROC IS NEW CHANGE(HUE); + PROCEDURE PROC1 IS NEW CHANGE(HUE1); + + BEGIN + BASIC := RED; + COLOR := HUE'SUCC(BASIC); + BASIC1 := RED; + COLOR1 := HUE1'SUCC(BASIC1); + IF (COLOR < BASIC OR BASIC >= 'R' OR 'Y' <= COLOR OR + COLOR > 'B') OR + NOT (COLOR1 >= BASIC1 AND BASIC1 < 'R' AND + 'Y' > COLOR1 AND COLOR1 <= 'B') THEN + FAILED("ORDERING RELATIONS ARE INCORRECT"); + END IF; + + PROC(BASIC,COLOR); + PROC1(BASIC1,COLOR1); + + IF COLOR /= RED OR COLOR1 /= RED THEN + FAILED("VALUES OF PARAMETERS TO INSTANCE OF " & + "GENERIC UNIT NOT CORRECT AFTER CALL"); + END IF; + + BARRAY := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + BARRAY1 := (IDENT_INT(1),IDENT_INT(2),IDENT_INT(3), + IDENT_INT(4),IDENT_INT(5),IDENT_INT(6)); + + IF (BARRAY (RED) /= 1 OR BARRAY (BLUE) /= 2 OR + BARRAY (YELLOW) /= 3 OR BARRAY ('R') /= 4 OR + BARRAY ('B') /= 5 OR BARRAY ('Y') /= 6) OR + NOT (BARRAY1 (RED) = 1 AND BARRAY1 (BLUE) = 2 AND + BARRAY1 (YELLOW) = 3 AND BARRAY1 ('R') = 4 AND + BARRAY1 ('B') = 5 AND BARRAY1 ('Y') = 6) + THEN + FAILED("INDEXING ARRAY FAILURE"); + END IF; + + END GENPACK; + + PACKAGE P IS NEW GENPACK; + BEGIN + NULL; + END; + + RESULT; + END CD3015I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3015k.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- CD3015K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ENUMERATION + -- REPRESENTATION CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN THE + -- VISIBLE OR PRIVATE PART OF A GENERIC PACKAGE FOR A DERIVED TYPE + -- DECLARED IN THE VISIBLE PART, WHERE AN ENUMERATION CLAUSE + -- HAS BEEN GIVEN FOR THE PARENT. + + -- HISTORY + -- DHH 10/01/87 CREATED ORIGINAL TEST + -- DHH 03/29/89 CHANGE FROM 'A' TEST TO 'C' TEST AND FROM '.DEP' + -- '.ADA'. ADDED CHECK ON REPRESENTATION CLAUSES. + + WITH REPORT; USE REPORT; + WITH ENUM_CHECK; -- CONTAINS A CALL TO 'FAILED'. + PROCEDURE CD3015K IS + + BEGIN + + TEST ("CD3015K", "CHECK THAT AN ENUMERATION REPRESENTATION " & + "CLAUSE FOR A DERIVED TYPE CAN BE GIVEN IN " & + "THE VISIBLE OR PRIVATE PART OF A GENERIC " & + "PACKAGE FOR A DERIVED TYPE DECLARED IN " & + "THE VISIBLE PART, WHERE AN ENUMERATION " & + "CLAUSE HAS BEEN GIVEN FOR THE PARENT"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + TYPE MAIN IS (RED,BLUE,YELLOW); + FOR MAIN USE (RED => 1, BLUE => 2, YELLOW => 3); + + TYPE HUE IS NEW MAIN; + TYPE NEWHUE IS NEW MAIN; + + FOR HUE USE (RED => 8, BLUE => 11, YELLOW => 12); + + PRIVATE + + FOR NEWHUE USE (RED => 6, BLUE => 12, YELLOW => 18); + + TYPE INT1 IS RANGE 8 .. 12; + FOR INT1'SIZE USE HUE'SIZE; + + TYPE INT2 IS RANGE 6 .. 18; + FOR INT2'SIZE USE NEWHUE'SIZE; + + PROCEDURE CHECK_1 IS NEW ENUM_CHECK(HUE, INT1); + PROCEDURE CHECK_2 IS NEW ENUM_CHECK(NEWHUE, INT2); + + END GENPACK; + + PACKAGE BODY GENPACK IS + + BEGIN + CHECK_1 (RED, 8, "HUE"); + CHECK_2 (YELLOW, 18, "NEWHUE"); + END GENPACK; + + PACKAGE P IS NEW GENPACK; + + BEGIN + NULL; + END; + + RESULT; + END CD3015K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd3021a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CD3021A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE AGGREGATE IN AN ENUMERATION REPRESENTATION CLAUSE + -- IS NOT AMBIGUOUS EVEN IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY + -- TYPES WITH THE ENUMERATION TYPE AS THE INDEX SUBTYPE. + + -- HISTORY: + -- BCB 09/30/87 CREATED ORIGINAL TEST. + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP', CORRECTED + -- CHECKS FOR FAILURE. + + WITH REPORT; USE REPORT; + + PROCEDURE CD3021A IS + + TYPE ENUM IS (A,B,C); + + TYPE ARR1 IS ARRAY(ENUM) OF INTEGER; + TYPE ARR2 IS ARRAY(ENUM) OF INTEGER; + TYPE ARR3 IS ARRAY(ENUM) OF INTEGER; + + FOR ENUM USE (A => 1,B => 2,C => 3); + + A1 : ARR1 := (A => 5,B => 6,C => 13); + A2 : ARR2 := (A => 1,B => 2,C => 3); + A3 : ARR3 := (A => 0,B => 1,C => 2); + + BEGIN + + TEST ("CD3021A", "CHECK THAT THE AGGREGATE IN AN ENUMERATION " & + "REPRESENTATION CLAUSE IS NOT AMBIGUOUS EVEN " & + "IF THERE ARE SEVERAL ONE-DIMENSIONAL ARRAY " & + "TYPES WITH THE ENUMERATION TYPE AS THE INDEX " & + "SUBTYPE"); + + IF (A1 /= (IDENT_INT (5), IDENT_INT (6), IDENT_INT (13))) OR + (A2 /= (IDENT_INT (1), IDENT_INT (2), IDENT_INT (3))) OR + (A3 /= (IDENT_INT (0), IDENT_INT (1), IDENT_INT (2))) THEN + FAILED ("INCORRECT VALUES FOR ARRAYS"); + END IF; + + RESULT; + END CD3021A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd33001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd33001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd33001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd33001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + -- CD33001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Component_Sizes that are a factor of the word + -- size are supported. + -- + -- Check that for such Component_Sizes arrays contain no gaps between + -- components. + -- + -- TEST DESCRIPTION: + -- This test defines three array types and specifies their layouts + -- using representation specifications for the 'Component_Size and + -- pragma Packs for each. It then checks that the implied assumptions + -- about the resulting layout actually can be made. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 07 MAY 96 SAIC Revised for 2.1 + -- 24 AUG 96 SAIC Additional 2.1 revisions + -- 17 FEB 97 PWB.CTA Corrected prefix of 'Component_Size to name + -- array object instead of array subtype + -- 16 FEB 98 EDS Modified documentation. + --! + + ----------------------------------------------------------------- CD33001_0 + + with System; + package CD33001_0 is + + S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit; + + type Nibble is mod 2**4; + + type Byte is mod 2**8; + + type Half_Stuff is array(Natural range <>) of Nibble; + for Half_Stuff'Component_Size + use System.Word_Size / 2; -- factor -- ANX-C RQMT. + pragma Pack(Half_Stuff); -- ANX-C RQMT. + + type Word_Stuff is array(Natural range <>) of Byte; + for Word_Stuff'Component_Size + use System.Word_Size; -- ANX-C RQMT. + + type Address_Calculator is record + Item_1 : Nibble; + Item_2 : Nibble; + end record; + + for Address_Calculator use record + Item_1 at 0 range 0..3; + Item_2 at 1 range 0..3; + end record; + + -- given that Item_1 is specified to be at 'Position = 0 and + -- Item_2 is specified to be at 'Position = 1 + -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1 + + end CD33001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- there is no package body CD33001_0 + + ------------------------------------------------------------------- CD33001 + + with Report; + with System.Storage_Elements; + with CD33001_0; + procedure CD33001 is + + use type System.Storage_Elements.Storage_Offset; + + A_Half : CD33001_0.Half_Stuff(0..15); + + A_Word : CD33001_0.Word_Stuff(0..15); + + procedure Unexpected( Message : String; Wanted, Got: Integer ) is + begin + Report.Failed( Message & " Wanted:" + & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) ); + end Unexpected; + + begin -- Main test procedure. + + Report.Test ("CD33001", "Check that Component_Sizes that are factor of " & + "the word size are supported. Check that for " & + "such Component_Sizes arrays contain no gaps " & + "between components" ); + + if A_Half'Size /= A_Half'Component_Size * 16 then + Unexpected("Half word Size", + CD33001_0.Half_Stuff'Component_Size * 16, + A_Half'Size ); + end if; + + if A_Word(1)'Size /= System.Word_Size then + Unexpected("Word Size", System.Word_Size, A_Word(1)'Size ); + end if; + + + Report.Result; + + end CD33001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd33002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd33002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd33002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd33002.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- CD33002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Component_Sizes that are multiples of the word + -- size are supported. + -- + -- Check that for such Component_Sizes arrays contain no gaps between + -- components. + -- + -- TEST DESCRIPTION: + -- This test defines three array types and specifies their layouts + -- using representation specifications for the 'Component_Size and + -- pragma Packs for each. It then checks that the implied assumptions + -- about the resulting layout actually can be made. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 07 MAY 96 SAIC Revised for 2.1 + -- 24 AUG 96 SAIC Additional 2.1 revisions + -- 16 FEB 98 EDS Modify documentation. + --! + + ----------------------------------------------------------------- CD33002_0 + + with System; + package CD33002_0 is + + S_Units_per_Word : constant := System.Word_Size/System.Storage_Unit; + + type Nibble is mod 2**4; + + type Byte is mod 2**8; + + type Word_Stuff is array(Natural range <>) of Byte; + for Word_Stuff'Component_Size + use System.Word_Size; -- ANX-C RQMT. + pragma Pack(Word_Stuff); -- ANX-C RQMT. + + type Double_Stuff is array(Natural range <>) of Byte; + for Double_Stuff'Component_Size + use System.Word_Size * 2; -- multiple -- ANX-C RQMT. + + type Address_Calculator is record + Item_1 : Nibble; + Item_2 : Nibble; + end record; + + for Address_Calculator use record + Item_1 at 0 range 0..3; + Item_2 at 1 range 0..3; + end record; + + -- by definition (13.5.2(2)) abs(Item_2'Address - Item_1'Address) = 1 + -- it therefore follows that: + -- Address_Calculator'Size = 2 * Addressable_Unit'Size + + end CD33002_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + -- there is no package body CD33002_0 + + ------------------------------------------------------------------- CD33002 + + with Report; + with TCTouch; + with System.Storage_Elements; + with CD33002_0; + procedure CD33002 is + + use type System.Storage_Elements.Storage_Offset; + + A_Word : CD33002_0.Word_Stuff(0..15); + + A_Double : CD33002_0.Double_Stuff(0..15); + + procedure Unexpected( Message : String; Wanted, Got: Integer ) is + begin + Report.Failed ( Message & " Wanted:" + & Integer'Image(Wanted) & " Got:" & Integer'Image(Got) ); + end Unexpected; + + begin -- Main test procedure. + + Report.Test ("CD33002", "Check that Component_Sizes that are multiples " + & "of the word size are supported. Check that for " + & "such Component_Sizes arrays contain no gaps " + & "between components" ); + + if A_Word'Size /= CD33002_0.Word_Stuff'Component_Size * 16 then + Unexpected("Word Size", + CD33002_0.Word_Stuff'Component_Size * 16, + A_Word'Size ); + end if; + + if A_Double'Size /= CD33002_0.Double_Stuff'Component_Size * 16 then + Unexpected("Double word Size", + CD33002_0.Double_Stuff'Component_Size * 16, + A_Double'Size ); + end if; + + + Report.Result; + + end CD33002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd40001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd40001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd40001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd40001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,181 ---- + -- CD40001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Enumeration_Representation_Clauses are supported for + -- codes in the range System.Min_Int..System.Max_Int. + -- + -- TEST DESCRIPTION: + -- This test defines several types, and checks that the range of the + -- enumeration clause is as expected. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 07 MAY 96 SAIC Revised for 2.1 + -- 16 FEB 98 EDS Modified Documentation. + --! + + with System; + with Ada.Unchecked_Conversion; + package CD40001_0 is + + type Press_The_Bounds is ( Negative_Large, Positive_Large ); + + for Press_The_Bounds use + ( Negative_Large => System.Min_Int, -- ANX-C RQMT. + Positive_Large => System.Max_Int ); -- ANX-C RQMT. + + type Add_The_Bounds is + ( Monday, Tuesday, Wednesday, Thursday, Friday, Saturday); + + for Add_The_Bounds use + ( Monday => System.Min_Int, -- ANX-C RQMT. + Tuesday => System.Min_Int + 1, -- ANX-C RQMT. + Wednesday => System.Min_Int + 2, -- ANX-C RQMT. + Thursday => System.Min_Int + 3, -- ANX-C RQMT. + Friday => System.Min_Int + 4, -- ANX-C RQMT. + Saturday => System.Min_Int + 5 ); -- ANX-C RQMT. + + type Minus_The_Bounds is ( Jan, Feb, Mar, Apr); + + for Minus_The_Bounds use + ( Apr => System.Max_Int, -- ANX-C RQMT. + Mar => System.Max_Int - 1, -- ANX-C RQMT. + Feb => System.Max_Int - 2, -- ANX-C RQMT. + Jan => System.Max_Int - 3 ); -- ANX-C RQMT. + + type TC_Integer is range System.Min_Int..System.Max_Int; + + procedure TC_Check_Press; + + procedure TC_Check_Add; + + procedure TC_Check_Minus; + + function TC_Compare_Press is new Ada.Unchecked_Conversion + (Press_The_Bounds, TC_Integer); + + function TC_Compare_Add is new Ada.Unchecked_Conversion + (Add_The_Bounds, TC_Integer); + + function TC_Compare_Minus is new Ada.Unchecked_Conversion + (Minus_The_Bounds, TC_Integer); + + end CD40001_0; + + --==================================================================-- + + with Report; + package body CD40001_0 is + + procedure TC_Check_Press is + My_Press_First : Press_The_Bounds := Negative_Large; + My_Press_Last : Press_The_Bounds := Positive_Large; + begin + if TC_Compare_Press (My_Press_First) /= System.Min_Int or + TC_Compare_Press (My_Press_Last) /= System.Max_Int + then + Report.Failed + ("Expected enumeration size of System.Min_Int and System.Max_Int " & + "not available for this implementation"); + end if; + end TC_Check_Press; + + --------------------------------------------------------------------------- + procedure TC_Check_Add is + My_Monday : Add_The_Bounds := Monday; + My_Tuesday : Add_The_Bounds := Tuesday; + My_Wednesday : Add_The_Bounds := Wednesday; + My_Thursday : Add_The_Bounds := Thursday; + My_Friday : Add_The_Bounds := Friday; + My_Saturday : Add_The_Bounds := Saturday; + begin + if TC_Compare_Add (My_Monday) /= (System.Min_Int) or + TC_Compare_Add (My_Thursday) /= (System.Min_Int + 3) or + TC_Compare_Add (My_Wednesday) /= (System.Min_Int + 2) or + TC_Compare_Add (My_Tuesday) /= (System.Min_Int + 1) or + TC_Compare_Add (My_Saturday) /= (System.Min_Int + 5) or + TC_Compare_Add (My_Friday) /= (System.Min_Int + 4) + then + Report.Failed + ("Expected enumeration size of System.Min_Int, System.Min_Int + 1 " & + "through System.Min_Int + 5 not available for this implementation"); + end if; + end TC_Check_Add; + + --------------------------------------------------------------------------- + procedure TC_Check_Minus is + My_Jan : Minus_The_Bounds := Jan; + My_Feb : Minus_The_Bounds := Feb; + My_Mar : Minus_The_Bounds := Mar; + My_Apr : Minus_The_Bounds := Apr; + begin + if TC_Compare_Minus (My_Jan) /= (System.Max_Int - 3) or + TC_Compare_Minus (My_Feb) /= (System.Max_Int - 2) or + TC_Compare_Minus (My_Mar) /= (System.Max_Int - 1) or + TC_Compare_Minus (My_Apr) /= (System.Max_Int) + then + Report.Failed + ("Expected enumeration size of System.Max_Int, System.Max_Int - 1 " & + "through System.Max_Int - 3 not available for this implementation"); + end if; + end TC_Check_Minus; + + end CD40001_0; + + --==================================================================-- + + with Report; + with CD40001_0; + + procedure CD40001 is + + begin -- Main test procedure. + + Report.Test ("CD40001", "Check that Enumeration_Representation_Clauses " & + "are supported for codes in the range " & + "System.Min_Int..System.Max_Int" ); + + CD40001_0.TC_Check_Press; + + CD40001_0.TC_Check_Add; + + CD40001_0.TC_Check_Minus; + + Report.Result; + + end CD40001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4031a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + -- CD4031A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN A RECORD REPRESENTATION CLAUSE IS GIVEN FOR A + -- VARIANT RECORD TYPE, THEN COMPONENTS BELONGING TO DIFFERENT + -- VARIANTS CAN BE GIVEN OVERLAPPING STORAGE. + + -- HISTORY: + -- PWB 07/22/87 CREATED ORIGINAL TEST. + -- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND + -- ADDED CHECK FOR REPRESENTATION CLAUSE. + -- RJW 06/12/90 REMOVED REFERENCES TO LENGTH_CHECK. REVISED + -- COMMENTS. + -- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's + -- complement machines to represent all values in + -- the specified number of bits. + + WITH REPORT; USE REPORT; + PROCEDURE CD4031A IS + + TYPE DISCRIMINAN IS RANGE -1 .. 1; + TYPE INT IS RANGE -3 .. 3; + TYPE LARGE_INT IS RANGE -7 .. 7; + + TYPE TEST_CLAUSE (DISC : DISCRIMINAN := 0) IS + RECORD + CASE DISC IS + WHEN 0 => + INTEGER_COMP : LARGE_INT; + WHEN OTHERS => + CH_COMP_1 : INT; + CH_COMP_2 : INT; + END CASE; + END RECORD; + + FOR TEST_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0 .. 1; + INTEGER_COMP AT 0 + RANGE 2 .. 5; + CH_COMP_1 AT 0 + RANGE 2 .. 4; + CH_COMP_2 AT 0 + RANGE 5 .. 7; + END RECORD; + + TYPE TEST_CL1 IS NEW TEST_CLAUSE(DISC => 0); + TYPE TEST_CL2 IS NEW TEST_CLAUSE(DISC => 1); + TEST_RECORD : TEST_CL1; + TEST_RECORD1 : TEST_CL2; + + INTEGER_COMP_FIRST, + CH_COMP_1_FIRST : INTEGER; + + BEGIN + TEST ("CD4031A", "IN RECORD REPRESENTATION CLAUSES " & + "FOR VARIANT RECORD TYPES, " & + "COMPONENTS OF DIFFERENT VARIANTS " & + "CAN BE GIVEN OVERLAPPING STORAGE"); + + TEST_RECORD := (0, -7); + INTEGER_COMP_FIRST := TEST_RECORD.INTEGER_COMP'FIRST_BIT; + + TEST_RECORD1 := (1, -3, -3); + CH_COMP_1_FIRST := TEST_RECORD1.CH_COMP_1'FIRST_BIT; + + IF INTEGER_COMP_FIRST /= CH_COMP_1_FIRST THEN + FAILED ("COMPONENTS DO NOT BEGIN AT SAME POINT"); + END IF; + + RESULT; + END CD4031A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4041a.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- CD4041A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ALIGNMENT CLAUSE CAN BE GIVEN FOR A RECORD + -- REPRESENTATION CLAUSE. + + -- HISTORY: + -- RJW 08/25/87 CREATED ORIGINAL TEST. + -- DHH 03/30/89 CHANGED MOD 4 TO A MACRO VALUE AND CHANGED + -- EXTENSION FROM '.DEP' TO '.TST'. + + -- MACRO SUBSTITUTION: + -- $ALIGNMENT IS THE VALUE USED TO ALIGN A RECORD ON A BOUNDARY + -- DEFINED BY THE IMPLEMENTATION. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD4041A IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE CHECK_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + FOR CHECK_CLAUSE USE + RECORD AT MOD $ALIGNMENT; + INT_COMP AT 0 + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + + BEGIN + TEST ("CD4041A", "CHECK THAT AN ALIGNMENT CLAUSE CAN BE " & + "GIVEN FOR A RECORD REPRESENTATION CLAUSE"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; + END CD4041A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- CD4051A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR + -- DERIVED TYPES WHOSE PARENT TYPES ARE RECORD TYPES WITHOUT + -- DISCRIMINANTS. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- RJW 08/25/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD4051A IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + INT_COMP AT 0 + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + + BEGIN + TEST ("CD4051A", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITHOUT DISCRIMINANTS"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= 0 THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; + END CD4051A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- CD4051B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE WHICH CHANGES THE + -- ORDER OF THE COMPONENT STORAGE CAN BE GIVEN FOR A DERIVED TYPE + -- WHOSE PARENT TYPE IS A RECORD WITHOUT A DISCRIMINANT. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- RJW 08/25/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD4051B IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + INT_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 0 + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (1, 'A'); + + BEGIN + TEST ("CD4051B", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE WHICH CHANGES THE ORDER OF COMPONENT " & + "STORAGE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITHOUT DISCRIMINANTS"); + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; + END CD4051B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- CD4051C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR + -- A DERIVED TYPE WHOSE PARENT TYPE IS A RECORD WITH A + -- DISCRIMINANT. + + -- HISTORY: + -- BCB 03/20/89 CHANGED EXTENSION FROM '.ADA' TO '.DEP'. + -- RJW 08/25/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD4051C IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1) / + SYSTEM.STORAGE_UNIT; + + TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD + INT_COMP : INTEGER; + CHAR_COMP : CHARACTER; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE; + + FOR CHECK_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0..BOOLEAN'SIZE - 1; + INT_COMP AT 1*UNITS_PER_INTEGER + RANGE 0..INTEGER'SIZE - 1; + CHAR_COMP AT 2*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE (TRUE) := (TRUE, 1, 'A'); + + BEGIN + TEST ("CD4051C", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS IS A RECORD TYPE " & + "WITH DISCRIMINANTS"); + + IF CHECK_RECORD.DISC'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'LAST_BIT /= BOOLEAN'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF DISC"); + END IF; + + IF CHECK_RECORD.INT_COMP'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'LAST_BIT /= + IDENT_INT (INTEGER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF INT_COMP"); + END IF; + + IF CHECK_RECORD.INT_COMP'POSITION /= + IDENT_INT (UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF INT_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'LAST_BIT /= + IDENT_INT (CHARACTER'SIZE - 1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHAR_COMP"); + END IF; + + IF CHECK_RECORD.CHAR_COMP'POSITION /= + IDENT_INT (2 * UNITS_PER_INTEGER) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHAR_COMP"); + END IF; + + RESULT; + END CD4051C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd4051d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CD4051D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A RECORD REPRESENTATION CLAUSE CAN BE GIVEN FOR + -- A DERIVED SUBTYPE WHOSE PARENT TYPE IS A RECORD TYPE WITH + -- VARIANTS AND THE REPRESENTATION CLAUSE MENTIONS COMPONENTS THAT + -- DO NOT EXIST IN THE DERIVED SUBTYPE. + + -- HISTORY: + -- RJW 08/25/87 CREATED ORIGINAL TEST. + -- DHH 03/27/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA' AND + -- ADDED CHECK FOR REPRESENTATION CLAUSE. + -- RJW 10/26/89 REMOVED REFERENCES TO LENGTH_CHECK. + -- THS 09/18/90 MADE CALLS TO IDENT_INT TO DEFEAT OPTIMIZATION. + -- JRL 10/13/96 Adjusted ranges in type definitions to allow 1's + -- complement machines to represent all values in + -- the specified number of bits. + + WITH REPORT; USE REPORT; + WITH SYSTEM; + PROCEDURE CD4051D IS + + TYPE INT IS RANGE -3 .. 3; + TYPE LARGE_INT IS RANGE -7 .. 7; + + TYPE BASIC_CLAUSE (DISC : BOOLEAN) IS RECORD + BOOL_COMP : BOOLEAN; + CASE DISC IS + WHEN FALSE => + INT_COMP : LARGE_INT; + WHEN TRUE => + CH_COMP_1 : INT; + CH_COMP_2 : INT; + END CASE; + END RECORD; + + TYPE CHECK_CLAUSE IS NEW BASIC_CLAUSE (TRUE); + + FOR CHECK_CLAUSE USE + RECORD + DISC AT 0 + RANGE 0 .. 0; + BOOL_COMP AT 0 + RANGE 1 .. 1; + INT_COMP AT 0 + RANGE 2 .. 5; + CH_COMP_1 AT 0 + RANGE 2 .. 4; + CH_COMP_2 AT 0 + RANGE 5 .. 7; + END RECORD; + + CHECK_RECORD : CHECK_CLAUSE := (TRUE, TRUE, -2, -2); + + BEGIN + TEST ("CD4051D", "CHECK THAT A RECORD REPRESENTATION " & + "CLAUSE CAN BE GIVEN FOR A DERIVED TYPE " & + "WHOSE PARENT TYPE IS A RECORD TYPE " & + "WITH VARIANTS AND WHERE THE RECORD " & + "REPRESENTATION CLAUSE MENTIONS COMPONENTS " & + "THAT DO NOT EXIST IN THE DERIVED SUBTYPE"); + + IF CHECK_RECORD.DISC'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'LAST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF DISC"); + END IF; + + IF CHECK_RECORD.DISC'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF DISC"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'FIRST_BIT /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'LAST_BIT /= IDENT_INT (1) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.BOOL_COMP'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF BOOL_COMP"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'FIRST_BIT /= IDENT_INT (2) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'LAST_BIT /= IDENT_INT (4) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_1'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_1"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'FIRST_BIT /= IDENT_INT (5) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CH_COMP_2"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'LAST_BIT /= IDENT_INT (7) THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CH_COMP_2"); + END IF; + + IF CHECK_RECORD.CH_COMP_2'POSITION /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CH_COMP_2"); + END IF; + + RESULT; + END CD4051D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- CD5003A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN FOR + -- A PACKAGE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH' + -- CLAUSE IS GIVEN FOR THE SPECIFICATION. + + -- HISTORY: + -- RJW 10/13/88 CREATED ORIGINAL TEST. + -- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY + -- CRITERIA AND N/A ERROR MESSAGES. + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + WITH SYSTEM; + PACKAGE CD5003A_PKG2 IS + PROCEDURE REQUIRE_BODY; + END CD5003A_PKG2; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CD5003A_PKG2 IS + TEST_VAR : INTEGER; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + TEST ("CD5003A", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " & + "NEED NOT BE GIVEN FOR A PACKAGE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE SPECIFICATION"); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + END CD5003A_PKG2; + + WITH REPORT; USE REPORT; + WITH CD5003A_PKG2; USE CD5003A_PKG2; + WITH SPPRT13; + PROCEDURE CD5003A IS + BEGIN + + RESULT; + END CD5003A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CD5003B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN FOR + -- A PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE AS LONG AS A 'WITH' + -- CLAUSE IS GIVEN FOR THE PROCEDURE SPECIFICATION. + + -- HISTORY: + -- VCL 09/04/87 CREATED ORIGINAL TEST. + -- RJW 10/13/88 INITIALIZED THE VARIABLE "CHECK_VAR". + -- BCB 04/18/89 CHANGED EXTENSION TO '.ADA'. REMOVED APPLICABILITY + -- CRITERIA AND N/A ERROR MESSAGES. + + WITH SYSTEM; + PROCEDURE CD5003B; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + PROCEDURE CD5003B IS + TYPE ENUM IS (A0, A1, A2, A3, A4, A5); + + TEST_VAR : ENUM := A0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_ENUM (P : ENUM) RETURN ENUM IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN A0; + END IF; + END IDENT_ENUM; + + BEGIN + TEST ("CD5003B", "CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' " & + "NEED NOT BE GIVEN FOR A PROCEDURE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE PROCEDURE " & + "SPECIFICATION"); + + TEST_VAR := IDENT_ENUM (A3); + + IF TEST_VAR /= A3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END CD5003B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- CD5003C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS + -- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE + -- PACKAGE SPECIFICATION. + + -- HISTORY: + -- VCL 09/04/87 CREATED ORIGINAL TEST. + -- PWB 05/12/89 CHANGED TO ".ADA" TEST. + + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CD5003C IS + PACKAGE CD5003C_PACK2 IS END CD5003C_PACK2; + + PACKAGE BODY CD5003C_PACK2 IS SEPARATE; + + USE CD5003C_PACK2; + BEGIN + RESULT; + END CD5003C; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + SEPARATE (CD5003C) + PACKAGE BODY CD5003C_PACK2 IS + TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER; + + TEST_VAR : ATYPE := (OTHERS => 0); + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN (OTHERS => 0); + END IF; + END IDENT; + BEGIN + TEST ("CD5003C", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A PACKAGE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE PACKAGE SPECIFICATION"); + + + TEST_VAR := IDENT (ATYPE'(OTHERS => 3)); + + IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + END CD5003C_PACK2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CD5003D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS + -- LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING + -- THE PROCEDURE SPECIFICATION. + + -- HISTORY: + -- VCL 09/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + PACKAGE CD5003D_PACK2 IS + PROCEDURE CD5003D_PROC2; + END CD5003D_PACK2; + + WITH SYSTEM; + PACKAGE BODY CD5003D_PACK2 IS + PROCEDURE CD5003D_PROC2 IS SEPARATE; + END CD5003D_PACK2; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + SEPARATE (CD5003D_PACK2) + PROCEDURE CD5003D_PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD := 0.0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIXD; + BEGIN + TEST ("CD5003D", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A PROCEDURE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE PROCEDURE SPECIFICATION"); + + TEST_VAR := IDENT_FIXD (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END CD5003D_PROC2; + + WITH CD5003D_PACK2; USE CD5003D_PACK2; + PROCEDURE CD5003D IS + BEGIN + CD5003D_PROC2; + END CD5003D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD5003E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A TASK BODY SUBUNIT CONTAINING AN ADDRESS CLAUSE AS LONG + -- AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING THE TASK + -- SPECIFICATION. + + -- HISTORY: + -- VCL 09/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + + WITH SYSTEM; + PROCEDURE CD5003E IS + TASK TASK2 IS + ENTRY TST; + END TASK2; + TASK BODY TASK2 IS SEPARATE; + BEGIN + TASK2.TST; + END CD5003E; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + SEPARATE (CD5003E) + TASK BODY TASK2 IS + TEST_VAR : INTEGER := 0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + BEGIN + ACCEPT TST DO + TEST ("CD5003E", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A TASK BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG " & + "AS A 'WITH' CLAUSE IS GIVEN FOR THE " & + "UNIT CONTAINING THE TASK SPECIFICATION"); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END TST; + END TASK2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CD5003F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A GENERIC PACKAGE BODY CONTAINING AN ADDRESS CLAUSE + -- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE GENERIC PACKAGE + -- SPECIFICATION. + + -- HISTORY: + -- VCL 09/09/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + WITH SYSTEM; + GENERIC + PACKAGE CD5003F_PACK2 IS + PROCEDURE REQUIRE_BODY; + END CD5003F_PACK2; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CD5003F_PACK2 IS + TYPE ATYPE IS ARRAY (1 .. 10) OF INTEGER; + + TEST_VAR : ATYPE := (OTHERS => 0); + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT (P : ATYPE) RETURN ATYPE IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN (OTHERS => 0); + END IF; + END IDENT; + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + TEST ("CD5003F", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A GENERIC PACKAGE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE GENERIC " & + "PACKAGE SPECIFICATION"); + + TEST_VAR := IDENT (ATYPE'(OTHERS => 3)); + + IF TEST_VAR /= ATYPE'(OTHERS => 3) THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + END CD5003F_PACK2; + + WITH CD5003F_PACK2; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CD5003F IS + PACKAGE CD5003F_PACK3 IS NEW CD5003F_PACK2; + BEGIN + RESULT; + END CD5003F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CD5003G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A GENERIC PROCEDURE BODY CONTAINING AN ADDRESS CLAUSE + -- AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT CONTAINING + -- THE GENERIC PROCEDURE SPECIFICATION. + + -- HISTORY: + -- VCL 09/09/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; + PACKAGE CD5003G_PACK2 IS + GENERIC + PROCEDURE CD5003G_PROC2; + END CD5003G_PACK2; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + PACKAGE BODY CD5003G_PACK2 IS + PROCEDURE CD5003G_PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD := 0.0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + + FUNCTION IDENT_FIXD (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT_FIXD; + BEGIN + TEST ("CD5003G", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT " & + "BE GIVEN FOR A GENERIC PROCEDURE BODY " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS " & + "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PROCEDURE " & + "SPECIFICATION"); + + TEST_VAR := IDENT_FIXD (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END CD5003G_PROC2; + END CD5003G_PACK2; + + + WITH CD5003G_PACK2; USE CD5003G_PACK2; + PROCEDURE CD5003G IS + PROCEDURE PROC3 IS NEW CD5003G_PROC2; + BEGIN + PROC3; + END CD5003G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003h.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CD5003H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A GENERIC PACKAGE BODY SUBUNIT CONTAINING AN ADDRESS + -- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT + -- CONTAINING THE GENERIC PACKAGE SPECIFICATION. + + -- HISTORY: + -- VCL 09/09/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- PWN 11/30/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + WITH SYSTEM; + PACKAGE CD5003H_PACK3 IS + + PROCEDURE REQUIRE_BODY; + + GENERIC + PACKAGE PACK4 IS END PACK4; + END CD5003H_PACK3; + + PACKAGE BODY CD5003H_PACK3 IS + + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + + PACKAGE BODY PACK4 IS SEPARATE; + END CD5003H_PACK3; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + SEPARATE (CD5003H_PACK3) + PACKAGE BODY PACK4 IS + TEST_VAR : INTEGER := 0; + FOR TEST_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + USE SYSTEM; + BEGIN + TEST ("CD5003H", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A GENERIC PACKAGE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS " & + "A 'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PACKAGE SPECIFICATION."); + + TEST_VAR := IDENT_INT (3); + + IF TEST_VAR /= 3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + END PACK4; + + WITH CD5003H_PACK3; USE CD5003H_PACK3; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CD5003H IS + PACKAGE PACK5 IS NEW PACK4; + BEGIN + RESULT; + END CD5003H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5003i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- CD5003I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE GIVEN + -- FOR A GENERIC PROCEDURE BODY SUBUNIT CONTAINING AN ADDRESS + -- CLAUSE AS LONG AS A 'WITH' CLAUSE IS GIVEN FOR THE UNIT + -- CONTAINING THE GENERIC PROCEDURE SPECIFICATION. + + -- HISTORY: + -- VCL 09/09/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + PACKAGE CD5003I_PACK3 IS + GENERIC + PROCEDURE PROC2; + END CD5003I_PACK3; + + WITH SYSTEM; + PACKAGE BODY CD5003I_PACK3 IS + PROCEDURE PROC2 IS SEPARATE; + END CD5003I_PACK3; + + WITH SPPRT13; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (SPPRT13); + PRAGMA ELABORATE (REPORT); + SEPARATE (CD5003I_PACK3) + PROCEDURE PROC2 IS + TYPE FIXD IS DELTA 0.1 RANGE -10.0 .. 10.0; + + TEST_VAR : FIXD; + FOR TEST_VAR + USE AT SPPRT13.VARIABLE_ADDRESS; + + USE SYSTEM; + + FUNCTION IDENT (P : FIXD) RETURN FIXD IS + BEGIN + IF EQUAL (3, 3) THEN + RETURN P; + ELSE + RETURN 0.0; + END IF; + END IDENT; + BEGIN + TEST ("CD5003I", "A 'WITH' CLAUSE NAMING 'SYSTEM' NEED NOT BE " & + "GIVEN FOR A GENERIC PROCEDURE BODY SUBUNIT " & + "CONTAINING AN ADDRESS CLAUSE AS LONG AS A " & + "'WITH' CLAUSE IS GIVEN FOR THE UNIT " & + "CONTAINING THE GENERIC PROCEDURE SPECIFICATION"); + + TEST_VAR := IDENT (3.3); + + IF TEST_VAR /= 3.3 THEN + FAILED ("INCORRECT VALUE FOR TEST_VAR"); + END IF; + + IF TEST_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR TEST_VAR"); + END IF; + + RESULT; + END PROC2; + + WITH CD5003I_PACK3; USE CD5003I_PACK3; + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PROCEDURE CD5003I IS + PROCEDURE PROC3 IS NEW PROC2; + BEGIN + PROC3; + END CD5003I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CD5011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN + -- ENUMERATION TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + + -- HISTORY: + -- PWB 08/06/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5011A IS + + TYPE ENUM IS (RED, BLUE, 'R', 'B'); + + PROCEDURE MIX IS + HUE : ENUM := RED; + FOR HUE USE + AT SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + HUE := BLUE; + END IF; + IF HUE /= BLUE THEN + FAILED ("WRONG VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + END MIX; + + FUNCTION FIX RETURN BOOLEAN IS + LETTER : ENUM := 'R'; + FOR LETTER USE AT + SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + LETTER := 'B'; + END IF; + IF LETTER /= ENUM'LAST THEN + FAILED ("WRONG VALUE FOR VARIABLE IN FUNCTION"); + END IF; + IF LETTER'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN FUNCTION"); + END IF; + RETURN EQUAL(3,3); + END FIX; + + BEGIN + + TEST ("CD5011A", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ENUMERATION " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM."); + + IF NOT FIX THEN + FAILED ("FUNCTION FIX YIELDS WRONG VALUE"); + END IF; + + MIX; + RESULT; + + END CD5011A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- CD5011C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF + -- AN INTEGER TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY. + + -- HISTORY: + -- JET 09/11/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011C IS + + PACKAGE CD5011C_PACKAGE IS + END CD5011C_PACKAGE; + + PACKAGE BODY CD5011C_PACKAGE IS + + INT : INTEGER := 0; + FOR INT USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST ("CD5011C", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN INTEGER " & + "TYPE IN THE DECLARATIVE PART OF A " & + "PACKAGE BODY"); + + IF EQUAL (3, 3) THEN + INT := 5; + END IF; + IF INT /= IDENT_INT (5) THEN + FAILED ("WRONG VALUE FOR VARIABLE IN PACKAGE"); + END IF; + IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE"); + END IF; + END; + + BEGIN + + RESULT; + + END CD5011C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CD5011E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- FLOATING POINT TYPE IN THE DECLARATIVE PART OF A BLOCK + -- STATEMENT. + + -- HISTORY: + -- JET 09/11/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011E IS + + BEGIN + + TEST ("CD5011E", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A FLOATING POINT " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + FP : FLOAT := 3.0; + FOR FP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + FP := 2.0; + END IF; + + IF FP /= 2.0 THEN + FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK"); + END IF; + + IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK"); + END IF; + + END; + + RESULT; + + END CD5011E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- CD5011G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- FIXED POINT TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + + -- HISTORY: + -- JET 09/11/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011G IS + + TYPE FIX_TYPE IS DELTA 0.125 RANGE 0.0 .. 10.0; + + PROCEDURE CD5011G_PROC IS + + FP : FIX_TYPE := 2.0; + FOR FP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + FP := 3.0; + END IF; + + IF FP /= 3.0 THEN + FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + + IF FP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + + END CD5011G_PROC; + + BEGIN + TEST ("CD5011G", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A FIXED POINT " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM"); + + CD5011G_PROC; + + RESULT; + + END CD5011G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- CD5011I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF + -- AN ARRAY TYPE IN THE DECLARATIVE PART OF A PACKAGE BODY. + + -- HISTORY: + -- JET 09/11/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011I IS + + PACKAGE CD5011I_PACKAGE IS + END CD5011I_PACKAGE; + + PACKAGE BODY CD5011I_PACKAGE IS + + INT : ARRAY (1 .. 10) OF INTEGER; + FOR INT USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST ("CD5011I", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ARRAY " & + "TYPE IN THE DECLARATIVE PART OF A " & + "PACKAGE BODY"); + + FOR I IN INT'RANGE LOOP + INT (I) := IDENT_INT (I); + END LOOP; + + FOR I IN INT'RANGE LOOP + IF INT (I) /= I THEN + FAILED ("WRONG VALUE FOR ELEMENT" & + INTEGER'IMAGE (I)); + END IF; + END LOOP; + + IF INT'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN PACKAGE"); + END IF; + END; + + BEGIN + + RESULT; + + END CD5011I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011k.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- CD5011K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- RECORD TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT. + + -- HISTORY: + -- JET 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011K IS + + BEGIN + + TEST ("CD5011K", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A RECORD " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + TYPE REC_TYPE IS RECORD + I : INTEGER := 12; + B : BOOLEAN := TRUE; + END RECORD; + + REC : REC_TYPE; + FOR REC USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + REC.I := 17; + REC.B := FALSE; + END IF; + + IF REC.I /= 17 OR REC.B THEN + FAILED ("WRONG VALUE FOR VARIABLE IN BLOCK"); + END IF; + + IF REC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE IN BLOCK"); + END IF; + + END; + + RESULT; + + END CD5011K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011m.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- CD5011M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF + -- AN ACCESS TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + + -- HISTORY: + -- JET 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011M IS + + TYPE ACC_TYPE IS ACCESS STRING; + + PROCEDURE CD5011M_PROC IS + + ACC : ACC_TYPE := NEW STRING'("THE QUICK BROWN FOX"); + FOR ACC USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + ACC := NEW STRING'("THE LAZY DOG"); + END IF; + + IF ACC.ALL /= IDENT_STR ("THE LAZY DOG") THEN + FAILED ("INCORRECT VALUE FOR VARIABLE IN PROCEDURE"); + END IF; + + IF ACC'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE IN PROCEDURE"); + END IF; + + END CD5011M_PROC; + + BEGIN + TEST ("CD5011M", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ACCESS " & + "TYPE IN THE DECLARATIVE PART OF A " & + "SUBPROGRAM"); + + CD5011M_PROC; + + RESULT; + + END CD5011M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011q.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CD5011Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- PRIVATE TYPE IN THE DECLARATIVE PART OF A BLOCK STATEMENT. + + -- HISTORY: + -- JET 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011Q IS + + PACKAGE P IS + TYPE PRIV_TYPE IS PRIVATE; + FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE; + FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN; + PRIVATE + TYPE PRIV_TYPE IS NEW INTEGER; + END P; + + PACKAGE BODY P IS + + FUNCTION INT_TO_PRIV (I : INTEGER) RETURN PRIV_TYPE IS + BEGIN + RETURN PRIV_TYPE(I); + END; + + FUNCTION EQUAL (P : PRIV_TYPE; I : INTEGER) RETURN BOOLEAN IS + BEGIN + RETURN (P = PRIV_TYPE(I)); + END; + + END P; + + USE P; + + BEGIN + + TEST ("CD5011Q", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A PRIVATE " & + "TYPE IN THE DECLARATIVE PART OF A " & + "BLOCK STATEMENT"); + + DECLARE + + PRIV : PRIV_TYPE := INT_TO_PRIV (12); + FOR PRIV USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + PRIV := INT_TO_PRIV (17); + + IF NOT EQUAL (PRIV, IDENT_INT (17)) THEN + FAILED ("INCORRECT VALUE FOR VARIABLE OF PRIVATE TYPE"); + END IF; + + IF PRIV'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR VARIABLE OF " & + "PRIVATE TYPE"); + END IF; + END; + + RESULT; + + END CD5011Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5011s.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CD5011S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A SUBPROGRAM. + + -- HISTORY: + -- JET 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + + PROCEDURE CD5011S IS + + PACKAGE P IS + TYPE LIMP_TYPE IS LIMITED PRIVATE; + PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE); + PRIVATE + TYPE LIMP_TYPE IS ARRAY (1 .. 10) OF INTEGER; + END P; + + PACKAGE BODY P IS + PROCEDURE TEST_LIMP (LIMP : IN OUT LIMP_TYPE) IS + BEGIN + FOR I IN LIMP'RANGE LOOP + LIMP (I) := IDENT_INT (I); + END LOOP; + + FOR I IN LIMP'RANGE LOOP + IF LIMP (I) /= I THEN + FAILED ("INCORRECT VALUE FOR ELEMENT" & + INTEGER'IMAGE (I)); + END IF; + END LOOP; + END TEST_LIMP; + END P; + + USE P; + + PROCEDURE CD5011S_PROC IS + + LIMP : LIMP_TYPE; + FOR LIMP USE + AT SPPRT13.VARIABLE_ADDRESS; + + BEGIN + TEST_LIMP (LIMP); + + IF LIMP'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE OF A LIMITED " & + "PRIVATE TYPE"); + END IF; + END; + + BEGIN + TEST ("CD5011S", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A LIMITED " & + "PRIVATE TYPE IN THE DECLARATIVE PART " & + "OF A SUBPROGRAM"); + + CD5011S_PROC; + + RESULT; + + END CD5011S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CD5012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN + -- ENUMERATION TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM. + + -- HISTORY: + -- DHH 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012A IS + + BEGIN + + TEST ("CD5012A", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ENUMERATION " & + "TYPE IN THE DECLARATIVE PART OF A " & + "GENERIC SUBPROGRAM"); + + DECLARE + TYPE NON_CHAR IS (RED, BLUE, GREEN); + + COLOR : NON_CHAR; + TEST_VAR : ADDRESS := COLOR'ADDRESS; + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + HUE : NON_CHAR := GREEN; + FOR HUE USE AT + SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + HUE := RED; + END IF; + IF HUE /= RED THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "GENERIC PROCEDURE"); + END IF; + IF HUE'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN GENERIC PROCEDURE"); + END IF; + END GENPROC; + + PROCEDURE PROC IS NEW GENPROC; + BEGIN + PROC; + END; + RESULT; + END CD5012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CD5012B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN + -- INTEGER TYPE IN THE DECLARATIVE PART OF A GENERIC PACKAGE BODY. + + -- HISTORY: + -- DHH 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012B IS + + BEGIN + + TEST ("CD5012B", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN INTEGER " & + "TYPE IN THE DECLARATIVE PART OF A " & + "GENERIC PACKAGE BODY"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + END GENPACK; + + PACKAGE BODY GENPACK IS + + INT2 : INTEGER :=2; + + FOR INT2 USE AT + SPPRT13.VARIABLE_ADDRESS; + + BEGIN + IF EQUAL (3, 3) THEN + INT2 := 1; + END IF; + IF INT2 /= 1 THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PACKAGE BODY"); + END IF; + IF INT2'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PACKAGE BODY"); + END IF; + END GENPACK; + + PACKAGE PACK IS NEW GENPACK; + BEGIN + NULL; + END; + RESULT; + END CD5012B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD5012E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- FIXED POINT TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM. + + -- HISTORY: + -- DHH 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012E IS + + BEGIN + + TEST ("CD5012E", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A FIXED POINT " & + "TYPE IN THE DECLARATIVE PART OF A " & + "GENERIC SUBPROGRAM"); + + DECLARE + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0; + + TESTFIX : FIXED := 0.0; + FOR TESTFIX USE AT SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF EQUAL (3, 3) THEN + TESTFIX := 1.0; + END IF; + IF TESTFIX /= 1.0 THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PROCEDURE"); + END IF; + IF TESTFIX'ADDRESS /= + SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PROCEDURE"); + END IF; + END GENPROC; + + PROCEDURE PROC IS NEW GENPROC; + BEGIN + PROC; + END; + RESULT; + END CD5012E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012f.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CD5012F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN + -- ARRAY TYPE IN THE DECLARATIVE PART OF A GENERIC + -- PACKAGE BODY. + + -- HISTORY: + -- DHH 09/17/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012F IS + + BEGIN + + TEST ("CD5012F", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ARRAY " & + "TYPE IN THE DECLARATIVE " & + "PART OF A GENERIC PACKAGE BODY"); + + DECLARE + + GENERIC + PACKAGE GENPACK IS + + END GENPACK; + + PACKAGE BODY GENPACK IS + ARRAY_VAR : ARRAY (0..4) OF INTEGER := (0,1,2,3,4); + + FOR ARRAY_VAR USE AT SPPRT13.VARIABLE_ADDRESS; + + + BEGIN + IF EQUAL (3, 3) THEN + ARRAY_VAR := (4,3,2,1,0); + END IF; + IF ARRAY_VAR /= (4,3,2,1,0) THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PACKAGE BODY"); + END IF; + IF ARRAY_VAR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PACKAGE BODY"); + END IF; + END GENPACK; + + PACKAGE PACK IS NEW GENPACK; + BEGIN + NULL; + END; + RESULT; + END CD5012F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CD5012I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF AN + -- ACCESS TYPE IN THE DECLARATIVE PART OF A GENERIC SUBPROGRAM. + + -- HISTORY: + -- DHH 09/17/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012I IS + + BEGIN + + TEST ("CD5012I", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF AN ACCESS " & + "TYPE IN THE DECLARATIVE PART OF A " & + "GENERIC SUBPROGRAM"); + + DECLARE + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + TYPE CELL; + TYPE POINTER IS ACCESS CELL; + TYPE CELL IS + RECORD + VALUE : INTEGER; + NEXT : POINTER; + END RECORD; + + C,PTR : POINTER := NULL; + + FOR PTR USE AT + SPPRT13.VARIABLE_ADDRESS; + BEGIN + PTR := NEW CELL'(0,NULL); + C := PTR; + + IF EQUAL (3, 3) THEN + PTR.VALUE := 1; + PTR.NEXT := C; + END IF; + IF PTR.ALL /= (1,C) THEN + FAILED ("WRONG VALUE FOR VARIABLE IN " & + "A GENERIC PROCEDURE"); + END IF; + IF PTR'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR VARIABLE " & + "IN A GENERIC PROCEDURE"); + END IF; + END GENPROC; + + PROCEDURE PROC IS NEW GENPROC; + BEGIN + PROC; + END; + RESULT; + END CD5012I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5012m.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CD5012M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN FOR A VARIABLE OF A + -- LIMITED PRIVATE TYPE IN THE DECLARATIVE PART OF A GENERIC + -- SUBPROGRAM. + + -- HISTORY: + -- DHH 09/15/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH REPORT; USE REPORT; + WITH SPPRT13; + PROCEDURE CD5012M IS + + BEGIN + + TEST ("CD5012M", "AN ADDRESS CLAUSE CAN BE " & + "GIVEN FOR A VARIABLE OF A LIMITED " & + "PRIVATE TYPE IN THE DECLARATIVE " & + "PART OF A GENERIC SUBPROGRAM"); + + DECLARE + + PACKAGE P IS + TYPE FIXED IS LIMITED PRIVATE; + + PRIVATE + TYPE FIXED IS DELTA 2.0**(-4) RANGE -10.0..10.0; + END P; + + USE P; + + GENERIC + PROCEDURE GENPROC; + + PROCEDURE GENPROC IS + + TESTFIX : FIXED; + + FOR TESTFIX USE AT + SPPRT13.VARIABLE_ADDRESS; + BEGIN + IF TESTFIX'ADDRESS /= SPPRT13.VARIABLE_ADDRESS THEN + FAILED ("WRONG ADDRESS FOR LIMITED PRIVATE " & + "TYPE VARIABLE IN GENERIC PROCEDURE"); + END IF; + END GENPROC; + + PROCEDURE PROC IS NEW GENPROC; + BEGIN + PROC; + END; + RESULT; + END CD5012M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- CD5013A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ENUMERATION TYPE, + -- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013A IS + + TYPE ENUM_TYPE IS (ONE,TWO,THREE,FOUR,FIVE,SIX); + + PACKAGE PACK IS + CHECK_TYPE : ENUM_TYPE; + FOR CHECK_TYPE USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013A", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ENUMERATION TYPE, WHERE " & + "THE VARIABLE IS DECLARED IN THE VISIBLE PART " & + "OF THE SPECIFICATION"); + + CHECK_TYPE := ONE; + IF EQUAL(3,3) THEN + CHECK_TYPE := THREE; + END IF; + + IF CHECK_TYPE /= THREE THEN + FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE"); + END IF; + + IF CHECK_TYPE'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE"); + END IF; + + RESULT; + END CD5013A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- CD5013C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER TYPE, WHERE + -- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013C IS + + TYPE INT_TYPE IS RANGE INTEGER'FIRST .. INTEGER'LAST; + + PACKAGE PACK IS + CHECK_VAR : INT_TYPE; + PRIVATE + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013C", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE PRIVATE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN INTEGER TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := 100; + IF EQUAL(3,3) THEN + CHECK_VAR := 10; + END IF; + + IF CHECK_VAR /= 10 THEN + FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE"); + END IF; + + RESULT; + END CD5013C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- CD5013E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING POINT TYPE, + -- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013E IS + + TYPE FLT_TYPE IS DIGITS 5 RANGE -1.0 .. 1.0; + + PACKAGE PACK IS + CHECK_VAR : FLT_TYPE; + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013E", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF A FLOATING POINT TYPE, " & + "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " & + "PART OF THE SPECIFICATION"); + + CHECK_VAR := 0.5; + IF EQUAL(3,3) THEN + CHECK_VAR := 0.0; + END IF; + + IF CHECK_VAR /= 0.0 THEN + FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE"); + END IF; + + RESULT; + END CD5013E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- CD5013G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED POINT TYPE, + -- WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013G IS + + TYPE FIX_TYPE IS DELTA 0.5 RANGE -7.5 .. 7.5; + + PACKAGE PACK IS + CHECK_VAR : FIX_TYPE; + PRIVATE + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013G", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE PRIVATE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF A FIXED POINT TYPE, " & + "WHERE THE VARIABLE IS DECLARED IN THE VISIBLE " & + "PART OF THE SPECIFICATION"); + + CHECK_VAR := 1.5; + IF EQUAL(3,3) THEN + CHECK_VAR := 5.0; + END IF; + + IF CHECK_VAR /= 5.0 THEN + FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE"); + END IF; + + RESULT; + END CD5013G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- CD5013I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY TYPE, WHERE + -- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013I IS + + TYPE ARR_TYPE IS ARRAY(1..5) OF INTEGER; + + PACKAGE PACK IS + CHECK_VAR : ARR_TYPE; + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013I", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ARRAY TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := (1,2,3,4,5); + IF EQUAL(3,3) THEN + CHECK_VAR := (5,4,3,2,1); + END IF; + + IF CHECK_VAR /= (5,4,3,2,1) THEN + FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE"); + END IF; + + RESULT; + END CD5013I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013k.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + -- CD5013K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD TYPE, WHERE + -- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013K IS + + TYPE REC_TYPE IS RECORD + BOOL : BOOLEAN; + INT : INTEGER; + END RECORD; + + PACKAGE PACK IS + CHECK_VAR : REC_TYPE; + PRIVATE + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + PACKAGE BODY PACK IS + BEGIN + TEST ("CD5013K", "AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A RECORD " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN " & + "THE VISIBLE PART OF THE SPECIFICATION"); + + CHECK_VAR := (TRUE, IDENT_INT(5)); + IF EQUAL(3,3) THEN + CHECK_VAR := (FALSE, IDENT_INT(10)); + END IF; + + IF CHECK_VAR /= (FALSE, IDENT_INT (10)) THEN + FAILED ("INCORRECT VALUE FOR RECORD VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE"); + END IF; + END PACK; + + BEGIN + + RESULT; + END CD5013K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013m.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + -- CD5013M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS TYPE, WHERE + -- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013M IS + + TYPE ACC_TYPE IS ACCESS INTEGER; + + PACKAGE PACK IS + CHECK_VAR : ACC_TYPE; + FOR CHECK_VAR USE + AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + BEGIN + + TEST ("CD5013M", "AN ADDRESS CLAUSE CAN BE GIVEN IN " & + "THE VISIBLE PART OF A PACKAGE SPECIFICATION " & + "FOR A VARIABLE OF AN ACCESS TYPE, WHERE THE " & + "VARIABLE IS DECLARED IN THE VISIBLE PART OF " & + "THE SPECIFICATION"); + + CHECK_VAR := NEW INTEGER'(100); + IF EQUAL(3,3) THEN + CHECK_VAR := NEW INTEGER'(25); + END IF; + + IF CHECK_VAR.ALL /= 25 THEN + FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE"); + END IF; + + RESULT; + END CD5013M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5013o.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CD5013O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART OF + -- A PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE TYPE, WHERE + -- THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + -- HISTORY: + -- BCB 09/16/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH REPORT; USE REPORT; + WITH SPPRT13; USE SPPRT13; + WITH SYSTEM; USE SYSTEM; + + PROCEDURE CD5013O IS + + PACKAGE P1 IS + END P1; + + PACKAGE PACK IS + TYPE F IS PRIVATE; + PRIVATE + TYPE F IS NEW INTEGER; + CHECK_VAR : F; + FOR CHECK_VAR USE AT VARIABLE_ADDRESS; + END PACK; + + USE PACK; + + PACKAGE BODY P1 IS + BEGIN + TEST ("CD5013O", "AN ADDRESS CLAUSE CAN BE GIVEN" & + " IN THE PRIVATE PART OF A PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A " & + "PRIVATE TYPE, WHERE THE VARIABLE IS " & + "DECLARED IN THE VISIBLE PART OF THE " & + "SPECIFICATION"); + END P1; + + PACKAGE BODY PACK IS + BEGIN + CHECK_VAR := 100; + IF EQUAL(3,3) THEN + CHECK_VAR := 25; + END IF; + + IF CHECK_VAR /= 25 THEN + FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE"); + END IF; + + IF CHECK_VAR'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE"); + END IF; + END PACK; + + BEGIN + + RESULT; + END CD5013O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD5014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN + -- ENUMERATION TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE + -- PART OF THE SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014A IS + + BEGIN + + TEST ("CD5014A", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF AN " & + "ENUMERATION TYPE, WHERE THE VARIABLE IS " & + "DECLARED IN THE VISIBLE PART OF THE " & + "SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE ENUM_TYPE IS (RED,BLUE,GREEN); + ENUM_OBJ1 : ENUM_TYPE := RED; + FOR ENUM_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + ENUM_OBJ1 := BLUE; + END IF; + + IF ENUM_OBJ1 /= BLUE THEN + FAILED ("INCORRECT VALUE FOR ENUMERATION VARIABLE"); + END IF; + + IF ENUM_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ENUMERATION VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD5014C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN INTEGER + -- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014C IS + + BEGIN + + TEST ("CD5014C", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF AN INTEGER " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " & + "VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE INTEGER_TYPE IS RANGE 0 .. 100; + INTEGER_OBJ1 : INTEGER_TYPE := 50; + PRIVATE + FOR INTEGER_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + INTEGER_OBJ1 := 7; + END IF; + + IF INTEGER_OBJ1 /= 7 THEN + FAILED ("INCORRECT VALUE FOR INTEGER VARIABLE"); + END IF; + + IF INTEGER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR INTEGER VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD5014E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FLOATING + -- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART + -- OF THE SPECIFICATION. + + + -- HISTORY: + -- CDJ 08/19/87 CREATED ORIGINAL TEST. + -- BCB 09/30/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014E IS + + BEGIN + + TEST ("CD5014E", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FLOATING " & + "POINT TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE FLOAT_TYPE IS DIGITS SYSTEM.MAX_DIGITS + RANGE 0.0 .. 100.0; + FLOAT_OBJ1 : FLOAT_TYPE := 50.0; + FOR FLOAT_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + FLOAT_OBJ1 := 5.0; + END IF; + + IF FLOAT_OBJ1 /= 5.0 THEN + FAILED ("INCORRECT VALUE FOR FLOATING POINT VARIABLE"); + END IF; + + IF FLOAT_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FLOATING POINT VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014g.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CD5014G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FIXED + -- POINT TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF + -- THE SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014G IS + + BEGIN + + TEST ("CD5014G", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FIXED " & + "POINT TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE FIXED_TYPE IS DELTA 0.5 RANGE 0.0 .. 100.0; + FIXED_OBJ1 : FIXED_TYPE := 50.0; + PRIVATE + FOR FIXED_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + FIXED_OBJ1 := 5.0; + END IF; + + IF FIXED_OBJ1 /= 5.0 THEN + FAILED ("INCORRECT VALUE FOR FIXED POINT VARIABLE"); + END IF; + + IF FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FIXED POINT VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014i.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CD5014I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ARRAY + -- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014I IS + + BEGIN + + TEST ("CD5014I", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF AN ARRAY " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " & + "VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE ARR_TYPE IS ARRAY (1..2) OF INTEGER; + ARR_OBJ1 : ARR_TYPE := (5,10); + FOR ARR_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + ARR_OBJ1 := (13,21); + END IF; + + IF ARR_OBJ1 /= (13,21) THEN + FAILED ("INCORRECT VALUE FOR ARRAY VARIABLE"); + END IF; + + IF ARR_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ARRAY VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014k.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CD5014K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A RECORD + -- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014K IS + + BEGIN + + TEST ("CD5014K", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A RECORD " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " & + "VISIBLE PART OF THE SPECIFICATION"); + + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE REC_TYPE IS RECORD + VAL : INTEGER; + END RECORD; + REC_OBJ1 : REC_TYPE := (VAL => 10); + PRIVATE + FOR REC_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + REC_OBJ1.VAL := 100; + END IF; + + IF REC_OBJ1.VAL /= 100 THEN + FAILED ("INCORRECT VALUE FOR RECORD VARIABLE COMPONENT"); + END IF; + + IF REC_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR RECORD VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014m.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CD5014M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF AN ACCESS + -- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF + -- THE SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014M IS + + BEGIN + + TEST ("CD5014M", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF AN ACCESS " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " & + "VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE ACCESS_TYPE; + TYPE POINTER_TYPE IS ACCESS ACCESS_TYPE; + TYPE ACCESS_TYPE IS RECORD + VAL1 : INTEGER; + NEXT : POINTER_TYPE; + END RECORD; + POINTER_OBJ1 : POINTER_TYPE := NEW ACCESS_TYPE'(0,NULL); + FOR POINTER_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + POINTER_OBJ1 := NEW ACCESS_TYPE'(10,NULL); + END IF; + + IF POINTER_OBJ1.ALL /= (10,NULL) THEN + FAILED ("INCORRECT VALUE FOR ACCESS VARIABLE"); + END IF; + + IF POINTER_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR ACCESS VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014o.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CD5014O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A PRIVATE + -- TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART OF THE + -- SPECIFICATION. + + + -- HISTORY: + -- CDJ 07/24/87 CREATED ORIGINAL TEST. + -- BCB 10/01/87 CHANGED TEST TO STANDARD FORMAT. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + -- MCH 04/03/90 ADDED INSTANTIATION. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014O IS + + BEGIN + + TEST ("CD5014O", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A PRIVATE " & + "TYPE, WHERE THE VARIABLE IS DECLARED IN THE " & + "VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + PACKAGE PKG IS + TYPE PRIVATE_TYPE IS PRIVATE; + PRIVATE + TYPE PRIVATE_TYPE IS RANGE 1 .. 20; + PRIVATE_OBJ1 : PRIVATE_TYPE := 5; + FOR PRIVATE_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + PRIVATE_OBJ1 := 9; + END IF; + + IF PRIVATE_OBJ1 /= 9 THEN + FAILED ("INCORRECT VALUE FOR PRIVATE VARIABLE"); + END IF; + + IF PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR PRIVATE VARIABLE"); + END IF; + END PKG; + + PACKAGE INSTANTIATE IS NEW PKG; + + BEGIN + NULL; + END; + + RESULT; + END CD5014O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014t.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + -- CD5014T.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL + -- DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART + -- OF THE SPECIFICATION. + + + -- HISTORY: + -- BCB 10/08/87 CREATED ORIGINAL TEST. + + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014T IS + + BEGIN + + TEST ("CD5014T", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "DISCRETE TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + TYPE FORM_DISCRETE_TYPE IS (<>); + PACKAGE PKG IS + FORM_DISCRETE_OBJ1 : FORM_DISCRETE_TYPE := + FORM_DISCRETE_TYPE'FIRST; + PRIVATE + FOR FORM_DISCRETE_OBJ1 USE + AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + + IF EQUAL(3,3) THEN + FORM_DISCRETE_OBJ1 := FORM_DISCRETE_TYPE'LAST; + END IF; + + IF FORM_DISCRETE_OBJ1 /= FORM_DISCRETE_TYPE'LAST THEN + FAILED ("INCORRECT VALUE FOR FORMAL DISCRETE VARIABLE"); + END IF; + + IF FORM_DISCRETE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL DISCRETE " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_DISCRETE_TYPE => INTEGER); + + BEGIN + NULL; + END; + + RESULT; + END CD5014T; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014v.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CD5014V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL + -- FIXED TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART + -- OF THE SPECIFICATION. + + + -- HISTORY: + -- BCB 10/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014V IS + + BEGIN + + TEST ("CD5014V", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "FIXED TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + TYPE FIX IS DELTA 0.5 RANGE -30.00 .. 30.00; + + GENERIC + TYPE FORM_FIXED_TYPE IS DELTA <>; + PACKAGE PKG IS + FORM_FIXED_OBJ1 : FORM_FIXED_TYPE := 5.0; + FOR FORM_FIXED_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF EQUAL(3,3) THEN + FORM_FIXED_OBJ1 := 20.0; + END IF; + + IF FORM_FIXED_OBJ1 /= 20.0 THEN + FAILED ("INCORRECT VALUE FOR FORMAL FIXED VARIABLE"); + END IF; + + IF FORM_FIXED_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL FIXED " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_FIXED_TYPE => FIX); + + BEGIN + NULL; + END; + + RESULT; + END CD5014V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014x.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CD5014X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL + -- ARRAY TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART + -- OF THE SPECIFICATION. + + -- HISTORY: + -- BCB 10/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CD5014X IS + + BEGIN + + TEST ("CD5014X", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "ARRAY TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + TYPE COLOR IS (RED,BLUE,GREEN); + TYPE COLOR_TABLE IS ARRAY (COLOR) OF INTEGER; + + GENERIC + TYPE INDEX IS (<>); + TYPE FORM_ARRAY_TYPE IS ARRAY (INDEX) OF INTEGER; + PACKAGE PKG IS + FORM_ARRAY_OBJ1 : FORM_ARRAY_TYPE := (1,2,3); + PRIVATE + FOR FORM_ARRAY_OBJ1 USE AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + + IF EQUAL(3,3) THEN + FORM_ARRAY_OBJ1 := (10,20,30); + END IF; + + IF FORM_ARRAY_OBJ1 /= (10,20,30) THEN + FAILED ("INCORRECT VALUE FOR FORMAL ARRAY VARIABLE"); + END IF; + + IF FORM_ARRAY_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL ARRAY " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(INDEX => COLOR, + FORM_ARRAY_TYPE => COLOR_TABLE); + + BEGIN + NULL; + END; + + RESULT; + END CD5014X; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014y.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- CD5014Y.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE VISIBLE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL + -- PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE VISIBLE PART + -- OF THE SPECIFICATION. + + -- HISTORY: + -- BCB 10/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014Y IS + + BEGIN + + TEST ("CD5014Y", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE VISIBLE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED " & + "IN THE VISIBLE PART OF THE SPECIFICATION"); + + DECLARE + + GENERIC + TYPE FORM_PRIVATE_TYPE IS PRIVATE; + PACKAGE PKG IS + FORM_PRIVATE_OBJ1 : FORM_PRIVATE_TYPE; + FOR FORM_PRIVATE_OBJ1 USE + AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF FORM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL PRIVATE " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_PRIVATE_TYPE => INTEGER); + + BEGIN + NULL; + END; + + RESULT; + END CD5014Y; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd5014z.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CD5014Z.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN ADDRESS CLAUSE CAN BE GIVEN IN THE PRIVATE PART + -- OF A GENERIC PACKAGE SPECIFICATION FOR A VARIABLE OF A FORMAL + -- LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS DECLARED IN THE + -- VISIBLE PART OF THE SPECIFICATION. + + -- HISTORY: + -- BCB 10/08/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; USE SYSTEM; + WITH SPPRT13; USE SPPRT13; + WITH REPORT; USE REPORT; + + PROCEDURE CD5014Z IS + + BEGIN + + TEST ("CD5014Z", " AN ADDRESS CLAUSE CAN BE GIVEN " & + "IN THE PRIVATE PART OF A GENERIC PACKAGE " & + "SPECIFICATION FOR A VARIABLE OF A FORMAL " & + "LIMITED PRIVATE TYPE, WHERE THE VARIABLE IS " & + "DECLARED IN THE VISIBLE PART OF THE " & + "SPECIFICATION"); + + DECLARE + + GENERIC + TYPE FORM_LIM_PRIVATE_TYPE IS LIMITED PRIVATE; + PACKAGE PKG IS + FORM_LIM_PRIVATE_OBJ1 : FORM_LIM_PRIVATE_TYPE; + PRIVATE + FOR FORM_LIM_PRIVATE_OBJ1 USE + AT VARIABLE_ADDRESS; + END PKG; + + PACKAGE BODY PKG IS + BEGIN + IF FORM_LIM_PRIVATE_OBJ1'ADDRESS /= VARIABLE_ADDRESS THEN + FAILED ("INCORRECT ADDRESS FOR FORMAL LIMITED PRIVATE " & + "VARIABLE"); + END IF; + END PKG; + + PACKAGE PACK IS NEW PKG(FORM_LIM_PRIVATE_TYPE => INTEGER); + + BEGIN + NULL; + END; + + RESULT; + END CD5014Z; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd70001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd70001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd70001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd70001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,201 ---- + -- + -- CD70001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that package System includes Max_Base_Digits, Address, + -- Null_Address, Word_Size, functions "<", "<=", ">", ">=", "=" + -- (with Address parameters and Boolean results), Bit_Order, + -- Default_Bit_Order, Any_Priority, Interrupt_Priority, + -- and Default_Priority. + -- + -- Check that package System.Storage_Elements includes all required + -- types and operations. + -- + -- TEST DESCRIPTION: + -- The test checks for the existence of the names additional + -- to package system above those names tested for in 9Xbasic. + -- + -- This test checks that the semantics provided in Storage_Elements + -- are present and operate marginally within expectations (to the best + -- extent possible in a portable implementation independent fashion). + -- + -- + -- CHANGE HISTORY: + -- 09 MAY 95 SAIC Initial version + -- 27 JAN 96 SAIC Revised for 2.1; Allow negative address delta + -- + --! + + with Report; + with Ada.Text_IO; + with System.Storage_Elements; + with System.Address_To_Access_Conversions; + procedure CD70001 is + use System; + + procedure CD70 is + + type Int_Max is range Min_Int .. Max_Int; + + My_Int : Int_Max := System.Max_Base_Digits + System.Word_Size; + + An_Address : Address; + An_Other_Address : Address := An_Address'Address; + + begin -- 7.0 + + + if Default_Bit_Order not in High_Order_First..Low_Order_First then + Report.Failed ("Default_Bit_Order invalid"); + end if; + + if Bit_Order'Pos(High_Order_First) /= 0 then + Report.Failed ("Bit_Order'Pos(High_Order_First) /= 0"); + end if; + + if Bit_Order'Pos(Low_Order_First) /= 1 then + Report.Failed ("Bit_Order'Pos(Low_Order_First) /= 1"); + end if; + + An_Address := My_Int'Address; + + if An_Address = Null_Address then + Report.Failed ("Null_Address matched a real address"); + end if; + + + if An_Address'Address /= An_Other_Address then + Report.Failed("Value set at elaboration not equal to itself"); + end if; + + if An_Address'Address > An_Other_Address + and An_Address'Address < An_Other_Address then + Report.Failed("Address is both greater and less!"); + end if; + + if not (An_Address'Address >= An_Other_Address + and An_Address'Address <= An_Other_Address) then + Report.Failed("Address comparisons wrong"); + end if; + + + if Priority'First /= Any_Priority'First then + Report.Failed ("Priority'First /= Any_Priority'First"); + end if; + + if Interrupt_Priority'First /= Priority'Last+1 then + Report.Failed ("Interrupt_Priority'First /= Priority'Last+1"); + end if; + + if Interrupt_Priority'Last /= Any_Priority'Last then + Report.Failed ("Interrupt_Priority'Last /= Any_Priority'Last"); + end if; + + if Default_Priority /= ((Priority'First + Priority'Last)/2) then + Report.Failed ("Default_Priority wrong value"); + end if; + + end CD70; + + procedure CD71 is + use System.Storage_Elements; + + Storehouse_1 : Storage_Array(0..127); + Storehouse_2 : Storage_Array(0..127); + + House_Offset : Storage_Offset; + + begin -- 7.1 + + + if Storage_Count'First /= 0 then + Report.Failed ("Storage_Count'First /= 0"); + end if; + + if Storage_Count'Last /= Storage_Offset'Last then + Report.Failed ("Storage_Count'Last /= Storage_Offset'Last"); + end if; + + + if Storage_Element'Size /= Storage_Unit then + Report.Failed ("Storage_Element'Size /= Storage_Unit"); + end if; + + if Storage_Array'Component_Size /= Storage_Unit then + Report.Failed ("Storage_Array'Element_Size /= Storage_Unit"); + end if; + + if Storage_Element'Last+1 /= 0 then + Report.Failed ("Storage_Element not modular"); + end if; + + + -- "+", "-"( Address, Storage_Offset) and inverse + + House_Offset := Storehouse_2'Address - Storehouse_1'Address; + -- Address - Address = Offset + -- Note that House_Offset may be a negative value + + if House_Offset + Storehouse_1'Address /= Storehouse_2'Address then + -- Offset + Address = Address + Report.Failed ("Storage arithmetic non-linear O+A"); + end if; + + if Storehouse_1'Address + House_Offset /= Storehouse_2'Address then + -- Address + Offset = Address + Report.Failed ("Storage arithmetic non-linear A+O"); + end if; + + if Storehouse_2'Address - House_Offset /= Storehouse_1'Address then + -- Address - Offset = Address + Report.Failed ("Storage arithmetic non-linear A-O"); + end if; + + if (Storehouse_2'Address mod abs(House_Offset) > abs(House_Offset)) then + -- "mod"( Address, Storage_Offset) + Report.Failed("Mod arithmetic"); + end if; + + + if Storehouse_1'Address + /= To_Address(To_Integer(Storehouse_1'Address)) then + Report.Failed("To_Address, To_Integer not symmetric"); + end if; + + end CD71; + + + begin -- Main test procedure. + + Report.Test ("CD70001", "Check package System" ); + + CD70; + + CD71; + + Report.Result; + + end CD70001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7002a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- CD7002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A VARIABLE OF TYPE ADDRESS CAN BE DECLARED IN A UNIT + -- WHICH HAS A WITH CLAUSE NAMING SYSTEM. + + -- HISTORY: + -- DHH 08/31/88 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD7002A IS + + I : INTEGER; + + OBJECT : SYSTEM.ADDRESS := I'ADDRESS; + + SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS; + + BEGIN + TEST ("CD7002A", "CHECK THAT A VARIABLE OF TYPE ADDRESS CAN BE " & + "DECLARED IN A UNIT WHICH HAS A WITH CLAUSE " & + "NAMING SYSTEM"); + + IF NOT IDENT_BOOL(OBJECT IN MY_ADDRESS) THEN + FAILED("INCORRECT RESULT"); + END IF; + + RESULT; + END CD7002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7007b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- CD7007B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SUBTYPE 'PRIORITY' IS DECLARED WITHIN THE PACKAGE + -- SYSTEM AND IT IS A SUBTYPE OF 'INTEGER'. + + -- HISTORY: + -- VCL 09/16/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + PROCEDURE CD7007B IS + BEGIN + TEST ("CD7007B", "THE SUBTYPE 'PRIORITY' IS DECLARED WITHIN " & + "THE PACKAGE SYSTEM AND IT IS A SUBTYPE OF " & + "'INTEGER'"); + + DECLARE + CHECK_VAR : SYSTEM.PRIORITY; + BEGIN + IF SYSTEM.PRIORITY'FIRST NOT IN + INTEGER'FIRST .. INTEGER'LAST AND + SYSTEM.PRIORITY'LAST NOT IN + INTEGER'FIRST .. INTEGER'LAST THEN + FAILED ("'SYSTEM.PRIORITY' IS NOT AN INTEGER SUBTYPE"); + END IF; + END; + + RESULT; + END CD7007B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- CD7101D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE SYSTEM, + -- INTEGER'FIRST >= MIN_INT AND INTEGER'LAST <= MAX_INT. + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7101D IS + + BEGIN + + TEST ("CD7101D", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " & + "SYSTEM, INTEGER'FIRST >= MIN_INT AND INTEGER'" & + "LAST <= MAX_INT"); + + IF INTEGER'POS (INTEGER'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF INTEGER'POS (INTEGER'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + + END CD7101D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101e.dep 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- CD7101E.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE SYSTEM, + -- SHORT_INTEGER'FIRST >= MIN_INT AND SHORT_INTEGER'LAST <= MAX_INT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO THOSE IMPLEMENTATIONS THAT + -- SUPPORT THE SHORT_INTEGER DATA TYPE. + + -- IF THE SHORT_INTEGER TYPE IS NOT SUPPORTED THEN THE + -- DECLARATION OF "TEST_VAR" MUST BE REJECTED. + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7101E IS + + TEST_VAR : SHORT_INTEGER := 0; -- N/A => ERROR. + + BEGIN + + TEST ("CD7101E", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " & + "SYSTEM, SHORT_INTEGER'FIRST >= MIN_INT AND " & + "SHORT_INTEGER'LAST <= MAX_INT"); + + IF SHORT_INTEGER'POS (SHORT_INTEGER'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF SHORT_INTEGER'POS (SHORT_INTEGER'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + + END CD7101E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101f.dep 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- CD7101F.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE SYSTEM, + -- LONG_INTEGER'FIRST >= MIN_INT AND LONG_INTEGER'LAST <= MAX_INT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT SUPPORT + -- THE LONG_INTEGER DATA TYPE. + + -- IF THE LONG_INTEGER TYPE IS NOT SUPPORTED, THEN THE + -- DECLARATION OF "TEST_VAR" MUST BE REJECTED. + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7101F IS + + TEST_VAR : LONG_INTEGER := 0; -- N/A => ERROR. + + BEGIN + + TEST ("CD7101F", "CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE " & + "SYSTEM, LONG_INTEGER'FIRST >= MIN_INT AND " & + "LONG_INTEGER'LAST <= MAX_INT"); + + IF LONG_INTEGER'POS (LONG_INTEGER'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF LONG_INTEGER'POS (LONG_INTEGER'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + + END CD7101F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7101g.tst 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CD7101G.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR MIN_INT AND MAX_INT IN PACKAGE SYSTEM AND + -- A PREDEFINED INTEGER TYPE I OTHER THAN INTEGER, SHORT_INTEGER, + -- AND LONG_INTEGER, I'FIRST >= MIN_INT AND I'LAST <= MAX_INT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS THAT HAVE + -- A PREDEFINED INTEGER TYPE OTHER THAN INTEGER, SHORT_INTEGER, + -- AND LONG_INTEGER. + + -- IF NO SUCH TYPE EXISTS, THEN THE DECLARATION OF TEST_VAR + -- MUST BE REJECTED. + + -- HISTORY: + -- JET 09/10/87 CREATED ORIGINAL TEST. + + -- $NAME IS THE NAME OF A PREDEFINED INTEGER TYPE OTHER THAN + -- INTEGER, SHORT_INTEGER, AND LONG_INTEGER, IF ANY SUCH TYPE + -- EXISTS. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7101G IS + + TEST_VAR : $NAME := 0; -- N/A => ERROR. + + BEGIN + + TEST ("CD7101G", "CHECK THAT FOR MIN_INT AND MAX_INT IN " & + "PACKAGE SYSTEM AND A PREDEFINED INTEGER " & + "TYPE I OTHER THAN INTEGER, SHORT_INTEGER, " & + "AND LONG_INTEGER, I'FIRST >= MIN_INT AND " & + "I'LAST <= MAX_INT"); + + IF $NAME'POS ($NAME'FIRST) < SYSTEM.MIN_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MIN_INT"); + END IF; + + IF $NAME'POS ($NAME'LAST) > SYSTEM.MAX_INT THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.MAX_INT"); + END IF; + + RESULT; + + END CD7101G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7103d.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- CD7103D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CONSTANT FINE_DELTA = 2.0 ** (- MAX_MANTISSA). + + -- HISTORY: + -- BCB 09/10/87 CREATED ORIGINAL TEST. + + -- DTN 11/21/91 DELETED SUBPART (A). CHANGED EXTENSION FROM '.TST' TO + -- '.ADA'. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7103D IS + + MANTISSA_VAL : CONSTANT := 2.0 ** (-SYSTEM.MAX_MANTISSA); + + BEGIN + + TEST ("CD7103D", "CHECK THAT THE CONSTANT FINE_DELTA " & + "= 2.0 ** (- MAX_MANTISSA)"); + + IF SYSTEM.FINE_DELTA /= MANTISSA_VAL THEN + FAILED ("INCORRECT VALUE FOR SYSTEM.FINE_DELTA"); + END IF; + + RESULT; + + END CD7103D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7202a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- CD7202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- THE 'ADDRESS ATTRIBUTE CAN BE USED IN A COMPILATION UNIT EVEN IF + -- A WITH CLAUSE FOR PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT. + + -- HISTORY: + -- DHH 08/31/88 CREATED ORIGINAL TEST. + + WITH SYSTEM; + PACKAGE CD7202A_SYS IS + SUBTYPE MY_ADDRESS IS SYSTEM.ADDRESS; + END CD7202A_SYS; + + WITH CD7202A_SYS; + WITH REPORT; USE REPORT; + PROCEDURE CD7202A IS + + INT : INTEGER := 2; + + BOOL : BOOLEAN := (INT'ADDRESS IN CD7202A_SYS.MY_ADDRESS); + + BEGIN + TEST ("CD7202A", "THE 'ADDRESS ATTRIBUTE CAN BE USED IN A" & + " COMPILATION UNIT EVEN IF A WITH CLAUSE FOR " & + "PACKAGE SYSTEM DOES NOT APPLY TO THE UNIT"); + + IF NOT IDENT_BOOL(BOOL) THEN + FAILED("ADDRESS ATTRIBUTE INCORRECT"); + END IF; + + RESULT; + END CD7202A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7204b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + -- CD7204B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT + -- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES + -- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE IS + -- NOT PRESENT. + + -- HISTORY: + -- BCB 09/14/87 CREATED ORIGINAL TEST. + -- RJW 02/08/88 REVISED SO THAT TEST PASSES IF BOOLEAN'SIZE = 1. + -- RJW 05/31/90 CORRECTED COMPARISONS INVOLVING SIZES. + -- LDC 10/04/90 ADDED CHECK FOR 'POSITION. + + WITH REPORT; USE REPORT; + + PROCEDURE CD7204B IS + + TYPE BASIC_REC IS RECORD + CHECK_INT : INTEGER := 5; + CHECK_BOOL : BOOLEAN := TRUE; + END RECORD; + + CHECK_REC : BASIC_REC; + + BEGIN + + TEST ("CD7204B", "CHECK THAT THE PREFIX OF THE 'POSITION, " & + "'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " & + "DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " & + "RETURN APPROPRIATE VALUES WHEN A RECORD " & + "REPRESENTATION CLAUSE IS NOT PRESENT"); + + IF CHECK_REC.CHECK_INT'FIRST_BIT >= CHECK_REC.CHECK_INT'LAST_BIT + THEN FAILED ("INCORRECT VALUES FOR FIRST_BIT OR LAST_BIT " & + "OF CHECK_INT"); + END IF; + + IF (CHECK_REC.CHECK_INT'LAST_BIT - CHECK_REC.CHECK_INT'FIRST_BIT + + 1) < INTEGER'SIZE THEN + FAILED ("INCORRECT SIZE FOR CHECK_INT"); + END IF; + + IF CHECK_REC.CHECK_BOOL'POSITION <= CHECK_REC.CHECK_INT'POSITION + THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " & + "OR CHECK_BOOL"); + END IF; + + IF CHECK_REC.CHECK_INT'POSITION >= CHECK_REC.CHECK_BOOL'POSITION + THEN FAILED ("INCORRECT VALUE FOR 'POSITION OF CHECK_INT " & + "OR CHECK_BOOL - 2"); + END IF; + + IF CHECK_REC.CHECK_BOOL'FIRST_BIT > CHECK_REC.CHECK_BOOL'LAST_BIT + THEN FAILED ("INCORRECT VALUE FOR FIRST_BIT OR LAST_BIT " & + "OF CHECK_BOOL"); + END IF; + + IF (CHECK_REC.CHECK_BOOL'LAST_BIT - CHECK_REC.CHECK_BOOL'FIRST_BIT + + 1) < BOOLEAN'SIZE THEN + FAILED ("INCORRECT SIZE FOR CHECK_BOOL"); + END IF; + + RESULT; + + END CD7204B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7204c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CD7204C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PREFIX OF THE 'POSITION, 'LAST_BIT, AND 'FIRST_BIT + -- ATTRIBUTES CAN DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES + -- RETURN APPROPRIATE VALUES WHEN A RECORD REPRESENTATION CLAUSE + -- IS GIVEN. + + -- HISTORY: + -- BCB 09/14/87 CREATED ORIGINAL TEST. + -- PWB 05/11/89 CHANGED EXTENSION FROM '.DEP' TO '.ADA'. + + WITH SYSTEM; + WITH REPORT; USE REPORT; + + PROCEDURE CD7204C IS + + UNITS_PER_INTEGER : CONSTANT := + (INTEGER'SIZE + SYSTEM.STORAGE_UNIT - 1)/SYSTEM.STORAGE_UNIT; + + TYPE BASIC_REC IS RECORD + CHECK_INT : INTEGER; + CHECK_CHAR : CHARACTER; + END RECORD; + + FOR BASIC_REC USE + RECORD + CHECK_INT AT 0 RANGE 0..INTEGER'SIZE - 1; + CHECK_CHAR AT 1*UNITS_PER_INTEGER + RANGE 0..CHARACTER'SIZE - 1; + END RECORD; + + CHECK_REC : BASIC_REC; + + BEGIN + + TEST ("CD7204C", "THE PREFIX OF THE 'POSITION, " & + "'LAST_BIT, AND 'FIRST_BIT ATTRIBUTES CAN " & + "DENOTE A RECORD COMPONENT, AND THE ATTRIBUTES " & + "RETURN APPROPRIATE VALUES WHEN A RECORD " & + "REPRESENTATION CLAUSE IS GIVEN"); + + IF CHECK_REC.CHECK_INT'POSITION /= 0 THEN + FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_INT"); + END IF; + + IF CHECK_REC.CHECK_INT'FIRST_BIT /= IDENT_INT (0) THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_INT"); + END IF; + + IF CHECK_REC.CHECK_INT'LAST_BIT /= INTEGER'SIZE - 1 THEN + FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_INT"); + END IF; + + IF CHECK_REC.CHECK_CHAR'POSITION /= IDENT_INT (UNITS_PER_INTEGER) + THEN FAILED ("INCORRECT VALUE FOR POSITION OF CHECK_CHAR"); + END IF; + + IF CHECK_REC.CHECK_CHAR'FIRST_BIT /= 0 THEN + FAILED ("INCORRECT VALUE FOR FIRST_BIT OF CHECK_CHAR"); + END IF; + + IF CHECK_REC.CHECK_CHAR'LAST_BIT /= IDENT_INT (CHARACTER'SIZE - 1) + THEN FAILED ("INCORRECT VALUE FOR LAST_BIT OF CHECK_CHAR"); + END IF; + + RESULT; + + END CD7204C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd72a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd72a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd72a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd72a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- + -- CD72A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the package System.Address_To_Access_Conversions may be + -- instantiated for various simple types. + -- + -- Check that To_Pointer and To_Address are inverse operations. + -- + -- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an + -- X that allows Unchecked_Access. + -- + -- Check that To_Pointer(Null_Address) returns null. + -- + -- TEST DESCRIPTION: + -- This test checks that the semantics provided in + -- Address_To_Access_Conversions are present and operate + -- within expectations (to the best extent possible in a portable + -- implementation independent fashion). + -- + -- The functions Address_To_Hex and Hex_To_Address test the invertability + -- of the To_Integer and To_Address functions, along with a great deal + -- of optimizer chaff and protection from the fact that type + -- Storage_Elements.Integer_Address may be either a modular or a signed + -- integer type. + -- + -- This test has some interesting usage paradigms in that users + -- occasionally want to store address information in a transportable + -- fashion, and often resort to some textual representation of values. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- CHANGE HISTORY: + -- 13 JUL 95 SAIC Initial version (CD72001) + -- 08 FEB 96 SAIC Revised (split) version for 2.1 + -- 07 MAY 96 SAIC Additional subtest added for 2.1 + -- 16 FEB 98 EDS Modified documentation. + --! + + with Report; + with Impdef; + with FD72A00; + with System.Storage_Elements; + with System.Address_To_Access_Conversions; + procedure CD72A01 is + use System; + use FD72A00; + + package Number_ATAC is + new System.Address_To_Access_Conversions(Number); -- ANX-C RQMT + + use type Number_ATAC.Object_Pointer; + + type Data is record + One, Two: aliased Number; + end record; + + package Data_ATAC is + new System.Address_To_Access_Conversions(Data); -- ANX-C RQMT + + use type Data_ATAC.Object_Pointer; + + type Test_Cases is ( Addr_Type, Record_Type ); + + type Naive_Dynamic_String is access String; + + type String_Store is array(Test_Cases) of Naive_Dynamic_String; + + The_Strings : String_Store; + + -- create several aliased objects with distinct values + + My_Number : aliased Number := Number'First; + My_Data : aliased Data := (Number'First,Number'Last); + + use type System.Storage_Elements.Integer_Address; + + begin -- Main test procedure. + + Report.Test ("CD72A01", "Check package " & + "System.Address_To_Access_Conversions " & + "for simple types" ); + + -- take several pointer objects, convert them to addresses, and store + -- the address as a hexadecimal representation for later reconversion + + The_Strings(Addr_Type) := new String'( + Address_To_Hex(Number_ATAC.To_Address(My_Number'Access)) ); + + The_Strings(Record_Type) := new String'( + Address_To_Hex(Data_ATAC.To_Address(My_Data'Access)) ); + + -- now, reconvert the hexadecimal address values back to pointers, + -- and check that the dereferenced pointer still designates the + -- value placed at that location. The use of the intermediate + -- string representation should foil even the cleverest of optimizers + + if Number_ATAC.To_Pointer( + Hex_To_Address(The_Strings(Addr_Type))).all + /= Number'First then + Report.Failed("Number reconversion"); + end if; + + if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type))).all + /= (Number'First,Number'Last) then + Report.Failed("Data reconversion"); + end if; + + -- check that the resulting values are equal to the 'Unchecked_Access + -- of the value + + if Number_ATAC.To_Pointer( + Hex_To_Address(The_Strings(Addr_Type))) + /= My_Number'Unchecked_Access then + Report.Failed("Number Unchecked_Access"); + end if; + + if Data_ATAC.To_Pointer(Hex_To_Address(The_Strings(Record_Type))) + /= My_Data'Unchecked_Access then + Report.Failed("Data Unchecked_Access"); + end if; + + if Number_ATAC.To_Pointer(System.Null_Address) /= null then + Report.Failed("To_Pointer(Null_Address) /= null"); + end if; + + if Number_ATAC.To_Address(null) /= System.Null_Address then + Report.Failed("To_Address(null) /= Null_Address"); + end if; + + Report.Result; + + end CD72A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd72a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd72a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd72a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd72a02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,225 ---- + -- CD72A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the package System.Address_To_Access_Conversions may be + -- instantiated for various composite types. + -- + -- Check that To_Pointer and To_Address are inverse operations. + -- + -- Check that To_Pointer(X'Address) equals X'Unchecked_Access for an + -- X that allows Unchecked_Access. + -- + -- Check that To_Pointer(Null_Address) returns null. + -- + -- TEST DESCRIPTION: + -- This test is identical to CD72A01 with the exception that it tests + -- the composite types where CD72A01 tests "simple" types. + -- + -- This test checks that the semantics provided in + -- Address_To_Access_Conversions are present and operate + -- within expectations (to the best extent possible in a portable + -- implementation independent fashion). + -- + -- The functions Address_To_Hex and Hex_To_Address test the invertability + -- of the To_Integer and To_Address functions, along with a great deal + -- of optimizer chaff and protection from the fact that type + -- Storage_Elements.Integer_Address may be either a modular or a signed + -- integer type. + -- + -- This test has some interesting usage paradigms in that users + -- occasionally want to store address information in a transportable + -- fashion, and often resort to some textual representation of values. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 13 JUL 95 SAIC Initial version (CD72001) + -- 08 FEB 96 SAIC Split from CD72001 by reviewer request for 2.1 + -- 12 NOV 96 SAIC Corrected typo in RM ref + -- 16 FEB 98 EDS Modified documentation. + -- 22 JAN 02 RLB Corrected test description. + --! + + with Report; + with Impdef; + with FD72A00; + with System.Storage_Elements; + with System.Address_To_Access_Conversions; + procedure CD72A02 is + use System; + use FD72A00; + + type Tagged_Record is tagged record + Value : Natural; + end record; + + package Class_ATAC is + new System.Address_To_Access_Conversions(Tagged_Record'Class); + -- ANX-C RQMT + + use type Class_ATAC.Object_Pointer; + + task type TC_Task_Type is + entry E; + entry F; + end TC_Task_Type; + + package Task_ATAC is + new System.Address_To_Access_Conversions(TC_Task_Type); + -- ANX-C RQMT + + use type Task_ATAC.Object_Pointer; + + task body TC_Task_Type is + begin + select + accept E; + or + accept F; + Report.Failed("Task rendezvoused on wrong path"); + end select; + end TC_Task_Type; + + protected type TC_Protec is + procedure E; + procedure F; + private + Visited : Boolean := False; + end TC_Protec; + + package Protected_ATAC is + new System.Address_To_Access_Conversions(TC_Protec); + -- ANX-C RQMT + + use type Protected_ATAC.Object_Pointer; + + protected body TC_Protec is + procedure E is + begin + Visited := True; + end E; + procedure F is + begin + if not Visited then + Report.Failed("Protected Object took wrong path"); + end if; + end F; + end TC_Protec; + + type Test_Cases is ( Tagged_Type, Task_Type, Protected_Type ); + + type Naive_Dynamic_String is access String; + + type String_Store is array(Test_Cases) of Naive_Dynamic_String; + + The_Strings : String_Store; + + -- create several aliased objects with distinct values + + My_Rec : aliased Tagged_Record := (Value => Natural'Last); + My_Task : aliased TC_Task_Type; + My_Prot : aliased TC_Protec; + + use type System.Storage_Elements.Integer_Address; + + begin -- Main test procedure. + + Report.Test ("CD72A02", "Check package " & + "System.Address_To_Access_Conversions " & + "for composite types" ); + + -- take several pointer objects, convert them to addresses, and store + -- the address as a hexadecimal representation for later reconversion + + The_Strings(Tagged_Type) := new String'( + Address_To_Hex(Class_ATAC.To_Address(My_Rec'Access)) ); + + The_Strings(Task_Type) := new String'( + Address_To_Hex(Task_ATAC.To_Address(My_Task'Access)) ); + + The_Strings(Protected_Type) := new String'( + Address_To_Hex(Protected_ATAC.To_Address(My_Prot'Access)) ); + + -- now, reconvert the hexadecimal address values back to pointers, + -- and check that the dereferenced pointer still designates the + -- value placed at that location. The use of the intermediate + -- string representation should foil even the cleverest of optimizers + + if Tagged_Record(Class_ATAC.To_Pointer( + Hex_To_Address(The_Strings(Tagged_Type))).all) + /= Tagged_Record'(Value => Natural'Last) then + Report.Failed("Tagged_Record reconversion"); + end if; + + Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type))).E; + + begin + select -- allow for task to have completed. + My_Task.F; -- should not happen, will call Report.Fail in task + else + null; -- expected case, "Report.Pass;" + end select; + exception + when Tasking_Error => null; -- task terminated, which is OK + end; + + Protected_ATAC.To_Pointer( + Hex_To_Address(The_Strings(Protected_Type))).E; + My_Prot.F; -- checks that call to E occurred + + + -- check that the resulting values are equal to the 'Unchecked_Access + -- of the value + + if Class_ATAC.To_Pointer(Hex_To_Address(The_Strings(Tagged_Type))) + /= My_Rec'Unchecked_Access then + Report.Failed("Tagged_Record Unchecked_Access"); + end if; + + if Task_ATAC.To_Pointer(Hex_To_Address(The_Strings(Task_Type))) + /= My_Task'Unchecked_Access then + Report.Failed("Task Unchecked_Access"); + end if; + + if Protected_ATAC.To_Pointer( + Hex_To_Address(The_Strings(Protected_Type))) + /= My_Prot'Unchecked_Access then + Report.Failed("Protected Unchecked_Access"); + end if; + + Report.Result; + + end CD72A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd7305a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- CD7305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK, FOR DIGITS 5, THAT MACHINE_RADIX, MACHINE_MANTISSA, + -- MACHINE_EMAX, AND MACHINE_EMIN HAVE THE CORRECT VALUES. + + -- HISTORY: + -- DHH 09/15/88 CREATED ORIGINAL TEST. + -- PWN 02/02/95 REMOVED INCONSISTENCIES WITH ADA 9X. + + WITH REPORT; USE REPORT; + PROCEDURE CD7305A IS + + TYPE T IS DIGITS 5; + + B : BOOLEAN := FALSE; + + BEGIN + TEST ("CD7305A", "CHECK, FOR DIGITS 5, THAT MACHINE_RADIX, " & + "MACHINE_MANTISSA, MACHINE_EMAX, AND " & + "MACHINE_EMIN HAVE THE CORRECT VALUES"); + + + IF T'MACHINE_RADIX < 2 OR + T'BASE'MACHINE_RADIX /= T'MACHINE_RADIX THEN + FAILED ("INCORRECT 'MACHINE_RADIX"); + END IF; + + RESULT; + END CD7305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd90001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd90001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd90001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd90001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,233 ---- + -- CD90001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Unchecked_Conversion is supported and is reversible in + -- the cases where: + -- Source'Size = Target'Size + -- Source'Alignment = Target'Alignment + -- Source and Target are both represented contiguously + -- Bit pattern in Source is a meaningful value of Target type + -- + -- TEST DESCRIPTION: + -- This test declares an enumeration type with a representation + -- specification that should fit neatly into an 8 bit object; and a + -- modular type that should also be able to fit easily into 8 bits; + -- uses size representation clauses on both of them for 8 bit + -- representations. It then defines two instances of + -- Unchecked_Conversion; to convert both ways between the types. + -- Using several distinctive values, it checks that the conversions + -- are performed, and reversible. + -- As a second case, the above is performed with an integer type and + -- a packed array of booleans. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-C RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 22 JUL 95 SAIC Initial version + -- 07 MAY 96 SAIC Changed Boolean to Character for 2.1 + -- 27 JUL 96 SAIC Allowed for partial N/A to be PASS + -- 14 FEB 97 PWB.CTA Corrected "=" to "/=" in alignment check. + -- 16 FEB 98 EDS Modified documentation. + --! + + ----------------------------------------------------------------- CD90001_0 + + with Report; + with Unchecked_Conversion; + package CD90001_0 is + + -- Case 1 : Modular <=> Enumeration + + type Eight_Bits is mod 2**8; + for Eight_Bits'Size use 8; + + type User_Enums is ( One, Two, Four, Eight, + Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight ); + for User_Enums'Size use 8; + + for User_Enums use + ( One => 1, -- ANX-C RQMT. + Two => 2, -- ANX-C RQMT. + Four => 4, -- ANX-C RQMT. + Eight => 8, -- ANX-C RQMT. + Sixteen => 16, -- ANX-C RQMT. + Thirty_Two => 32, -- ANX-C RQMT. + Sixty_Four => 64, -- ANX-C RQMT. + One_Twenty_Eight => 128 ); -- ANX-C RQMT. + + function EB_2_UE is new Unchecked_Conversion( Eight_Bits, User_Enums ); + + function UE_2_EB is new Unchecked_Conversion( User_Enums, Eight_Bits ); + + procedure TC_Check_Case_1; + + -- Case 2 : Integer <=> Packed Character array + + type Signed_16 is range -2**15+1 .. 2**15-1; + -- +1, -1 allows for both 1's and 2's comp + + type Bits_16 is array(0..1) of Character; + pragma Pack(Bits_16); -- ANX-C RQMT. + + function S16_2_B16 is new Unchecked_Conversion( Signed_16, Bits_16 ); + + function B16_2_S16 is new Unchecked_Conversion( Bits_16, Signed_16 ); + + procedure TC_Check_Case_2; + + end CD90001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CD90001_0 is + + Check_List : constant array(1..8) of Eight_Bits + := ( 1, 2, 4, 8, 16, 32, 64, 128 ); + + Check_Enum : constant array(1..8) of User_Enums + := ( One, Two, Four, Eight, + Sixteen, Thirty_Two, Sixty_Four, One_Twenty_Eight ); + + procedure TC_Check_Case_1 is + Mod_Value : Eight_Bits; + Enum_Val : User_Enums; + begin + for I in Check_List'Range loop + + if EB_2_UE(Check_List(I)) /= Check_Enum(I) then + Report.Failed("EB => UE conversion failed"); + end if; + + if Check_List(I) /= UE_2_EB(Check_Enum(I)) then + Report.Failed ("EU => EB conversion failed"); + end if; + + end loop; + end TC_Check_Case_1; + + procedure TC_Check_Case_2 is + S: Signed_16; + T,U: Signed_16; + B: Bits_16; + C,D: Bits_16; -- allow for byte swapping + begin + --FDEC_BA98_7654_3210 + S := 2#0011_0000_0111_0111#; + B := S16_2_B16( S ); + C := ( Character'Val(2#0011_0000#), Character'Val(2#0111_0111#) ); + D := ( Character'Val(2#0111_0111#), Character'Val(2#0011_0000#) ); + + if (B /= C) and (B /= D) then + Report.Failed("Int => Chararray conversion failed"); + end if; + + B := ( Character'Val(2#0011_1100#), Character'Val(2#0101_0101#) ); + S := B16_2_S16( B ); + T := 2#0011_1100_0101_0101#; + U := 2#0101_0101_0011_1100#; + + if (S /= T) and (S /= U) then + Report.Failed("Chararray => Int conversion failed"); + end if; + + end TC_Check_Case_2; + + end CD90001_0; + + ------------------------------------------------------------------- CD90001 + + with Report; + with CD90001_0; + + procedure CD90001 is + + Eight_NA : Boolean := False; + Sixteen_NA : Boolean := False; + + begin -- Main test procedure. + + Report.Test ("CD90001", "Check that Unchecked_Conversion is supported " & + "and is reversible in appropriate cases" ); + Eight_Bit_Case: + begin + if CD90001_0.User_Enums'Size /= CD90001_0.Eight_Bits'Size then + Report.Comment("The sizes of the 8 bit types used in this test " + & "do not match" ); + Eight_NA := True; + elsif CD90001_0.User_Enums'Alignment /= CD90001_0.Eight_Bits'Alignment then + Report.Comment("The alignments of the 8 bit types used in this " + & "test do not match" ); + Eight_NA := True; + else + CD90001_0.TC_Check_Case_1; + end if; + + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised in 8 bit case"); + when others => + Report.Failed("Unexpected exception raised in 8 bit case"); + end Eight_Bit_Case; + + Sixteen_Bit_Case: + begin + if CD90001_0.Signed_16'Size /= CD90001_0.Bits_16'Size then + Report.Comment("The sizes of the 16 bit types used in this test " + & "do not match" ); + Sixteen_NA := True; + elsif CD90001_0.Signed_16'Alignment = CD90001_0.Bits_16'Alignment then + Report.Comment("The alignments of the 16 bit types used in this " + & "test do not match" ); + Sixteen_NA := True; + else + CD90001_0.TC_Check_Case_2; + end if; + + exception + when Constraint_Error => + Report.Failed("Constraint_Error raised in 16 bit case"); + when others => + Report.Failed("Unexpected exception raised in 16 bit case"); + end Sixteen_Bit_Case; + + if Eight_NA and Sixteen_NA then + Report.Not_Applicable("No cases in this test apply"); + end if; + + Report.Result; + + end CD90001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd92001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd92001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cd92001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cd92001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- CD92001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that if X denotes a scalar object, X'Valid + -- yields true if an only if the object denoted by X is normal and + -- has a valid representation. + -- + -- TEST DESCRIPTION: + -- Using Unchecked_Conversion, Image and Value attributes, combined + -- with string manipulation, cause valid and invalid values to be + -- stored in various objects. Check their validity with the + -- attribute 'Valid. Invalid objects are created in a loop which + -- performs a simplistic check to ensure that the values being used + -- are indeed not valid, then assigns the value using an instance of + -- Unchecked_Conversion. The creation of the tables of valid values + -- is trivial. + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Systems Programming Annex (C): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex C: + -- this test may report compile time errors at one or more points + -- indicated by "-- N/A => ERROR", in which case it may be graded as + -- inapplicable. Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 10 MAY 95 SAIC Initial version + -- 07 MAY 96 SAIC Changed U_C to Ada.U_C for 2.1 + -- 05 JAN 99 RLB Added Component_Size clauses to compensate + -- for the fact that there is no required size + -- for either the enumeration or modular components. + --! + + with Report; + with Ada.Unchecked_Conversion; + with System; + procedure CD92001 is + + type Sparse_Enumerated is + ( Help, Home, Page_Up, Del, EndK, + Page_Down, Up, Left, Down, Right ); + + for Sparse_Enumerated use ( Help => 2, + Home => 4, + Page_Up => 8, + Del => 16, + EndK => 32, + Page_Down => 64, + Up => 128, + Left => 256, + Down => 512, + Right => 1024 ); + + type Mod_10 is mod 10; + + type Default_Enumerated is ( Zero, One, Two, Three, Four, + Five, Six, Seven, Eight, Nine, + Clear, '=', '/', '*', '-', + '+', Enter ); + for Default_Enumerated'Size use 8; + + Default_Enumerated_Count : constant := 17; + + type Mod_By_Enum_Items is mod Default_Enumerated_Count; + + type Mod_Same_Size_As_Sparse_Enum is mod 2**12; + -- Sparse_Enumerated 'Size; + + type Mod_Same_Size_As_Def_Enum is mod 2**8; + -- Default_Enumerated'Size; + + subtype Test_Width is Positive range 1..100; + + -- Note: There is no required relationship between 'Size and 'Component_Size, + -- so we must use component_size clauses here. + -- We use the following expressions to insure that the component size is a + -- multiple of the Storage_Unit. + Sparse_Component_Size : constant := ((Sparse_Enumerated'Size / System.Storage_Unit) + + Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) * + System.Storage_Unit; + Default_Component_Size : constant := ((Default_Enumerated'Size / System.Storage_Unit) + + Boolean'Pos((Sparse_Enumerated'Size mod System.Storage_Unit) /= 0)) * + System.Storage_Unit; + + type Sparse_Enum_Table is array(Test_Width) of Sparse_Enumerated; + for Sparse_Enum_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR. + type Def_Enum_Table is array(Test_Width) of Default_Enumerated; + for Def_Enum_Table'Component_Size use Default_Component_Size; -- N/A => ERROR. + + type Sparse_Mod_Table is + array(Test_Width) of Mod_Same_Size_As_Sparse_Enum; + for Sparse_Mod_Table'Component_Size use Sparse_Component_Size; -- N/A => ERROR. + + type Default_Mod_Table is + array(Test_Width) of Mod_Same_Size_As_Def_Enum; + for Default_Mod_Table'Component_Size use Default_Component_Size; -- N/A => ERROR. + + function UC_Sparse_Mod_Enum is + new Ada.Unchecked_Conversion( Sparse_Mod_Table, Sparse_Enum_Table ); + + function UC_Def_Mod_Enum is + new Ada.Unchecked_Conversion( Default_Mod_Table, Def_Enum_Table ); + + Valid_Sparse_Values : Sparse_Enum_Table; + Valid_Def_Values : Def_Enum_Table; + + Sample_Enum_Value_Table : Sparse_Mod_Table; + Sample_Def_Value_Table : Default_Mod_Table; + + + -- fill the Valid tables with valid values for conversion + procedure Fill_Valid is + K : Mod_10 := 0; + P : Mod_By_Enum_Items := 0; + begin + for I in Test_Width loop + Valid_Sparse_Values(I) := Sparse_Enumerated'Val( K ); + Valid_Def_Values(I) := Default_Enumerated'Val( Integer(P) ); + K := K +1; + P := P +1; + end loop; + end Fill_Valid; + + -- fill the Sample tables with invalid values for conversion + procedure Fill_Invalid is + K : Mod_Same_Size_As_Sparse_Enum := 1; + P : Mod_Same_Size_As_Def_Enum := 1; + begin + for I in Test_Width loop + K := K +13; + if K mod 2 = 0 then -- oops, that would be a valid value + K := K +1; + end if; + if P = Mod_Same_Size_As_Def_Enum'Last + or P < Default_Enumerated_Count then -- that would be valid + P := Default_Enumerated_Count + 1; + else + P := P +1; + end if; + Sample_Enum_Value_Table(I) := K; + Sample_Def_Value_Table(I) := P; + end loop; + + Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table); + Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table); + + end Fill_Invalid; + + -- fill the tables with second set of valid values for conversion + procedure Refill_Valid is + K : Mod_10 := 0; + P : Mod_By_Enum_Items := 0; + + Table : Array(Mod_10) of Mod_Same_Size_As_Sparse_Enum + := ( 2, 4, 8, 16, 32, 64, 128, 256, 512, 1024 ); + + begin + for I in Test_Width loop + Sample_Enum_Value_Table(I) := Table(K); + Sample_Def_Value_Table(I) := Mod_Same_Size_As_Def_Enum(P); + K := K +1; + P := P +1; + end loop; + Valid_Sparse_Values := UC_Sparse_Mod_Enum(Sample_Enum_Value_Table); + Valid_Def_Values := UC_Def_Mod_Enum(Sample_Def_Value_Table); + end Refill_Valid; + + procedure Validate(Expect_Valid: Boolean) is + begin -- here's where we actually use the tested attribute + + for K in Test_Width loop + if Valid_Sparse_Values(K)'Valid /= Expect_Valid then + Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid) + & " for Sparse item " & Integer'Image(K) ); + end if; + end loop; + + for P in Test_Width loop + if Valid_Def_Values(P)'Valid /= Expect_Valid then + Report.Failed("Expected 'Valid =" & Boolean'Image(Expect_Valid) + & " for Default item " & Integer'Image(P) ); + end if; + end loop; + + end Validate; + + begin -- Main test procedure. + + Report.Test ("CD92001", "Check object attribute: X'Valid" ); + + Fill_Valid; + Validate(True); + + Fill_Invalid; + Validate(False); + + Refill_Valid; + Validate(True); + + Report.Result; + + end CD92001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201a.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- CDA201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR + -- CONVERSION BETWEEN INTEGER AND BOOLEAN ARRAY TYPES. + + -- HISTORY: + -- JET 09/12/88 CREATED ORIGINAL TEST. + -- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + + WITH REPORT; USE REPORT; + WITH UNCHECKED_CONVERSION; + PROCEDURE CDA201A IS + + TYPE BOOL_ARR IS ARRAY (1..INTEGER'SIZE) OF BOOLEAN; + PRAGMA PACK (BOOL_ARR); + + I : INTEGER; + B : BOOL_ARR; + + FUNCTION INT_TO_BOOL IS NEW + UNCHECKED_CONVERSION (INTEGER, BOOL_ARR); + + FUNCTION BOOL_TO_INT IS NEW UNCHECKED_CONVERSION(BOOL_ARR,INTEGER); + + BEGIN + TEST ("CDA201A", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR CONVERSION BETWEEN " & + "INTEGER AND BOOLEAN ARRAY TYPES"); + + I := BOOL_TO_INT((1..INTEGER'SIZE => IDENT_BOOL(TRUE))); + + IF INT_TO_BOOL(IDENT_INT(I)) /= (1..INTEGER'SIZE => TRUE) THEN + FAILED("INCORRECT RESULT FROM ARRAY-INTEGER-ARRAY"); + END IF; + + B := INT_TO_BOOL(IDENT_INT(-1)); + + FOR J IN B'RANGE LOOP + B(J) := IDENT_BOOL(B(J)); + END LOOP; + + IF BOOL_TO_INT(B) /= -1 THEN + FAILED("INCORRECT RESULT FROM INTEGER-ARRAY-INTEGER"); + END IF; + + RESULT; + END CDA201A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201b.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CDA201B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR + -- CONVERSION BETWEEN FLOAT AND BOOLEAN ARRAY TYPES. + + -- HISTORY: + -- JET 09/12/88 CREATED ORIGINAL TEST. + -- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + -- GJD 11/15/95 REMOVED USE OF OBSOLETE ADA 83 ATTRIBUTE (LARGE). + + WITH REPORT; USE REPORT; + WITH UNCHECKED_CONVERSION; + PROCEDURE CDA201B IS + + TYPE BOOL_ARR IS ARRAY (1..FLOAT'SIZE) OF BOOLEAN; + PRAGMA PACK (BOOL_ARR); + + B : BOOL_ARR; + + FUNCTION FLT_TO_BOOL IS NEW UNCHECKED_CONVERSION(FLOAT, BOOL_ARR); + + FUNCTION BOOL_TO_FLT IS NEW UNCHECKED_CONVERSION(BOOL_ARR, FLOAT); + + BEGIN + TEST ("CDA201B", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR CONVERSION BETWEEN " & + "FLOAT AND BOOLEAN ARRAY TYPES"); + + B := FLT_TO_BOOL(FLOAT'LAST + FLOAT(IDENT_INT(0))); + + FOR J IN B'RANGE LOOP + B(J) := B(J+IDENT_INT(0)); + END LOOP; + + IF BOOL_TO_FLT(B) /= FLOAT'LAST THEN + FAILED("INCORRECT RESULT FROM FLOAT-ARRAY-FLOAT"); + END IF; + + RESULT; + END CDA201B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201c.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CDA201C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR + -- CONVERSION BETWEEN CONSTRAINED ARRAY AND RECORD TYPES. + + -- HISTORY: + -- JET 09/12/88 CREATED ORIGINAL TEST. + -- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + + WITH REPORT; USE REPORT; + WITH UNCHECKED_CONVERSION; + PROCEDURE CDA201C IS + + TYPE INT IS NEW INTEGER; + + TYPE ARR IS ARRAY (1..2) OF INTEGER; + TYPE ARR2 IS ARRAY (ARR'RANGE) OF INT; + + TYPE REC IS RECORD + D : INTEGER; + I : INTEGER; + END RECORD; + + TYPE REC2 IS RECORD + D : INT; + I : INT; + END RECORD; + + A : ARR2; + R : REC2; + + FUNCTION ARR_CONV IS NEW UNCHECKED_CONVERSION(ARR, ARR2); + FUNCTION REC_CONV IS NEW UNCHECKED_CONVERSION(REC, REC2); + + BEGIN + TEST ("CDA201C", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR CONVERSION BETWEEN " & + "CONSTRAINED ARRAY AND RECORD TYPES"); + + A := ARR_CONV(ARR'(ARR'RANGE => IDENT_INT(-1))); + + IF A /= ARR2'(ARR'RANGE => -1) THEN + FAILED("INCORRECT RESULT FROM ARRAY CONVERSION"); + END IF; + + R := REC_CONV(REC'(D | I => IDENT_INT(1))); + + IF R /= REC2'(D => 1, I => 1) THEN + FAILED("INCORRECT RESULT FROM RECORD CONVERSION"); + END IF; + + RESULT; + END CDA201C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cda201e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cda201e.ada 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- CDA201E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNCHECKED_CONVERSION CAN BE INSTANTIATED FOR THE + -- CONVERSION OF AN ENUMERATION TYPE WITH A REPRESENTATION CLAUSE TO + -- INTEGER. + + -- HISTORY: + -- JET 09/23/88 CREATED ORIGINAL TEST. + -- DHH 05/17/89 CHANGED FROM '.DEP' TEST TO '.ADA' TEST. + -- RJW 02/28/90 ADDED SIZE CLAUSE FOR TYPE STOOGE. + -- LDC 09/20/90 ADDED CHECK FOR CONVERSION FROM INT TO STOOGE, + -- ADDED COMMENT WHEN SIZES AREN'T EQUAL. + + WITH REPORT; USE REPORT; + WITH UNCHECKED_CONVERSION; + PROCEDURE CDA201E IS + + TYPE STOOGE IS (CURLY, MOE, LARRY); + FOR STOOGE USE (CURLY => -5, MOE => 13, LARRY => 127); + FOR STOOGE'SIZE USE 8; + + TYPE INT IS RANGE -128 .. 127; + FOR INT'SIZE USE 8; + + I : INT := 0; + NAME : STOOGE := CURLY; + + FUNCTION E_TO_I IS NEW UNCHECKED_CONVERSION(STOOGE, INT); + FUNCTION I_TO_E IS NEW UNCHECKED_CONVERSION(INT, STOOGE); + + FUNCTION ID(E : STOOGE) RETURN STOOGE IS + BEGIN + RETURN STOOGE'VAL(STOOGE'POS(E) + IDENT_INT(0)); + END ID; + + FUNCTION ID_INT (X : INT) RETURN INT IS + A : INTEGER := IDENT_INT(3); + BEGIN + IF EQUAL (A, IDENT_INT(3)) THEN -- ALWAYS EQUAL. + RETURN X; -- ALWAYS EXECUTED. + END IF; + RETURN 0; -- NEVER EXECUTED. + END ID_INT; + + BEGIN + TEST ("CDA201E", "CHECK THAT UNCHECKED_CONVERSION CAN BE " & + "INSTANTIATED FOR THE CONVERSION OF AN " & + "ENUMERATION TYPE WITH A REPRESENTATION " & + "CLAUSE TO INTEGER"); + + IF I'SIZE /= NAME'SIZE THEN + COMMENT( "UNCHECKED_CONVERSION MIGHT BE INSTANTIATED WITH " & + "DIFFERNT SIZES"); + END IF; + + BEGIN + I := E_TO_I(ID(CURLY)); + IF I /= -5 THEN + FAILED ("INCORRECT VALUE OF CURLY: " & INT'IMAGE(I)); + END IF; + + I := E_TO_I(ID(MOE)); + IF I /= 13 THEN + FAILED ("INCORRECT VALUE OF MOE: " & INT'IMAGE(I)); + END IF; + + I := E_TO_I(ID(LARRY)); + IF I /= 127 THEN + FAILED ("INCORRECT VALUE OF LARRY: " & INT'IMAGE(I)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION"); + END; + + BEGIN -- 2 + NAME := I_TO_E(ID_INT(-5)); + IF NAME /= CURLY THEN + FAILED ("INCORRECT VALUE OF -5 : " & STOOGE'IMAGE(NAME)); + END IF; + + NAME := I_TO_E(ID_INT(13)); + IF NAME /= MOE THEN + FAILED ("INCORRECT VALUE OF 13: " & STOOGE'IMAGE(NAME)); + END IF; + + NAME := I_TO_E(ID_INT(127)); + IF NAME /= LARRY THEN + FAILED ("INCORRECT VALUE OF 127: " & STOOGE'IMAGE(NAME)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED BY CONVERSION - 2"); + END; + + RESULT; + END CDA201E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdb0a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,305 ---- + -- CDB0A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a storage pool may be user_determined, and that storage + -- is allocated by calling Allocate. + -- + -- Check that a storage.pool may be specified using 'Storage_Pool + -- and that S'Storage_Pool denotes the storage pool of the type S. + -- + -- TEST DESCRIPTION: + -- The package System.Storage_Pools is exercised by two very similar + -- packages which define a tree type and exercise it in a simple manner. + -- One package uses a user defined pool. The other package uses a + -- storage pool assigned by the implementation; Storage_Size is + -- specified for this pool. + -- The dispatching procedures Allocate and Deallocate are tested as an + -- intentional side effect of the tree packages. + -- + -- For completeness, the actions of the tree packages are checked for + -- correct operation. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FDB0A00.A (foundation code) + -- CDB0A01.A + -- + -- + -- CHANGE HISTORY: + -- 02 JUN 95 SAIC Initial version + -- 07 MAY 96 SAIC Removed ambiguity with CDB0A02 + -- 13 FEB 97 PWB.CTA Corrected lexically ordered string literal + --! + + ---------------------------------------------------------------- CDB0A01_1 + + ---------------------------------------------------------- FDB0A00.Pool1 + + package FDB0A00.Pool1 is + User_Pool : Stack_Heap( 5_000 ); + end FDB0A00.Pool1; + + ---------------------------------------------------------- FDB0A00.Comparator + + with System.Storage_Pools; + package FDB0A00.Comparator is + + function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class ) + return Boolean; + + end FDB0A00.Comparator; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + package body FDB0A00.Comparator is + + function "="( A,B : System.Storage_Pools.Root_Storage_Pool'Class ) + return Boolean is + use type System.Address; + begin + return A'Address = B'Address; + end "="; + + end FDB0A00.Comparator; + + ---------------------------------------------------------------- CDB0A01_2 + + with FDB0A00.Pool1; + package CDB0A01_2 is + + type Cell; + type User_Pool_Tree is access Cell; + + for User_Pool_Tree'Storage_Pool use FDB0A00.Pool1.User_Pool; + + type Cell is record + Data : Character; + Left,Right : User_Pool_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ); + + procedure Traverse( The_Tree : User_Pool_Tree ); + + procedure Defoliate( The_Tree : in out User_Pool_Tree ); + + end CDB0A01_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + with Unchecked_Deallocation; + package body CDB0A01_2 is + procedure Deallocate is new Unchecked_Deallocation(Cell,User_Pool_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out User_Pool_Tree ) is + begin + if On_Tree = null then + On_Tree := new Cell'(Item,null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : User_Pool_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out User_Pool_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + + end CDB0A01_2; + + ---------------------------------------------------------------- CDB0A01_3 + + with FDB0A00.Pool1; + package CDB0A01_3 is + + type Cell; + type System_Pool_Tree is access Cell; + + for System_Pool_Tree'Storage_Size use 2000; + + -- assumptions: Cell is <= 20 storage_units + -- Tree building exercise requires O(15) cells + -- 2000 > 20 * 15 by a generous margin + + type Cell is record + Data: Character; + Left,Right : System_Pool_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ); + + procedure Traverse( The_Tree : System_Pool_Tree ); + + procedure Defoliate( The_Tree : in out System_Pool_Tree ); + + end CDB0A01_3; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + with Unchecked_Deallocation; + package body CDB0A01_3 is + procedure Deallocate is new Unchecked_Deallocation(Cell,System_Pool_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out System_Pool_Tree ) is + begin + if On_Tree = null then + On_Tree := new Cell'(Item,null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : System_Pool_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out System_Pool_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + + end CDB0A01_3; + + ------------------------------------------------------------------ CDB0A01 + + with Report; + with TCTouch; + with FDB0A00.Comparator; + with FDB0A00.Pool1; + with CDB0A01_2; + with CDB0A01_3; + + procedure CDB0A01 is + + Banyan : CDB0A01_2.User_Pool_Tree; + Torrey : CDB0A01_3.System_Pool_Tree; + + use type CDB0A01_2.User_Pool_Tree; + use type CDB0A01_3.System_Pool_Tree; + + Countess : constant String := "Ada Augusta Lovelace"; + Cenosstu : constant String := " AALaaacdeeglostuuv"; + Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA"; + Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD"; + + begin -- Main test procedure. + + Report.Test ("CDB0A01", "Check that a storage pool may be " & + "user_determined, and that storage is " & + "allocated by calling Allocate. Check that " & + "a storage.pool may be specified using " & + "'Storage_Pool and that S'Storage_Pool denotes " & + "the storage pool of the type S" ); + + -- Check that S'Storage_Pool denotes the storage pool for the type S. + + TCTouch.Assert( + FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool, + CDB0A01_2.User_Pool_Tree'Storage_Pool ), + "'Storage_Pool not correct for CDB0A01_2.User_Pool_Tree"); + + TCTouch.Assert_Not( + FDB0A00.Comparator."="(FDB0A00.Pool1.User_Pool, + CDB0A01_3.System_Pool_Tree'Storage_Pool ), + "'Storage_Pool not correct for CDB0A01_3.System_Pool_Tree"); + + -- Check that storage is allocated by calling Allocate. + + for Count in Countess'Range loop + CDB0A01_2.Insert( Countess(Count), Banyan ); + end loop; + TCTouch.Validate(Insertion, "Allocate calls via CDB0A01_2" ); + + for Count in Countess'Range loop + CDB0A01_3.Insert( Countess(Count), Torrey ); + end loop; + TCTouch.Validate("", "Allocate calls via CDB0A01_3" ); + + CDB0A01_2.Traverse(Banyan); + TCTouch.Validate(Cenosstu, "Traversal of Banyan" ); + + CDB0A01_3.Traverse(Torrey); + TCTouch.Validate(Cenosstu, "Traversal of Torrey" ); + + CDB0A01_2.Defoliate(Banyan); + TCTouch.Validate(Deallocation, "Deforestation of Banyan" ); + TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null"); + + CDB0A01_3.Defoliate(Torrey); + TCTouch.Validate("", "Deforestation of Torrey" ); + TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null"); + + Report.Result; + + end CDB0A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdb0a02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,329 ---- + -- CDB0A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that several access types can share the same pool. + -- + -- Check that any exception propagated by Allocate is + -- propagated by the allocator. + -- + -- Check that for an access type S, S'Max_Size_In_Storage_Elements + -- denotes the maximum values for Size_In_Storage_Elements that will + -- be requested via Allocate. + -- + -- TEST DESCRIPTION: + -- After checking correct operation of the tree packages, the limits of + -- the storage pools (first the shared user defined storage pool, then + -- the system storage pool) are intentionally exceeded. The test checks + -- that the correct exception is raised. + -- + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FDB0A00.A (foundation code) + -- CDB0A02.A + -- + -- + -- CHANGE HISTORY: + -- 10 AUG 95 SAIC Initial version + -- 07 MAY 96 SAIC Disambiguated for 2.1 + -- 13 FEB 97 PWB.CTA Reduced minimum allowable + -- Max_Size_In_Storage_Units, for implementations + -- with larger storage units + -- 25 JAN 01 RLB Removed dubious checks on Max_Size_In_Storage_Units; + -- tightened important one. + + --! + + ---------------------------------------------------------- FDB0A00.Pool2 + + package FDB0A00.Pool2 is + Pond : Stack_Heap( 5_000 ); + end FDB0A00.Pool2; + + ---------------------------------------------------------------- CDB0A02_2 + + with FDB0A00.Pool2; + package CDB0A02_2 is + + type Small_Cell; + type Small_Tree is access Small_Cell; + + for Small_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- first usage + + type Small_Cell is record + Data: Character; + Left,Right : Small_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out Small_Tree ); + + procedure Traverse( The_Tree : Small_Tree ); + + procedure Defoliate( The_Tree : in out Small_Tree ); + + procedure TC_Exceed_Pool; + + Pool_Max_Elements : constant := 6000; + -- to guarantee overflow in TC_Exceed_Pool + + end CDB0A02_2; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + with Report; + with Unchecked_Deallocation; + package body CDB0A02_2 is + procedure Deallocate is new Unchecked_Deallocation(Small_Cell,Small_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out Small_Tree ) is + begin + if On_Tree = null then + On_Tree := new Small_Cell'(Item,null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : Small_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out Small_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + + procedure TC_Exceed_Pool is + Wild_Branch : Small_Tree; + begin + for Ever in 1..Pool_Max_Elements loop + Wild_Branch := new Small_Cell'('a', Wild_Branch, Wild_Branch); + TCTouch.Validate("A","Allocating element for overflow"); + end loop; + Report.Failed(" Pool_Overflow not raised on exceeding user pool size"); + exception + when FDB0A00.Pool_Overflow => null; -- anticipated case + when others => + Report.Failed("wrong exception raised in user Exceed_Pool"); + end TC_Exceed_Pool; + + end CDB0A02_2; + + ---------------------------------------------------------------- CDB0A02_3 + + -- This package is essentially identical to CDB0A02_2, except that the size + -- of a cell is significantly larger. This is used to check that different + -- access types may share a single pool + + with FDB0A00.Pool2; + package CDB0A02_3 is + + type Large_Cell; + type Large_Tree is access Large_Cell; + + for Large_Tree'Storage_Pool use FDB0A00.Pool2.Pond; -- second usage + + type Large_Cell is record + Data: Character; + Extra_Data : String(1..2); + Left,Right : Large_Tree; + end record; + + procedure Insert( Item: Character; On_Tree : in out Large_Tree ); + + procedure Traverse( The_Tree : Large_Tree ); + + procedure Defoliate( The_Tree : in out Large_Tree ); + + end CDB0A02_3; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with TCTouch; + with Unchecked_Deallocation; + package body CDB0A02_3 is + procedure Deallocate is new Unchecked_Deallocation(Large_Cell,Large_Tree); + + -- Sort: zeros on the left, ones on the right... + procedure Insert( Item: Character; On_Tree : in out Large_Tree ) is + begin + if On_Tree = null then + On_Tree := new Large_Cell'(Item,(Item,Item),null,null); + elsif Item > On_Tree.Data then + Insert(Item,On_Tree.Right); + else + Insert(Item,On_Tree.Left); + end if; + end Insert; + + procedure Traverse( The_Tree : Large_Tree ) is + begin + if The_Tree = null then + null; -- how very symmetrical + else + Traverse(The_Tree.Left); + TCTouch.Touch(The_Tree.Data); + Traverse(The_Tree.Right); + end if; + end Traverse; + + procedure Defoliate( The_Tree : in out Large_Tree ) is + begin + + if The_Tree.Left /= null then + Defoliate(The_Tree.Left); + end if; + + if The_Tree.Right /= null then + Defoliate(The_Tree.Right); + end if; + + Deallocate(The_Tree); + + end Defoliate; + + end CDB0A02_3; + + ------------------------------------------------------------------ CDB0A02 + + with Report; + with TCTouch; + with System.Storage_Elements; + with CDB0A02_2; + with CDB0A02_3; + with FDB0A00; + + procedure CDB0A02 is + + Banyan : CDB0A02_2.Small_Tree; + Torrey : CDB0A02_3.Large_Tree; + + use type CDB0A02_2.Small_Tree; + use type CDB0A02_3.Large_Tree; + + Countess1 : constant String := "Ada "; + Countess2 : constant String := "Augusta "; + Countess3 : constant String := "Lovelace"; + Cenosstu : constant String := " AALaaacdeeglostuuv"; + Insertion : constant String := "AAAAAAAAAAAAAAAAAAAA" + & "AAAAAAAAAAAAAAAAAAAA"; + Deallocation : constant String := "DDDDDDDDDDDDDDDDDDDD"; + + begin -- Main test procedure. + + Report.Test ("CDB0A02", "Check that several access types can share " & + "the same pool. Check that any exception " & + "propagated by Allocate is propagated by the " & + "allocator. Check that for an access type S, " & + "S'Max_Size_In_Storage_Elements denotes the " & + "maximum values for Size_In_Storage_Elements " & + "that will be requested via Allocate" ); + + -- Check that access types can share the same pool. + + for Count in Countess1'Range loop + CDB0A02_2.Insert( Countess1(Count), Banyan ); + end loop; + + for Count in Countess1'Range loop + CDB0A02_3.Insert( Countess1(Count), Torrey ); + end loop; + + for Count in Countess2'Range loop + CDB0A02_2.Insert( Countess2(Count), Banyan ); + end loop; + + for Count in Countess2'Range loop + CDB0A02_3.Insert( Countess2(Count), Torrey ); + end loop; + + for Count in Countess3'Range loop + CDB0A02_2.Insert( Countess3(Count), Banyan ); + end loop; + + for Count in Countess3'Range loop + CDB0A02_3.Insert( Countess3(Count), Torrey ); + end loop; + + TCTouch.Validate(Insertion, "Allocate calls via CDB0A02_2" ); + + + CDB0A02_2.Traverse(Banyan); + TCTouch.Validate(Cenosstu, "Traversal of Banyan" ); + + CDB0A02_3.Traverse(Torrey); + TCTouch.Validate(Cenosstu, "Traversal of Torrey" ); + + CDB0A02_2.Defoliate(Banyan); + TCTouch.Validate(Deallocation, "Deforestation of Banyan" ); + TCTouch.Assert(Banyan = null, "Banyan Deallocation result not null"); + + CDB0A02_3.Defoliate(Torrey); + TCTouch.Validate(Deallocation, "Deforestation of Torrey" ); + TCTouch.Assert(Torrey = null, "Torrey Deallocation result not null"); + + -- Check that for an access type S, S'Max_Size_In_Storage_Elements + -- denotes the maximum values for Size_In_Storage_Elements that will + -- be requested via Allocate. (Of course, all we can do is check that + -- whatever was requested of Allocate did not exceed the values of the + -- attributes.) + + TCTouch.Assert( FDB0A00.TC_Largest_Request in 1 .. + System.Storage_Elements.Storage_Count'Max ( + CDB0A02_2.Small_Cell'Max_Size_In_Storage_Elements, + CDB0A02_3.Large_Cell'Max_Size_In_Storage_Elements), + "An object of excessive size was allocated. Size: " + & System.Storage_Elements.Storage_Count'Image(FDB0A00.TC_Largest_Request)); + + -- Check that an exception raised in Allocate is propagated by the allocator. + + CDB0A02_2.TC_Exceed_Pool; + + Report.Result; + + end CDB0A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd1001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd1001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd1001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd1001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- CDD1001.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that components of Stream_Element_Array are aliased. (Defect + -- Report 8652/0044). + -- + -- APPLICABILITY CRITERIA: + -- All implementations must attempt to compile this test. + -- + -- For implementations for which Stream_Element'Size is a multiple of + -- System.Storage_Unit, this test must execute. + -- + -- For other implementations, if this test compiles without error messages + -- at compilation, it must bind and execute. + -- + -- PASS/FAIL CRITERIA: + -- For implementations for which Stream_Element'Size is a multiple of + -- System.Storage_Unit, this test must execute, report PASSED, and + -- complete normally, otherwise the test FAILS. + -- + -- For other implementations: + -- PASSING behavior is: + -- this test executes, reports PASSED, and completes normally + -- or + -- this test produces at least one error message at compilation, and + -- the error message is associated with one of the items marked: + -- -- N/A => ERROR. + -- + -- All other behaviors are FAILING. + -- + -- + -- CHANGE HISTORY: + -- 12 FEB 2001 PHL Initial version + -- 15 MAR 2001 RLB Readied for release. + + --! + with Ada.Streams; + use Ada.Streams; + with Report; + use Report; + procedure CDD1001 is + + type Acc is access all Stream_Element; + + A : Stream_Element_Array + (Stream_Element_Offset (Ident_Int (1)) .. + Stream_Element_Offset (Ident_Int (10))); + B : array (A'Range) of Acc; + begin + Test ("CDD1001", + "Check that components of Stream_Element_Array are aliased"); + + for I in A'Range loop + A (I) := Stream_Element (Ident_Int (Integer (I)) * Ident_Int (3)); + end loop; + + for I in B'Range loop + B (I) := A (I)'Access; -- N/A => ERROR. + end loop; + + for I in B'Range loop + if B (I).all /= Stream_Element + (Ident_Int (Integer (I)) * Ident_Int (3)) then + Failed ("Unable to build access values desginating elements " & + "of a Stream_Element_Array"); + end if; + end loop; + + Result; + end CDD1001; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- CDD2001.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the default implementation of Read and Input raise End_Error + -- if the end of stream is reached before the reading of a value is + -- completed. (Defect Report 8652/0045, + -- Technical Corrigendum 13.13.2(35.1/1)). + -- + -- CHANGE HISTORY: + -- 12 FEB 2001 PHL Initial version. + -- 29 JUN 2001 RLB Reformatted for ACATS. + -- + --! + + with Ada.Streams; + use Ada.Streams; + package CDD2001_0 is + + type My_Stream (Size : Stream_Element_Count) is new Root_Stream_Type with + record + First : Stream_Element_Offset := 1; + Last : Stream_Element_Offset := 0; + Contents : Stream_Element_Array (1 .. Size); + end record; + + procedure Clear (Stream : in out My_Stream); + + procedure Read (Stream : in out My_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + procedure Write (Stream : in out My_Stream; Item : in Stream_Element_Array); + + end CDD2001_0; + + package body CDD2001_0 is + + procedure Clear (Stream : in out My_Stream) is + begin + Stream.First := 1; + Stream.Last := 0; + end Clear; + + procedure Read (Stream : in out My_Stream; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + begin + if Item'Length >= Stream.Last - Stream.First + 1 then + Item (Item'First .. Item'First + Stream.Last - Stream.First) := + Stream.Contents (Stream.First .. Stream.Last); + Last := Item'First + Stream.Last - Stream.First; + Stream.First := Stream.Last + 1; + else + Item := Stream.Contents (Stream.First .. + Stream.First + Item'Length - 1); + Last := Item'Last; + Stream.First := Stream.First + Item'Length; + end if; + end Read; + + procedure Write (Stream : in out My_Stream; + Item : in Stream_Element_Array) is + begin + Stream.Contents (Stream.Last + 1 .. Stream.Last + Item'Length) := Item; + Stream.Last := Stream.Last + Item'Length; + end Write; + + end CDD2001_0; + + with Ada.Exceptions; + use Ada.Exceptions; + with CDD2001_0; + use CDD2001_0; + with Io_Exceptions; + use Io_Exceptions; + with Report; + use Report; + procedure CDD2001 is + + subtype Int is Integer range -20 .. 20; + + type R (D : Int) is + record + C1 : Character := Ident_Char ('a'); + case D is + when 0 .. 20 => + C2 : String (1 .. D) := (others => Ident_Char ('b')); + when others => + C3, C4 : Float := Float (-D); + end case; + end record; + + S : aliased My_Stream (200); + + begin + Test + ("CDD2001", + "Check that the default implementation of Read and Input " & + "raise End_Error if the end of stream is reached before the " & + "reading of a value is completed"); + + Read: + declare + X : R (Ident_Int (13)); + begin + Clear (S); + + -- A complete object. + R'Write (S'Access, X); + X.C1 := Ident_Char ('A'); + X.C2 := (others => Ident_Char ('B')); + R'Read (S'Access, X); + if X.C1 /= Ident_Char ('a') or X.C2 /= + (1 .. 13 => Ident_Char ('b')) then + Failed ("Read did not produce the expected result"); + end if; + + Clear (S); + + -- Not enough data. + Character'Write (S'Access, 'a'); + String'Write (S'Access, "bbb"); + + begin + R'Read (S'Access, X); + Failed + ("No exception raised when the end of stream is reached " & + "before the reading of a value is completed - 1"); + exception + when End_Error => + null; + when E: others => + Failed ("Wrong Exception " & Exception_Name (E) & + " - " & Exception_Information (E) & + " - " & Exception_Message (E) & " - 1"); + end; + + end Read; + + Input: + declare + X : R (Ident_Int (-11)); + begin + Clear (S); + + -- A complete object. + R'Output (S'Access, X); + X.C1 := Ident_Char ('A'); + X.C3 := 4.0; + X.C4 := 5.0; + X := R'Input (S'Access); + if X.C1 /= Ident_Char ('a') or X.C3 /= 11.0 or X.C4 /= 11.0 then + Failed ("Input did not produce the expected result"); + end if; + + Clear (S); + + -- Not enough data. + Integer'Output (S'Access, Ident_Int (-11)); -- The discriminant + Character'Output (S'Access, 'a'); + Float'Output (S'Access, 11.0); + + begin + X := R'Input (S'Access); + Failed + ("No exception raised when the end of stream is reached " & + "before the reading of a value is completed - 2"); + exception + when End_Error => + null; + when E: others => + Failed ("Wrong exception " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 2"); + end; + + end Input; + + Result; + end CDD2001; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a01.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,379 ---- + -- CDD2A01.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Read and Write attributes for a type extension are created + -- from the parent type's attribute (which may be user-defined) and those + -- for the extension components. Also check that the default Input and + -- Output attributes are used for a type extension, even if the parent + -- type's attribute is user-defined. (Defect Report 8652/0040, + -- as reflected in Technical Corrigendum 1, penultimate sentence of + -- 13.13.2(9/1) and 13.13.2(25/1)). + -- + -- CHANGE HISTORY: + -- 30 JUL 2001 PHL Initial version. + -- 5 DEC 2001 RLB Reformatted for ACATS. + -- + --! + with Ada.Streams; + use Ada.Streams; + with FDD2A00; + use FDD2A00; + with Report; + use Report; + procedure CDD2A01 is + + Input_Output_Error : exception; + + type Int is range 1 .. 1000; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is tagged + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + X : Parent (1, 1, True); + begin + raise Input_Output_Error; + return X; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + raise Input_Output_Error; + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + + type Derived1 is new Parent with + record + C3 : Int; + end record; + + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False) with + record + C3 : Int; + end record; + + begin + Test ("CDD2A01", + "Check that the Read and Write attributes for a type " & + "extension are created from the parent type's " & + "attribute (which may be user-defined) and those for the " & + "extension components; also check that the default input " & + "and output attributes are used for a type extension, even " & + "if the parent type's attribute is user-defined"); + + Test1: + declare + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + Y1 : Derived1 := (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (100), + C3 => Int (Ident_Int (88))); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + X1.C3 := Int (Ident_Int (99)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call parent type's Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + + if X2 /= (D1 => 2, + D2 => 5, + B => True, + S => Str (Ident_Str ("bcde")), + C2 => Float (Ident_Int (4)), + C3 => Int (Ident_Int (99))) then + Failed + ("Inherited Read and Write are not inverses of each other - 1"); + end if; + + begin + Derived1'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 4, Input => 0, Output => 0) then + Failed ("Error writing extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 2"); + end if; + exception + when Input_Output_Error => + Failed ("Did call inherited Output - 2"); + end; + + begin + declare + Y2 : Derived1 := Derived1'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Error reading extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 2"); + end if; + if Y2 /= (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (88))) then + Failed + ("Input and Output are not inverses of each other - 2"); + end if; + end; + exception + when Input_Output_Error => + Failed ("Did call inherited Input - 2"); + end; + + end Test1; + + Test2: + declare + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + Y1 : Derived2 := (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (200), + C3 => Int (Ident_Int (77))); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + X1.C3 := Int (Ident_Int (666)); + + Derived2'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 4, Write => 5, Input => 0, Output => 0) then + Failed ("Error writing extension components - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 3, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 3"); + end if; + + Derived2'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 5, Write => 5, Input => 0, Output => 0) then + Failed ("Error reading extension components - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 3, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 3"); + end if; + + if X2 /= (D => 7, + S => Str (Ident_Str ("g")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (666))) then + Failed ("Read and Write are not inverses of each other - 3"); + end if; + + begin + Derived2'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 5, Write => 7, Input => 0, Output => 0) then + Failed ("Error writing extension components - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 4, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 4"); + end if; + exception + when Input_Output_Error => + Failed ("Did call inherited Output - 4"); + end; + + begin + declare + Y2 : Derived2 := Derived2'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 7, Write => 7, Input => 0, Output => 0) then + Failed ("Error reading extension components - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 4"); + end if; + if Y2 /= (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (7), + C3 => Int (Ident_Int (77))) then + Failed + ("Input and Output are not inverses of each other - 4"); + end if; + end; + exception + when Input_Output_Error => + Failed ("Did call inherited Input - 4"); + end; + + end Test2; + + Result; + end CDD2A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a02.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,345 ---- + -- CDD2A02.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Read, Write, Input, and Output attributes are inherited + -- for untagged derived types. (Defect Report 8652/0040, + -- as reflected in Technical Corrigendum 1, 13.13.2(8.1/1) and + -- 13.13.2(25/1)). + -- + -- CHANGE HISTORY: + -- 30 JUL 2001 PHL Initial version. + -- 5 DEC 2001 RLB Reformatted for ACATS. + -- + --! + with Ada.Streams; + use Ada.Streams; + with FDD2A00; + use FDD2A00; + with Report; + use Report; + procedure CDD2A02 is + + type Int is range 1 .. 10; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + D1, D2 : Int; + B : Boolean; + begin + Int'Read (Stream, D2); + Boolean'Read (Stream, B); + Int'Read (Stream, D1); + + declare + Item : Parent (D1 => D1, D2 => D2, B => B); + begin + Parent'Read (Stream, Item); + return Item; + end; + + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + Int'Write (Stream, Item.D2); + Boolean'Write (Stream, Item.B); + Int'Write (Stream, Item.D1); + Parent'Write (Stream, Item); + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + + begin + Test ("CDD2A02", "Check that the Read, Write, Input, and Output " & + "attributes are inherited for untagged derived types"); + + Test1: + declare + type Derived1 is new Parent; + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), B => Ident_Bool (True)); + Y1 : Derived1 := (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (100)); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 0, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 0, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + + if X2 /= (D1 => 2, + D2 => 5, + B => True, + S => Str (Ident_Str ("bcde")), + C2 => Float (Ident_Int (4))) then + Failed + ("Inherited Read and Write are not inverses of each other - 1"); + end if; + + Derived1'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 2, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 1) then + Failed ("Didn't call inherited Output - 2"); + end if; + + declare + Y2 : Derived1 := Derived1'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 1, Output => 1) then + Failed ("Didn't call inherited Input - 2"); + end if; + + if Y2 /= (D1 => 3, + D2 => 6, + B => False, + S => Str (Ident_Str ("3456")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Input and Output are not inverses of each other - 2"); + end if; + end; + end Test1; + + Test2: + declare + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False); + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + Y1 : Derived2 := (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (200)); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + + Derived2'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 3, Input => 1, Output => 1) then + Failed ("Didn't call inherited Write - 3"); + end if; + + Derived2'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 3"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 3, Input => 1, Output => 1) then + Failed ("Didn't call inherited Read - 3"); + end if; + + if X2 /= (D => 7, + S => Str (Ident_Str ("g")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Read and Write are not inverses of each other - 3"); + end if; + + Derived2'Output (S'Access, Y1); + if Int_Ops.Get_Counts /= + (Read => 2, Write => 4, Input => 0, Output => 0) then + Failed ("Error writing discriminants - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 3, Write => 4, Input => 1, Output => 2) then + Failed ("Didn't call inherited Output - 4"); + end if; + + declare + Y2 : Derived2 := Derived2'Input (S'Access); + begin + if Int_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 0, Output => 0) then + Failed ("Error reading discriminants - 4"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 4, Write => 4, Input => 2, Output => 2) then + Failed ("Didn't call inherited Input - 4"); + end if; + + if Y2 /= (D => 8, + S => Str (Ident_Str ("8")), + C1 => Ident_Int (7)) then + Failed + ("Inherited Input and Output are not inverses of each other - 4"); + end if; + end; + end Test2; + + Result; + end CDD2A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cdd2a03.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,325 ---- + -- CDD2A03.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the default Read and Write attributes for a limited type + -- extension are created from the parent type's attribute (which may be + -- user-defined) and those for the extension components, if the extension + -- components are non-limited or have user-defined attributes. Check that + -- such limited type extension attributes are callable (Defect Report + -- 8652/0040, as reflected in Technical Corrigendum 1, penultimate sentence + -- of 13.13.2(9/1) and 13.13.2(36/1)). + -- + -- CHANGE HISTORY: + -- 1 AUG 2001 PHL Initial version. + -- 3 DEC 2001 RLB Reformatted for ACATS. + -- + --! + with Ada.Streams; + use Ada.Streams; + with FDD2A00; + use FDD2A00; + with Report; + use Report; + procedure CDD2A03 is + + Input_Output_Error : exception; + + type Int is range 1 .. 1000; + type Str is array (Int range <>) of Character; + + procedure Read (Stream : access Root_Stream_Type'Class; + Item : out Int'Base); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base); + function Input (Stream : access Root_Stream_Type'Class) return Int'Base; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base); + + for Int'Read use Read; + for Int'Write use Write; + for Int'Input use Input; + for Int'Output use Output; + + + type Lim is limited + record + C : Int; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim); + function Input (Stream : access Root_Stream_Type'Class) return Lim; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim); + + for Lim'Read use Read; + for Lim'Write use Write; + for Lim'Input use Input; + for Lim'Output use Output; + + + type Parent (D1, D2 : Int; B : Boolean) is tagged limited + record + S : Str (D1 .. D2); + case B is + when False => + C1 : Integer; + when True => + C2 : Float; + end case; + end record; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent); + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent); + function Input (Stream : access Root_Stream_Type'Class) return Parent; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent); + + for Parent'Read use Read; + for Parent'Write use Write; + for Parent'Input use Input; + for Parent'Output use Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Int) is + begin + Integer'Read (Stream, Integer (Item)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Write (Stream, Integer (Item)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Int is + begin + return Int (Integer'Input (Stream)); + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Int) is + begin + Integer'Output (Stream, Integer (Item)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Lim) is + begin + Integer'Read (Stream, Integer (Item.C)); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Write (Stream, Integer (Item.C)); + end Actual_Write; + + function Actual_Input (Stream : access Root_Stream_Type'Class) return Lim is + Result : Lim; + begin + Result.C := Int (Integer'Input (Stream)); + return Result; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Lim) is + begin + Integer'Output (Stream, Integer (Item.C)); + end Actual_Output; + + + procedure Actual_Read + (Stream : access Root_Stream_Type'Class; Item : out Parent) is + begin + case Item.B is + when False => + Item.C1 := 7; + when True => + Float'Read (Stream, Item.C2); + end case; + Str'Read (Stream, Item.S); + end Actual_Read; + + procedure Actual_Write + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + case Item.B is + when False => + null; -- Don't write C1 + when True => + Float'Write (Stream, Item.C2); + end case; + Str'Write (Stream, Item.S); + end Actual_Write; + + function Actual_Input + (Stream : access Root_Stream_Type'Class) return Parent is + X : Parent (1, 1, True); + begin + raise Input_Output_Error; + return X; + end Actual_Input; + + procedure Actual_Output + (Stream : access Root_Stream_Type'Class; Item : Parent) is + begin + raise Input_Output_Error; + end Actual_Output; + + package Int_Ops is new Counting_Stream_Ops (T => Int'Base, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Lim_Ops is new Counting_Stream_Ops (T => Lim, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + package Parent_Ops is + new Counting_Stream_Ops (T => Parent, + Actual_Write => Actual_Write, + Actual_Input => Actual_Input, + Actual_Read => Actual_Read, + Actual_Output => Actual_Output); + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Int'Base) + renames Int_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Int'Base + renames Int_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Int'Base) + renames Int_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Lim) + renames Lim_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Lim + renames Lim_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Lim) + renames Lim_Ops.Output; + + procedure Read (Stream : access Root_Stream_Type'Class; Item : out Parent) + renames Parent_Ops.Read; + procedure Write (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Write; + function Input (Stream : access Root_Stream_Type'Class) return Parent + renames Parent_Ops.Input; + procedure Output (Stream : access Root_Stream_Type'Class; Item : Parent) + renames Parent_Ops.Output; + + type Derived1 is new Parent with + record + C3 : Int; + end record; + + type Derived2 (D : Int) is new Parent (D1 => D, + D2 => D, + B => False) with + record + C3 : Lim; + end record; + + begin + Test ("CDD2A03", + "Check that the default Read and Write attributes for a limited " & + "type extension are created from the parent type's " & + "attribute (which may be user-defined) and those for the " & + "extension components, if the extension components are " & + "non-limited or have user-defined attributes; check that such " & + "limited type extension attributes are callable"); + + Test1: + declare + S : aliased My_Stream (1000); + X1 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + X2 : Derived1 (D1 => Int (Ident_Int (2)), + D2 => Int (Ident_Int (5)), + B => Ident_Bool (True)); + begin + X1.S := Str (Ident_Str ("bcde")); + X1.C2 := Float (Ident_Int (4)); + X1.C3 := Int (Ident_Int (99)); + + Derived1'Write (S'Access, X1); + if Int_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call parent type's Write - 1"); + end if; + + Derived1'Read (S'Access, X2); + if Int_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 1"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 1"); + end if; + end Test1; + + Test2: + declare + S : aliased My_Stream (1000); + X1 : Derived2 (D => Int (Ident_Int (7))); + X2 : Derived2 (D => Int (Ident_Int (7))); + begin + X1.S := Str (Ident_Str ("g")); + X1.C1 := Ident_Int (4); + X1.C3.C := Int (Ident_Int (666)); + + Derived2'Write (S'Access, X1); + if Lim_Ops.Get_Counts /= + (Read => 0, Write => 1, Input => 0, Output => 0) then + Failed ("Error writing extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 1, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Write - 2"); + end if; + + Derived2'Read (S'Access, X2); + if Lim_Ops.Get_Counts /= + (Read => 1, Write => 1, Input => 0, Output => 0) then + Failed ("Error reading extension components - 2"); + end if; + if Parent_Ops.Get_Counts /= + (Read => 2, Write => 2, Input => 0, Output => 0) then + Failed ("Didn't call inherited Read - 2"); + end if; + end Test2; + + Result; + end CDD2A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cde0001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cde0001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cd/cde0001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cd/cde0001.a 2003-10-27 11:28:56.000000000 +0000 *************** *** 0 **** --- 1,324 ---- + -- CDE0001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the following names can be used in the declaration of a + -- generic formal parameter (object, array type, or access type) without + -- causing freezing of the named type: + -- (1) The name of a private type, + -- (2) A name that denotes a subtype of a private type, and + -- (3) A name that denotes a composite type with a subcomponent of a + -- private type (or subtype). + -- Check for untagged and tagged types. + -- + -- TEST DESCRIPTION: + -- This transition test defines private and limited private types, + -- subtypes of these private types, records and arrays of both types and + -- subtypes, a tagged type and a private extension. + -- This test creates examples where the above types are used in the + -- definition of several generic formal type parameters (object, array + -- type, or access type) in both visible and private parts. These + -- visible and private generic packages are instantiated in the body of + -- the public child and the private child, respectively. + -- The main program utilizes the functions declared in the public child + -- to verify results of the instantiations. + -- + -- Inspired by B74103F.ADA. + -- + -- + -- CHANGE HISTORY: + -- 12 Mar 96 SAIC Initial version for ACVC 2.1. + -- 05 Oct 96 SAIC ACVC 2.1: Added pragma Elaborate for CDE0001. + -- 21 Nov 98 RLB Added pragma Elaborate for CDE0001 to CDE0001_3. + --! + + package CDE0001_0 is + + subtype Small_Int is Integer range 1 .. 2; + + type Private_Type is private; + type Limited_Private is limited private; + + subtype Private_Subtype is Private_Type; + subtype Limited_Private_Subtype is Limited_Private; + + type Array_Of_LP_Subtype is array (1..2) of Limited_Private_Subtype; + + type Rec_Of_Limited_Private is + record + C1 : Limited_Private; + end record; + + type Rec_Of_Private_SubType is + record + C1 : Private_SubType; + end record; + + type Tag_Type is tagged + record + C1 : Small_Int; + end record; + + type New_TagType is new Tag_Type with private; + + generic + + Formal_Obj01 : in out Private_Type; -- Formal objects defined + Formal_Obj02 : in out Limited_Private; -- by names of private + Formal_Obj03 : in out Private_Subtype; -- types, names that + Formal_Obj04 : in out Limited_Private_Subtype; -- denotes subtypes of + Formal_Obj05 : in out New_TagType; -- the private types. + + package CDE0001_1 is + procedure Assign_Objects; + + end CDE0001_1; + + private + + generic + -- Formal array types of a private type, a composite type with a + -- subcomponent of a private type. + + type Formal_Arr01 is array (Small_Int) of Private_Type; + type Formal_Arr02 is array (Small_Int) of Rec_Of_Limited_Private; + + -- Formal access types of composite types with a subcomponent of + -- a private subtype. + + type Formal_Acc01 is access Rec_Of_Private_Subtype; + type Formal_Acc02 is access Array_Of_LP_Subtype; + + package CDE0001_2 is + + procedure Assign_Arrays (P1 : out Formal_Arr01; + P2 : out Formal_Arr02); + + procedure Assign_Access (P1 : out Formal_Acc01; + P2 : out Formal_Acc02); + + end CDE0001_2; + + ---------------------------------------------------------- + type Private_Type is range 1 .. 10; + type Limited_Private is (Eh, Bee, Sea, Dee); + type New_TagType is new Tag_Type with + record + C2 : Private_Type; + end record; + + end CDE0001_0; + + --==================================================================-- + + package body CDE0001_0 is + + package body CDE0001_1 is + + procedure Assign_Objects is + begin + Formal_Obj01 := Private_Type'First; + Formal_Obj02 := Limited_Private'Last; + Formal_Obj03 := Private_Subtype'Last; + Formal_Obj04 := Limited_Private_Subtype'First; + Formal_Obj05 := New_TagType'(C1 => 2, C2 => Private_Type'Last); + + end Assign_Objects; + + end CDE0001_1; + + --===========================================================-- + + package body CDE0001_2 is + + procedure Assign_Arrays (P1 : out Formal_Arr01; + P2 : out Formal_Arr02) is + begin + P1(1) := Private_Type'Pred(Private_Type'Last); + P1(2) := Private_Type'Succ(Private_Type'First); + P2(1).C1 := Limited_Private'Succ(Limited_Private'First); + P2(2).C1 := Limited_Private'Pred(Limited_Private'Last); + + end Assign_Arrays; + + ----------------------------------------------------------------- + procedure Assign_Access (P1 : out Formal_Acc01; + P2 : out Formal_Acc02) is + begin + P1 := new Rec_Of_Private_Subtype'(C1 => Private_Subtype'Last); + P2 := new Array_Of_LP_Subtype'(Eh, Dee); + + end Assign_Access; + + end CDE0001_2; + + end CDE0001_0; + + --==================================================================-- + + -- The following private child package instantiates its parent private generic + -- package. + + with CDE0001_0; + pragma Elaborate (CDE0001_0); -- So generic unit can be instantiated. + private + package CDE0001_0.CDE0001_3 is + + type Arr01 is array (Small_Int) of Private_Type; + type Arr02 is array (Small_Int) of Rec_Of_Limited_Private; + type Acc01 is access Rec_Of_Private_Subtype; + type Acc02 is access Array_Of_LP_Subtype; + + package Formal_Types_Pck is new CDE0001_2 (Arr01, Arr02, Acc01, Acc02); + + Arr01_Obj : Arr01; + Arr02_Obj : Arr02; + Acc01_Obj : Acc01; + Acc02_Obj : Acc02; + + end CDE0001_0.CDE0001_3; + + --==================================================================-- + + package CDE0001_0.CDE0001_4 is + + -- The following functions check the private types defined in the parent + -- and the private child package from within the client program. + + function Verify_Objects return Boolean; + + function Verify_Arrays return Boolean; + + function Verify_Access return Boolean; + + end CDE0001_0.CDE0001_4; + + --==================================================================-- + + with CDE0001_0.CDE0001_3; -- private sibling. + + pragma Elaborate (CDE0001_0.CDE0001_3); + + package body CDE0001_0.CDE0001_4 is + + Obj1 : Private_Type := 2; + Obj2 : Limited_Private := Bee; + Obj3 : Private_Subtype := 3; + Obj4 : Limited_Private_Subtype := Sea; + Obj5 : New_TagType := (1, 5); + + -- Instantiate the generic package declared in the visible part of + -- the parent. + + package Formal_Obj_Pck is new CDE0001_1 (Obj1, Obj2, Obj3, Obj4, Obj5); + + --------------------------------------------------- + function Verify_Objects return Boolean is + Result : Boolean := False; + begin + if Obj1 = 1 and + Obj2 = Dee and + Obj3 = 10 and + Obj4 = Eh and + Obj5.C1 = 2 and + Obj5.C2 = 10 then + Result := True; + end if; + + return Result; + + end Verify_Objects; + + --------------------------------------------------- + function Verify_Arrays return Boolean is + Result : Boolean := False; + begin + if CDE0001_0.CDE0001_3.Arr01_Obj(1) = 9 and + CDE0001_0.CDE0001_3.Arr01_Obj(2) = 2 and + CDE0001_0.CDE0001_3.Arr02_Obj(1).C1 = Bee and + CDE0001_0.CDE0001_3.Arr02_Obj(2).C1 = Sea then + Result := True; + end if; + + return Result; + + end Verify_Arrays; + + --------------------------------------------------- + function Verify_Access return Boolean is + Result : Boolean := False; + begin + if CDE0001_0.CDE0001_3.Acc01_Obj.C1 = 10 and + CDE0001_0.CDE0001_3.Acc02_Obj(1) = Eh and + CDE0001_0.CDE0001_3.Acc02_Obj(2) = Dee then + Result := True; + end if; + + return Result; + + end Verify_Access; + + begin + + Formal_Obj_Pck.Assign_Objects; + + CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Arrays + (CDE0001_0.CDE0001_3.Arr01_Obj, CDE0001_0.CDE0001_3.Arr02_Obj); + CDE0001_0.CDE0001_3.Formal_Types_Pck.Assign_Access + (CDE0001_0.CDE0001_3.Acc01_Obj, CDE0001_0.CDE0001_3.Acc02_Obj); + + end CDE0001_0.CDE0001_4; + + --==================================================================-- + + with Report; + with CDE0001_0.CDE0001_4; + + procedure CDE0001 is + + begin + + Report.Test ("CDE0001", "Check that the name of the private type, a " & + "name that denotes a subtype of the private type, or a " & + "name that denotes a composite type with a subcomponent " & + "of a private type can be used in the declaration of a " & + "generic formal type parameter without causing freezing " & + "of the named type"); + + if not CDE0001_0.CDE0001_4.Verify_Objects then + Report.Failed ("Wrong values for formal objects"); + end if; + + if not CDE0001_0.CDE0001_4.Verify_Arrays then + Report.Failed ("Wrong values for formal array types"); + end if; + + if not CDE0001_0.CDE0001_4.Verify_Access then + Report.Failed ("Wrong values for formal access types"); + end if; + + Report.Result; + + end CDE0001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- CE2102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL + -- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE SEQUENTIAL_IO. + + -- A) OPENED FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- DLD 08/10/82 + -- JBG 02/22/84 + -- SPW 07/29/87 SPLIT CASE FOR UNOPENED FILES INTO CE2102L.ADA. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102A IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER); + USE SEQ_IO; + TEST_FILE_ONE : SEQ_IO.FILE_TYPE; + + BEGIN + + TEST ("CE2102A", "CHECK THAT STATUS_ERROR IS RAISED WHEN " & + "PERFORMING ILLEGAL OPERATIONS ON OPENED FILES " & + "OF TYPE SEQUENTIAL_IO"); + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + + -- CHECK THAT OPEN STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY OPEN + + BEGIN + OPEN (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " & + "ALREADY OPEN - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 1"); + END; + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " & + "ALREADY OPEN - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 2"); + END; + + -- CHECK THAT CREATE STATEMENT RAISES EXCEPTION WHEN FILE + -- IS ALREADY OPEN + + BEGIN + CREATE (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " & + "FILE IS USED IN A CREATE - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 1"); + END; + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " & + "FILE IS USED IN A CREATE - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2"); + END; + + --DELETE TEST FILE + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF EXTERNAL FILE APPEARS NOT " & + "TO BE SUPPORTED"); + + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "FOR DELETE"); + END; + + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED FOR CREATE " & + "WITH OUT_FILE MODE"); + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED FOR CREATE " & + "WITH OUT_FILE MODE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CREATE"); + END; + + RESULT; + END CE2102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- CE2102B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL + -- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE DIRECT_IO. + + -- A) OPENED FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO THOSE IMPLEMENTATIONS WHICH + -- SUPPORT CREATE WITH OUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- DLD 08/10/82 + -- SPS 11/03/82 + -- JBG 02/22/84 + -- SPW 08/13/87 SPLIT CASE FOR UNOPENED FILES INTO CE2102M.ADA. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102B IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER); + USE DIR_IO; + TEST_FILE_ONE : DIR_IO.FILE_TYPE; + + BEGIN + + TEST ("CE2102B", "CHECK THAT STATUS_ERROR IS RAISED WHEN " & + "PERFORMING ILLEGAL OPERATIONS ON FILES " & + "OF TYPE DIRECT_IO"); + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + + -- CHECK THAT OPEN STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY OPEN + + BEGIN + OPEN (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " & + "ALREADY OPEN - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 1"); + END; + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " & + "ALREADY OPEN - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 2"); + END; + + BEGIN + OPEN (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN FILE IS " & + "ALREADY OPEN - 3"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 3"); + END; + + -- CHECK THAT CREATE STATEMENT RAISES EXCEPTION WHEN FILE IS ALREADY + -- OPEN + + BEGIN + CREATE (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " & + "FILE IS USED IN A CREATE - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 1"); + END; + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " & + "FILE IS USED IN A CREATE - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2"); + END; + + BEGIN + CREATE (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN OPEN " & + "FILE IS USED IN A CREATE - 3"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 3"); + END; + + --DELETE TEST FILE + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF EXTERNAL FILE APPEARS NOT " & + "TO BE SUPPORTED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR DELETE"); + END; + + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED FOR CREATE " & + "WITH OUT_FILE MODE"); + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED FOR CREATE " & + "WITH OUT_FILE MODE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CREATE"); + END; + + RESULT; + + END CE2102B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102c.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- CE2102C.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NAME_ERROR IS RAISED WHEN THE NAME STRING DOES NOT + -- IDENTIFY AN EXTERNAL FILE FOR AN OPEN OR CREATE OPERATION FOR + -- SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL TEMPORARY FILES. + + -- HISTORY: + -- SPS 08/26/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- JRK 11/30/84 CHANGED TO .TST TEST. + -- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2102H-B.TST. + -- SPW 08/25/87 CORRECTED EXCEPTION HANDLING. + -- BCB 09/28/88 ADDED EXCEPTION HANDLERS FOR DELETE STATEMENTS. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102C IS + + NAME1 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME1"; + -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY) + -- CONTAINS INVALID CHARACTERS OR IS TOO LONG. + + NAME2 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME2"; + -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY) + -- CONTAINS A WILD CARD CHARACTER OR IS TOO LONG. + + BEGIN + + TEST ("CE2102C", "CHECK THAT NAME_ERROR IS RAISED BY OPEN AND " & + "CREATE WHEN NAME DOES NOT IDENTIFY AN " & + "EXTERNAL FILE FOR SEQUENTIAL_IO"); + + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + BEGIN + + -- CHECK WHETHER CREATE RAISES USE_ERROR + + BEGIN + CREATE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("TEMPORARY SEQUENTIAL FILES WITH " & + "OUT_FILE MODE NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE"); + RAISE INCOMPLETE; + END; + CLOSE (FILE1); + + BEGIN + CREATE(FILE1, OUT_FILE, NAME1); + FAILED ("NAME_ERROR NOT RAISED - CREATE SEQ 1"); + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - CREATE SEQ 1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CREATE SEQ 1"); + END; + + BEGIN + CREATE (FILE1, OUT_FILE, NAME2); + FAILED("NAME_ERROR NOT RAISED - CREATE SEQ 2"); + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - CREATE SEQ 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CREATE SEQ 2"); + END; + + -- CHECK WHETHER OPEN RAISES NAME_ERROR IN THE CASE OF A LEGAL FILE + -- NAME BUT A NON-EXISTENT FILE. + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + FAILED("NAME_ERROR NOT RAISED - OPEN SEQ"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - OPEN SEQ"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - OPEN SEQ"); + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CE2102D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE + -- IMPLEMENTATION FOR SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT IN_FILE FOR CREATE FOR SEQUENTIAL_IO. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102D IS + BEGIN + + TEST ("CE2102D", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR SEQUENTIAL_IO"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + BEGIN + CREATE (FILE1, IN_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE2102D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CE2102E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE + -- IMPLEMENTATION FOR SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OUT_FILE FOR CREATE FOR SEQUENTIAL_IO. + + -- HISTORY: + -- SPS 08/26/82 + -- JBG 06/04/84 + -- EG 05/08/85 + -- TBN 07/23/87 COMPLETELY REVISED TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102E IS + BEGIN + + TEST ("CE2102E", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR SEQUENTIAL_IO"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + BEGIN + CREATE (FILE1, OUT_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE2102E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- CE2102F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY + -- THE IMPLEMENTATION FOR DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT INOUT_FILE FOR CREATE FOR DIRECT FILES. + + -- HISTORY: + -- SPS 08/26/82 + -- JBG 06/04/84 + -- TBN 07/23/87 COMPLETELY REVISED TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102F IS + BEGIN + + TEST ("CE2102F", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "INOUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR DIRECT_IO"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + BEGIN + CREATE (FILE1, INOUT_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE INOUT_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE2102F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CE2102G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT + -- SUPPORT RESET FOR SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- SPS 08/27/82 + -- JBG 06/04/84 + -- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2102K.ADA. + -- TBN 09/15/87 COMPLETELY REVISED TEST. + + WITH SEQUENTIAL_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2102G IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2102G", "CHECK THAT USE_ERROR IS RAISED IF AN " & + "IMPLEMENTATION DOES NOT SUPPORT RESET FOR " & + "SEQUENTIAL_IO"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FILE1 : FILE_TYPE; + INT1 : INTEGER := IDENT_INT(1); + INT2 : INTEGER := 2; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " & + "SEQUENTIAL FILE WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " & + "SEQUENTIAL FILE WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, INT2); + BEGIN + RESET (FILE1, IN_FILE); + COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS ALLOWED"); + BEGIN + READ (FILE1, INT1); + IF INT1 /= IDENT_INT(2) THEN + FAILED ("RESETTING FROM OUT_FILE TO IN_FILE " & + "AFFECTED DATA"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "READING FROM FILE"); + END; + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS NOT " & + "ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM OUT_FILE TO IN_FILE"); + END; + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " & + "SEQUENTIAL FILE WITH IN_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE1, OUT_FILE); + COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS NOT " & + "ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM IN_FILE TO OUT_FILE"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102h.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + -- CE2102H.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NAME_ERROR IS RAISED WHEN THE NAME STRING DOES NOT + -- IDENTIFY AN EXTERNAL FILE FOR AN OPEN OR CREATE OPERATION FOR + -- DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH INOUT_FILE MODE FOR TEMPORARY DIRECT FILES. + + -- HISTORY: + -- TBN 02/12/86 + -- SPW 08/26/87 CORRECTED EXCEPTION HANDLING. + -- BCB 09/28/88 ADDED EXCEPTION HANDLERS FOR DELETE STATEMENTS. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102H IS + + NAME1 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME1"; + -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY) + -- CONTAINS INVALID CHARACTERS OR IS TOO LONG. + + NAME2 : CONSTANT STRING := "$ILLEGAL_EXTERNAL_FILE_NAME2"; + -- AN ILLEGAL EXTERNAL FILE NAME THAT EITHER (PREFERABLY) + -- CONTAINS A WILD CARD CHARACTER OR IS TOO LONG. + + BEGIN + + TEST ("CE2102H", "CHECK THAT NAME_ERROR IS RAISED BY OPEN AND " & + "CREATE WHEN NAME DOES NOT IDENTIFY AN " & + "EXTERNAL FILE FOR DIRECT_IO"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + BEGIN + + -- CHECK WHETHER CREATE RAISES USE_ERROR + + BEGIN + CREATE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("TEMPORARY DIRECT FILES WITH " & + "INOUT_FILE MODE NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE"); + RAISE INCOMPLETE; + END; + CLOSE (FILE1); + + BEGIN + CREATE(FILE1, OUT_FILE, NAME1); + FAILED ("NAME_ERROR NOT RAISED - CREATE DIR 1"); + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - CREATE DIR 1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CREATE DIR 1"); + END; + + BEGIN + CREATE (FILE1, OUT_FILE, NAME2); + FAILED("NAME_ERROR NOT RAISED - CREATE DIR 2"); + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - CREATE DIR 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CREATE DIR 2"); + END; + + -- CHECK WHETHER OPEN RAISES NAME_ERROR IN THE CASE OF A LEGAL FILE NAME + -- BUT A NON-EXISTENT FILE. + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + FAILED("NAME_ERROR NOT RAISED - OPEN DIR"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED - OPEN DIR"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - OPEN DIR"); + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CE2102I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY + -- THE IMPLEMENTATION FOR DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT IN_FILE FOR CREATE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102I IS + BEGIN + + TEST ("CE2102I", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR DIRECT_IO"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + BEGIN + CREATE (FILE1, IN_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE2102I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102j.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- CE2102J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY + -- THE IMPLEMENTATION FOR DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OUT_FILE FOR CREATE FOR DIRECT FILES. + + -- HISTORY: + -- SPS 08/26/82 + -- JBG 06/04/84 + -- EG 05/08/85 + -- TBN 07/23/87 COMPLETELY REVISED TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102J IS + BEGIN + + TEST ("CE2102J", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR DIRECT_IO"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + BEGIN + CREATE (FILE1, OUT_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE2102J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102k.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,248 ---- + -- CE2102K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT + -- SUPPORT RESET FOR DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- TBN 02/12/86 CREATED ORIGINAL TEST. + -- TBN 09/15/87 COMPLETELY REVISED TEST. + + WITH DIRECT_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2102K IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2102K", "CHECK THAT USE_ERROR IS RAISED IF AN " & + "IMPLEMENTATION DOES NOT SUPPORT RESET FOR " & + "DIRECT_IO"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INT1 : INTEGER := IDENT_INT(1); + INT2 : INTEGER := 2; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " & + "DIRECT FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " & + "DIRECT FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, INT2); + + -- RESETTING FROM OUT_FILE TO IN_FILE. + + BEGIN + RESET (FILE1, IN_FILE); + COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS ALLOWED"); + BEGIN + READ (FILE1, INT1); + IF INT1 /= IDENT_INT(2) THEN + FAILED ("RESETTING FROM OUT_FILE TO IN_FILE " & + "AFFECTED DATA"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "READING FROM FILE - 1"); + END; + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM OUT_FILE TO IN_FILE IS NOT " & + "ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM OUT_FILE TO IN_FILE"); + END; + + CLOSE (FILE1); + + -- RESETTING FROM OUT_FILE TO INOUT_FILE. + + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME(2)); + + WRITE (FILE1, INT2); + BEGIN + RESET (FILE1, INOUT_FILE); + COMMENT ("RESET FROM OUT_FILE TO INOUT_FILE IS ALLOWED"); + BEGIN + READ (FILE1, INT1); + IF INT1 /= IDENT_INT(2) THEN + FAILED ("RESETTING FROM OUT_FILE TO " & + "INOUT_FILE AFFECTED DATA"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "READING FROM FILE - 2"); + END; + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM OUT_FILE TO INOUT_FILE IS " & + "NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM OUT_FILE TO INOUT_FILE"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + -- RESETTING FROM IN_FILE TO OUT_FILE. + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " & + "DIRECT FILE WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE1, OUT_FILE); + COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM IN_FILE TO OUT_FILE IS NOT " & + "ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM IN_FILE TO OUT_FILE"); + END; + + CLOSE (FILE1); + + -- RESETTING FROM IN_FILE TO INOUT_FILE. + + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + + BEGIN + RESET (FILE1, INOUT_FILE); + COMMENT ("RESET FROM IN_FILE TO INOUT_FILE IS ALLOWED"); + BEGIN + READ (FILE1, INT1); + IF INT1 /= IDENT_INT(2) THEN + FAILED ("RESETTING FROM IN_FILE TO " & + "INOUT_FILE AFFECTED DATA"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "READING FROM FILE - 3"); + END; + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM IN_FILE TO INOUT_FILE IS " & + "NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM IN_FILE TO INOUT_FILE"); + END; + + CLOSE (FILE1); + + -- RESETTING FROM INOUT_FILE TO IN_FILE. + + BEGIN + OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPENING OF " & + "DIRECT FILE WITH INOUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE1, IN_FILE); + COMMENT ("RESET FROM INOUT_FILE TO IN_FILE IS ALLOWED"); + BEGIN + READ (FILE1, INT1); + IF INT1 /= IDENT_INT(2) THEN + FAILED ("RESETTING FROM INOUT_FILE TO " & + "IN_FILE AFFECTED DATA"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "READING FROM FILE - 2"); + END; + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM INOUT_FILE TO IN_FILE IS " & + "NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM INOUT_FILE TO IN_FILE"); + END; + + CLOSE (FILE1); + + -- RESETTING FROM INOUT_FILE TO OUT_FILE. + + OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + + BEGIN + RESET (FILE1, OUT_FILE); + COMMENT ("RESET FROM INOUT_FILE TO OUT_FILE IS ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("RESET FROM INOUT_FILE TO OUT_FILE IS " & + "NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN " & + "RESETTING FROM INOUT_FILE TO OUT_FILE"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102l.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CE2102L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL + -- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE SEQUENTIAL_IO. + + -- B) UNOPENED FILES + + -- HISTORY: + -- SPW 07/29/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102L IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER); + USE SEQ_IO; + + TEST_FILE_ONE : SEQ_IO.FILE_TYPE; + STR : STRING (1 .. 10); + FL_MODE : SEQ_IO.FILE_MODE ; + + BEGIN + + TEST ("CE2102L", "CHECK THAT STATUS_ERROR IS RAISED WHEN " & + "PERFORMING ILLEGAL OPERATIONS ON UNOPENED " & + "FILES OF TYPE SEQUENTIAL_IO"); + + -- CHECK TO SEE THAT PROPER EXCEPTIONS ARE RAISED WHEN + -- PERFORMING OPERATIONS ON AN UNOPENED FILE + + -- CLOSE AN UNOPENED FILE + + BEGIN + CLOSE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " & + "FILE IS USED IN A CLOSE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CLOSE"); + END; + + -- DELETE AN UNOPENED FILE + + BEGIN + DELETE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " & + "FILE IS USED IN A DELETE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON DELETE"); + END; + + -- RESET UNOPENED FILE + + BEGIN + RESET (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " & + "FILE IS USED IN A RESET"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON RESET"); + END; + + BEGIN + RESET (TEST_FILE_ONE, IN_FILE); + FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED FILE " & + "IS USED IN A RESET WITH MODE PARAMETER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON RESET " & + "WITH MODE"); + END; + + -- ATTEMPT TO DETERMINE MODE OF UNOPENED FILE + + BEGIN + FL_MODE := MODE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED " & + "FILE IS USED IN A MODE OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON MODE"); + END; + + -- ATTEMPT TO DETERMINE NAME OF UNOPENED FILE + + BEGIN + STR := NAME (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN A UNOPENED " & + "FILE IS USED IN A NAME OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON NAME"); + END; + + --ATTEMPT TO DETERMINE FORM OF UNOPENED FILE + + BEGIN + STR := FORM (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED " & + "FILE IS USED IN A FORM OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON FORM"); + END; + + RESULT; + + END CE2102L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102m.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- CE2102M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK TO SEE THAT STATUS_ERROR IS RAISED WHEN PERFORMING ILLEGAL + -- OPERATIONS ON OPENED OR UNOPENED FILES OF TYPE DIRECT_IO. + + -- B) UNOPENED FILES + + -- HISTORY: + -- SPW 02/24/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102M IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER); + USE DIR_IO; + + TEST_FILE_ONE : DIR_IO.FILE_TYPE; + STR : STRING (1 .. 10); + FL_MODE : DIR_IO.FILE_MODE ; + + BEGIN + + TEST ("CE2102M", "CHECK THAT STATUS_ERROR IS RAISED WHEN " & + "PERFORMING ILLEGAL OPERATIONS ON UNOPENED " & + "FILES OF TYPE DIRECT_IO"); + + -- CHECK TO SEE THAT PROPER EXCEPTIONS ARE RAISED WHEN + -- PERFORMING OPERATIONS ON AN UNOPENED FILE + + -- CLOSE AN UNOPENED FILE + + BEGIN + CLOSE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A CLOSE OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CLOSE"); + END; + + -- DELETE AN UNOPENED FILE + + BEGIN + DELETE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A DELETE OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON DELETE"); + END; + + -- RESET UNOPENED FILE + + BEGIN + RESET (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A RESET"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON RESET"); + END; + + BEGIN + RESET (TEST_FILE_ONE, IN_FILE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A RESET WITH MODE PARAMETER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON RESET WITH " & + "MODE PARAMETER"); + END; + + -- ATTEMPT TO DETERMINE MODE OF UNOPENED FILE + + BEGIN + FL_MODE := MODE (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A MODE OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON MODE"); + END; + + -- ATTEMPT TO DETERMINE NAME OF UNOPENED FILE + + BEGIN + STR := NAME (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A NAME OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON NAME"); + END; + + --ATTEMPT TO DETERMINE FORM OF UNOPENED FILE + + BEGIN + STR := FORM (TEST_FILE_ONE); + FAILED ("STATUS_ERROR NOT RAISED WHEN AN UNOPENED FILE " & + "IS USED IN A FORM OPERATION"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON FORM"); + END; + + RESULT; + END CE2102M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102n.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OPEN WITH IN_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102N IS + BEGIN + + TEST ("CE2102N", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR SEQUENTIAL FILES"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102o.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE2102O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR RESET BY THE + -- IMPLEMENTATION FOR SEQUENTIAL FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT RESET WITH IN_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102O IS + BEGIN + + TEST ("CE2102O", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " & + "A FILE OF MODE IN_FILE, WHEN IN_FILE MODE IS " & + "NOT SUPPORTED FOR RESET BY THE IMPLEMENTATION " & + "FOR SEQUENTIAL FILES"); + + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE1); + NOT_APPLICABLE ("RESET FOR IN_FILE MODE IS " & + "SUPPORTED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "RESET"); + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102p.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OPEN WITH OUT_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102P IS + BEGIN + + TEST ("CE2102P", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR SEQUENTIAL FILES"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102q.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- CE2102Q.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR RESET BY THE + -- IMPLEMENTATION FOR SEQUENTIAL FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT RESET WITH OUT_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2102Q IS + BEGIN + + TEST ("CE2102Q", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " & + "A FILE OF MODE OUT_FILE, WHEN OUT_FILE MODE " & + "IS NOT SUPPORTED FOR RESET BY THE " & + "IMPLEMENTATION FOR SEQUENTIAL FILES"); + + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + + BEGIN + RESET (FILE1); + NOT_APPLICABLE ("RESET FOR OUT_FILE MODE IS SUPPORTED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102Q; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102r.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102R.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OPEN WITH INOUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102R IS + BEGIN + + TEST ("CE2102R", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "INOUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR DIRECT FILES"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR INOUT_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102R; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102s.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102S.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE + -- INOUT_FILE, WHEN INOUT_FILE MODE IS NOT SUPPORTED FOR RESET BY + -- THE IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT RESET WITH INOUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102S IS + BEGIN + + TEST ("CE2102S", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " & + "A FILE OF MODE INOUT_FILE, WHEN INOUT_FILE " & + "MODE IS NOT SUPPORTED FOR RESET BY THE " & + "IMPLEMENTATION FOR DIRECT FILES"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + + BEGIN + RESET (FILE1); + NOT_APPLICABLE ("RESET FOR INOUT_FILE MODE IS " & + "SUPPORTED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102S; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102t.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102T.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OPEN WITH IN_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102T IS + BEGIN + + TEST ("CE2102T", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR DIRECT FILES"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102T; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102u.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE2102U.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR RESET BY + -- THE IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT RESET WITH IN_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102U IS + BEGIN + + TEST ("CE2102U", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " & + "A FILE OF MODE IN_FILE, WHEN IN_FILE " & + "MODE IS NOT SUPPORTED FOR RESET BY THE " & + "IMPLEMENTATION FOR DIRECT FILES"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE " & + "NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE1); + NOT_APPLICABLE ("RESET FOR IN_FILE MODE IS " & + "SUPPORTED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "RESET"); + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102U; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102v.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102V.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OPEN WITH OUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102V IS + BEGIN + + TEST ("CE2102V", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR DIRECT FILES"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "INOUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102V; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102w.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2102W.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN RESETTING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR RESET BY + -- THE IMPLEMENTATION FOR DIRECT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT RESET WITH OUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2102W IS + BEGIN + + TEST ("CE2102W", "CHECK THAT USE_ERROR IS RAISED WHEN RESETTING " & + "A FILE OF MODE OUT_FILE, WHEN OUT_FILE " & + "MODE IS NOT SUPPORTED FOR RESET BY THE " & + "IMPLEMENTATION FOR DIRECT FILES"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (BOOLEAN); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + VAR1 : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, VAR1); + + BEGIN + RESET (FILE1); + NOT_APPLICABLE ("RESET FOR OUT_FILE MODE IS " & + "SUPPORTED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON RESET"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2102W; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102x.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + -- CE2102X.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT + -- SUPPORT DELETION OF AN EXTERNAL SEQUENTIAL FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF A SEQUENTIAL FILE WITH OUT_FILE MODE. + + -- HISTORY: + -- TBN 09/15/87 CREATED ORIGINAL TEST. + + WITH SEQUENTIAL_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2102X IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2102X", "CHECK THAT USE_ERROR IS RAISED IF AN " & + "IMPLEMENTATION DOES NOT SUPPORT DELETION " & + "OF AN EXTERNAL SEQUENTIAL FILE"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FILE1 : FILE_TYPE; + INT1 : INTEGER := IDENT_INT(1); + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " & + "SEQUENTIAL FILE WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " & + "SEQUENTIAL FILE WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, INT1); + BEGIN + DELETE (FILE1); + COMMENT ("DELETION OF AN EXTERNAL SEQUENTIAL FILE IS " & + "ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF AN EXTERNAL SEQUENTIAL " & + "FILE IS NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "DELETING AN EXTERNAL FILE"); + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102X; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2102y.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CE2102Y.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED IF AN IMPLEMENTATION DOES NOT + -- SUPPORT DELETION OF AN EXTERNAL DIRECT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF A DIRECT FILE WITH OUT_FILE MODE. + + -- HISTORY: + -- TBN 09/15/87 CREATED ORIGINAL TEST. + + WITH DIRECT_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2102Y IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2102Y", "CHECK THAT USE_ERROR IS RAISED IF AN " & + "IMPLEMENTATION DOES NOT SUPPORT DELETION " & + "OF AN EXTERNAL DIRECT FILE"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INT1 : INTEGER := IDENT_INT(1); + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE OF " & + "DIRECT FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE OF " & + "DIRECT FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, INT1); + BEGIN + DELETE (FILE1); + COMMENT ("DELETION OF AN EXTERNAL DIRECT FILE IS " & + "ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF AN EXTERNAL DIRECT " & + "FILE IS NOT ALLOWED"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHILE " & + "DELETING AN EXTERNAL FILE"); + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE2102Y; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103a.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- CE2103A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE SEQUENTIAL_IO. + + -- A) UNOPENED FILES + + -- HISTORY: + -- DLD 08/10/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 06/03/85 + -- SPW 08/10/87 SPLIT CASE FOR OPENED FILES INTO CE2103C.ADA. + -- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2103A IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(CHARACTER); + USE SEQ_IO; + + TEST_FILE_ZERO : SEQ_IO.FILE_TYPE; + TEST_FILE_ONE : SEQ_IO.FILE_TYPE; + TEST_FILE_TWO : SEQ_IO.FILE_TYPE; + TEST_FILE_THREE : SEQ_IO.FILE_TYPE; + TEST_FILE_FOUR : SEQ_IO.FILE_TYPE; + VAL : BOOLEAN; + + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2103A", "CHECK THAT IS_OPEN RETURNS THE PROPER " & + "VALUES FOR UNOPENED FILES OF TYPE " & + "SEQUENTIAL_IO"); + + -- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS SEQUENTIAL FILES AT ALL + + BEGIN + SEQ_IO.CREATE ( TEST_FILE_ZERO, + SEQ_IO.OUT_FILE, + REPORT.LEGAL_FILE_NAME ); + EXCEPTION + WHEN SEQ_IO.USE_ERROR | SEQ_IO.NAME_ERROR => + REPORT.NOT_APPLICABLE + ( "SEQUENTIAL FILES NOT SUPPORTED -- CREATE OUT-FILE" ); + RAISE INCOMPLETE; + END; + SEQ_IO.DELETE ( TEST_FILE_ZERO ); + + -- WHEN FILE IS DECLARED BUT NOT OPEN + + BEGIN + VAL := TRUE; + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE"); + END IF; + END; + + -- FOLLOWING UNSUCCESSFUL CREATE + + BEGIN + VAL := TRUE; + CREATE (TEST_FILE_TWO, OUT_FILE, + "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN (TEST_FILE_TWO); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE AFTER AN " & + "UNSUCCESSFUL CREATE"); + END IF; + END; + + -- FOLLOWING UNSUCCESSFUL OPEN + + BEGIN + VAL := TRUE; + OPEN (TEST_FILE_THREE, IN_FILE, + "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL OPEN"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN (TEST_FILE_THREE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE - UNSUCCESSFUL OPEN"); + END IF; + END; + + -- FOLLOWING CLOSING FILE THAT IS NOT OPEN + + BEGIN + VAL := TRUE; + CLOSE (TEST_FILE_FOUR); + FAILED ("STATUS ERROR NOT RAISED WHEN " & + "ATTEMPTING TO CLOSE AN UNOPENED FILE"); + EXCEPTION + WHEN STATUS_ERROR => + VAL := IS_OPEN (TEST_FILE_FOUR); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE AFTER ATTEMPTING " & + "TO CLOSE AN UNOPENED FILE"); + END IF; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + REPORT.RESULT; + WHEN OTHERS => + REPORT.FAILED ( "UNEXPECTED EXCEPTION" ); + REPORT.RESULT; + END CE2103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103b.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- CE2103B.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE DIRECT_IO. + + -- A) UNOPENED FILES + + -- HISTORY: + -- DLD 08/10/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 06/03/85 + -- SPW 08/13/87 SPLIT CASE FOR OPEN FILES INTO CE2103D.ADA. + -- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2103B IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(CHARACTER); + USE DIR_IO; + + TEST_FILE_ZERO : DIR_IO.FILE_TYPE; + TEST_FILE_ONE : DIR_IO.FILE_TYPE; + TEST_FILE_TWO : DIR_IO.FILE_TYPE; + TEST_FILE_THREE : DIR_IO.FILE_TYPE; + TEST_FILE_FOUR : DIR_IO.FILE_TYPE; + VAL : BOOLEAN; + + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2103B", "CHECK THAT IS_OPEN RETURNS THE PROPER " & + "VALUES FOR UNOPENED FILES OF TYPE DIRECT_IO"); + + -- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS DIRECT FILES AT ALL + + BEGIN + DIR_IO.CREATE ( TEST_FILE_ZERO, + DIR_IO.OUT_FILE, + REPORT.LEGAL_FILE_NAME ); + EXCEPTION + WHEN DIR_IO.USE_ERROR | DIR_IO.NAME_ERROR => + REPORT.NOT_APPLICABLE + ( "DIRECT FILES NOT SUPPORTED -- CREATE OUT-FILE" ); + RAISE INCOMPLETE; + END; + DIR_IO.DELETE ( TEST_FILE_ZERO ); + + -- WHEN FILE IS DECLARED BUT NOT OPEN + + BEGIN + VAL := TRUE; + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE"); + END IF; + END; + + -- FOLLOWING UNSUCCESSFUL CREATE + + BEGIN + VAL := TRUE; + CREATE (TEST_FILE_TWO, OUT_FILE, + "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN (TEST_FILE_TWO); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE AFTER AN " & + "UNSUCCESSFUL CREATE"); + END IF; + END; + + -- FOLLOWING UNSUCCESSFUL OPEN + + BEGIN + VAL := TRUE; + OPEN (TEST_FILE_THREE, IN_FILE, + "$ILLEGAL_EXTERNAL_FILE_NAME2"); + FAILED ("NAME_ERROR NOT RAISED - UNSUCCESSFUL OPEN"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN (TEST_FILE_THREE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE - UNSUCCESSFUL OPEN"); + END IF; + END; + + -- FOLLOWING CLOSING FILE THAT IS NOT OPEN + + BEGIN + VAL := TRUE; + CLOSE (TEST_FILE_FOUR); + FAILED ("STATUS ERROR NOT RAISED WHEN ATTEMPTING " & + "CLOSE AN UNOPENED FILE"); + EXCEPTION + WHEN STATUS_ERROR => + VAL := IS_OPEN (TEST_FILE_FOUR); + IF VAL = TRUE THEN + FAILED ("IS_OPEN GIVES TRUE AFTER ATTEMPTING " & + "TO CLOSE AN UNOPENED FILE"); + END IF; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + REPORT.RESULT; + WHEN OTHERS => + REPORT.FAILED ( "UNEXPECTED EXCEPTION" ); + REPORT.RESULT; + END CE2103B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- CE2103C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE SEQUENTIAL_IO. + + -- B) OPENED FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- SPW 08/10/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2103C IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(CHARACTER); + USE SEQ_IO; + INCOMPLETE : EXCEPTION; + TEST_FILE_ONE : SEQ_IO.FILE_TYPE; + VAL : BOOLEAN; + + BEGIN + + TEST ("CE2103C", "CHECK THAT IS_OPEN RETURNS THE PROPER " & + "VALUES FOR FILES OF TYPE SEQUENTIAL_IO"); + + -- FOLLOWING A CREATE + + VAL := FALSE; + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER CREATE"); + END IF; + + -- FOLLOWING CLOSE + + VAL := TRUE; + CLOSE (TEST_FILE_ONE); + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN RETURNS TRUE AFTER CLOSE"); + END IF; + + -- FOLLOWING OPEN + + VAL := FALSE; + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN + FAILED ("IS_OPEN GIVES TRUE ON " & + "UNSUCESSFUL OPEN"); + END IF; + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER OPEN"); + END IF; + + -- AFTER RESET + + VAL := FALSE; + + BEGIN + RESET (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER RESET"); + END IF; + + -- AFTER DELETE + + VAL := TRUE; + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN + FAILED ("IS_OPEN GIVES TRUE ON UNSUCCESSFUL " & + "DELETE"); + END IF; + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN RETURNS TRUE AFTER DELETE"); + END IF; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2103C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2103d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- CE2103D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE DIRECT_IO. + + -- B) OPENED FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTAIONS WHICH SUPPORT + -- CREATION OF EXTERNAL FILES FOR DIRECT FILES. + + -- HISTORY: + -- SPW 08/13/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2103D IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(CHARACTER); + USE DIR_IO; + INCOMPLETE : EXCEPTION; + TEST_FILE_ONE : DIR_IO.FILE_TYPE; + VAL : BOOLEAN; + + BEGIN + + TEST ("CE2103D", "CHECK THAT IS_OPEN RETURNS THE PROPER " & + "VALUES FOR FILES OF TYPE DIRECT_IO"); + + -- FOLLOWING A CREATE + + VAL := FALSE; + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER CREATE"); + END IF; + + -- FOLLOWING CLOSE + + VAL := TRUE; + CLOSE (TEST_FILE_ONE); + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN RETURNS TRUE AFTER CLOSE"); + END IF; + + -- FOLLOWING OPEN + + VAL := FALSE; + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN + FAILED ("IS_OPEN GIVES TRUE ON " & + "UNSUCCESSFUL OPEN"); + END IF; + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER OPEN"); + END IF; + + -- AFTER RESET + + VAL := FALSE; + + BEGIN + RESET (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED ("IS_OPEN RETURNS FALSE AFTER RESET"); + END IF; + + -- AFTER DELETE + + VAL := TRUE; + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_ONE) /= FALSE THEN + FAILED ("IS_OPEN GIVES TRUE ON UNSUCCESSFUL " & + "DELETE"); + END IF; + RAISE INCOMPLETE; + END; + + VAL := IS_OPEN (TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED ("IS_OPEN RETURNS TRUE AFTER DELETE"); + END IF; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2103D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CE2104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FILE CAN BE CLOSED AND THEN RE-OPENED. + + -- A) SEQUENTIAL FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE + -- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 06/03/85 + -- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2104A IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER); + USE SEQ_IO; + + SEQ_FILE : SEQ_IO.FILE_TYPE; + VAR : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2104A", "CHECK THAT A FILE CAN BE CLOSED " & + "AND THEN RE-OPENED"); + + -- INITIALIZE TEST FILE + + BEGIN + CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + + END; + + WRITE (SEQ_FILE, 17); + CLOSE (SEQ_FILE); + + -- RE-OPEN SEQUENTIAL TEST FILE + + BEGIN + OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + READ (SEQ_FILE, VAR); + IF VAR /= 17 THEN + FAILED ("WRONG DATA RETURNED FROM READ - " & + "SEQUENTIAL"); + END IF; + + -- DELETE TEST FILE + + BEGIN + + DELETE (SEQ_FILE); + + EXCEPTION + + WHEN USE_ERROR => + NULL; + + END; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- CE2104B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAME RETURNED BY NAME CAN BE USED IN A + -- SUBSEQUENT OPEN. + + -- A) SEQUENTIAL FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE + -- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/31/85 + -- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED IS + -- CALLED FOR OPEN OR CREATE. + -- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH SEQUENTIAL_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE2104B IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER); + USE SEQ_IO; + TYPE ACC_STR IS ACCESS STRING; + + SEQ_FILE_ONE : SEQ_IO.FILE_TYPE; + SEQ_FILE_TWO : SEQ_IO.FILE_TYPE; + SEQ_FILE_NAME : ACC_STR; + VAR : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2104B", "CHECK THAT THE NAME RETURNED BY NAME " & + "CAN BE USED IN A SUBSEQUENT OPEN"); + + -- CREATE TEST FILE + + BEGIN + CREATE(SEQ_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (SEQ_FILE_ONE, 14); + SEQ_FILE_NAME := NEW STRING'(NAME(SEQ_FILE_ONE)); + CLOSE (SEQ_FILE_ONE); + + -- ATTEMPT TO RE-OPEN SEQUENTIAL TEST FILE USING RETURNED NAME VALUE + + BEGIN + OPEN (SEQ_FILE_TWO, IN_FILE, SEQ_FILE_NAME.ALL); + EXCEPTION + WHEN SEQ_IO.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + WHEN SEQ_IO.NAME_ERROR => + FAILED ("STRING NOT ACCEPTED AS NAME FOR FILE - SEQ"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("FILE NOT RE-OPENED - SEQ"); + RAISE INCOMPLETE; + END; + + READ (SEQ_FILE_TWO, VAR); + IF VAR /= 14 THEN + FAILED ("WRONG DATA RETURNED FROM READ -SEQ"); + END IF; + + -- DELETE TEST FILE + + BEGIN + DELETE (SEQ_FILE_TWO); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF EXTERNAL FILE IS NOT SUPPORTED"); + END; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2104B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CE2104C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FILE CAN BE CLOSED AND THEN RE-OPENED. + + -- B) DIRECT FILES + + -- APPLICABLILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE + -- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 06/03/85 + -- PWB 02/10/86 CORRECTED REPORTED TEST NAME; CHANGED DATA FILE + -- NAME TO "Y2104C" TO MATCH TEST NAME. + -- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2104C IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER); + USE DIR_IO; + + DIR_FILE : DIR_IO.FILE_TYPE; + VAR : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2104C", "CHECK THAT A FILE CAN BE CLOSED " & + "AND THEN RE-OPENED"); + + -- INITIALIZE TEST FILE + + BEGIN + CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + + END; + + WRITE (DIR_FILE, 28); + CLOSE (DIR_FILE); + + -- RE-OPEN DIRECT TEST FILE + + BEGIN + OPEN (DIR_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + READ (DIR_FILE, VAR); + IF VAR /= 28 THEN + FAILED ("WRONG DATA RETURNED FROM READ - DIRECT"); + END IF; + + -- DELETE TEST FILE + + BEGIN + DELETE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2104C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2104d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- CE2104D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAME RETURNED BY NAME CAN BE USED IN A + -- SUBSEQUENT OPEN. + + -- B) DIRECT FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHOSE + -- ENVIRONMENT SUPPORTS CREATE/OPEN FOR THE GIVEN MODE. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/31/85 + -- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED IS + -- CALLED FOR OPEN OR CREATE. + -- SPW 08/07/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH DIRECT_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE2104D IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER); + USE DIR_IO; + TYPE ACC_STR IS ACCESS STRING; + + DIR_FILE_ONE : DIR_IO.FILE_TYPE; + DIR_FILE_TWO : DIR_IO.FILE_TYPE; + DIR_FILE_NAME : ACC_STR; + VAR : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2104D", "CHECK THAT THE NAME RETURNED BY NAME " & + "CAN BE USED IN A SUBSEQUENT OPEN"); + + -- CREATE TEST FILE + + BEGIN + CREATE (DIR_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (DIR_FILE_ONE, 3); + DIR_FILE_NAME := NEW STRING'(NAME(DIR_FILE_ONE)); + CLOSE (DIR_FILE_ONE); + + -- ATTEMPT TO RE-OPEN DIRECT TEST FILE USING RETURNED NAME VALUE + + BEGIN + OPEN (DIR_FILE_TWO, IN_FILE, DIR_FILE_NAME.ALL); + EXCEPTION + WHEN DIR_IO.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + WHEN DIR_IO.NAME_ERROR => + FAILED ("STRING NOT ACCEPTED AS NAME FOR FILE - DIR"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("FILE NOT RE-OPENED - DIR"); + RAISE INCOMPLETE; + + END; + + READ (DIR_FILE_TWO, VAR); + IF VAR /= 3 THEN + FAILED ("WRONG DATA RETURNED FROM READ - DIR"); + END IF; + + -- DELETE TEST FILE + + BEGIN + DELETE (DIR_FILE_TWO); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("DELETION OF EXTERNAL FILE IS NOT SUPPORTED"); + END; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE2104D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2106a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CE2106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE + -- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION. + + -- A) SEQUENTIAL FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH OUT_FILE MODE FOR SEQUENTIAL FILES AND + -- DELETION OF EXTERNAL FILES. + + -- HISTORY: + -- SPS 08/25/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 02/12/86 SPLIT TEST. PUT DIRECT_IO INTO CE2106B.ADA. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- SPW 08/07/87 INSERTED ALLOWABLE EXCEPTION USE_ERROR ON + -- DELETE. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2106A IS + + BEGIN + + TEST ("CE2106A", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " & + "AFTER AN EXTERNAL FILE WITH SAME NAME HAS " & + "BEEN DELETED FOR SEQUENTIAL_IO"); + + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FL1 : FILE_TYPE; + FL2 : FILE_TYPE; + T_FAILED : BOOLEAN := FALSE; + D_FILE : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " & + "CREATE"); + T_FAILED := TRUE; + END; + + IF NOT T_FAILED THEN + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL FILE " & + "IS NOT SUPPORTED"); + T_FAILED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "DELETE"); + T_FAILED := TRUE; + END; + END IF; + + IF NOT T_FAILED THEN + BEGIN + CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME); + D_FILE := TRUE; + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR FOR RECREATE - SEQ"); + WHEN OTHERS => + FAILED ("UNABLE TO RECREATE FILE AFTER " & + "DELETION - SEQ"); + END; + + IF D_FILE THEN + BEGIN + DELETE (FL2); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR FOR DELETE - SEQ"); + END; + END IF; + END IF; + END; + + RESULT; + + END CE2106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2106b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CE2106B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE + -- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION. + + -- B) DIRECT FILES + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH OUT_FILE MODE FOR DIRECT FILES AND + -- DELETION OF EXTERNAL FILES. + + -- HISTORY: + -- TBN 02/12/86 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- SPW 08/07/87 INSERTED ALLOWABLE EXCEPTION USE_ERROR ON + -- DELETE. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2106B IS + BEGIN + + TEST ("CE2106B", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " & + "AFTER AN EXTERNAL FILE WITH SAME NAME HAS " & + "BEEN DELETED FOR DIRECT_IO"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FL1 : FILE_TYPE; + FL2 : FILE_TYPE; + T_FAILED : BOOLEAN := FALSE; + D_FILE : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; DIRECT CREATE " & + "WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; DIRECT " & + "CREATE WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; DIRECT " & + "CREATE"); + T_FAILED := TRUE; + END; + + IF NOT T_FAILED THEN + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL FILE " & + "IS NOT SUPPORTED"); + T_FAILED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "DELETE"); + T_FAILED := TRUE; + END; + END IF; + + IF NOT T_FAILED THEN + BEGIN + CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME); + D_FILE := TRUE; + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR FOR RECREATE - DIR"); + WHEN OTHERS => + FAILED ("UNABLE TO RECREATE FILE AFTER " & + "DELETION - DIR"); + END; + + IF D_FILE THEN + BEGIN + DELETE (FL2); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR WHILE DELETING DIR " & + "FILE"); + END; + END IF; + END IF; + END; + + RESULT; + + END CE2106B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CE2108E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL SEQUENTIAL FILE SPECIFIED BY A NON-NULL + -- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN + -- PROGRAM. + + -- THIS TEST CREATES A SEQUENTIAL FILE; CE2108F.ADA READS IT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF AN EXTERNAL SEQUENTIAL FILE WITH OUT_FILE MODE. + + -- HISTORY: + -- TBN 07/16/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2108E IS + + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + INCOMPLETE : EXCEPTION; + FILE_NAME : SEQ.FILE_TYPE; + PREVENT_EMPTY_FILE : NATURAL := 5; + + BEGIN + + TEST ("CE2108E" , "CHECK THAT AN EXTERNAL SEQUENTIAL FILE " & + "SPECIFIED BY A NON-NULL STRING NAME IS " & + "ACCESSIBLE AFTER THE COMPLETION OF THE MAIN " & + "PROGRAM"); + BEGIN + BEGIN + SEQ.CREATE (FILE_NAME, SEQ.OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN SEQ.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN SEQ.NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "SEQUENTIAL CREATE"); + RAISE INCOMPLETE; + END; + + SEQ.WRITE (FILE_NAME, PREVENT_EMPTY_FILE); + SEQ.CLOSE (FILE_NAME); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2108E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE2108F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL SEQUENTIAL FILE SPECIFIED BY A NON-NULL + -- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN + -- PROGRAM. + + -- THIS TEST CHECKS THE CREATION OF A SEQUENTIAL FILE WHICH WAS + -- CREATED BY CE2108E.ADA. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 07/16/87 CREATED ORIGINAL TESTED. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2108F IS + + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + INCOMPLETE : EXCEPTION; + CHECK_SUPPORT, FILE_NAME : FILE_TYPE; + PREVENT_EMPTY_FILE : NATURAL := 0; + + BEGIN + TEST ("CE2108F", "CHECK THAT AN EXTERNAL SEQUENTIAL FILE " & + "SPECIFIED BY A NON-NULL STRING NAME IS " & + "ACCESSIBLE AFTER THE COMPLETION OF THE MAIN " & + "PROGRAM"); + + -- TEST FOR SEQUENTIAL FILE SUPPORT. + + BEGIN + CREATE (CHECK_SUPPORT, OUT_FILE, LEGAL_FILE_NAME); + BEGIN + DELETE (CHECK_SUPPORT); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON DELETE"); + END; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "SEQUENTIAL CREATE"); + RAISE INCOMPLETE; + END; + + -- BEGIN TEST OBJECTIVE. + + BEGIN + OPEN (FILE_NAME, IN_FILE, LEGAL_FILE_NAME(1, "CE2108E")); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN FOR " & + "SEQUENTIAL FILE WITH IN_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + READ (FILE_NAME, PREVENT_EMPTY_FILE); + IF PREVENT_EMPTY_FILE /= 5 THEN + FAILED ("OPENED WRONG FILE OR DATA ERROR"); + END IF; + BEGIN + DELETE (FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " & + "EXTERNAL FILE"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE2108F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CE2108G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED BY A NON-NULL + -- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN + -- PROGRAM. + + -- THIS TEST CREATES A DIRECT FILE; CE2108H.ADA READS IT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF AN EXTERNAL DIRECT FILE. + + -- HISTORY: + -- TBN 07/16/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2108G IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + INCOMPLETE : EXCEPTION; + FILE_NAME : DIR.FILE_TYPE; + PREVENT_EMPTY_FILE : NATURAL := 5; + + BEGIN + + TEST ("CE2108G", "CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED " & + "BY A NON-NULL STRING NAME IS ACCESSIBLE AFTER " & + "THE COMPLETION OF THE MAIN PROGRAM"); + BEGIN + BEGIN + DIR.CREATE (FILE_NAME, DIR.OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN DIR.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON DIRECT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN DIR.NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON DIRECT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "DIRECT CREATE"); + RAISE INCOMPLETE; + END; + + DIR.WRITE (FILE_NAME, PREVENT_EMPTY_FILE); + DIR.CLOSE (FILE_NAME); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2108G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2108h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- CE2108H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED BY A NON-NULL + -- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN + -- PROGRAM. + + -- THIS TEST CHECKS THE CREATION OF A DIRECT FILE WHICH WAS + -- CREATED BY CE2108G.ADA. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- TBN 07/16/87 CREATED ORIGINAL TESTED. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2108H IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + INCOMPLETE : EXCEPTION; + CHECK_SUPPORT, FILE_NAME : FILE_TYPE; + PREVENT_EMPTY_FILE : NATURAL := 0; + + BEGIN + TEST ("CE2108H", "CHECK THAT AN EXTERNAL DIRECT FILE SPECIFIED " & + "BY A NON-NULL STRING NAME IS ACCESSIBLE AFTER " & + "THE COMPLETION OF THE MAIN PROGRAM"); + + -- TEST FOR DIRECT FILE SUPPORT. + + BEGIN + CREATE (CHECK_SUPPORT, OUT_FILE, LEGAL_FILE_NAME); + BEGIN + DELETE (CHECK_SUPPORT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON DIRECT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON DIRECT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON DIRECT CREATE"); + RAISE INCOMPLETE; + END; + + -- BEGIN TEST OBJECTIVE. + + BEGIN + OPEN (FILE_NAME, IN_FILE, LEGAL_FILE_NAME(1, "CE2108G")); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + READ (FILE_NAME, PREVENT_EMPTY_FILE); + IF PREVENT_EMPTY_FILE /= 5 THEN + FAILED ("OPENED WRONG FILE OR DATA ERROR"); + END IF; + BEGIN + DELETE (FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " & + "EXTERNAL FILE"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE2108H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,83 ---- + -- CE2109A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR + -- SEQUENTIAL_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR SEQUENTIAL FILES. + + -- HISTORY: + -- ABW 08/13/82 + -- SPS 11/09/82 + -- JBG 11/11/83 + -- TBN 02/13/86 SPLIT TEST. PUT DIRECT_IO INTO CE2109B.ADA AND + -- TEXT_IO INTO CE2109C.ADA. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED + -- NAME_ERROR, AND CLOSED THE FILE. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2109A IS + + INCOMPLETE : EXCEPTION; + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FILE2 : SEQ.FILE_TYPE; + + BEGIN + + TEST( "CE2109A", "CHECK DEFAULT MODE IN CREATE FOR SEQ_IO"); + + BEGIN + CREATE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "OUT_FILE MODE NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + END; + + IF MODE (FILE2) /= OUT_FILE THEN + FAILED( "MODE INCORRECTLY SET FOR SEQUENTIAL_IO" ); + END IF; + + CLOSE (FILE2); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2109A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + -- CE2109B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR + -- DIRECT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- TBN 02/13/86 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED + -- NAME_ERROR, AND CLOSED THE FILE. + -- LDC 05/26/88 CHANGED APPLICABILITY COMMENT FROM OUT_FILE TO + -- INOUT_FILE. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2109B IS + + INCOMPLETE : EXCEPTION; + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE3 : DIR.FILE_TYPE; + + BEGIN + + TEST( "CE2109B", "CHECK DEFAULT MODE IN CREATE FOR DIRECT_IO"); + + BEGIN + CREATE (FILE3); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("CREATE OF DIRECT FILE WITH " & + "INOUT_FILE MODE NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; DIRECT CREATE"); + RAISE INCOMPLETE; + END; + + IF MODE (FILE3) /= INOUT_FILE THEN + FAILED( "MODE INCORRECTLY SET FOR DIRECT_IO" ); + END IF; + + CLOSE (FILE3); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2109B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2109c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CE2109C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE DEFAULT MODES IN CREATE ARE SET CORRECTLY FOR + -- TEXT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR TEXT FILES. + + -- HISTORY: + -- TBN 02/13/86 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/12/87 CHANGED NOT_APPLICABLE MESSAGE, REMOVED + -- NAME_ERROR, AND CLOSED THE FILE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE2109C IS + + INCOMPLETE : EXCEPTION; + FILE1 : TEXT_IO.FILE_TYPE; + + BEGIN + + TEST( "CE2109C", "CHECK DEFAULT MODE IN CREATE FOR TEXT_IO"); + + BEGIN + CREATE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("CREATE OF TEXT FILE WITH OUT_FILE" & + "MODE NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + IF MODE (FILE1) /= OUT_FILE THEN + FAILED( "MODE INCORRECTLY SET FOR TEXT_IO" ); + END IF; + + CLOSE (FILE1); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2109C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2110a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CE2110A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL FILE CEASES TO EXIST AFTER A SUCCESSFUL + -- DELETE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION AND DELETION OF SEQUENTIAL FILES. + + -- HISTORY: + -- SPS 08/25/82 + -- SPS 11/09/82 + -- JBG 04/01/83 + -- EG 05/31/85 + -- JLH 07/21/87 ADDED A CALL TO NOT_APPLICABLE, IF EXCEPTION + -- USE_ERROR IS RAISED BY DELETE. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2110A IS + BEGIN + + TEST ("CE2110A", "CHECK THAT THE EXTERNAL FILE CEASES TO EXIST " & + "AFTER A SUCCESSFUL DELETE"); + + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FL1, FL2 : FILE_TYPE; + VAR1 : INTEGER := 5; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FL1, VAR1); -- THIS WRITES TO THE FILE IF IT + EXCEPTION -- CAN, NOT NECESSARY FOR THE + WHEN OTHERS => -- OBJECTIVE. + NULL; + END; + + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL FILES NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FL2, IN_FILE, LEGAL_FILE_NAME); + FAILED ("EXTERNAL FILE STILL EXISTS AFTER " & + "A SUCCESSFUL DELETION - SEQ"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2110A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2110c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CE2110C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL FILE CEASES TO EXIST AFTER A SUCCESSFUL + -- DELETE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION AND DELETION OF DIRECT FILES. + + -- HISTORY: + -- SPS 08/25/82 + -- SPS 11/09/82 + -- JBG 04/01/83 + -- EG 05/31/85 + -- JLH 07/21/87 ADDED A CALL TO NOT_APPLICABLE IF EXCEPTION + -- USE_ERROR IS RAISED ON DELETE. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2110C IS + BEGIN + + TEST ("CE2110C", "CHECK THAT THE EXTERNAL FILE CEASES TO EXIST " & + "AFTER A SUCCESSFUL DELETE"); + + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FL1, FL2 : FILE_TYPE; + VAR1 : INTEGER := 5; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXCEPTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FL1, VAR1); -- THIS WRITES TO THE FILE IF IT + EXCEPTION -- CAN, NOT NECESSARY FOR THE + WHEN OTHERS => -- OBJECTIVE. + NULL; + END; + + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL FILE NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FL2, IN_FILE, LEGAL_FILE_NAME); + FAILED ("EXTERNAL FILE STILL EXISTS AFTER " & + "A SUCCESSFUL DELETION - DIR"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2110C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + -- CE2111A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE REMAINS OPEN AFTER A RESET. + + -- THIS OBJECTIVE IS BEING INTERPRETED AS : CHECK THAT A FILE + -- REMAINS OPEN AFTER AN ATTEMPT TO RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- DLD 08/13/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/28/85 + -- JLH 07/22/87 REWROTE TEST ALGORITHM. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2111A IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO(INTEGER); + USE SEQ_IO; + + SEQ_FILE : SEQ_IO.FILE_TYPE; + VAR1 : INTEGER := 5; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2111A", "CHECK THAT THE FILE REMAINS OPEN AFTER A RESET"); + + -- CREATE SEQUENTIAL TEST FILE + + BEGIN + CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + WRITE (SEQ_FILE, VAR1); + CLOSE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("SEQUENTIAL FILES NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + -- OPEN FILE + + BEGIN + OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT SUPPORTED " & + "FOR SEQ_IO"); + RAISE INCOMPLETE; + END; + + -- RESET FILE + + BEGIN + RESET(SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (SEQ_FILE) THEN + CLOSE (SEQ_FILE); + ELSE + FAILED ("RESET FOR IN_FILE, CLOSED FILE"); + END IF; + + -- RE-OPEN AS OUT_FILE AND REPEAT TEST + + BEGIN + OPEN (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " & + "SUPPORTED FOR SEQ_IO"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (SEQ_FILE) THEN + BEGIN + DELETE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + ELSE + FAILED ("RESET FOR OUT_FILE, CLOSED FILE"); + END IF; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,183 ---- + -- CE2111B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUCCESSFUL RESET POSITIONS THE INDEX CORRECTLY + -- TO THE START OF THE FILE FOR DIRECT IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR DIRECT FILES. + + -- HISTORY: + -- DLD 08/13/82 + -- JBG 03/24/83 + -- EG 05/29/85 + -- JLH 07/23/87 ADDED CHECKS FOR USE_ERROR WHEN FILE IS RESET. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2111B IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + TEST_FILE_ONE : DIR_IO.FILE_TYPE; + DATUM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2111B", "CHECK THAT SUCCESSFUL RESETS POSITION THE " & + "INDEX CORRECTLY"); + + -- CREATE AND INITIALIZE TEST FILE + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (TEST_FILE_ONE, 5); + WRITE (TEST_FILE_ONE, 6); + WRITE (TEST_FILE_ONE, 7); + WRITE (TEST_FILE_ONE, 8); + + -- CHECK THAT RESET POSITIONS INDEX CORRECTLY FOR OUT_FILE + + BEGIN + RESET (TEST_FILE_ONE); + IF INDEX (TEST_FILE_ONE) /= 1 THEN + FAILED ("RESET INCORRECTLY POSITIONED FILE FOR " & + "OUT_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR OUT_FILE"); + RAISE INCOMPLETE; + END; + + -- WRITE MORE DATA + + WRITE (TEST_FILE_ONE, 2); + CLOSE (TEST_FILE_ONE); + + -- NOW CHECK TO SEE THAT RESET WORKED FOR OUT_FILE + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DIR_IO NOT SUPPORTED FOR IN_FILE OPEN"); + RAISE INCOMPLETE; + END; + READ (TEST_FILE_ONE, DATUM); + IF DATUM /= 2 THEN + FAILED ("RESET FAILED FOR OUT_FILE"); + END IF; + + -- POSITION POINTER APPROPRIATELY FOR IN_FILE RESET + + READ (TEST_FILE_ONE, DATUM); + + -- RESET IN_FILE + + BEGIN + RESET (TEST_FILE_ONE); + IF INDEX (TEST_FILE_ONE) /= 1 THEN + FAILED ("RESET INCORRECTLY POSITIONED FILE " & + "FOR IN_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR IN_FILE"); + RAISE INCOMPLETE; + END; + + -- VALIDATE IN_FILE RESET + + READ (TEST_FILE_ONE, DATUM); + IF DATUM /= 2 THEN + FAILED ("RESET FAILED FOR IN_FILE"); + END IF; + + -- VALIDATE RESET FOR IN_OUT FILE + + CLOSE (TEST_FILE_ONE); + BEGIN + OPEN (TEST_FILE_ONE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DIR_IO NOT SUPPORTED FOR INOUT_FILE " & + "OPEN"); + RAISE INCOMPLETE; + END; + + -- WRITE NEW DATA + + WRITE (TEST_FILE_ONE, 3); + + -- RESET INOUT_FILE + + BEGIN + RESET (TEST_FILE_ONE); + IF INDEX (TEST_FILE_ONE) /= 1 THEN + FAILED ("RESET INCORRECTLY POSITIONED FILE " & + "FOR INOUT_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR INOUT_FILE"); + RAISE INCOMPLETE; + END; + + -- VALIDATE RESET + + READ (TEST_FILE_ONE, DATUM); + IF DATUM /= 3 THEN + FAILED ("RESET FAILED FOR INOUT_FILE"); + END IF; + + -- DELETE TEST FILE + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- CE2111C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUPPLIED MODE PARAMETER IN A RESET CHANGES + -- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED + -- THE MODE REMAINS THE SAME. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR SEQUENTIAL FILES. + + -- HISTORY: + -- DLD 08/16/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/29/85 + -- JLH 07/23/87 ADDED CHECKS FOR USE_ERROR WHEN FILE IS RESET. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2111C IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + SEQ_FILE : SEQ_IO.FILE_TYPE; + SEQ_MODE : SEQ_IO.FILE_MODE; + INCOMPLETE : EXCEPTION; + VAR1 : INTEGER := 5; + + BEGIN + + TEST ("CE2111C", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " & + "THE MODE OF THE GIVEN FILE APPROPRIATELY"); + + -- CREATE SEQUENTIAL TEST FILE + + BEGIN + CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + WRITE (SEQ_FILE, VAR1); + CLOSE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (SEQ_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("SEQUENTIAL FILES WITH IN_FILE MODE " & + "NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + -- RESET TO DEFAULT + + BEGIN + SEQ_MODE := OUT_FILE; + RESET (SEQ_FILE); + SEQ_MODE := MODE (SEQ_FILE); + IF SEQ_MODE /= IN_FILE THEN + FAILED ("DEFAULT RESET CHANGED MODE - SEQ"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR SEQ IN_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + -- RESET TO OUT_FILE + + BEGIN + SEQ_MODE := IN_FILE; + RESET (SEQ_FILE, OUT_FILE); + SEQ_MODE := MODE (SEQ_FILE); + IF SEQ_MODE /= OUT_FILE THEN + FAILED ("RESET TO OUT_FILE FAILED - SEQ"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM IN_FILE TO OUT_FILE MODE " & + "NOT SUPPORTED FOR SEQ FILES"); + RAISE INCOMPLETE; + END; + + BEGIN + DELETE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- CE2111E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE REMAINS OPEN AFTER A RESET. + + -- THIS OBJECTIVE IS BEING INTERPRETED AS : CHECK THAT A FILE + -- REMAINS OPEN AFTER AN ATTEMPT TO RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- DLD 08/13/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/28/85 + -- JLH 07/23/87 REWROTE TEST ALGORITHM. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2111E IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + + DIR_FILE : DIR_IO.FILE_TYPE; + VAR1 : INTEGER := 5; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2111E", "CHECK THAT THE FILE REMAINS OPEN AFTER A RESET"); + + -- CREATE DIRECT TEST FILE + + BEGIN + CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME); + WRITE (DIR_FILE, VAR1); + CLOSE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("DIRECT FILES NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + -- OPEN FILE + + BEGIN + OPEN (DIR_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT SUPPORTED " & + "FOR DIR_IO"); + RAISE INCOMPLETE; + END; + + -- RESET FILE + + BEGIN + RESET (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (DIR_FILE) THEN + CLOSE (DIR_FILE); + ELSE + FAILED ("RESET FOR IN_FILE, CLOSED FILE"); + END IF; + + + -- RE-OPEN AS OUT_FILE AND REPEAT TEST + + BEGIN + OPEN (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " & + "SUPPORTED FOR DIR_IO"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (DIR_FILE) THEN + CLOSE (DIR_FILE); + ELSE + FAILED ("RESET FOR OUT_FILE, CLOSED FILE"); + END IF; + + -- RE-OPEN AS IN_OUT FILE AND REPEAT TEST + + BEGIN + OPEN (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_OUT FILE MODE NOT " & + "SUPPORTED FOR DIR_IO"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (DIR_FILE) THEN + BEGIN + DELETE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + ELSE + FAILED ("RESET FOR INOUT_FILE, CLOSED FILE"); + END IF; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- CE2111F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUCCESSFUL RESET POSITIONS THE FILE CORRECTLY + -- TO THE START OF THE FILE FOR SEQUENTIAL IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 08/03/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2111F IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + TEST_FILE_ONE : SEQ_IO.FILE_TYPE; + DATUM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2111F", "CHECK THAT SUCCESSFUL RESET POSITIONS THE " & + "FILE CORRECTLY"); + + -- CREATE AND INITIALIZE TEST FILE + + BEGIN + CREATE (TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (TEST_FILE_ONE, 5); + WRITE (TEST_FILE_ONE, 6); + + -- CHECK THAT RESET POSITIONS INDEX CORRECTLY FOR OUT_FILE + + BEGIN + RESET (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR OUT_FILE"); + RAISE INCOMPLETE; + END; + + -- WRITE MORE DATA + + WRITE (TEST_FILE_ONE, 2); + CLOSE (TEST_FILE_ONE); + + -- NOW CHECK TO SEE THAT RESET WORKED FOR OUT_FILE + + BEGIN + OPEN (TEST_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("SEQ_IO NOT SUPPORTED FOR IN_FILE OPEN"); + RAISE INCOMPLETE; + END; + + READ (TEST_FILE_ONE, DATUM); + + IF DATUM /= 2 THEN + FAILED ("RESET INCORRECTLY POSITIONED FILE FOR OUT_FILE"); + END IF; + + + -- RESET IN_FILE + + BEGIN + RESET (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR IN_FILE"); + RAISE INCOMPLETE; + END; + + -- VALIDATE IN_FILE RESET + + READ (TEST_FILE_ONE, DATUM); + + IF DATUM /= 2 THEN + FAILED ("RESET INCORRECTLY POSITIONED FILE FOR IN_FILE"); + END IF; + + -- DELETE TEST FILE + + BEGIN + DELETE (TEST_FILE_ONE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CE2111G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUPPLIED MODE PARAMETER IN A RESET CHANGES + -- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED + -- THE MODE REMAINS THE SAME. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR DIRECT FILES. + + -- HISTORY: + -- DLD 08/16/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/29/85 + -- TBN 11/04/86 ADDED A RAISE INCOMPLETE STATEMENT WHEN FAILED + -- IS CALLED FOR OPEN OR CREATE. + -- JLH 07/24/87 ADDED CHECKS FOR USE_ERR0R WHEN FILE IS RESET. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2111G IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + DIR_FILE : DIR_IO.FILE_TYPE; + DIR_MODE : DIR_IO.FILE_MODE; + INCOMPLETE : EXCEPTION; + VAR1 : INTEGER := 5; + + BEGIN + + TEST ("CE2111G", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " & + "THE MODE OF THE GIVEN FILE APPROPRIATELY"); + + -- CREATE DIRECT TEST FILE + + BEGIN + CREATE (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME); + WRITE (DIR_FILE, VAR1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + -- RESET TO DEFAULT + + BEGIN + DIR_MODE := OUT_FILE; + RESET (DIR_FILE); + DIR_MODE := MODE (DIR_FILE); + IF DIR_MODE /= INOUT_FILE THEN + FAILED ("DEFAULT RESET CHANGED MODE - DIR"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR DIR " & + "INOUT_FILES"); + END; + + -- RESET TO OUT_FILE + + BEGIN + DIR_MODE := IN_FILE; + RESET (DIR_FILE, OUT_FILE); + DIR_MODE := MODE (DIR_FILE); + IF DIR_MODE /= OUT_FILE THEN + FAILED ("RESET TO OUT_FILE FAILED - DIR"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM INOUT_FILE TO OUT_FILE " & + "NOT SUPPORTED FOR DIR FILES"); + END; + + -- RESET TO IN_FILE + + BEGIN + DIR_MODE := OUT_FILE; + RESET (DIR_FILE, IN_FILE); + DIR_MODE := MODE (DIR_FILE); + IF DIR_MODE /= IN_FILE THEN + FAILED ("RESET TO IN_FILE FAILED - DIR"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE NOT " & + "SUPPORTED FOR DIR IN_FILE"); + END; + + -- RESET TO INOUT_FILE + + BEGIN + DIR_MODE := OUT_FILE; + RESET (DIR_FILE, INOUT_FILE); + DIR_MODE := MODE (DIR_FILE); + IF DIR_MODE /= INOUT_FILE THEN + FAILED ("RESET TO INOUT_FILE FAILED - DIR"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM IN_FILE TO INOUT_FILE NOT " & + "SUPPORTED FOR DIR INOUT_FILES"); + END; + + BEGIN + DELETE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2111i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- CE2111I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A SUPPLIED MODE PARAMETER IN A RESET CHANGES + -- THE MODE OF A GIVEN FILE. IF NO PARAMETER IS SUPPLIED + -- THE MODE REMAINS THE SAME. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 07/23/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2111I IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + SEQ_FILE : SEQ_IO.FILE_TYPE; + SEQ_MODE : SEQ_IO.FILE_MODE; + INCOMPLETE : EXCEPTION; + VAR1 : INTEGER := 5; + + BEGIN + + TEST("CE2111I", "CHECK THAT A SUPPLIED MODE PARAMETER SETS " & + "THE MODE OF THE GIVEN FILE APPROPRIATELY"); + + -- CREATE SEQUENTIAL TEST FILE + + BEGIN + CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + WRITE (SEQ_FILE, VAR1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + -- RESET TO DEFAULT + + BEGIN + SEQ_MODE := IN_FILE; + RESET (SEQ_FILE); + SEQ_MODE := MODE (SEQ_FILE); + IF SEQ_MODE /= OUT_FILE THEN + FAILED ("DEFAULT RESET CHANGED MODE - SEQ"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET NOT SUPPORTED FOR SEQ OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + -- RESET TO IN_FILE + + BEGIN + SEQ_MODE := OUT_FILE; + RESET (SEQ_FILE, IN_FILE); + SEQ_MODE := MODE (SEQ_FILE); + IF SEQ_MODE /= IN_FILE THEN + FAILED ("RESET TO IN_FILE FAILED - SEQ"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE MODE " & + "NOT SUPPORTED FOR SEQ FILES"); + RAISE INCOMPLETE; + END; + + BEGIN + DELETE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2111I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE2201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT_TYPE STRING. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- ABW 08/16/82 + -- SPS 11/09/82 + -- JBG 01/05/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 07/28/87 REMOVED DEPENDENCE ON SUPPORT OF RESET. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201A IS + + BEGIN + + TEST ("CE2201A", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - STRING TYPE"); + + DECLARE + SUBTYPE STRNG IS STRING (1..12); + PACKAGE SEQ_STR IS NEW SEQUENTIAL_IO (STRNG); + USE SEQ_STR; + FILE_STR : FILE_TYPE; + INCOMPLETE : EXCEPTION; + STR : STRNG := "TEXT OF FILE"; + ITEM_STR : STRNG; + BEGIN + BEGIN + CREATE (FILE_STR, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_STR, STR); + CLOSE (FILE_STR); + + BEGIN + OPEN (FILE_STR, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_STR) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE STRING"); + END IF; + + READ (FILE => FILE_STR, ITEM => ITEM_STR); + + IF ITEM_STR /= STRNG (IDENT_STR("TEXT OF FILE")) THEN + FAILED ("READ WRONG VALUE - STRING"); + END IF; + + IF NOT END_OF_FILE (FILE_STR) THEN + FAILED ("END OF FILE NOT TRUE - STRING"); + END IF; + + BEGIN + DELETE (FILE_STR); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- CE2201B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED ARRAY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED ARRAY. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 05/02/83 + -- EG 05/08/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED + -- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY + -- FILES. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201B IS + + BEGIN + + TEST ("CE2201B", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - CONSTRAINED ARRAY"); + + DECLARE + TYPE ARR_CN IS ARRAY (1..5) OF BOOLEAN; + PACKAGE SEQ_ARR_CN IS NEW SEQUENTIAL_IO (ARR_CN); + USE SEQ_ARR_CN; + FILE_ARR_CN : FILE_TYPE; + INCOMPLETE : EXCEPTION; + ARR1 : ARR_CN := (TRUE,TRUE,FALSE,TRUE,TRUE); + ITEM_ARR1 : ARR_CN; + BEGIN + BEGIN + CREATE (FILE_ARR_CN, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_ARR_CN, ARR1); + CLOSE (FILE_ARR_CN); + + BEGIN + OPEN (FILE_ARR_CN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_ARR_CN) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "CONSTRAINED ARRAY"); + END IF; + + READ (FILE_ARR_CN, ITEM_ARR1); + + IF ITEM_ARR1 /= ARR1 THEN + FAILED ("READ WRONG VALUE - CONSTRAINED ARRAY"); + END IF; + + IF NOT END_OF_FILE (FILE_ARR_CN) THEN + FAILED ("END OF FILE NOT TRUE - CONSTRAINED ARRAY"); + END IF; + + BEGIN + DELETE (FILE_ARR_CN); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CE2201C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT_TYPE FLOAT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 11/10/82 + -- JBG 20/22/84 CHANGED TO .ADA TEST. + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED AN EXTERNAL + -- FILE RATHER THAN A TEMPORARY FILE. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201C IS + BEGIN + + TEST ("CE2201C", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - FLOAT"); + + DECLARE + PACKAGE SEQ_FLT IS NEW SEQUENTIAL_IO (FLOAT); + USE SEQ_FLT; + FILE_FLT : FILE_TYPE; + INCOMPLETE : EXCEPTION; + FLT : FLOAT := 65.0; + ITEM_FLT : FLOAT; + BEGIN + BEGIN + CREATE (FILE_FLT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_FLT, FLT); + CLOSE (FILE_FLT); + + BEGIN + OPEN (FILE_FLT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_FLT) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR FLOATING POINT"); + END IF; + + READ (FILE_FLT, ITEM_FLT); + + IF ITEM_FLT /= 65.0 THEN + FAILED ("READ WRONG VALUE - FLOAT"); + END IF; + + IF NOT END_OF_FILE (FILE_FLT) THEN + FAILED ("END OF FILE NOT TRUE - FLOAT"); + END IF; + + BEGIN + DELETE (FILE_FLT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2201C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201d.dep 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- CE2201D.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT_TYPE UNCONSTRAINED ARRAY. + + -- IF I/O IS NOT SUPPORTED, THEN CREATE AND OPEN CAN RAISE USE_ERROR + -- OR NAME_ERROR. SEE (AI-00332). + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS NON-APPLICABLE IF THE INSTANTIATION OF SEQUENTIAL_IO + -- WITH UNCONSTRAINED ARRAY TYPE, ARR_UNCN, IS NOT SUPPORTED. + + -- IF THE INSTANTIATION OF SEQUENTIAL_IO IS NOT SUPPORTED THEN + -- THE INSTANTIATION MUST BE REJECTED. + + -- HISTORY: + -- ABW 8/17/82 + -- SPS 9/15/82 + -- SPS 11/9/82 + -- JBG 1/6/83 + -- JBG 6/4/84 + -- TBN 11/01/85 RENAMED FROM CE2201D.DEP AND MODIFIED COMMENTS. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- THS 03/30/90 RENAMED FROM EE2201D.ADA. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201D IS + INCOMPLETE : EXCEPTION; + BEGIN + + TEST ("CE2201D" , "CHECK WHETHER READ, WRITE, AND END_OF_FILE " & + "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " & + "UNCONSTRAINED ARRAY TYPES"); + + DECLARE + SUBTYPE ONE_TEN IS INTEGER RANGE 1..10; + TYPE ARR_UNCN IS ARRAY (ONE_TEN RANGE <>) OF INTEGER; + PACKAGE SEQ_ARR_UNCN + IS NEW SEQUENTIAL_IO (ARR_UNCN); -- N/A => ERROR. + USE SEQ_ARR_UNCN; + FILE_ARR_UNCN : FILE_TYPE; + ARR2 : ARR_UNCN (1..6) := (1,3,5,7,9,0); + ITEM_ARR2 : ARR_UNCN (1..6); + BEGIN + BEGIN + CREATE (FILE_ARR_UNCN); + + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FILE_ARR_UNCN,ARR2); + WRITE (FILE_ARR_UNCN, (0, -2)); + + EXCEPTION + WHEN OTHERS => + FAILED ("WRITE FOR UNCONSTRAINED ARRAY"); + END; + + RESET (FILE_ARR_UNCN,IN_FILE); + + IF END_OF_FILE (FILE_ARR_UNCN) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "UNCONSTRAINED ARRAY"); + END IF; + + BEGIN + READ (FILE_ARR_UNCN,ITEM_ARR2); + + EXCEPTION + WHEN OTHERS => + FAILED ("READ FOR UNCONSTRAINED ARRAY"); + END; + + IF ITEM_ARR2 /= (1,3,5,7,9,0) THEN + FAILED ("READ WRONG VALUE - 1"); + END IF; + + BEGIN + READ (FILE_ARR_UNCN, ITEM_ARR2(3..4)); + + IF ITEM_ARR2 /= (1,3,0,-2,9,0) THEN + FAILED ("READ WRONG VALUE - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION FOR SECOND ARRAY READ"); + END; + + IF NOT END_OF_FILE(FILE_ARR_UNCN) THEN + FAILED ("NOT AT END OF FILE"); + END IF; + + CLOSE (FILE_ARR_UNCN); + + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED BY RESET"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2201D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201e.dep 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,155 ---- + -- CE2201E.DEP + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH VARIANT RECORDS WITH NON-DEFAULT + -- DISCRIMINANTS. + + -- IF I/O IS NOT SUPPORTED, THEN CREATE AND OPEN CAN RAISE USE_ERROR + -- OR NAME_ERROR. SEE (AI-00332). + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS NON-APPLICABLE IF THE INSTANTIATION OF + -- SEQUENTIAL_IO WITH VARIANT RECORDS HAVING NO DEFAULT + -- DISCRIMINANT VALUES IS REJECTED. + + -- HISTORY: + -- JBG 1/6/83 + -- JBG 5/2/83 + -- TBN 11/18/85 RENAMED FROM CE2201E.DEP AND MODIFIED COMMENTS. + -- SPLIT DEFAULT DISCRIMINANT CASE INTO + -- CE2201G.ADA. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- THS 03/30/90 RENAMED FROM EE2201E.ADA. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201E IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2201E", "CHECK WHETHER READ, WRITE, AND END_OF_FILE " & + "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " & + "UNCONSTRAINED VARIANT RECORD TYPES WITH " & + "NON-DEFAULT DISCRIMINANTS."); + + DECLARE + TYPE VAR_REC (DISCR : BOOLEAN) IS + RECORD + CASE DISCR IS + WHEN TRUE => + A : INTEGER; + WHEN FALSE => + B : STRING (1..20); + END CASE; + END RECORD; + + PACKAGE SEQ_VAR_REC + IS NEW SEQUENTIAL_IO (VAR_REC); -- N/A => ERROR. + USE SEQ_VAR_REC; + + FILE_VAR_REC : FILE_TYPE; + ITEM_TRUE : VAR_REC(TRUE); + ITEM_FALSE : VAR_REC(FALSE); + + BEGIN + + BEGIN + CREATE (FILE_VAR_REC); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; SEQUENTIAL " & + "CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FILE_VAR_REC, (TRUE, -6)); + WRITE (FILE_VAR_REC, (FALSE, (1..20 => 'C'))); + EXCEPTION + WHEN OTHERS => + FAILED ("WRITE FOR RECORD WITH DISCRIMINANT"); + END; + + BEGIN + RESET (FILE_VAR_REC,IN_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR FOR RESET"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_VAR_REC) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" & + "WITH DISCRIMINANT"); + END IF; + + BEGIN + READ (FILE_VAR_REC,ITEM_TRUE); + + IF ITEM_TRUE /= (TRUE, IDENT_INT(-6)) THEN + FAILED ("READ WRONG VALUE - 1"); + END IF; + + IF END_OF_FILE (FILE_VAR_REC) THEN + FAILED ("PREMATURE END OF FILE"); + END IF; + + READ (FILE_VAR_REC, ITEM_FALSE); + + IF ITEM_FALSE /= (FALSE, (1..IDENT_INT(20) => 'C')) THEN + FAILED ("READ WRONG VALUE - 2"); + END IF; + + IF NOT END_OF_FILE(FILE_VAR_REC) THEN + FAILED ("NOT AT END OF FILE"); + END IF; + + EXCEPTION + WHEN OTHERS => + FAILED ("READ FOR VARIANT RECORD"); + END; + + CLOSE (FILE_VAR_REC); + + END; + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2201E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- CE2201F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH PRIVATE ELEMENT_TYPES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES WITH PRIVATE ELEMENT_TYPES. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 01/06/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED EXTERNAL + -- FILES RATHER THAN TEMPORARY FILES. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201F IS + + PACKAGE PKG IS + TYPE PRIV IS PRIVATE; + FUNCTION MAKE_PRIV (X : INTEGER) RETURN PRIV; + PRIVATE + TYPE PRIV IS NEW INTEGER; + END PKG; + USE PKG; + + PACKAGE BODY PKG IS + FUNCTION MAKE_PRIV (X : INTEGER) RETURN PRIV IS + BEGIN + RETURN PRIV(X); + END; + END PKG; + + BEGIN + + TEST ("CE2201F", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES FOR PRIVATE TYPES"); + + DECLARE + PACKAGE SEQ_PRV IS NEW SEQUENTIAL_IO (PRIV); + USE SEQ_PRV; + PRV, ITEM_PRV : PRIV; + FILE_PRV : FILE_TYPE; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FILE_PRV, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + PRV := MAKE_PRIV(IDENT_INT(26)); + + WRITE (FILE_PRV, PRV); + CLOSE (FILE_PRV); + + BEGIN + OPEN (FILE_PRV, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_PRV) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR PRIVATE TYPE"); + END IF; + + READ (FILE_PRV, ITEM_PRV); + + IF ITEM_PRV /= MAKE_PRIV (26) THEN + FAILED ("READ WRONG VALUE"); + END IF; + + IF NOT END_OF_FILE (FILE_PRV) THEN + FAILED ("NOT AT END OF FILE"); + END IF; + + BEGIN + DELETE (FILE_PRV); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- CE2201G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED + -- FOR SEQUENTIAL FILES WITH VARIANT RECORDS WITH DEFAULT + -- DISCRIMINANTS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 05/15/86 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/03/87 REMOVED DEPENDENCE OF RESET AND CREATED EXTERNAL + -- FILES RATHER THAN TEMPORARY FILES. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201G IS + + BEGIN + + TEST ("CE2201G", "CHECK THAT READ, WRITE, AND END_OF_FILE " & + "ARE SUPPORTED FOR SEQUENTIAL FILES WITH " & + "UNCONSTRAINED VARIANT RECORD TYPES WITH " & + "DEFAULT DISCRIMINANTS."); + + DECLARE + TYPE VAR_REC (DISCR : BOOLEAN := TRUE) IS + RECORD + CASE DISCR IS + WHEN TRUE => + A : INTEGER; + WHEN FALSE => + B : STRING (1..20); + END CASE; + END RECORD; + + PACKAGE SEQ_VAR_REC IS NEW SEQUENTIAL_IO (VAR_REC); + USE SEQ_VAR_REC; + + FILE_VAR_REC : FILE_TYPE; + INCOMPLETE : EXCEPTION; + ITEM_TRUE : VAR_REC(TRUE); -- CONSTRAINED + ITEM : VAR_REC; -- UNCONSTRAINED + + BEGIN + BEGIN + CREATE (FILE_VAR_REC, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_VAR_REC, (TRUE, -5)); + WRITE (FILE_VAR_REC, (FALSE, (1..20 => 'B'))); + CLOSE (FILE_VAR_REC); + + BEGIN + OPEN (FILE_VAR_REC, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_VAR_REC) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" & + "WITH DISCRIMINANT"); + END IF; + + BEGIN + READ (FILE_VAR_REC, ITEM_TRUE); + + IF ITEM_TRUE /= (TRUE, IDENT_INT(-5)) THEN + FAILED ("READ WRONG VALUE - 1"); + END IF; + + IF END_OF_FILE (FILE_VAR_REC) THEN + FAILED ("PREMATURE END OF FILE"); + END IF; + + READ (FILE_VAR_REC, ITEM); + + IF ITEM /= (FALSE, (1..IDENT_INT(20) => 'B')) THEN + FAILED ("READ WRONG VALUE - 2"); + END IF; + + IF NOT END_OF_FILE(FILE_VAR_REC) THEN + FAILED ("NOT AT END OF FILE"); + END IF; + + END; + + BEGIN + DELETE (FILE_VAR_REC); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2201G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CE2201H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT TYPE INTEGER. + + -- APPLICABILITY: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES WITH ELEMENT TYPE INTEGER. + + -- HISTORY: + -- JLH 07/28/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201H IS + + BEGIN + + TEST ("CE2201H" , "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - INTEGER TYPE"); + + DECLARE + PACKAGE SEQ_INT IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_INT; + FILE_INT : FILE_TYPE; + INCOMPLETE : EXCEPTION; + INT : INTEGER := IDENT_INT (33); + ITEM_INT : INTEGER; + BEGIN + BEGIN + CREATE (FILE_INT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_INT, INT); + CLOSE (FILE_INT); + + BEGIN + OPEN (FILE_INT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_INT) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE INTEGER"); + END IF; + + READ (FILE_INT, ITEM_INT); + + IF ITEM_INT /= IDENT_INT(33) THEN + FAILED ("READ WRONG VALUE - INTEGER"); + END IF; + + IF NOT END_OF_FILE (FILE_INT) THEN + FAILED ("END OF FILE NOT TRUE - INTEGER"); + END IF; + + BEGIN + DELETE (FILE_INT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CE2201I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT TYPE BOOLEAN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 07/28/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201I IS + + BEGIN + + TEST ("CE2201I", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - BOOLEAN TYPE"); + + DECLARE + PACKAGE SEQ_BOOL IS NEW SEQUENTIAL_IO (BOOLEAN); + USE SEQ_BOOL; + FILE_BOOL : FILE_TYPE; + INCOMPLETE : EXCEPTION; + BOOL : BOOLEAN := IDENT_BOOL (TRUE); + ITEM_BOOL : BOOLEAN; + BEGIN + BEGIN + CREATE (FILE_BOOL, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_BOOL, BOOL); + CLOSE (FILE_BOOL); + + BEGIN + OPEN (FILE_BOOL, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_BOOL) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE BOOLEAN"); + END IF; + + READ (FILE_BOOL, BOOL); + + IF BOOL /= IDENT_BOOL (TRUE) THEN + FAILED ("READ WRONG VALUE - BOOLEAN"); + END IF; + + IF NOT END_OF_FILE (FILE_BOOL) THEN + FAILED ("END OF FILE NOT TRUE - BOOLEAN"); + END IF; + + BEGIN + DELETE (FILE_BOOL); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201j.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CE2201J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT TYPE ENUMERATION. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 07/28/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201J IS + + BEGIN + + TEST ("CE2201J", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - ENUMERATION TYPE"); + + DECLARE + TYPE ENUMERATION IS (ONE, TWO, '4'); + PACKAGE SEQ_ENUM IS NEW SEQUENTIAL_IO (ENUMERATION); + USE SEQ_ENUM; + FILE_ENUM : FILE_TYPE; + INCOMPLETE : EXCEPTION; + ENUM : ENUMERATION := ('4'); + ITEM_ENUM : ENUMERATION; + BEGIN + BEGIN + CREATE (FILE_ENUM, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_ENUM, ENUM); + CLOSE (FILE_ENUM); + + BEGIN + OPEN (FILE_ENUM, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_ENUM) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE ENUMERATION"); + END IF; + + READ (FILE_ENUM, ITEM_ENUM); + + IF ITEM_ENUM /= '4' THEN + FAILED ("READ WRONG VALUE - ENUMERATION"); + END IF; + + IF NOT END_OF_FILE (FILE_ENUM) THEN + FAILED ("END OF FILE NOT TRUE - ENUMERATION"); + END IF; + + BEGIN + DELETE (FILE_ENUM); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201k.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- CE2201K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT TYPE ACCESS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 07/28/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201K IS + + BEGIN + + TEST ("CE2201K", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - ACCESS TYPE"); + + DECLARE + TYPE ACC_INT IS ACCESS INTEGER; + PACKAGE SEQ_ACC IS NEW SEQUENTIAL_IO (ACC_INT); + USE SEQ_ACC; + FILE_ACC : FILE_TYPE; + INCOMPLETE : EXCEPTION; + ACC : ACC_INT := NEW INTEGER'(33); + ITEM_ACC : ACC_INT; + BEGIN + BEGIN + CREATE (FILE_ACC, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_ACC, ACC); + CLOSE (FILE_ACC); + + BEGIN + OPEN (FILE_ACC, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_ACC) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE ACCESS"); + END IF; + + READ (FILE_ACC, ITEM_ACC); + + IF NOT END_OF_FILE (FILE_ACC) THEN + FAILED ("END OF FILE NOT TRUE - ACCESS"); + END IF; + + BEGIN + DELETE (FILE_ACC); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201l.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CE2201L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT TYPE FIXED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 08/03/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201L IS + BEGIN + + TEST ("CE2201L", "CHECK THAT READ, WRITE, AND END_OF_FILE " & + "ARE SUPPORTED FOR SEQUENTIAL FILES - FIXED"); + + DECLARE + TYPE FIX IS DELTA 0.5 RANGE -10.0 .. 255.0; + PACKAGE SEQ_FIX IS NEW SEQUENTIAL_IO (FIX); + USE SEQ_FIX; + FILE_FIX : FILE_TYPE; + INCOMPLETE : EXCEPTION; + FX : FIX := -8.5; + ITEM_FIX : FIX; + BEGIN + BEGIN + CREATE (FILE_FIX, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_FIX, FX); + CLOSE (FILE_FIX); + + BEGIN + OPEN (FILE_FIX, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_FIX) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR FIXED POINT"); + END IF; + + READ (FILE_FIX, ITEM_FIX); + + IF NOT END_OF_FILE (FILE_FIX) THEN + FAILED ("END OF FILE NOT TRUE - FIXED"); + END IF; + + IF ITEM_FIX /= -8.5 THEN + FAILED ("READ WRONG VALUE - STRING"); + END IF; + + BEGIN + DELETE (FILE_FIX); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201m.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- CE2201M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED + -- FOR SEQUENTIAL FILES WITH ELEMENT_TYPE RECORD WITHOUT + -- DISCRIMINANTS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT SEQUENTIAL FILES WITH ELEMENT_TYPE RECORD WITHOUT + -- DISCRIMINANTS. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 05/02/83 + -- EG 05/08/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED + -- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY + -- FILES. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201M IS + + BEGIN + + TEST ("CE2201M", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - RECORD WITHOUT " & + "DISCRIMINANTS"); + + DECLARE + TYPE REC IS + RECORD + ONE : INTEGER; + TWO : INTEGER; + END RECORD; + PACKAGE SEQ_REC IS NEW SEQUENTIAL_IO (REC); + USE SEQ_REC; + FILE_REC : FILE_TYPE; + INCOMPLETE : EXCEPTION; + REC1 : REC := (ONE=>18, TWO=>36); + ITEM_REC1 : REC; + BEGIN + + BEGIN + CREATE (FILE_REC, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_REC, REC1); + CLOSE (FILE_REC); + + BEGIN + OPEN (FILE_REC, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_REC) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE RECORD"); + END IF; + + READ (FILE_REC, ITEM_REC1); + + IF ITEM_REC1 /= (18, IDENT_INT(36)) THEN + FAILED ("READ WRONG VALUE - RECORD"); + END IF; + + IF NOT END_OF_FILE (FILE_REC) THEN + FAILED ("END OF FILE NOT TRUE - RECORD"); + END IF; + + BEGIN + DELETE (FILE_REC); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2201n.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + -- CE2201N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE ARE SUPPORTED FOR + -- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED RECORD TYPES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES WITH ELEMENT_TYPE CONSTRAINED RECORD TYPES. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 05/02/83 + -- EG 05/08/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 07/28/87 REMOVED THE DEPENDENCE OF RESET BEING SUPPORTED + -- AND CREATED EXTERNAL FILES RATHER THAN TEMPORARY + -- FILES. + + WITH REPORT; + USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2201N IS + + BEGIN + + TEST ("CE2201N", "CHECK THAT READ, WRITE, AND " & + "END_OF_FILE ARE SUPPORTED FOR " & + "SEQUENTIAL FILES - CONSTRAINED RECORDS"); + + DECLARE + TYPE REC_DEF (DISCR : INTEGER := 18) IS + RECORD + ONE : INTEGER := 1; + TWO : INTEGER := 2; + THREE : INTEGER := 17; + FOUR : INTEGER := 2; + END RECORD; + SUBTYPE REC_DEF_2 IS REC_DEF(2); + PACKAGE SEQ_REC_DEF IS NEW SEQUENTIAL_IO (REC_DEF_2); + USE SEQ_REC_DEF; + FILE_REC_DEF : FILE_TYPE; + INCOMPLETE : EXCEPTION; + REC3 : REC_DEF(2); + ITEM_REC3 : REC_DEF(2); + BEGIN + BEGIN + CREATE (FILE_REC_DEF, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE OF SEQUENTIAL FILE WITH " & + "MODE OUT_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + WRITE (FILE_REC_DEF, REC3); + CLOSE (FILE_REC_DEF); + + BEGIN + OPEN (FILE_REC_DEF, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN OF SEQUENTIAL FILE WITH " & + "MODE IN_FILE NOT SUPPORTED"); + RAISE INCOMPLETE; + END; + + IF END_OF_FILE (FILE_REC_DEF) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR RECORD" & + "WITH DEFAULT"); + END IF; + + READ (FILE_REC_DEF, ITEM_REC3); + + IF ITEM_REC3 /= (2, IDENT_INT(1),2,17,2) THEN + FAILED ("READ WRONG VALUE - RECORD WITH DEFAULT"); + END IF; + + IF NOT END_OF_FILE (FILE_REC_DEF) THEN + FAILED ("END OF FILE NOT TRUE - RECORD WITH DEFAULT"); + END IF; + + BEGIN + DELETE (FILE_REC_DEF); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2201N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2202a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- CE2202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, AND END_OF_FILE RAISE STATUS_ERROR + -- WHEN APPLIED TO A NON-OPEN SEQUENTIAL FILE. USE_ERROR IS + -- NOT PERMITTED. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/13/82 + -- SPS 11/09/82 + -- EG 11/26/84 + -- EG 05/16/85 + -- GMT 07/24/87 REPLACED CALL TO REPORT.COMMENT WITH "NULL;". + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2202A IS + + PACKAGE SEQ IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ; + FILE1, FILE2 : FILE_TYPE; + CNST : CONSTANT INTEGER := 101; + IVAL : INTEGER; + BOOL : BOOLEAN; + + BEGIN + TEST ("CE2202A","CHECK THAT READ, WRITE, AND " & + "END_OF_FILE RAISE STATUS_ERROR " & + "WHEN APPLIED TO A NON-OPEN " & + "SEQUENTIAL FILE"); + BEGIN + BEGIN + WRITE (FILE1,CNST); + FAILED ("STATUS_ERROR NOT RAISED WHEN WRITE APPLIED " & + "TO NON-EXISTENT FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN WRITE " & + "APPLIED TO NON-EXISTENT FILE"); + END; + + BEGIN + READ (FILE1,IVAL); + FAILED ("STATUS_ERROR NOT RAISED WHEN READ APPLIED " & + "TO NON-EXISTENT FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN READ " & + "APPLIED TO NON-EXISTENT FILE"); + END; + + BEGIN + BOOL := END_OF_FILE (FILE1); + FAILED ("STATUS_ERROR NOT RAISED WHEN END_OF_FILE " & + "APPLIED TO NON-EXISTENT FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN END_OF_FILE " & + "APPLIED TO NON-EXISTENT FILE"); + END; + END; + + BEGIN + BEGIN + CREATE (FILE2); + CLOSE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; -- IF FILE2 CANNOT BE CREATED THEN WE WILL + -- BE REPEATING EARLIER TESTS, BUT THAT'S OK. + END; + + BEGIN + WRITE (FILE2,CNST); + FAILED ("STATUS_ERROR NOT RAISED WHEN WRITE APPLIED " & + "TO FILE2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN WRITE " & + "APPLIED TO FILE2"); + END; + + BEGIN + READ (FILE2,IVAL); + FAILED ("STATUS_ERROR NOT RAISED WHEN READ APPLIED " & + "TO FILE2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN READ " & + "APPLIED TO FILE2"); + END; + + BEGIN + BOOL := END_OF_FILE (FILE2); + FAILED ("STATUS_ERROR NOT RAISED WHEN END_OF_FILE " & + "APPLIED TO FILE2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED WHEN END_OF_FILE " & + "APPLIED TO FILE2"); + END; + + END; + + RESULT; + + END CE2202A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2203a.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- CE2203A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR SEQUENTIAL_IO, WRITE RAISES THE EXCEPTION + -- USE_ERROR IF THE CAPACITY OF THE EXTERNAL FILE IS EXCEEDED. + -- THIS TEST ONLY CHECKS THAT THE IMPLEMENTATION SUPPORTS AN + -- EXTERNAL FILE CAPACITY OF 4096 CHARACTERS OR LESS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. ALSO, THE IMPLEMENTATION MUST BE ABLE TO + -- RESTRICT THE CAPACITY OF AN EXTERNAL FILE. + + -- $FORM_STRING2 IS DEFINED SUCH THAT THE CAPACITY OF THE FILE IS + -- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION + -- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL + -- "CANNOT_RESTRICT_FILE_CAPACITY". + + -- HISTORY: + -- JLH 07/12/88 CREATED ORIGINAL TEST. + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2203A IS + + SUBTYPE STR512 IS STRING (1 .. 512); + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (STR512); + USE SEQ_IO; + + FILE : FILE_TYPE; + ITEM : STR512 := (1 .. 512 => 'A'); + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2203A", "CHECK FOR SEQUENTIAL_IO THAT WRITE RAISES " & + "USE_ERROR IF THE CAPACITY OF THE EXTERNAL " & + "FILE IS EXCEEDED"); + + BEGIN + + IF + $FORM_STRING2 + = STRING'("CANNOT_RESTRICT_FILE_CAPACITY") THEN + NOT_APPLICABLE ("IMPLEMENTATION CANNOT RESTRICT FILE " & + "CAPACITY"); + RAISE INCOMPLETE; + ELSE + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME, + + $FORM_STRING2 + ); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON " & + "CREATE WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "CREATE"); + RAISE INCOMPLETE; + END; + END IF; + + BEGIN + FOR I IN 1 .. 9 LOOP + WRITE (FILE, ITEM); + END LOOP; + FAILED ("USE_ERROR NOT RAISED WHEN THE CAPACITY " & + "OF THE EXTERNAL FILE IS EXCEEDED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE2204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE IS FORBIDDEN FOR SEQUENTIAL FILES OF + -- MODE IN_FILE. + + -- A) CHECK NON-TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- DLD 08/17/82 + -- SPS 08/24/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- JBG 03/30/84 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 07/27/87 SPLIT THIS TEST BY MOVING THE CODE FOR CHECKING + -- TEMPORARY FILES INTO CE2204C.ADA. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2204A IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2204A", "CHECK THAT MODE_ERROR IS RAISED BY WRITE " & + "WHEN THE MODE IS IN_FILE AND THE FILE " & + "IS A NON-TEMPORARY FILE"); + DECLARE + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + SEQ_FILE : FILE_TYPE; + VAR1 : INTEGER := 5; + BEGIN + BEGIN + CREATE (SEQ_FILE, OUT_FILE, + LEGAL_FILE_NAME (1, "CE2204A")); + WRITE (SEQ_FILE, VAR1); + CLOSE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; " & + "SEQUENTIAL CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; " & + "SEQUENTIAL CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; " & + "SEQUENTIAL CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (SEQ_FILE, IN_FILE, + LEGAL_FILE_NAME (1, "CE2204A")); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON THE " & + "OPENING OF A SEQUENTIAL " & + "NON-TEMPORARY FILE"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (SEQ_FILE, 3); + FAILED ("MODE_ERROR NOT RAISED - NAMED FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NAMED FILE"); + END; + + BEGIN + DELETE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CE2204B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ AND END_OF_FILE ARE FORBIDDEN FOR SEQUENTIAL + -- FILES OF MODE OUT_FILE. + + -- A) CHECK NON-TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- THE CREATION OF SEQUENTIAL FILES. + + -- HISTORY: + -- DLD 08/17/82 + -- SPS 08/24/82 + -- SPS 110/9/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 07/24/87 SPLIT THIS TEST BY MOVING THE CODE FOR CHECKING + -- TEMPORARY FILES INTO CE2204D.ADA. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2204B IS + BEGIN + TEST ("CE2204B", "FOR A NON-TEMPORARY SEQUENTIAL FILE, CHECK " & + "THAT MODE_ERROR IS RAISED BY READ AND " & + "END_OF_FILE WHEN THE MODE IS OUT_FILE"); + DECLARE + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + SEQ_FILE : FILE_TYPE; + X : INTEGER; + B : BOOLEAN; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (SEQ_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 3"); + RAISE INCOMPLETE; + END; + + WRITE (SEQ_FILE, 5); + + BEGIN -- THIS IS ONLY + RESET (SEQ_FILE); -- AN ATTEMPT + EXCEPTION -- TO RESET, + WHEN USE_ERROR => -- IF RESET + NULL; -- N/A THEN + END; -- TEST IS + -- NOT AFFECTED. + BEGIN + READ (SEQ_FILE, X); + FAILED ("MODE_ERROR NOT RAISED ON READ - 4"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 5"); + END; + + BEGIN + B := END_OF_FILE (SEQ_FILE); + FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 6"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - END_OF_FILE - 7"); + END; + + BEGIN + DELETE (SEQ_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2204B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CE2204C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE IS FORBIDDEN FOR SEQUENTIAL FILES OF + -- MODE IN_FILE. + + -- B) CHECK TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEMPORARY SEQUENTIAL FILES AND THE RESETTING FROM OUT_FILE + -- TO IN_FILE. + + -- HISTORY: + -- GMT 07/27/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2204C IS + INCOMPLETE : EXCEPTION; + BEGIN + TEST ("CE2204C", "CHECK THAT MODE_ERROR IS RAISED BY WRITE " & + "WHEN THE MODE IS INFILE AND THE FILE IS " & + "A TEMPORARY FILE"); + DECLARE + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + FT : FILE_TYPE; + VAR1 : INTEGER := 5; + BEGIN + BEGIN + CREATE (FT, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + END; + + WRITE (FT, VAR1); + + BEGIN + RESET (FT, IN_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON RESET - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE(FT, 3); + FAILED ("MODE_ERROR NOT RAISED ON WRITE - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON WRITE - 4"); + END; + + CLOSE (FT); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2204C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2204d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CE2204D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ AND END_OF_FILE ARE FORBIDDEN FOR SEQUENTIAL + -- FILES OF MODE OUT_FILE. + + -- B) CHECK TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- THE CREATION OF TEMPORARY SEQUENTIAL FILES. + + -- HISTORY: + -- GMT 07/24/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2204D IS + BEGIN + TEST ("CE2204D", "FOR A TEMPORARY SEQUENTIAL FILE, CHECK THAT " & + "MODE_ERROR IS RAISED BY READ AND END_OF_FILE " & + "WHEN THE MODE IS OUT_FILE"); + DECLARE + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + FT : FILE_TYPE; + X : INTEGER; + B : BOOLEAN; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + WRITE (FT, 5); + + BEGIN -- THIS IS ONLY + RESET (FT); -- AN ATTEMPT + EXCEPTION -- TO RESET, + WHEN USE_ERROR => -- IF RESET + NULL; -- N/A THEN + END; -- TEST IS + -- NOT AFFECTED. + + BEGIN + READ (FT, X); + FAILED ("MODE_ERROR NOT RAISED ON READ - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 4"); + END; + + BEGIN + B := END_OF_FILE (FT); + FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 5"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - END_OF_FILE - 6"); + END; + + CLOSE (FT); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2204D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2205a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- CE2205A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK WHETHER READ FOR A SEQUENTIAL FILE RAISES DATA_ERROR OR + -- CONSTRAINT_ERROR WHEN AN ELEMENT IS READ THAT IS OUTSIDE THE + -- RANGE OF THE ITEM TYPE BUT WITHIN THE RANGE OF THE INSTANTIATED + -- TYPE, AND CHECK THAT READING CAN CONTINUE AFTER THE EXCEPTION + -- HAS BEEN HANDLED. + + -- A) CHECK ENUMERATION TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT SEQUENTIAL FILES. + + -- HISTORY: + -- SPS 09/28/82 + -- JBG 06/04/84 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 07/24/87 RENAMED FROM CE2210A.ADA AND REMOVED THE USE OF + -- RESET. + -- PWB 05/18/89 DELETED CALL TO FAILED WHEN NO EXCEPTION RAISED. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2205A IS + BEGIN + + TEST ("CE2205A", "CHECK WHETHER READ FOR A SEQUENTIAL FILE " & + "RAISES DATA_ERROR OR CONSTRAINT_ERROR WHEN " & + "AN ELEMENT IS READ THAT IS OUTSIDE THE RANGE " & + "OF THE ITEM TYPE BUT WITHIN THE RANGE OF THE " & + "INSTANTIATED TYPE, AND CHECK THAT READING CAN " & + "CONTINUE AFTER THE EXCEPTION HAS BEEN HANDLED"); + DECLARE + PACKAGE SEQ IS NEW SEQUENTIAL_IO (CHARACTER); + USE SEQ; + FT : FILE_TYPE; + SUBTYPE CH IS CHARACTER RANGE 'A' .. 'D'; + X : CH; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON SEQUENTIAL " & + "CREATE WITH OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "SEQUENTIAL CREATE - 3"); + RAISE INCOMPLETE; + END; + + WRITE (FT, 'A'); + WRITE (FT, 'M'); + WRITE (FT, 'B'); + WRITE (FT, 'C'); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE IS NOT " & + "SUPPORTED - 4"); + RAISE INCOMPLETE; + END; + + -- BEGIN TEST + + READ (FT, X); + IF X /= 'A' THEN + FAILED ("INCORRECT VALUE FOR READ - 5"); + END IF; + + BEGIN + READ (FT, X); + COMMENT ("NO EXCEPTION RAISED FOR READ WITH ELEMENT " & + "OUT OF RANGE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED FOR SCALAR " & + "TYPES - 7"); + WHEN DATA_ERROR => + COMMENT ("DATA_ERROR RAISED FOR SCALAR TYPES - 8"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 9"); + END; + + BEGIN + READ (FT, X); + IF X /= 'B' THEN + FAILED ("INCORRECT VALUE FOR READ - 10"); + END IF; + + READ (FT, X); + IF X /= 'C' THEN + FAILED ("INCORRECT VALUE FOR READ - 11"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("UNABLE TO CONTINUE READING - 12"); + RAISE INCOMPLETE; + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2205A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2206a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- CE2206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ FOR A SEQUENTIAL FILE RAISES END_ERROR WHEN + -- THERE ARE NO MORE ELEMENTS THAT CAN BE READ FROM THE GIVEN + -- FILE. ALSO CHECK THAT END_OF_FILE CORRECTLY DETECTS THE END + -- OF A SEQUENTIAL FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- SEQUENTIAL FILES. + + -- HISTORY: + -- JLH 08/22/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH SEQUENTIAL_IO; + + PROCEDURE CE2206A IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (CHARACTER); + USE SEQ_IO; + + FILE : FILE_TYPE; + ITEM : CHARACTER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2206A", "CHECK THAT READ FOR A SEQUENTIAL FILE RAISES " & + "END_ERROR WHEN THERE ARE NO MORE ELEMENTS " & + "THAT CAN BE READ FROM THE GIVEN FILE. ALSO " & + "CHECK THAT END_OF_FILE CORRECTLY DETECTS THE " & + "END OF A SEQUENTIAL FILE"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + WRITE (FILE, 'A'); + WRITE (FILE, 'B'); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + READ (FILE, ITEM); + IF ITEM /= 'A' THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + IF END_OF_FILE (FILE) THEN + FAILED ("END_OF_FILE NOT DETECTED CORRECTLY - 1"); + END IF; + + READ (FILE, ITEM); + + IF NOT END_OF_FILE (FILE) THEN + FAILED ("END_OF_FILE NOT DETECTED CORRECTLY - 2"); + END IF; + + BEGIN + READ (FILE, ITEM); + FAILED ("END_ERROR NOT RAISED FOR READ"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON READ"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2208b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + -- CE2208B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA CAN BE OVERWRITTEN IN THE SEQUENTIAL FILE AND THE + -- CORRECT VALUES CAN LATER BE READ. ALSO CHECK THAT OVERWRITING + -- TRUNCATES THE FILE TO THE LAST ELEMENT WRITTEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- THE CREATING AND OPENING OF SEQUENTIAL FILES. + + -- HISTORY: + -- TBN 09/30/86 CREATED ORIGINAL TEST. + -- GMT 07/24/87 ADDED CHECKS FOR USE_ERROR AND REMOVED SOME CODE. + -- BCB 10/03/90 CHANGED CODE TO CHECK THAT OVERWRITING TRUNCATES + -- INSTEAD OF WHETHER IT TRUNCATES. + + WITH SEQUENTIAL_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2208B IS + + PACKAGE SEQ_IO IS NEW SEQUENTIAL_IO (INTEGER); + USE SEQ_IO; + + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2208B", + "CHECK THAT DATA CAN BE OVERWRITTEN IN THE SEQUENTIAL " & + "FILE AND THE CORRECT VALUES CAN LATER BE READ. ALSO " & + "CHECK THAT OVERWRITING TRUNCATES THE FILE." ); + + -- INITIALIZE TEST FILE + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED DURING CREATE"); + RAISE INCOMPLETE; + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED DURING CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED DURING CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + FOR I IN 1 .. 25 LOOP + WRITE (FILE1, I); + END LOOP; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING WRITE"); + RAISE INCOMPLETE; + END; + + BEGIN + CLOSE (FILE1); + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING CLOSE"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ( "OPEN WITH OUT_FILE MODE NOT " & + "SUPPORTED FOR SEQUENTIAL FILES" ); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING OPEN"); + RAISE INCOMPLETE; + END; + + BEGIN + FOR I IN 26 .. 36 LOOP + WRITE (FILE1, I); + END LOOP; + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING OVERWRITE"); + RAISE INCOMPLETE; + END; + + BEGIN + CLOSE (FILE1); + EXCEPTION + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING 2ND CLOSE"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ( "OPEN WITH IN_FILE MODE NOT " & + "SUPPORTED FOR SEQUENTIAL FILES" ); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("EXCEPTION RAISED DURING SECOND OPEN"); + RAISE INCOMPLETE; + END; + + DECLARE + END_REACHED : BOOLEAN := FALSE; + COUNT : INTEGER := 26; + NUM : INTEGER; + BEGIN + WHILE COUNT <= 36 AND NOT END_REACHED LOOP + BEGIN + READ (FILE1, NUM); + IF NUM /= COUNT THEN + FAILED ("INCORRECT RESULTS READ FROM FILE " & + INTEGER'IMAGE (NUM)); + END IF; + COUNT := COUNT + 1; + EXCEPTION + WHEN END_ERROR => + END_REACHED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "READING - 1"); + RAISE INCOMPLETE; + END; + END LOOP; + IF COUNT <= 36 THEN + FAILED ("FILE WAS INCOMPLETE"); + RAISE INCOMPLETE; + ELSE + BEGIN + READ (FILE1, NUM); + FAILED ("END_ERROR NOT RAISED BY ATTEMPT TO READ"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "DURING READING - 2"); + RAISE INCOMPLETE; + END; + END IF; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2208B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,357 ---- + -- CE2401A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE AND + -- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPES + -- STRING, CHARACTER, AND INTEGER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT DIRECT FILES. + + -- HISTORY: + -- ABW 08/16/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 07/31/87 ISOLATED EXCEPTIONS. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401A IS + END_SUBTEST : EXCEPTION; + BEGIN + + TEST ("CE2401A" , "CHECK THAT READ, WRITE, SET_INDEX " & + "INDEX, SIZE AND END_OF_FILE ARE " & + "SUPPORTED FOR DIRECT FILES"); + + DECLARE + SUBTYPE STR_TYPE IS STRING (1..12); + PACKAGE DIR_STR IS NEW DIRECT_IO (STR_TYPE); + USE DIR_STR; + FILE_STR : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_STR, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - STRING"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - STRING"); + RAISE END_SUBTEST; + END; + + DECLARE + STR : STR_TYPE := "TEXT OF FILE"; + ITEM_STR : STR_TYPE; + ONE_STR : POSITIVE_COUNT := 1; + TWO_STR : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_STR,STR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "STRING - 1"); + END; + + BEGIN + WRITE (FILE_STR,STR,TWO_STR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "STRING - 2"); + END; + + BEGIN + IF SIZE (FILE_STR) /= TWO_STR THEN + FAILED ("SIZE FOR TYPE STRING"); + END IF; + IF NOT END_OF_FILE (FILE_STR) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR STRING"); + END IF; + SET_INDEX (FILE_STR,ONE_STR); + IF INDEX (FILE_STR) /= ONE_STR THEN + FAILED ("WRONG INDEX VALUE FOR STRING"); + END IF; + END; + + CLOSE (FILE_STR); + + BEGIN + OPEN (FILE_STR, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 1"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_STR,ITEM_STR); + IF ITEM_STR /= STR THEN + FAILED ("INCORRECT STRING VALUE READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR STRING"); + END; + + BEGIN + READ (FILE_STR,ITEM_STR,ONE_STR); + IF ITEM_STR /= STR THEN + FAILED ("INCORRECT STRING VALUE READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR STRING"); + END; + END; + + BEGIN + DELETE (FILE_STR); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + DECLARE + PACKAGE DIR_CHR IS NEW DIRECT_IO (CHARACTER); + USE DIR_CHR; + FILE_CHR : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_CHR, INOUT_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - CHARACTER"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - CHARACTER"); + RAISE END_SUBTEST; + END; + + DECLARE + CHR : CHARACTER := 'C'; + ITEM_CHR : CHARACTER; + ONE_CHR : POSITIVE_COUNT := 1; + TWO_CHR : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_CHR,CHR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "CHARACTER - 1"); + END; + + BEGIN + WRITE (FILE_CHR,CHR,TWO_CHR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "CHARACTER - 2"); + END; + + BEGIN + IF SIZE (FILE_CHR) /= TWO_CHR THEN + FAILED ("SIZE FOR TYPE CHARACTER"); + END IF; + IF NOT END_OF_FILE (FILE_CHR) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " & + "CHARACTER"); + END IF; + SET_INDEX (FILE_CHR,ONE_CHR); + IF INDEX (FILE_CHR) /= ONE_CHR THEN + FAILED ("WRONG INDEX VALUE FOR TYPE " & + "CHARACTER"); + END IF; + END; + + CLOSE (FILE_CHR); + + BEGIN + OPEN (FILE_CHR, IN_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 2"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_CHR,ITEM_CHR); + IF ITEM_CHR /= CHR THEN + FAILED ("INCORRECT CHR VALUE READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE CHARACTER"); + END; + + BEGIN + READ (FILE_CHR,ITEM_CHR,ONE_CHR); + IF ITEM_CHR /= CHR THEN + FAILED ("INCORRECT CHR VALUE READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE CHARACTER"); + END; + END; + + BEGIN + DELETE (FILE_CHR); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + DECLARE + PACKAGE DIR_INT IS NEW DIRECT_IO (INTEGER); + USE DIR_INT; + FILE_INT : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_INT, INOUT_FILE, LEGAL_FILE_NAME(3)); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - INTEGER"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - INTEGER"); + RAISE END_SUBTEST; + END; + + DECLARE + INT : INTEGER := IDENT_INT (33); + ITEM_INT : INTEGER; + ONE_INT : POSITIVE_COUNT := 1; + TWO_INT : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_INT,INT); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "INTEGER - 1"); + END; + + BEGIN + WRITE (FILE_INT,INT,TWO_INT); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "INTEGER - 2"); + END; + + BEGIN + IF SIZE (FILE_INT) /= TWO_INT THEN + FAILED ("SIZE FOR TYPE INTEGER"); + END IF; + IF NOT END_OF_FILE (FILE_INT) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " & + "INTEGER"); + END IF; + SET_INDEX (FILE_INT, ONE_INT); + IF INDEX (FILE_INT) /= ONE_INT THEN + FAILED ("WRONG INDEX VALUE FOR TYPE INTEGER"); + END IF; + END; + + CLOSE (FILE_INT); + + BEGIN + OPEN (FILE_INT, IN_FILE, LEGAL_FILE_NAME(3)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 3"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_INT,ITEM_INT); + IF ITEM_INT /= INT THEN + FAILED ("INCORRECT INT VALUE READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE INTEGER"); + END; + + BEGIN + READ (FILE_INT,ITEM_INT,ONE_INT); + IF ITEM_INT /= INT THEN + FAILED ("INCORRECT INT VALUE READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE INTEGER"); + END; + END; + + BEGIN + DELETE (FILE_INT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,347 ---- + -- CE2401B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE FOR DIRECT FILES WITH ELEMENT_TYPES BOOLEAN, + -- ACCESS, AND ENUMERATED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- ABW 08/18/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/07/87 ISOLATED EXCEPTIONS. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401B IS + END_SUBTEST : EXCEPTION; + BEGIN + + TEST ("CE2401B", "CHECK READ, WRITE, SET_INDEX " & + "INDEX, SIZE, AND END_OF_FILE FOR " & + "DIRECT FILES FOR BOOLEAN, ACCESS " & + "AND ENUMERATION TYPES"); + DECLARE + PACKAGE DIR_BOOL IS NEW DIRECT_IO (BOOLEAN); + USE DIR_BOOL; + FILE_BOOL : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_BOOL, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - BOOLEAN"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - BOOLEAN"); + RAISE END_SUBTEST; + END; + + DECLARE + BOOL : BOOLEAN := IDENT_BOOL (TRUE); + ITEM_BOOL : BOOLEAN; + ONE_BOOL : POSITIVE_COUNT := 1; + TWO_BOOL : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_BOOL,BOOL); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "BOOLEAN - 1"); + END; + + BEGIN + WRITE (FILE_BOOL,BOOL,TWO_BOOL); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "BOOLEAN - 2"); + END; + + BEGIN + IF SIZE (FILE_BOOL) /= TWO_BOOL THEN + FAILED ("SIZE FOR TYPE BOOLEAN"); + END IF; + IF NOT END_OF_FILE (FILE_BOOL) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "BOOLEAN"); + END IF; + SET_INDEX (FILE_BOOL,ONE_BOOL); + IF INDEX (FILE_BOOL) /= ONE_BOOL THEN + FAILED ("WRONG INDEX VALUE FOR TYPE BOOLEAN"); + END IF; + END; + + CLOSE (FILE_BOOL); + + BEGIN + OPEN (FILE_BOOL, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 1"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_BOOL,ITEM_BOOL); + IF ITEM_BOOL /= BOOL THEN + FAILED ("INCORRECT BOOLEAN VALUE READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE BOOLEAN"); + END; + + BEGIN + READ (FILE_BOOL,ITEM_BOOL,ONE_BOOL); + IF ITEM_BOOL /= BOOL THEN + FAILED ("INCORRECT BOOLEAN VALUE READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR BOOLEAN"); + END; + END; + + BEGIN + DELETE (FILE_BOOL); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + DECLARE + TYPE ENUMERATED IS (ONE,TWO,THREE); + PACKAGE DIR_ENUM IS NEW DIRECT_IO (ENUMERATED); + USE DIR_ENUM; + FILE_ENUM : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_ENUM, INOUT_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - ENUMERATED"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - ENUMERATED"); + RAISE END_SUBTEST; + END; + + DECLARE + ENUM : ENUMERATED := (THREE); + ITEM_ENUM : ENUMERATED; + ONE_ENUM : POSITIVE_COUNT := 1; + TWO_ENUM : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_ENUM,ENUM); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "ENUMERATED - 1"); + END; + + BEGIN + WRITE (FILE_ENUM,ENUM,TWO_ENUM); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "ENUMERATED - 2"); + END; + + BEGIN + IF SIZE (FILE_ENUM) /= TWO_ENUM THEN + FAILED ("SIZE FOR TYPE ENUMERATED"); + END IF; + IF NOT END_OF_FILE (FILE_ENUM) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " & + "ENUMERATED"); + END IF; + SET_INDEX (FILE_ENUM,ONE_ENUM); + IF INDEX (FILE_ENUM) /= ONE_ENUM THEN + FAILED ("WRONG INDEX VALUE FOR TYPE " & + "ENUMERATED"); + END IF; + END; + + CLOSE (FILE_ENUM); + + BEGIN + OPEN (FILE_ENUM, IN_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 2"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_ENUM,ITEM_ENUM); + IF ITEM_ENUM /= ENUM THEN + FAILED ("INCORRECT ENUM VALUE READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR ENUMERATED"); + END; + + BEGIN + READ (FILE_ENUM,ITEM_ENUM,ONE_ENUM); + IF ITEM_ENUM /= ENUM THEN + FAILED ("INCORRECT ENUM VALUE READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE ENUMERATED"); + END; + END; + + BEGIN + DELETE (FILE_ENUM); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + DECLARE + TYPE ACC_INT IS ACCESS INTEGER; + PACKAGE DIR_ACC IS NEW DIRECT_IO (ACC_INT); + USE DIR_ACC; + FILE_ACC : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE_ACC, INOUT_FILE, LEGAL_FILE_NAME(3)); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - ACCESS"); + RAISE END_SUBTEST; + END; + + DECLARE + ACC : ACC_INT := NEW INTEGER'(33); + ITEM_ACC : ACC_INT; + ONE_ACC : POSITIVE_COUNT := 1; + TWO_ACC : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_ACC,ACC); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "ACCESS - 1"); + END; + + BEGIN + WRITE (FILE_ACC,ACC,TWO_ACC); + + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "ACCESS - 2"); + END; + + BEGIN + IF SIZE (FILE_ACC) /= TWO_ACC THEN + FAILED ("SIZE FOR TYPE ACCESS"); + END IF; + IF NOT END_OF_FILE (FILE_ACC) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR ACCESS"); + END IF; + SET_INDEX (FILE_ACC,ONE_ACC); + IF INDEX (FILE_ACC) /= ONE_ACC THEN + FAILED ("WRONG INDEX VALUE FOR TYPE ACCESS"); + END IF; + END; + + CLOSE (FILE_ACC); + + BEGIN + OPEN (FILE_ACC, IN_FILE, LEGAL_FILE_NAME(3)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE NOT " & + "SUPPORTED - 3"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_ACC,ITEM_ACC); + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR ACCESS"); + END; + + BEGIN + READ (FILE_ACC,ITEM_ACC,ONE_ACC); + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR ACCESS"); + END; + END; + + BEGIN + DELETE (FILE_ACC); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,268 ---- + -- CE2401C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE ARE IMPLEMENTED FOR DIRECT FILES WITH + -- ELEMENT_TYPE CONSTRAINED ARRAY, AND RECORD WITHOUT DISCRIMINANTS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- ABW 08/18/82 + -- SPS 09/20/82 + -- SPS 11/09/82 + -- JBG 05/02/83 + -- JRK 03/26/84 + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/10/87 ISOLATED EXCEPTIONS. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401C IS + END_SUBTEST: EXCEPTION; + BEGIN + + TEST ("CE2401C" , "CHECK READ, WRITE, SET_INDEX " & + "INDEX, SIZE, AND END_OF_FILE FOR " & + "DIRECT FILES FOR CONSTRAINED ARRAY TYPES, " & + "AND RECORD TYPES WITHOUT DISCRIMINANTS"); + + DECLARE + TYPE ARR_CN IS ARRAY (1..5) OF BOOLEAN; + PACKAGE DIR_ARR_CN IS NEW DIRECT_IO (ARR_CN); + USE DIR_ARR_CN; + FILE : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - CONSTRAINED ARRAY"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - CONSTRAINED ARRAY"); + RAISE END_SUBTEST; + END; + + DECLARE + ARR : ARR_CN := (TRUE,TRUE,FALSE,TRUE,TRUE); + ITEM : ARR_CN; + ONE : POSITIVE_COUNT := 1; + TWO : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE,ARR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "CONTRAINED ARRAY - 1"); + END; + + BEGIN + WRITE (FILE,ARR,TWO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "CONSTRAINED ARRAY - 2"); + END; + + BEGIN + IF SIZE (FILE) /= TWO THEN + FAILED ("SIZE FOR TYPE CONSTRAINED ARRAY"); + END IF; + IF NOT END_OF_FILE (FILE) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " & + "CONSTRAINED ARRAY"); + END IF; + SET_INDEX (FILE,ONE); + IF INDEX (FILE) /= ONE THEN + FAILED ("WRONG INDEX VALUE FOR TYPE " & + "CONSTRAINED ARRAY"); + END IF; + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 1"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE,ITEM); + IF ITEM /= ARR THEN + FAILED ("INCORRECT ARRAY VALUES READ " & + "- 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE CONSTRAINED ARRAY"); + END; + + BEGIN + READ (FILE,ITEM,ONE); + IF ITEM /= ARR THEN + FAILED ("INCORRECT ARRAY VALUES READ " & + "- 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE CONSTRAINED ARRAY"); + END; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + DECLARE + TYPE REC IS + RECORD + ONE : INTEGER; + TWO : INTEGER; + END RECORD; + PACKAGE DIR_REC IS NEW DIRECT_IO (REC); + USE DIR_REC; + FILE : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - RECORD"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON CREATE - " & + "RECORD"); + END; + + DECLARE + REC1 : REC := REC'(ONE=>18,TWO=>36); + ITEM : REC; + ONE : POSITIVE_COUNT := 1; + TWO : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE,REC1); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR - " & + "RECORD - 1"); + END; + + BEGIN + WRITE (FILE,REC1,TWO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR - " & + "RECORD - 2"); + END; + + BEGIN + IF SIZE (FILE) /= TWO THEN + FAILED ("SIZE FOR TYPE RECORD"); + END IF; + IF NOT END_OF_FILE (FILE) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR RECORD"); + END IF; + SET_INDEX (FILE,ONE); + IF INDEX (FILE) /= ONE THEN + FAILED ("WRONG INDEX VALUE FOR TYPE RECORD"); + END IF; + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED - 2"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE,ITEM); + IF ITEM /= REC1 THEN + FAILED ("INCORRECT RECORD VALUES READ " & + "- 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR RECORD"); + END; + + BEGIN + READ (FILE,ITEM,ONE); + IF ITEM /= REC1 THEN + FAILED ("INCORRECT RECORD VALUES READ " & + "- 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE RECORD"); + END; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,172 ---- + -- CE2401E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE + -- FLOATING POINT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY FOR IMPLEMENTATIONS WHICH SUPPORT CREATION OF + -- DIRECT FILES WITH INOUT_FILE MODE AND OPENING OF DIRECT FILES + -- WITH IN_FILE MODE. + + -- HISTORY: + -- ABW 08/18/82 + -- SPS 09/15/82 + -- SPS 11/11/82 + -- JBG 05/02/83 + -- EG 11/19/85 HANDLE IMPLEMENTATIONS WITH + -- POSITIVE_COUNT'LAST=1. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/10/87 ISOLATED EXCEPTIONS. SPLIT FIXED POINT TESTS + -- INTO CE2401I. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401E IS + + END_SUBTEST : EXCEPTION; + + BEGIN + + TEST ("CE2401E", "CHECK THAT READ, WRITE, SET_INDEX, " & + "INDEX, SIZE, AND END_OF_FILE ARE " & + "SUPPORTED FOR DIRECT FILES WITH " & + "ELEMENT_TYPE FLOAT"); + + DECLARE + + PACKAGE DIR_FLT IS NEW DIRECT_IO (FLOAT); + USE DIR_FLT; + FILE_FLT : FILE_TYPE; + + BEGIN + BEGIN + CREATE (FILE_FLT, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - FLOAT"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - FLOAT"); + RAISE END_SUBTEST; + END; + + DECLARE + FLT : FLOAT := 65.0; + ITEM_FLT : FLOAT; + ONE_FLT : POSITIVE_COUNT := 1; + TWO_FLT : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE_FLT, FLT); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "FLOATING POINT - 1"); + END; + + BEGIN + WRITE (FILE_FLT, FLT, TWO_FLT); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "FLOATING POINT - 2"); + END; + + BEGIN + IF SIZE (FILE_FLT) /= TWO_FLT THEN + FAILED ("SIZE FOR FLOATING POINT"); + END IF; + + IF NOT END_OF_FILE (FILE_FLT) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "FLOATING POINT"); + END IF; + + SET_INDEX (FILE_FLT, ONE_FLT); + IF INDEX (FILE_FLT) /= ONE_FLT THEN + FAILED ("WRONG INDEX VALUE FOR " & + "FLOATING POINT"); + END IF; + END; + + CLOSE (FILE_FLT); + + BEGIN + OPEN (FILE_FLT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE " & + "MODE NOT SUPPORTED"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_FLT, ITEM_FLT); + IF ITEM_FLT /= FLT THEN + FAILED ("WRONG VALUE READ FOR " & + "FLOATING POINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE FLOATING POINT"); + END; + + BEGIN + READ (FILE_FLT, ITEM_FLT, ONE_FLT); + IF ITEM_FLT /= FLT THEN + FAILED ("WRONG VALUE READ WITH INDEX FOR " & + "FLOATING POINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE FLOATING POINT"); + END; + + BEGIN + DELETE (FILE_FLT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + + RESULT; + + END CE2401E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,200 ---- + -- CE2401F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE + -- PRIVATE. + + -- APPLICABILITY CRITERIA: + -- + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR + -- DIRECT FILES. + + -- HISTORY: + -- ABW 08/18/82 + -- SPS 09/15/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST + -- EG 11/19/85 CORRECT SO TEST CAN HANDLE IMPLEMENTATION WITH + -- POSITIVE_COUNT'LAST=1; COVER POSSIBILITY OF CREATE + -- RAISING USE_ERROR; ENSURE RESET DOESN'T RAISE + -- EXCEPTION IF CREATE FAILS; CHECK THAT WE CAN READ + -- DATA THAT HAS BEEN WRITTEN. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/11/87 ISOLATED EXCEPTIONS. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401F IS + + END_SUBTEST : EXCEPTION; + + BEGIN + + TEST ("CE2401F", "CHECK THAT READ, WRITE, SET_INDEX, " & + "INDEX, SIZE, AND END_OF_FILE ARE " & + "SUPPORTED FOR DIRECT FILES WITH " & + "ELEMENT_TYPE PRIVATE"); + + DECLARE + + PACKAGE PKG IS + TYPE PRIV IS PRIVATE; + FUNCTION ASSIGN RETURN PRIV; + PRIVATE + TYPE PRIV IS NEW INTEGER; + END PKG; + + USE PKG; + + PACKAGE DIR_PRV IS NEW DIRECT_IO (PRIV); + USE DIR_PRV; + FILE_PRV : FILE_TYPE; + + PACKAGE BODY PKG IS + FUNCTION ASSIGN RETURN PRIV IS + BEGIN + RETURN (16); + END; + BEGIN + NULL; + END PKG; + + BEGIN + BEGIN + CREATE (FILE_PRV, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - PRIVATE"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - PRIVATE"); + RAISE END_SUBTEST; + END; + + BEGIN + + DECLARE + + PRV, ITEM_PRV : PRIV; + ONE_PRV : POSITIVE_COUNT := 1; + TWO_PRV : POSITIVE_COUNT := 2; + + BEGIN + + PRV := ASSIGN; + + BEGIN + WRITE (FILE_PRV, PRV); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "PRIVATE - 1"); + END; + + BEGIN + WRITE (FILE_PRV, PRV, TWO_PRV); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "PRIVATE - 2"); + END; + + BEGIN + IF SIZE (FILE_PRV) /= TWO_PRV THEN + FAILED ("SIZE FOR TYPE PRIVATE"); + END IF; + IF NOT END_OF_FILE (FILE_PRV) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "PRIVATE TYPE"); + END IF; + + SET_INDEX (FILE_PRV, ONE_PRV); + + IF INDEX (FILE_PRV) /= ONE_PRV THEN + FAILED ("WRONG INDEX VALUE FOR PRIVATE " & + "TYPE"); + END IF; + END; + + CLOSE (FILE_PRV); + + BEGIN + OPEN (FILE_PRV, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE NOT " & + "SUPPORTED"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_PRV, ITEM_PRV); + IF ITEM_PRV /= PRV THEN + FAILED ("INCORRECT PRIVATE TYPE VALUE " & + "READ - 1"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "PRIVATE TYPE"); + END; + + BEGIN + READ (FILE_PRV, ITEM_PRV, ONE_PRV); + IF ITEM_PRV /= PRV THEN + FAILED ("INCORRECT PRIVATE TYPE VALUE " & + "READ - 2"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "PRIVATE TYPE"); + END; + END; + + BEGIN + DELETE (FILE_PRV); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- CE2401H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH + -- ELEMENT_TYPE UNCONSTRAINED RECORDS WITH DEFAULT DISCRIMINANTS. + + -- THIS INSTANTIATION IS ALWAYS LEGAL BY AI-00037. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR + -- DIRECT FILES. + + -- HISTORY: + -- TBN 05/15/86 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/10/87 ISOLATED EXCEPTIONS. + + WITH REPORT; + USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401H IS + + END_SUBTEST : EXCEPTION; + + BEGIN + + TEST ("CE2401H", "CHECK THAT READ, WRITE, SET_INDEX, INDEX, " & + "SIZE, AND END_OF_FILE ARE SUPPORTED FOR " & + "DIRECT FILES WITH ELEMENT_TYPE UNCONSTRAINED " & + "RECORDS WITH DEFAULT DISCRIMINANTS"); + + DECLARE + TYPE REC_DEF (DISCR : INTEGER := 1) IS + RECORD + ONE : INTEGER := DISCR; + TWO : INTEGER := 3; + THREE : INTEGER := 5; + FOUR : INTEGER := 7; + END RECORD; + PACKAGE DIR_REC_DEF IS NEW DIRECT_IO (REC_DEF); + USE DIR_REC_DEF; + FILE1 : FILE_TYPE; + REC : REC_DEF; + ITEM : REC_DEF; + ONE : POSITIVE_COUNT := 1; + TWO : POSITIVE_COUNT := 2; + + BEGIN + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " & + "NOT SUPPORTED FOR " & + "UNCONSTRAINED RECORDS WITH " & + "DEFAULT DISCRIMINATES"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON DIRECT " & + "CREATE"); + RAISE END_SUBTEST; + END; + + BEGIN + WRITE (FILE1, REC); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "RECORD WITH DEFAULT - 1"); + END; + + BEGIN + WRITE (FILE1, REC, TWO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "RECORD WITH DEFAULT - 2"); + END; + + BEGIN + IF SIZE (FILE1) /= TWO THEN + FAILED ("SIZE FOR RECORD WITH DEFAULT"); + END IF; + IF NOT END_OF_FILE (FILE1) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR TYPE " & + "RECORD WITH DEFAULT"); + END IF; + SET_INDEX (FILE1, ONE); + IF INDEX (FILE1) /= ONE THEN + FAILED ("WRONG INDEX VALUE FOR RECORD" & + "WITH DEFAULT"); + END IF; + END; + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE NOT SUPPORTED"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE1, ITEM); + IF ITEM /= (1,1,3,5,7) THEN + FAILED ("WRONG VALUE READ"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR " & + "TYPE RECORD WITH DEFAULT"); + END; + + BEGIN + ITEM := (OTHERS => 0); + READ (FILE1, ITEM, ONE); + IF ITEM /= (1,1,3,5,7) THEN + FAILED ("WRONG VALUE READ"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR " & + "TYPE RECORD WITH DEFAULT"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- CE2401I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ (WITH AND WITHOUT PARAMETER FROM), WRITE (WITH + -- AND WITHOUT PARAMETER TO), SET_INDEX, INDEX, SIZE, AND + -- END_OF_FILE ARE SUPPORTED FOR DIRECT FILES WITH ELEMENT_TYPE + -- FIXED POINT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY FOR IMPLEMENTATIONS WHICH SUPPORT CREATION OF + -- DIRECT FILES WITH INOUT_FILE MODE AND OPENING OF DIRECT FILES + -- WITH IN_FILE MODE. + + -- HISTORY: + -- DWC 08/10/87 CREATED ORIGINAL VERSION. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401I IS + + END_SUBTEST : EXCEPTION; + + BEGIN + + TEST ("CE2401I", "CHECK THAT READ, WRITE, SET_INDEX, " & + "INDEX, SIZE, AND END_OF_FILE ARE " & + "SUPPORTED FOR DIRECT FILES WITH " & + "ELEMENT_TYPE FIXED"); + + DECLARE + + TYPE FIX_TYPE IS DELTA 0.5 RANGE 0.0 .. 255.0; + PACKAGE DIR_FIX IS NEW DIRECT_IO (FIX_TYPE); + USE DIR_FIX; + FILE_FIX : FILE_TYPE; + + BEGIN + BEGIN + CREATE (FILE_FIX, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR RAISED " & + "ON CREATE - FIXED POINT"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE - FIXED POINT"); + RAISE END_SUBTEST; + END; + + DECLARE + FIX : FIX_TYPE := 16.0; + ITEM_FIX : FIX_TYPE; + ONE_FIX : POSITIVE_COUNT := 1; + TWO_FIX : POSITIVE_COUNT := 2; + + BEGIN + BEGIN + WRITE (FILE_FIX, FIX); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "FIXED POINT - 1"); + END; + + BEGIN + WRITE (FILE_FIX, FIX, TWO_FIX); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE FOR " & + "FIXED POINT - 2"); + END; + + BEGIN + IF SIZE (FILE_FIX) /= TWO_FIX THEN + FAILED ("SIZE FOR TYPE FIXED POINT"); + END IF; + + IF NOT END_OF_FILE (FILE_FIX) THEN + FAILED ("WRONG END_OF_FILE VALUE FOR " & + "FIXED POINT"); + END IF; + + SET_INDEX (FILE_FIX, ONE_FIX); + + IF INDEX (FILE_FIX) /= ONE_FIX THEN + FAILED ("WRONG INDEX VALUE FOR FIXED " & + "POINT"); + END IF; + END; + + CLOSE (FILE_FIX); + + BEGIN + OPEN (FILE_FIX, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE " & + "NOT SUPPORTED"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE_FIX, ITEM_FIX); + IF ITEM_FIX /= FIX THEN + FAILED ("WRONG VALUE READ FOR FIXED POINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITHOUT FROM FOR FIXED " & + "POINT"); + END; + + BEGIN + READ (FILE_FIX, ITEM_FIX, ONE_FIX); + IF ITEM_FIX /= FIX THEN + FAILED ("WRONG VALUE READ WITH INDEX " & + "FOR FIXED POINT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ WITH FROM FOR FIXED POINT"); + END; + + BEGIN + DELETE (FILE_FIX); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401j.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- CE2401J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA WRITTEN INTO A DIRECT FILE CAN BE READ + -- CORRECTLY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH INOUT_FILE MODE AND OPENING WITH IN_FILE MODE FOR + -- DIRECT FILES. + + -- HISTORY: + -- DWC 08/12/87 CREATE ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401J IS + END_SUBTEST: EXCEPTION; + BEGIN + + TEST ("CE2401J" , "CHECK THAT DATA WRITTEN INTO A DIRECT FILE " & + "CAN BE READ CORRECTLY"); + + DECLARE + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + FILE : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH INOUT FILE NOT " & + "SUPPORTED"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE"); + RAISE END_SUBTEST; + END; + + DECLARE + OUT_ITEM1 : INTEGER := 10; + OUT_ITEM2 : INTEGER := 21; + OUT_ITEM3 : INTEGER := 32; + IN_ITEM : INTEGER; + ONE : POSITIVE_COUNT := 1; + THREE : POSITIVE_COUNT := 3; + FIVE : POSITIVE_COUNT := 5; + BEGIN + BEGIN + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM2, THREE); + BEGIN + READ (FILE, IN_ITEM, ONE); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE " & + "READ - 1"); + END IF; + END; + WRITE (FILE, OUT_ITEM3, FIVE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE, IN_ITEM, THREE); + IF OUT_ITEM2 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 2"); + END IF; + END; + + BEGIN + RESET (FILE); + READ (FILE, IN_ITEM); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 3"); + END IF; + EXCEPTION + WHEN USE_ERROR => NULL; + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE, IN_ITEM); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 4"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ IN IN_FILE MODE - 1"); + END; + + BEGIN + READ (FILE, IN_ITEM, ONE); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 5"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ IN IN_FILE MODE - 2"); + END; + + BEGIN + READ (FILE, IN_ITEM, FIVE); + IF OUT_ITEM3 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 6"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ IN IN_FILE MODE - 3"); + END; + + BEGIN + READ (FILE, IN_ITEM, THREE); + IF OUT_ITEM2 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 7"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("READ IN IN_FILE MODE - 4"); + END; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401k.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CE2401K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA CAN BE OVERWRITTEN IN THE DIRECT FILE AND + -- THE CORRECT VALUES CAN LATER BE READ. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF INOUT_FILE MODE AND OPENING OF OUT_FILE MODE FOR + -- DIRECT FILES. + + -- HISTORY: + -- DWC 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401K IS + END_SUBTEST: EXCEPTION; + BEGIN + + TEST ("CE2401K" , "CHECK THAT DATA CAN BE OVERWRITTEN IN " & + "THE DIRECT FILE AND THE CORRECT VALUES " & + "CAN LATER BE READ."); + + DECLARE + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + FILE : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " & + "NOT SUPPORTED"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE"); + RAISE END_SUBTEST; + END; + + DECLARE + OUT_ITEM1 : INTEGER := 10; + OUT_ITEM2 : INTEGER := 21; + IN_ITEM : INTEGER; + ONE : POSITIVE_COUNT := 1; + TWO : POSITIVE_COUNT := 2; + BEGIN + BEGIN + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM2, TWO); + WRITE (FILE, OUT_ITEM2, ONE); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE " & + "IN INOUT_FILE MODE"); + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE, IN_ITEM, ONE); + IF OUT_ITEM2 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 1"); + RAISE END_SUBTEST; + END IF; + END; + + BEGIN + READ (FILE, IN_ITEM, TWO); + IF OUT_ITEM2 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 2"); + RAISE END_SUBTEST; + END IF; + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + RAISE END_SUBTEST; + END; + + BEGIN + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM2, TWO); + WRITE (FILE, OUT_ITEM1, TWO); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE " & + "IN OUT_FILE MODE"); + RAISE END_SUBTEST; + END; + + BEGIN + RESET (FILE, IN_FILE); + EXCEPTION + WHEN USE_ERROR => + RAISE END_SUBTEST; + END; + + BEGIN + READ (FILE, IN_ITEM, ONE); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 3"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN USE_ERROR => + FAILED ("READ IN IN_FILE MODE - 1"); + END; + + BEGIN + READ (FILE, IN_ITEM, TWO); + IF OUT_ITEM1 /= IN_ITEM THEN + FAILED ("INCORRECT INTEGER VALUE READ - 4"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN USE_ERROR => + FAILED ("READ IN IN_FILE MODE - 2"); + END; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2401l.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- CE2401L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT REWRITING AN ELEMENT DOES NOT CHANGE THE SIZE OF + -- THE FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- DWC 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2401L IS + END_SUBTEST: EXCEPTION; + BEGIN + + TEST ("CE2401L" , "CHECK THAT REWRITING AN ELEMENT DOES NOT " & + "CHANGE THE SIZE OF THE FILE"); + + DECLARE + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + FILE : FILE_TYPE; + BEGIN + BEGIN + CREATE (FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE " & + "NOT SUPPORTED"); + RAISE END_SUBTEST; + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED ON " & + "CREATE"); + RAISE END_SUBTEST; + END; + + DECLARE + OUT_ITEM1 : INTEGER := 10; + OUT_ITEM2 : INTEGER := 21; + OUT_ITEM4 : INTEGER := 43; + IN_ITEM : INTEGER; + ONE : POSITIVE_COUNT := 1; + TWO : POSITIVE_COUNT := 2; + FOUR : POSITIVE_COUNT := 4; + OLD_FILE_SIZE : POSITIVE_COUNT; + BEGIN + BEGIN + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM4, FOUR); + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED ON WRITE " & + "IN INOUT_FILE MODE"); + RAISE END_SUBTEST; + END; + + OLD_FILE_SIZE := SIZE (FILE); + + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM4, FOUR); + + IF OLD_FILE_SIZE /= SIZE (FILE) THEN + FAILED ("FILE SIZE CHANGED DURING REWRITE - 1"); + RAISE END_SUBTEST; + END IF; + + WRITE (FILE, OUT_ITEM1, ONE); + WRITE (FILE, OUT_ITEM2, TWO); + WRITE (FILE, OUT_ITEM4, FOUR); + + OLD_FILE_SIZE := SIZE (FILE); + + WRITE (FILE, OUT_ITEM1, FOUR); + + IF OLD_FILE_SIZE /= SIZE (FILE) THEN + FAILED ("FILE SIZE CHANGED DURING REWRITE - 2"); + RAISE END_SUBTEST; + END IF; + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN END_SUBTEST => + NULL; + END; + + RESULT; + + END CE2401L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2402a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- CE2402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ, WRITE, INDEX, SET_INDEX, SIZE, AND + -- END_OF_FILE RAISE STATUS_ERROR WHEN APPLIED TO A NON-OPEN + -- DIRECT FILE. USE_ERROR IS NOT PERMITTED. + + -- HISTORY: + -- ABW 08/17/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- JBG 08/30/83 + -- EG 11/26/84 + -- EG 06/04/85 + -- GMT 08/03/87 CLARIFIED SOME OF THE FAILED MESSAGES, AND + -- REMOVED THE EXCEPTION FOR CONSTRAINT_ERROR. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2402A IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + CNST : CONSTANT INTEGER := 101; + IVAL : INTEGER; + BOOL : BOOLEAN; + X_COUNT : COUNT; + P_COUNT : POSITIVE_COUNT; + + BEGIN + TEST ("CE2402A","CHECK THAT READ, WRITE, INDEX, " & + "SET_INDEX, SIZE, AND END_OF_FILE " & + "RAISE STATUS_ERROR WHEN APPLIED " & + "A NON-OPEN DIRECT FILE"); + BEGIN + WRITE (FILE1, CNST); + FAILED ("STATUS_ERROR WAS NOT RAISED ON WRITE - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON WRITE - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON WRITE - 3"); + END; + + BEGIN + X_COUNT := SIZE (FILE1); + FAILED ("STATUS_ERROR NOT RAISED ON SIZE - 4"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON SIZE - 5"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON SIZE - 6"); + END; + + BEGIN + BOOL := END_OF_FILE (FILE1); + FAILED ("STATUS_ERROR WAS NOT RAISED ON END_OF_FILE - 7"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON END_OF_FILE - 8"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON END_OF_FILE - 9"); + END; + + BEGIN + P_COUNT := INDEX (FILE1); + FAILED ("STATUS_ERROR WAS NOT RAISED ON INDEX - 10"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON INDEX - 11"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON INDEX - 12"); + END; + + BEGIN + READ (FILE1, IVAL); + FAILED ("STATUS_ERROR WAS NOT RAISED ON READ - 13"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON READ - 14"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 15"); + END; + + DECLARE + ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1)); + BEGIN + BEGIN + WRITE (FILE1, CNST, ONE); + FAILED ("STATUS_ERROR NOT RAISED ON WRITE - 16"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON WRITE - 17"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON WRITE - 18"); + END; + + BEGIN + SET_INDEX (FILE1,ONE); + FAILED ("STATUS_ERROR NOT RAISED ON SET_INDEX - 19"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON SET_INDEX - 20"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON SET_INDEX - 21"); + END; + + BEGIN + READ (FILE1, IVAL, ONE); + FAILED ("STATUS_ERROR WAS NOT RAISED ON READ - 22"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON READ - 23"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 24"); + END; + END; + + RESULT; + + END CE2402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2403a.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- CE2403A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR DIRECT_IO, WRITE RAISES THE EXCEPTION + -- USE_ERROR IF THE CAPACITY OF THE EXTERNAL FILE IS EXCEEDED. + -- THIS TEST ONLY CHECKS THAT THE IMPLEMENTATION SUPPORTS AN + -- EXTERNAL FILE CAPACITY OF 4096 CHARACTERS OR LESS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. ALSO, THE IMPLEMENTATION MUST BE ABLE TO + -- RESTRICT THE CAPACITY OF AN EXTERNAL FILE. + + -- $FORM_STRING2 IS DEFINED SUCH THAT THE CAPACITY OF THE FILE IS + -- RESTRICTED TO 4096 CHARACTERS OR LESS. IF THE IMPLEMENTATION + -- CANNOT RESTRICT FILE CAPACITY, $FORM_STRING2 SHOULD EQUAL + -- "CANNOT_RESTRICT_FILE_CAPACITY". + + -- HISTORY: + -- JLH 07/12/88 CREATED ORIGINAL TEST. + -- PWN 11/30/94 SUBTYPE QUALIFIED LITERALS FOR ADA 9X. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2403A IS + + SUBTYPE STR512 IS STRING (1 .. 512); + + PACKAGE DIR_IO IS NEW DIRECT_IO (STR512); + USE DIR_IO; + + FILE : FILE_TYPE; + ITEM : STR512 := (1 .. 512 => 'A'); + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2403A", "CHECK FOR DIRECT_IO THAT WRITE RAISES " & + "USE_ERROR IF THE CAPACITY OF THE EXTERNAL " & + "FILE IS EXCEEDED"); + + BEGIN + + IF + $FORM_STRING2 + = STRING'("CANNOT_RESTRICT_FILE_CAPACITY") THEN + NOT_APPLICABLE ("IMPLEMENTATION CANNOT RESTRICT FILE " & + "CAPACITY"); + RAISE INCOMPLETE; + ELSE + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME, + + $FORM_STRING2 + ); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON " & + "CREATE WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "CREATE"); + RAISE INCOMPLETE; + END; + END IF; + + BEGIN + FOR I IN 1 .. 9 LOOP + WRITE (FILE, ITEM); + END LOOP; + FAILED ("USE_ERROR NOT RAISED WHEN THE CAPACITY " & + "OF THE EXTERNAL FILE IS EXCEEDED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2403A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2404a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- CE2404A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ RAISES MODE_ERROR WHEN THE CURRENT MODE IS + -- OUT_FILE. + + -- A) CHECK NON-TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF DIRECT FILES WITH MODE OUT_FILE. + + -- HISTORY: + -- DLD 08/17/82 + -- SPS 11/09/82 + -- SPS 11/22/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 08/03/87 MOVED THE TEMP-FILE CASE TO CE2404B.ADA. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2404A IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + DIR_FILE_1 : FILE_TYPE; + I : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2404A", "CHECK THAT READ RAISES MODE_ERROR WHEN THE " & + "CURRENT MODE IS OUT_FILE AND THE FILE IS " & + "A NON-TEMPORARY FILE"); + BEGIN + + CREATE (DIR_FILE_1, OUT_FILE, LEGAL_FILE_NAME); + + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 3"); + RAISE INCOMPLETE; + END; + + BEGIN + READ (DIR_FILE_1, I); + FAILED ("MODE_ERROR NOT RAISED ON READ - 4"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 5"); + END; + + BEGIN + DELETE (DIR_FILE_1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2404A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2404b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CE2404B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ RAISES MODE_ERROR WHEN THE CURRENT MODE IS + -- OUT_FILE. + + -- B) CHECK TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF DIRECT FILES WITH MODE OUT_FILE. + + -- HISTORY: + -- GMT 08/03/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2404B IS + + PACKAGE DIR_IO IS NEW DIRECT_IO(INTEGER); + USE DIR_IO; + DIR_FILE_2 : FILE_TYPE; + I : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2404B", "CHECK THAT READ RAISES MODE_ERROR WHEN THE " & + "CURRENT MODE IS OUT_FILE AND THE FILE IS " & + "A TEMPORARY FILE"); + BEGIN + CREATE (DIR_FILE_2, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + READ(DIR_FILE_2, I); + FAILED("MODE_ERROR NOT RAISED ON READ - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED("WRONG EXCEPTION RAISED ON READ - 4"); + END; + + CLOSE (DIR_FILE_2); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2404B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2405b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- CE2405B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT READ RAISES END_ERROR WHEN THE CURRENT READ POSITION + -- IS GREATER THAN THE END POSITION. ALSO CHECK THAT END_OF_FILE + -- CORRECTLY DETECTS THE END OF A DIRECT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH INOUT_FILE MODE AND OPENING OF IN_FILE MODE. + + -- HISTORY: + -- SPS 09/28/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST + -- EG 05/16/85 + -- GMT 08/03/87 ADDED CODE TO CHECK THAT END_OF_FILE WORKS, AND + -- ADDED CODE TO PREVENT SOME EXCEPTION PROPAGATION. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2405B IS + BEGIN + TEST ("CE2405B", "CHECK THAT END_ERROR IS RAISED BY READ AT THE " & + "END OF A FILE AND THAT END_OF_FILE CORRECTLY " & + "DETECTS THE END OF A DIRECT_IO FILE"); + DECLARE + PACKAGE DIR IS NEW DIRECT_IO (CHARACTER); + USE DIR; + FT : FILE_TYPE; + CH : CHARACTER; + INCOMPLETE : EXCEPTION; + BEGIN + + -- CREATE AND INITIALIZE FILE + + BEGIN + CREATE (FT, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("USE_ERROR | NAME_ERROR WAS " & + "RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + + WRITE (FT, 'C'); + WRITE (FT, 'X'); + + -- BEGIN TEST + + IF NOT END_OF_FILE (FT) THEN + FAILED ("END_OF_FILE RETURNED INCORRECT " & + "BOOLEAN VALUE - 3"); + END IF; + + BEGIN + READ (FT, CH); + FAILED ("END_ERROR NOT RAISED ON READ - 4"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 5"); + END; + + WRITE (FT,'E'); + + BEGIN + READ (FT, CH); + FAILED ("END_ERROR NOT RAISED ON READ - 6"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON READ - 7"); + END; + + END; + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN - 8"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON OPEN - 9"); + RAISE INCOMPLETE; + END; + + DECLARE + COUNT_NBR_OF_READS : NATURAL := 0; + EXPECTED_COUNT : CONSTANT := 3; + BEGIN + LOOP + IF END_OF_FILE (FT) THEN + EXIT; + ELSE + READ (FT, CH); + COUNT_NBR_OF_READS := COUNT_NBR_OF_READS + 1; + END IF; + END LOOP; + + IF COUNT_NBR_OF_READS /= EXPECTED_COUNT THEN + FAILED ("THE BAD VALUE FOR COUNT_NBR_OF_READS " & + "IS " & + NATURAL'IMAGE (COUNT_NBR_OF_READS) ); + END IF; + + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE2405B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2406a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,199 ---- + -- CE2406A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR A DIRECT ACCESS FILE, CHECK THAT AFTER A READ, THE CURRENT + -- READ POSITION IS INCREMENTED BY ONE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT_IO FILES. + + -- HISTORY: + -- ABW 08/20/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGE TO .ADA TEST. + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 08/05/87 REMOVED DEPENDENCE ON RESET AND ADDED CHECK FOR + -- USE_ERROR ON DELETE. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2406A IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INT : INTEGER := IDENT_INT (18); + BOOL : BOOLEAN := IDENT_BOOL (TRUE); + INT_ITEM1, INT_ITEM2 : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2406A", "CHECK THAT READ POSITION IS INCREMENTED " & + "BY ONE AFTER A READ"); + + -- CREATE AND INITIALIZE FILE1 + + BEGIN + + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN NAME_ERROR | USE_ERROR => + NOT_APPLICABLE ("NAME_ERROR | USE_ERROR RAISED " & + "ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FILE1, INT); + WRITE (FILE1, 26); + WRITE (FILE1, 12); + WRITE (FILE1, 19); + WRITE (FILE1, INT); + WRITE (FILE1, 3); + + -- BEGIN TEST + + CLOSE (FILE1); + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON" & + "OPEN - 3"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON " & + "OPEN - 4"); + RAISE INCOMPLETE; + END; + + + IF INDEX(FILE1) /= POSITIVE_COUNT (IDENT_INT(1)) THEN + FAILED ("INITIAL INDEX VALUE INCORRECT - 5"); + ELSE + READ (FILE1, INT_ITEM1); + IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN + FAILED ("INDEX VALUE NOT INCREMENTED - 6"); + ELSE + IF INT_ITEM1 /= IDENT_INT(18) THEN + FAILED ("READ INCORRECT VALUE - 7"); + END IF; + READ (FILE1, INT_ITEM1, 4); + IF INDEX(FILE1) /= + POSITIVE_COUNT (IDENT_INT(5)) THEN + FAILED ("INDEX VALUE NOT INCREMENTED " & + "WHEN TO IS SPECIFIED - 8"); + ELSE + IF INT_ITEM1 /= IDENT_INT(19) THEN + FAILED ("READ INCORRECT VALUE - 9"); + END IF; + READ (FILE1, INT_ITEM1); + IF INDEX(FILE1) /= + POSITIVE_COUNT(IDENT_INT(6)) THEN + FAILED ("INDEX VALUE NOT " & + "INCREMENTED WHEN " & + "LAST - 10"); + ELSIF INT_ITEM1 /= IDENT_INT(18) THEN + FAILED ("READ INCORRECT " & + "IN_FILE VALUE - 11"); + END IF; + END IF; + END IF; + END IF; + + CLOSE (FILE1); + BEGIN + OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON " & + "OPEN - 12"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON " & + "OPEN - 13"); + RAISE INCOMPLETE; + END; + + IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(1)) THEN + FAILED ("INITIAL INDEX VALUE INCORRECT - 14"); + ELSE + READ (FILE1, INT_ITEM2); + IF INDEX(FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN + FAILED ("INDEX VALUE NOT INCREMENTED - 15"); + ELSE + IF INT_ITEM2 /= IDENT_INT(18) THEN + FAILED ("READ INCORRECT VALUE - 16"); + END IF; + READ (FILE1, INT_ITEM2, 4); + IF INDEX (FILE1) /= + POSITIVE_COUNT(IDENT_INT(5)) THEN + FAILED ("INDEX VALUE NOT INCREMENTED " & + "WHEN TO IS SPECIFIED - 17"); + ELSE + IF INT_ITEM2 /= IDENT_INT(19) THEN + FAILED ("INCORRECT VALUE - 18"); + END IF; + READ (FILE1, INT_ITEM2); + IF INDEX(FILE1) /= + POSITIVE_COUNT(IDENT_INT(6)) THEN + FAILED ("INDEX VALUE NOT " & + "INCREMENTED WHEN " & + "LAST - INOUT_FILE - 19"); + ELSIF INT_ITEM2 /= IDENT_INT(18) THEN + FAILED ("READ INCORRECT " & + "INOUT_FILE VALUE - 20"); + END IF; + END IF; + END IF; + END IF; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE2406A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2407a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- CE2407A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE RAISES MODE_ERROR WHEN THE CURRENT MODE + -- IS IN_FILE. + + -- 1) CHECK NON-TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE AND OPEN WITH IN_FILE MODE FOR DIRECT + -- FILES. + + -- HISTORY: + -- ABW 08/20/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 08/06/86 REMOVED THE DEPENDENCE ON RESET AND MOVED THE CHECK + -- FOR TEMPORARY FILES INTO CE2407B.ADA. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2407A IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + INCOMPLETE : EXCEPTION; + FILE1 : FILE_TYPE; + INT : INTEGER := IDENT_INT (18); + + BEGIN + TEST ("CE2407A", "CHECK THAT WRITE RAISES MODE_ERROR WHEN THE " & + "CURRENT MODE IS IN_FILE AND THE FILE IS " & + "A NON-TEMPORARY FILE"); + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 3"); + RAISE INCOMPLETE; + END; + + WRITE (FILE1, INT); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE("USE_ERROR RAISED ON OPEN - 4"); + RAISE INCOMPLETE; + END; + + + + BEGIN + WRITE (FILE1,INT); + FAILED ("MODE_ERROR NOT RAISED ON WRITE - 5"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON WRITE - 6"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2407A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2407b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- CE2407B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE RAISES MODE_ERROR WHEN THE CURRENT MODE + -- IS IN_FILE. + + -- 2) CHECK TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE AND RESET FROM OUT_FILE MODE TO + -- IN_FILE MODE. + + -- HISTORY: + -- GMT 08/06/86 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2407B IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + INCOMPLETE : EXCEPTION; + FILE2 : FILE_TYPE; + INT : INTEGER := IDENT_INT (18); + + BEGIN + TEST ("CE2407B", "CHECK THAT WRITE RAISES MODE_ERROR WHEN THE " & + "CURRENT MODE IS IN_FILE AND THE FILE IS " & + "A TEMPORARY FILE"); + BEGIN + CREATE (FILE2, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + WRITE (FILE2, INT); + + BEGIN + RESET (FILE2, IN_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE("USE_ERROR RAISED ON RESET - 3"); + RAISE INCOMPLETE; + END; + + BEGIN + WRITE (FILE2, INT); + FAILED ("MODE_ERROR NOT RAISED ON WRITE - 4"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED ON WRITE - 5"); + END; + + CLOSE (FILE2); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2407B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2408a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- CE2408A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE TO + -- PARAMETER IS GREATER THAN THE END POSITION. + + -- 1) FILE MODE IS OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF DIRECT FILES WITH MODE OUT_FILE. + + -- HISTORY: + -- DLD 08/19/82 + -- SPS 11/09/82 + -- EG 05/16/85 + -- GMT 08/05/87 ADDED A CHECK FOR USE_ERROR ON DELETE AND REMOVED + -- THE OTHERS EXCEPTION AT THE BOTTOM OF THE FILE. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2408A IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + + DIR_FILE : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2408A", "FOR FILES OF MODE OUT_FILE, CHECK THAT " & + "WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE " & + """TO"" PARAMETER IS GREATER THAN THE END " & + "POSITION"); + + -- CREATE TEST FILE + + BEGIN + CREATE (DIR_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH MODE " & + "OUT_FILE FOR DIR_IO - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "MODE OUT_FILE FOR DIR_IO - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE WITH " & + "MODE OUT_FILE FOR DIR_IO - 3"); + RAISE INCOMPLETE; + END; + + -- FILL UP FILE + + WRITE (DIR_FILE, 3); + WRITE (DIR_FILE, 4); + WRITE (DIR_FILE, 5); + WRITE (DIR_FILE, 6); + + -- WRITE WHERE TO IS LARGER THAN END OF FILE + + BEGIN + WRITE (DIR_FILE, 9, 7); + EXCEPTION + WHEN OTHERS => + FAILED ("WRITE RAISED EXCEPTION WHEN TO " & + "PARAMETER WAS BEYOND END - 4"); + END; + + BEGIN + SET_INDEX (DIR_FILE, 11); + WRITE (DIR_FILE, 10); + EXCEPTION + WHEN OTHERS => + FAILED ("SET_INDEX/WRITE RAISED EXCEPTION WHEN TO " & + "PARAMETER EXCEEDS THE END POSITION - 5"); + END; + + -- DELETE TEST FILE + + BEGIN + DELETE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2408A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2408b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE2408B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE TO + -- PARAMETER IS GREATER THAN THE END POSITION. + + -- 2) FILE MODE IS INOUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF DIRECT FILES WITH MODE INOUT_FILE. + + -- HISTORY: + -- GMT 08/05/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2408B IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + + DIR_FILE : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2408B", "FOR FILES OF MODE INOUT_FILE, CHECK THAT " & + "WRITE DOES NOT CAUSE AN EXCEPTION WHEN THE " & + """TO"" PARAMETER IS GREATER THAN THE END " & + "POSITION"); + BEGIN + CREATE (DIR_FILE, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "MODE INOUT_FILE FOR DIR_IO - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "MODE INOUT_FILE FOR DIR_IO - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE WITH " & + "MODE INOUT_FILE FOR DIR_IO - 3"); + RAISE INCOMPLETE; + END; + + -- FILL UP FILE + + WRITE (DIR_FILE, 3); + WRITE (DIR_FILE, 4); + WRITE (DIR_FILE, 5); + WRITE (DIR_FILE, 6); + + -- WRITE WHERE TO IS LARGER THAN END OF FILE + + BEGIN + WRITE (DIR_FILE, 9, 7); + EXCEPTION + WHEN OTHERS => + FAILED ("WRITE RAISED EXCEPTION WHEN TO " & + "PARAMETER WAS BEYOND END - 4"); + END; + + BEGIN + SET_INDEX (DIR_FILE, 11); + WRITE (DIR_FILE, 10); + EXCEPTION + WHEN OTHERS => + FAILED ("SET_INDEX/WRITE RAISED EXCEPTION WHEN TO " & + "PARAMETER EXCEEDS THE END POSITION - 5"); + END; + + -- DELETE TEST FILE + + BEGIN + DELETE (DIR_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2408B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2409a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,113 ---- + -- CE2409A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DIRECT ACCESS FILES, CHECK THAT A WRITE TO A POSITION + -- GREATER THAN THE CURRENT END POSITION CAUSES THE WRITE + -- POSITION AND THE FILE SIZE TO BE INCREMENTED. + + -- 1) CHECK FILES OF MODE INOUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH INOUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- ABW 08/27/82 + -- SPS 11/09/82 + -- SPS 03/18/83 + -- EG 05/16/85 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 08/05/87 REVISED EXCEPTION HANDLING, ADDED CHECK FOR WRITE + -- USING TO, AND MOVED OUT_FILE CASE TO CE2409B.ADA. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2409A IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2409A", "CHECK THAT WRITE POSITION AND " & + "SIZE ARE INCREMENTED CORRECTLY FOR " & + "DIR FILES OF MODE INOUT_FILE"); + + BEGIN + CREATE (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH INOUT_FILE MODE NOT " & + "SUPPORTED FOR DIR FILES - 1"); + RAISE INCOMPLETE; + END; + + DECLARE + INT : INTEGER := IDENT_INT (18); + TWO_C : COUNT := COUNT (IDENT_INT(2)); + THREE_PC : POSITIVE_COUNT + := POSITIVE_COUNT (IDENT_INT(3)); + FIVE_C : COUNT := COUNT (IDENT_INT(5)); + FIVE_PC : POSITIVE_COUNT + := POSITIVE_COUNT (IDENT_INT(5)); + SIX_PC : POSITIVE_COUNT + := POSITIVE_COUNT (IDENT_INT(6)); + BEGIN + WRITE (FILE1, INT); + WRITE (FILE1, INT); + IF INDEX (FILE1) /= THREE_PC THEN + FAILED ("INCORRECT INDEX VALUE - 1"); + END IF; + IF SIZE (FILE1) /= TWO_C THEN + FAILED ("INCORRECT SIZE VALUE - 2"); + END IF; + + WRITE (FILE1, INT, FIVE_PC); + IF INDEX (FILE1) /= SIX_PC THEN + FAILED ("INCORRECT INDEX VALUE - 3"); + END IF; + IF SIZE (FILE1) /= FIVE_C THEN + FAILED ("INCORRECT SIZE VALUE - 4"); + END IF; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT ; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2409A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2409b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE2409B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR DIRECT ACCESS FILES, CHECK THAT A WRITE TO A POSITION + -- GREATER THAN THE CURRENT END POSITION CAUSES THE WRITE + -- POSITION AND THE FILE SIZE TO BE INCREMENTED. + + -- 2) CHECK FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH MODE OUT_FILE FOR DIRECT FILES. + + -- HISTORY: + -- GMT 08/05/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2409B IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2409B", "CHECK THAT WRITE POSITION AND " & + "SIZE ARE INCREMENTED APPROPRIATELY"); + BEGIN + CREATE (FILE1, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE NOT " & + "SUPPORTED FOR DIR FILES - 1"); + RAISE INCOMPLETE; + END; + + DECLARE + INT : INTEGER := IDENT_INT (18); + TWO_C : COUNT := COUNT (IDENT_INT(2)); + THREE_C : COUNT := COUNT (IDENT_INT(3)); + THREE_PC : POSITIVE_COUNT + := POSITIVE_COUNT (IDENT_INT(3)); + FOUR_PC : POSITIVE_COUNT + := POSITIVE_COUNT (IDENT_INT(4)); + BEGIN + WRITE (FILE1, INT); + WRITE (FILE1, INT); + IF INDEX (FILE1) /= THREE_PC THEN + FAILED ("INCORRECT VALUE FOR INDEX - 2"); + END IF; + IF SIZE (FILE1) /= TWO_C THEN + FAILED ("INCORRECT VALUE FOR SIZE - 3"); + END IF; + + WRITE (FILE1, INT); + IF INDEX (FILE1) /= FOUR_PC THEN + FAILED ("INCORRECT VALUE FOR INDEX - 4"); + END IF; + IF SIZE (FILE1) /= THREE_C THEN + FAILED ("INCORRECT VALUE FOR SIZE - 5"); + END IF; + + END; + + CLOSE (FILE1); + + RESULT ; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2409B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2410a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + -- CE2410A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN THE CURRENT + -- MODE IS OUT_FILE. + + -- 1) CHECK NON-TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- ABW 08/20/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- EG 11/02/84 + -- EG 05/16/85 + -- GMT 08/05/87 REVISED EXCEPTION HANDLING AND MOVED THE CASE FOR + -- TEMPORARY FILES INTO CE2410B.ADA. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2410A IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INT : INTEGER := IDENT_INT (18); + BOOL : BOOLEAN; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2410A", "CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN " & + "THE CURRENT MODE IS OUT_FILE AND THE FILE IS " & + "A NON-TEMPORARY FILE."); + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE NOT " & + "SUPPORTED FOR DIRECT FILES - 1"); + RAISE INCOMPLETE; + END; + + BEGIN + BOOL := END_OF_FILE (FILE1); + FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 2"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON " & + "END_OF_FILE - 3"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT ; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2410A ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2410b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CE2410B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN THE CURRENT + -- MODE IS OUT_FILE. + + -- 2) CHECK TEMPORARY FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR DIRECT FILES. + + -- HISTORY: + -- GMT 08/05/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH DIRECT_IO; + + PROCEDURE CE2410B IS + + PACKAGE DIR IS NEW DIRECT_IO (INTEGER); + USE DIR; + FILE1 : FILE_TYPE; + INT : INTEGER := IDENT_INT (18); + BOOL : BOOLEAN; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE2410B", "CHECK THAT END_OF_FILE RAISES MODE_ERROR WHEN " & + "THE CURRENT MODE IS OUT_FILE AND THE FILE IS " & + "A TEMPORARY FILE."); + + BEGIN + CREATE (FILE1, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE NOT " & + "SUPPORTED FOR DIRECT FILES - 1"); + RAISE INCOMPLETE; + END; + + BEGIN + BOOL := END_OF_FILE (FILE1); + FAILED ("MODE_ERROR NOT RAISED ON END_OF_FILE - 2"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED ON " & + "END_OF_FILE - 3"); + END; + + CLOSE (FILE1); + + RESULT ; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE2410B ; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce2411a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,207 ---- + -- CE2411A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INDEX RETURNS THE CORRECT INDEX POSITION AND THAT + -- SET_INDEX CORRECTLY SETS THE INDEX POSITION IN A DIRECT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- DIRECT FILES. + + -- HISTORY: + -- TBN 10/01/86 + -- JLH 08/07/87 REVISED EXTERNAL FILE NAME, REMOVED CHECK FOR + -- NAME_ERROR ON OPEN CALLS, AND REMOVED + -- UNNECESSARY CODE. + + WITH DIRECT_IO; + WITH REPORT; USE REPORT; + PROCEDURE CE2411A IS + + PACKAGE DIR_IO IS NEW DIRECT_IO (INTEGER); + USE DIR_IO; + + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE2411A", "CHECK THAT INDEX RETURNS THE CORRECT INDEX " & + "POSITION AND THAT SET_INDEX CORRECTLY SETS " & + "THE INDEX POSITION IN A DIRECT FILE"); + + + -- INITIALIZE TEST FILE + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED DURING CREATE " & + "WITH OUT_FILE MODE FOR DIR_IO"); + RAISE INCOMPLETE; + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED DURING CREATE " & + "WITH OUT_FILE MODE FOR DIR_IO"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED DURING CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + IF INDEX (FILE1) /= 1 THEN + FAILED ("STARTING INDEX POSITION IS INCORRECT - 1"); + RAISE INCOMPLETE; + END IF; + FOR I IN 1 .. 10 LOOP + WRITE (FILE1, I); + END LOOP; + IF INDEX (FILE1) /= 11 THEN + FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 2"); + END IF; + WRITE (FILE1, 20, 20); + IF INDEX (FILE1) /= 21 THEN + FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 3"); + END IF; + SET_INDEX (FILE1, 11); + IF INDEX (FILE1) /= 11 THEN + FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - 4"); + END IF; + WRITE (FILE1, 11); + IF INDEX (FILE1) /= 12 THEN + FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 5"); + END IF; + END; + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED DURING OPEN INFILE " & + "FOR DIR_IO"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED DURING OPEN INFILE"); + RAISE INCOMPLETE; + END; + + DECLARE + NUM : INTEGER; + BEGIN + IF INDEX (FILE1) /= 1 THEN + FAILED ("STARTING INDEX POSITION IS INCORRECT - 7"); + RAISE INCOMPLETE; + END IF; + FOR I IN 1 .. 10 LOOP + READ (FILE1, NUM); + IF NUM /= I THEN + FAILED ("FILE CONTAINS INCORRECT DATA - 8"); + END IF; + IF INDEX (FILE1) /= POSITIVE_COUNT(I + 1) THEN + FAILED ("INDEX DOES NOT RETURN THE CORRECT " & + "POSITION - 9"); + END IF; + END LOOP; + SET_INDEX (FILE1, 20); + IF INDEX (FILE1) /= 20 THEN + FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " & + "10"); + END IF; + READ (FILE1, NUM, 20); + IF NUM /= 20 THEN + FAILED ("FILE CONTAINS INCORRECT DATA - 11"); + END IF; + IF INDEX (FILE1) /= 21 THEN + FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 12"); + END IF; + SET_INDEX (FILE1, 1); + IF INDEX (FILE1) /= 1 THEN + FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " & + "13"); + END IF; + END; + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, INOUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED DURING OPEN " & + "INOUT_FILE FOR DIR_IO"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNKNOWN EXCEPTION RAISED DURING OPEN INOUT"); + RAISE INCOMPLETE; + END; + + DECLARE + NUM : INTEGER; + BEGIN + IF INDEX (FILE1) /= 1 THEN + FAILED ("STARTING INDEX POSITION IS INCORRECT - 15"); + RAISE INCOMPLETE; + END IF; + FOR I IN 1 .. 10 LOOP + READ (FILE1, NUM); + IF NUM /= I THEN + FAILED ("FILE CONTAINS INCORRECT DATA - 16"); + END IF; + IF INDEX (FILE1) /= POSITIVE_COUNT(I + 1) THEN + FAILED ("INDEX DOES NOT RETURN THE CORRECT " & + "POSITION - 17"); + END IF; + END LOOP; + SET_INDEX (FILE1, 20); + IF INDEX (FILE1) /= 20 THEN + FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " & + "18"); + END IF; + WRITE (FILE1, 12, 12); + IF INDEX (FILE1) /= 13 THEN + FAILED ("INDEX DOES NOT RETURN CORRECT POSITION - 19"); + END IF; + SET_INDEX (FILE1, 1); + IF INDEX (FILE1) /= 1 THEN + FAILED ("SET_INDEX DOES NOT CORRECTLY SET POSITION - " & + "20"); + END IF; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE2411A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002b.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CE3002B.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT COUNT IS A VISIBLE TYPE, THAT COUNT'FIRST IS 0, + -- THAT POSITIVE_COUNT IS A SUBTYPE OF COUNT, THAT + -- POSITIVE_COUNT'FIRST IS 1, THAT POSITIVE_COUNT'LAST + -- EQUALS COUNT'LAST, AND COUNT'LAST HAS A SPECIFIED + -- IMPLEMENTATION-DEPENDENT VALUE. + + -- HISTORY: + -- SPS 09/30/82 + -- SPS 11/09/82 + -- JBG 03/16/83 + -- JLH 08/07/87 REVISED VALUES USED IN COUNT AND POSITIVE_COUNT + -- TO THE INTEGER VALUE 1. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3002B IS + BEGIN + + TEST ("CE3002B", "CHECK THAT COUNT IS VISIBLE, COUNT'FIRST IS " & + "0, POSITIVE_COUNT IS A SUBTYPE OF COUNT, " & + "POSITIVE_COUNT'FIRST IS 1, POSITIVE_COUNT'" & + "LAST EQUALS COUNT'LAST, AND COUNT'LAST " & + "HAS A SPECIFIED VALUE"); + + DECLARE + X : COUNT; + A : POSITIVE_COUNT; + BEGIN + IF COUNT'FIRST /= COUNT(IDENT_INT (0)) THEN + FAILED ("COUNT'FIRST NOT 0; IS" & + COUNT'IMAGE(COUNT'FIRST)); + END IF; + + IF POSITIVE_COUNT'FIRST /= POSITIVE_COUNT (IDENT_INT (1)) THEN + FAILED ("POSITIVE_COUNT'FIRST NOT 1; IS" & + COUNT'IMAGE(POSITIVE_COUNT'FIRST)); + END IF; + + IF POSITIVE_COUNT'LAST /= COUNT'LAST THEN + FAILED ("POSITIVE_COUNT'LAST NOT EQUAL COUNT'LAST"); + END IF; + + IF COUNT'LAST /= $COUNT_LAST THEN + FAILED ("COUNT'LAST NOT $COUNT_LAST; IS" & + COUNT'IMAGE(COUNT'LAST)); + END IF; + + X := POSITIVE_COUNT (IDENT_INT (1)); + A := X; + A := COUNT (IDENT_INT (1)); + X := A; + END; + + RESULT; + + END CE3002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002c.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- CE3002C.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIELD IS A SUBTYPE OF INTEGER, FIELD'FIRST = 0, AND + -- FIELD'LAST HAS A SPECIFIED IMPLEMENTATION-DEPENDENT VALUE. + + -- HISTORY: + -- SPS 09/30/82 + -- SPS 11/09/82 + -- JBG 03/16/83 + -- JLH 08/07/87 REVISED VALUES USED IN INTEGER AND FIELD TO THE + -- INTEGER VALUE 1. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3002C IS + BEGIN + + TEST ("CE3002C", "CHECK THAT FIELD IS A SUBTYPE OF INTEGER AND " & + "FIELD'FIRST = 0"); + + DECLARE + A : INTEGER; + B : FIELD; + BEGIN + IF FIELD'FIRST /= IDENT_INT (0) THEN + FAILED ("FIELD'FIRST NOT 0; IS" & + FIELD'IMAGE(FIELD'FIRST)); + END IF; + + IF FIELD'LAST /= $FIELD_LAST THEN + FAILED ("FIELD'LAST NOT $FIELD_LAST; IS" & + FIELD'IMAGE(FIELD'LAST)); + END IF; + + A := IDENT_INT (1); + B := A; + B := IDENT_INT (1); + A := B; + END; + + RESULT; + + END CE3002C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- CE3002D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT NUMBER_BASE IS A SUBTYPE OF INTEGER, WITH + -- NUMBER_BASE'FIRST EQUAL 2 AND NUMBER_BASE'LAST EQUAL 16. + + -- SPS 10/1/82 + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3002D IS + BEGIN + + TEST ("CE3002D", "CHECK THAT NUMBER_BASE IS A SUBTYPE " & + "OF INTEGER WITH NUMBER_BASE'FIRST = 2 " & + "AND NUMBER_BASE'LAST = 16"); + + DECLARE + X : INTEGER; + Y : NUMBER_BASE; + BEGIN + IF NUMBER_BASE'FIRST /= IDENT_INT (2) THEN + FAILED ("NUMBER_BASE'FIRST NOT 2"); + END IF; + + IF NUMBER_BASE'LAST /= IDENT_INT (16) THEN + FAILED ("NUMBER_BASE'LAST NOT 16"); + END IF; + + X := IDENT_INT (3); + Y := X; + Y := IDENT_INT (8); + X := Y; + END; + + RESULT; + END CE3002D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3002f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- CE3002F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT UNBOUNDED HAS TYPE COUNT AND VALUE ZERO. + + -- SPS 10/1/82 + -- SPS 11/9/82 + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3002F IS + BEGIN + + TEST ("CE3002F", "CHECK THAT UNBOUNDED HAS TYPE COUNT AND " & + "VALUE ZERO"); + + DECLARE + Z : COUNT := 0; + BEGIN + IF UNBOUNDED /= COUNT(IDENT_INT(0)) THEN + FAILED ("UNBOUNDED NOT 0"); + END IF; + + IF UNBOUNDED /= Z THEN + FAILED ("UNBOUNDED NOT COUNT"); + END IF; + END; + + RESULT; + + END CE3002F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,151 ---- + -- CE3102A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT STATUS_ERROR IS RAISED BY CREATE AND OPEN + -- IF THE GIVEN TEXT FILES ARE ALREADY OPEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH MODE OUT_FILE FOR TEXT FILES. + + -- HISTORY: + -- ABW 08/24/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- JBG 07/25/83 + -- JLH 08/07/87 COMPLETE REVISION OF TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3102A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3102A" , "CHECK THAT STATUS_ERROR IS RAISED " & + "APPROPRIATELY FOR TEXT FILES"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + CREATE (FILE, OUT_FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 1"); + END; + + BEGIN + CREATE (FILE, IN_FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 2"); + END; + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED FOR CREATE - 3"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR CREATE - 3"); + END; + + BEGIN + OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 1"); + END; + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 2"); + END; + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME (2, "CE3102A")); + FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 3"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 3"); + END; + + BEGIN + CREATE (FILE, IN_FILE, LEGAL_FILE_NAME (2, "CE3102A")); + FAILED ("STATUS_ERROR NOT RAISED FOR OPEN - 4"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OPEN - 4"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102b.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + -- CE3102B.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FOR TEXT FILES NAME_ERROR IS RAISED BY CREATE AND + -- OPEN IF THE GIVEN NAME STRING DOES NOT ALLOW THE IDENTIFICATION + -- OF AN EXTERNAL FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE FOR TEXT_IO. + + -- HISTORY: + -- ABW 08/24/82 + -- JBG 03/16/83 + -- EG 05/30/85 + -- JLH 08/12/87 REMOVED UNNECESSARY CODE, ADDED NEW CASES FOR OPEN, + -- AND REMOVED DEPENDENCE ON DELETE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102B IS + + FILE1, FILE2 : FILE_TYPE; + FILE_NAME_OK : BOOLEAN := FALSE; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3102B", "CHECK THAT NAME_ERROR IS RAISED " & + "APPROPRIATELY"); + + -- CHECK THAT A LEGAL FILE NAME IS OK SO TEST IS VALID + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "OF ASSUMED VALID FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "OF ASSUMED VALID FILE"); + RAISE INCOMPLETE; + END; + + BEGIN + DELETE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + FAILED ("FILE STILL EXISTS AFTER DELETE"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT OPEN"); + END; + + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + -- PERFORM VARIOUS CHECKS + + BEGIN + OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2)); + FAILED ("NO EXCEPTION FOR NON-EXISTENT FILE - IN_FILE"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR OPEN OF " & + "NON-EXISTENT FILE - IN_FILE"); + END; + + BEGIN + OPEN (FILE2, OUT_FILE, LEGAL_FILE_NAME(3)); + FAILED ("NO EXCEPTION FOR NON-EXISTENT FILE - OUT_FILE"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR OPEN FOR " & + "NON-EXISTENT FILE - OUT_FILE"); + END; + + BEGIN + CREATE (FILE1, NAME => "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED ("NO EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE"); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE"); + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - CREATE"); + END; + + BEGIN + CREATE (FILE2, NAME => "$ILLEGAL_EXTERNAL_FILE_NAME2"); + FAILED ("NO EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE"); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE"); + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - CREATE"); + END; + + BEGIN + OPEN (FILE2, IN_FILE, + NAME => "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED ("NO EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN"); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE ERROR RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN"); + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME1 - OPEN"); + END; + + BEGIN + OPEN (FILE1, IN_FILE, + NAME => "$ILLEGAL_EXTERNAL_FILE_NAME2"); + FAILED ("NO EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN"); + EXCEPTION + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN"); + WHEN NAME_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR " & + "$ILLEGAL_EXTERNAL_FILE_NAME2 - OPEN"); + END; + + RESULT; + + EXCEPTION + + WHEN INCOMPLETE => + RESULT; + + END CE3102B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- CE3102D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT STATUS_ERROR IS RAISED BY CLOSE, DELETE, RESET, MODE, + -- NAME, AND FORM IF THE GIVEN TEXT FILES ARE NOT OPEN. + + -- HISTORY: + -- JLH 08/10/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3102D IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + FT : FILE_TYPE; + + BEGIN + + TEST ("CE3102D" , "CHECK THAT STATUS_ERROR IS RAISED " & + "APPROPRIATELY FOR TEXT FILES"); + + BEGIN + CREATE (FT); + CLOSE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CREATE"); + END; + + BEGIN + RESET (FT); + FAILED ("STATUS_ERROR NOT RAISED FOR RESET"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR RESET OF CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR RESET"); + END; + + BEGIN + DECLARE + MD : FILE_MODE := MODE (FT); + BEGIN + FAILED ("STATUS_ERROR NOT RAISED FOR MODE"); + END; + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR MODE OF CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR MODE"); + END; + + BEGIN + DECLARE + NM : CONSTANT STRING := NAME (FT); + BEGIN + FAILED ("STATUS_ERROR NOT RAISED FOR NAME"); + END; + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR NAME OF CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR NAME"); + END; + + BEGIN + DECLARE + FM : CONSTANT STRING := FORM (FT); + BEGIN + FAILED ("STATUS_ERROR NOT RAISED FOR FORM"); + END; + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR FORM OF CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR FORM"); + END; + + BEGIN + CLOSE (FT); + FAILED ("STATUS_ERROR NOT RAISED FOR CLOSE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED WHEN CLOSING CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CLOSE"); + END; + + BEGIN + DELETE (FT); + FAILED ("STATUS_ERROR NOT RAISED FOR DELETE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED FOR DELETE OF CLOSED FILE"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR DELETE"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3102D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CE3102E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE + -- IMPLEMENTATION FOR TEXT FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT IN_FILE MODE WITH CREATE FOR TEXT FILES. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102E IS + + FILE1 : FILE_TYPE; + + BEGIN + + TEST ("CE3102E", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR TEXT FILES"); + + BEGIN + CREATE (FILE1, IN_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE IN_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE3102E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CE3102F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN AN EXTERNAL FILE + -- CANNOT BE RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES, BUT DO NOT SUPPORT RESET OF EXTERNAL FILES. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3102F IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3102F", "CHECK THAT USE_ERROR IS RAISED WHEN AN " & + "EXTERNAL FILE CANNOT BE RESET"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + NOT_APPLICABLE ("RESET FOR OUT_FILE MODE ALLOWED - 1"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 1"); + END; + + PUT (FILE, "HELLO"); + + BEGIN + RESET (FILE, IN_FILE); + NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE MODE " & + "ALLOWED - 1"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RASIED FOR RESET - 2"); + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("TEXT_IO NOT SUPPORTED FOR IN_FILE " & + "OPEN"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + NOT_APPLICABLE ("RESET FOR IN_FILE MODE ALLOWED - 2"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 3"); + END; + + BEGIN + RESET (FILE, OUT_FILE); + NOT_APPLICABLE ("RESET FROM IN_FILE TO OUT_FILE MODE " & + "ALLOWED - 2"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET - 4"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3102F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,84 ---- + -- CE3102G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN AN EXTERNAL FILE + -- CANNOT BE DELETED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES, BUT DO NOT SUPPORT DELETION OF EXTERNAL FILES. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3102G IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + VAR1 : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3102G" , "CHECK THAT USE_ERROR IS RAISED WHEN AN " & + "EXTERNAL FILE CANNOT BE DELETED"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + NOT_APPLICABLE ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, VAR1); + + BEGIN + DELETE (FILE); + NOT_APPLICABLE ("DELETION OF EXTERNAL FILES ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR DELETE"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3102G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,116 ---- + -- CE3102H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MODE_ERROR IS RAISED WHEN ATTEMPTING TO CHANGE + -- THE MODE OF A FILE SERVING AS THE CURRENT DEFAULT INPUT + -- OR DEFAULT OUTPUT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102H IS + + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + ITEM : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3102H", "CHECK THAT MODE_ERROR IS RAISED WHEN " & + "ATTEMPTING TO CHANGE THE MODE OF A FILE " & + "SERVING AS THE CURRENT DEFAULT INPUT OR " & + "DEFAULT OUTPUT FILE"); + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + SET_OUTPUT (FILE1); + + BEGIN + RESET (FILE1, IN_FILE); + FAILED ("MODE_ERROR NOT RAISED FOR RESET"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET"); + END; + + SET_OUTPUT (STANDARD_OUTPUT); + + PUT (FILE1, ITEM); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE1); + + BEGIN + RESET (FILE1, OUT_FILE); + FAILED ("MODE_ERROR NOT RAISED FOR RESET"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR RESET"); + END; + + SET_INPUT (STANDARD_INPUT); + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3102H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- CE3102I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN CREATING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR CREATE BY THE + -- IMPLEMENTATION FOR TEXT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OUT_FILE FOR CREATE FOR TEXT_IO. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102I IS + + FILE1 : FILE_TYPE; + + BEGIN + + TEST ("CE3102I", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF CREATE FOR TEXT_IO"); + + BEGIN + CREATE (FILE1, OUT_FILE); + CLOSE (FILE1); + NOT_APPLICABLE ("CREATE WITH MODE OUT_FILE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + END; + + RESULT; + + END CE3102I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102j.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE3102J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- IN_FILE, WHEN IN_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR TEXT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT IN_FILE MODE FOR OPEN FOR TEXT_IO. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102J IS + + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + RAISED_USE_ERROR : BOOLEAN := FALSE; + VAR1 : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3102J", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "IN_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR TEXT_IO"); + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR IN_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3102J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3102k.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- CE3102K.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED WHEN OPENING A FILE OF MODE + -- OUT_FILE, WHEN OUT_FILE MODE IS NOT SUPPORTED FOR OPEN BY THE + -- IMPLEMENTATION FOR TEXT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH DO NOT + -- SUPPORT OUT_FILE MODE FOR OPEN FOR TEXT_IO. + + -- HISTORY: + -- JLH 08/12/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3102K IS + + FILE1 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + RAISED_USE_ERROR : BOOLEAN := FALSE; + VAR1 : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3102K", "CHECK THAT USE_ERROR IS RAISED WHEN MODE " & + "OUT_FILE IS NOT SUPPORTED FOR THE OPERATION " & + "OF OPEN FOR TEXT_IO"); + BEGIN + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE FOR " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, VAR1); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, OUT_FILE, LEGAL_FILE_NAME); + NOT_APPLICABLE ("OPEN FOR OUT_FILE MODE ALLOWED"); + EXCEPTION + WHEN USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + END; + + IF IS_OPEN (FILE1) THEN + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3102K; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3103a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + -- CE3103A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE PAGE AND LINE LENGTH OF TEXT FILES ARE ZERO + -- AFTER A CREATE, OPEN, OR RESET TO OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILE. + + -- HISTORY: + -- ABW 08/24/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- SPS 01/18/83 + -- EG 11/02/84 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/13/87 REVISED TEST TO INCLUDE CASES TO RESET THE FILE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3103A IS + + SUBTEST : EXCEPTION; + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ZERO : CONSTANT COUNT := COUNT(IDENT_INT(0)); + TWO : CONSTANT COUNT := COUNT (IDENT_INT(2)); + FIVE : CONSTANT COUNT := COUNT (IDENT_INT(5)); + + BEGIN + + TEST ("CE3103A" , "CHECK THAT PAGE AND LINE LENGTH " & + "ARE SET TO ZERO AFTER CREATE, " & + "OPEN, OR RESET"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + IF LINE_LENGTH (FILE) /= ZERO THEN + FAILED ("LINE_LENGTH FOR CREATE IS NOT ZERO"); + END IF; + IF PAGE_LENGTH (FILE) /= ZERO THEN + FAILED ("PAGE_LENGTH FOR CREATE IS NOT ZERO"); + END IF; + + SET_LINE_LENGTH (FILE, TWO); + SET_PAGE_LENGTH (FILE, FIVE); + + PUT_LINE (FILE, "HI"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN"); + RAISE INCOMPLETE; + END; + + IF LINE_LENGTH (FILE) /= ZERO THEN + FAILED ("LINE_LENGTH FOR OPEN IS NOT ZERO"); + END IF; + IF PAGE_LENGTH (FILE) /= ZERO THEN + FAILED ("PAGE_LENGTH FOR OPEN IS NOT ZERO"); + END IF; + + SET_LINE_LENGTH (FILE, TWO); + SET_PAGE_LENGTH (FILE, TWO); + + PUT_LINE (FILE, "HI"); + + BEGIN + BEGIN + RESET (FILE, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + RAISE SUBTEST; + END; + + IF LINE_LENGTH (FILE) /= ZERO THEN + FAILED ("LINE_LENGTH FOR RESET TO OUT_FILE IS NOT " & + "ZERO - 1"); + END IF; + IF PAGE_LENGTH (FILE) /= ZERO THEN + FAILED ("PAGE_LENGTH FOR RESET TO OUT_FILE IS NOT " & + "ZERO - 1"); + END IF; + EXCEPTION + WHEN SUBTEST => + NULL; + END; + + SET_LINE_LENGTH (FILE, FIVE); + SET_PAGE_LENGTH (FILE, FIVE); + + PUT_LINE (FILE, "HELLO"); + + IF LINE_LENGTH (FILE) /= 5 THEN + FAILED ("LINE_LENGTH FOR RESET IN OUT_FILE, PLUS HELLO " & + "IS NOT FIVE"); + END IF; + IF PAGE_LENGTH (FILE) /= 5 THEN + FAILED ("PAGE_LENGTH FOR RESET IN OUT_FILE, PLUS HELLO " & + "IS NOT FIVE"); + END IF; + + BEGIN + BEGIN + RESET (FILE); + EXCEPTION + WHEN USE_ERROR => + RAISE SUBTEST; + END; + + IF LINE_LENGTH (FILE) /= ZERO THEN + FAILED ("LINE_LENGTH FOR RESET IS NOT ZERO"); + END IF; + IF PAGE_LENGTH (FILE) /= ZERO THEN + FAILED ("PAGE_LENGTH FOR RESET IS NOT ZERO"); + END IF; + EXCEPTION + WHEN SUBTEST => + NULL; + END; + + SET_LINE_LENGTH (FILE, FIVE); + SET_PAGE_LENGTH (FILE, FIVE); + + PUT_LINE (FILE, "HELLO"); + + IF LINE_LENGTH (FILE) /= 5 THEN + FAILED ("LINE_LENGTH FOR RESET PLUS HELLO"); + END IF; + IF PAGE_LENGTH (FILE) /= 5 THEN + FAILED ("PAGE_LENGTH FOR RESET PLUS HELLO"); + END IF; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + RAISE INCOMPLETE; + END; + + IF LINE_LENGTH (FILE) /= ZERO THEN + FAILED ("LINE_LENGTH FOR RESET TO OUT_FILE IS NOT ZERO - 2"); + END IF; + IF PAGE_LENGTH (FILE) /= ZERO THEN + FAILED ("PAGE_LENGTH FOR RESET TO OUT_FILE IS NOT ZERO - 2"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,231 ---- + -- CE3104A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE CURRENT COLUMN, LINE, AND PAGE NUMBERS OF + -- TEXT FILES ARE SET TO ONE AFTER A CREATE, OPEN, OR RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/24/82 + -- SPS 09/16/82 + -- SPS 11/09/82 + -- JBG 03/16/83 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/13/87 CHANGED FAILED MESSAGES AND ADDED SUBTEST + -- EXCEPTION. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3104A IS + + INCOMPLETE, SUBTEST : EXCEPTION; + FILE, FT : FILE_TYPE; + ONE : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + CHAR : CHARACTER; + + BEGIN + + TEST ("CE3104A" , "CHECK THAT COLUMN, LINE, AND " & + "PAGE NUMBERS ARE ONE AFTER A " & + "CREATE, OPEN, OR RESET"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER CREATE"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER CREATE"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER CREATE"); + END IF; + + NEW_PAGE (FILE); + NEW_LINE (FILE); + PUT (FILE, "STRING"); + + CLOSE (FILE); + + BEGIN + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + RAISE SUBTEST; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER " & + "OPEN - IN_FILE"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER " & + "OPEN - IN_FILE"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER " & + "OPEN - IN_FILE"); + END IF; + + GET (FILE, CHAR); -- SETS PAGE, LINE, AND COL /= 1 + + BEGIN + RESET (FILE); + EXCEPTION + WHEN USE_ERROR => + CLOSE (FILE); + RAISE SUBTEST; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER RESET"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER RESET"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER RESET"); + END IF; + + GET (FILE, CHAR); -- CHANGES LINE, PAGE, COL; STILL IN_FILE + + BEGIN + RESET (FILE,OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + CLOSE (FILE); + RAISE SUBTEST; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER RESET " & + "TO OUT_FILE"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER RESET " & + "TO OUT_FILE"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER RESET " & + "TO OUT_FILE"); + END IF; + + CLOSE (FILE); + + EXCEPTION + WHEN SUBTEST => + NULL; + END; + + BEGIN + BEGIN + OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + RAISE SUBTEST; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER OPEN " & + "TO OUT_FILE"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER OPEN " & + "TO OUT_FILE"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER OPEN " & + "TO OUT_FILE"); + END IF; + + EXCEPTION + WHEN SUBTEST => + NULL; + END; + + BEGIN + BEGIN + CREATE (FT, IN_FILE); + EXCEPTION + WHEN USE_ERROR => + RAISE SUBTEST; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM COLUMN AFTER CREATE " & + "IN IN_FILE"); + END IF; + IF LINE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM LINE AFTER CREATE " & + "IN IN_FILE"); + END IF; + IF PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT RESULTS FROM PAGE AFTER CREATE " & + "IN IN_FILE"); + END IF; + + CLOSE (FT); + + EXCEPTION + WHEN SUBTEST => + NULL; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3104A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + -- CE3104B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE REMAINS OPEN AFTER A RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- DWC 08/13/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3104B IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ITEM1 : STRING (1..5) := "STUFF"; + + BEGIN + + TEST ("CE3104B", "CHECK THAT THE FILE REMAINS OPEN AFTER " & + "A RESET"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + PUT_LINE (FILE, ITEM1); + CLOSE (FILE); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE " & + "NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "FILE I/O"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH IN_FILE MODE NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (FILE) THEN + CLOSE (FILE); + ELSE + FAILED ("RESET FOR IN_FILE, CLOSED FILE"); + END IF; + + BEGIN + OPEN (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("OPEN WITH OUT_FILE MODE NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + IF IS_OPEN (FILE) THEN + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + ELSE + FAILED ("RESET FOR OUT_FILE CLOSED FILE"); + END IF; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3104B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3104c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE3104C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE MODE PARAMETER IN RESET CHANGES THE MODE OF A + -- GIVEN FILE, AND IF NO MODE IS SUPPLIED, THE MODE IS LEFT AS IT + -- WAS BEFORE THE RESET. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- RESET FOR TEXT FILES. + + -- HISTORY: + -- DWC 08/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3104C IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ITEM1 : STRING (1..5) := "STUFF"; + ITEM2 : STRING (1..5); + LENGTH : NATURAL; + + BEGIN + + TEST ("CE3104C", "CHECK THAT THE FILE REMAINS OPEN AFTER " & + "A RESET"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + PUT_LINE (FILE, ITEM1); + EXCEPTION + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATE WITH OUT_FILE MODE NOT " & + "SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED DURING " & + "FILE I/O"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + IF MODE (FILE) /= OUT_FILE THEN + FAILED ("RESET CHANGED MODE OF OUT_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FOR OUT_FILE MODE NOT " & + "SUPPORTED FOR TEXT FILES"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE, IN_FILE); + IF MODE (FILE) /= IN_FILE THEN + FAILED ("RESET MODE TO IN_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET FROM OUT_FILE TO IN_FILE " & + "NOT SUPPORTED FOR TEXT FILES"); + RAISE INCOMPLETE; + END; + + BEGIN + RESET (FILE); + IF MODE (FILE) /= IN_FILE THEN + FAILED ("RESET CHANGED MODE OF IN_FILE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("RESET OF IN_FILE MODE NOT SUPPORTED " & + "FOR TEXT FILES"); + RAISE INCOMPLETE; + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3104C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3106a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- CE3106A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CLOSING A FILE HAS THE FOLLOWING EFFECT: + -- 1) IF THERE IS NO LINE TERMINATOR, A LINE TERMINATOR, PAGE + -- TERMINATOR, AND FILE TERMINATOR ARE WRITTEN AT THE END + -- OF THE FILE. + -- 2) IF THERE IS A LINE TERMINATOR BUT NO PAGE TERMINATOR, A + -- PAGE TERMINATOR AND A FILE TERMINATOR ARE WRITTEN. + -- 3) IF THERE IS A PAGE TERMINATOR, A FILE TERMINATOR IS + -- WRITTEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3106A IS + + INCOMPLETE : EXCEPTION; + FILE1, FILE2, FILE3 : FILE_TYPE; + ITEM : CHARACTER; + + BEGIN + + TEST ("CE3106A", "CHECK THAT CLOSING A FILE HAS THE CORRECT " & + "EFFECT ON THE FILE CONCERNING LINE, PAGE, " & + "AND FILE TERMINATORS"); + + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE" & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, 'A'); + NEW_LINE (FILE1); + PUT (FILE1, 'B'); + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + GET (FILE1, ITEM); + + IF LINE (FILE1) /= 1 THEN + FAILED ("INCORRECT LINE NUMBER - 1"); + END IF; + + GET (FILE1, ITEM); + IF ITEM /= 'B' THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + IF LINE (FILE1) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 2"); + END IF; + + IF NOT END_OF_LINE (FILE1) THEN + FAILED ("LINE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED"); + END IF; + + IF NOT END_OF_PAGE (FILE1) THEN + FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED"); + END IF; + + IF NOT END_OF_FILE (FILE1) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED"); + END IF; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2)); + PUT (FILE2, 'A'); + NEW_LINE (FILE2); + PUT (FILE2, 'B'); + NEW_PAGE (FILE2); + PUT (FILE2, 'C'); + NEW_LINE (FILE2); + + CLOSE (FILE2); + + OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2)); + + GET (FILE2, ITEM); + + GET (FILE2, ITEM); + IF ITEM /= 'B' THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + IF LINE (FILE2) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 3"); + END IF; + + GET (FILE2, ITEM); + + IF LINE (FILE2) /= 1 THEN + FAILED ("INCORRECT LINE NUMBER - 4"); + END IF; + + IF PAGE (FILE2) /= 2 THEN + FAILED ("INCORRECT PAGE NUMBER - 1"); + END IF; + + IF NOT END_OF_PAGE (FILE2) THEN + FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED - 2"); + END IF; + + IF NOT END_OF_FILE (FILE2) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED - 2"); + END IF; + + BEGIN + DELETE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CREATE (FILE3, OUT_FILE, LEGAL_FILE_NAME(3)); + PUT (FILE3, 'A'); + NEW_PAGE (FILE3); + PUT (FILE3, 'B'); + NEW_PAGE (FILE3); + NEW_LINE (FILE3); + PUT (FILE3, 'C'); + NEW_PAGE (FILE3); + + CLOSE (FILE3); + + OPEN (FILE3, IN_FILE, LEGAL_FILE_NAME(3)); + + GET (FILE3, ITEM); + + GET (FILE3, ITEM); + IF ITEM /= 'B' THEN + FAILED ("INCORRECT VALUE READ - 3"); + END IF; + + GET (FILE3, ITEM); + + IF LINE (FILE3) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 5"); + END IF; + + IF PAGE (FILE3) /= 3 THEN + FAILED ("INCORRECT PAGE NUMBER - 2"); + END IF; + + IF NOT END_OF_FILE (FILE3) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS CLOSED - 3"); + END IF; + + BEGIN + DELETE (FILE3); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3106A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3106b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,220 ---- + -- CE3106B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT RESETTING AN OUT_FILE TO AN IN_FILE HAS THE FOLLOWING + -- EFFECT: + -- 1) IF THERE IS NO LINE TERMINATOR, A LINE TERMINATOR, PAGE + -- TERMINATOR, AND FILE TERMINATOR ARE WRITTEN AT THE END + -- OF THE FILE. + -- 2) IF THERE IS A LINE TERMINATOR BUT NO PAGE TERMINATOR, A + -- PAGE TERMINATOR AND A FILE TERMINATOR ARE WRITTEN. + -- 3) IF THERE IS A PAGE TERMINATOR, A FILE TERMINATOR IS + -- WRITTEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3106B IS + + INCOMPLETE : EXCEPTION; + FILE1, FILE2, FILE3 : FILE_TYPE; + ITEM : CHARACTER; + + BEGIN + + TEST ("CE3106B", "CHECK THAT RESETTING AN OUT_FILE TO AN " & + "IN_FILE HAS THE CORRECT EFFECT ON THE " & + "FILE CONCERNING LINE, PAGE, AND FILE " & + "TERMINATORS"); + + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE" & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, 'A'); + NEW_LINE (FILE1); + PUT (FILE1, 'B'); + + BEGIN + RESET (FILE1, IN_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON FILE RESET " & + "FROM OUT_FILE TO IN_FILE"); + RAISE INCOMPLETE; + END; + + GET (FILE1, ITEM); + + IF LINE (FILE1) /= 1 THEN + FAILED ("INCORRECT LINE NUMBER - 1"); + END IF; + + GET (FILE1, ITEM); + IF ITEM /= 'B' THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + IF LINE (FILE1) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 2"); + END IF; + + IF NOT END_OF_LINE (FILE1) THEN + FAILED ("LINE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET"); + END IF; + + IF NOT END_OF_PAGE (FILE1) THEN + FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET"); + END IF; + + IF NOT END_OF_FILE (FILE1) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET"); + END IF; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2)); + PUT (FILE2, 'A'); + NEW_LINE (FILE2); + PUT (FILE2, 'B'); + NEW_PAGE (FILE2); + PUT (FILE2, 'C'); + NEW_LINE (FILE2); + + RESET (FILE2, IN_FILE); + + GET (FILE2, ITEM); + GET (FILE2, ITEM); + + IF LINE (FILE2) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 3"); + END IF; + + GET (FILE2, ITEM); + IF ITEM /= 'C' THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + IF LINE(FILE2) /= 1 THEN + FAILED ("INCORRECT LINE NUMBER - 4"); + END IF; + + IF PAGE(FILE2) /= 2 THEN + FAILED ("INCORRECT PAGE NUMBER - 1"); + END IF; + + IF NOT END_OF_PAGE (FILE2) THEN + FAILED ("PAGE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET - 2"); + END IF; + + IF NOT END_OF_FILE (FILE2) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET - 2"); + END IF; + + BEGIN + DELETE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CREATE (FILE3, OUT_FILE, LEGAL_FILE_NAME(3)); + PUT (FILE3, 'A'); + NEW_PAGE (FILE3); + PUT (FILE3, 'B'); + NEW_PAGE (FILE3); + NEW_LINE (FILE3); + PUT (FILE3, 'C'); + NEW_PAGE (FILE3); + + RESET (FILE3, IN_FILE); + + GET (FILE3, ITEM); + IF ITEM /= 'A' THEN + FAILED ("INCORRECT VALUE READ - 3"); + END IF; + + GET (FILE3, ITEM); + GET (FILE3, ITEM); + + IF LINE(FILE3) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER - 5"); + END IF; + + IF PAGE(FILE3) /= 3 THEN + FAILED ("INCORRECT PAGE NUMBER - 2"); + END IF; + + IF NOT END_OF_FILE (FILE3) THEN + FAILED ("FILE TERMINATOR NOT WRITTEN WHEN FILE " & + "IS RESET - 3"); + END IF; + + BEGIN + DELETE (FILE3); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3106B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3107a.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- CE3107A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE TEXT_IO. + + -- HISTORY: + -- DLD 08/10/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/29/85 + -- DWC 08/17/87 SPLIT OUT CASES WHICH DEPEND ON A TEXT FILE + -- BEING CREATED OR SUCCESSFULLY OPENED. PLACED + -- CASES INTO CE3107B.ADA. + -- PWB 03/07/97 ADDED CHECK FOR FILE SUPPORT. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3107A IS + + TEST_FILE_ZERO : FILE_TYPE; + TEST_FILE_ONE : FILE_TYPE; + TEST_FILE_TWO : FILE_TYPE; + TEST_FILE_THREE : FILE_TYPE; + VAL : BOOLEAN; + + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST("CE3107A", "CHECK THAT IS_OPEN RETURNS THE PROPER " & + "VALUES FOR UNOPENED FILES OF TYPE TEXT_IO"); + + -- FIRST TEST WHETHER IMPLEMENTATION SUPPORTS TEXT FILES AT ALL + + BEGIN + TEXT_IO.CREATE ( TEST_FILE_ZERO, + TEXT_IO.OUT_FILE, + REPORT.LEGAL_FILE_NAME ); + EXCEPTION + WHEN TEXT_IO.USE_ERROR | TEXT_IO.NAME_ERROR => + REPORT.NOT_APPLICABLE + ( "TEXT FILES NOT SUPPORTED -- CREATE OUT-FILE" ); + RAISE INCOMPLETE; + END; + TEXT_IO.DELETE ( TEST_FILE_ZERO ); + + -- WHEN FILE IS DECLARED BUT NOT OPEN + + VAL := TRUE; + VAL := IS_OPEN(TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED("FILE NOT OPEN BUT IS_OPEN RETURNS TRUE"); + END IF; + + -- FOLLOWING UNSUCCESSFUL CREATE + + BEGIN + VAL := TRUE; + CREATE(TEST_FILE_TWO, OUT_FILE, + "$ILLEGAL_EXTERNAL_FILE_NAME1"); + FAILED("NAME_ERROR NOT RAISED - UNSUCCESSFUL CREATE"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN(TEST_FILE_TWO); + IF VAL = TRUE THEN + FAILED("IS_OPEN GIVES TRUE AFTER AN " & + "UNSUCCESSFUL CREATE"); + END IF; + END; + + -- FOLLOWING UNSUCCESSFUL OPEN + + BEGIN + VAL := FALSE; + OPEN(TEST_FILE_TWO, IN_FILE, LEGAL_FILE_NAME); + FAILED("NAME_ERROR NOT RAISED - " & + "UNSUCCESSFUL OPEN"); + EXCEPTION + WHEN NAME_ERROR => + VAL := IS_OPEN(TEST_FILE_TWO); + IF VAL = TRUE THEN + FAILED("IS_OPEN GIVES TRUE - " & + "UNSUCCESSFUL OPEN"); + END IF; + END; + + -- CLOSE FILE WHILE NOT OPEN + + BEGIN + VAL := TRUE; + CLOSE(TEST_FILE_THREE); -- STATUS ERROR + FAILED("STATUS_ERROR NOT RAISED - UNSUCCESSFUL CLOSE"); + EXCEPTION + WHEN OTHERS => + VAL := IS_OPEN(TEST_FILE_THREE); + IF VAL = TRUE THEN + FAILED("IS_OPEN GIVES TRUE - UNSUCCESSFUL " & + "CLOSE"); + END IF; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + REPORT.RESULT; + WHEN OTHERS => + REPORT.FAILED ( "UNEXPECTED EXCEPTION" ); + REPORT.RESULT; + END CE3107A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3107b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- CE3107B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT IS_OPEN RETURNS THE PROPER VALUES FOR FILES OF + -- TYPE TEXT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION WITH OUT_FILE MODE FOR TEXT FILES. + + -- HISTORY: + -- DWC 08/17/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3107B IS + + TEST_FILE_ONE : FILE_TYPE; + TEST_FILE_TWO : FILE_TYPE; + VAL : BOOLEAN; + + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST("CE3107B", "CHECK THAT IS_OPEN RETURNS THE " & + "PROPER VALUES FOR FILES OF TYPE TEXT_IO"); + + -- FOLLOWING A CREATE + + BEGIN + VAL := FALSE; + CREATE(TEST_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + VAL := IS_OPEN(TEST_FILE_ONE); + IF VAL = FALSE THEN + FAILED("IS_OPEN RETURNS FALSE AFTER CREATE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + -- FOLLOWING CLOSE + + VAL := TRUE; + IF IS_OPEN(TEST_FILE_ONE) = TRUE THEN + CLOSE(TEST_FILE_ONE); + END IF; + VAL := IS_OPEN(TEST_FILE_ONE); + IF VAL = TRUE THEN + FAILED("IS_OPEN RETURNS TRUE AFTER CLOSE"); + END IF; + + -- FOLLOWING OPEN + + BEGIN + VAL := FALSE; + BEGIN + OPEN (TEST_FILE_TWO, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_TWO) /= FALSE THEN + FAILED ("FILE OPEN AFTER USE_ERROR " & + "DURING OPEN"); + END IF; + RAISE INCOMPLETE; + END; + VAL := IS_OPEN(TEST_FILE_TWO); + IF VAL = FALSE THEN + FAILED("IS_OPEN RETURNS FALSE AFTER OPEN"); + END IF; + + -- AFTER RESET + + BEGIN + VAL := FALSE; + RESET(TEST_FILE_TWO); + VAL := IS_OPEN(TEST_FILE_TWO); + IF VAL = FALSE THEN + FAILED("IS_OPEN RETURNS FALSE AFTER RESET"); + END IF; + EXCEPTION + WHEN USE_ERROR => + COMMENT("IMPLEMENTATION DOES NOT SUPPORT RESET"); + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + -- AFTER DELETE + + BEGIN + VAL := TRUE; + DELETE(TEST_FILE_TWO); + VAL := IS_OPEN(TEST_FILE_TWO); + IF VAL = TRUE THEN + FAILED("IS_OPEN RETURNS TRUE AFTER DELETE"); + END IF; + EXCEPTION + WHEN USE_ERROR => + IF IS_OPEN (TEST_FILE_TWO) /= FALSE THEN + FAILED ("FILE OPEN AFTER USE_ERROR " & + "DURING DELETE"); + END IF; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3107B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3108a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CE3108A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A FILE CAN BE CLOSED AND THEN RE-OPENED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/16/85 + -- GMT 08/17/87 REMOVED UNNECESSARY CODE AND ADDED A CHECK FOR + -- USE_ERROR ON DELETE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3108A IS + + TXT_FILE : FILE_TYPE; + VAR : STRING (1..2); + LAST : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3108A", "CHECK THAT A FILE CAN BE CLOSED " & + "AND THEN RE-OPENED"); + + -- INITIALIZE TEST FILES + + BEGIN + + BEGIN + CREATE (TXT_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (TXT_FILE, "17"); + CLOSE (TXT_FILE); + + -- RE-OPEN TEXT TEST FILE + + BEGIN + OPEN (TXT_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (TXT_FILE, VAR); + IF VAR /= "17" THEN + FAILED ("WRONG DATA RETURNED FROM READ -TEXT"); + END IF; + + -- DELETE TEST FILES + + BEGIN + DELETE (TXT_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3108A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3108b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CE3108B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE NAME RETURNED BY THE NAME FUNCTION CAN BE USED + -- IN A SUBSEQUENT OPEN. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- DLD 08/11/82 + -- SPS 11/09/82 + -- JBG 03/24/83 + -- EG 05/16/85 + -- GMT 08/17/87 REMOVED UNNECESSARY CODE AND ADDED A CHECK FOR + -- USE_ERROR ON DELETE. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE3108B IS + + TYPE ACC_STR IS ACCESS STRING; + + TXT_FILE : FILE_TYPE; + TXT_FILE_NAME : ACC_STR; + DIR_FILE_NAME : ACC_STR; + VAR : STRING(1..2); + LAST : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3108B", "CHECK THAT THE NAME RETURNED BY THE NAME-" & + "FUNCTION CAN BE USED IN A SUBSEQUENT OPEN"); + + -- CREATE TEST FILES + + BEGIN + BEGIN + CREATE (TXT_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE - 1"); + RAISE INCOMPLETE; + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (TXT_FILE, "14"); + TXT_FILE_NAME := NEW STRING'(NAME (TXT_FILE)); + CLOSE (TXT_FILE); + + -- ATTEMPT TO RE-OPEN TEXT TEST FILE USING RETURNED NAME + -- VALUE + + BEGIN + OPEN (TXT_FILE, IN_FILE, TXT_FILE_NAME.ALL); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR ON RE-OPEN - 3"); + RAISE INCOMPLETE; + END; + + GET (TXT_FILE, VAR); + IF VAR /= "14" THEN + FAILED ("WRONG DATA RETURNED FROM READ - 4"); + END IF; + + -- CLOSE AND DELETE TEST FILES + + BEGIN + DELETE (TXT_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3108B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3110a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- CE3110A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AFTER A SUCCESSFUL DELETE OF AN EXTERNAL FILE, THE + -- NAME OF THE FILE CAN BE USED IN A CREATE OPERATION. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION AND DELETION OF TEXT FILES. + + -- HISTORY: + -- SPS 08/25/82 + -- SPS 11/09/82 + -- JBG 06/04/84 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/18/87 CORRECTED EXCEPTION FORMAT. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3110A IS + BEGIN + + TEST ("CE3110A", "CHECK THAT AN EXTERNAL FILE CAN BE CREATED " & + "AFTER AN EXTERNAL FILE WITH SAME NAME HAS BEEN" & + " DELETED"); + DECLARE + FL1 : FILE_TYPE; + FL2 : FILE_TYPE; + T_FAILED : BOOLEAN := FALSE; + D_FILE : BOOLEAN := FALSE; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + T_FAILED := TRUE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE"); + T_FAILED := TRUE; + END; + + IF NOT T_FAILED THEN + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL " & + "FILES NOT SUPPORTED"); + T_FAILED := TRUE; + END; + END IF; + + IF NOT T_FAILED THEN + BEGIN + CREATE (FL2, OUT_FILE, LEGAL_FILE_NAME); + D_FILE := TRUE; + EXCEPTION + WHEN OTHERS => + FAILED ("UNABLE TO RECREATE FILE AFTER " & + "DELETION - TEXT"); + END; + IF D_FILE THEN + BEGIN + DELETE (FL2); + EXCEPTION + WHEN OTHERS => + FAILED ("DELETE SHOULD STILL BE " & + "SUPPORTED"); + END; + END IF; + END IF; + END; + + RESULT; + + END CE3110A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3112c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,81 ---- + -- CE3112C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED BY A NON-NULL + -- STRING NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN + -- PROGRAM. + + -- THIS TEST CREATES A TEXT FILE WHICH CE3112D.ADA WILL READ. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF AN EXTERNAL TEXT FILE WITH OUT_FILE MODE. + + -- HISTORY: + -- GMT 08/13/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; + + PROCEDURE CE3112C IS + + INCOMPLETE : EXCEPTION; + FILE_NAME : TEXT_IO.FILE_TYPE; + PREVENT_EMPTY_FILE : STRING (1..5) := "HELLO"; + + BEGIN + TEST ("CE3112C" , "CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED " & + "BY A NON-NULL STRING NAME IS ACCESSIBLE " & + "AFTER THE COMPLETION OF THE MAIN PROGRAM"); + BEGIN + BEGIN + TEXT_IO.CREATE (FILE_NAME, TEXT_IO.OUT_FILE, + LEGAL_FILE_NAME); + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN TEXT_IO.NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE - 3"); + RAISE INCOMPLETE; + END; + + TEXT_IO.PUT (FILE_NAME, PREVENT_EMPTY_FILE); + TEXT_IO.CLOSE (FILE_NAME); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3112C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3112d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE3112D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED BY A NON-NULL STRING + -- NAME IS ACCESSIBLE AFTER THE COMPLETION OF THE MAIN PROGRAM. + + -- THIS TEST CHECKS THE CREATION OF A TEXT FILE X3112C, WHICH WAS + -- CREATED BY CE3112C.ADA. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- GMT 08/13/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; + + PROCEDURE CE3112D IS + + INCOMPLETE : EXCEPTION; + CHECK_SUPPORT, FILE_NAME : TEXT_IO.FILE_TYPE; + PREVENT_EMPTY_FILE : STRING (1..5); + + BEGIN + TEST ("CE3112D", "CHECK THAT AN EXTERNAL TEXT FILE SPECIFIED BY " & + "A NON-NULL STRING NAME IS ACCESSIBLE AFTER " & + "THE COMPLETION OF THE MAIN PROGRAM"); + + -- TEST FOR TEXT FILE SUPPORT. + + BEGIN + TEXT_IO.CREATE (CHECK_SUPPORT, TEXT_IO.OUT_FILE, + LEGAL_FILE_NAME); + BEGIN + TEXT_IO.DELETE (CHECK_SUPPORT); + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "DELETE - 1"); + END; + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN TEXT_IO.NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE - 3"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE - 4"); + RAISE INCOMPLETE; + END; + + -- BEGIN TEST OBJECTIVE. + + BEGIN + TEXT_IO.OPEN (FILE_NAME, TEXT_IO.IN_FILE, + LEGAL_FILE_NAME (1, "CE3112C")); + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE("USE_ERROR RAISED ON OPEN FOR TEXT " & + "FILE WITH IN_FILE MODE - 5"); + RAISE INCOMPLETE; + END; + + TEXT_IO.GET (FILE_NAME, PREVENT_EMPTY_FILE); + + IF PREVENT_EMPTY_FILE /= "HELLO" THEN + FAILED ("OPENED WRONG FILE OR DATA ERROR - 6"); + END IF; + BEGIN + TEXT_IO.DELETE (FILE_NAME); + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + COMMENT ("IMPLEMENTATION WOULD NOT ALLOW DELETION OF " & + "EXTERNAL FILE - 7"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3112D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3114a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- CE3114A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AN EXTERNAL TEXT FILE CEASES TO EXIST AFTER + -- A SUCCESSFUL DELETE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION AND DELETION OF TEXT FILES. + + -- HISTORY: + -- SPS 08/25/82 + -- SPS 11/09/82 + -- JBG 04/01/83 + -- EG 05/16/85 + -- GMT 08/25/87 COMPLETELY REVISED. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3114A IS + BEGIN + + TEST ("CE3114A", "CHECK THAT AN EXTERNAL TEXT FILE CEASES TO " & + "EXIST AFTER A SUCCESSFUL DELETE"); + + DECLARE + FL1, FL2 : FILE_TYPE; + VAR1 : CHARACTER := 'A'; + INCOMPLETE : EXCEPTION; + BEGIN + BEGIN + CREATE (FL1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "CREATE - 3"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FL1, VAR1); -- THIS PUTS TO THE FILE IF + EXCEPTION -- IT CAN, NOT NECESSARY FOR + WHEN OTHERS => -- THE OBJECTIVE. + NULL; + END; + + BEGIN + DELETE (FL1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("DELETION OF EXTERNAL TEXT FILES " & + "IS NOT SUPPORTED - 4"); + RAISE INCOMPLETE; + END; + + BEGIN + OPEN (FL2, IN_FILE, LEGAL_FILE_NAME); + FAILED ("EXTERNAL TEXT FILE STILL EXISTS AFTER " & + "A SUCCESSFUL DELETION - 5"); + EXCEPTION + WHEN NAME_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3114A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3115a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,232 ---- + -- CE3115A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT RESETTING ONE OF A MULTIPLE OF INTERNAL FILES + -- ASSOCIATED WITH THE SAME EXTERNAL FILE HAS NO EFFECT ON ANY + -- OF THE OTHER INTERNAL FILES. + + + -- APPLICABILITY CRITERIA: + -- THIS TEST APPLIES ONLY TO IMPLEMENTATIONS WHICH SUPPORT MULTIPLE + -- INTERNAL FILES ASSOCIATED WITH THE SAME EXTERNAL FILE AND + -- RESETTING OF THESE MULTIPLE INTERNAL FILES FOR TEXT FILES. + + -- HISTORY: + -- DLD 08/16/82 + -- SPS 11/09/82 + -- JBG 06/04/84 + -- EG 11/19/85 MADE TEST INAPPLICABLE IF CREATE USE_ERROR. + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE RESULT WHEN + -- FILES NOT SUPPORTED. + -- GMT 08/25/87 COMPLETELY REVISED. + -- EDS 12/01/97 ADD NAME_ERROR HANDLER TO OUTPUT NOT_APPLICABLE RESULT. + -- RLB 09/29/98 MADE MODIFICATION TO AVOID BUFFERING PROBLEMS. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3115A IS + + BEGIN + + TEST ("CE3115A", "CHECK THAT RESETTING ONE OF A MULTIPLE OF " & + "INTERNAL FILES ASSOCIATED WITH THE SAME " & + "EXTERNAL FILE HAS NO EFFECT ON ANY OF THE " & + "OTHER INTERNAL FILES"); + + DECLARE + TXT_FILE_ONE : TEXT_IO.FILE_TYPE; + TXT_FILE_TWO : TEXT_IO.FILE_TYPE; + + CH : CHARACTER := 'A'; + + INCOMPLETE : EXCEPTION; + + PROCEDURE TXT_CLEANUP IS + FILE1_OPEN : BOOLEAN := IS_OPEN (TXT_FILE_ONE); + FILE2_OPEN : BOOLEAN := IS_OPEN (TXT_FILE_TWO); + BEGIN + IF FILE1_OPEN AND FILE2_OPEN THEN + CLOSE (TXT_FILE_TWO); + DELETE (TXT_FILE_ONE); + ELSIF FILE1_OPEN THEN + DELETE (TXT_FILE_ONE); + ELSIF FILE2_OPEN THEN + DELETE (TXT_FILE_TWO); + END IF; + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED " & + "IN CLEANUP - 1"); + END TXT_CLEANUP; + + BEGIN + + BEGIN -- CREATE FIRST FILE + + CREATE (TXT_FILE_ONE, OUT_FILE, LEGAL_FILE_NAME); + PUT (TXT_FILE_ONE, CH); + + EXCEPTION + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; CREATE OF " & + "EXTERNAL FILENAME IS NOT " & + "SUPPORTED - 2"); + RAISE INCOMPLETE; + WHEN TEXT_IO.NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; CREATE OF " & + "EXTERNAL FILENAME IS NOT " & + "SUPPORTED - 3"); + RAISE INCOMPLETE; + + END; -- CREATE FIRST FILE + + BEGIN -- OPEN SECOND FILE + + OPEN (TXT_FILE_TWO, IN_FILE, LEGAL_FILE_NAME); + + EXCEPTION + + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE ("MULTIPLE INTERNAL FILES ARE NOT " & + "SUPPORTED WHEN ONE IS MODE " & + "OUT_FILE AND THE OTHER IS MODE " & + "IN_FILE - 4" & + " - USE_ERROR RAISED "); + TXT_CLEANUP; + RAISE INCOMPLETE; + + WHEN TEXT_IO.NAME_ERROR => + NOT_APPLICABLE ("MULTIPLE INTERNAL FILES ARE NOT " & + "SUPPORTED WHEN ONE IS MODE " & + "OUT_FILE AND THE OTHER IS MODE " & + "IN_FILE - 4" & + " - NAME_ERROR RAISED "); + TXT_CLEANUP; + RAISE INCOMPLETE; + + END; -- OPEN SECOND FILE + FLUSH (TXT_FILE_ONE); -- AVOID BUFFERING PROBLEMS. + + CH := 'B'; + GET (TXT_FILE_TWO, CH); + IF CH /= 'A' THEN + FAILED ("INCORRECT VALUE FOR GET - 5"); + END IF; + + BEGIN -- INITIALIZE FIRST FILE TO CHECK POINTER RESETTING + + RESET (TXT_FILE_ONE); + IF MODE (TXT_FILE_ONE) /= OUT_FILE THEN + FAILED ("FILE WAS NOT RESET - 6"); + END IF; + IF MODE (TXT_FILE_TWO) /= IN_FILE THEN + FAILED ("RESETTING OF ONE INTERNAL FILE " & + "AFFECTED THE OTHER INTERNAL FILE - 7"); + END IF; + + EXCEPTION + + WHEN TEXT_IO.USE_ERROR => + NOT_APPLICABLE ("RESETTING OF EXTERNAL FILE FOR " & + "OUT_FILE MODE IS " & + " NOT SUPPORTED - 8"); + TXT_CLEANUP; + RAISE INCOMPLETE; + + END; -- INITIALIZE FIRST FILE TO CHECK POINTER RESETTING + + -- PERFORM SOME I/O ON THE FIRST FILE + + PUT (TXT_FILE_ONE, 'C'); + PUT (TXT_FILE_ONE, 'D'); + PUT (TXT_FILE_ONE, 'E'); + CLOSE (TXT_FILE_ONE); + + BEGIN + OPEN (TXT_FILE_ONE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("MULTIPLE INTERNAL FILES NOT " & + "SUPPORTED WHEN BOTH FILES HAVE " & + "IN_FILE MODE - 9"); + RAISE INCOMPLETE; + END; + + GET (TXT_FILE_ONE, CH); + GET (TXT_FILE_ONE, CH); + + BEGIN -- INITIALIZE SECOND FILE AND PERFORM SOME I/O + + CLOSE (TXT_FILE_TWO); + OPEN (TXT_FILE_TWO, IN_FILE, LEGAL_FILE_NAME); + + EXCEPTION + + WHEN TEXT_IO.USE_ERROR => + FAILED ("MULTIPLE INTERNAL FILES SHOULD STILL " & + "BE ALLOWED - 10"); + TXT_CLEANUP; + RAISE INCOMPLETE; + + END; -- INITIALIZE SECOND FILE AND PERFORM SOME I/O + + BEGIN -- RESET FIRST FILE AND CHECK EFFECTS ON SECOND FILE + + GET (TXT_FILE_TWO, CH); + IF CH /= 'C' THEN + FAILED ("INCORRECT VALUE FOR GET OPERATION - 11"); + END IF; + + RESET (TXT_FILE_ONE); + GET (TXT_FILE_TWO, CH); + IF CH /= 'D' THEN + FAILED ("RESETTING INDEX OF ONE TEXT FILE " & + "RESETS THE OTHER ASSOCIATED FILE - 12"); + END IF; + + EXCEPTION + + WHEN TEXT_IO.USE_ERROR => + FAILED ("RESETTING SHOULD STILL BE SUPPORTED - 13"); + TXT_CLEANUP; + RAISE INCOMPLETE; + + END; -- RESET FIRST FILE AND CHECK EFFECTS ON SECOND FILE + + TXT_CLEANUP; + + EXCEPTION + + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3115A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3201a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- CE3201A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT THE STANDARD INPUT AND OUTPUT FILES EXIST + -- AND ARE OPEN. + + -- ABW 8/25/82 + -- SPS 9/16/82 + -- SPS 12/14/82 + -- JBG 3/17/83 + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3201A IS + CH : CHARACTER; + BEGIN + + TEST ("CE3201A", "CHECK THAT STANDARD INPUT AND " & + "OUTPUT EXIST AND ARE OPEN"); + + IF NOT IS_OPEN (STANDARD_INPUT) THEN + FAILED ("STANDARD_INPUT NOT OPEN - IS_OPEN"); + END IF; + + IF NOT IS_OPEN (STANDARD_OUTPUT) THEN + FAILED ("STANDARD_OUTPUT NOT OPEN - IS_OPEN"); + END IF; + + BEGIN + PUT ('X'); + EXCEPTION + WHEN OTHERS => + FAILED ("STANDARD_OUTPUT NOT AVAILABLE - " & + "PUT DEFAULT"); + END; + + BEGIN + PUT (STANDARD_OUTPUT, 'D'); + EXCEPTION + WHEN OTHERS => + FAILED ("STANDARD_OUTPUT NOT AVAILABLE - " & + "PUT"); + END; + + RESULT; + + END CE3201A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3202a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- CE3202A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT CURRENT_INPUT AND CURRENT_OUTPUT INITIALLY + -- CORRESPOND TO STANDARD FILES. + + -- ABW 8/25/82 + -- SPS 11/9/82 + -- JBG 3/17/83 + -- JBG 5/8/84 + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3202A IS + + + BEGIN + + TEST ("CE3202A", "CHECK THAT CURRENT_INPUT AND " & + "CURRENT_OUTPUT INITIALLY " & + "CORRESPOND TO STANDARD FILES"); + + IF NAME (CURRENT_INPUT) /= NAME (STANDARD_INPUT) THEN + FAILED ("CURRENT_INPUT INCORRECT - NAME"); + END IF; + + IF NAME (CURRENT_OUTPUT) /= NAME (STANDARD_OUTPUT) THEN + FAILED ("CURRENT_OUTPUT INCORRECT - NAME"); + END IF; + + RESULT; + + END CE3202A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3206a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CE3206A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_INPUT AND SET_OUTPUT RAISE STATUS_ERROR WHEN + -- CALLED WITH A FILE PARAMETER DENOTING A CLOSED FILE. + + -- HISTORY: + -- ABW 08/31/82 + -- SPS 10/01/82 + -- SPS 11/09/82 + -- JLH 08/18/87 ADDED NEW CASES FOR SET_INPUT AND SET_OUTPUT. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3206A IS + + FILE_IN, FILE1 : FILE_TYPE; + ITEM : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3206A", "CHECK THAT SET_INPUT AND SET_OUTPUT " & + "RAISE STATUS_ERROR WHEN CALLED WITH A " & + "FILE PARAMETER DENOTING A CLOSED FILE"); + + BEGIN + SET_INPUT (FILE_IN); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_INPUT - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT - 1"); + END; + + BEGIN + SET_OUTPUT (FILE_IN); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_OUTPUT - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT - 1"); + END; + + BEGIN + CREATE (FILE1, OUT_FILE); + PUT (FILE1, ITEM); + CLOSE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + SET_INPUT (FILE1); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_INPUT - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT - 2"); + END; + + BEGIN + SET_OUTPUT (FILE1); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_OUTPUT - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT - 2"); + END; + + + RESULT; + + END CE3206A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3207a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- CE3207A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT MODE_ERROR IS RAISED IF THE PARAMETER TO SET_INPUT HAS + -- MODE OUT_FILE OR THE PARAMETER TO SET_OUTPUT HAS MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3207A IS + + FILE1, FILE2 : FILE_TYPE; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3207A", "CHECK THAT MODE_ERROR IS RAISED IF THE " & + "PARAMETER TO SET_INPUT HAS MODE OUT_FILE " & + "OR THE PARAMETER TO SET_OUTPUT HAS MODE " & + "IN_FILE"); + + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + SET_INPUT (FILE1); + FAILED ("MODE_ERROR NOT RAISED FOR SET_INPUT WITH " & + "MODE OUT_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_INPUT"); + END; + + CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME); + + PUT (FILE2, "OUTPUT STRING"); + CLOSE (FILE2); + OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME); + + BEGIN + SET_OUTPUT (FILE2); + FAILED ("MODE_ERROR NOT RAISED FOR SET_OUTPUT WITH " & + "MODE IN_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR SET_OUTPUT"); + END; + + BEGIN + DELETE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3207A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3301a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- CE3301A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN THE LINE AND PAGE LENGTH ARE NONZERO, LINE AND + -- PAGE TERMINATORS ARE OUTPUT AT THE APPROPRIATE POINTS. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/22/82 + -- SPS 11/15/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/27/87 COMPLETELY REVISED TEST. + -- LDC 05/26/88 ADDED "FILE" PARAMETERS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3301A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + TWO : CONSTANT COUNT := COUNT(IDENT_INT(2)); + TEN : CONSTANT COUNT := COUNT(IDENT_INT(10)); + THREE : CONSTANT COUNT := COUNT(IDENT_INT(3)); + ITEM1 : STRING (1..10); + ITEM2 : STRING (1..2); + + BEGIN + + TEST ("CE3301A", "CHECK THAT WHEN THE LINE AND PAGE LENGTH ARE " & + "NONZERO, LINE AND PAGE TERMINATORS ARE " & + "OUTPUT AT THE APPROPRIATE POINTS"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + IF LINE_LENGTH (FILE) /= UNBOUNDED THEN + FAILED ("LINE LENGTH NOT INITIALLY UNBOUNDED"); + END IF; + + IF PAGE_LENGTH (FILE) /= UNBOUNDED THEN + FAILED ("PAGE LENGTH NOT INITIALLY UNBOUNDED"); + END IF; + + SET_LINE_LENGTH (FILE,TEN); + SET_PAGE_LENGTH (FILE,TWO); + + FOR I IN 1 .. 30 LOOP + PUT (FILE,'C'); + END LOOP; + + IF PAGE (FILE) /= 2 AND LINE (FILE) /= 1 THEN + FAILED ("LINE AND PAGE LENGTHS WERE NOT BOUND " & + "CORRECTLY"); + END IF; + + SET_LINE_LENGTH (FILE, TWO); + SET_PAGE_LENGTH (FILE, THREE); + PUT (FILE, "DDDDDDD"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM1); + + IF NOT (END_OF_LINE (FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR"); + END IF; + + IF END_OF_PAGE (FILE) THEN + FAILED ("PAGE TERMINATOR OUTPUT AT INAPPROPRIATE POINT"); + END IF; + + GET (FILE, ITEM1); + + IF ITEM1 /= "CCCCCCCCCC" THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + IF NOT (END_OF_LINE(FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR"); + END IF; + + IF NOT (END_OF_PAGE(FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR"); + END IF; + + GET (FILE, ITEM1); + GET (FILE, ITEM2); + + IF ITEM2 /= "DD" THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + IF NOT (END_OF_LINE(FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR"); + END IF; + + IF END_OF_PAGE (FILE) THEN + FAILED ("PAGE TERMINATOR OUTPUT AT INAPPROPRIATE POINT"); + END IF; + + GET (FILE, ITEM2); + + IF ITEM2 /= "DD" THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + IF NOT (END_OF_LINE(FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE LINE TERMINATOR"); + END IF; + + IF NOT (END_OF_PAGE(FILE)) THEN + FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3301A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3302a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- CE3302A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE_LENGTH, SET_PAGE_LENGTH, LINE_LENGTH, AND + -- PAGE_LENGTH RAISE MODE_ERROR WHEN APPLIED TO A FILE OF MODE + -- IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/19/87 CREATED AN EXTERNAL FILE WITH A NAME, REMOVED + -- DEPENDENCE ON RESET, AND ADDED CODE TO DELETE + -- EXTERNAL FILE. + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3302A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + FIVE : COUNT := COUNT(IDENT_INT(5)); + VAR1 : COUNT; + ITEM : CHARACTER := 'A'; + + BEGIN + TEST ("CE3302A", "CHECK THAT SET_LINE_LENGTH, SET_PAGE_LENGTH, " & + "LINE_LENGTH, AND PAGE_LENGTH RAISE MODE_ERROR " & + "WHEN APPLIED TO A FILE OF MODE IN_FILE"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT FILE CREATE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT FILE CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, ITEM); + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT FILE OPEN"); + RAISE INCOMPLETE; + END; + + BEGIN + SET_LINE_LENGTH (FILE, FIVE); + FAILED ("MODE_ERROR NOT RAISED - SET_LINE_LENGTH"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - SET_LINE_LENGTH"); + END; + + BEGIN + SET_PAGE_LENGTH (FILE, FIVE); + FAILED ("MODE_ERROR NOT RAISED - SET_PAGE_LENGTH"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - SET_PAGE_LENGTH"); + END; + + BEGIN + VAR1 := LINE_LENGTH (FILE); + FAILED ("MODE_ERROR NOT RAISED - LINE_LENGTH"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - LINE_LENGTH"); + END; + + BEGIN + VAR1 := PAGE_LENGTH (FILE); + FAILED ("MODE_ERROR NOT RAISED - PAGE_LENGTH"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PAGE_LENGTH"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3302A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3303a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CE3303A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE_LENGTH, SET_PAGE_LENGTH, LINE_LENGTH, AND + -- PAGE_LENGTH RAISE STATUS_ERROR WHEN APPLIED TO A CLOSED FILE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- JLH 08/19/87 ADDED AN ATTEMPT TO CREATE AN EXTERNAL FILE; + -- ADDED CHECKS TO THE SAME FOUR CASES WHICH EXIST + -- IN TEST AGAINST ATTEMPTED CREATE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3303A IS + + FILE : FILE_TYPE; + FIVE : COUNT := COUNT(IDENT_INT(5)); + C : COUNT; + ITEM : CHARACTER := 'A'; + + BEGIN + + TEST ("CE3303A" , "CHECK THAT SET_LINE_LENGTH, " & + "SET_PAGE_LENGTH, LINE_LENGTH, AND " & + "PAGE_LENGTH RAISE STATUS_ERROR " & + "WHEN APPLIED TO A CLOSED FILE"); + + -- FILE NONEXISTANT + + BEGIN + SET_LINE_LENGTH (FILE, FIVE); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_LINE_LENGTH - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR SET_LINE_LENGTH " & + "- 1"); + END; + + BEGIN + SET_PAGE_LENGTH (FILE, FIVE); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_PAGE_LENGTH - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR SET_PAGE_LENGTH " & + "- 1"); + END; + + BEGIN + C := LINE_LENGTH (FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR LINE_LENGTH - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR LINE_LENGTH - 1"); + END; + + BEGIN + C := PAGE_LENGTH (FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR PAGE_LENGTH - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PAGE_LENGTH - 1"); + END; + + BEGIN + CREATE (FILE, OUT_FILE); + PUT (FILE, ITEM); + CLOSE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + SET_LINE_LENGTH (FILE, FIVE); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_LINE_LENGTH - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR SET_LINE_LENGTH " & + "- 2"); + END; + + BEGIN + SET_PAGE_LENGTH (FILE, FIVE); + FAILED ("STATUS_ERROR NOT RAISED FOR SET_PAGE_LENGTH - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR SET_PAGE_LENGTH " & + "- 2"); + END; + + BEGIN + C := LINE_LENGTH (FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR LINE_LENGTH - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR LINE_LENGTH - 2"); + END; + + BEGIN + C := PAGE_LENGTH (FILE); + FAILED ("STATUS_ERROR NOT RAISED FOR PAGE_LENGTH - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR PAGE_LENGTH - 2"); + END; + + RESULT; + + END CE3303A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3304a.tst 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,204 ---- + -- CE3304A.TST + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT USE_ERROR IS RAISED BY A CALL TO SET_LINE_LENGTH + -- OR TO SET_PAGE_LENGTH WHEN THE SPECIFIED VALUE IS INAPPROPRIATE + -- FOR THE EXTERNAL FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE TO IMPLEMENTATIONS THAT SATISFY THE + -- FOLLOWING CONDITIONS: + -- 1) TEXT FILES ARE SUPPORTED + -- 2) EITHER BY DEFAULT OR BY USE OF THE "FORM" PARAMETER TO + -- THE CREATE PROCEDURE, A TEXT FILE CAN BE CREATED FOR + -- WHICH AT LEAST ONE OF THE FOLLOWING CONDITIONS HOLDS: + -- A) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT + -- AN APPROPRIATE LINE-LENGTH FOR THE FILE, + -- OR + -- B) THERE IS A VALUE OF TYPE TEXT_IO.COUNT THAT IS NOT + -- AN APPROPRIATE PAGE-LENGTH FOR THE FILE. + + -- MACRO SUBSTITUTIONS: + -- FOR THE MACRO SYMBOL "$FORM_STRING," SUBSTITUTE A STRING LITERAL + -- SPECIFIYING THAT THE EXTERNAL FILE MEETS BOTH OF THE CONDITIONS + -- (A) AND (B) ABOVE. IF IT IS NOT POSSIBLE TO SATISFY BOTH + -- CONDITIONS, THEN SUBSTITUTE A STRING LITERAL SPECIFYING THAT THE + -- EXTERNAL FILE SATISFIES ONE OF THE CONDITIONS. IF IT IS NOT + -- POSSIBLE TO SATISFY EITHER CONDITION, THEN SUBSTITUE THE NULL + -- STRING (""). + -- FOR THE MACRO SYMBOL "$INAPPROPRIATE_LINE_LENGTH," SUBSTITUTE + -- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE LINE-LENGTH + -- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1. + -- FOR THE MACRO SYMBOL "$INAPPROPRIATE_PAGE_LENGTH," SUBSTITUTE + -- A LITERAL OF TYPE COUNT THAT IS INAPPROPRIATE AS THE PAGE-LENGTH + -- FOR THE EXTERNAL FILE. IF THERE IS NO SUCH VALUE, THEN USE -1. + + -- HISTORY: + -- PWB 07/07/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3304A IS + + FILE1, + FILE2, + FILE3 : FILE_TYPE; + + LINE_LENGTH_SHOULD_WORK, + PAGE_LENGTH_SHOULD_WORK : BOOLEAN; + + INCOMPLETE : EXCEPTION; + + TEST_VALUE : COUNT; + + BEGIN + + TEST ("CE3304A", "CHECK THAT USE_ERROR IS RAISED IF A CALL TO " & + "SET_LINE_LENGTH OR SET_PAGE_LENGTH SPECIFIES " & + "A VALUE THAT IS INAPPROPRIATE FOR THE " & + "EXTERNAL FILE"); + + BEGIN -- CHECK WHETHER TEXT FILES ARE SUPPORTED. + + CREATE(FILE1, OUT_FILE, LEGAL_FILE_NAME(1), + FORM => $FORM_STRING); + PUT_LINE(FILE1, "AAA"); + CLOSE(FILE1); + + EXCEPTION + + WHEN USE_ERROR | NAME_ERROR => + NOT_APPLICABLE ("CREATION OF TEXT FILES NOT SUPPORTED"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED AT INITIAL CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN -- CHECK INAPPROPRIATE LINE LENGTH. + + BEGIN -- IS THERE AN INAPPROPRIATE VALUE? + TEST_VALUE := + COUNT(IDENT_INT($INAPPROPRIATE_LINE_LENGTH)); + IF NOT EQUAL (INTEGER(TEST_VALUE), + INTEGER(TEST_VALUE)) THEN + COMMENT ("OPTIMIZATION DEFEATED" & + COUNT'IMAGE(TEST_VALUE)); + END IF; + LINE_LENGTH_SHOULD_WORK := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + LINE_LENGTH_SHOULD_WORK := FALSE; + COMMENT("THERE IS NO INAPPROPRIATE LINE LENGTH"); + END; + + IF LINE_LENGTH_SHOULD_WORK THEN + BEGIN + CREATE(FILE2, OUT_FILE, LEGAL_FILE_NAME(2), + FORM => $FORM_STRING); + SET_LINE_LENGTH(FILE2, $INAPPROPRIATE_LINE_LENGTH); + FAILED("NO EXCEPTION FOR INAPPROPRIATE LINE " & + "LENGTH"); + EXCEPTION + WHEN USE_ERROR => + IF NOT IS_OPEN(FILE2) THEN + FAILED ("FILE NOT OPENED -- LINE LENGTH"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "INAPPROPRIATE LINE LENGTH"); + END; + END IF; + END; + + ----------------------------------------------------------------------- + + BEGIN -- CHECK INAPPROPRIATE PAGE LENGTH. + + BEGIN -- IS THERE AN INAPPROPRIATE VALUE? + TEST_VALUE := + COUNT(IDENT_INT($INAPPROPRIATE_PAGE_LENGTH)); + IF NOT EQUAL (INTEGER(TEST_VALUE), + INTEGER(TEST_VALUE)) THEN + COMMENT ("OPTIMIZATION DEFEATED" & + COUNT'IMAGE(TEST_VALUE)); + END IF; + PAGE_LENGTH_SHOULD_WORK := TRUE; + EXCEPTION + WHEN CONSTRAINT_ERROR => + PAGE_LENGTH_SHOULD_WORK := FALSE; + COMMENT("THERE IS NO INAPPROPRIATE PAGE LENGTH"); + END; + + IF PAGE_LENGTH_SHOULD_WORK THEN + BEGIN + CREATE(FILE3, OUT_FILE, LEGAL_FILE_NAME(3), + FORM => $FORM_STRING); + SET_PAGE_LENGTH(FILE3, $INAPPROPRIATE_PAGE_LENGTH); + FAILED("NO EXCEPTION FOR INAPPROPRIATE PAGE " & + "LENGTH"); + EXCEPTION + WHEN USE_ERROR => + IF NOT IS_OPEN(FILE3) THEN + FAILED ("FILE NOT OPENED -- PAGE LENGTH"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "INAPPROPRIATE PAGE LENGTH"); + END; + END IF; + END; + + IF NOT (PAGE_LENGTH_SHOULD_WORK OR LINE_LENGTH_SHOULD_WORK) THEN + NOT_APPLICABLE("NO INAPPROPRIATE VALUES FOR EITHER LINE " & + "LENGTH OR PAGE LENGTH"); + END IF; + + BEGIN -- CLEAN UP FILES. + + IF IS_OPEN(FILE1) THEN + CLOSE(FILE1); + END IF; + + IF IS_OPEN(FILE2) THEN + CLOSE(FILE2); + END IF; + + IF IS_OPEN(FILE3) THEN + CLOSE(FILE3); + END IF; + + EXCEPTION + WHEN USE_ERROR => + COMMENT("FILES NOT DELETED"); + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3304A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3305a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- CE3305A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE LINE AND PAGE LENGTHS MAY BE ALTERED DYNAMICALLY + -- SEVERAL TIMES. CHECK THAT WHEN RESET TO ZERO, THE LENGTHS ARE + -- UNBOUNDED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES WITH UNBOUNDED LINE LENGTH. + + -- HISTORY: + -- SPS 09/28/82 + -- EG 05/22/85 + -- DWC 08/18/87 ADDED CHECK_FILE WITHOUT A'S. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3305A IS + + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3305A", "CHECK THAT LINE AND PAGE LENGTHS MAY BE " & + "ALTERED DYNAMICALLY"); + + DECLARE + FT : FILE_TYPE; + + PROCEDURE PUT_CHARS (CNT: INTEGER; CH: CHARACTER) IS + BEGIN + FOR I IN 1 .. CNT LOOP + PUT (FT, CH); + END LOOP; + END PUT_CHARS; + + BEGIN + + BEGIN + CREATE(FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 10); + SET_PAGE_LENGTH (FT, 5); + + PUT_CHARS (150, 'X'); -- 15 LINES + + BEGIN + SET_LINE_LENGTH (FT, 5); + SET_PAGE_LENGTH (FT, 10); + EXCEPTION + WHEN OTHERS => + FAILED ("UNABLE TO CHANGE LINE OR PAGE LENGTH"); + END; + + PUT_CHARS (50, 'B'); -- 10 LINES + + BEGIN + SET_LINE_LENGTH (FT, 25); + SET_PAGE_LENGTH (FT,4); + EXCEPTION + WHEN OTHERS => + FAILED ("UNABLE TO CHANGE LINE OR PAGE LENGTH - 2"); + END; + + PUT_CHARS (310, 'K'); -- 12 LINES, 10 CHARACTERS + + -- THIS CAN RAISE USE_ERROR IF AN IMPLEMENTATION REQUIRES A BOUNDED + -- LINE LENGTH FOR AN EXTERNAL FILE. + + BEGIN + BEGIN + SET_LINE_LENGTH (FT, UNBOUNDED); + SET_PAGE_LENGTH (FT, UNBOUNDED); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("BOUNDED LINE LENGTH " & + "REQUIRED"); + RAISE INCOMPLETE; + END; + + PUT_CHARS (100, 'A'); -- ONE LINE + + CHECK_FILE (FT,"XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#@" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#@" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "XXXXXXXXXX#" & + "BBBBB#" & + "BBBBB#" & + "BBBBB#" & + "BBBBB#" & + "BBBBB#@" & + "BBBBB#" & + "BBBBB#" & + "BBBBB#" & + "BBBBB#" & + "BBBBBKKKKKKKKKKKKKKKKKKKK#@" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#@" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#@" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#" & + "KKKKKKKKKKKKKKKKKKKKKKKKK#"& + "KKKKKKKKKKKKKKKKKKKKKKKKK#"& + "KKKKKKKKKKKKKKKAAAAAAAAAAA" & + "AAAAAAAAAAAAAAAAAAAAAAAAAA" & + "AAAAAAAAAAAAAAAAAAAAAAAAAA" & + "AAAAAAAAAAAAAAAAAAAAAAAAAA" & + "AAAAAAAAAAA#@%"); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3305A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3306a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,82 ---- + -- CE3306A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE VALUE OF 'TO' IS + -- NEGATIVE OR GREATER THAN COUNT'LAST WHEN COUNT'LAST IS LESS THAN + -- COUNT'BASE'LAST. + + -- HISTORY: + -- JET 08/17/88 CREATED ORIGINAL TEST. + -- PWN 10/27/95 REMOVED CONSTRAINT CHECK THAT NOW HAPPENS AT + -- COMPILE TIME. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + PROCEDURE CE3306A IS + + BEGIN + TEST ("CE3306A", "CHECK THAT CONSTRAINT_ERROR IS RAISED IF THE " & + "VALUE OF 'TO' IS NEGATIVE OR GREATER THAN " & + "COUNT'LAST WHEN COUNT'LAST IS LESS THAN " & + "COUNT'BASE'LAST"); + + BEGIN + SET_LINE_LENGTH(-1); + FAILED("NO EXCEPTION FOR SET_LINE_LENGTH(-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION FOR SET_LINE_LENGTH(-1)"); + END; + + BEGIN + SET_PAGE_LENGTH(COUNT(IDENT_INT(-1))); + FAILED("NO EXCEPTION FOR SET_PAGE_LENGTH(-1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION FOR SET_PAGE_LENGTH(-1)"); + END; + + IF COUNT'LAST < COUNT'BASE'LAST THEN + BEGIN + SET_LINE_LENGTH(COUNT'LAST + COUNT(IDENT_INT(1))); + FAILED("NO EXCEPTION FOR SET_LINE_LENGTH(COUNT'LAST+1)"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION FOR SET_LINE_LENGTH" & + "(COUNT'LAST+1)"); + END; + + ELSE + COMMENT("COUNT'LAST IS EQUAL TO COUNT'BASE'LAST"); + END IF; + + RESULT; + END CE3306A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3401a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + -- CE3401A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FORMAL PARAMETERS OF EACH COLUMN, LINE, AND + -- PAGE OPERATION ARE NAMED CORRECTLY. + + -- HISTORY: + -- JET 08/17/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + PROCEDURE CE3401A IS + + FIN, FOUT : FILE_TYPE; + B : BOOLEAN; + C : COUNT; + FILE_OK : BOOLEAN := FALSE; + + BEGIN + TEST ("CE3401A", "CHECK THAT THE FORMAL PARAMETERS OF EACH " & + "COLUMN, LINE, AND PAGE OPERATION ARE NAMED " & + "CORRECTLY"); + + BEGIN + CREATE(FOUT, OUT_FILE, LEGAL_FILE_NAME); + FILE_OK := TRUE; + EXCEPTION + WHEN OTHERS => + NOT_APPLICABLE("OUTPUT FILE COULD NOT BE CREATED"); + END; + + IF FILE_OK THEN + NEW_LINE(FILE => FOUT, SPACING => 1); + NEW_PAGE(FILE => FOUT); + SET_COL(FILE => FOUT, TO => 1); + SET_LINE(FILE => FOUT, TO => 1); + C := COL(FILE => FOUT); + C := LINE(FILE => FOUT); + C := PAGE(FILE => FOUT); + + NEW_PAGE(FOUT); + + BEGIN + CLOSE(FOUT); + EXCEPTION + WHEN OTHERS => + FAILED("OUTPUT FILE COULD NOT BE CLOSED"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + BEGIN + OPEN(FIN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN OTHERS => + FAILED("INPUT FILE COULD NOT BE OPENED"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + SKIP_LINE(FILE => FIN, SPACING => 1); + SKIP_PAGE(FILE => FIN); + B := END_OF_LINE(FILE => FIN); + B := END_OF_PAGE(FILE => FIN); + B := END_OF_FILE(FILE => FIN); + + BEGIN + DELETE(FIN); + EXCEPTION + WHEN USE_ERROR => + COMMENT("FILE COULD NOT BE DELETED"); + WHEN OTHERS => + FAILED("UNEXPECTED ERROR AT DELETION"); + END; + END IF; + + RESULT; + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED"); + END CE3401A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE3402A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_LINE RAISES MODE_ERROR WHEN THE FILE MODE + -- IS IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/19/87 ADDED ATTEMPT TO DELETE THE FILE AND REPLACED + -- RESET WITH CLOSE AND OPEN. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3402A IS + + INCOMPLETE : EXCEPTION; + FILE1 : FILE_TYPE; + SPAC : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1)); + + BEGIN + + TEST ("CE3402A" , "CHECK THAT NEW_LINE RAISES MODE_ERROR " & + "WHEN THE FILE MODE IS IN_FILE"); + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT_LINE (FILE1, "STUFF"); + CLOSE (FILE1); + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED FOR OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + NEW_LINE (FILE1,SPAC); + FAILED ("MODE_ERROR NOT RAISED FOR IN_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR IN_FILE"); + END; + + BEGIN + NEW_LINE (STANDARD_INPUT,SPAC); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR STANDARD_INPUT"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3402A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE3402C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_LINE INCREMENTS THE CURRENT PAGE BY ONE AND + -- SETS THE CURRENT LINE NUMBER TO ONE WHEN THE PAGE LENGTH IS + -- BOUNDED AND THE LINE NUMBER WOULD HAVE EXCEEDED THE + -- MAXIMUM PAGE LENGTH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 09/01/82 + -- SPS 11/30/82 + -- SPS 01/24/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/19/87 ADDED ORIGINAL_LINE_LENGTH AND + -- ORIGINAL_PAGE_LENGTH VARIABLES AND CLOSED FILE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3402C IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + ORIGINAL_LINE_LENGTH : COUNT := LINE_LENGTH; + ORIGINAL_PAGE_LENGTH : COUNT := PAGE_LENGTH; + + BEGIN + + TEST ("CE3402C" , "CHECK END_OF_PAGE BEHAVIOR OF NEW_LINE"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FILE,THREE); + SET_PAGE_LENGTH (FILE,TWO); + + FOR I IN 1..6 + LOOP + PUT (FILE,CHAR); + END LOOP; + + NEW_LINE (FILE); + + IF PAGE (FILE) /= TWO THEN + FAILED ("PAGE NOT INCREMENTED BY ONE"); + END IF; + + IF LINE (FILE) /= ONE THEN + FAILED ("LINE NOT SET TO ONE"); + END IF; + + NEW_LINE (FILE, 7); + IF PAGE (FILE) /= POSITIVE_COUNT(IDENT_INT (5)) THEN + FAILED ("MULTIPLE PAGES NOT CREATED BY NEW_LINE"); + END IF; + + SET_LINE_LENGTH (FILE, ORIGINAL_LINE_LENGTH); + SET_PAGE_LENGTH (FILE, ORIGINAL_PAGE_LENGTH); + CHECK_FILE (FILE, "CCC#CCC#@##@##@##@#@%"); + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3402C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + -- CE3402D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_LINE SETS THE CURRENT COLUMN NUMBER TO ONE, + -- AND NEW_LINE OUTPUTS LINE TERMINATORS WHEN THE SPACING IS + -- GREATER THAN ONE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATE WITH OUT_FILE MODE FOR TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/19/87 CHANGED FAILED MESSAGE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3402D IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + SPAC3 : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4)); + + BEGIN + + TEST ("CE3402D", "CHECK THAT NEW_LINE SETS THE CURRENT " & + "COLUMN NUMBER TO ONE, AND NEW_LINE OUTPUTS " & + "TERMINATORS WHEN THE SPACING IS " & + "GREATER THAN ONE"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..5 LOOP + PUT (FILE, 'X'); + END LOOP; + + NEW_LINE (FILE, SPAC3); + IF LINE (FILE) /= FOUR THEN + FAILED ("NEW_LINE DID NOT OUTPUT LINE TERMINATORS"); + END IF; + + IF COL (FILE) /= ONE THEN + FAILED ("COLUMN NOT SET TO ONE"); + END IF; + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3402D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3402e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CE3402E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_LINE RAISES CONSTRAINT_ERROR IF SPACING IS + -- ZERO, OR NEGATIVE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- JBG 08/30/83 + -- DWC 08/19/87 ADDED COUNT'LAST CASE. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3402E IS + + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3402E" , "CHECK THAT NEW_LINE RAISES CONSTRAINT_ERROR " & + "IF SPACING IS ZERO, OR NEGATIVE"); + + BEGIN + NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR ZERO"); + END; + + BEGIN + NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(-2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR NEGATIVE NUMBER"); + END; + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR ZERO"); + END; + + BEGIN + NEW_LINE (FILE,POSITIVE_COUNT(IDENT_INT(-2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR NEGATIVE NUMBER"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + RESULT; + + END CE3402E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- CE3403A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_LINE CAN ONLY BE APPLIED TO FILES OF MODE + -- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT CREATION OF TEMPORARY FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/04/87 REVISED EXCEPTION HANDLERS AND ADDED A CASE + -- FOR STANDARD_OUTPUT. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + SPAC : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1)); + + BEGIN + + TEST ("CE3403A" , "CHECK THAT SKIP_LINE CAN ONLY BE " & + "APPLIED TO FILES OF MODE IN_FILE"); + + BEGIN + CREATE (FILE, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE OF " & + "TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + SKIP_LINE (FILE,SPAC); + FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OUT_FILE"); + END; + + BEGIN + SKIP_LINE (CURRENT_OUTPUT,SPAC); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "CURRENT_OUTPUT"); + END; + + BEGIN + SKIP_LINE (STANDARD_OUTPUT,SPAC); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "STANDARD_OUTPUT"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3403A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CE3403B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SPACING PARAMETER OF SKIP_LINE IS OPTIONAL, + -- AND THAT THE DEFAULT VALUE IS ONE. + -- CHECK THAT THE FILE PARAMETER IS ALSO OPTIONAL, AND THAT THE + -- FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 12/14/82 + -- JBG 1/17/83 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/04/87 REVISED EXCEPTION HANDLERS, REMOVED + -- DEPENDENCIES ON RESET, AND ADDED AN ATTEMPT + -- TO DELETE FILE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403B IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + SPAC, TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2)); + A : INTEGER := CHARACTER'POS('A'); + CH : CHARACTER; + + BEGIN + + TEST ("CE3403B" , "CHECK DEFAULT SPACING AND FILE " & + "OF SKIP_LINE"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1 .. 3 LOOP -- CREATES "BBB#CC#D##F#@%" + FOR J IN 1 .. 4-I LOOP + PUT (FILE, CHARACTER'VAL(A + I)); + END LOOP; + NEW_LINE (FILE); + END LOOP; + NEW_LINE (FILE); + PUT (FILE, 'F'); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FILE, CH); + IF CH /= CHARACTER'VAL (A + 1) THEN + FAILED ("LINE CONTENT WRONG - 1"); + END IF; + + SKIP_LINE (FILE); + + IF LINE (FILE) /= TWO THEN + FAILED ("SPACING DEFAULT NOT ONE"); + END IF; + + GET (FILE, CH); + IF CH /= CHARACTER'VAL (A + 2) THEN + FAILED ("LINE CONTENT WRONG - 2"); + END IF; + + SET_INPUT (FILE); + SKIP_LINE (FILE); + + IF LINE (FILE) /= 3 THEN + FAILED ("SKIP_LINE DOES NOT OPERATE CORRECTLY ON " & + "DEFAULT FILE"); + END IF; + + GET (FILE, CH); + IF CH /= CHARACTER'VAL (A + 3) THEN + FAILED ("LINE CONTENT WRONG - 3"); + END IF; + + SKIP_LINE; + + IF LINE (FILE) /= 4 THEN + FAILED ("LINE COUNT NOT 4; WAS " & COUNT'IMAGE(LINE(FILE))); + END IF; + + GET (FILE, CH); + IF CH /= 'F' THEN + FAILED ("NOT RIGHT LINE"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3403B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CE3403C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_LINE SETS THE CURRENT COLUMN NUMBER TO ONE, + -- AND THAT IT IS PERFORMED SPACING TIMES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/08/87 REVISED EXCEPTION HANDLING, REMOVED + -- DEPENDENCE ON RESET, AND ADDED NEW CASES. + -- GJD 11/15/95 FIXED ADA 95 INCOMPATIBLE USE OF CHARACTER LITERALS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403C IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + SPAC3 : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4)); + CH: CHARACTER; + + BEGIN + + TEST ("CE3403C" , "CHECK THAT SKIP_LINE SETS THE CURRENT " & + "COLUMN NUMBER TO ONE, AND THAT IT IS " & + "PERFORMED SPACING TIMES"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN CHARACTER RANGE 'A' .. 'E' LOOP + FOR J IN 1 .. 3 LOOP + PUT (FILE, I); + END LOOP; + NEW_LINE (FILE); + END LOOP; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF COL (FILE) /= ONE THEN + FAILED ("COLUMN NOT SET TO ONE"); + END IF; + + GET (FILE, CH); + + IF CH /= 'A' THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + SKIP_LINE (FILE,SPAC3); + GET (FILE, CH); + + IF CH /= 'D' THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + IF LINE (FILE) /= FOUR THEN + FAILED ("NOT PERFORMED SPACING TIMES"); + END IF; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3403C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + -- CE3403D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_LINE RAISES CONSTRAINT_ERROR IF SPACING IS + -- ZERO OR NEGATIVE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- SPS 11/11/82 + -- DWC 09/09/87 ADDED CASE FOR COUNT'LAST. + -- KAS 11/27/95 REMOVED CASES FOR COUNT'LAST + -- TMB 11/19/96 FIXED OBJECTIVE + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403D IS + + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3403D" , "CHECK THAT SKIP_LINE RAISES " & + "CONSTRAINT_ERROR IF SPACING IS ZERO, " & + "OR NEGATIVE" ); + BEGIN + SKIP_LINE (FILE, POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO"); + END; + + BEGIN + SKIP_LINE (FILE, POSITIVE_COUNT(IDENT_INT(-2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "NEGATIVE NUMBER"); + END; + + + BEGIN + SKIP_LINE (POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO " & + "- DEFAULT"); + END; + + BEGIN + SKIP_LINE (POSITIVE_COUNT(IDENT_INT(-6))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUM " & + "- DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED NEGATIVE NUM " & + "- DEFAULT"); + END; + + + RESULT; + + END CE3403D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- CE3403E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_LINE INCREMENTS THE CURRENT LINE NUMBER BY ONE + -- AND SETS THE CURRENT COLUMN NUMBER TO ONE IF THE LINE TERMINATOR + -- IS NOT FOLLOWED BY A PAGE TERMINATOR, AND THAT IT SETS BOTH THE + -- LINE AND COLUMN NUMBERS TO ONE AND INCREMENTS THE CURRENT PAGE + -- NUMBER BY ONE IF THE LINE TERMINATOR IS FOLLOWED BY A PAGE + -- TERMINATOR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 REVISED TEST TO USE A FILE NAME, REMOVED + -- DEPENDENCE ON RESET, AND ATTEMPTED TO + -- DELETE THE FILE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403E IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + CHAR : CHARACTER := ('C'); + + BEGIN + + TEST ("CE3403E" , "CHECK THAT SKIP_LINE SETS COLUMN, " & + "LINE, AND PAGE NUMBERS CORRECTLY"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, CHAR); + NEW_LINE (FILE); + PUT (FILE, CHAR); + NEW_PAGE (FILE); + PUT (FILE, CHAR); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF (LINE (FILE) /= ONE) OR (PAGE (FILE) /= ONE) THEN + FAILED ("INCORRECT LINE AND PAGE NUMBERS"); + ELSE + + -- LINE TERMINATOR NOT FOLLOWED BY PAGE TERMINATOR + + GET (FILE, CHAR); + + IF CHAR /= 'C' THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + SKIP_LINE (FILE); + IF LINE (FILE) /= TWO THEN + FAILED ("FIRST SUBTEST - LINE NOT INCREMENTED"); + END IF; + IF COL (FILE) /= ONE THEN + FAILED ("FIRST SUBTEST - COLUMN NOT SET TO ONE"); + END IF; + + -- LINE TERMINATOR FOLLOWED BY PAGE TERMINATOR + + GET (FILE, CHAR); + + IF CHAR /= 'C' THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + SKIP_LINE (FILE); + IF LINE (FILE) /= ONE THEN + FAILED ("SECOND SUBTEST - LINE NOT SET TO ONE"); + END IF; + IF COL (FILE) /= ONE THEN + FAILED ("SECOND SUBTEST - COLUMN NOT SET TO ONE"); + END IF; + IF PAGE (FILE) /= TWO THEN + FAILED ("SECOND SUBTEST - PAGE NOT INCREMENTED"); + END IF; + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3403E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3403f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,156 ---- + -- CE3403F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_LINE RAISES END_ERROR IF AN ATTEMPT IS + -- MADE TO SKIP A FILE TERMINATOR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 11/11/82 + -- SPS 12/14/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 REVISED TEST TO USE A FILE NAME, REMOVED + -- DEPENDENCE ON RESET, AND ADDED ATTEMPT TO + -- DELETE THE FILE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3403F IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT (1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT (2)); + + BEGIN + TEST ("CE3403F" , "CHECK THAT SKIP_LINE RAISES END_ERROR " & + "IF AN ATTEMPT IS MADE TO SKIP A FILE " & + "TERMINATOR"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..3 + LOOP + PUT (FILE,CHAR); + END LOOP; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FILE, CHAR); + IF CHAR /= 'C' THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + SKIP_LINE (FILE); + SKIP_LINE (FILE); + FAILED ("END_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN END_ERROR => + + IF COL (FILE) /= ONE THEN + FAILED ("COL NOT RESET CORRECTLY"); + END IF; + + IF NOT END_OF_FILE (FILE) THEN + FAILED ("NOT POSITIONED AT END OF FILE"); + END IF; + + IF PAGE (FILE) /= TWO THEN + FAILED ("PAGE NOT INCREMENTED"); + END IF; + + IF LINE (FILE) /= ONE THEN + FAILED ("LINE NOT RESET CORRECTLY"); + END IF; + + IF NOT END_OF_LINE (FILE) THEN + FAILED ("EOL FALSE AT FILE TERMINATOR"); + END IF; + + IF NOT END_OF_PAGE (FILE) THEN + FAILED ("EOP FALSE AT FILE TERMINATOR"); + END IF; + + BEGIN + SKIP_LINE (FILE); + FAILED ("END_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + END; + + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3403F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + -- CE3404A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_LINE RAISES MODE_ERROR WHEN APPLIED TO + -- AN OUT_FILE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/17/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 29/28/87 COMPLETELY REVISED. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3404A IS + + MY_FILE : FILE_TYPE; + BOOL : BOOLEAN; + + BEGIN + + TEST ("CE3404A", "CHECK THAT END_OF_LINE RAISES MODE_ERROR " & + "WHEN APPLIED TO AN OUT_FILE"); + + BEGIN + BOOL := END_OF_FILE (CURRENT_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT - 1"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "CURRENT_OUTPUT - 2"); + END; + + BEGIN + BOOL := END_OF_FILE (STANDARD_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "STANDARD_OUTPUT - 4"); + END; + + BEGIN + CREATE (MY_FILE); + BEGIN + BOOL := END_OF_FILE (MY_FILE); + FAILED ("MODE_ERROR NOT RAISED FOR MY_FILE - 5"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "MY_FILE - 6"); + + END; + + CLOSE (MY_FILE); + + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + END CE3404A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CE3404B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_LINE OPERATES ON THE CURRENT DEFAULT INPUT FILE + -- IF NO FILE IS SPECIFIED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/17/82 + -- SPS 11/11/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 09/22/87 CREATED A NON-TEMP FILE, REMOVED DEPENDENCE ON + -- RESET, AND CHECKED THE VALUE OF THE CHAR READ. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3404B IS + + INCOMPLETE : EXCEPTION; + MY_FILE : FILE_TYPE; + LOOP_COUNT : INTEGER := 0; + BOOL : BOOLEAN; + CHAR : CHARACTER := ('C'); + + BEGIN + + TEST ("CE3404B", "CHECK THAT END_OF_LINE OPERATES ON THE " & + "CURRENT DEFAULT INPUT FILE IF NO FILE " & + "IS SPECIFIED"); + + -- CREATE AND INITIALIZE THE FILE + + BEGIN + CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE - 3"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..3 LOOP + PUT (MY_FILE,CHAR); + END LOOP; + NEW_LINE (MY_FILE); + PUT (MY_FILE,CHAR); + + CLOSE (MY_FILE); + + BEGIN + OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE ERROR RAISED ON ATTEMPT TO " & + "RE-OPEN WITH MODE OF IN_FILE - 4"); + RAISE INCOMPLETE; + END; + + SET_INPUT (MY_FILE); + + -- START THE TEST + + LOOP + GET (CHAR); + IF CHAR /= 'C' THEN + FAILED ("CHAR READ FROM FILE HAS WRONG VALUE - 5"); + RAISE INCOMPLETE; + END IF; + EXIT WHEN END_OF_LINE; + LOOP_COUNT := LOOP_COUNT + 1; + IF LOOP_COUNT > IDENT_INT (3) THEN + FAILED ("END_OF_LINE ON DEFAULT INCORRECT - 6"); + EXIT; + END IF; + END LOOP; + + GET (CHAR); + IF CHAR /= 'C' THEN + FAILED ("FINAL CHAR READ FROM FILE HAS WRONG VALUE - 7"); + END IF; + + BEGIN + DELETE (MY_FILE); + EXCEPTION + WHEN OTHERS => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3404B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,165 ---- + -- CE3404C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_LINE RETURNS THE CORRECT VALUE WHEN POSITIONED + -- AT THE BEGINNING AND THE END OF A LINE, AND WHEN POSITIONED JUST + -- BEFORE THE FILE TERMINATOR. + + -- CASE 1) BOUNDED LINE LENGTH + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/17/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- GMT 09/22/87 REMOVED DEPENDENCE ON RESET AND MOVED THE CHECK + -- FOR UNBOUNDED LINE_LENGTH TO CE3404D.ADA. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3404C IS + INCOMPLETE : EXCEPTION; + MY_FILE : FILE_TYPE; + ITEM_CHAR : CHARACTER; + CHAR : CHARACTER := ('C'); + TEN : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(10)); + BLANK_COUNTER : NATURAL := 0; + + BEGIN + + TEST ("CE3404C", "CHECK THAT END_OF_LINE RETURNS THE CORRECT " & + "VALUE WHEN POSITIONED AT THE BEGINNING " & + "AND THE END OF A LINE, AND WHEN POSITIONED " & + "JUST BEFORE THE FILE TERMINATOR"); + + -- CREATE AND INITIALIZE TEST FILE WITH BOUNDED LINE LENGTH + + BEGIN + CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (MY_FILE,TEN); + + FOR I IN 1..5 LOOP + PUT (MY_FILE, CHAR); + END LOOP; + NEW_LINE (MY_FILE); + PUT (MY_FILE, 'B'); + + CLOSE (MY_FILE); + + BEGIN + OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- BEGIN THE TEST + + IF END_OF_LINE (MY_FILE) THEN + FAILED ("END_OF_LINE: INCORRECT VALUE AT FIRST POSITION - 5"); + END IF; + + IF COL (MY_FILE) /= 1 THEN + FAILED ("EOL MODIFIED COL NUMBER - 6"); + END IF; + + FOR I IN 1..4 LOOP + GET (MY_FILE,ITEM_CHAR); + END LOOP; + + IF END_OF_LINE (MY_FILE) THEN + FAILED ("END_OF_LINE: INCORRECT VALUE AT FIFTH POSITION - 7"); + END IF; + + GET (MY_FILE,ITEM_CHAR); + + WHILE NOT END_OF_LINE (MY_FILE) LOOP + GET (MY_FILE, ITEM_CHAR); + IF ITEM_CHAR = ' ' THEN + BLANK_COUNTER := BLANK_COUNTER + 1; + ELSE + FAILED ("STRING WAS PADDED WITH SOMETHING OTHER THAN " & + "BLANKS - 8"); + END IF; + END LOOP; + + IF BLANK_COUNTER > 5 THEN + FAILED ("TOO MANY BLANKS WERE USED FOR PADDING - 9"); + END IF; + + IF LINE (MY_FILE) /= 1 THEN + FAILED ("EOL SKIPPED LINE TERMINATOR - 10"); + END IF; + + IF NOT END_OF_LINE (MY_FILE) THEN + FAILED ("EOL SKIPPED LINE TERMINATOR - 11"); + END IF; + + SKIP_PAGE (MY_FILE); + + IF PAGE (MY_FILE) /= 2 THEN + FAILED ("INCORRECT PAGE NUMBER"); + END IF; + + IF NOT END_OF_LINE (MY_FILE) THEN + FAILED ("INCORRECT VALUE WHEN POSITIONED JUST BEFORE FILE " & + "TERMINATOR"); + END IF; + + BEGIN + DELETE (MY_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3404C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3404d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CE3404D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_LINE RETURNS THE CORRECT VALUE WHEN POSITIONED + -- AT THE BEGINNING AND THE END OF A LINE, AND WHEN POSITIONED JUST + -- BEFORE THE FILE TERMINATOR. + + -- CASE 2) UNBOUNDED LINE LENGTH + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- GMT 09/22/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3404D IS + INCOMPLETE : EXCEPTION; + MY_FILE : FILE_TYPE; + ITEM_CHAR : CHARACTER; + CHAR : CHARACTER := ('C'); + TEN : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(10)); + BLANK_COUNTER : NATURAL := 0; + + BEGIN + + TEST ("CE3404D", "CHECK THAT END_OF_LINE RETURNS THE CORRECT " & + "VALUE WHEN POSITIONED AT THE BEGINNING AND " & + "THE END OF A LINE, AND WHEN POSITIONED JUST " & + "BEFORE THE FILE TERMINATOR"); + + -- CREATE AND INITIALIZE TEST FILE WITH BOUNDED LINE LENGTH + + BEGIN + CREATE (MY_FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..5 LOOP + PUT (MY_FILE, CHAR); + END LOOP; + NEW_LINE (MY_FILE); + PUT (MY_FILE, 'B'); + + CLOSE (MY_FILE); + + BEGIN + OPEN (MY_FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- BEGIN THE TEST + + IF END_OF_LINE (MY_FILE) THEN + FAILED ("END_OF_LINE: INCORRECT VALUE AT FIRST POSITION - 5"); + END IF; + + IF COL (MY_FILE) /= 1 THEN + FAILED ("EOL MODIFIED COL NUMBER - 6"); + END IF; + + FOR I IN 1..4 LOOP + GET (MY_FILE,ITEM_CHAR); + END LOOP; + + IF END_OF_LINE (MY_FILE) THEN + FAILED ("END_OF_LINE: INCORRECT VALUE AT FIFTH POSITION - 7"); + END IF; + + GET (MY_FILE,ITEM_CHAR); + + WHILE NOT END_OF_LINE (MY_FILE) LOOP + GET (MY_FILE, ITEM_CHAR); + IF ITEM_CHAR = ' ' THEN + FAILED ("STRING WAS PADDED WITH SOMETHING OTHER THAN " & + "BLANKS - 8"); + END IF; + END LOOP; + + IF LINE (MY_FILE) /= 1 THEN + FAILED ("EOL SKIPPED LINE TERMINATOR - 10"); + END IF; + + IF NOT END_OF_LINE (MY_FILE) THEN + FAILED ("EOL SKIPPED LINE TERMINATOR - 11"); + END IF; + + SKIP_PAGE (MY_FILE); + + IF PAGE (MY_FILE) /= 2 THEN + FAILED ("INCORRECT PAGE NUMBER"); + END IF; + + IF NOT END_OF_LINE (MY_FILE) THEN + FAILED ("INCORRECT VALUE WHEN POSITIONED JUST BEFORE " & + "TERMINATOR"); + END IF; + + BEGIN + DELETE (MY_FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3404D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- CE3405A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_PAGE OUTPUTS A LINE TERMINATOR FOLLOWED BY A PAGE + -- TERMINATOR IF THE CURRENT LINE IS NOT AT COLUMN 1 OR IF THE + -- CURRENT PAGE IS AT LINE 1; IF THE CURRENT LINE IS AT COLUMN 1, + -- OUTPUTS A PAGE TERMINATOR ONLY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 09/02/82 + -- JBG 01/18/83 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/23/87 ADDED A CASE WHICH CALLS NEW_LINE AND NEW_PAGE + -- CONSECUTIVELY AND SEPARATED CASES INTO DIFFERENT + -- IF STATEMENTS. ADDED CHECK FOR USE_ERROR ON + -- DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3405A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(4)); + CHAR : CHARACTER := ('C'); + + BEGIN + + TEST ("CE3405A", "CHECK THAT NEW_PAGE OUTPUTS A LINE TERMINATOR " & + "FOLLOWED BY A PAGE TERMINATOR IF THE CURRENT " & + "LINE IS NOT AT COLUMN 1 OR IF THE CURRENT " & + "PAGE IS AT LINE 1; IF THE CURRENT LINE IS AT " & + "COLUMN 1, OUTPUTS A PAGE TERMINATOR ONLY"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + NEW_PAGE (FILE); + NEW_PAGE (FILE); -- CURRENT PAGE TERMINATED + IF PAGE (FILE) /= THREE THEN + FAILED ("INITIAL PAGE COUNT INCORRECT"); + END IF; + + SET_LINE_LENGTH (FILE,THREE); + PUT (FILE,CHAR); + NEW_LINE (FILE); + + IF LINE (FILE) /= TWO THEN + FAILED ("INCORRECT LINE NUMBER - 1"); + END IF; + + IF PAGE (FILE) /= THREE THEN + FAILED ("INCORRECT PAGE NUMBER - 2"); + END IF; + + NEW_PAGE (FILE); -- CURRENT LINE TERMINATED (B) + IF LINE (FILE) /= ONE THEN + FAILED ("LINE NUMBER NOT INCREMENTED"); + END IF; + IF PAGE (FILE) /= FOUR THEN + FAILED ("PAGE NUMBER NOT INCREMENTED"); + END IF; + PUT (FILE, IDENT_CHAR('E')); -- CURRENT LINE NOT TERM (C) + NEW_PAGE (FILE); + NEW_LINE (FILE); + NEW_PAGE (FILE); + + CHECK_FILE (FILE, "#@#@C#@E#@#@%"); + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3405A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,126 ---- + -- CE3405C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_PAGE RAISES MODE_ERROR IF THE FILE SPECIFIED + -- HAS MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/23/87 CREATED AN EXTERNAL FILE, REMOVED DEPENDENCE ON + -- RESET, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3405C IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3405C", "CHECK THAT NEW_PAGE RAISES MODE_ERROR IF THE " & + "FILE SPECIFIED HAS MODE IN_FILE"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "STUFF"); + + CLOSE (FILE); + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + NEW_PAGE (FILE); + FAILED ("MODE_ERROR NOT RAISED FOR IN_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR IN_FILE"); + END; + + BEGIN + NEW_PAGE (STANDARD_INPUT); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_INPUT"); + END; + + BEGIN + NEW_PAGE (CURRENT_INPUT); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_INPUT"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3405C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3405d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + -- CE3405D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_PAGE INCREMENTS THE CURRENT PAGE NUMBER AND + -- SETS THE CURRENT COLUMN AND LINE NUMBERS TO ONE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 08/28/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/23/87 CORRECTED EXCEPTION HANDLING AND ADDED CASES FOR + -- CONSECUTIVE NEW_LINE AND NEW_PAGE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3405D IS + INCOMPLETE : EXCEPTION; + BEGIN + + TEST ("CE3405D", "CHECK THAT NEW_PAGE INCREMENTS PAGE COUNT " & + "AND SETS COLUMN AND LINE TO ONE"); + + DECLARE + FT : FILE_TYPE; + CH : CHARACTER; + PG_NUM : POSITIVE_COUNT; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILE WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "STRING"); + NEW_LINE (FT); + PUT (FT, 'X'); + PG_NUM := PAGE (FT); + + NEW_PAGE (FT); + + IF COL(FT) /= 1 THEN + FAILED ("COLUMN NUMBER NOT RESET - OUTPUT - 1"); + END IF; + IF LINE (FT) /= 1 THEN + FAILED ("LINE NUMBER NOT RESET - OUTPUT - 1"); + END IF; + IF PAGE (FT) /= PG_NUM + 1 THEN + FAILED ("PAGE NUMBER NOT INCREMENTED - OUTPUT - 1"); + END IF; + + PUT (FT, "MORE STUFF"); + NEW_LINE (FT); + NEW_PAGE (FT); + + IF COL(FT) /= 1 THEN + FAILED ("COLUMN NUMBER NOT RESET - OUTPUT - 2"); + END IF; + IF LINE (FT) /= 1 THEN + FAILED ("LINE NUMBER NOT RESET - OUTPUT - 2"); + END IF; + IF PAGE (FT) /= PG_NUM + 2 THEN + FAILED ("PAGE NUMBER NOT INCREMENTED - OUTPUT - 2"); + END IF; + + CHECK_FILE (FT, "STRING#X#@MORE STUFF#@%"); + + CLOSE (FT); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3405D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- CE3406A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_PAGE READS AND DISCARDS CHARACTERS AND LINE + -- TERMINATORS UNTIL A PAGE TERMINATOR IS READ, ADDS ONE TO THE + -- CURRENT PAGE NUMBER, AND SETS THE CURRENT COLUMN NUMBER AND LINE + -- NUMBER TO ONE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/17/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE + -- ON RESET, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3406A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + CHAR_X : CHARACTER := ('X'); + ITEM_CHAR : CHARACTER; + ONE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + + BEGIN + + TEST ("CE3406A", "CHECK THAT SKIP_LINE READS AND " & + "SETS PAGE AND COLUMN CORRECTLY"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "CDE"); + NEW_LINE (FILE); + PUT (FILE, "FGHI"); + NEW_LINE (FILE); + PUT (FILE, "JK"); + NEW_PAGE (FILE); + NEW_PAGE (FILE); + PUT (FILE,CHAR_X); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF (LINE (FILE) /= ONE) THEN + FAILED ("LINE NUMBER NOT EQUAL TO ONE"); + END IF; + + IF (PAGE (FILE) /= ONE) THEN + FAILED ("PAGE NUMBER NOT EQUAL TO ONE"); + END IF; + + GET (FILE, ITEM_CHAR); + + IF ITEM_CHAR /= 'C' THEN + FAILED ("INCORRECT VALUE READ FROM FILE - 1"); + END IF; + + SKIP_PAGE (FILE); + + IF COL (FILE) /= ONE THEN + FAILED ("COLUMN NOT SET TO ONE - 1"); + END IF; + + IF LINE (FILE) /= ONE THEN + FAILED ("LINE NOT SET TO ONE - 1"); + END IF; + + IF PAGE (FILE) /= TWO THEN + FAILED ("PAGE NOT SET TO TWO"); + END IF; + + SKIP_PAGE (FILE); + + IF COL (FILE) /= ONE THEN + FAILED ("COLUMN NOT SET TO ONE - 2"); + END IF; + + IF LINE (FILE) /= ONE THEN + FAILED ("LINE NOT SET TO ONE - 2"); + END IF; + + IF PAGE (FILE) /= THREE THEN + FAILED ("PAGE NOT SET TO THREE"); + END IF; + + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'X' THEN + FAILED ("INCORRECT VALUE READ FROM FILE - 2"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3406A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- CE3406B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_PAGE CAN ONLY BE APPLIED TO FILES OF MODE + -- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILE CREATE WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/24/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3406B IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3406B", "CHECK THAT SKIP_PAGE CAN ONLY BE " & + "APPLIED TO FILES OF MODE IN_FILE"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + SKIP_PAGE (FILE); + FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR OUT_FILE"); + END; + + BEGIN + SKIP_PAGE (STANDARD_OUTPUT); + FAILED ("MODE_ERROR RAISED FOR STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_OUTPUT"); + END; + + BEGIN + SKIP_PAGE (CURRENT_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_OUTPUT"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3406B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,148 ---- + -- CE3406C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_PAGE RAISES END_ERROR WHEN THE FILE IS POSITIONED + -- BEFORE THE FILE TERMINATOR BUT NOT WHEN THE FILE IS POSITIONED + -- BEFORE THE FINAL PAGE TERMINATOR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/17/82 + -- JBG 01/24/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE + -- ON RESET, AND CHECKED CHARACTER READ IN. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3406C IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + + BEGIN + + TEST ("CE3406C", "CHECK THAT SKIP_PAGE RAISES END_ERROR WHEN " & + "THE FILE IS POSITIONED BEFORE THE FILE " & + "TERMINATOR BUT NOT WHEN THE FILE IS " & + "POSITIONED BEFORE THE FINAL PAGE TERMINATOR"); + + -- CREATE AND INITIALIZE FILE + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..2 LOOP + FOR I IN 1..3 LOOP + PUT (FILE,CHAR); + END LOOP; + NEW_LINE (FILE); + END LOOP; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- START TEST + + -- TEST SKIP_PAGE BEFORE FINAL PAGE TERMINATOR + + WHILE NOT END_OF_PAGE (FILE) LOOP + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'C' THEN + FAILED ("INCORRECT VALUE READ FROM FILE"); + END IF; + END LOOP; + + BEGIN + SKIP_PAGE (FILE); + EXCEPTION + WHEN END_ERROR => + FAILED ("RAISED END_ERROR BEFORE FINAL PAGE " & + "TERMINATOR - 1"); + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + IF PAGE (FILE) /= TWO THEN + FAILED ("PAGE NOT SET TO TWO"); + END IF; + + -- TEST SKIP_PAGE BEFORE FILE TERMINATOR + BEGIN + SKIP_PAGE (FILE); + FAILED ("END_ERROR NOT RAISED"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3406C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3406d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CE3406D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SKIP_PAGE OPERATES ON THE CURRENT DEFAULT INPUT + -- FILE WHEN NO FILE IS SPECIFIED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- JBG 01/26/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/24/87 CREATED NON-TEMPORARY FILE, REMOVED DEPENDENCE + -- ON RESET, AND CHECKED CHARACTER READ IN. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3406D IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ITEM_CHAR : CHARACTER; + TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + + BEGIN + + TEST ("CE3406D", "CHECK THAT SKIP_PAGE OPERATES ON THE CURRENT " & + "DEFAULT INPUT FILE WHEN NO FILE IS SPECIFIED"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "ABC"); + NEW_PAGE (FILE); + PUT (FILE, "DEF"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE); + + SKIP_PAGE; + + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'D' THEN + FAILED ("INCORRECT VALUE READ FROM FILE"); + END IF; + + IF PAGE (CURRENT_INPUT) /= TWO THEN + FAILED ("SKIP_PAGE NOT APPLIED TO CURRENT_INPUT"); + END IF; + + SKIP_PAGE (FILE); + + IF PAGE (CURRENT_INPUT) /= THREE THEN + FAILED ("SKIP_PAGE NOT APPLIED TO CURRENT_INPUT"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3406D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- CE3407A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_PAGE RETURNS THE CORRECT VALUE WHEN POSITIONED + -- AT THE BEGINNING AND AT THE END OF THE PAGE, AND BEFORE A FILE + -- TERMINATOR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/22/82 + -- JBG 01/26/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/28/87 REMOVED UNNECESSARY CODE, REMOVED DEPENDENCE + -- ON RESET AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3407A IS + + INCOMPLETE : EXCEPTION; + FILE1 : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3407A", "CHECK THAT END_OF_PAGE RETURNS " & + "THE CORRECT VALUE"); + + -- CREATE & INITIALIZE OUTPUT FILE + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..6 LOOP + PUT (FILE1, CHAR); + END LOOP; + + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION - 1"); + END IF; + + IF END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION - 2"); + END IF; + + -- TEST WHEN POSITIONED BEFORE LAST CHARACTER IN FILE + + FOR I IN 1..5 LOOP + GET (FILE1, ITEM_CHAR); + END LOOP; + + IF END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER"); + END IF; + + -- TEST WHEN AT END OF FILE + + GET (FILE1, ITEM_CHAR); + IF NOT END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE AT LAST POSITION"); + END IF; + + SKIP_PAGE (FILE1); + + IF NOT END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 1"); + END IF; + + IF NOT END_OF_PAGE (FILE1) THEN + FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 2"); + END IF; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3407A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- CE3407B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_PAGE CAN ONLY BE APPLIED TO FILES OF MODE + -- IN_FILE, THAT MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/22/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/28/87 CORRECTED EXCEPTION HANDLING AND ADDED CASE + -- FOR CURRENT_OUTPUT. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3407B IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + BOOL : BOOLEAN; + + BEGIN + + TEST ("CE3407B", "CHECK THAT END_OF_PAGE RAISES MODE_ERROR " & + "FOR FILES OF MODE OUT_FILE"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " & + "TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + BOOL := END_OF_PAGE (FILE); + FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR OUT_FILE"); + END; + + BEGIN + BOOL := END_OF_PAGE (STANDARD_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR STANDARD_OUTPUT"); + END; + + BEGIN + BOOL := END_OF_PAGE (CURRENT_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED FOR CURRENT_OUTPUT"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3407B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3407c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CE3407C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE PARAMETER OF END_OF_PAGE IS OPTIONAL, AND + -- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT + -- FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/28/87 REMOVED DEPENDENCE ON RESET, ADDED MORE CASES FOR + -- END_OF_PAGE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3407C IS + + INCOMPLETE : EXCEPTION; + FILE_IN : FILE_TYPE; + CHAR : CHARACTER := 'C'; + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3407C", "CHECK THAT THE FILE PARAMETER OF END_OF_PAGE " & + "IS OPTIONAL, AND THAT THE FUNCTION IS THEN " & + "APPLIED TO THE CURRENT DEFAULT INPUT FILE"); + + BEGIN + CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..3 LOOP + PUT (FILE_IN, CHAR); + END LOOP; + NEW_PAGE (FILE_IN); + PUT (FILE_IN, 'D'); + + CLOSE (FILE_IN); + + BEGIN + OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE_IN); + + IF END_OF_PAGE THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION"); + END IF; + + IF END_OF_PAGE /= END_OF_PAGE (FILE_IN) THEN + FAILED ("END OF PAGE DOES NOT OPERATE WITH DEFAULT FILE"); + END IF; + + GET (ITEM_CHAR); + GET (ITEM_CHAR); + GET (ITEM_CHAR); + + IF END_OF_PAGE /= TRUE THEN + FAILED ("INCORRECT VALUE BEFORE PAGE TERMINATOR"); + END IF; + + IF END_OF_PAGE /= END_OF_PAGE (FILE_IN) THEN + FAILED ("END_OF_PAGE WITHOUT PARAMETER DOES " & + "NOT OPERATE ON THE DEFAULT INPUT FILE"); + END IF; + + GET (ITEM_CHAR); + + IF NOT (END_OF_PAGE) THEN + FAILED ("INCORRECT VALUE AT LAST POSITION"); + END IF; + + BEGIN + DELETE (FILE_IN); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3407C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- CE3408A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_FILE RETURNS TRUE ONLY IF POSITIONED BEFORE THE + -- FINAL PAGE TERMINATOR OR BEFORE THE FILE TERMINATOR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- JBG 01/26/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3408A IS + + INCOMPLETE : EXCEPTION; + COUNT : INTEGER := 0; + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3408A", "CHECK THAT END_OF_FILE RETURNS " & + "THE CORRECT VALUE"); + + -- CREATE & INITIALIZE OUTPUT FILE. + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..6 LOOP + PUT (FILE, CHAR); + END LOOP; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- TEST WHEN POSITIONED TO BEGINNING OF FILE. + + IF END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION - 1"); + END IF; + + IF END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION - 2"); + END IF; + + -- TEST WHEN POSITIONED BEFORE LAST CHARACTER IN FILE. + + FOR I IN 1..5 LOOP + GET (FILE, ITEM_CHAR); + END LOOP; + + IF END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER"); + END IF; + + -- TEST WHEN AT END OF FILE. + + GET (FILE, ITEM_CHAR); + IF NOT END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE AT LAST POSITION"); + END IF; + + SKIP_PAGE (FILE); + + IF NOT END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 1"); + END IF; + + IF NOT END_OF_FILE (FILE) THEN + FAILED ("INCORRECT VALUE BEFORE FILE TERMINATOR - 2"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3408A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- CE3408B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_OF_FILE CAN ONLY BE APPLIED TO FILES OF MODE + -- IN_FILE, MODE_ERROR IS RAISED FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3408B IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + BOOL : BOOLEAN; + + BEGIN + + TEST ("CE3408B", "CHECK THAT END_OF_FILE CAN ONLY BE " & + "APPLIED TO FILES OF MODE IN_FILE"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " & + "TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + BOOL := END_OF_FILE (FILE); + FAILED ("MODE_ERROR NOT RAISED FOR OUT_FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR OUT_FILE"); + END; + + BEGIN + BOOL := END_OF_FILE (STANDARD_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "STANDARD_OUTPUT"); + END; + + BEGIN + BOOL := END_OF_FILE (CURRENT_OUTPUT); + FAILED ("MODE_ERROR NOT RAISED FOR CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR " & + "CURRENT_OUTPUT"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3408B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3408c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- CE3408C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE PARAMETER OF END_OF_FILE IS OPTIONAL, AND + -- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT INPUT + -- FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3408C IS + + INCOMPLETE : EXCEPTION; + FILE_IN : FILE_TYPE; + CHAR : CHARACTER := 'A'; + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3408C", "CHECK THAT THE FILE PARAMETER OF END_OF_FILE " & + "IS OPTIONAL, AND THAT THE FUNCTION IS THEN " & + "APPLIED TO THE CURRENT DEFAULT INPUT FILE"); + + + -- CREATE TEST FILE + + BEGIN + CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1..3 LOOP + PUT (FILE_IN, CHAR); + END LOOP; + NEW_PAGE (FILE_IN); + + PUT (FILE_IN, CHAR); + + CLOSE (FILE_IN); + + BEGIN + OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE_IN); + IF END_OF_FILE THEN + FAILED ("INCORRECT VALUE AT FIRST POSITION"); + END IF; + + IF END_OF_FILE /= END_OF_FILE (FILE_IN) THEN + FAILED ("END OF FILE DOES NOT OPERATE WITH DEFAULT FILE"); + END IF; + + WHILE NOT END_OF_PAGE (FILE_IN) + LOOP + GET (ITEM_CHAR); + END LOOP; + + IF END_OF_FILE THEN + FAILED ("INCORRECT VALUE BEFORE LAST CHARACTER"); + END IF; + + IF END_OF_FILE /= END_OF_FILE (FILE_IN) THEN + FAILED ("END_OF_FILE WITHOUT PARAMETER DOES " & + "NOT OPERATE ON THE DEFAULT INPUT FILE"); + END IF; + + GET (ITEM_CHAR); + + IF NOT (END_OF_FILE) THEN + FAILED ("INCORRECT VALUE AT LAST POSITION"); + END IF; + + BEGIN + DELETE (FILE_IN); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3408C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CE3409A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_COL RAISES LAYOUT_ERROR IF THE LINE LENGTH IS + -- BOUNDED AND THE GIVEN COLUMN POSITION EXCEEDS THE LINE LENGTH + -- FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 CORRECTD EXCEPTION HANDLING AND ADDED NEW CASES + -- FOR OBJECTIVE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3409A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + FIVE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(5)); + + BEGIN + + TEST ("CE3409A", "CHECK THAT SET_COL RAISES " & + "LAYOUT_ERROR APPROPRIATELY"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " & + "TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FILE, THREE); + + BEGIN + SET_COL (FILE, FOUR); + FAILED ("LAYOUT_ERROR NOT RAISED ON SET_COL - 1"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL - 1"); + END; + + IF COL (FILE) /= 1 THEN + FAILED ("COLUMN LENGTH NOT INITIALLY ONE"); + END IF; + + PUT (FILE, 'A'); + PUT (FILE, 'B'); + PUT (FILE, 'C'); + + SET_LINE_LENGTH (FILE, FOUR); + + BEGIN + SET_COL (FILE, FIVE); + FAILED ("LAYOUT_ERROR NOT RAISED ON SET_COL - 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL - 2"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3409A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- CE3409B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_COL RAISES CONSTRAINT_ERROR IF THE GIVEN + -- COLUMN NUMBER IS ZERO, OR NEGATIVE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/22/82 + -- JBG 01/27/83 + -- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, REMOVED UNNECESSARY + -- CODE, AND ADDED CASE FOR COUNT'LAST. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS. + + WITH REPORT ; + USE REPORT ; + WITH TEXT_IO ; + USE TEXT_IO ; + + PROCEDURE CE3409B IS + FILE : FILE_TYPE; + BEGIN + + TEST ("CE3409B", "CHECK THAT SET_COL RAISES CONSTRAINT_ERROR " & + "IF THE GIVEN COLUMN NUMBER IS ZERO, OR NEGATIVE."); + + BEGIN + SET_COL (FILE, POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO"); + END; + + BEGIN + SET_COL (FILE, POSITIVE_COUNT(IDENT_INT(-2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR NEGATIVE " & + "NUMBER"); + END; + + RESULT; + + END CE3409B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + -- CE3409C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_COL SETS THE CURRENT COLUMN NUMBER TO THE VALUE + -- SPECIFIED BY TO FOR FILES OF MODES IN_FILE AND OUT_FILE. + -- CHECK THAT IT HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS + -- EQUAL TO THE CURRENT COLUMN NUMBER FOR BOTH IN_FILE AND OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- JBG 01/27/83 + -- SPS 02/18/83 + -- EG 05/22/85 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3409C IS + + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3409C", "CHECK THAT SET_COL SETS THE CURRENT COLUMN " & + "NUMBER TO THE VALUE SPECIFIED BY TO FOR FILES " & + "OF MODES IN_FILE AND OUT_FILE. CHECK THAT IT " & + "HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS " & + "EQUAL TO THE CURRENT COLUMN NUMBER FOR BOTH " & + "IN_FILE AND OUT_FILE"); + + DECLARE + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + SET_PAGE_LENGTH (FILE, TWO); + SET_COL (FILE, FOUR); + IF COL (FILE) /= FOUR THEN + FAILED ("FOR OUT_FILE COLUMN NOT FOUR"); + ELSE + PUT (FILE, 'C'); + SET_COL (FILE, 5); + IF COL (FILE) /= FOUR+1 OR LINE (FILE) /= ONE THEN + FAILED ("FOR OUT_FILE COLUMN UNNECESSARILY " & + "CHANGED FROM FOUR"); + ELSE + SET_COL (FILE, 8); + PUT (FILE, "DE"); + SET_COL (FILE, TWO+1); + IF COL (FILE) /= TWO+ONE OR LINE (FILE) /= TWO THEN + FAILED ("FOR OUT_FILE COLUMN NOT TWO"); + END IF; + PUT (FILE, 'B'); + SET_COL (FILE, TWO); + + IF PAGE (FILE) /= TWO THEN + FAILED ("PAGE TERMINATOR NOT OUTPUT"); + END IF; + + IF LINE (FILE) /= ONE THEN + FAILED ("LINE TERMINATOR NOT OUTPUT"); + END IF; + + IF COL (FILE) /= TWO THEN + FAILED ("COL NOT TWO; IS" & + COUNT'IMAGE(COL(FILE))); + END IF; + + PUT (FILE, 'X'); + END IF; + END IF; + + CHECK_FILE (FILE, " C DE# B#@ X#@%"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + SET_COL (FILE, FOUR); + IF COL (FILE) /= FOUR THEN + FAILED ("FOR IN_FILE COLUMN NOT FOUR"); + ELSE + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'C' THEN + FAILED ("SET_COL FOR READ; ACTUALLY READ '" & + ITEM_CHAR & "'"); + END IF; + + SET_COL (FILE, 5); + IF COL (FILE) /= FOUR+1 OR LINE (FILE) /= ONE THEN + FAILED ("FOR IN_FILE COLUMN UNNECESSARILY " & + "CHANGED FROM FOUR"); + ELSE + SET_COL (FILE, 9); + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'E' THEN + FAILED ("SET_COL FOR READ 2; ACTUALLY READ '" & + ITEM_CHAR & "'"); + END IF; + + SET_COL (FILE, 3); + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'B' THEN + FAILED ("SET_COL FOR READ 3; ACTUALLY READ '" & + ITEM_CHAR & "'"); + END IF; + + IF COL (FILE) /= 4 OR LINE (FILE) /= TWO THEN + FAILED ("FOR IN_FILE COLUMN NOT TWO"); + END IF; + END IF; + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3409C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- CE3409D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR FILES OF MODE IN_FILE, SET_COL READS UNTIL A + -- LINE FOUND HAVING A CHARACTER AT THE SPECIFIED COLUMN, SKIPPING + -- LINE AND PAGE TERMINATORS AS NECESSARY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JBG 01/27/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 REMOVED DEPENDENCE ON REST, REMOVED UNNECESSARY + -- CODE, CHECKED FOR USE_ERROR ON DELETE, AND ADDED + -- NEW CASES FOR SET_COL. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3409D IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3409D", "CHECK THAT SET_COL SKIPS LINE AND PAGE " & + "TERMINATORS WHEN NECESSARY"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "ABC"); + NEW_LINE (FILE); + PUT (FILE, "DEFGHI"); + NEW_PAGE (FILE); + PUT (FILE, "XYZ"); + NEW_PAGE (FILE); + PUT (FILE, "IJKL"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + SET_COL (FILE, FOUR); + GET (FILE, ITEM_CHAR); + + IF ITEM_CHAR = ' ' THEN + BEGIN + COMMENT ("FILE PADS LINES WITH SPACES"); + + SET_COL (FILE, FOUR); + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'G' THEN + FAILED ("INCORRECT VALUE FROM SET_COL - 1"); + END IF; + + SET_COL (FILE, FOUR); + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= ' ' THEN + FAILED ("LINES SHOULD STILL BE PADDED WITH BLANKS"); + END IF; + END; + + ELSIF ITEM_CHAR /= 'G' THEN + FAILED ("SET_COL DOESN'T SKIP LINE MARKS; " & + "ACTUALLY READ '" & ITEM_CHAR & "'"); + ELSE + BEGIN + SET_COL (FILE, FOUR); + GET (FILE, ITEM_CHAR); + + IF ITEM_CHAR /= 'L' THEN + FAILED ("SET_COL DOESN'T SKIP PAGE MARKS; " & + "ACTUALLY READ '" & ITEM_CHAR & "'"); + END IF; + END; + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3409D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3409e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,115 ---- + -- CE3409E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_COL RAISES END_ERROR IF NO LINE BEFORE THE END OF + -- THE FILE IS LONG ENOUGH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- JBG 01/27/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3409E IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3409E", "CHECK THAT SET_COL RAISES END_ERROR " & + "WHEN IT ATTEMPTS TO READ THE FILE TERMINATOR"); + + -- CREATE & INITIALIZE FILE + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "ABCD"); + NEW_LINE (FILE); + PUT (FILE, "DEF"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + SET_COL (FILE, 513); + FAILED ("END ERROR NOT RAISED ON SET_COL"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_COL"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3409E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- CE3410A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE RAISES LAYOUT_ERROR IF THE PAGE LENGTH IS + -- BOUNDED AND THE GIVEN LINE POSITION EXCEEDS THE PAGE LENGTH + -- FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- ABW 08/26/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3410A IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + + BEGIN + + TEST ("CE3410A", "CHECK THAT SET_LINE RAISES " & + "LAYOUT_ERROR APPROPRIATELY"); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE FOR " & + "TEMPORARY FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_PAGE_LENGTH (FILE, THREE); + + BEGIN + SET_LINE (FILE, FOUR); + FAILED ("LAYOUT ERROR NOT RAISED FOR SET_LINE"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR SET_LINE"); + END; + + CLOSE (FILE); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3410A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,77 ---- + -- CE3410B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE RAISES CONSTRAINT_ERROR IF THE GIVEN + -- LINE NUMBER IS ZERO, OR NEGATIVE. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/22/82 + -- JBG 01/27/83 + -- JLH 08/31/87 ADDED CASE FOR COUNT'LAST. + -- PWN 10/27/95 REMOVED OUT OF RANGE STATIC VALUE CHECKS + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3410B IS + + FILE : FILE_TYPE; + + BEGIN + + TEST ("CE3410B", "CHECK THAT SET_LINE RAISES CONSTRAINT_ERROR " & + "IF THE GIVEN LINE NUMBER IS ZERO, OR NEGATIVE"); + + BEGIN + SET_LINE (FILE, POSITIVE_COUNT(IDENT_INT(0))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ZERO"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR ZERO"); + END; + + BEGIN + SET_LINE (FILE, POSITIVE_COUNT(IDENT_INT(-2))); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE NUMBER"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR INSTEAD OF CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR NEGATIVE " & + "NUMBER"); + END; + + RESULT; + + END CE3410B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,205 ---- + -- CE3410C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE SETS THE CURRENT LINE NUMBER TO THE VALUE + -- SPECIFIED BY TO FOR FILES OF MODES IN_FILE AND OUT_FILE. + -- CHECK THAT IT HAS NO EFFECT IF THE VALUE SPECIFIED BY TO IS + -- EQUAL TO THE CURRENT LINE NUMBER FOR BOTH IN_FILE AND OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- JBG 01/27/83 + -- EG 05/22/85 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/01/87 REMOVED DEPENDENCE ON RESET, ADDED MORE TEST + -- CASES, AND CHECKED FOR USE_ERROR ON DELETE. + -- JRL 02/29/96 Added File parameter to call to Set_Page_Length. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3410C IS + + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3410C", "CHECK THAT SET_LINE SETS LINE " & + "NUMBER CORRECTLY"); + + DECLARE + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + ONE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(1)); + TWO : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(3)); + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE (FILE, FOUR); + IF LINE (FILE) /= FOUR THEN + FAILED ("FOR OUT_FILE LINE NOT FOUR"); + ELSE + PUT (FILE, 'C'); + NEW_LINE (FILE); + SET_LINE (FILE, 5); + IF LINE (FILE) /= FOUR+1 THEN + FAILED ("FOR OUT_FILE LINE UNNECESSARILY " & + "CHANGED FROM FOUR"); + ELSE + SET_LINE (FILE, 8); + PUT (FILE, "DE"); + SET_LINE (FILE, TWO+1); + IF LINE (FILE) /= TWO+ONE THEN + FAILED ("FOR OUT_FILE LINE NOT THREE"); + END IF; + + SET_LINE (FILE, TWO); + + IF PAGE (FILE) /= ONE+TWO THEN + FAILED ("PAGE TERMINATOR NOT OUTPUT - 2"); + END IF; + + IF LINE (FILE) /= TWO THEN + FAILED ("LINE NOT TWO; IS" & + COUNT'IMAGE(LINE(FILE))); + END IF; + + SET_PAGE_LENGTH (FILE, TWO); + PUT (FILE, 'X'); + SET_LINE (FILE, TWO); + PUT (FILE, 'Y'); + + IF LINE (FILE) /= TWO THEN + FAILED ("LINE NOT TWO; IS " & + COUNT'IMAGE(LINE(FILE))); + END IF; + + IF PAGE (FILE) /= THREE THEN + FAILED ("PAGE NOT THREE; IS " & + COUNT'IMAGE(PAGE(FILE))); + END IF; + + END IF; + END IF; + + CHECK_FILE (FILE, "###C####DE#@##@#XY#@%"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED FOR TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE (FILE, FOUR); + IF LINE (FILE) /= FOUR THEN + FAILED ("FOR IN_FILE LINE NOT FOUR"); + ELSE + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'C' THEN + FAILED ("SET_LINE FOR READ; ACTUALLY READ '" & + ITEM_CHAR & "'"); + END IF; + + SKIP_LINE (FILE); + SET_LINE (FILE, 5); + IF LINE (FILE) /= FOUR+1 OR PAGE (FILE) /= ONE THEN + FAILED ("INCORRECT LINE OR PAGE"); + ELSE + SET_LINE (FILE, 8); + GET (FILE, ITEM_CHAR); + IF ITEM_CHAR /= 'D' THEN + FAILED ("SET_LINE FOR READ 2; ACTUALLY READ '"& + ITEM_CHAR & "'"); + END IF; + + SET_LINE (FILE, TWO); + IF PAGE (FILE) /= TWO THEN + FAILED ("FOR IN_FILE PAGE NOT TWO"); + END IF; + + SET_LINE (FILE, TWO); + IF PAGE (FILE) /= TWO OR LINE (FILE) /= TWO THEN + FAILED ("FOR IN_FILE PAGE NOT 2"); + END IF; + + SKIP_LINE (FILE); + SET_LINE (FILE, TWO); + + GET (FILE, ITEM_CHAR); + + IF ITEM_CHAR /= 'X' THEN + FAILED ("SET_LINE FOR READ 3; ACTUALLY READ '"& + ITEM_CHAR & "'"); + END IF; + + END IF; + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3410C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CE3410D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT, FOR FILES OF MODE IN_FILE, SET_LINE READS UNTIL A + -- PAGE IS FOUND HAVING A LINE AT THE SPECIFIED POSITION, SKIPPING + -- LINE AND PAGE TERMINATORS AS NECESSARY. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JBG 01/27/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/01/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR + -- USE_ERROR ON DELETE. + -- GJD 11/15/95 FIXED ADA 95 INCOMPATIBLE USE OF CHARACTER LITERALS. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3410D IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + FOUR : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + ITEM_CHAR : CHARACTER; + + BEGIN + + TEST ("CE3410D", "CHECK THAT SET_LINE SKIPS PAGE " & + "TERMINATORS WHEN NECESSARY"); + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN CHARACTER RANGE 'A'..'C' LOOP + PUT (FILE, I); + NEW_LINE (FILE); + END LOOP; + + NEW_PAGE (FILE); + + FOR I IN CHARACTER RANGE 'D'..'H' -- 5 LINES + LOOP + PUT (FILE, I); + NEW_LINE (FILE); + END LOOP; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE (FILE, FOUR); + GET (FILE, ITEM_CHAR); + + IF ITEM_CHAR /= 'G' THEN + FAILED ("SET_LINE DOESN'T SKIP PAGE MARKS; " & + "ACTUALLY READ '" & ITEM_CHAR & "'"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3410D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3410e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- CE3410E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_LINE RAISES END_ERROR IF NO PAGE BEFORE THE END + -- OF THE FILE IS LONG ENOUGH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- JBG 01/27/83 + -- JBG 08/30/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, ADDED NEW CASES FOR + -- OBJECTIVE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3410E IS + + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + CHAR : CHARACTER := ('C'); + ITEM_CHAR : CHARACTER; + FIVE : POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(5)); + + BEGIN + + TEST ("CE3410E", "CHECK THAT SET_LINE RAISES END_ERROR " & + "WHEN IT ATTEMPTS TO READ THE FILE TERMINATOR"); + + -- CREATE & INITIALIZE FILE + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "ABCD"); + NEW_LINE (FILE); + PUT (FILE, "DEF"); + NEW_LINE (FILE, 3); + NEW_PAGE (FILE); + PUT_LINE (FILE, "HELLO"); + NEW_PAGE (FILE); + PUT_LINE (FILE, "GH"); + PUT_LINE (FILE, "IJK"); + PUT_LINE (FILE, "HI"); + PUT_LINE (FILE, "TESTING"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + BEGIN + SET_LINE (FILE,FIVE); + FAILED ("END ERROR NOT RAISED ON SET_LINE"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON SET_LINE"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3410E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3411a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CE3411A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT COL RETURNS THE VALUE OF THE CURRENT COLUMN NUMBER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 08/30/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/02/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR + -- USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3411A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3411A", "CHECK THAT COL RETURNS THE VALUE OF THE " & + "CURRENT COLUMN NUMBER"); + + DECLARE + FT : FILE_TYPE; + X : CHARACTER; + NUM_CHARS : POSITIVE_COUNT; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "OUTPUT STRING"); + IF COL (FT) /= 14 THEN + FAILED ("COL INCORRECT AFTER PUT; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + NEW_LINE (FT); + IF COL (FT) /= 1 THEN + FAILED ("COL INCORRECT AFTER NEW_LINE; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + PUT (FT, "MORE OUTPUT"); + NEW_PAGE (FT); + IF COL (FT) /= 1 THEN + FAILED ("COL INCORRECT AFTER NEW_PAGE; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + PUT (FT, "FINAL"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF COL (FT) /= 1 THEN + FAILED ("COL INCORRECT AFTER REOPEN; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + FOR I IN 1 .. 4 LOOP + GET (FT, X); + END LOOP; + IF COL (FT) /= 5 THEN + FAILED ("COL INCORRECT AFTER GET; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + NUM_CHARS := COL(FT); + WHILE NOT END_OF_LINE(FT) LOOP + GET (FT, X); + NUM_CHARS := NUM_CHARS + 1; + END LOOP; + + IF COL(FT) /= NUM_CHARS THEN + FAILED ("COL INCORRECT BEFORE END OF LINE; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + SKIP_LINE (FT); + IF COL(FT) /= 1 THEN + FAILED ("COL INCORRECT AFTER SKIP_LINE; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + SET_COL (FT, 2); + IF COL (FT) /= 2 THEN + FAILED ("COL INCORRECT AFTER SET_COL; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + SKIP_PAGE (FT); + IF COL(FT) /= 1 THEN + FAILED ("COL INCORRECT AFTER SKIP_PAGE; IS" & + COUNT'IMAGE(COL(FT))); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + END CE3411A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3411c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,146 ---- + -- CE3411C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT COL OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN + -- NO FILE IS SPECIFIED. CHECK THAT COL CAN OPERATE ON FILES OF + -- MODES IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT + -- INPUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 01/31/83 + -- JBG 08/30/83 + -- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3411C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3411C", "CHECK THAT COL OPERATES ON DEFAULT IN_FILE AND "& + "OUT_FILE FILES"); + + DECLARE + F1, F2 : FILE_TYPE; + C : POSITIVE_COUNT; + X : CHARACTER; + BEGIN + IF COL /= COL (STANDARD_OUTPUT) THEN + FAILED ("COL DEFAULT NOT STANDARD_OUTPUT"); + END IF; + + IF COL /= COL (STANDARD_INPUT) THEN + FAILED ("COL DEFAULT NOT STANDARD_INPUT"); + END IF; + + IF COL /= COL (CURRENT_INPUT) THEN + FAILED ("COL DEFAULT NOT CURRENT_INPUT"); + END IF; + + IF COL /= COL (CURRENT_OUTPUT) THEN + FAILED ("COL DEFAULT NOT CURRENT_OUTPUT"); + END IF; + + BEGIN + CREATE (F1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (F2, OUT_FILE); + + SET_OUTPUT (F2); + + PUT (F1, "STRING"); + IF COL (F1) /= 7 THEN + FAILED ("COL INCORRECT SUBTEST 1"); + END IF; + + PUT (F2, "OUTPUT STRING"); + IF COL /= COL(F2) AND COL(F2) /= 14 THEN + FAILED ("COL INCORRECT SUBTEST 2; WAS " & + COUNT'IMAGE(COL) & " VS. " & + COUNT'IMAGE(COL(F2))); + END IF; + + CLOSE (F1); + + BEGIN + OPEN (F1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (F1); + + GET (F1, X); + GET (F1, X); + GET (F1, X); + + IF X /= 'R' THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + IF COL (CURRENT_INPUT) /= 4 AND COL /= 4 THEN + FAILED ("COL INCORRECT SUBTEST 3"); + END IF; + + BEGIN + DELETE (F1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CLOSE (F2); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3411C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3412a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,149 ---- + -- CE3412A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LINE RETURNS THE VALUE OF THE CURRENT LINE NUMBER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 08/30/83 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/02/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR + -- USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3412A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3412A", "CHECK LINE RETURNS LINE NUMBER"); + + DECLARE + FT : FILE_TYPE; + X : CHARACTER; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + IF LINE (FT) /= 1 THEN + FAILED ("CURRENT LINE NUMBER NOT INITIALLY ONE"); + END IF; + + FOR I IN 1 .. 3 LOOP + PUT (FT, "OUTPUT STRING"); + NEW_LINE (FT); + END LOOP; + IF LINE (FT) /= 4 THEN + FAILED ("LINE INCORRECT AFTER PUT; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + NEW_PAGE (FT); + IF LINE (FT) /= 1 THEN + FAILED ("LINE INCORRECT AFTER NEW_PAGE; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + FOR I IN 1 .. 5 LOOP + PUT (FT, "MORE OUTPUT"); + NEW_LINE(FT); + END LOOP; + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF LINE (FT) /= 1 THEN + FAILED ("LINE INCORRECT AFTER RESET; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + FOR I IN 1 .. 2 LOOP + SKIP_LINE (FT); + END LOOP; + IF LINE (FT) /= 3 THEN + FAILED ("LINE INCORRECT AFTER SKIP_LINE; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + SET_LINE (FT, 2); + IF LINE (FT) /= 2 THEN + FAILED ("LINE INCORRECT AFTER SET_LINE; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + SKIP_PAGE (FT); + IF LINE (FT) /= 1 THEN + FAILED ("LINE INCORRECT AFTER SKIP_PAGE; IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3412A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- CE3413A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PAGE RETURNS THE VALUE OF THE CURRENT PAGE NUMBER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 08/30/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/04/87 REMOVED DEPENDENCE ON RESET AND CHECKED FOR + -- USE_ERROR ON DELETE. + + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3413A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3413A", "CHECK THAT PAGE RETURNS THE CORRECT PAGE " & + "NUMBER"); + + DECLARE + FT : FILE_TYPE; + X : CHARACTER; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + IF PAGE (FT) /= 1 THEN + FAILED ("CURRENT PAGE NOT INITIALLY ONE"); + END IF; + + FOR I IN 1 .. 6 LOOP + PUT (FT, "OUTPUT STRING"); + NEW_PAGE (FT); + END LOOP; + IF PAGE (FT) /= 7 THEN + FAILED ("PAGE INCORRECT AFTER PUT; IS" & + COUNT'IMAGE(PAGE(FT))); + END IF; + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF PAGE (FT) /= 1 THEN + FAILED ("PAGE INCORRECT AFTER OPEN IS" & + COUNT'IMAGE(PAGE(FT))); + END IF; + + FOR I IN 1 .. 4 LOOP + SKIP_PAGE (FT); + END LOOP; + IF PAGE (FT) /= 5 THEN + FAILED ("PAGE INCORRECT AFTER SKIP_PAGE; IS" & + COUNT'IMAGE(PAGE(FT))); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3413A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- CE3413B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PAGE RAISES LAYOUT_ERROR WHEN THE VALUE OF THE + -- PAGE NUMBER EXCEEDS COUNT'LAST. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- HISTORY: + -- JLH 07/27/88 CREATED ORIGINAL TEST. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + + PROCEDURE CE3413B IS + + FILE : FILE_TYPE; + INCOMPLETE, INAPPLICABLE : EXCEPTION; + ITEM : STRING(1..3) := "ABC"; + LST : NATURAL; + + BEGIN + + TEST ("CE3413B", "CHECK THAT PAGE RAISES LAYOUT_ERROR WHEN THE " & + "VALUE OF THE PAGE NUMBER EXCEEDS COUNT'LAST"); + + BEGIN + + IF COUNT'LAST > 150000 THEN + RAISE INAPPLICABLE; + END IF; + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1 .. COUNT'LAST-1 LOOP + NEW_PAGE (FILE); + END LOOP; + + PUT (FILE, ITEM); + + NEW_PAGE (FILE); + PUT (FILE, "DEF"); + + BEGIN + IF PAGE(FILE) <= POSITIVE_COUNT(COUNT'LAST) THEN + FAILED ("PAGE NUMBER INCORRECT AFTER PAGE SET - 1"); + END IF; + FAILED ("LAYOUT_ERROR NOT RAISED FOR PAGE - 1"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PAGE - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR PAGE - 1"); + END; + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + FOR I IN 1 .. COUNT'LAST-1 LOOP + SKIP_PAGE (FILE); + END LOOP; + + IF PAGE(FILE) /= COUNT'LAST THEN + FAILED ("INCORRECT PAGE NUMBER"); + END IF; + + GET_LINE (FILE, ITEM, LST); + IF ITEM /= "ABC" THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + SKIP_PAGE (FILE); + + BEGIN + IF PAGE(FILE) <= POSITIVE_COUNT(COUNT'LAST) THEN + FAILED ("PAGE NUMBER INCORRECT AFTER PAGE SET - 2"); + END IF; + FAILED ("LAYOUT_ERROR NOT RAISED FOR PAGE - 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED FOR PAGE - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED FOR PAGE - 2"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + WHEN INAPPLICABLE => + NOT_APPLICABLE ("THE VALUE OF COUNT'LAST IS GREATER " & + "THAN 150000. THE CHECKING OF THIS " & + "OBJECTIVE IS IMPRACTICAL"); + + END; + + RESULT; + + END CE3413B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3413c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CE3413C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PAGE OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN + -- NO FILE IS SPECIFIED. CHECK THAT PAGE CAN OPERATE ON FILES OF + -- MODES IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT + -- INPUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 08/30/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/04/87 REMOVED DEPENDENCE ON RESET, CORRECTED EXCEPTION + -- HANDLING, AND CHECKED FOR USE_ERROR ON DELETE. + + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3413C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3413C", "CHECK THAT PAGE OPERATES ON DEFAULT IN_FILE " & + "AND OUT_FILE FILES"); + + DECLARE + F1, F2 : FILE_TYPE; + C : POSITIVE_COUNT; + X : CHARACTER; + BEGIN + + BEGIN + CREATE (F1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + CREATE (F2, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILES WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_OUTPUT (F2); + + IF PAGE (F2) /= 1 AND PAGE (STANDARD_OUTPUT) /= 1 THEN + FAILED ("PAGE INCORRECT SUBTEST - 1"); + END IF; + + FOR I IN 1 .. 3 LOOP + PUT (F1, "STRING"); + NEW_PAGE (F1); + END LOOP; + + IF PAGE (F1) /= 4 THEN + FAILED ("PAGE INCORRECT SUBTEST - 2"); + END IF; + + SET_LINE_LENGTH (F2, 3); + SET_PAGE_LENGTH (F2, 1); + PUT ("OUTPUT STRING"); + IF PAGE /= PAGE(F2) THEN + FAILED ("PAGE INCORRECT SUBTEST - 3"); + END IF; + + CLOSE (F1); + + BEGIN + OPEN (F1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (F1); + + IF PAGE (F1) /= 1 THEN + FAILED ("PAGE INCORRECT SUBTEST - 4"); + END IF; + + SKIP_PAGE(F1); + SKIP_PAGE(F1); + IF PAGE (F1) /= PAGE (CURRENT_INPUT) THEN + FAILED ("PAGE INCORRECT SUBTEST - 5"); + END IF; + + BEGIN + DELETE (F1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CLOSE (F2); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3413C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3414a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,204 ---- + -- CE3414A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT STATUS_ERROR IS RAISED WHEN NEW_LINE, SKIP_LINE, + -- END_OF_LINE, NEW_PAGE, SKIP_PAGE, END_OF_PAGE, END_OF_FILE, + -- SET_COL, SET_LINE, COL, LINE, AND PAGE ARE CALLED AND THE FILE + -- IS NOT OPEN. + + -- HISTORY: + -- BCB 10/27/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3414A IS + + FILE : FILE_TYPE; + + INCOMPLETE : EXCEPTION; + + X : POSITIVE_COUNT; + + BEGIN + TEST ("CE3414A", "CHECK THAT STATUS_ERROR IS RAISED WHEN " & + "NEW_LINE, SKIP_LINE, END_OF_LINE, NEW_PAGE, " & + "SKIP_PAGE, END_OF_PAGE, END_OF_FILE, SET_COL, " & + "SET_LINE, COL, LINE, AND PAGE ARE CALLED AND " & + "THE FILE IS NOT OPEN"); + + BEGIN + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, 'A'); + + CLOSE (FILE); + + BEGIN + NEW_LINE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + SKIP_LINE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + BEGIN + IF NOT END_OF_LINE (FILE) THEN + NULL; + END IF; + FAILED ("STATUS_ERROR WAS NOT RAISED - 3"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 3"); + END; + + BEGIN + NEW_PAGE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 4"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 4"); + END; + + BEGIN + SKIP_PAGE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 5"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 5"); + END; + + BEGIN + IF NOT END_OF_PAGE (FILE) THEN + NULL; + END IF; + FAILED ("STATUS_ERROR WAS NOT RAISED - 6"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 6"); + END; + + BEGIN + IF NOT END_OF_FILE (FILE) THEN + NULL; + END IF; + FAILED ("STATUS_ERROR WAS NOT RAISED - 7"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 7"); + END; + + BEGIN + SET_COL (FILE, 2); + FAILED ("STATUS_ERROR WAS NOT RAISED - 8"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 8"); + END; + + BEGIN + SET_LINE (FILE, 2); + FAILED ("STATUS_ERROR WAS NOT RAISED - 9"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 9"); + END; + + BEGIN + X := COL (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 10"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 10"); + END; + + BEGIN + X := LINE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 11"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 11"); + END; + + BEGIN + X := PAGE (FILE); + FAILED ("STATUS_ERROR WAS NOT RAISED - 12"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 12"); + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE3414A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3601a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,187 ---- + -- CE3601A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET (FOR STRINGS AND CHARACTERS), PUT (FOR STRINGS AND + -- CHARACTERS), GET_LINE, AND PUT_LINE RAISE STATUS_ERROR WHEN + -- CALLED WITH AN UNOPEN FILE PARAMETER. ALSO CHECK NAMES OF FORMAL + -- PARAMETERS. + + -- HISTORY: + -- SPS 08/27/82 + -- VKG 02/15/83 + -- JBG 03/30/83 + -- JLH 09/04/87 ADDED CASE WHICH ATTEMPTS TO CREATE FILE AND THEN + -- RETESTED OBJECTIVE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3601A IS + + BEGIN + + TEST ("CE3601A", "STATUS_ERROR RAISED BY GET, PUT, GET_LINE, " & + "PUT_LINE WHEN FILE IS NOT OPEN"); + + DECLARE + FILE1, FILE2 : FILE_TYPE; + CH: CHARACTER := '%'; + LST: NATURAL; + ST: STRING (1 .. 10); + LN : STRING (1 .. 80); + BEGIN + BEGIN + GET (FILE => FILE1, ITEM => CH); + FAILED ("STATUS_ERROR NOT RAISED - GET CHARACTER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHARACTER"); + END; + + BEGIN + GET (FILE => FILE1, ITEM => ST); + FAILED ("STATUS_ERROR NOT RAISED - GET STRING"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING"); + END; + + BEGIN + GET_LINE (FILE => FILE1, ITEM => LN, LAST => LST); + FAILED ("STATUS_ERROR NOT RAISED - GET_LINE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET_LINE"); + END; + + BEGIN + PUT (FILE => FILE1, ITEM => CH); + FAILED ("STATUS_ERROR NOT RAISED - PUT CHARACTER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT CHARACTER"); + END; + + BEGIN + PUT (FILE => FILE1, ITEM => ST); + FAILED ("STATUS_ERROR NOT RAISED - PUT STRING"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT STRING"); + END; + + BEGIN + PUT_LINE (FILE => FILE1, ITEM => LN); + FAILED ("STATUS_ERROR NOT RAISED - PUT_LINE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT_LINE"); + END; + + BEGIN + CREATE (FILE2, OUT_FILE); -- THIS IS ONLY AN ATTEMPT TO + CLOSE (FILE2); -- CREATE A FILE. OK, WHETHER + EXCEPTION -- SUCCESSFUL OR NOT. + WHEN USE_ERROR => + NULL; + END; + + BEGIN + GET (FILE => FILE2, ITEM => CH); + FAILED ("STATUS_ERROR NOT RAISED - GET CHARACTER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHARACTER"); + END; + + BEGIN + GET (FILE => FILE2, ITEM => ST); + FAILED ("STATUS_ERROR NOT RAISED - GET STRING"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING"); + END; + + BEGIN + GET_LINE (FILE => FILE2, ITEM => LN, LAST => LST); + FAILED ("STATUS_ERROR NOT RAISED - GET_LINE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET_LINE"); + END; + + BEGIN + PUT (FILE => FILE2, ITEM => CH); + FAILED ("STATUS_ERROR NOT RAISED - PUT CHARACTER"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT CHARACTER"); + END; + + BEGIN + PUT (FILE => FILE2, ITEM => ST); + FAILED ("STATUS_ERROR NOT RAISED - PUT STRING"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT STRING"); + END; + + BEGIN + PUT_LINE (FILE => FILE2, ITEM => LN); + FAILED ("STATUS_ERROR NOT RAISED - PUT_LINE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT_LINE"); + END; + + END; + + RESULT; + + END CE3601A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,189 ---- + -- CE3602A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR CHARACTERS AND STRINGS ALLOW A STRING TO SPAN + -- OVER MORE THAN ONE LINE, SKIPPING INTERVENING LINE AND PAGE + -- TERMINATORS. ALSO CHECK THAT GET ACCEPTS A NULL STRING ACTUAL + -- PARAMETER AND A STRING SLICE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 08/30/82 + -- VKG 01/26/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/04/87 REMOVED DEPENDENCE ON RESET, CORRECTED EXCEPTION + -- HANDLING, AND ADDED NEW CASES FOR OBJECTIVE. + + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3602A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3602A", "CHECK THAT GET FOR CHARACTERS AND STRINGS " & + "ALLOWS A STRING TO SPAN OVER MORE THAN ONE " & + "LINE, SKIPPING INTERVENING LINE AND PAGE " & + "TERMINATORS. ALSO CHECK THAT GET ACCEPTS " & + "A NULL STRING ACTUAL PARAMETER AND A STRING " & + "SLICE"); + + DECLARE + FILE1 : FILE_TYPE; + ST : STRING (1 .. 40); + STR: STRING (1 .. 100); + NST: STRING (1 .. 0); + ORIGINAL_LINE_LENGTH : COUNT; + + -- READ_CHARS RETURNS A STRING OF N CHARACTERS FROM A GIVEN FILE. + + FUNCTION READ_CHARS (FILE : FILE_TYPE; + N : NATURAL ) + RETURN STRING IS + C: CHARACTER; + BEGIN + IF N = 0 THEN RETURN ""; + ELSE + GET (FILE,C); + RETURN C&READ_CHARS (FILE,N-1); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("ERROR ON READ_CHARS"); + END READ_CHARS; + + + BEGIN + + -- CREATE AND INITIALIZE TEST DATA FILE + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + ORIGINAL_LINE_LENGTH := LINE_LENGTH; + + -- LINE_LENGTH SET IN CASE IMPLEMENTATION REQUIRES BOUNDED LENGTH LINES + + SET_LINE_LENGTH (16); + PUT (FILE1, "THIS LINE SHALL "); + SET_LINE_LENGTH (10); + PUT (FILE1, "SPAN OVER "); + SET_LINE_LENGTH (14); + PUT (FILE1, "SEVERAL LINES."); + CLOSE (FILE1); + SET_LINE_LENGTH (ORIGINAL_LINE_LENGTH); + + + -- BEGIN TEST + + BEGIN + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN WITH IN_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + STR(1..40) := READ_CHARS (FILE1, 40); + CLOSE (FILE1); + + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + + GET (FILE1, ST); + IF STR(1..40) /= ST THEN + FAILED ("GET FOR STRING INCORRECT"); + END IF; + + IF STR(1..40) /= "THIS LINE SHALL SPAN OVER SEVERAL " & + "LINES." THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + -- GET NULL STRING + + CLOSE (FILE1); + + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + + BEGIN + GET (FILE1, NST); + EXCEPTION + WHEN OTHERS => + FAILED (" GET FAILED ON NULL STRING"); + END; + + -- GET NULL SLICE + + BEGIN + GET (FILE1, STR (10 .. 1)); + EXCEPTION + WHEN OTHERS => + FAILED ("GET FAILED ON A NULL SLICE"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3602A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- CE3602B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET (FOR CHARACTER AND STRINGS) PROPERLY SETS THE + -- PAGE, LINE, AND COLUMN NUMBERS AFTER EACH OPERATION. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 08/30/82 + -- SPS 12/17/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/04/87 REMOVED DEPENDENCE ON UNBOUNDED LINE LENGTH AND + -- CORRECTED EXCEPTION HANDLING. + -- BCB 11/13/87 GAVE SET_LINE_LENGTH PROCEDURE THE FILE VARIABLE + -- AS A PARAMETER. REMOVED LINE WHICH SAVED AND + -- RESTORED THE LINE LENGTH. + + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3602B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3602B", "CHECK THAT GET PROPERLY SETS PAGE, LINE, AND " & + "COLUMN NUMBERS"); + + DECLARE + FILE1 : FILE_TYPE; + LINE1 : CONSTANT STRING := "LINE ONE OF TEST DATA FILE"; + LINE2 : CONSTANT STRING := "LINE TWO"; + LINE3 : CONSTANT STRING := "LINE THREE"; + CN, LN : POSITIVE_COUNT; + CH : CHARACTER; + ST: STRING (1 .. 5); + ORIGINAL_LINE_LENGTH : COUNT; + + BEGIN + + -- CREATE AND INITIALIZE TEST DATA FILE + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + ORIGINAL_LINE_LENGTH := LINE_LENGTH; + SET_LINE_LENGTH (FILE1, LINE1'LENGTH); + + PUT (FILE1, LINE1); + SET_LINE_LENGTH (FILE1, LINE2'LENGTH); + PUT (FILE1, LINE2); + NEW_LINE (FILE1, 2); + NEW_PAGE (FILE1); + SET_LINE_LENGTH (FILE1, LINE3'LENGTH); + PUT (FILE1, LINE3); + CLOSE (FILE1); + + -- BEGIN TEST + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + IF COL (FILE1) /= 1 THEN + FAILED ("COLUMN NUMBER NOT INITIALLY ONE"); + END IF; + + IF LINE (FILE1) /= 1 THEN + FAILED ("LINE NUMBER NOT INITIALLY ONE"); + END IF; + + IF PAGE (FILE1) /= 1 THEN + FAILED ("PAGE NUMBER NOT INITIALLY ONE"); + END IF; + + -- TEST COLUMN NUMBER FOR CHARACTER + + GET (FILE1, CH); + IF CH /= 'L' THEN + FAILED ("CHARACTER NOT EQUAL TO L - 1"); + END IF; + CN := COL (FILE1); + IF CN /= 2 THEN + FAILED ("COLUMN NUMBER NOT SET CORRECTLY " & + "- GET CHARACTER. COL NUMBER IS" & + COUNT'IMAGE(CN)); + END IF; + + -- TEST COLUMN NUMBER FOR STRING + + GET (FILE1, ST); + CN := COL (FILE1); + IF CN /= 7 THEN + FAILED ("COLUMN NUMBER NOT SET CORRECTLY " & + "- GET STRING. COL NUMBER IS" & + COUNT'IMAGE(CN)); + END IF; + + -- POSITION CURRENT INDEX TO END OF LINE + + WHILE NOT END_OF_LINE (FILE1) LOOP + GET (FILE1, CH); + END LOOP; + + IF CH /= 'E' THEN + FAILED ("CHARACTER NOT EQUAL TO E"); + END IF; + + -- TEST LINE NUMBER FOR CHARACTER + + GET(FILE1, CH); + IF CH /= 'L' THEN + FAILED ("CHARACTER NOT EQUAL TO L - 2"); + END IF; + LN := LINE (FILE1); + IF LN /= 2 THEN + FAILED ("LINE NUMBER NOT SET CORRECTLY " & + "- GET CHARACTER. LINE NUMBER IS" & + COUNT'IMAGE(LN)); + END IF; + IF PAGE (FILE1) /= POSITIVE_COUNT(IDENT_INT(1)) THEN + FAILED ("PAGE NUMBER NOT CORRECT - 1. PAGE IS" & + COUNT'IMAGE(PAGE(FILE1))); + END IF; + + -- TEST LINE NUMBER FOR STRING + + WHILE NOT END_OF_LINE (FILE1) LOOP + GET (FILE1, CH); + END LOOP; + GET (FILE1, ST); + IF ST /= "LINE " THEN + FAILED ("INCORRECT VALUE READ - ST"); + END IF; + LN := LINE (FILE1); + CN := COL (FILE1); + IF CN /= 6 THEN + FAILED ("COLUMN NUMBER NOT SET CORRECTLY " & + "- GET STRING. COL NUMBER IS" & + COUNT'IMAGE(CN)); + END IF; + IF LN /= 1 THEN + FAILED ("LINE NUMBER NOT SET CORRECTLY " & + "- GET STRING. LINE NUMBER IS" & + COUNT'IMAGE(LN)); + END IF; + IF PAGE (FILE1) /= POSITIVE_COUNT(IDENT_INT(2)) THEN + FAILED ("PAGE NUMBER NOT CORRECT - 2. PAGE IS" & + COUNT'IMAGE(PAGE(FILE1))); + END IF; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3602B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,202 ---- + -- CE3602C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET RAISES MODE_ERROR FOR FILES OF MODE OUT_FILE. + + -- APPLICABILITY CRITEIRA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 08/31/82 + -- SPS 12/17/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND CHECKED FOR + -- USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3602C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3602C", "CHECK THAT MODE_ERROR IS RAISED BY GET FOR " & + "FILES OF MODE OUT_FILE"); + + DECLARE + FILE1, FILE2 : FILE_TYPE; + CH : CHARACTER; + ST : STRING (1 .. 5); + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE - 1"); + RAISE INCOMPLETE; + END; + + BEGIN + CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE - 2"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FILE1, CH); + FAILED ("MODE_ERROR NOT RAISED - GET CHAR UN-NAMED " & + "FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHAR " & + "UN-NAMED FILE"); + END; + + BEGIN + GET (FILE2, CH); + FAILED ("MODE_ERROR NOT RAISED - GET CHAR NAMED FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHAR " & + "NAMED FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, CH); + FAILED ("MODE_ERROR NOT RAISED - GET CHAR " & + "STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHAR " & + "STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, CH); + FAILED ("MODE_ERROR NOT RAISED - GET CHAR " & + "CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET CHAR " & + "CURRENT_OUTPUT"); + END; + + BEGIN + GET (FILE1, ST); + FAILED ("MODE_ERROR NOT RAISED - GET STRING UN-NAMED " & + "FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING " & + "UN-NAMED FILE"); + END; + + BEGIN + GET (FILE2, ST); + FAILED ("MODE_ERROR NOT RAISED - GET STRING NAMED FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING " & + "NAMED FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, ST); + FAILED ("MODE_ERROR NOT RAISED - GET STRING " & + "STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING " & + "STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, ST); + FAILED ("MODE_ERROR NOT RAISED - GET STRING " & + "CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET STRING " & + "CURRENT_OUTPUT"); + END; + + CLOSE (FILE1); + + BEGIN + DELETE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3602C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3602d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,150 ---- + -- CE3602D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FILES ARE OF MODE IN_FILE AND THAT WHEN NO FILE IS + -- SPECIFIED THAT CURRENT DEFAULT INPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/06/82 + -- SPS 12/17/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 REMOVED DEPENDENCE ON RESET AND CORRECTED + -- EXCEPTION HANDLING. + + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3602D IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3602D", "CHECK THAT GET FOR STRINGS AND CHARACTERS " & + "OPERATES ON IN_FILE FILES"); + + DECLARE + FT , FILE : FILE_TYPE; + X : CHARACTER; + ST: STRING (1 .. 3); + BEGIN + + -- CREATE AND INITIALIZE FILES + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "ABCE"); + NEW_LINE (FT); + PUT (FT, "EFGHIJKLM"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FILE, "STRING"); + NEW_LINE (FILE); + PUT (FILE, "END OF OUTPUT"); + + CLOSE (FILE); + + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2)); + + SET_INPUT (FILE); + + -- BEGIN TEST + + GET (FT, X); + IF X /= IDENT_CHAR ('A') THEN + FAILED ("CHARACTER FROM FILE INCORRECT, WAS '" & + X & "'"); + END IF; + + GET (FT, ST); + IF ST /= "BCE" THEN + FAILED ("STRING FROM FILE INCORRECT; WAS """ & + ST & """"); + END IF; + + GET (X); + IF X /= IDENT_CHAR ('S') THEN + FAILED ("CHARACTER FROM DEFAULT INCORRECT; WAS '" & + X & "'"); + END IF; + + GET (ST); + IF ST /= "TRI" THEN + FAILED ("STRING FROM DEFAULT INCORRECT; WAS """ & + ST & """"); + END IF; + + BEGIN + DELETE (FT); + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3602D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3603a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,217 ---- + -- CE3603A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_ERROR IS NOT RAISED BY: + -- GET FOR CHARACTERS UNTIL ONLY LINE AND PAGE TERMINATORS REMAIN; + -- GET FROM STRING UNTIL FEWER CHARACTERS THAN NEEDED REMAIN; + -- GET_LINE UNTIL THE FINAL PAGE TERMINATOR HAS BEEN SKIPPED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 08/31/82 + -- JBG 12/23/82 + -- EG 05/22/85 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND REMOVED + -- DEPENDENCE ON RESET. + + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3603A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3603A", "CHECK THAT END_ERROR IS RAISED BY GET AFTER " & + "THE LAST CHARACTER IN THE FILE HAS BEEN READ"); + + DECLARE + FILE1 : FILE_TYPE; + OLDCH, CH : CHARACTER; + ST : STRING (1..10) := (1..10 => '.'); + COUNT : NATURAL; + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT" & + "CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, "LINE ONE"); + NEW_LINE (FILE1); + PUT (FILE1, "LINE TWO"); + NEW_LINE (FILE1, 3); + NEW_PAGE (FILE1); + NEW_PAGE (FILE1); + CLOSE (FILE1); + + BEGIN + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SKIP_LINE (FILE1); + GET (FILE1, ST(1..7)); + IF ST(1..7) /= "LINE TW" THEN + FAILED ("NOT POSITIONED RIGHT - GET CHAR"); + END IF; + + -- COUNT NUMBER OF CHARACTERS IN FIRST LINE (TO ALLOW FOR TRAILING + -- BLANKS) + + COUNT := 0; + WHILE NOT END_OF_LINE(FILE1) + LOOP + GET (FILE1, CH); + OLDCH := CH; + COUNT := COUNT + 1; + END LOOP; + + BEGIN + GET (FILE1, CH); + FAILED ("END_ERROR NOT RAISED - GET " & + "CHARACTER"); + EXCEPTION + WHEN END_ERROR => + IF CH /= OLDCH THEN + FAILED ("CH MODIFIED ON END_" & + "ERROR"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- GET CHARACTER"); + END; + + CLOSE (FILE1); + + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + + SKIP_LINE (FILE1); + GET (FILE1, ST(1..7)); + IF ST(1..7) /= "LINE TW" THEN + FAILED ("WRONG LINE 2. ACTUALLY READ '" & ST(1..7) & + "'"); + END IF; + + BEGIN + GET (FILE1, ST(8..8+COUNT)); + FAILED ("END_ERROR NOT RAISED - GET " & + "STRING"); + EXCEPTION + WHEN END_ERROR => + IF ST(1..7) /= "LINE TW" THEN + FAILED ("ST MODIFIED ON END_ERROR"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED " & + "- GET STRING"); + END; + + CLOSE (FILE1); + + END; + + DECLARE + LAST : NATURAL; + BEGIN + + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + + SKIP_LINE (FILE1); + GET_LINE (FILE1, ST, LAST); + IF LAST < 8 THEN + FAILED ("LAST < 8. LAST IS" & INTEGER'IMAGE(LAST)); + ELSIF ST(1..8) /= "LINE TWO" THEN + FAILED ("GET_LINE FAILED. ACTUALLY READ '" & + ST(1..8) & "'"); + END IF; + + SKIP_PAGE (FILE1); + SKIP_PAGE (FILE1); + + BEGIN + GET_LINE (FILE1, ST(1..1), LAST); + FAILED ("END_ERROR NOT RAISED - GET_LINE - 1"); + EXCEPTION + WHEN END_ERROR => + IF LAST /= 8 THEN + FAILED ("LAST MODIFIED BY GET_LINE " & + "ON END_ERROR. LAST IS" & + INTEGER'IMAGE(LAST)); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - GET_LINE - 1"); + END; + + BEGIN -- NULL ITEM ARGUMENT + GET_LINE (FILE1, ST(1..0), LAST); + EXCEPTION + WHEN END_ERROR => + FAILED ("GET_LINE ATTEMPTED TO READ INTO A " & + "NULL STRING"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION - GET_LINE - 2"); + END; + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3603A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3604a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,160 ---- + -- CE3604A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET_LINE MAY BE CALLED TO RETURN AN ENTIRE LINE. ALSO + -- CHECK THAT GET_LINE MAY BE CALLED TO RETURN THE REMAINDER OF A + -- PARTLY READ LINE. ALSO CHECK THAT GET_LINE RETURNS IN THE + -- PARAMETER LAST, THE INDEX VALUE OF THE LAST CHARACTER READ. + -- WHEN NO CHARACTERS ARE READ, LAST IS ONE LESS THAN ITEM'S LOWER + -- BOUND. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 09/25/87 COMPLETELY REVISED TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3604A IS + + BEGIN + + TEST ("CE3604A", "CHECK THAT GET_LINE READS LINES APPROPRIATELY " & + "AND CHECK THAT LAST RETURNS THE CORRECT INDEX " & + "VALUE"); + + DECLARE + FILE : FILE_TYPE; + STR : STRING (1 .. 25); + LAST : NATURAL; + ITEM1 : STRING (2 .. 6); + ITEM2 : STRING (3 .. 6); + CH : CHARACTER; + INCOMPLETE : EXCEPTION; + + BEGIN + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "FIRST LINE OF INPUT"); + NEW_LINE (FILE); + PUT (FILE, "SECOND LINE OF INPUT"); + NEW_LINE (FILE); + PUT (FILE, "THIRD LINE OF INPUT"); + NEW_LINE (FILE); + NEW_LINE (FILE); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET_LINE (FILE, STR, LAST); + + BEGIN + IF STR(1..LAST) /= "FIRST LINE OF INPUT" THEN + FAILED ("GET_LINE - RETURN OF ENTIRE LINE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED AFTER " & + "GET_LINE - 1"); + END; + + GET (FILE, ITEM1); + GET_LINE (FILE, STR, LAST); + + BEGIN + IF STR(1..LAST) /= "D LINE OF INPUT" THEN + FAILED ("GET_LINE - REMAINDER OF PARTLY READ LINE"); + END IF; + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED AFTER " & + "GET_LINE - 2"); + END; + + GET_LINE (FILE, ITEM1, LAST); + IF LAST /= 6 THEN + FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 1"); + END IF; + + WHILE NOT END_OF_LINE (FILE) LOOP + GET (FILE, CH); + END LOOP; + + GET_LINE (FILE, ITEM1, LAST); + IF LAST /= 1 THEN + FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 2"); + END IF; + + IF NOT END_OF_LINE (FILE) THEN + FAILED ("END_OF_LINE NOT TRUE"); + END IF; + + GET_LINE (FILE, ITEM2, LAST); + IF LAST /= 2 THEN + FAILED ("INCORRECT VALUE FOR LAST PARAMETER - 3"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3604A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3604b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- CE3604B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET_LINE DOES NOT DO A SKIP_LINE AND NO CHARACTERS ARE + -- READ WHEN THE INPUT IS AT THEN END OF A LINE AND THE STRING + -- PARAMETER IS A NULL STRING. ALSO CHECK THAT GET_LINE DOES NOT + -- SKIP THE LINE TERMINATOR AFTER READING ALL THE CHARACTERS INTO + -- A STRING WHICH IS EXACTLY EQUAL TO THE NUMBER OF CHARACTERS + -- REMAINING ON THAT LINE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 10/13/87 CREATED ORIGINAL TEST. + + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3604B IS + + BEGIN + + TEST ("CE3604B", "CHECK THAT GET_LINE READS LINES APPROPRIATELY"); + + DECLARE + INCOMPLETE : EXCEPTION; + FILE : FILE_TYPE; + ITEM1 : STRING (1 .. 19); + ITEM2 : STRING (1 .. 20); + NULL_ITEM : STRING (2 .. 1); + LAST : NATURAL; + + BEGIN + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT " & + "CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "FIRST LINE OF INPUT"); + NEW_LINE (FILE); + PUT (FILE, "SECOND LINE OF INPUT"); + NEW_LINE (FILE); + PUT (FILE, "THIRD LINE OF INPUT"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM1); + IF ITEM1 /= "FIRST LINE OF INPUT" THEN + FAILED ("INCORRECT VALUE FOR GET"); + END IF; + + GET_LINE (FILE, NULL_ITEM, LAST); + + IF LINE (FILE) /= 1 THEN + FAILED ("INCORRECT LINE NUMBER AFTER GET_LINE - 1"); + END IF; + + IF COL (FILE) /= 20 THEN + FAILED ("INCORRECT COLUMN NUMBER AFTER GET_LINE - 1"); + END IF; + + SKIP_LINE (FILE); + GET_LINE (FILE, ITEM2, LAST); + IF ITEM2 /= "SECOND LINE OF INPUT" THEN + FAILED ("INCORRECT VALUE FOR GET_LINE"); + END IF; + + IF LINE (FILE) /= 2 THEN + FAILED ("INCORRECT LINE NUMBER AFTER GET_LINE - 2"); + END IF; + + IF COL (FILE) /= 21 THEN + FAILED ("INCORRECT COLUMN NUMBER AFTER GET_LINE - 2"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3604B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- CE3605A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR CHARACTER AND STRING PARAMETERS DOES NOT + -- UPDATE THE LINE NUMBER WHEN THE LINE LENGTH IS UNBOUNDED, + -- ONLY THE COLUMN NUMBER. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- SPS 09/02/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 CORRECTED EXCEPTION HANDLING AND ADDED CHECKS + -- FOR COLUMN NUMBER. + -- RJW 03/28/90 REVISED NUMERIC LITERALS USED IN LOOPS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3605A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3605A", "CHECK THAT PUT FOR CHARACTER AND STRING " & + "PARAMETERS DOES NOT UPDATE THE LINE NUMBER " & + "WHEN THE LINE LENGTH IS UNBOUNDED, ONLY THE " & + "COLUMN NUMBER"); + + DECLARE + FILE1 : FILE_TYPE; + LN : POSITIVE_COUNT := 1; + BEGIN + + BEGIN + CREATE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILES WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + LN := LINE (FILE1); + + IF LN /= 1 THEN + FAILED ("CURRENT LINE NUMBER NOT INITIALLY ONE"); + END IF; + + IF COL (FILE1) /= 1 THEN + FAILED ("CURRENT COLUMN NUMBER NOT INITIALLY ONE"); + END IF; + + FOR I IN 1 .. IDENT_INT(240) LOOP + PUT(FILE1, 'A'); + END LOOP; + IF LINE (FILE1) /= LN THEN + FAILED ("PUT ALTERED LINE NUMBER - CHARACTER"); + END IF; + + IF COL(FILE1) /= 241 THEN + FAILED ("COLUMN NUMBER NOT UPDATED CORRECTLY - 1"); + END IF; + + NEW_LINE(FILE1); + LN := LINE (FILE1); + + FOR I IN 1 .. IDENT_INT(40) LOOP + PUT (FILE1, "STRING"); + END LOOP; + IF LN /= LINE (FILE1) THEN + FAILED ("PUT ALTERED LINE NUMBER - STRING"); + END IF; + + IF COL(FILE1) /= 241 THEN + FAILED ("COLUMN NUMBER NOT UPDATED CORRECTLY - 2"); + END IF; + + CLOSE (FILE1); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3605A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- CE3605B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE; + -- CHECK THAT PUT OUTPUTS A LINE TERMINATOR, RESETS THE COLUMN + -- NUMBER AND INCREMENTS THE LINE NUMBER WHEN THE LINE LENGTH IS + -- BOUNDED AND THE COLUMN NUMBER EQUALS THE LINE LENGTH WHEN PUT + -- IS CALLED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/02/82 + -- JBG 12/28/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 GAVE FILE A NAME AND REMOVED CODE WHICH RESETS + -- THE FILE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + PROCEDURE CE3605B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3605B", "CHECK THAT PUT PROPERLY MAINTAINS THE " & + "LINE NUMBER AND COLUMN NUMBER WHEN THE " & + "LINE LENGTH IS BOUNDED"); + + DECLARE + FILE1 : FILE_TYPE; + LN_CNT : POSITIVE_COUNT; + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FILE1, 5); + LN_CNT := LINE (FILE1); + + FOR I IN 1 .. 5 LOOP + PUT (FILE1, 'X'); + END LOOP; + + IF COL(FILE1) /= 6 THEN + FAILED ("COLUMN NUMBER NOT INCREMENTED - PUT; " & + "VALUE WAS" & COUNT'IMAGE(COL(FILE1))); + END IF; + + IF LINE(FILE1) /= LN_CNT THEN + FAILED ("LINE COUNT MODIFIED - PUT CHARACTER; " & + "VALUE WAS" & COUNT'IMAGE(LINE(FILE1))); + END IF; + + PUT (FILE1, 'X'); + IF COL(FILE1) /= 2 THEN + FAILED ("COLUMN NUMBER NOT RESET - PUT CHARACTER; " & + "VALUE WAS" & COUNT'IMAGE(COL(FILE1))); + END IF; + + IF LINE(FILE1) /= LN_CNT + 1 THEN + FAILED("LINE NUMBER NOT INCREMENTED - PUT CHARACTER; " & + "VALUE WAS" & COUNT'IMAGE(LINE(FILE1))); + END IF; + + NEW_LINE (FILE1); + + SET_LINE_LENGTH (FILE1, 4); + LN_CNT := LINE (FILE1); + + PUT (FILE1, "XXXX"); + + IF COL(FILE1) /= 5 THEN + FAILED ("COLUMN NUMBER NOT INCREMENTED - PUT STRING; " & + "VALUE WAS" & COUNT'IMAGE(COL(FILE1))); + END IF; + + IF LINE (FILE1) /= LN_CNT THEN + FAILED ("LINE NUMBER INCREMENTED - PUT STRING; " & + "VALUE WAS" & COUNT'IMAGE(LINE (FILE1))); + END IF; + + PUT (FILE1, "STR"); + + IF COL(FILE1) /= 4 THEN + FAILED ("COLUMN NUMBER NOT SET CORRECTLY - PUT" & + "STRING; VALUE WAS" & COUNT'IMAGE(COL(FILE1))); + END IF; + + IF LINE (FILE1) /= LN_CNT + 1 THEN + FAILED ("LINE NUMBER NOT INCREMENTED - PUT STRING; " & + "VALUE WAS" & COUNT'IMAGE(LINE (FILE1))); + END IF; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3605B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- CE3605C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT RAISES MODE_ERROR FOR FILES OF MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/02/82 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3605C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3605C", "MODE_ERROR RAISED BY PUT FOR IN_FILES"); + + DECLARE + FILE1 : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE1, 'A'); + CLOSE (FILE1); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FILE1, 'A'); + FAILED ("MODE_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + PUT (STANDARD_INPUT, 'A'); + FAILED ("MODE_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + BEGIN + PUT (CURRENT_INPUT, 'A'); + FAILED ("MODE_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + BEGIN + PUT (FILE1, "STRING"); + FAILED ("MODE_ERROR NOT RAISED - 4"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; + + BEGIN + PUT (STANDARD_INPUT, "STRING"); + FAILED ("MODE_ERROR NOT RAISED - 5"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 5"); + END; + + BEGIN + PUT (CURRENT_INPUT, "STRING"); + FAILED ("MODE_ERROR NOT RAISED - 6"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6"); + END; + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3605C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- CE3605D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT DOES NOT RAISE LAYOUT_ERROR WHEN THE NUMBER OF + -- CHARACTERS TO BE OUTPUT EXCEEDS THE LINE LENGTH. + -- CHECK THAT PUT HAS THE EFFECT OF NEW_LINE (AS WELL AS + -- OUTPUTTING THE ITEM) WHEN THE NUMBER OF CHARACTERS TO BE OUTPUT + -- OVERFLOWS A BOUNDED LINE LENGTH. + -- CHECK THAT PUT WITH A NULL STRING PERFORMS NO OPERATION. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/02/82 + -- JBG 12/28/82 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + PROCEDURE CE3605D IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3605D", "CHECK THAT LAYOUT_ERROR IS NOT RAISED BY PUT " & + "FOR STRING"); + + DECLARE + FT : FILE_TYPE; + LC : POSITIVE_COUNT; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON " & + "TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 5); + + BEGIN + PUT (FT, "STRING"); + + IF LINE(FT) /= 2 THEN + FAILED ("LINE COUNT WAS" & COUNT'IMAGE(LINE(FT)) & + " INSTEAD OF 2"); + END IF; + + IF COL(FT) /= 2 THEN + FAILED ("COLUMN COUNT WAS" & COUNT'IMAGE(COL(FT)) & + " INSTEAD OF 2"); + END IF; + + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 1"); + + END; + + PUT (FT, "NEW"); + + IF LINE(FT) /= 2 THEN + FAILED ("LINE COUNT WRONG - 2; WAS" & + COUNT'IMAGE(LINE(FT)) & + " INSTEAD OF 2"); + END IF; + + IF COL(FT) /= 5 THEN + FAILED ("COL COUNT WRONG - 2; WAS" & + COUNT'IMAGE(COL(FT)) & + " INSTEAD OF 5"); + END IF; + + BEGIN + PUT (FT, "STR"); + IF LINE (FT) /= 3 THEN + FAILED ("PUT STRING WHEN IN MIDDLE OF " & + "LINE DOES NOT HAVE EFFECT OF " & + "NEW_LINE; LINE COUNT IS" & + COUNT'IMAGE(LINE(FT))); + END IF; + + IF COL(FT) /= 3 THEN + FAILED ("COL COUNT WRONG - 3; WAS" & + COUNT'IMAGE(COL(FT)) & + " INSTEAD OF 3"); + END IF; + + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 2"); + END; + + PUT (FT, "ING"); + + IF LINE(FT) /= 3 THEN + FAILED ("LINE COUNT WRONG - 3; WAS" & + COUNT'IMAGE(LINE(FT)) & + " INSTEAD OF 3"); + END IF; + + IF COL(FT) /= 6 THEN + FAILED ("COL COUNT WRONG - 3; WAS" & + COUNT'IMAGE(COL(FT)) & + " INSTEAD OF 6"); + END IF; + + BEGIN + PUT (FT, ""); + + IF LINE(FT) /= 3 THEN + FAILED ("LINE COUNT WRONG - 3; WAS" & + COUNT'IMAGE(LINE(FT)) & + " INSTEAD OF 3"); + END IF; + + IF COL(FT) /= 6 THEN + FAILED ("COL COUNT WRONG - 3; WAS" & + COUNT'IMAGE(COL(FT)) & + " INSTEAD OF 6"); + END IF; + + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED - 3"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - 3"); + END; + + CHECK_FILE (FT, + "STRIN#" & + "GNEWS#" & + "TRING#@%"); + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3605D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3605e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CE3605E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT CAN BE CALLED WITH CHARACTER AND STRING + -- PARAMETERS. CHECK THAT FILES OF MODE OUT_FILE ARE USED AND + -- THAT WHEN NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE + -- IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- SPS 10/06/82 + -- JBG 12/28/82 + -- VKG 02/15/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/08/87 REMOVED UNNECESSARY CODE AND CHECKED FOR + -- USE_ERROR ON DELETE. + + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + PROCEDURE CE3605E IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3605E", "CHECK THAT PUT FOR STRINGS AND CHARACTERS " & + "OPERATES ON OUT_FILE FILES"); + + DECLARE + FT , FILE : FILE_TYPE; + X : CHARACTER; + BEGIN + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FILE); + + SET_OUTPUT (FILE); + + PUT (FT, 'O'); + + PUT (FT, "UTPUT STRING"); + + PUT ('X'); + + PUT ("UTPUT STRING"); + + -- CHECK OUTPUT + + SET_OUTPUT (STANDARD_OUTPUT); + COMMENT ("CHECKING FT"); + CHECK_FILE (FT, "OUTPUT STRING#@%"); + COMMENT ("CHECKING FILE"); + CHECK_FILE (FILE, "XUTPUT STRING#@%"); + + CLOSE (FT); + CLOSE (FILE); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3605E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3606a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + -- CE3606A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT_LINE WILL OUTPUT A LINE TERMINATOR WHEN THE + -- STRING PARAMETER IS NULL. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEMPORARY TEXT FILES. + + -- HISTORY: + -- SPS 09/02/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + PROCEDURE CE3606A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3606A", "PUT_LINE PUTS LINE TERMINATOR WHEN STRING " & + "IS NULL"); + + DECLARE + FT : FILE_TYPE; + NS1 : STRING (1 .. 0); + NS2 : STRING (3 .. 1); + LC : POSITIVE_COUNT := 1; + BEGIN + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILES WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + PUT_LINE (FT, NS1); + IF LINE (FT) /= LC + 1 THEN + FAILED ("PUT_LINE OF NULL STRING 1; LINE " & + "COUNT WAS" & COUNT'IMAGE(LINE(FT))); + END IF; + + PUT_LINE (FT, NS2); + IF LINE (FT) /= LC + 2 THEN + FAILED ("PUT_LINE OF NULL STRING 2; LINE " & + "COUNT WAS" & COUNT'IMAGE(LINE(FT))); + END IF; + + CHECK_FILE (FT, "##@%"); + + CLOSE (FT); + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3606A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3606b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + -- CE3606B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT_LINE WILL OUTPUT A LINE ON MORE THAN ONE LINE + -- WHEN THE LINE LENGTH IS BOUNDED, IF THE STRING IS GREATER + -- THAN THE LINE LENGTH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEMPORARY TEXT FILES. + + -- HISTORY: + -- SPS 09/02/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + PROCEDURE CE3606B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3606B", "CHECK THAT PUT_LINE WILL OUTPUT A LINE " & + "ON MORE THAN ONE LINE WHEN THE LINE " & + "LENGTH IS BOUNDED, IF THE STRING IS " & + "GREATER THAN THE LINE LENGTH"); + + DECLARE + FT : FILE_TYPE; + LONG_LINE : CONSTANT STRING := "THIS LINE IS A LONG " & + "LINE WHICH WHEN OUTPUT SHOULD SPAN OVER SEVERAL " & + "LINES IN THE OUTPUT FILE"; + BEGIN + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILES WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 10); + + PUT_LINE (FT, LONG_LINE); + PUT_LINE (FT, "AA"); + + CHECK_FILE (FT, "THIS LINE #" & + "IS A LONG #" & + "LINE WHICH#" & + " WHEN OUTP#" & + "UT SHOULD #" & + "SPAN OVER #" & + "SEVERAL LI#" & + "NES IN THE#" & + " OUTPUT FI#" & + "LE#" & + "AA#@%"); + + CLOSE (FT); + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3606B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3701a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- CE3701A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET AND PUT OF INTEGER_IO RAISE STATUS_ERROR IF + -- THE FILE IS NOT OPEN. + + -- HISTORY: + -- ABW 08/27/82 + -- JBG 08/30/83 + -- DWC 09/09/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION + -- HANDLING, AND ATTEMPTED TO CREATE A FILE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3701A IS + + PACKAGE INT_IO IS NEW INTEGER_IO (INTEGER); + USE INT_IO; + FILE : FILE_TYPE; + INT_ITEM : INTEGER := 7; + + BEGIN + + TEST ("CE3701A", "CHECK THAT GET AND PUT RAISE " & + "STATUS_ERROR IF THE FILE " & + "IS NOT OPEN"); + + BEGIN + PUT (FILE, IDENT_INT(8)); + FAILED ("STATUS_ERROR NOT RAISED WHEN PUT APPLIED " & + "TO A NON-EXISTENT FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN PUT " & + "APPLIED TO A NON-EXISTENT FILE"); + END; + + BEGIN + GET (FILE, INT_ITEM); + FAILED ("STATUS_ERROR NOT RAISED WHEN GET APPLIED " & + "TO A NON-EXISTENT FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN GET " & + "APPLIED TO A NON-EXISTENT FILE"); + END; + + BEGIN + CREATE (FILE); -- THIS IS JUST AN ATTEMPT TO CREATE + CLOSE (FILE); -- A FILE. WHETHER THIS IS SUCCESSFUL + EXCEPTION -- OR NOT HAS NO EFFECT ON TEST + WHEN USE_ERROR => -- OBJECTIVE. + NULL; + END; + + BEGIN + PUT (FILE, IDENT_INT(8)); + FAILED ("STATUS_ERROR NOT RAISED WHEN PUT APPLIED " & + "TO AN UNOPENED FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN PUT " & + "APPLIED TO AN UNOPENED FILE"); + END; + + BEGIN + GET (FILE, INT_ITEM); + FAILED ("STATUS_ERROR NOT RAISED WHEN GET APPLIED " & + "TO AN UNOPENED FILE"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED WHEN GET " & + "APPLIED TO AN UNOPENED FILE"); + END; + + RESULT; + + END CE3701A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- CE3704A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- HISTORY: + -- CHECK THAT GET FOR INTEGER_IO CAN OPERATE ON ANY FILE OF MODE + -- IN_FILE AND THAT IF NO FILE IS SPECIFIED THE CURRENT DEFAULT + -- INPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/01/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION + -- HANDLING, AND REMOVED DEPENDENCE ON RESET. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704A", "CHECK THAT GET FOR INTEGER_IO CAN OPERATE " & + "ON ANY FILE OF MODE IN_FILE AND THAT IF " & + "NO FILE IS SPECIFIED THE CURRENT DEFAULT " & + "INPUT FILE IS USED"); + + DECLARE + FT : FILE_TYPE; + FT2: FILE_TYPE; + TYPE NI IS NEW INTEGER RANGE 1 .. 700; + X : NI; + PACKAGE IIO IS NEW INTEGER_IO (NI); + USE IIO; + BEGIN + + -- CREATE AND INITIALIZE DATA FILES + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, '3'); + PUT (FT, '6'); + PUT (FT, '9'); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FT2, '6'); + PUT (FT2, '2'); + PUT (FT2, '4'); + + CLOSE (FT2); + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + SET_INPUT (FT2); + + GET (FT, X); + + IF X /= 369 THEN + FAILED ("GET RETURNED WRONG VALUE; VALUE WAS" & + NI'IMAGE(X)); + END IF; + + GET (X); + + IF X /= 624 THEN + FAILED ("GET FOR DEFAULT WAS WRONG; VALUE WAS" & + NI'IMAGE(X)); + END IF; + + BEGIN + DELETE (FT); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- CE3704B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET RAISES MODE_ERROR FOR FILES OF MODE + -- OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/04/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704B", "CHECK THAT INTEGER_IO GET RAISES " & + "MODE_ERROR FOR FILES OF MODE OUT_FILE"); + + DECLARE + FT : FILE_TYPE; + TYPE INT IS NEW INTEGER RANGE 1 .. 10; + PACKAGE IIO IS NEW INTEGER_IO (INT); + USE IIO; + X : INT := 10; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE); + PUT (FT, '3'); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X); + FAILED ("MODE_ERROR NOT RAISED - FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CURRENT_OUTPUT"); + END; + + CLOSE (FT); + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,176 ---- + -- CE3704C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET RAISES CONSTRAINT_ERROR IF THE + -- WIDTH PARAMETER IS NEGATIVE, IF THE WIDTH PARAMETER IS + -- GREATER THAN FIELD'LAST WHEN FIELD'LAST IS LESS THAN + -- INTEGER'LAST, OR THE VALUE READ IS OUT OF THE RANGE OF + -- THE ITEM PARAMETER BUT WITHIN THE RANGE OF INSTANTIATED + -- TYPE. + + -- HISTORY: + -- SPS 10/04/82 + -- DWC 09/09/87 ADDED CASES FOR WIDTH BEING GREATER THAN + -- FIELD'LAST AND THE VALUE BEING READ IS OUT + -- OF ITEM'S RANGE BUT WITHIN INSTANTIATED + -- RANGE. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704C", "CHECK THAT INTEGER_IO GET RAISES " & + "CONSTRAINT_ERROR IF THE WIDTH PARAMETER " & + "IS NEGATIVE, IF THE WIDTH PARAMETER IS " & + "GREATER THAN FIELD'LAST WHEN FIELD'LAST IS " & + "LESS THAN INTEGER'LAST, OR THE VALUE READ " & + "IS OUT OF THE RANGE OF THE ITEM PARAMETER " & + "BUT WITHIN THE RANGE OF INSTANTIATED TYPE"); + + DECLARE + FT : FILE_TYPE; + TYPE INT IS NEW INTEGER RANGE 1 .. 10; + PACKAGE IIO IS NEW INTEGER_IO (INT); + X : INT RANGE 1 .. 5; + USE IIO; + BEGIN + + BEGIN + GET (FT, X, IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("RAISED STATUS_ERROR"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE"); + END; + + BEGIN + GET (X, IDENT_INT(-6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DEFAULT"); + END; + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, 1); + NEW_LINE (FT); + PUT (FT, 8); + NEW_LINE (FT); + PUT (FT, 2); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR FOR OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X, IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + END; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "OUT OF RANGE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "OUT OF RANGE"); + END; + + SKIP_LINE (FT); + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + GET (FT, X, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + END; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE3704C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,169 ---- + -- CE3704D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET READS AT MOST WIDTH CHARACTERS + -- OR UP TO THE NEXT TERMINATOR; INCLUDING LEADING BLANKS + -- AND HORIZONTAL TABULATION CHARACTERS, WHEN WIDTH IS + -- NONZERO. + + -- CHECK THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS + -- ENCOUNTERED AND THAT DATA_ERROR IS RAISED IF THE DATA + -- READ IS INVALID. + + -- APPLICABILITY CRITERIA: + + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/04/82 + -- VKG 01/12/83 + -- SPS 02/08/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/09/87 ADDED CASES FOR TABS, REMOVED UNNECESSARY + -- CODE, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704D IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704D", "CHECK THAT INTEGER_IO GET READS AT MOST " & + "WIDTH CHARACTERS OR UP TO THE NEXT " & + "TERMINATOR; INCLUDING LEADING BLANKS AND " & + "HORIZONTAL TABULATION CHARACTERS, WHEN WIDTH " & + "IS NONZERO"); + + DECLARE + FT : FILE_TYPE; + X : INTEGER; + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + BEGIN + + -- CREATE AND INITIALIZE FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, " 123"); + NEW_LINE (FT); + PUT (FT, "-5678"); + NEW_LINE (FT); + PUT (FT, " "); + NEW_PAGE (FT); + PUT (FT, ASCII.HT & "9"); + NEW_PAGE (FT); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- BEGIN TEST + + GET (FT, X, 5); + IF X /= IDENT_INT (123) THEN + FAILED ("WIDTH CHARACTERS NOT READ - 1"); + ELSE + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED -1"); + END; + SKIP_LINE (FT); + GET (FT, X, 6); + IF X /= IDENT_INT (-5678) THEN + FAILED ("GET WITH WIDTH " & + "INCORRECT - 2"); + ELSE + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + SKIP_LINE(FT); + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + SKIP_LINE(FT); + GET (FT, X, 2); + IF X /= IDENT_INT (9) THEN + FAILED ("GET WITH WIDTH " & + "INCORRECT - 3"); + END IF; + END IF; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,143 ---- + -- CE3704E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET RAISES DATA_ERROR WHEN THE LEXICAL + -- ELEMENT IS NOT OF THE INTEGER TYPE EXPECTED. CHECK THAT ITEM + -- IS UNAFFECTED AND READING CAN CONTINUE AFTER THE EXCEPTION + -- HAS BEEN HANDLED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/04/82 + -- VKG 01/14/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/10/87 REMOVED UNNECCESSARY CODE, CORRECTED EXCEPTION + -- HANDLING, AND CHECKED FOR USE_ERROR ON DELETE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704E IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704E", "CHECK THAT INTEGER_IO GET RAISES DATA_ERROR " & + "WHEN THE LEXICAL ELEMENT IS NOT OF THE " & + "INTEGER TYPE EXPECTED. CHECK THAT ITEM " & + "IS UNAFFECTED AND READING CAN CONTINUE AFTER " & + "THE EXCEPTION HAS BEEN HANDLED"); + + DECLARE + FT : FILE_TYPE; + TYPE INT IS NEW INTEGER RANGE 10 .. 20; + PACKAGE IIO IS NEW INTEGER_IO (INT); + USE IIO; + X : INT := 16; + BEGIN + + -- CREATE AND INITIALIZE FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, " 101 12"); + CLOSE(FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 16 THEN + FAILED ("ITEM AFFECTED BY GET WHEN DATA" & + "_ERROR IS RAISED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + GET (FT, X, 3); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 16 THEN + FAILED ("ITEM AFFECTED BY GET WHEN DATA" & + "_ERROR IS RAISED"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + BEGIN + GET (FT, X, 2); + IF X /= 12 THEN + FAILED ("READING NOT CONTINUED CORRECTLY " & + "AFTER EXCEPTION"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("GET OF CORRECT DATA RAISED EXCEPTION"); + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,365 ---- + -- CE3704F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET DOES NOT ALLOW EMBEDDED BLANKS OR + -- CONSECUTIVE UNDERSCORES TO BE INPUT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/04/82 + -- VKG 01/14/83 + -- CPP 07/30/84 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/10/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION + -- HANDLING, AND ADDED MORE CHECKS OF THE VALUES + -- OF CHARACTERS READ. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704F IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704F", "INTEGER_IO GET DOES NOT ALLOW EMBEDDED " & + "BLANKS OR CONSECUTIVE UNDERSCORES"); + + DECLARE + FT : FILE_TYPE; + X : INTEGER; + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + CH : CHARACTER; + P : POSITIVE; + BEGIN + + -- CREATE AND INITIALIZE FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "12_345"); + NEW_LINE (FT); + PUT (FT, "12 345"); + NEW_LINE (FT); + PUT (FT, "1__345"); + NEW_LINE (FT); + PUT (FT, "-56"); + NEW_LINE (FT); + PUT (FT, "10E0"); + NEW_LINE (FT); + PUT (FT, "10E-2X"); + NEW_LINE (FT); + PUT (FT, "4E1__2"); + NEW_LINE (FT); + PUT (FT, "1 0#99#"); + NEW_LINE (FT); + PUT (FT, "1__0#99#"); + NEW_LINE (FT); + PUT (FT, "10#9_9#"); + NEW_LINE (FT); + PUT (FT, "10#9__9#"); + NEW_LINE (FT); + PUT (FT, "10#9 9#"); + NEW_LINE (FT); + PUT (FT, "16#E#E1"); + NEW_LINE (FT); + PUT (FT, "2#110#E1_1"); + NEW_LINE (FT); + PUT (FT, "2#110#E1__1"); + CLOSE(FT); + + -- BEGIN TEST + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; " & + "TEXT OPEN WITH IN_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= 12345 THEN + FAILED ("GET WITH UNDERSCORE INCORRECT - (1)"); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 6); + FAILED ("DATA_ERROR NOT RAISED - (2)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (2)"); + END; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (3)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (3)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (3)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(3): CHAR IS " & CH); + END IF; + GET (FT, CH); + IF CH /= '3' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(3.5): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + GET (FT, X); + IF X /= (-56) THEN + FAILED ("GET WITH GOOD CASE INCORRECT - (4)"); + END IF; + + SKIP_LINE (FT); + GET (FT, X, 4); + IF X /= 10 THEN + FAILED ("GET WITH ZERO EXPONENT INCORRECT - (5)"); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (6)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (6)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (6)"); + ELSE + GET (FT, CH); + IF CH /= 'X' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(6): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (7)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (7)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (7)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(7): CHAR IS " & CH); + END IF; + GET (FT, CH); + IF CH /= '2' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(7.5): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 7); + FAILED ("DATA_ERROR NOT RAISED - (8)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (8)"); + END; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (9)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (9)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (9)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (9): CHAR IS " & CH); + END IF; + GET (FT, CH); + IF CH /= '0' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (9.5): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + GET (FT, X); + IF X /= 99 THEN + FAILED ("GET WITH UNDERSCORE IN " & + "BASED LITERAL INCORRECT - (10)"); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (11)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (11)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (11)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(11): CHAR IS " & CH); + END IF; + GET (FT, CH); + IF CH /= '9' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(11.5): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 6); + FAILED ("DATA_ERROR NOT RAISED - (12)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (12)"); + END; + + SKIP_LINE (FT); + GET (FT, X, 7); + IF X /= 224 THEN + FAILED ("GET WITH GOOD CASE OF " & + "BASED LITERAL INCORRECT - (13)"); + END IF; + + SKIP_LINE (FT); + GET (FT, X, 10); + IF X /= (6 * 2 ** 11) THEN + FAILED ("GET WITH UNDERSCORE IN EXPONENT" & + "OF BASED LITERAL INCORRECT - (14)"); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (15)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (15)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (15)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(15): CHAR IS " & CH); + END IF; + GET (FT, CH); + IF CH /= '1' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(15.5): CHAR IS " & CH); + END IF; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704m.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- CE3704M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR INTEGER_IO RAISES DATA_ERROR WHEN + -- THE INPUT CONTAINS + -- + -- (1) INTEGER_IO DECIMAL POINT + -- (2) INTEGER_IO LEADING OR TRAILING UNDERSCORES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- VKG 02/10/83 + -- CPP 07/30/84 + -- EG 05/22/85 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 REMOVED UNNECESSARY CODE, CORRECTED + -- EXCEPTION HANDLING, AND ADDED CASES WHICH + -- CHECK GET AT THE END_OF_FILE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3704M IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3704M", "CHECK THAT DATA_ERROR IS RAISED FOR " & + "INTEGER_IO WHEN A DECIMAL POINT, OR " & + "LEADING OR TRAILING UNDERSCORES " & + "ARE DETECTED"); + + DECLARE + FT : FILE_TYPE; + CH : CHARACTER; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "3.14152"); + NEW_LINE (FT); + PUT (FT, "2.15"); + NEW_LINE (FT); + PUT (FT, "_312"); + NEW_LINE (FT); + PUT (FT, "-312_"); + + CLOSE (FT); + + DECLARE + PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER); + USE INT_IO; + X : INTEGER := 402; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X, 3); + FAILED ("DATA_ERROR NOT RAISED - (1)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - (1)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (1)"); + ELSE + GET (FT, CH); + IF CH /= '4' THEN + FAILED ("GET STOPPED AT WRONG " & + "POSITION - (1): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + IF X /= 2 THEN + FAILED ("WRONG VALUE READ - (2)"); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - (2)"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - (2)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (2)"); + ELSE + GET (FT, CH); + IF CH /= '.' THEN + FAILED ("GET STOPPED AT WRONG " & + "POSITION - (2): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (3)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - (3)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (3)"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (3): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (4)"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - (4)"); + END; + + IF NOT END_OF_LINE (FT) THEN + FAILED ("END_OF_LINE NOT TRUE AFTER (4)"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704n.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,229 ---- + -- CE3704N.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR INTEGER_IO RAISES DATA_ERROR WHEN: + -- (A) BASE LESS THAN 2 OR GREATER THAN 16 + -- (B) THE LETTERS IN BASE ARE OUT OF THE BASE RANGE + -- (C) THERE IS NO CLOSING '#' SIGN FOR A BASED LITERAL + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- VKG 02/10/83 + -- SPS 03/16/83 + -- CPP 07/30/84 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 REMOVED UNNECESSARY CODE, CORRECTED + -- EXCEPTION HANDLING, AND CHECKED FOR + -- USE_ERROR ON DELETE. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT ; USE REPORT ; + + PROCEDURE CE3704N IS + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3704N" ,"CHECK THAT DATA_ERROR IS RAISED WHEN " & + "A BASED LITERAL DOES NOT HAVE ITS BASE " & + "IN THE RANGE 2 .. 16, DIGIT IS OUTSIDE " & + "THE BASE RANGE, OR THERE IS NO CLOSING " & + "'#' SIGN"); + + DECLARE + FT : FILE_TYPE; + BEGIN + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "1#0000#"); + NEW_LINE (FT); + PUT (FT, "A#234567#"); + NEW_LINE (FT); + PUT (FT, "17#123#1"); + NEW_LINE (FT); + PUT (FT, "5#1253#2"); + NEW_LINE (FT); + PUT (FT, "8#123"); + CLOSE (FT); + + DECLARE + PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER); + USE INT_IO; + X : INTEGER := 1003; + CH : CHARACTER; + BEGIN + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (1)"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1003 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (1)"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(1): CHAR IS " & CH); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (2)"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1003 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - (2)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (2)"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - (2)"); + ELSE + GET (FT, CH); + IF CH /= 'A' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (2): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (2A)"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1003 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - (2A)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (2A)"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + IF CH /= '1' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (2A): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (3)"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1003 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - (3)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (3)"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + IF CH /= '2' THEN + FAILED ("GET STOPPED AT WRONG POSITION - " & + "(3): CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - (4)"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1003 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - (4)"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - (4)"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- (4): CHAR IS " & CH); + END IF; + END IF; + + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3704N; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3704o.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- CE3704O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET WILL RAISE DATA_ERROR IF THE USE OF # AND : + -- IN BASED LITERALS IS MIXED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- VKG 02/10/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE3704O IS + + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3704O", "CHECK THAT MIXED USE OF # AND : " & + "IN BASED LITERALS WILL RAISE DATA_ERROR"); + + DECLARE + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + + PUT_LINE (FT, "8#77#E+1"); + PUT_LINE (FT, "2:110:"); + PUT (FT, "2#11:"); + NEW_LINE (FT); + PUT (FT, "4:223#"); + NEW_LINE (FT); + CLOSE (FT); + + + DECLARE + PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER); + USE INT_IO; + X : INTEGER := 100; + CH : CHARACTER; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= 8#77#E+1 THEN + FAILED ("INCORRECT VALUE - 1"); + END IF; + + GET (FT, X); + IF X /= 2#110# THEN + FAILED ("INCORRECT VALUE - 2"); + END IF; + + BEGIN + X := 100; + GET (FT,X); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 100 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + IF CH /= ':' THEN + FAILED ("GET STOPPED AT WRONG POSITION - 1"); + END IF; + END IF; + + BEGIN + X := 100; + GET (FT,X); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 100 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + IF NOT END_OF_LINE (FT) THEN + GET (FT, CH); + IF CH /='#' THEN + FAILED ("GET STOPPED AT WRONG " & + "POSITION - 1"); + END IF; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + RESULT; + + END CE3704O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- CE3705A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- FOR GET FROM A FILE, CHECK THAT IF ONLY THE FILE TERMINATOR + -- REMAINS TO BE READ, THEN ANY CALL TO GET FOR AN INTEGER (EVEN + -- WITH WIDTH = 0) RAISES END_ERROR. + + -- HISTORY: + -- BCB 10/28/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3705A IS + + FILE : FILE_TYPE; + + INCOMPLETE : EXCEPTION; + + I : INTEGER; + + PACKAGE INT_IO IS NEW INTEGER_IO(INTEGER); USE INT_IO; + + BEGIN + TEST ("CE3705A", "FOR GET FROM A FILE, CHECK THAT IF ONLY THE " & + "FILE TERMINATOR REMAINS TO BE READ, THEN ANY " & + "CALL TO GET FOR AN INTEGER (EVEN WITH WIDTH = " & + "0) RAISES END_ERROR"); + + BEGIN + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, 3); + + CLOSE (FILE); + + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + + GET (FILE, I); + + BEGIN + GET (FILE, I); + FAILED ("END_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 1"); + END; + + BEGIN + GET (FILE, I, WIDTH => 0); + FAILED ("END_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("OTHER EXCEPTION RAISED - 2"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE3705A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- CE3705B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- IF WIDTH IS ZERO, CHECK THAT END_ERROR IS RAISED IF THE ONLY + -- REMAINING CHARACTERS IN THE FILE CONSIST OF LINE TERMINATORS, + -- PAGE TERMINATORS, SPACES, AND HORIZONTAL TABULATION CHARACTERS. + -- AFTER END_ERROR IS RAISED, THE FILE SHOULD BE POSITIONED BEFORE + -- THE FILE TERMINATOR AND END_OF_FILE SHOULD BE TRUE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3705B IS + + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + + FILE : FILE_TYPE; + ITEM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3705B", "IF WIDTH IS ZERO, CHECK THAT END_ERROR IS " & + "RAISED IF THE ONLY REMAINING CHARACTERS IN " & + "THE FILE CONSIST OF LINE TERMINATORS, PAGE " & + "TERMINATORS, SPACES, AND HORIZONTAL TAB " & + "CHARACTERS. AFTER END_ERROR IS RAISED, THE " & + "FILE SHOULD BE POSITIONED BEFORE THE FILE " & + "TERMINATOR AND END_OF_FILE SHOULD BE TRUE"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, 2); + NEW_LINE (FILE); + PUT (FILE, 3); + NEW_LINE (FILE); + NEW_PAGE (FILE); + PUT (FILE, ASCII.HT); + NEW_LINE (FILE); + NEW_LINE (FILE); + NEW_PAGE (FILE); + PUT (FILE, ' '); + PUT (FILE, ASCII.HT); + PUT (FILE, ' '); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM); + IF ITEM /= 2 THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + GET (FILE, ITEM); + IF ITEM /= 3 THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + BEGIN + GET (FILE, ITEM, WIDTH => 0); + FAILED ("END_ERROR NOT RAISED FOR GET"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET"); + END; + + IF NOT END_OF_FILE(FILE) THEN + FAILED ("END_OF_FILE NOT TRUE AFTER RAISING EXCEPTION"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3705B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- CE3705C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE LAST CHARACTER IN A FILE MAY BE READ WITHOUT + -- RAISING END_ERROR, AND THAT AFTER THE LAST CHARACTER OF THE + -- FILE HAS BEEN READ, ANY ATTEMPT TO READ FURTHER CHARACTERS + -- WILL RAISE END_ERROR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/18/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3705C IS + + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + + FILE : FILE_TYPE; + ITEM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3705C", "CHECK THAT THE LAST CHARACTER IN A FILE MAY " & + "BE READ WITHOUT RAISING END_ERROR, AND THAT " & + "AFTER THE LAST CHARACTER OF THE FILE HAS BEEN " & + "READ, ANY ATTEMPT TO READ FURTHER CHARACTERS " & + "WILL RAISE END_ERROR"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + + PUT (FILE, 2); + PUT (FILE, 3); + NEW_LINE (FILE); + NEW_PAGE (FILE); + PUT (FILE, 5); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM); + GET (FILE, ITEM); + + BEGIN + GET (FILE, ITEM); + IF ITEM /= 5 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + BEGIN + GET (FILE, ITEM); + FAILED ("END_ERROR NOT RAISED AFTER LAST " & + "CHARACTER OF FILE HAS BEEN READ"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET"); + END; + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR RAISED WHEN READING LAST " & + "CHARACTER OF FILE"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET - 2"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3705C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CE3705D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA_ERROR, NOT END_ERROR, IS RAISED WHEN WIDTH > 0, + -- FEWER THAN WIDTH CHARACTERS REMAIN IN THE FILE, A BASED LITERAL + -- IS BEING READ, AND THE CLOSING # OR : HAS NOT YET BEEN FOUND. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/19/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3705D IS + + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + + FILE : FILE_TYPE; + ITEM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3705D", "CHECK THAT DATA_ERROR, NOT END_ERROR, IS " & + "RAISED WHEN WIDTH > 0, FEWER THAN WIDTH " & + "CHARACTERS REMAIN IN THE FILE, A BASED " & + "LITERAL IS BEING READ, AND THE CLOSING # " & + "OR : HAS NOT YET BEEN FOUND"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "2#1111_1111#"); + NEW_LINE (FILE); + PUT (FILE, "16#FFF"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN " & + "WITH MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM); + IF ITEM /= 255 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + BEGIN + GET (FILE, ITEM, WIDTH => 7); + FAILED ("DATA_ERROR NOT RAISED"); + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR INSTEAD OF DATA_ERROR RAISED"); + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3705D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3705e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CE3705E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA_ERROR, NOT END_ERROR, IS RAISED WHEN FEWER THAN + -- WIDTH CHARACTERS REMAIN IN THE FILE, AND THE REMAINING CHARACTERS + -- SATISFY THE SYNTAX FOR A REAL LITERAL. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/20/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3705E IS + + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + + FILE : FILE_TYPE; + ITEM : INTEGER; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3705E", "CHECK THAT DATA_ERROR, NOT END_ERROR, IS " & + "RAISED WHEN FEWER THAN WIDTH CHARACTERS " & + "REMAIN IN THE FILE, AND THE REMAINING " & + "CHARACTERS SATISFY THE SYNTAX FOR A REAL " & + "LITERAL"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, "16#FFF#"); + NEW_LINE (FILE); + PUT (FILE, "3.14159_26"); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN " & + "WITH MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM); + IF ITEM /= 4095 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + BEGIN + GET (FILE, ITEM, WIDTH => 11); + FAILED ("DATA_ERROR NOT RAISED"); + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR INSTEAD OF DATA_ERROR RAISED"); + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET"); + END; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3705E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,164 ---- + -- CE3706C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO PUT RAISES CONSTRAINT_ERROR IF: + -- A) THE BASE IS OUTSIDE THE RANGE 2..16. + -- B) THE VALUE OF WIDTH IS NEGATIVE OR GREATER THAN FIELD'LAST, + -- WHEN FIELD'LAST < INTEGER'LAST. + -- C) THE VALUE OF ITEM IS OUTSIDE THE RANGE OF THE INSTANTIATED + -- TYPE. + + -- HISTORY: + -- SPS 10/05/82 + -- JBG 08/30/83 + -- JLH 09/10/87 ADDED CASES FOR THE VALUE OF THE WIDTH BEING LESS + -- THAN ZERO AND GREATER THAN FIELD'LAST AND CASES FOR + -- THE VALUE OF ITEM OUTSIDE THE RANGE OF THE + -- INSTANTIATED TYPE. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3706C IS + BEGIN + + TEST ("CE3706C", "CHECK THAT INTEGER_IO PUT RAISES CONSTRAINT " & + "ERROR APPROPRIATELY"); + + DECLARE + FT : FILE_TYPE; + TYPE INT IS NEW INTEGER RANGE 1 .. 10; + PACKAGE IIO IS NEW INTEGER_IO (INT); + USE IIO; + ST : STRING (1 .. 10); + BEGIN + + BEGIN + PUT (FT, 2, 6, 1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE - 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE - 1"); + END; + + BEGIN + PUT (3, 4, 17); + FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT - 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DEFAULT - 1"); + END; + + BEGIN + PUT (TO => ST, ITEM => 4, BASE => -3); + FAILED ("CONSTRAINT_ERROR NOT RAISED - STRING - 1"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STRING - 1"); + END; + + BEGIN + PUT (ST, 5, 17); + FAILED ("CONSTRAINT_ERROR NOT RAISED - STRING - 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STRING - 2"); + END; + + BEGIN + PUT (FT, 5, -1); + FAILED ("CONSTRAINT_ERROR NOT RAISED - FILE - 2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE - 2"); + END; + + BEGIN + PUT (7, -3); + FAILED ("CONSTRAINT_ERROR NOT RAISED - DEFAULT - " & + "2"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - DEFAULT - 2"); + END; + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + PUT (7, FIELD'LAST+Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR WIDTH " & + "GREATER THAN FIELD'LAST"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR WIDTH " & + "GREATER THAN FIELD'LAST"); + END; + + END IF; + + BEGIN + PUT (FT, 11); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + END; + + BEGIN + PUT (11); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + END; + + END; + + RESULT; + END CE3706C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,127 ---- + -- CE3706D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO PUT RAISES MODE_ERROR FOR FILES OF MODE + -- IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/05/82 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/10/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, AND CORRECTED EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3706D IS + + BEGIN + + TEST ("CE3706D", "CHECK THAT INTEGER_IO PUT RAISES MODE_ERROR " & + "FOR FILES OF MODE IN_FILE"); + + DECLARE + FT : FILE_TYPE; + TYPE INT IS NEW INTEGER RANGE 1 .. 30; + PACKAGE IIO IS NEW INTEGER_IO (INT); + USE IIO; + INCOMPLETE : EXCEPTION; + BEGIN + + BEGIN + PUT (STANDARD_INPUT, 26); + FAILED ("MODE_ERROR NOT RAISED - STANDARD_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STANDARD_INPUT"); + END; + + BEGIN + PUT (CURRENT_INPUT, 26); + FAILED ("MODE_ERROR NOT RAISED - CURRENT_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CURRENT_INPUT"); + END; + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, 'A'); + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FT, 26); + FAILED ("MODE_ERROR NOT RAISED - FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE"); + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3706D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + -- CE3706F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO PUT RAISES LAYOUT_ERROR WHEN THE NUMBER OF + -- CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH. CHECK + -- THAT IT IS NOT RAISED WHEN THE NUMBER OF CHARACTERS TO BE OUTPUT + -- ADDED TO THE CURRENT COLUMN NUMBER EXCEEDS THE MAXIMUM LINE + -- LENGTH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- HISTORY: + -- SPS 10/05/82 + -- VKG 01/14/83 + -- SPS 02/18/83 + -- JBG 08/30/83 + -- EG 05/22/85 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/10/87 REMOVED UNNECESSARY CODE, CORRECTED EXCEPTION + -- HANDLING, AND ADDED CASE USING WIDTH OF FIVE. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3706F IS + + BEGIN + + TEST ("CE3706F", "CHECK THAT LAYOUT_ERROR IS RAISED CORRECTLY"); + + DECLARE + FT : FILE_TYPE; + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + INCOMPLETE : EXCEPTION; + BEGIN + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILE WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 4); + + BEGIN + PUT (FT, 32_000, WIDTH => 0); + FAILED ("LAYOUT_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + PUT (FT, 32_000, WIDTH => 5); + FAILED ("LAYOUT_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + PUT (FT, 123, WIDTH => 0); -- "123" + + BEGIN + PUT (FT, 457, WIDTH => 0); -- "123#457" + IF LINE (FT) /= 2 THEN + FAILED ("OUTPUT INCORRECT"); + END IF; + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED INCORRECTLY"); + END; + + CHECK_FILE (FT, "123#457#@%"); + + CLOSE (FT); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3706F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3706g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CE3706G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO PUT USES THE MINIMUM FIELD REQUIRED IF + -- WIDTH IS TOO SMALL AND THE LINE LENGTH IS SUFFICIENTLY LARGE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/05/82 + -- JLH 09/17/87 COMPLETELY REVISED TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3706G IS + + BEGIN + + TEST ("CE3706G", "CHECK THAT INTEGER_IO PUT USES THE MINIMUM " & + "FIELD REQUIRED IF WIDTH IS TOO SMALL AND THE " & + "LINE LENGTH IS SUFFICIENTLY LARGE"); + + DECLARE + FILE : FILE_TYPE; + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + INCOMPLETE : EXCEPTION; + NUM : INTEGER := 12345; + CH : CHARACTER; + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, NUM, WIDTH => 3); + TEXT_IO.PUT (FILE, ' '); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FILE, NUM); + GET (FILE, CH); + IF CH /= ' ' AND COL(FILE) /= 7 THEN + FAILED ("INTEGER_IO PUT DOES NOT USE MINIMUM FIELD " & + "REQUIRED WHEN WIDTH IS TOO SMALL"); + END IF; + + IF NUM /= 12345 THEN + FAILED ("INCORREC VALUE READ"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3706G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3707a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,130 ---- + -- CE3707A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO GET CAN READ A VALUE FROM A STRING. CHECK + -- THAT IT TREATS THE END OF THE STRING AS A FILE TERMINATOR. CHECK + -- THAT LAST CONTAINS THE INDEX VALUE OF THE LAST CHARACTER READ + -- FROM THE STRING. + + -- HISTORY: + -- SPS 10/05/82 + -- VKG 01/13/83 + -- JLH 09/11/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3707A IS + + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + X : INTEGER; + L : POSITIVE; + STR : STRING(1..6) := "123456" ; + + BEGIN + + TEST ("CE3707A", "CHECK THAT INTEGER_IO GET OPERATES CORRECTLY " & + "ON STRINGS"); + + -- LEFT JUSTIFIED STRING NON NULL + + GET ("2362 ", X, L); + IF X /= 2362 THEN + FAILED ("VALUE FROM STRING INCORRECT - 1"); + END IF; + + IF L /= 4 THEN + FAILED ("VALUE OF LAST INCORRECT - 1"); + END IF; + + -- STRING LITERAL WITH BLANKS + + BEGIN + GET (" ", X, L); + FAILED ("END_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN END_ERROR => + IF L /= 4 THEN + FAILED ("AFTER END ERROR VALUE OF LAST " & + "INCORRECT - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + -- NULL STRING + + BEGIN + GET ("", X, L); + FAILED (" END_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN END_ERROR => + IF L /= 4 THEN + FAILED ("AFTER END_ERROR VALUE OF LAST " & + "INCORRECT - 3"); + END IF; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3"); + END; + + -- NULL SLICE + + BEGIN + GET(STR(5..IDENT_INT(2)), X, L); + FAILED ("END_ERROR NOT RAISED - 4"); + EXCEPTION + WHEN END_ERROR => + IF L /= 4 THEN + FAILED ("AFTER END_ERROR VALUE OF LAST " & + "INCORRECT - 4"); + END IF; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 4"); + END; + + -- NON-NULL SLICE + + GET (STR(2..3), X, L); + IF X /= 23 THEN + FAILED ("INTEGER VALUE INCORRECT - 5"); + END IF; + IF L /= 3 THEN + FAILED ("LAST INCORRECT FOR SLICE - 5"); + END IF; + + -- RIGHT JUSTIFIED NEGATIVE NUMBER + + GET(" -2345",X,L); + IF X /= -2345 THEN + FAILED ("INTEGER VALUE INCORRECT - 6"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT FOR NEGATIVE NUMBER - 6"); + END IF; + + RESULT; + + END CE3707A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3708a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- CE3708A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT INTEGER_IO PUT RAISES LAYOUT_ERROR WHEN THE MINIMUM + -- WIDTH REQUIRED FOR THE OUTPUT VALUE IS GREATER THAN THE LENGTH + -- OF THE STRING. ALSO CHECK THAT INTEGER_IO PUT PADS THE OUTPUT + -- ON THE LEFT WITH SPACES IF THE LENGTH OF THE STRING IS GREATER + -- THAN THE MINIMUM WIDTH REQUIRED. + + -- HISTORY: + -- SPS 10/05/82 + -- CPP 07/30/84 + -- JLH 09/11/87 ADDED CASES FOR PADDING OF OUTPUT STRING. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3708A IS + BEGIN + + TEST ("CE3708A", "CHECK THAT INTEGER_IO PUT RAISES LAYOUT_ERROR " & + "WHEN THE MINIMUM WIDTH REQUIRED FOR THE " & + "OUTPUT VALUE IS GREATER THAN THE LENGTH OF " & + "THE STRING. ALSO CHECK THAT INTEGER_IO PUT " & + "PADS THE OUTPUT ON THE LEFT WITH SPACES IF " & + "THE LENGTH OF THE STRING IS GREATER THAN THE " & + "MINIMUM WIDTH REQUIRED."); + + DECLARE + PACKAGE IIO IS NEW INTEGER_IO (INTEGER); + USE IIO; + ST1 : STRING (1 .. 4); + ST2 : STRING (1 .. 4); + ST : STRING (1 .. 4) := "6382"; + BEGIN + PUT (ST1, IDENT_INT(6382)); + IF ST1 /= ST THEN + FAILED ("PUT TO STRING INCORRECT"); + END IF; + + BEGIN + PUT (ST2, IDENT_INT(12345)); + FAILED ("LAYOUT_ERROR NOT RAISED"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + PUT (ST1, IDENT_INT(123)); + IF ST1 /= " 123" THEN + FAILED ("PUT DID NOT PAD WITH BLANKS - 1"); + END IF; + + PUT (ST2, IDENT_INT(-2)); + IF ST2 /= " -2" THEN + FAILED ("PUT DID NOT PAD WITH BLANKS - 2"); + END IF; + + END; + + RESULT; + + END CE3708A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3801a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,112 ---- + -- CE3801A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EACH FLOAT_IO OPERATION RAISES STATUS_ERROR WHEN + -- CALLED WITH A FILE PARAMETER DESIGNATING AN UN-OPEN FILE. + + -- HISTORY: + -- SPS 09/07/82 + -- SPS 12/22/82 + -- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS + -- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF + -- WHAT IS EXPECTED. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3801A IS + BEGIN + + TEST ("CE3801A", "CHECK THAT EACH FLOAT_IO AND FIXED_IO " & + "OPERATION RAISES STATUS_ERROR WHEN CALLED " & + "WITH A FILE PARAMETER DESIGNATING AN " & + "UN-OPEN FILE"); + + DECLARE + TYPE FLT IS NEW FLOAT RANGE 1.0 .. 10.0; + PACKAGE FLT_IO IS NEW FLOAT_IO (FLT); + USE FLT_IO; + X : FLT := FLT'FIRST; + FT : FILE_TYPE; + BEGIN + + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET FLOAT_IO - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET " & + "FLOAT_IO - 1"); + END; + + BEGIN + PUT (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - PUT FLOAT_IO - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT " & + "FLOAT_IO - 1"); + END; + + BEGIN + CREATE (FT, OUT_FILE); -- THIS IS JUST AN ATTEMPT + CLOSE (FT); -- TO CREATE A FILE. + EXCEPTION -- OBJECTIVE MET EITHER WAY. + WHEN USE_ERROR => + NULL; + END; + + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET FLOAT_IO - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET " & + "FLOAT_IO - 2"); + END; + + BEGIN + PUT (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - PUT FLOAT_IO - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT " & + "FLOAT_IO - 2"); + END; + END; + + RESULT; + + END CE3801A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3801b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- CE3801B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT EACH FIXED_IO OPERATION RAISES STATUS_ERROR + -- WHEN CALLED WITH A FILE PARAMETER DESIGNATING AN UN-OPEN FILE. + + -- HISTORY: + -- DWC 09/11/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3801B IS + BEGIN + + TEST ("CE3801B", "CHECK THAT EACH FIXED_IO " & + "OPERATION RAISES STATUS_ERROR WHEN CALLED " & + "WITH A FILE PARAMETER DESIGNATING AN " & + "UN-OPEN FILE"); + + DECLARE + TYPE FIX IS DELTA 0.1 RANGE 1.0 .. 10.0; + PACKAGE FIX_IO IS NEW FIXED_IO (FIX); + USE FIX_IO; + X : FIX := FIX'LAST; + FT : FILE_TYPE; + + BEGIN + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET FIXED_IO - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET " & + "FIXED_IO - 1"); + END; + + BEGIN + PUT (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - PUT FIXED_IO - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT " & + "FIXED_IO - 1"); + END; + + BEGIN + CREATE (FT, OUT_FILE); -- THIS IS JUST AN ATTEMPT TO + CLOSE (FT); -- CREATE A FILE. OBJECTIVE + EXCEPTION -- IS MET EITHER WAY. + WHEN USE_ERROR => + NULL; + END; + + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET FIXED_IO - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET " & + "FIXED_IO - 2"); + END; + + BEGIN + PUT (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - PUT FIXED_IO - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT " & + "FIXED_IO - 2"); + END; + END; + + RESULT; + + END CE3801B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- CE3804A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR FLOAT_IO READS A PLUS OR MINUS SIGN + -- IF PRESENT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS + -- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF WHAT + -- IS EXPECTED. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804A", "CHECK THAT GET FOR FLOAT_IO READS A PLUS OR " & + "MINUS SIGN IF PRESENT"); + + DECLARE + FT : FILE_TYPE; + TYPE FL IS NEW FLOAT RANGE -3.0 .. 3.0; + X : FL; + ST1 : CONSTANT STRING := IDENT_STR ("-3.0"); + ST2 : CONSTANT STRING := IDENT_STR ("+2.0"); + ST3 : CONSTANT STRING := IDENT_STR ("1.0"); + BEGIN + + -- CREATE AND INITIALIZE DATA FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, ST1); + NEW_LINE(FT); + PUT (FT, ST2); + NEW_LINE(FT); + PUT (FT, ST3); + NEW_LINE(FT); + CLOSE (FT); + + -- BEGIN TEST + + DECLARE + PACKAGE FL_IO IS NEW FLOAT_IO (FL); + USE FL_IO; + LST : POSITIVE; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X = 3.0 THEN + FAILED ("MINUS SIGN NOT READ - 1"); + ELSIF X /= -3.0 THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + GET (FT, X); + IF X = -2.0 THEN + FAILED ("PLUS SIGN NOT READ - 2"); + ELSIF X /= +2.0 THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + GET (FT, X); + IF X /= 1.0 THEN + FAILED ("INCORRECT VALUE READ - 3"); + END IF; + + GET (ST1, X, LST); + IF X = 3.0 THEN + FAILED ("MINUS SIGN NOT READ - 4"); + ELSIF X /= -3.0 THEN + FAILED ("INCORRECT VALUE READ - 4"); + END IF; + + GET (ST2, X, LST); + IF X = -2.0 THEN + FAILED ("PLUS SIGN NOT READ - 5"); + ELSIF X /= +2.0 THEN + FAILED ("INCORRECT VALUE READ - 5"); + END IF; + + GET (ST3, X, LST); + IF X /= 1.0 THEN + FAILED ("INCORRECT VALUE READ - 6"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,147 ---- + -- CE3804B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR FIXED_IO READS A PLUS OR MINUS SIGN IF + -- PRESENT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 CORRECTED EXCEPTION HANDLING AND REVISED IFS + -- TO CHECK FOR CASE WHEN VALUE IS NEGATIVE OF + -- WHAT IS EXPECTED. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804B", "CHECK THAT GET FOR FIXED_IO READS A PLUS OR " & + "MINUS SIGN IF PRESENT"); + + DECLARE + FT : FILE_TYPE; + TYPE FIX IS DELTA 0.01 RANGE -3.0 .. 3.0; + X : FIX; + ST1 : CONSTANT STRING := IDENT_STR("-3.0"); + ST2 : CONSTANT STRING := IDENT_STR("+2.0"); + ST3 : CONSTANT STRING := IDENT_STR("1.0"); + BEGIN + + -- CREATE AND INITIALIZE DATA FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, ST1); + NEW_LINE(FT); + PUT (FT, ST2); + NEW_LINE(FT); + PUT (FT, ST3); + NEW_LINE(FT); + CLOSE (FT); + + DECLARE + PACKAGE FIX_IO IS NEW FIXED_IO (FIX); + USE FIX_IO; + LST : POSITIVE; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= -3.0 THEN + FAILED ("MINUS SIGN NOT READ - 1"); + END IF; + + GET (FT, X); + IF X /= +2.0 THEN + FAILED ("PLUS SIGN NOT READ - 2"); + END IF; + + GET (FT, X); + IF X /= 1.0 THEN + FAILED ("INCORRECT VALUE READ - 3"); + END IF; + + GET (ST1, X, LST); + IF X /= -3.0 THEN + FAILED ("MINUS SIGN NOT READ - 4"); + END IF; + + GET (ST2, X, LST); + IF X /= +2.0 THEN + FAILED ("PLUS SIGN NOT READ - 5"); + END IF; + + GET (ST3, X, LST); + IF X /= 1.0 THEN + FAILED ("INCORRECT VALUE READ - 6"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- CE3804C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- HISTORY: + -- CHECK THAT GET FOR FLOAT_IO RAISES MODE_ERROR WHEN THE + -- MODE IS NOT IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 SPLIT CASE FOR FIXED_IO INTO CE3804O.ADA + -- AND CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804C", "CHECK THAT GET FOR FLOAT_IO RAISES " & + "MODE_ERROR WHEN THE MODE IS NOT IN_FILE"); + + DECLARE + FT2 : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT2, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILES WITH OUT_FILE " & + "MODE - 1"); + RAISE INCOMPLETE; + END; + + DECLARE + PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT); + USE FL_IO; + X : FLOAT; + BEGIN + + BEGIN + GET (FT2, X); + FAILED ("MODE_ERROR NOT RAISED - FLOAT " & + "UN-NAMED FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FLOAT UN-NAMED FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - FLOAT " & + "STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FLOAT STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - FLOAT " & + "CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FLOAT CURRENT_OUTPUT"); + END; + + END; + + CLOSE (FT2); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,153 ---- + -- CE3804D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO GET RAISES DATA_ERROR WHEN THE DATA + -- READ IS OUT-OF-RANGE. CHECK THAT ITEM IS LEFT UNAFFECTED + -- AND THAT READING MAY CONTINUE AFTER THE EXCEPTION HAS + -- BEEN HANDLED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- SPS 02/10/83 + -- JBG 08/30/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804D IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804D", "FLOAT_IO GET RAISES DATA_ERROR FOR " & + "OUT-OF-RANGE DATA"); + + DECLARE + FT : FILE_TYPE; + BEGIN + + -- CREATE AND INITIALIZE TEST FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "1.25"); + NEW_LINE (FT); + PUT (FT, "-7.5"); + NEW_LINE (FT); + PUT (FT, "3.5"); + NEW_LINE (FT); + PUT (FT, "2.5"); + NEW_LINE (FT); + CLOSE (FT); + + -- BEGIN TEST + + DECLARE + TYPE FL IS NEW FLOAT RANGE 1.0 .. 3.0; + PACKAGE FL_IO IS NEW FLOAT_IO (FL); + X : FL; + USE FL_IO; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.25 THEN + FAILED ("ITEM ALTERED WHEN DATA_ERROR " & + "IS RAISED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.25 THEN + FAILED ("ITEM ALTERED WHEN DATA_ERROR " & + "IS RAISED - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + GET (FT, X); + IF X /= 2.5 THEN + FAILED ("READING NOT CONTINUED CORRECTLY " & + "AFTER DATA_ERROR"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,154 ---- + -- CE3804E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO GET RAISES DATA_ERROR WHEN THE DATA READ IS + -- OUT-OF-RANGE CHECK THAT ITEM IS LEFT UNAFFECTED AND THAT + -- READING MAY CONTINUE AFTER THE EXCEPTION HAS BEEN HANDLED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- SPS 02/10/83 + -- JBG 08/30/83 + -- EG 11/02/84 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/11/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804E IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804E", "FIXED_IO GET RAISES DATA_ERROR FOR " & + "OUT-OF-RANGE DATA"); + + DECLARE + FT : FILE_TYPE; + BEGIN + + -- CREATE AND INITIALIZE TEST FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "1.25"); + NEW_LINE (FT); + PUT (FT, "-7.5"); + NEW_LINE (FT); + PUT (FT, "3.5"); + NEW_LINE (FT); + PUT (FT, "2.5"); + NEW_LINE (FT); + CLOSE (FT); + + -- BEGIN TEST + + DECLARE + TYPE FX IS DELTA 0.001 RANGE 1.0 .. 3.0; + PACKAGE FX_IO IS NEW FIXED_IO (FX); + X : FX; + USE FX_IO; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X, 0); + + BEGIN + GET (FT, X, 0); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.25 THEN + FAILED ("ITEM ALTERED WHEN DATA_ERROR " & + "IS RAISED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + GET (FT, X, 0); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.25 THEN + FAILED ("ITEM ALTERED WHEN DATA_ERROR " & + "IS RAISED - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + GET (FT, X, 0); + IF X /= 2.5 THEN + FAILED ("READING NOT CONTINUED CORRECTLY " & + "AFTER DATA_ERROR"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,206 ---- + -- CE3804F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO GET RAISES CONSTRAINT_ERROR WHEN THE VALUE + -- SUPPLIED BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN FIELD'LAST + -- WHEN FIELD'LAST IS LESS THAN INTEGER'LAST, OR THE VALUE READ IS + -- OUT OF RANGE OF THE ITEM PARAMETER, BUT WITHIN THE RANGE OF THE + -- SUBTYPE USED TO INSTANTIATE FLOAT_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/07/82 + -- JBG 08/30/83 + -- DWC 09/11/87 SPLIT CASE FOR FIXED_IO INTO CE3804P.ADA AND + -- CORRECTED EXCEPTION HANDLING. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804F IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804F", "CHECK THAT FLOAT_IO GET RAISES " & + "CONSTRAINT_ERROR WHEN THE VALUE SUPPLIED " & + "BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN " & + "FIELD'LAST WHEN FIELD'LAST IS LESS THAN " & + "INTEGER'LAST, OR THE VALUE READ IS OUT OF " & + "RANGE OF THE ITEM PARAMETER, BUT WITHIN THE " & + "RANGE OF THE SUBTYPE USED TO INSTANTIATE " & + "FLOAT_IO."); + + DECLARE + FT : FILE_TYPE; + TYPE FLT IS NEW FLOAT RANGE 1.0 .. 10.0; + PACKAGE FL_IO IS NEW FLOAT_IO (FLT); + USE FL_IO; + X : FLT RANGE 1.0 .. 5.0; + + BEGIN + BEGIN + GET (FT, X, IDENT_INT(-3)); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE " & + "WIDTH"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR FOR NEGATIVE WIDTH"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR NEGATIVE " & + "WIDTH"); + END; + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + GET (X, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "FIELD'LAST + 1 WIDTH - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIELD'LAST + 1 WIDTH - DEFAULT"); + END; + END IF; + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "1.0"); + NEW_LINE (FT); + PUT (FT, "8.0"); + NEW_LINE (FT); + PUT (FT, "2.0"); + NEW_LINE (FT); + PUT (FT, "3.0"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= 1.0 THEN + FAILED ("WRONG VALUE READ WITH EXTERNAL FILE"); + END IF; + + BEGIN + GET (FT, X); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "VALUE OUT OF RANGE WITH EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "VALUE OUT OF RANGE WITH EXTERNAL FILE"); + END; + + BEGIN + GET (FT, X, IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + END; + + SKIP_LINE (FT); + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + GET (FT, X, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + END; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 3); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED - " & + "OUT OF RANGE WITH EXTERNAL FILE"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "OUT OF RANGE WITH EXTERNAL FILE"); + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + END CE3804F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- CE3804G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO GET WHEN SUPPLIED WITH A WIDTH PARAMETER + -- GREATER THAN ZERO READS ONLY THAT MANY CHARACTERS. ALSO CHECK + -- THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS ENCOUNTERED AND + -- THAT DATA_ERROR IS RAISED WHEN THE DATA IS INVALID. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 09/08/82 + -- SPS 12/14/82 + -- VKG 01/13/83 + -- SPS 02/08/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804H.ADA AND + -- CORRECTED EXCEPTION HANDLING. + -- LDC 06/01/88 CHANGED TEST VALUE FROM "3.525" TO "3.625". + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804G IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804G", "CHECK THAT FLOAT_IO GET WHEN SUPPLIED WITH " & + "A WIDTH PARAMETER GREATER THAN ZERO READS " & + "ONLY THAT MANY CHARACTERS. ALSO CHECK THAT " & + "INPUT TERMINATES WHEN A LINE TERMINATOR IS " & + "ENCOUNTERED AND THAT DATA_ERROR IS RAISED " & + "WHEN THE DATA IS INVALID."); + + DECLARE + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT(FT, "3.259.5 8.52"); + NEW_LINE (FT); + PUT (FT, " "); + NEW_LINE (FT); + PUT (FT, ASCII.HT & "9.0"); + NEW_LINE (FT); + PUT (FT, "-3.625"); + NEW_LINE (FT); + CLOSE (FT); + + -- BEGIN TEST + + DECLARE + TYPE FL IS DIGITS 4; + PACKAGE FL_IO IS NEW FLOAT_IO (FL); + USE FL_IO; + X : FL; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT" & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X, 4); + IF X /= 3.25 THEN + FAILED ("WIDTH CHARACTERS NOT READ - FLOAT"); + ELSE + GET (FT, X, 3); + IF X /= 9.5 THEN + FAILED ("WIDTH CHARACTERS NOT READ - " & + "FLOAT 2"); + ELSE + GET (FT, X, 4); + IF X /= 8.5 THEN + FAILED ("DIDN'T COUNT LEADING BLANKS " & + "- FLOAT"); + ELSE + SKIP_LINE(FT); + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - " & + "FLOAT"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED" + & " - FLOAT"); + END; + SKIP_LINE(FT); + GET (FT, X, 4); + IF X /= 9.0 THEN + FAILED ("GET WITH WIDTH " & + "INCORRECT - 3"); + END IF; + + SKIP_LINE (FT); + GET (FT, X, 7); + IF X /= -3.625 THEN + FAILED ("WIDTH CHARACTERS NOT " & + "READ - FLOAT 3"); + END IF; + END IF; + END IF; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,161 ---- + -- CE3804H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO GET WHEN SUPPLIED WITH A WIDTH PARAMETER + -- GREATER THAN ZERO READS ONLY THAT MANY CHARACTERS. ALSO CHECK + -- THAT INPUT TERMINATES WHEN A LINE TERMINATOR IS ENCOUNTERED AND + -- THAT DATA_ERROR IS RAISED WHEN THE DATA IS INVALID. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- DWC 09/14/87 CREATED ORIGINAL TEST. + -- RJW 08/17/89 CHANGED THE VALUE '-3.525' TO '-3.625'. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804H IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804H", "CHECK THAT FIXED_IO GET WHEN SUPPLIED WITH " & + "A WIDTH PARAMETER GREATER THAN ZERO READS " & + "ONLY THAT MANY CHARACTERS. ALSO CHECK THAT " & + "INPUT TERMINATES WHEN A LINE TERMINATOR IS " & + "ENCOUNTERED AND THAT DATA_ERROR IS RAISED " & + "WHEN THE DATA IS INVALID"); + + DECLARE + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT(FT, "3.259.5 8.52"); + NEW_LINE (FT); + PUT (FT, " "); + NEW_LINE (FT); + PUT (FT, ASCII.HT & "9.0"); + NEW_LINE (FT); + PUT (FT, "-3.625"); + NEW_LINE (FT); + + CLOSE (FT); + + -- BEGIN TEST + + DECLARE + TYPE FIXED IS DELTA 0.001 RANGE -100.0 .. 100.0; + PACKAGE FX_IO IS NEW FIXED_IO (FIXED); + USE FX_IO; + X : FIXED; + + BEGIN + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT" & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X, 4); + IF X /= 3.25 THEN + FAILED ("WIDTH CHARACTERS NOT READ - FIXED - 1"); + ELSE + GET (FT, X, 3); + IF X /= 9.5 THEN + FAILED ("WIDTH CHARACTERS NOT READ - " & + "FIXED 2"); + ELSE + GET (FT, X, 4); + IF X /= 8.5 THEN + FAILED ("DIDN'T COUNT LEADING BLANKS " & + "- FIXED"); + ELSE + SKIP_LINE(FT); + BEGIN + GET (FT, X, 2); + FAILED ("DATA_ERROR NOT RAISED - " & + "FIXED"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED" + & " - FIXED"); + END; + + SKIP_LINE(FT); + GET (FT, X, 4); + IF X /= 9.0 THEN + FAILED ("GET WITH WIDTH " & + "INCORRECT"); + END IF; + + SKIP_LINE (FT); + GET (FT, X, 7); + IF X /= -3.625 THEN + FAILED ("WIDTH CHARACTERS NOT " & + "READ"); + END IF; + END IF; + END IF; + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804i.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- CE3804I.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO GET OPERATES ON IN_FILE FILE AND WHEN + -- NO FILE IS SPECIFIED THE CURRENT DEFAULT INPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/06/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804J.ADA AND + -- CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804I IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804I", "CHECK THAT FLOAT_IO GET OPERATES ON " & + "IN_FILE FILE AND WHEN NO FILE IS " & + "SPECIFIED THE CURRENT DEFAULT INPUT " & + "FILE IS USED."); + + DECLARE + FT1, FT2 : FILE_TYPE; + BEGIN + + -- CREATE AND INITIALIZE FILES + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FT1, "1.0"); + NEW_LINE (FT1); + + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT2, "2.0"); + NEW_LINE (FT2); + + CLOSE (FT2); + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + SET_INPUT (FT2); + + DECLARE + TYPE FL IS NEW FLOAT; + PACKAGE FLIO IS NEW FLOAT_IO (FL); + USE FLIO; + X : FL; + BEGIN + BEGIN + GET (FT1, X); + IF X /= 1.0 THEN + FAILED ("FLOAT FILE VALUE INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - FILE FLOAT"); + END; + + BEGIN + GET (X); + IF X /= 2.0 THEN + FAILED ("FLOAT DEFAULT VALUE INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - DEFAULT FLOAT"); + END; + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804I; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804j.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,137 ---- + -- CE3804J.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO GET OPERATES ON IN_FILE FILE AND WHEN + -- NO FILE IS SPECIFIED THE CURRENT DEFAULT INPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- DWC 09/14/87 CREATED ORIGINAL TEST. + -- JRL 02/28/96 Changed upper bound of type FX from 1000.0 to 250.0. + -- Corrected TEST string. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804J IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804J", "CHECK THAT FIXED_IO GET OPERATES ON " & + "IN_FILE FILE AND WHEN NO FILE IS " & + "SPECIFIED THE CURRENT DEFAULT INPUT " & + "FILE IS USED"); + + DECLARE + FT1, FT2 : FILE_TYPE; + BEGIN + + -- CREATE AND INITIALIZE FILES + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FT1, "1.0"); + NEW_LINE (FT1); + + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT2, "2.0"); + NEW_LINE (FT2); + + CLOSE (FT2); + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + SET_INPUT (FT2); + + DECLARE + TYPE FX IS DELTA 0.0001 RANGE 1.0 .. 250.0; + PACKAGE FXIO IS NEW FIXED_IO (FX); + USE FXIO; + X : FX; + BEGIN + BEGIN + GET (FT1, X); + IF X /= 1.0 THEN + FAILED ("FIXED FILE VALUE INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - FILE FIXED"); + END; + + BEGIN + GET (X); + IF X /= 2.0 THEN + FAILED ("FIXED DEFAULT VALUE INCORRECT"); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - DEFAULT FIXED"); + END; + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804J; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804m.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + -- CE3804M.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET WILL RAISE DATA_ERROR IF THE USE OF # AND : + -- IN BASED LITERALS IS MIXED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- VKG 02/07/83 + -- JBG 03/30/84 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/14/87 SPLIT CASE FOR FIXED_IO INTO CE3804N.ADA AND + -- CORRECTED EXCEPTION HANDLING. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE3804M IS + + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3804M", "CHECK THAT FLOAT_IO GET WILL RAISE " & + "DATA_ERROR IF THE USE OF # AND : IN " & + "BASED LITERALS IS MIXED"); + + DECLARE + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + + PUT_LINE (FT, "2#1.1#E+2"); -- 2#1.1#E+2 + PUT_LINE (FT, "8:1.1:E-2"); -- 8:1.1:E-2 + PUT (FT, "2#1.1:E+1"); -- 2#1.1:E+1 + NEW_LINE (FT); + PUT (FT, "4:2.23#E+2"); -- 4:2.23#E+2 + NEW_LINE (FT); + PUT (FT, "2#1.0#E+1"); -- 2#1.0#E+1 + NEW_LINE (FT); + CLOSE (FT); + + DECLARE + PACKAGE FL_IO IS NEW FLOAT_IO(FLOAT); + USE FL_IO; + X : FLOAT := 1.00E+10; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= 2#1.1#E+2 THEN + FAILED ("DID NOT GET RIGHT VALUE - 1"); + END IF; + + GET (FT, X); + IF X /= 8#1.1#E-2 THEN + FAILED ("DID NOT GET RIGHT VALUE - 2"); + END IF; + + BEGIN + X := 1.0E+10; + GET (FT,X); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.00E+10 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + SKIP_LINE (FT); + + BEGIN + GET (FT,X); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= 1.00E+10 THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + SKIP_LINE (FT); + + GET (FT, X); + IF X /= 2#1.0#E+1 THEN + FAILED ("DID NOT GET RIGHT VALUE - 3"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804M; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804o.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- CE3804O.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- HISTORY: + -- CHECK THAT GET FOR FIXED_IO RAISES MODE_ERROR WHEN THE + -- MODE IS NOT IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- DWC 09/14/87 CREATED ORIGINAL TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804O IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804O", "CHECK THAT GET FOR FIXED_IO RAISES " & + "MODE_ERROR WHEN THE MODE IS NOT IN_FILE"); + + DECLARE + FT: FILE_TYPE; + BEGIN + BEGIN + CREATE (FT, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE FOR TEMP FILES " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE 1.0 .. 3.0; + PACKAGE FX_IO IS NEW FIXED_IO (FIXED); + USE FX_IO; + X : FIXED; + BEGIN + + BEGIN + GET (FT, X); + FAILED ("MODE_ERROR NOT RAISED - FIXED " & + "UN-NAMED FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIXED UN-NAMED FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - FIXED " & + "STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIXED STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - FIXED " & + "CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIXED CURRENT_OUTPUT"); + END; + + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804O; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3804p.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,206 ---- + -- CE3804P.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO GET RAISES CONSTRAINT_ERROR WHEN THE VALUE + -- SUPPLIED BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN FIELD'LAST + -- WHEN FIELD'LAST IS LESS THAN INTEGER'LAST, OR THE VALUE READ IS + -- OUT OF RANGE OF THE ITEM PARAMETER, BUT WITHIN THE RANGE OF THE + -- SUBTYPE USED TO INSTANTIATE FIXED_IO. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- DWC 09/15/87 CREATED ORIGINAL TEST. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. Corrected typo. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3804P IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3804P", "CHECK THAT FLOAT_IO GET RAISES " & + "CONSTRAINT_ERROR WHEN THE VALUE SUPPLIED " & + "BY WIDTH IS NEGATIVE, WIDTH IS GREATER THAN " & + "FIELD'LAST WHEN FIELD'LAST IS LESS THAN " & + "INTEGER'LAST, OR THE VALUE READ IS OUT OF " & + "RANGE OF THE ITEM PARAMETER, BUT WITHIN THE " & + "RANGE OF THE SUBTYPE USED TO INSTANTIATE " & + "FLOAT_IO."); + + DECLARE + TYPE FIXED IS DELTA 0.25 RANGE 0.0 .. 10.0; + FT : FILE_TYPE; + PACKAGE FX_IO IS NEW FIXED_IO (FIXED); + USE FX_IO; + X : FIXED RANGE 0.0 .. 5.0; + + BEGIN + BEGIN + GET (FT, X, IDENT_INT(-3)); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR NEGATIVE " & + "WIDTH"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR FOR NEGATIVE WIDTH"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR NEGATIVE " & + "WIDTH"); + END; + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + GET (X, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "FIELD'LAST + 1 WIDTH - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIELD'LAST + 1 WIDTH - DEFAULT"); + END; + END IF; + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "1.0"); + NEW_LINE (FT); + PUT (FT, "8.0"); + NEW_LINE (FT); + PUT (FT, "2.0"); + NEW_LINE (FT); + PUT (FT, "3.0"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= 1.0 THEN + FAILED ("WRONG VALUE READ WITH EXTERNAL FILE"); + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 3); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "OUT OF RANGE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "OUT OF RANGE"); + END; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "NEGATIVE WIDTH WITH EXTERNAL FILE"); + END; + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + GET (FT, X, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - " & + "FIELD'LAST + 1 WIDTH WITH " & + "EXTERNAL FILE"); + END; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X, 3); + EXCEPTION + WHEN CONSTRAINT_ERROR => + FAILED ("CONSTRAINT_ERROR RAISED; VALID WIDTH " & + "WITH EXTERNAL FILE"); + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED; VALID WIDTH " & + "WITH EXTERNAL FILE"); + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3804P; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3805a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,162 ---- + -- CE3805A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO GET MAY READ THE LAST CHARACTER IN THE FILE + -- WITHOUT RAISNG END_ERROR AND THAT SUBSEQUENT READING WILL RAISE + -- END_ERROR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATAIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/08/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/15/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3805A IS + + BEGIN + + TEST ("CE3805A", "CHECK THAT FLOAT_IO GET MAY READ THE LAST " & + "CHARACTER IN THE FILE WITHOUT RAISING " & + "END_ERROR AND THAT SUBSEQUENT READING WILL " & + "RAISE END_ERROR"); + + DECLARE + FT1, FT2 : FILE_TYPE; + PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT); + X : FLOAT; + USE FL_IO; + INCOMPLETE : EXCEPTION; + + BEGIN + + -- CREATE AND INITIALIZE TEST FILES + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FT1, "2.25"); + CLOSE (FT1); + + PUT (FT2, "2.50"); + NEW_LINE (FT2, 3); + NEW_PAGE (FT2); + NEW_LINE (FT2, 3); + CLOSE (FT2); + + -- BEGIN TEST + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + BEGIN + GET (FT1, X); + IF X /= 2.25 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + BEGIN + GET (FT1, X); + FAILED ("END_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR RAISED PREMATURELY - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED - 1"); + END; + + BEGIN + GET (FT2, X); + IF X /= 2.50 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + BEGIN + GET (FT2, X); + FAILED ("END_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR RAISED PREMATURELY - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED - 2"); + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3805A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3805b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + -- CE3805B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO GET MAY READ THE LAST CHARACTER IN THE FILE + -- WITHOUT RAISING END_ERROR AND THAT SUBSEQUENT READING WILL RAISE + -- END_ERROR. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/08/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/15/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3805B IS + + BEGIN + + TEST ("CE3805B", "CHECK THAT FIXED_IO GET MAY READ THE LAST "& + "CHARACTER IN THE FILE WITHOUT RAISING " & + "END_ERROR AND THAT SUBSEQUENT READING WILL " & + "RAISE END_ERROR"); + + DECLARE + FT1, FT2 : FILE_TYPE; + TYPE FIXED IS DELTA 0.02 RANGE 0.0 .. 50.0; + PACKAGE FX_IO IS NEW FIXED_IO (FIXED); + X : FIXED; + USE FX_IO; + INCOMPLETE : EXCEPTION; + + BEGIN + + -- CREATE AND INITIALIZE TEST FILES + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FT1, "2.25"); + CLOSE (FT1); + + PUT (FT2, "2.50"); + NEW_LINE (FT2, 3); + NEW_PAGE (FT2); + NEW_LINE (FT2, 3); + CLOSE (FT2); + + -- BEGIN TEST + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + BEGIN + GET (FT1, X); + IF X /= 2.25 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + BEGIN + GET (FT1, X); + FAILED ("END_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR RAISED PREMATURELY - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED - 1"); + END; + + BEGIN + GET (FT2, X); + IF X /= 2.50 THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + BEGIN + GET (FT2, X); + FAILED ("END_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + EXCEPTION + WHEN END_ERROR => + FAILED ("END_ERROR RAISED PREMATURELY - 2"); + WHEN OTHERS => + FAILED ("UNEXPECTED ERROR RAISED - 2"); + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3805B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- CE3806A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR FLOAT_IO RAISES MODE_ERROR FOR FILES OF + -- MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 09/10/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/11/87 REMOVED DEPENDENCE ON RESET AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3806A IS + + BEGIN + + TEST ("CE3806A", "CHECK THAT PUT FOR FLOAT_IO RAISES MODE_ERROR " & + "FOR FILES OF MODE IN_FILE"); + + DECLARE + FT1 : FILE_TYPE; + PACKAGE FL_IO IS NEW FLOAT_IO (FLOAT); + USE FL_IO; + INCOMPLETE : EXCEPTION; + X : FLOAT := -34.267/19.2; + + BEGIN + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT1, 'A'); + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FT1, X); + FAILED ("MODE_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + PUT (STANDARD_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + BEGIN + PUT (CURRENT_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + BEGIN + DELETE (FT1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3806A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,124 ---- + -- CE3806B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR FIXED_IO RAISES MODE_ERROR FOR FILES OF + -- MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 09/11/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3806B IS + + BEGIN + TEST ("CE3806B", "CHECK THAT PUT FOR FIXED_IO RAISES MODE_ERROR " & + "FOR FILES OF MODE IN_FILE"); + + DECLARE + FT1 : FILE_TYPE; + TYPE FIXED IS DELTA 0.01 RANGE 0.0 .. 1.0; + PACKAGE FX_IO IS NEW FIXED_IO (FIXED); + USE FX_IO; + INCOMPLETE : EXCEPTION; + X : FIXED := 0.2; + + BEGIN + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT1, 'A'); + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FT1, X); + FAILED ("MODE_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + PUT (STANDARD_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + BEGIN + PUT (CURRENT_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + BEGIN + DELETE (FT1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3806B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,197 ---- + -- CE3806C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE + -- VALUES SUPPLIED BY FORE, AFT, OR EXP ARE NEGATIVE OR GREATER + -- THAN FIELD'LAST WHEN FIELD'LAST < FIELD'BASE'LAST. ALSO CHECK + -- THAT PUT FOR FLOAT_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE OF + -- ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE + -- FLOAT_IO. + + -- HISTORY: + -- SPS 09/10/82 + -- JBG 08/30/83 + -- JLH 09/14/87 ADDED CASES FOR COMPLETE OBJECTIVE. + -- KAS 11/24/95 DELETED DIGITS CONSTRAINT FROM SUBTYPE + -- CHANGED STATIC EXPRESSIONS INVOLVING 'LAST + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3806C IS + + FIELD_LAST : TEXT_IO.FIELD := TEXT_IO.FIELD'LAST; + + BEGIN + + TEST ("CE3806C", "CHECK THAT PUT FOR FLOAT_IO RAISES " & + "CONSTRAINT_ERROR APPROPRIATELY"); + + DECLARE + TYPE FLOAT IS DIGITS 5 RANGE 0.0 .. 2.0; + SUBTYPE MY_FLOAT IS FLOAT RANGE 0.0 .. 1.0; + PACKAGE NFL_IO IS NEW FLOAT_IO (MY_FLOAT); + USE NFL_IO; + FT : FILE_TYPE; + Y : FLOAT := 1.8; + X : MY_FLOAT := 26.3 / 26.792; + + BEGIN + BEGIN + PUT (FT, X, FORE => IDENT_INT(-6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " & + "FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 1"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " & + "FLOAT"); + END; + + BEGIN + PUT (FT, X, AFT => IDENT_INT(-2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " & + "FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 2"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " & + "FLOAT"); + END; + + BEGIN + PUT (FT, X, EXP => IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " & + "FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 3"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " & + "FLOAT"); + END; + + IF FIELD_LAST < FIELD'BASE'LAST THEN + + BEGIN + PUT (FT, X, FORE => IDENT_INT(FIELD_LAST+1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 4"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FORE FLOAT"); + END; + + BEGIN + PUT (FT, X, AFT => IDENT_INT(FIELD_LAST+1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 5"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - AFT FLOAT"); + END; + + BEGIN + PUT (FT, X, EXP => IDENT_INT(FIELD_LAST+1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FLOAT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 6"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - EXP FLOAT"); + END; + END IF; + + BEGIN + PUT (FT, Y); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + END; + + BEGIN + PUT (Y); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + END; + + END; + + RESULT; + + END CE3806C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,129 ---- + -- CE3806D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO PUT OPERATES ON FILES OF MODE OUT_FILE AND + -- IF NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE IS USED. + + --- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/06/82 + -- VKG 02/15/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/14/87 REMOVED DEPENDENCE ON RESET AND CORRECT EXCEPTION + -- HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3806D IS + + BEGIN + + TEST ("CE3806D", "CHECK THAT FLOAT_IO OPERATES ON FILES OF MODE " & + "OUT_FILE AND IF NO FILE IS SPECIFIED THE " & + "CURRENT DEFAULT OUTPUT FILE IS USED"); + + DECLARE + FT1, FT2 : FILE_TYPE; + TYPE FL IS DIGITS 3; + PACKAGE FLIO IS NEW FLOAT_IO (FL); + USE FLIO; + INCOMPLETE : EXCEPTION; + X : FL := -1.5; + + BEGIN + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + SET_OUTPUT (FT2); + + BEGIN + PUT (FT1, X); + PUT (X + 1.0); + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_OUTPUT (STANDARD_OUTPUT); + + CLOSE (FT2); + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + X := 0.0; + GET (FT1, X); + IF X /= -1.5 THEN + FAILED ("VALUE INCORRECT - FLOAT FROM FILE"); + END IF; + X := 0.0; + GET (FT2, X); + IF X /= -0.5 THEN + FAILED (" VVALUE INCORRECT - FLOAT FROM DEFAULT"); + END IF; + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3806D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,159 ---- + -- CE3806E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO PUT RAISE LAYOUT_ERROR WHEN THE NUMBER + -- OF CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH. + -- CHECK THAT IT IS NOT RAISED, BUT RATHER NEW_LINE IS CALLED, + -- WHEN THE NUMBER DOES NOT EXCEED THE MAX, BUT WHEN ADDED TO + -- THE CURRENT COLUMN NUMBER, THE TOTAL EXCEEDS THE MAX. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/07/82 + -- SPS 12/14/82 + -- VKG 01/13/83 + -- SPS 02/18/83 + -- JBG 08/30/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 09/14/87 REMOVED DEPENDENCE ON RESET AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3806E IS + + BEGIN + + TEST ("CE3806E", "CHECK THAT FLOAT_IO PUT RAISES " & + "LAYOUT_ERROR CORRECTLY"); + + DECLARE + TYPE FL IS DIGITS 3 RANGE 100.0 .. 200.0; + PACKAGE FLIO IS NEW FLOAT_IO (FL); + USE FLIO; + X : FL := 126.0; + Y : FL := 134.0; + Z : FL := 120.0; + INCOMPLETE : EXCEPTION; + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 8); + + BEGIN + PUT (FT, X); -- " 1.26E+02" + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT"); + + END; + + BEGIN + PUT (FT, Y, FORE => 1); -- "1.34E+02" + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED SECOND PUT " & + "- FLOAT"); + WHEN OTHERS => + FAILED ("EXCEPTION RAISED SECOND PUT - FLOAT"); + END; + + BEGIN + PUT (FT,Z, FORE => 1, AFT => 0); -- "1.2E+02" + IF LINE (FT) /= 2 THEN + FAILED ("NEW_LINE NOT CALLED - FLOAT"); + END IF; + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED THIRD " & + "PUT - FLOAT"); + WHEN OTHERS => + FAILED ("EXCEPTION RAISED THIRD PUT - FLOAT"); + END; + + SET_LINE_LENGTH ( FT,7); + + BEGIN + PUT (FT, "X"); + PUT (FT, Y, FORE => 1, AFT => 2, + EXP => 1); -- 1.34E+2 + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED - 3 FLOAT"); + END; + + BEGIN + PUT (FT, "Z"); + PUT (FT, Z, FORE => 1); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED - 3 FLOAT"); + END; + + CHECK_FILE (FT, "1.34E+02#1.2E+02#X#1.34E+2#Z#@%"); + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3806E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + -- CE3806F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR FIXED_IO RAISES CONSTRAINT_ERROR WHEN THE + -- VALUES SUPPLIED BY FORE, AFT, OR EXP ARE NEGATIVE OR GREATER + -- THAN FIELD'LAST WHEN FIELD'LAST < FIELD'BASE'LAST. ALSO CHECK + -- THAT PUT FOR FIXED_IO RAISES CONSTRAINT_ERROR WHEN THE VALUE + -- OF ITEM IS OUTSIDE THE RANGE OF THE TYPE USED TO INSTANTIATE + -- FIXED_IO. + + -- HISTORY: + -- JLH 09/15/87 CREATED ORIGINAL TEST. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3806F IS + + BEGIN + + TEST ("CE3806F", "CHECK THAT PUT FOR FIXED_IO RAISES " & + "CONSTRAINT_ERROR APPROPRIATELY"); + + DECLARE + TYPE FIXED IS DELTA 0.01 RANGE 1.0 .. 2.0; + SUBTYPE MY_FIXED IS FIXED DELTA 0.01 RANGE 1.0 .. 1.5; + PACKAGE NFX_IO IS NEW FIXED_IO (MY_FIXED); + USE NFX_IO; + FT : FILE_TYPE; + Y : FIXED := 1.8; + X : MY_FIXED := 1.3; + + BEGIN + + BEGIN + PUT (FT, X, FORE => IDENT_INT(-6)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE FORE " & + "FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 1"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 1"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE FORE " & + "FIXED"); + END; + + BEGIN + PUT (FT, X, AFT => IDENT_INT(-2)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE AFT " & + "FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 2"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE AFT " & + "FIXED"); + END; + + BEGIN + PUT (FT, X, EXP => IDENT_INT(-1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED - NEGATIVE EXP " & + "FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 3"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - NEGATIVE EXP " & + "FIXED"); + END; + + IF FIELD'LAST < FIELD'BASE'LAST THEN + + BEGIN + PUT (FT, X, FORE => IDENT_INT(FIELD'LAST+Ident_Int(1))); + FAILED ("CONSTRAINT_ERROR NOT RAISED - FORE FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 4"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FORE FIXED"); + END; + + BEGIN + PUT (FT, X, AFT => IDENT_INT(FIELD'LAST+Ident_Int(1))); + FAILED ("CONSTRAINT_ERROR NOT RAISED - AFT FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 5"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 5"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - AFT FIXED"); + END; + + BEGIN + PUT (FT, X, EXP => IDENT_INT(FIELD'LAST+Ident_Int(1))); + FAILED ("CONSTRAINT_ERROR NOT RAISED - EXP FIXED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("STATUS_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 6"); + WHEN USE_ERROR => + FAILED ("USE_ERROR RAISED INSTEAD OF " & + "CONSTRAINT_ERROR - 6"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - EXP FIXED"); + END; + + END IF; + + BEGIN + PUT (FT, Y); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - FILE"); + END; + + BEGIN + PUT (Y); + FAILED ("CONSTRAINT_ERROR NOT RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR ITEM OUTSIDE " & + "RANGE - DEFAULT"); + END; + + END; + + RESULT; + + END CE3806F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806g.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,125 ---- + -- CE3806G.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO PUT OPERATES ON FILES OF MODE OUT_FILE AND + -- IF NO FILE IS SPECIFIED THE CURRENT DEFAULT OUTPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 09/13/87 CREATED ORIGINAL TEST. + -- BCB 10/03/90 ADDED THE STATEMENT "RAISE INCOMPLETE;" TO + -- NAME_ERROR EXCEPTION HANDLER. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3806G IS + + BEGIN + + TEST ("CE3806G", "CHECK THAT FIXED_IO PUT OPERATES ON FILES " & + "OF MODE OUT_FILE AND IF NO FILE IS SPECIFIED " & + "THE CURRENT DEFAULT OUTPUT FILE IS USED"); + + DECLARE + FT1, FT2 : FILE_TYPE; + TYPE FX IS DELTA 0.5 RANGE -10.0 .. 10.0; + PACKAGE FXIO IS NEW FIXED_IO (FX); + USE FXIO; + INCOMPLETE : EXCEPTION; + X : FX := -1.5; + + BEGIN + + BEGIN + CREATE (FT1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE, LEGAL_FILE_NAME(2)); + + SET_OUTPUT (FT2); + + BEGIN + PUT (FT1, X); + PUT (X + 1.0); + + CLOSE (FT1); + + BEGIN + OPEN (FT1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_OUTPUT (STANDARD_OUTPUT); + + CLOSE (FT2); + + OPEN (FT2, IN_FILE, LEGAL_FILE_NAME(2)); + + X := 0.0; + GET (FT1, X); + IF X /= -1.5 THEN + FAILED ("VALUE INCORRECT - FIXED FROM FILE"); + END IF; + X := 0.0; + GET (FT2, X); + IF X /= -0.5 THEN + FAILED ("VALUE INCORRECT - FIXED FROM DEFAULT"); + END IF; + END; + + BEGIN + DELETE (FT1); + DELETE (FT2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3806G; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3806h.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- CE3806H.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO PUT RAISES LAYOUT_ERROR WHEN THE NUMBER OF + -- CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE LENGTH. CHECK + -- THAT IT IS NOT RAISED, BUT RATHER NEW_LINE IS CALLED, WHEN THE + -- NUMBER DOES NOT EXCEED THE MAX, BUT WHEN ADDED TO THE CURRENT + -- COLUMN NUMBER, THE TOTAL EXCEEDS THE MAX. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 09/15/87 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3806H IS + + BEGIN + + TEST ("CE3806H", "CHECK THAT FIXED_IO PUT RAISES " & + "LAYOUT_ERROR CORRECTLY"); + + DECLARE + FT : FILE_TYPE; + TYPE FX IS DELTA 0.01 RANGE -200.0 .. 200.0; + PACKAGE FXIO IS NEW FIXED_IO (FX); + USE FXIO; + INCOMPLETE : EXCEPTION; + X : FX := 126.5; + Y : FX := -134.0; + Z : FX := 120.0; + + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 4); + + BEGIN + PUT (FT, X, FORE => 3, AFT => 1); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED"); + END; + + SET_LINE_LENGTH (FT,7); + + BEGIN + PUT (FT, Y, FORE => 3, AFT => 2); + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED SECOND PUT - " & + "FIXED"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED SECOND PUT - " & + "FIXED"); + END; + + BEGIN + PUT (FT,Z, FORE => 4, AFT => 2); + IF LINE (FT) /= 2 THEN + FAILED ("NEW_LINE NOT CALLED - FIXED"); + END IF; + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED THIRD PUT - " & + "FIXED"); + WHEN OTHERS => + FAILED ("EXCEPTION RAISED THIRD PUT - FIXED"); + END; + + BEGIN + PUT (FT, "Y"); + PUT (FT, Z, FORE => 3, AFT => 0); + NEW_LINE (FT); + PUT (FT, "Z"); + PUT (FT, Y, FORE => 3, AFT => 2); + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED LAST PUT - " & + "FIXED"); + WHEN OTHERS => + FAILED ("EXCEPTION RAISED LAST PUT - FIXED "); + END; + + CHECK_FILE (FT, "-134.00# 120.00#Y120.0#Z#-134.00#@%"); + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + + END; + + RESULT; + + END CE3806H; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3809a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- CE3809A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT I/O GET CAN READ A VALUE FROM A STRING. + -- CHECK THAT END_ERROR IS RAISED WHEN CALLED WITH A NULL STRING + -- OR A STRING CONTAINING SPACES AND/OR HORIZONTAL TABULATION + -- CHARACTERS. CHECK THAT LAST CONTAINS THE INDEX OF THE LAST + -- CHARACTER READ FROM THE STRING. + + -- HISTORY: + -- SPS 10/07/82 + -- SPS 12/14/82 + -- JBG 12/21/82 + -- DWC 09/15/87 ADDED CASE TO INCLUDE ONLY TABS IN STRING AND + -- CHECKED THAT END_ERROR IS RAISED. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3809A IS + BEGIN + + TEST ("CE3809A", "CHECK THAT FLOAT_IO GET " & + "OPERATES CORRECTLY ON STRINGS"); + + DECLARE + TYPE FL IS DIGITS 4; + PACKAGE FLIO IS NEW FLOAT_IO (FL); + USE FLIO; + X : FL; + STR : STRING (1..10) := " 10.25 "; + L : POSITIVE; + BEGIN + + -- LEFT-JUSTIFIED IN STRING, POSITIVE, NO EXPONENT + BEGIN + GET ("896.5 ", X, L); + IF X /= 896.5 THEN + FAILED ("FLOAT VALUE FROM STRING INCORRECT"); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - FLOAT - 1"); + END; + + IF L /= IDENT_INT (5) THEN + FAILED ("VALUE OF LAST INCORRECT - FLOAT - 1. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + + -- STRING LITERAL WITH BLANKS + BEGIN + GET (" ", X, L); + FAILED ("END_ERROR NOT RAISED - FLOAT - 2"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 2. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 2"); + END; + + -- NULL STRING LITERAL + BEGIN + GET ("", X, L); + FAILED ("END_ERROR NOT RAISED - FLOAT - 3"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 3. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 3"); + END; + + -- NULL SLICE + BEGIN + GET (STR(5..IDENT_INT(2)), X, L); + FAILED ("END_ERROR NOT RAISED - FLOAT - 4"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 4. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 4"); + END; + + -- SLICE WITH BLANKS + BEGIN + GET (STR(IDENT_INT(9)..10), X, L); + FAILED ("END_ERROR NOT RAISED - FLOAT - 5"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(5) THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 5. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 5"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 5"); + END; + + -- NON-NULL SLICE + BEGIN + GET (STR(2..IDENT_INT(8)), X, L); + IF X /= 10.25 THEN + FAILED ("FLOAT VALUE INCORRECT - 6"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT FOR SLICE - 6. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 6"); + END; + + -- LEFT-JUSTIFIED, POSITIVE EXPONENT + BEGIN + GET ("1.34E+02", X, L); + IF X /= 134.0 THEN + FAILED ("FLOAT WITH EXP FROM STRING INCORRECT - 7"); + END IF; + + IF L /= 8 THEN + FAILED ("VALUE OF LAST INCORRECT - FLOAT - 7. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_EROR RAISED - FLOAT - 7"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - FLOAT - 7"); + END; + + -- RIGHT-JUSTIFIED, NEGATIVE EXPONENT + BEGIN + GET (" 25.0E-2", X, L); + IF X /= 0.25 THEN + FAILED ("NEG EXPONENT INCORRECT - 8"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT - 8. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 8"); + END; + + -- RIGHT-JUSTIFIED, NEGATIVE + GET (" -1.50", X, L); + IF X /= -1.5 THEN + FAILED ("FLOAT IN RIGHT JUSTIFIED STRING INCORRECT - 9"); + END IF; + IF L /= 7 THEN + FAILED ("LAST INCORRECT - 9. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + + -- HORIZONTAL TAB WITH BLANKS + BEGIN + GET (" " & ASCII.HT & "2.3E+2", X, L); + IF X /= 230.0 THEN + FAILED ("FLOAT WITH TAB IN STRING INCORRECT - 10"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT FOR TAB - 10. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_ERROR FOR STRING WITH TAB - 10"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED FOR STRING WITH " & + "TAB - 10"); + END; + + -- HORIZONTAL TABS ONLY + BEGIN + GET (ASCII.HT & ASCII.HT, X, L); + FAILED ("END_ERROR NOT RAISED - FLOAT - 11"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(8) THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 11. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FLOAT - 11"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 11"); + END; + END; + + RESULT; + + END CE3809A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3809b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,239 ---- + -- CE3809B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- HISTORY: + -- CHECK THAT FIXED I/O GET CAN READ A VALUE FROM A STRING. + -- CHECK THAT END_ERROR IS RAISED WHEN CALLED WITH A NULL STRING + -- OR A STRING CONTAINING SPACES AND/OR HORIZONTAL TABULATION + -- CHARACTERS. CHECK THAT LAST CONTAINS THE INDEX OF THE LAST + -- CHARACTER READ FROM THE STRING. + + -- HISTORY: + -- SPS 10/07/82 + -- SPS 12/14/82 + -- JBG 12/21/82 + -- DWC 09/15/87 ADDED CASE TO INCLUDE ONLY TABS IN STRING AND + -- CHECKED THAT END_ERROR IS RAISED. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3809B IS + BEGIN + + TEST ("CE3809B", "CHECK THAT FIXED_IO GET " & + "OPERATES CORRECTLY ON STRINGS"); + + DECLARE + TYPE FX IS DELTA 0.001 RANGE -2.0 .. 1000.0; + PACKAGE FXIO IS NEW FIXED_IO (FX); + USE FXIO; + X : FX; + L : POSITIVE; + STR : STRING (1..10) := " 10.25 "; + BEGIN + + -- LEFT-JUSTIFIED IN STRING, POSITIVE, NO EXPONENT + BEGIN + GET ("896.5 ", X, L); + IF X /= 896.5 THEN + FAILED ("FIXED VALUE FROM STRING INCORRECT"); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 1"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - FIXED - 1"); + END; + + IF L /= IDENT_INT (5) THEN + FAILED ("VALUE OF LAST INCORRECT - FIXED - 1. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + + -- STRING LITERAL WITH BLANKS + BEGIN + GET (" ", X, L); + FAILED ("END_ERROR NOT RAISED - FIXED - 2"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 2. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 2"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 2"); + END; + + -- NULL STRING LITERAL + BEGIN + GET ("", X, L); + FAILED ("END_ERROR NOT RAISED - FIXED - 3"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 3. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 3"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 3"); + END; + + -- NULL SLICE + BEGIN + GET (STR(5..IDENT_INT(2)), X, L); + FAILED ("END_ERROR NOT RAISED - FIXED - 4"); + EXCEPTION + WHEN END_ERROR => + IF L /= 5 THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 4. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 4"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 4"); + END; + + -- SLICE WITH BLANKS + BEGIN + GET (STR(IDENT_INT(9)..10), X, L); + FAILED ("END_ERROR NOT RAISED - FIXED - 5"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(5) THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 5. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 5"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 5"); + END; + + -- NON-NULL SLICE + BEGIN + GET (STR(2..IDENT_INT(8)), X, L); + IF X /= 10.25 THEN + FAILED ("FIXED VALUE INCORRECT - 6"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT FOR SLICE - 6. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 6"); + END; + + -- LEFT-JUSTIFIED, POSITIVE EXPONENT + BEGIN + GET ("1.34E+02", X, L); + IF X /= 134.0 THEN + FAILED ("FIXED WITH EXP FROM STRING INCORRECT - 7"); + END IF; + + IF L /= 8 THEN + FAILED ("VALUE OF LAST INCORRECT - FIXED - 7. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_EROR RAISED - FIXED - 7"); + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED - FIXED - 7"); + END; + + -- RIGHT-JUSTIFIED, NEGATIVE EXPONENT + BEGIN + GET (" 25.0E-2", X, L); + IF X /= 0.25 THEN + FAILED ("NEG EXPONENT INCORRECT - 8"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT - 8. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN OTHERS => + FAILED ("EXCEPTION RAISED - 8"); + END; + + -- RIGHT-JUSTIFIED, NEGATIVE + GET (" -1.50", X, L); + IF X /= -1.5 THEN + FAILED ("FIXED IN RIGHT JUSTIFIED STRING INCORRECT - 9"); + END IF; + IF L /= 7 THEN + FAILED ("LAST INCORRECT - 9. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + + -- HORIZONTAL TAB WITH BLANK + BEGIN + GET (" " & ASCII.HT & "2.3E+2", X, L); + IF X /= 230.0 THEN + FAILED ("FIXED WITH TAB IN STRING INCORRECT - 10"); + END IF; + IF L /= 8 THEN + FAILED ("LAST INCORRECT FOR TAB - 10. " & + "LAST IS" & INTEGER'IMAGE(L)); + END IF; + EXCEPTION + WHEN DATA_ERROR => + FAILED ("DATA_ERROR FOR STRING WITH TAB - 10"); + WHEN OTHERS => + FAILED ("EXCEPTION FOR STRING WITH TAB - 10"); + END; + + -- HORIZONTAL TABS ONLY + + BEGIN + GET (ASCII.HT & ASCII.HT, X, L); + FAILED ("END_ERROR NOT RAISED - FIXED - 11"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(8) THEN + FAILED ("AFTER END_ERROR, VALUE OF LAST " & + "INCORRECT - 11. LAST IS" & + INTEGER'IMAGE(L)); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED - FIXED - 11"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 11"); + END; + END; + + RESULT; + + END CE3809B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3810a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + -- CE3810A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FLOAT_IO PUT CAN OPERATE ON STRINGS. ALSO CHECK THAT + -- LAYOUT_ERROR IS RAISED WHEN THE STRING IS INSUFFICIENTLY LONG. + + -- HISTORY: + -- SPS 10/07/82 + -- VKG 01/20/83 + -- SPS 02/18/83 + -- DWC 09/15/87 SPLIT CASE FOR FIXED_IO INTO CE3810B.ADA AND + -- ADDED CASED FOR AFT AND EXP TO RAISE LAYOUT_ERROR. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3810A IS + BEGIN + + TEST ("CE3810A", "CHECK THAT FLOAT_IO PUT " & + "OPERATES ON STRINGS CORRECTLY"); + + DECLARE + TYPE FL IS DIGITS 4; + PACKAGE FLIO IS NEW FLOAT_IO (FL); + USE FLIO; + ST : STRING (1 .. 2 + (FL'DIGITS-1) + 3 + 2); + ST1 : STRING (1 .. 10) := " 2.345E+02"; + ST2 : STRING (1 .. 2); + BEGIN + PUT (ST, 234.5); + IF ST /= ST1 THEN + FAILED ("PUT FLOAT TO STRING INCORRECT; OUTPUT WAS """ & + ST & """"); + END IF; + + BEGIN + PUT (ST(1 .. 8), 234.5); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 1"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 1"); + END; + + BEGIN + PUT (ST, 2.3, 9, 0); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 2"); + END; + + BEGIN + PUT (ST2, 2.0, 0, 0); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 3"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 3"); + END; + + BEGIN + PUT (ST, 2.345, 6, 2); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 4"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 4"); + END; + + BEGIN + PUT (ST, 2.0, 0, 7); + FAILED ("LAYOUT_ERROR NOT RAISED - FLOAT - 5"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FLOAT - 5"); + END; + END; + + RESULT; + + END CE3810A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3810b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,122 ---- + -- CE3810B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT FIXED_IO PUT CAN OPERATE ON STRINGS. ALSO CHECK THAT + -- LAYOUT_ERROR IS RAISED WHEN THE STRING IS INSUFFICIENTLY LONG. + + -- HISTORY: + -- DWC 09/15/87 CREATE ORIGINAL TEST. + -- JRL 02/28/96 Changed upper bound of type FX from 1000.0 to 250.0. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3810B IS + BEGIN + + TEST ("CE3810B", "CHECK THAT FIXED_IO PUT CAN OPERATE ON " & + "STRINGS. ALSO CHECK THAT LAYOUT_ERROR IS " & + "RAISED WHEN THE STRING IS INSUFFICIENTLY LONG"); + + DECLARE + TYPE FX IS DELTA 0.0001 RANGE 0.0 .. 250.0; + PACKAGE FXIO IS NEW FIXED_IO (FX); + USE FXIO; + ST1 : CONSTANT STRING := " 234.5000"; + ST : STRING (ST1'RANGE); + ST2 : STRING (1 .. 2); + + BEGIN + BEGIN + PUT (ST, 234.5); + EXCEPTION + WHEN LAYOUT_ERROR => + FAILED ("LAYOUT_ERROR RAISED ON PUT" & + "TO STRING - FIXED"); + WHEN OTHERS => + FAILED ("SOME EXCEPTION RAISED ON PUT" & + "TO STRING -FIXED"); + END; + + IF ST /= ST1 THEN + FAILED ("PUT FIXED TO STRING INCORRECT; OUTPUT " & + "WAS """ & ST & """"); + END IF; + + BEGIN + PUT (ST (1..7), 234.5000); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 1"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 1"); + END; + + BEGIN + PUT (ST, 2.3, 9, 0); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 2"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 2"); + END; + + BEGIN + PUT (ST2, 2.0, 0, 0); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 3"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 3"); + END; + + BEGIN + PUT (ST, 2.345, 6, 2); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 4"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 4"); + END; + + BEGIN + PUT (ST, 2.0, 0, 7); + FAILED ("LAYOUT_ERROR NOT RAISED - FIXED - 5"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FIXED - 5"); + END; + END; + + RESULT; + END CE3810B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3815a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- CE3815A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATIONS IN GENERIC PACKAGE FLOAT_IO ALL HAVE + -- THE CORRECT PARAMETER NAMES. + + -- HISTORY: + -- JET 10/28/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + PROCEDURE CE3815A IS + + STR : STRING(1..20) := (OTHERS => ' '); + FIN, FOUT : FILE_TYPE; + F : FLOAT; + L : POSITIVE; + FILE_OK : BOOLEAN := FALSE; + + PACKAGE FIO IS NEW FLOAT_IO(FLOAT); + USE FIO; + + BEGIN + TEST ("CE3815A", "CHECK THAT THE OPERATIONS IN GENERIC PACKAGE " & + "FLOAT_IO ALL HAVE THE CORRECT PARAMETER NAMES"); + + PUT (TO => STR, ITEM => 1.0, AFT => 3, EXP => 3); + GET (FROM => STR, ITEM => F, LAST => L); + + BEGIN + CREATE(FOUT, OUT_FILE, LEGAL_FILE_NAME); + FILE_OK := TRUE; + EXCEPTION + WHEN OTHERS => + COMMENT("OUTPUT FILE COULD NOT BE CREATED"); + END; + + IF FILE_OK THEN + BEGIN + PUT (FILE => FOUT, ITEM => 1.0, FORE => 3, AFT => 3, + EXP => 3); + NEW_LINE(FOUT); + + CLOSE(FOUT); + EXCEPTION + WHEN OTHERS => + FAILED("OUTPUT FILE COULD NOT BE WRITTEN"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + BEGIN + OPEN(FIN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN OTHERS => + FAILED("INPUT FILE COULD NOT BE OPENED"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + BEGIN + GET (FILE => FIN, ITEM => F, WIDTH => 10); + EXCEPTION + WHEN OTHERS => + FAILED ("DATA COULD NOT BE READ FROM FILE"); + END; + + BEGIN + DELETE(FIN); + EXCEPTION + WHEN USE_ERROR => + COMMENT("FILE COULD NOT BE DELETED"); + WHEN OTHERS => + FAILED("UNEXPECTED ERROR AT DELETION"); + END; + END IF; + + RESULT; + END CE3815A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3901a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- CE3901A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET AND PUT FOR ENUMERATED TYPES RAISE STATUS ERROR + -- IF THE FILE IS NOT OPEN. + + -- HISTORY: + -- SPS 10/07/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- DWC 09/16/87 ADDED AN ATTEMPT TO CREATE A FILE AND THEN + -- RETESTED OBJECTIVE. + -- BCB 10/03/90 ADDED NAME_ERROR AS A CHOICE TO THE EXCEPTION + -- HANDLER FOR CREATE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3901A IS + BEGIN + + TEST ("CE3901A", "CHECK THAT GET AND PUT FOR ENUMERATED TYPES " & + "RAISE STATUS ERROR IF THE FILE IS NOT OPEN."); + + DECLARE + TYPE COLOR IS (RED, BLUE, GREEN, ORANGE, YELLOW); + FT : FILE_TYPE; + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + X : COLOR; + BEGIN + BEGIN + PUT (FT, RED); + FAILED ("STATUS_ERROR NOT RAISED - PUT - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT - 1"); + END; + + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET - 1"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET - 1"); + END; + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); -- THIS IS JUST + CLOSE (FT); -- AN ATTEMPT TO CREATE A + EXCEPTION -- FILE. OBJECTIVE IS MET + WHEN USE_ERROR -- EITHER WAY. + | NAME_ERROR => NULL; + END; + + BEGIN + PUT (FT, RED); + FAILED ("STATUS_ERROR NOT RAISED - PUT - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - PUT - 2"); + END; + + BEGIN + GET (FT, X); + FAILED ("STATUS_ERROR NOT RAISED - GET - 2"); + EXCEPTION + WHEN STATUS_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - GET - 2"); + END; + END; + + RESULT; + + END CE3901A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3902b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE3902B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE OPERATIONS IN GENERIC PACKAGE ENUMERATION_IO + -- ALL HAVE THE CORRECT PARAMETER NAMES. + + -- HISTORY: + -- JLH 08/25/88 CREATED ORIGINAL TEST. + -- RJW 02/28/90 ADDED CODE TO PREVENT MODE_ERROR FROM BEING RAISED. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3902B IS + + TYPE COLOR IS (RED, BLUE, GREEN); + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + + FILE1 : FILE_TYPE; + CRAYON : COLOR := RED; + INDEX : POSITIVE; + NUM : FIELD := 5; + COLOR_STRING : STRING (1..5); + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3902B", "CHECK THAT THE OPERATIONS IN GENERIC PACKAGE " & + "ENUMERATION_IO ALL HAVE THE CORRECT PARAMETER " & + "NAMES"); + + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + SET_OUTPUT (FILE1); + + PUT (FILE => FILE1, ITEM => CRAYON, WIDTH => NUM, + SET => UPPER_CASE); + + PUT (ITEM => GREEN, WIDTH => 5, SET => LOWER_CASE); + + PUT (TO => COLOR_STRING, ITEM => BLUE, SET => UPPER_CASE); + + CLOSE (FILE1); + + SET_OUTPUT (STANDARD_OUTPUT); + + BEGIN + OPEN (FILE1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE1); + + GET (FILE => FILE1, ITEM => CRAYON); + + GET (ITEM => CRAYON); + + GET (FROM => COLOR_STRING, ITEM => CRAYON, LAST => INDEX); + + BEGIN + DELETE (FILE1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3902B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3904a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,117 ---- + -- CE3904A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE LAST NONBLANK CHARACTER IN A FILE MAY BE READ BY + -- 'GET' IN ENUMERATION_IO WITHOUT RAISING END_ERROR, AND THAT AFTER + -- THE LAST CHARACTER OF THE FILE HAS BEEN READ, ANY ATTEMPT TO READ + -- FURTHER CHARACTERS WILL RAISE END_ERROR. + + -- HISTORY: + -- JET 08/19/88 CREATED ORIGINAL TEST. + + WITH REPORT, TEXT_IO; USE REPORT, TEXT_IO; + PROCEDURE CE3904A IS + + TYPE ENUM IS (THE, QUICK, BROWN, X); + E : ENUM; + + PACKAGE EIO IS NEW ENUMERATION_IO(ENUM); + USE EIO; + + F : FILE_TYPE; + + FILE_OK : BOOLEAN := FALSE; + + BEGIN + TEST ("CE3904A", "CHECK THAT THE LAST NONBLANK CHARACTER IN A " & + "FILE MAY BE READ BY 'GET' IN ENUMERATION_IO " & + "WITHOUT RAISING END_ERROR, AND THAT AFTER THE " & + "LAST CHARACTER OF THE FILE HAS BEEN READ, ANY " & + "ATTEMPT TO READ FURTHER CHARACTERS WILL RAISE " & + "END_ERROR"); + + BEGIN + CREATE(F, OUT_FILE, LEGAL_FILE_NAME); + FILE_OK := TRUE; + EXCEPTION + WHEN OTHERS => + NOT_APPLICABLE("DATA FILE COULD NOT BE OPENED FOR " & + "WRITING"); + END; + + IF FILE_OK THEN + BEGIN + PUT(F, THE); NEW_LINE(F); + PUT(F, QUICK); NEW_LINE(F); + PUT(F, BROWN); NEW_LINE(F); + PUT(F, X); NEW_LINE(F); + CLOSE(F); + EXCEPTION + WHEN OTHERS => + NOT_APPLICABLE("DATA FILE COULD NOT BE WRITTEN"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + BEGIN + OPEN(F, IN_FILE, LEGAL_FILE_NAME); + FOR I IN 0..3 LOOP + GET(F, E); + IF E /= ENUM'VAL(I) THEN + FAILED("INCORRECT VALUE READ -" & + INTEGER'IMAGE(I)); + END IF; + END LOOP; + EXCEPTION + WHEN OTHERS => + FAILED("UNEXPECTED EXCEPTION RAISED BEFORE END " & + "OF FILE"); + FILE_OK := FALSE; + END; + END IF; + + IF FILE_OK THEN + BEGIN + GET(F, E); + FAILED("NO EXCEPTION RAISED AFTER END OF FILE"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED("INCORRECT EXCEPTION RAISED AFTER END OF " & + "FILE"); + END; + + BEGIN + DELETE(F); + EXCEPTION + WHEN OTHERS => + COMMENT("DATA FILE COULD NOT BE DELETED"); + END; + END IF; + + RESULT; + END CE3904A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3904b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,142 ---- + -- CE3904B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT END_ERROR IS RAISED BY GET WITH AN ENUMERATION TYPE + -- WHEN THE ONLY REMAINING CHARACTERS IN THE FILE ARE SPACES, + -- HORIZONTAL TABULATION CHARACTERS, LINE TERMINATORS, AND PAGE + -- TERMINATORS. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS THAT SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- JLH 07/15/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE CE3904B IS + + TYPE COLOR IS (RED, BLUE, GREEN); + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + + FILE : FILE_TYPE; + ITEM : COLOR; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3904B", "CHECK THAT END_ERROR IS RAISED BY GET WITH " & + "AN ENUMERATION TYPE WHEN THE ONLY REMAINING " & + "CHARACTERS IN THE FILE ARE SPACES, HORIZONTAL " & + "TABULATION CHARACTERS, LINE TERMINATORS, AND " & + "PAGE TERMINATORS"); + + BEGIN + + BEGIN + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE, RED); + NEW_LINE (FILE); + NEW_LINE (FILE); + NEW_PAGE (FILE); + PUT (FILE, ASCII.HT); + PUT (FILE, GREEN); + NEW_LINE (FILE); + NEW_LINE (FILE); + NEW_PAGE (FILE); + PUT (FILE, ' '); + PUT (FILE, ASCII.HT); + PUT (FILE, ' '); + + CLOSE (FILE); + + BEGIN + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "MODE IN_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON OPEN"); + RAISE INCOMPLETE; + END; + + GET (FILE, ITEM); + IF ITEM /= RED THEN + FAILED ("INCORRECT VALUE READ - 1"); + END IF; + + GET (FILE, ITEM); + IF ITEM /= GREEN THEN + FAILED ("INCORRECT VALUE READ - 2"); + END IF; + + BEGIN + GET (FILE, ITEM); + FAILED ("END_ERROR NOT RAISED FOR GET"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON GET"); + END; + + IF NOT END_OF_FILE (FILE) THEN + FAILED ("END_OF_FILE NOT TRUE AFTER RAISING EXCEPTION"); + END IF; + + BEGIN + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3904B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,145 ---- + -- CE3905A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR ENUMERATION TYPES OPERATES ON FILE OF MODE + -- IN_FILE AND THAT WHEN NO FILE IS SPECIFIED IT OPERATES ON THE + -- CURRENT DEFAULT INPUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/07/82 + -- SPS 12/22/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/16/87 REMOVED DEPENDENCE ON RESET AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3905A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3905A", "CHECK THAT GET FOR ENUMERATION TYPES " & + "OPERATES ON FILE OF MODE IN_FILE AND THAT " & + "WHEN NO FILE IS SPECIFIED IT OPERATES ON " & + "THE CURRENT DEFAULT INPUT_FILE"); + + DECLARE + TYPE DAY IS (MONDAY, TUESDAY, WEDNESDAY, THURSDAY, FRIDAY); + PACKAGE DAY_IO IS NEW ENUMERATION_IO (DAY); + FT : FILE_TYPE; + FILE : FILE_TYPE; + USE DAY_IO; + X : DAY; + BEGIN + + -- CREATE AND INITIALIZE DATA FILES. + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + PUT (FT, "WEDNESDAY"); + NEW_LINE (FT); + PUT (FT, "FRIDAY"); + + CREATE (FILE, OUT_FILE, LEGAL_FILE_NAME(2)); + + PUT (FILE, "TUESDAY"); + NEW_LINE (FILE); + PUT (FILE, "THURSDAY"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "FOR IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + CLOSE (FILE); + OPEN (FILE, IN_FILE, LEGAL_FILE_NAME(2)); + + SET_INPUT (FILE); + + -- BEGIN TEST + + GET (FT, X); + IF X /= WEDNESDAY THEN + FAILED ("VALUE FROM FILE INCORRECT"); + END IF; + + GET (X); + IF X /= TUESDAY THEN + FAILED ("VALUE FROM DEFAULT INCORRECT"); + END IF; + + GET (FT, X); + IF X /= FRIDAY THEN + FAILED ("VALUE FROM FILE INCORRECT"); + END IF; + + GET (FILE, X); + IF X /= THURSDAY THEN + FAILED ("VALUE FROM DEFAULT INCORRECT"); + END IF; + + BEGIN + DELETE (FT); + DELETE (FILE); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3905A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CE3905B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR ENUMERATION TYPES RAISE MODE_ERROR WHEN THE + -- MODE OF THE FILE SPECIFIED IS OUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT CREATE FOR TEMP FILES WITH OUT_FILE. + + -- HISTORY: + -- SPS 10/07/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/16/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3905B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3905B", "CHECK THAT ENUMERATION_IO GET RAISES " & + "MODE_ERROR WHEN THE MODE OF THE FILE IS " & + "OUT_FILE"); + + DECLARE + FT : FILE_TYPE; + TYPE COLOR IS (RED, BLUE, GREEN, YELLOW); + X : COLOR; + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILES WITH OUT_FILE " & + "MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X); + FAILED ("MODE_ERROR NOT RAISED - FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE"); + END; + + BEGIN + GET (STANDARD_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - STANDARD_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STANDARD_OUTPUT"); + END; + + BEGIN + GET (CURRENT_OUTPUT, X); + FAILED ("MODE_ERROR NOT RAISED - CURRENT_OUTPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CURRENT_OUTPUT"); + END; + + CLOSE (FT); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3905B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,202 ---- + -- CE3905C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR ENUMERATION TYPES RAISES DATA_ERROR WHEN THE + -- ELEMENT RETRIEVED IS NOT OF THE TYPE EXPECTED OR IS OUT OF THE + -- RANGE OF A SUBTYPE. ALSO CHECK THAT CONSTRAINT_ERROR IS RAISED + -- IF THE VALUE READ IS OUT OF RANGE OF THE ITEM PARAMETER, BUT + -- WITHIN THE RANGE OF THE INSTANTIATED TYPE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/08/82 + -- SPS 12/14/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/16/87 REMOVED DEPENDENCE ON RESET AND CORRECTED + -- EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3905C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3905C", "CHECK THAT GET FOR ENUMERATION TYPES RAISES " & + "DATA_ERROR WHEN THE ELEMENT RETRIEVED IS NOT " & + "OF THE TYPE EXPECTED OR IS OUT OF THE RANGE " & + "OF A SUBTYPE. ALSO CHECK THAT " & + "CONSTRAINT_ERROR IS RAISED IF THE VALUE READ " & + "IS OUT OF RANGE OF THE ITEM PARAMETER, BUT " & + "WITHIN THE RANGE OF THE INSTANTIATED TYPE"); + + DECLARE + FT : FILE_TYPE; + TYPE COLOR IS (RED, BLUE, YELLOW, WHITE, ORANGE, GREEN, + PURPLE, BLACK); + SUBTYPE P_COLOR IS COLOR RANGE RED .. YELLOW; + CRAYON : COLOR := BLACK; + PAINT : P_COLOR := BLUE; + ST : STRING (1 .. 2); + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + BEGIN + + -- CREATE AND INITIALIZE DATA FILE + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "BROWN"); + NEW_LINE (FT); + PUT (FT, "ORANGE"); + NEW_LINE (FT); + PUT (FT, "GREEN"); + NEW_LINE (FT); + PUT (FT, "WHITE"); + NEW_LINE (FT); + PUT (FT, "WHI"); + NEW_LINE (FT); + PUT (FT, "TE"); + NEW_LINE (FT); + PUT (FT, "RED"); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + -- START TEST + + BEGIN + GET (FT, CRAYON); -- BROWN + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF CRAYON /= BLACK THEN + FAILED ("ITEM CRAYON AFFECTED - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + BEGIN + GET (FT, PAINT); -- ORANGE + FAILED ("CONSTRAINT_ERROR NOT RAISED"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + IF PAINT /= BLUE THEN + FAILED ("ITEM PAINT AFFECTED - 2"); + END IF; + WHEN DATA_ERROR => + FAILED ("DATA_ERROR RAISED FOR ITEM SUBTYPE"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + DECLARE + PACKAGE P_COLOR_IO IS NEW ENUMERATION_IO (P_COLOR); + USE P_COLOR_IO; + BEGIN + BEGIN + P_COLOR_IO.GET (FT, PAINT); -- GREEN + FAILED ("DATA_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN DATA_ERROR => + IF PAINT /= BLUE THEN + FAILED ("ITEM PAINT AFFECTED - 3"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + BEGIN + P_COLOR_IO.GET (FT, PAINT); -- WHITE + FAILED ("DATA_ERROR NOT RAISED - 3A"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3A"); + END; + END; + + BEGIN + GET (FT, CRAYON); -- WHI + FAILED ("DATA_ERROR NOT RAISED - 4"); + EXCEPTION + WHEN DATA_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; + + GET (FT, ST); -- TE + + GET (FT, CRAYON); -- RED + IF CRAYON /= RED THEN + FAILED ("READING NOT CONTINUED CORRECTLY AFTER" & + "DATA_ERROR EXCEPTION"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3905C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3905l.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,311 ---- + -- CE3905L.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT DATA_ERROR IS RAISED, BY GET, WHEN THE INPUT CONTAINS + -- + -- 1. EMBEDDED BLANKS. + -- 2. SINGLY QUOTED CHARACTER LITERALS. + -- 3. IDENTIFIERS BEGINNING WITH NON LETTERS. + -- 4. IDENTIFIERS CONTAINING SPECIAL CHARACTERS. + -- 5. CONSECUTIVE UNDERSCORES. + -- 6. LEADING OR TRAILING UNDERSCORES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- VKG 02/14/83 + -- SPS 03/16/83 + -- CPP 07/30/84 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/16/87 REMOVED UNNECESSARY CODE AND CORRECTED + -- EXCEPTION HANDLING. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + + PROCEDURE CE3905L IS + + INCOMPLETE : EXCEPTION; + + BEGIN + TEST ("CE3905L", "CHECK GET FOR ENUMERATION_IO " & + "WITH LEXICAL ERRORS"); + DECLARE + FT : FILE_TYPE; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, "RED ISH"); + NEW_LINE (FT); + PUT (FT, "'A "); + NEW_LINE (FT); + PUT (FT, "2REDISH"); + NEW_LINE (FT); + PUT (FT, "BLUE$%ISH"); + NEW_LINE (FT); + PUT (FT, "RED__ISH"); + NEW_LINE (FT); + PUT (FT, "_YELLOWISH"); + NEW_LINE (FT); + PUT (FT, "GREENISH_"); + NEW_LINE (FT); + + CLOSE (FT); + + DECLARE + TYPE COLOUR IS + ( GREYISH, + REDISH , + BLUEISH, + YELLOWISH, + GREENISH, 'A'); + PACKAGE COLOUR_IO IS NEW ENUMERATION_IO(COLOUR); + USE COLOUR_IO; + X : COLOUR := GREYISH; + CH : CHARACTER; + BEGIN + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "OPEN WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 1"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 1"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 1"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 1"); + ELSE + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 1: CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 2"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 2"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 2"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 2"); + ELSE + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 2: CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 3"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 3"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 3"); + ELSE + GET (FT, CH); + IF CH /= '2' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 3: CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 4"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 4"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 4"); + ELSE + GET (FT, CH); + IF CH /= '$' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 4: CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 5"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 5"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 5"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 5"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 5: CHAR IS " & CH); + ELSE + GET (FT, CH); + IF CH /= 'I' THEN + FAILED ("ERROR READING DATA - 5"); + END IF; + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 6"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 6"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6"); + END; + + IF END_OF_LINE (FT) THEN + FAILED ("GET STOPPED AT END OF LINE - 6"); + ELSE + GET (FT, CH); + IF CH /= '_' THEN + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 6: CHAR IS " & CH); + END IF; + END IF; + + SKIP_LINE (FT); + + BEGIN + GET (FT, X); + FAILED ("DATA_ERROR NOT RAISED - 7"); + EXCEPTION + WHEN DATA_ERROR => + IF X /= GREYISH THEN + FAILED ("ACTUAL PARAMETER TO GET " & + "AFFECTED ON DATA_ERROR - 7"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 7"); + END; + + IF NOT END_OF_LINE (FT) THEN + BEGIN + GET (FT, X); + FAILED ("GET STOPPED AT WRONG POSITION " & + "- 7"); + EXCEPTION + WHEN END_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED FOR " & + "EMPTY FILE - 7"); + END; + END IF; + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3905L; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- CE3906A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR ENUMERATION TYPES CAN OPERATE ON FILES OF + -- MODE OUT_FILE AND THAT WHEN NO FILE PARAMETER IS SPECIFIED + -- THE CURRENT DEFAULT OUTPUT FILE IS USED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEMPORARY TEXT FILES. + + -- HISTORY: + -- SPS 10/08/82 + -- SPS 01/03/83 + -- SPS 02/18/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/17/87 REMOVED UNNECESSARY CODE AND CORRECTED EXCEPTION + -- HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3906A IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3906A", "CHECK THAT PUT FOR ENUMERATION TYPES CAN " & + "OPERATE ON FILES OF MODE OUT_FILE AND THAT " & + "WHEN NO FILE PARAMETER IS SPECIFIED THE " & + "CURRENT DEFAULT OUTPUT FILE IS USED. CHECK " & + "THAT ENUMERATION_IO PUT OPERATES ON OUT_FILE " & + "FILES"); + + DECLARE + FT1, FT2 : FILE_TYPE; + TYPE COLOR IS (ROSE, VANILLA, CHARCOAL, CHOCOLATE); + CRAYON : COLOR := ROSE; + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + BEGIN + + BEGIN + CREATE (FT1, OUT_FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "FOR TEMP FILES WITH OUT_FILE " & + "MODE - 1"); + RAISE INCOMPLETE; + END; + + CREATE (FT2, OUT_FILE); + + SET_OUTPUT (FT2); + + PUT (FT1, CRAYON); + NEW_LINE (FT1); + PUT (FT1, CHOCOLATE); + + CRAYON := CHARCOAL; + + PUT (CRAYON); + NEW_LINE; + PUT (VANILLA); + + -- CHECK OUTPUT + + SET_OUTPUT (STANDARD_OUTPUT); + COMMENT ("CHECKING FT1"); + CHECK_FILE (FT1, "ROSE#CHOCOLATE#@%"); + + COMMENT ("CHECKING FT2"); + CHECK_FILE (FT2, "CHARCOAL#VANILLA#@%"); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3906A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906b.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,133 ---- + -- CE3906B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR ENUMERATION TYPES RAISES MODE_ERROR WHEN + -- APPLIED TO FILES OF MODE IN_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/08/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/17/87 REMOVED DEPENDENCY ON RESET AND CORRECTED + -- EXCEPTION HANDLERS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3906B IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3906B", "CHECK THAT PUT FOR ENUMERATION TYPES RAISES " & + "MODE_ERROR WHEN APPLIED TO FILES OF MODE " & + "IN_FILE"); + + DECLARE + FT : FILE_TYPE; + TYPE FLOWER IS (ROSE, DAISY, SNAPDRAGON, VIOLET, CARNATION); + PACKAGE FLOWER_IO IS NEW ENUMERATION_IO (FLOWER); + USE FLOWER_IO; + X : FLOWER := DAISY; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + PUT (FT, X); + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + BEGIN + PUT (FT, X); + FAILED ("MODE_ERROR NOT RAISED - FILE"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - FILE"); + END; + + BEGIN + PUT (STANDARD_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - STANDARD_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - STANDARD_INPUT"); + END; + + BEGIN + PUT (CURRENT_INPUT, X); + FAILED ("MODE_ERROR NOT RAISED - CURRENT_INPUT"); + EXCEPTION + WHEN MODE_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - CURRENT_INPUT"); + END; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3906B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906c.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,177 ---- + -- CE3906C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT PUT FOR ENUMERATION TYPES OUTPUTS THE ENUMERATION + -- LITERAL WITH NO TRAILING OR PRECEDING BLANKS WHEN WIDTH IS + -- NOT SPECIFIED OR IS SPECIFIED TO BE LESS THAN OR EQUAL TO THE + -- LENGTH OF THE STRING. CHECK THAT WHEN WIDTH IS SPECIFIED TO + -- BE GREATER THAN THE LENGTH OF THE STRING, TRAILING BLANKS ARE + -- OUTPUT. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- HISTORY: + -- SPS 10/08/82 + -- SPS 01/03/83 + -- VKG 01/07/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST. + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/18/87 REMOVED CALL TO CHECKFILE. CLOSED AND REOPENED + -- FILE AND CHECKED CONTENTS OF FILE USING + -- ENUMERATION_IO GETS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3906C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3906C", "CHECK THAT ENUMERATION_IO PUT OUTPUTS " & + "ENUMERATION LITERALS CORRECTLY WITH AND " & + "WITHOUT WIDTH PARAMETERS"); + + DECLARE + FT : FILE_TYPE; + TYPE MOOD IS (ANGRY, HAPPY, BORED, SAD); + X : MOOD := BORED; + PACKAGE MOOD_IO IS NEW ENUMERATION_IO (MOOD); + CH : CHARACTER; + USE MOOD_IO; + BEGIN + + BEGIN + CREATE (FT, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + DEFAULT_WIDTH := FIELD(IDENT_INT(5)); + + IF DEFAULT_WIDTH /= FIELD(IDENT_INT(5)) THEN + FAILED ("DEFAULT_WIDTH NOT SET CORRECTLY"); + END IF; + + PUT (FT, X, 3); -- BORED + X := HAPPY; + NEW_LINE(FT); + PUT (FILE => FT, ITEM => X, WIDTH => 5); -- HAPPY + NEW_LINE (FT); + PUT (FT, SAD, 5); -- SAD + DEFAULT_WIDTH := FIELD(IDENT_INT(6)); + PUT (FT, X); -- HAPPY + PUT (FT, SAD, 3); -- SAD + NEW_LINE(FT); + DEFAULT_WIDTH := FIELD(IDENT_INT(2)); + PUT (FT, SAD); -- SAD + + CLOSE (FT); + + BEGIN + OPEN (FT, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT OPEN FOR " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + GET (FT, X); + IF X /= BORED THEN + FAILED ("BORED NOT READ CORRECTLY"); + END IF; + + GET (FT, X); + IF X /= HAPPY THEN + FAILED ("HAPPY NOT READ CORRECTLY - 1"); + END IF; + + SKIP_LINE (FT); + + GET (FT, X); + IF X /= SAD THEN + FAILED ("SAD NOT READ CORRECTLY - 1"); + END IF; + + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("BLANKS NOT POSITIONED CORRECTLY - 1"); + END IF; + + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("BLANKS NOT POSITIONED CORRECTLY - 2"); + END IF; + + GET (FT, X); + IF X /= HAPPY THEN + FAILED ("HAPPY NOT READ CORRECTLY - 2"); + END IF; + + GET (FT, CH); + IF CH /= ' ' THEN + FAILED ("BLANKS NOT POSITIONED CORRECTLY - 3"); + END IF; + + GET (FT, X); + IF X /= SAD THEN + FAILED ("SAD NOT READ CORRECTLY - 2"); + END IF; + + SKIP_LINE (FT); + + GET (FT, X); + IF X /= SAD THEN + FAILED ("SAD NOT READ CORRECTLY - 3"); + END IF; + + BEGIN + DELETE (FT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3906C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906d.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + -- CE3906D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT FOR ENUMERATION + -- TYPES WHEN THE VALUE OF WIDTH IS NEGATIVE, WHEN WIDTH IS + -- GREATER THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM IS OUTSIDE + -- THE RANGE OF THE SUBTYPE USED TO INSTANTIATE ENUMERATION_IO. + + -- HISTORY: + -- SPS 10/08/82 + -- DWC 09/17/87 ADDED CASES FOR CONSTRAINT_ERROR. + -- JRL 06/07/96 Added call to Ident_Int in expressions involving + -- Field'Last, to make the expressions non-static and + -- prevent compile-time rejection. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3906D IS + BEGIN + + TEST ("CE3906D", "CHECK THAT CONSTRAINT_ERROR IS RAISED BY PUT " & + "FOR ENUMERATION TYPES WHEN THE VALUE OF " & + "WIDTH IS NEGATIVE, WHEN WIDTH IS GREATER " & + "THAN FIELD'LAST, OR WHEN THE VALUE OF ITEM " & + "IS OUTSIDE THE RANGE OF THE SUBTYPE USED TO " & + "INSTANTIATE ENUMERATION_IO"); + + DECLARE + FT : FILE_TYPE; + TYPE DAY IS (SUNDAY, MONDAY, TUESDAY, WEDNESDAY, + THURSDAY, FRIDAY, SATURDAY); + TODAY : DAY := FRIDAY; + SUBTYPE WEEKDAY IS DAY RANGE MONDAY .. FRIDAY; + PACKAGE DAY_IO IS NEW ENUMERATION_IO (WEEKDAY); + USE DAY_IO; + BEGIN + + BEGIN + PUT (FT, TODAY, -1); + FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " & + "WIDTH - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("RAISED STATUS_ERROR"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " & + "WIDTH - FILE"); + END; + + IF FIELD'LAST < INTEGER'LAST THEN + BEGIN + PUT (FT, TODAY, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " & + "GREATER THAN FIELD'LAST + 1- FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; WIDTH " & + "GREATER THAN FIELD'LAST + 1 - FILE"); + END; + + BEGIN + PUT (TODAY, FIELD'LAST + Ident_Int(1)); + FAILED ("CONSTRAINT_ERROR NOT RAISED; WIDTH " & + "GREATER THAN FIELD'LAST + 1 - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; WIDTH " & + "GREATER THAN FIELD'LAST + 1 " & + "- DEFAULT"); + END; + + END IF; + + TODAY := SATURDAY; + + BEGIN + PUT (FT, TODAY); + FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " & + "OUT OF RANGE - FILE"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " & + "OUT OF RANGE - FILE"); + END; + + TODAY := FRIDAY; + + BEGIN + PUT (TODAY, -3); + FAILED ("CONSTRAINT_ERROR NOT RAISED; NEGATIVE " & + "WIDTH - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN STATUS_ERROR => + FAILED ("RAISED STATUS_ERROR"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; NEGATIVE " & + "WIDTH - DEFAULT"); + END; + + TODAY := SATURDAY; + + BEGIN + PUT (TODAY); + FAILED ("CONSTRAINT_ERROR NOT RAISED; ITEM VALUE " & + "OUT OF RANGE - DEFAULT"); + EXCEPTION + WHEN CONSTRAINT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED; ITEM VALUE " & + "OUT OF RANGE - DEFAULT"); + END; + END; + + RESULT; + + END CE3906D; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906e.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + -- CE3906E.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- HISTORY: + -- CHECK THAT PUT FOR ENUMERATION TYPES RAISES LAYOUT_ERROR WHEN + -- THE NUMBER OF CHARACTERS TO BE OUTPUT EXCEEDS THE MAXIMUM LINE + -- LENGTH. CHECK THAT LAYOUT_ERROR IS NOT RAISED WHEN THE NUMBER + -- OF CHARACTERS TO BE OUTPUT DOES NOT EXCEED THE MAXIMUM LINE + -- LENGTH, BUT WHEN ADDED TO THE CURRENT COLUMN NUMBER, THE TOTAL + -- EXCEEDS THE MAXIMUM LINE LENGTH. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMETATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- SPS 10/11/82 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/18/87 CORRECTED EXCEPTION HANDLING. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CE3906E IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("CE3906E", "CHECK THAT ENUMERATION_IO PUT RAISES " & + "LAYOUT_ERROR CORRECTLY"); + + DECLARE + FT : FILE_TYPE; + TYPE COLOR IS (RED, BLU, YELLOW, ORANGE, RD); + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + CRAYON : COLOR := ORANGE; + BEGIN + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE FOR TEMP FILES WITH " & + "OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + SET_LINE_LENGTH (FT, 5); + + BEGIN + PUT (FT, CRAYON); + FAILED("LAYOUT_ERROR NOT RAISED"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + PUT (FT, RED); + + PUT (FT, BLU); + IF LINE (FT) /= 2 THEN + FAILED ("PUT DID NOT CAUSE NEW_LINE EFFECT"); + END IF; + + PUT (FT, RD); + + CHECK_FILE (FT, "RED#" & + "BLURD#@%"); + + CLOSE (FT); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END CE3906E; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3906f.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- CE3906F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE SET PARAMETER AFFECTS THE CASE OF IDENTIFIERS, + -- BUT NOT CHARACTER LITERALS. CHECK THAT CHARACTER LITERALS ARE + -- ENCLOSED IN APOSTROPHES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH + -- SUPPORT TEXT FILES. + + -- HISTORY: + -- JBG 12/30/82 + -- VKG 01/12/83 + -- RJW 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 09/18/87 CORRECTED EXCEPTION HANDLING. + + WITH TEXT_IO; USE TEXT_IO; + WITH REPORT; USE REPORT; + WITH CHECK_FILE; + + PROCEDURE CE3906F IS + + TYPE ENUM IS (REDISH,GREENISH,YELLOWISH); + PACKAGE ENUM_IO IS NEW ENUMERATION_IO(ENUM); + PACKAGE CHAR_IO IS NEW ENUMERATION_IO(CHARACTER); + USE ENUM_IO; USE CHAR_IO; + INCOMPLETE : EXCEPTION; + FT : FILE_TYPE; + + BEGIN + + TEST ("CE3906F", "CHECK THE CASE OF ENUMERATION IO OUTPUT"); + + BEGIN + CREATE (FT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT " & + "CREATE FOR TEMP FILE WITH " & + "OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + END; + + IF ENUM_IO.DEFAULT_WIDTH /= 0 THEN + FAILED ("INITIAL DEFAULT WIDTH INCORRECT"); + END IF; + + IF CHAR_IO.DEFAULT_SETTING /= UPPER_CASE THEN + FAILED ("INITIAL DEFAULT_SETTING INCORRECT"); + END IF; + + PUT (FT, 'A', SET => LOWER_CASE); + NEW_LINE (FT); + PUT (FT, 'a', SET => LOWER_CASE); + NEW_LINE (FT); + PUT (FT, REDISH, SET => LOWER_CASE); + NEW_LINE (FT); + ENUM_IO.DEFAULT_SETTING := LOWER_CASE; + CHAR_IO.PUT (FT, 'C'); + NEW_LINE (FT); + CHAR_IO.PUT (FT, 'b'); + NEW_LINE (FT); + PUT (FT, REDISH); + NEW_LINE (FT); + PUT (FT, GREENISH, SET => LOWER_CASE); + NEW_LINE (FT); + PUT (FT, YELLOWISH, SET => UPPER_CASE); + + CHECK_FILE (FT, "'A'#'a'#redish#'C'#'b'#redish#greenish#" + & "YELLOWISH#@%"); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END CE3906F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3907a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- CE3907A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK THAT PUT FOR ENUMERATION TYPES CAN BE APPLIED TO A STRING. + -- CHECK THAT IT RAISES LAYOUT_ERROR WHEN THE ENUMERATION LITERAL TO BE + -- PLACED IN THE STRING IS LONGER THAN THE STRING. + + -- SPS 10/11/82 + -- JBG 2/22/84 CHANGED TO .ADA TEST + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3907A IS + BEGIN + + TEST ("CE3907A", "CHECK THAT ENUMERATION_IO PUT OPERATES ON " & + "STRINGS CORRECTLY"); + + DECLARE + TYPE COLOR IS (RED, BLUE, GREEN); + ST : STRING (1..4); + PACKAGE COLOR_IO IS NEW ENUMERATION_IO (COLOR); + USE COLOR_IO; + CRAYON : COLOR := GREEN; + BEGIN + PUT (ST, RED); + IF ST /= "RED " THEN + FAILED ("PUT TO STRING, LENGTH LESS THAN STRING " & + "INCORRECT"); + END IF; + + PUT (ST, BLUE); + IF ST /= "BLUE" THEN + FAILED ("PUT TO STRING, LENGTH EQUAL TO STRING " & + "INCORRECT"); + END IF; + + BEGIN + PUT (ST, CRAYON); + FAILED ("LAYOUT_ERROR NOT RAISED"); + EXCEPTION + WHEN LAYOUT_ERROR => + NULL; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED"); + END; + + END; + + RESULT; + END CE3907A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/ce/ce3908a.ada 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- CE3908A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT GET FOR ENUMERATION TYPES CAN OPERATE ON STRINGS. + -- CHECK THAT IT RAISES END_ERROR WHEN THE STRING IS NULL OR + -- EMPTY. CHECK THAT LAST CONTAINS THE INDEX VALUE OF THE LAST + -- CHARACTER READ FROM THE STRING. + + -- HISTORY: + -- SPS 10/11/82 + -- VKG 01/06/83 + -- JBG 02/22/84 CHANGED TO .ADA TEST + -- DWC 09/18/87 ADDED CASES WHICH CONTAIN TABS WITH AND WITHOUT + -- ENUMERATION LITERALS. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE CE3908A IS + BEGIN + + TEST ("CE3908A", "CHECK THAT GET FOR ENUMERATION TYPES CAN " & + "OPERATE ON STRINGS. CHECK THAT IT RAISES " & + "END_ERROR WHEN THE STRING IS NULL OR EMPTY. " & + "CHECK THAT LAST CONTAINS THE INDEX VALUE OF " & + "THE LAST CHARACTER READ FROM THE STRING"); + + DECLARE + TYPE FRUIT IS (APPLE, PEAR, ORANGE, STRAWBERRY); + DESSERT : FRUIT; + PACKAGE FRUIT_IO IS NEW ENUMERATION_IO (FRUIT); + USE FRUIT_IO; + L : POSITIVE; + BEGIN + GET ("APPLE ", DESSERT, L); + IF DESSERT /= APPLE THEN + FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 1"); + END IF; + + IF L /= IDENT_INT (5) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 1"); + END IF; + + GET ("APPLE", DESSERT, L); + IF DESSERT /= APPLE THEN + FAILED ("ENUMERATION VALUE FROM STRING INCORRECT - 2"); + END IF; + + IF L /= IDENT_INT (5) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE AFTER GET - 2"); + END IF; + + BEGIN + GET (ASCII.HT & "APPLE", DESSERT, L); + IF DESSERT /= APPLE THEN + FAILED ("ENUMERATION VALUE FROM STRING " & + "INCORRECT - 3"); + END IF; + IF L /= IDENT_INT(6) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE AFTER " & + "GET - 3"); + END IF; + EXCEPTION + WHEN END_ERROR => + FAILED ("GET DID NOT SKIP LEADING TABS"); + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 3"); + END; + + -- NULL STRING LITERAL. + + BEGIN + GET ("", DESSERT, L); + FAILED ("END_ERROR NOT RAISED - 4"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(6) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE " & + "AFTER GET - 4"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 4"); + END; + + BEGIN + GET (ASCII.HT & "", DESSERT, L); + FAILED ("END_ERROR NOT RAISED - 5"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(6) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE " & + "AFTER GET - 5"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 5"); + END; + + -- STRING LITERAL WITH BLANKS. + + BEGIN + GET(" ", DESSERT, L); + FAILED ("END ERROR NOT RAISED - 6"); + EXCEPTION + WHEN END_ERROR => + IF L /= IDENT_INT(6) THEN + FAILED ("LAST CONTAINS INCORRECT VALUE " & + "AFTER GET - 6"); + END IF; + WHEN OTHERS => + FAILED ("WRONG EXCEPTION RAISED - 6"); + END; + + END; + + RESULT; + END CE3908A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3001.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,507 ---- + -- CXA3001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the character classification functions defined in + -- package Ada.Characters.Handling produce correct results when provided + -- constant arguments from package Ada.Characters.Latin_1. + -- + -- TEST DESCRIPTION: + -- This test checks the character classification functions of package + -- Ada.Characters.Handling. In the evaluation of each function, loops + -- are constructed to examine the function with as many values of type + -- Character (Ada.Characters.Latin_1 constants) as possible in an + -- amount of code that is about equal to the amount of code required + -- to examine the function with a few representative input values and + -- endpoint values. + -- The usage paradigm being demonstrated by this test is that of the + -- functions being used to assign to boolean variables, as well as + -- serving as boolean conditions. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 29 Apr 95 SAIC Fixed subtest checking Is_Graphic function. + -- + --! + + with Ada.Characters.Latin_1; + with Ada.Characters.Handling; + with Report; + + procedure CXA3001 is + + begin + + Report.Test ("CXA3001", "Check that the character classification " & + "functions defined in package " & + "Ada.Characters.Handling produce " & + "correct results when provided constant " & + "arguments from package Ada.Characters.Latin_1"); + + Test_Block: + declare + + package AC renames Ada.Characters; + package ACH renames Ada.Characters.Handling; + + TC_Boolean : Boolean := False; + + begin + + -- Over the next six statements/blocks of code, evaluate functions + -- Is_Control and Is_Graphic with control character and non-control + -- character values. + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.US) loop + if not ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 1"); + end if; + if ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 1"); + end if; + end loop; + + + for i in Character'Pos(AC.Latin_1.Space) .. + Character'Pos(AC.Latin_1.Tilde) loop + if not ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 2"); + end if; + if ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 2"); + end if; + end loop; + + + for i in Character'Pos(AC.Latin_1.Reserved_128) .. + Character'Pos(AC.Latin_1.APC) loop + if not ACH.Is_Control(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Control - 3"); + end if; + TC_Boolean := ACH.Is_Graphic(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect result from function Is_Graphic - 3"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.No_Break_Space) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + TC_Boolean := ACH.Is_Control(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect result from function Is_Control - 4"); + TC_Boolean := False; + end if; + if not ACH.Is_Graphic(Character'Val(i)) then + Report.Failed ("Incorrect result from function Is_Graphic - 4"); + end if; + end loop; + + -- Check renamed constants. + + if not (ACH.Is_Control(AC.Latin_1.IS4) and + ACH.Is_Control(AC.Latin_1.IS3) and + ACH.Is_Control(AC.Latin_1.IS2) and + ACH.Is_Control(AC.Latin_1.IS1)) or + (ACH.Is_Control(AC.Latin_1.NBSP) or + ACH.Is_Control(AC.Latin_1.Paragraph_Sign) or + ACH.Is_Control(AC.Latin_1.Minus_Sign) or + ACH.Is_Control(AC.Latin_1.Ring_Above)) + then + Report.Failed ("Incorrect result from function Is_Control - 5"); + end if; + + if (ACH.Is_Graphic(AC.Latin_1.IS4) or + ACH.Is_Graphic(AC.Latin_1.IS3) or + ACH.Is_Graphic(AC.Latin_1.IS2) or + ACH.Is_Graphic(AC.Latin_1.IS1)) or + not (ACH.Is_Graphic(AC.Latin_1.NBSP) and + ACH.Is_Graphic(AC.Latin_1.Paragraph_Sign) and + ACH.Is_Graphic(AC.Latin_1.Minus_Sign) and + ACH.Is_Graphic(AC.Latin_1.Ring_Above)) + then + Report.Failed ("Incorrect result from function Is_Graphic - 5"); + end if; + + + -- Evaluate function Is_Letter with letter/non-letter inputs. + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 3"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 4"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 5"); + end if; + end loop; + + -- Check for rejection of non-letters. + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.Commercial_At) loop + if ACH.Is_Letter(Character'Val(i)) then + Report.Failed ("Incorrect Is_Letter result - 6"); + end if; + end loop; + + + -- Evaluate function Is_Lower with lower case/non-lower case inputs. + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A_Grave) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Lower(Character'Val(i)) then + Report.Failed ("Incorrect Is_Lower result - 3"); + end if; + end loop; + + if ACH.Is_Lower('A') or + ACH.Is_Lower(AC.Latin_1.UC_Icelandic_Eth) or + ACH.Is_Lower(AC.Latin_1.Number_Sign) or + ACH.Is_Lower(AC.Latin_1.Cedilla) or + ACH.Is_Lower(AC.Latin_1.SYN) or + ACH.Is_Lower(AC.Latin_1.ESA) + then + Report.Failed ("Incorrect Is_Lower result - 4"); + end if; + + + -- Evaluate function Is_Upper with upper case/non-upper case inputs. + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.UC_Icelandic_Thorn) loop + if not ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 3"); + end if; + end loop; + + if ACH.Is_Upper('8') or + ACH.Is_Upper(AC.Latin_1.LC_A_Ring ) or + ACH.Is_Upper(AC.Latin_1.Dollar_Sign) or + ACH.Is_Upper(AC.Latin_1.Broken_Bar) or + ACH.Is_Upper(AC.Latin_1.ETB) or + ACH.Is_Upper(AC.Latin_1.VTS) + then + Report.Failed ("Incorrect Is_Upper result - 4"); + end if; + + + for i in Character'Pos('a') .. Character'Pos('z') loop + if ACH.Is_Upper(Character'Val(i)) then + Report.Failed ("Incorrect Is_Upper result - 5"); + end if; + end loop; + + + -- Evaluate function Is_Basic with basic/non-basic inputs. + -- (Note: Basic letters are those without diacritical marks.) + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 1"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 2"); + end if; + end loop; + + + if not (ACH.Is_Basic(AC.Latin_1.UC_AE_Diphthong) and + ACH.Is_Basic(AC.Latin_1.LC_AE_Diphthong) and + ACH.Is_Basic(AC.Latin_1.LC_German_Sharp_S) and + ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Eth) and + ACH.Is_Basic(AC.Latin_1.LC_Icelandic_Thorn) and + ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Eth) and + ACH.Is_Basic(AC.Latin_1.UC_Icelandic_Thorn)) + then + Report.Failed ("Incorrect Is_Basic result - 3"); + end if; + + -- Check for rejection of non-basics. + if ACH.Is_Basic(AC.Latin_1.UC_A_Tilde) or + ACH.Is_Basic(AC.Latin_1.LC_A_Grave) or + ACH.Is_Basic(AC.Latin_1.Ampersand) or + ACH.Is_Basic(AC.Latin_1.Yen_Sign) or + ACH.Is_Basic(AC.Latin_1.NAK) or + ACH.Is_Basic(AC.Latin_1.SS2) + then + Report.Failed ("Incorrect Is_Basic result - 4"); + end if; + + + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.Commercial_At) loop + if ACH.Is_Basic(Character'Val(i)) then + Report.Failed ("Incorrect Is_Basic result - 5"); + end if; + end loop; + + + -- Evaluate functions Is_Digit and Is_Decimal_Digit (a rename of + -- Is_Digit) with decimal digit/non-digit inputs. + + + if not (ACH.Is_Digit('0') and + ACH.Is_Decimal_Digit('9')) or + ACH.Is_Digit ('a') or -- Hex digits. + ACH.Is_Decimal_Digit ('f') or + ACH.Is_Decimal_Digit ('A') or + ACH.Is_Digit ('F') + then + Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 1"); + end if; + + if ACH.Is_Digit (AC.Latin_1.Full_Stop) or + ACH.Is_Decimal_Digit (AC.Latin_1.Dollar_Sign) or + ACH.Is_Digit (AC.Latin_1.Number_Sign) or + ACH.Is_Decimal_Digit (AC.Latin_1.Left_Parenthesis) or + ACH.Is_Digit (AC.Latin_1.Right_Parenthesis) + then + Report.Failed ("Incorrect Is_Digit/Is_Decimal_Digit result - 2"); + end if; + + + -- Evaluate functions Is_Hexadecimal_Digit with hexadecimal digit and + -- non-hexadecimal digit inputs. + + for i in Character'Pos('0') .. Character'Pos('9') loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 1"); + end if; + end loop; + + for i in Character'Pos('A') .. Character'Pos('F') loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_F) loop + if not ACH.Is_Hexadecimal_Digit(Character'Val(i)) then + Report.Failed ("Incorrect Is_Hexadecimal_Digit result - 3"); + end if; + end loop; + + + if ACH.Is_Hexadecimal_Digit (AC.Latin_1.Minus_Sign) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Hyphen) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_G) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.LC_Z) or + ACH.Is_Hexadecimal_Digit ('G') or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Cent_Sign) or + ACH.Is_Hexadecimal_Digit (AC.Latin_1.Pound_Sign) + then + Report.Failed ("Incorrect Is_HexaDecimal_Digit result - 4"); + end if; + + + -- Evaluate functions Is_Alphanumeric and Is_Special with + -- letters, digits, and non-alphanumeric inputs. + + for i in Character'Pos(AC.Latin_1.NUL) .. + Character'Pos(AC.Latin_1.US) loop + if ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 1"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 1"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.Reserved_128) .. + Character'Pos(AC.Latin_1.APC) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 2"); + TC_Boolean := False; + end if; + if ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 2"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.Space) .. + Character'Pos(AC.Latin_1.Solidus) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 3"); + TC_Boolean := False; + end if; + if not ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 3"); + end if; + end loop; + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 4"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 4"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos('0') .. Character'Pos('9') loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 5"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 5"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 6"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 6"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.No_Break_Space) .. + Character'Pos(AC.Latin_1.Inverted_Question) loop + TC_Boolean := ACH.Is_Alphanumeric(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Alphanumeric result - 7"); + TC_Boolean := False; + end if; + if not ACH.Is_Special(Character'Val(i)) then + Report.Failed ("Incorrect Is_Special result - 7"); + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_A_Grave) .. + Character'Pos(AC.Latin_1.UC_O_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 8"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 8"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.UC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_O_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 9"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 9"); + TC_Boolean := False; + end if; + end loop; + + for i in Character'Pos(AC.Latin_1.LC_O_Oblique_Stroke) .. + Character'Pos(AC.Latin_1.LC_Y_Diaeresis) loop + if not ACH.Is_Alphanumeric(Character'Val(i)) then + Report.Failed ("Incorrect Is_Alphanumeric result - 10"); + end if; + TC_Boolean := ACH.Is_Special(Character'Val(i)); + if TC_Boolean then + Report.Failed ("Incorrect Is_Special result - 10"); + TC_Boolean := False; + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised during processing"); + end Test_Block; + + + Report.Result; + + end CXA3001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3002.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,318 ---- + -- CXA3002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the conversion functions for Characters and Strings + -- defined in package Ada.Characters.Handling provide correct results + -- when given character/string input parameters. + -- + -- TEST DESCRIPTION: + -- This test checks the output of the To_Lower, To_Upper, and + -- To_Basic functions for both Characters and Strings. Each function + -- is called with input parameters that are within the appropriate + -- range of values, and also with values outside the specified + -- range (i.e., lower case 'a' to To_Lower). The functions are also + -- used in combination with one another, with the result of one function + -- providing the actual input parameter value to another. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 22 Dec 94 SAIC Corrected evaluations of Functions In Combination. + -- + --! + + with Ada.Characters.Latin_1; + with Ada.Characters.Handling; + with Report; + + procedure CXA3002 is + + package AC renames Ada.Characters; + package ACH renames Ada.Characters.Handling; + + begin + + Report.Test ("CXA3002", "Check that the conversion functions for " & + "Characters and Strings defined in package " & + "Ada.Characters.Handling provide correct " & + "results when given character/string input " & + "parameters"); + + + Character_Block: + declare + Offset : constant Integer := Character'Pos('a') - Character'Pos('A'); + begin + + -- Function To_Lower for Characters + + if ACH.To_Lower('A') /= 'a' or ACH.To_Lower('Z') /= 'z' then + Report.Failed ("Incorrect operation of function To_Lower - 1"); + end if; + + + for i in Character'Pos('A') .. Character'Pos('Z') loop + if ACH.To_Lower(Character'Val(i)) /= Character'Val(i + Offset) then + Report.Failed ("Incorrect operation of function To_Lower - 2"); + end if; + end loop; + + + if (ACH.To_Lower(AC.Latin_1.UC_A_Grave) /= + AC.Latin_1.LC_A_Grave) or + (ACH.To_Lower(AC.Latin_1.UC_Icelandic_Thorn) /= + AC.Latin_1.LC_Icelandic_Thorn) + then + Report.Failed ("Incorrect operation of function To_Lower - 3"); + end if; + + + if ACH.To_Lower('c') /= 'c' or + ACH.To_Lower('w') /= 'w' or + ACH.To_Lower(AC.Latin_1.CR) /= AC.Latin_1.CR or + ACH.To_Lower(AC.Latin_1.LF) /= AC.Latin_1.LF or + ACH.To_Lower(AC.Latin_1.Comma) /= AC.Latin_1.Comma or + ACH.To_Lower(AC.Latin_1.Question) /= AC.Latin_1.Question or + ACH.To_Lower('0') /= '0' or + ACH.To_Lower('9') /= '9' + then + Report.Failed ("Incorrect operation of function To_Lower - 4"); + end if; + + + --- Function To_Upper for Characters + + + if not (ACH.To_Upper('b') = 'B') and (ACH.To_Upper('y') = 'Y') then + Report.Failed ("Incorrect operation of function To_Upper - 1"); + end if; + + + for i in Character'Pos(AC.Latin_1.LC_A) .. + Character'Pos(AC.Latin_1.LC_Z) loop + if ACH.To_Upper(Character'Val(i)) /= Character'Val(i - Offset) then + Report.Failed ("Incorrect operation of function To_Upper - 2"); + end if; + end loop; + + + if (ACH.To_Upper(AC.Latin_1.LC_U_Diaeresis) /= + AC.Latin_1.UC_U_Diaeresis) or + (ACH.To_Upper(AC.Latin_1.LC_A_Ring) /= + AC.Latin_1.UC_A_Ring) + then + Report.Failed ("Incorrect operation of function To_Upper - 3"); + end if; + + + if not (ACH.To_Upper('F') = 'F' and + ACH.To_Upper('U') = 'U' and + ACH.To_Upper(AC.Latin_1.LC_German_Sharp_S) = + AC.Latin_1.LC_German_Sharp_S and + ACH.To_Upper(AC.Latin_1.LC_Y_Diaeresis) = + AC.Latin_1.LC_Y_Diaeresis) + then + Report.Failed ("Incorrect operation of function To_Upper - 4"); + end if; + + + --- Function To_Basic for Characters + + + if ACH.To_Basic(AC.Latin_1.LC_A_Circumflex) /= + ACH.To_Basic(AC.Latin_1.LC_A_Tilde) or + ACH.To_Basic(AC.Latin_1.LC_E_Grave) /= + ACH.To_Basic(AC.Latin_1.LC_E_Acute) or + ACH.To_Basic(AC.Latin_1.LC_I_Circumflex) /= + ACH.To_Basic(AC.Latin_1.LC_I_Diaeresis) or + ACH.To_Basic(AC.Latin_1.UC_O_Tilde) /= + ACH.To_Basic(AC.Latin_1.UC_O_Acute) or + ACH.To_Basic(AC.Latin_1.UC_U_Grave) /= + ACH.To_Basic(AC.Latin_1.UC_U_Acute) or + ACH.To_Basic(AC.Latin_1.LC_Y_Acute) /= + ACH.To_Basic(AC.Latin_1.LC_Y_Diaeresis) + then + Report.Failed ("Incorrect operation of function To_Basic - 1"); + end if; + + + if ACH.To_Basic('Y') /= 'Y' or + ACH.To_Basic(AC.Latin_1.LC_E_Acute) /= 'e' or + ACH.To_Basic('6') /= '6' or + ACH.To_Basic(AC.Latin_1.LC_R) /= 'r' + then + Report.Failed ("Incorrect operation of function To_Basic - 2"); + end if; + + + -- Using Functions (for Characters) in Combination + + + if (ACH.To_Upper(ACH.To_Lower('A')) /= 'A' ) or + (ACH.To_Upper(ACH.To_Lower(AC.Latin_1.UC_A_Acute)) /= + AC.Latin_1.UC_A_Acute ) + then + Report.Failed("Incorrect operation of functions in combination - 1"); + end if; + + + if ACH.To_Basic(ACH.To_Lower(ACH.To_Upper(AC.Latin_1.LC_U_Grave))) /= + 'u' + then + Report.Failed("Incorrect operation of functions in combination - 2"); + end if; + + + if ACH.To_Lower (ACH.To_Basic + (ACH.To_Upper(AC.Latin_1.LC_O_Diaeresis))) /= 'o' + then + Report.Failed("Incorrect operation of functions in combination - 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Character_Block"); + end Character_Block; + + + String_Block: + declare + + LC_String : constant String := "az" & + AC.Latin_1.LC_A_Grave & + AC.Latin_1.LC_C_Cedilla; + + UC_String : constant String := "AZ" & + AC.Latin_1.UC_A_Grave & + AC.Latin_1.UC_C_Cedilla; + + LC_Basic_String : constant String := "aei" & 'o' & 'u'; + + LC_NonBasic_String : constant String := AC.Latin_1.LC_A_Diaeresis & + AC.Latin_1.LC_E_Circumflex & + AC.Latin_1.LC_I_Acute & + AC.Latin_1.LC_O_Tilde & + AC.Latin_1.LC_U_Grave; + + UC_Basic_String : constant String := "AEIOU"; + + UC_NonBasic_String : constant String := AC.Latin_1.UC_A_Tilde & + AC.Latin_1.UC_E_Acute & + AC.Latin_1.UC_I_Grave & + AC.Latin_1.UC_O_Diaeresis & + AC.Latin_1.UC_U_Circumflex; + + LC_Special_String : constant String := "ab" & + AC.Latin_1.LC_German_Sharp_S & + AC.Latin_1.LC_Y_Diaeresis; + + UC_Special_String : constant String := "AB" & + AC.Latin_1.LC_German_Sharp_S & + AC.Latin_1.LC_Y_Diaeresis; + + begin + + -- Function To_Lower for Strings + + + if ACH.To_Lower (UC_String) /= LC_String or + ACH.To_Lower (LC_String) /= LC_String + then + Report.Failed ("Incorrect result from To_Lower for strings - 1"); + end if; + + + if ACH.To_Lower (UC_Basic_String) /= LC_Basic_String then + Report.Failed ("Incorrect result from To_Lower for strings - 2"); + end if; + + + -- Function To_Upper for Strings + + + if not (ACH.To_Upper (LC_String) = UC_String) then + Report.Failed ("Incorrect result from To_Upper for strings - 1"); + end if; + + + if ACH.To_Upper (LC_Basic_String) /= UC_Basic_String or + ACH.To_Upper (UC_String) /= UC_String + then + Report.Failed ("Incorrect result from To_Upper for strings - 2"); + end if; + + + if ACH.To_Upper (LC_Special_String) /= UC_Special_String then + Report.Failed ("Incorrect result from To_Upper for strings - 3"); + end if; + + + + -- Function To_Basic for Strings + + + if (ACH.To_Basic (LC_String) /= "azac") or + (ACH.To_Basic (UC_String) /= "AZAC") + then + Report.Failed ("Incorrect result from To_Basic for Strings - 1"); + end if; + + + if ACH.To_Basic (LC_NonBasic_String) /= LC_Basic_String then + Report.Failed ("Incorrect result from To_Basic for Strings - 2"); + end if; + + + if ACH.To_Basic (UC_NonBasic_String) /= UC_Basic_String then + Report.Failed ("Incorrect result from To_Basic for Strings - 3"); + end if; + + + -- Using Functions (for Strings) in Combination + + + if ACH.To_Upper(ACH.To_Lower(UC_Basic_String)) /= UC_Basic_String or + ACH.To_Lower(ACH.To_Upper(LC_Basic_String)) /= LC_Basic_String + then + Report.Failed ("Incorrect operation of functions in combination - 4"); + end if; + + + if (ACH.To_Basic(ACH.To_Lower(UC_NonBasic_String)) /= LC_Basic_String) or + (ACH.To_Basic(ACH.To_Upper(LC_NonBasic_String)) /= UC_Basic_String) + then + Report.Failed ("Incorrect operation of functions in combination - 5"); + end if; + + + exception + when others => Report.Failed ("Exception raised in String_Block"); + end String_Block; + + + Report.Result; + + end CXA3002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3003.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,243 ---- + -- CXA3003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions defined in package Ada.Characters.Handling + -- for use in classifying and converting characters between the ISO 646 + -- and type Character sets produce the correct results with both + -- Character and String input values. + -- + -- TEST DESCRIPTION: + -- This test is designed to exercise the classification and conversion + -- functions (between Character and ISO_646 types) found in package + -- Ada.Characters.Handling. Two subprograms are defined, a procedure for + -- characters, a function for strings, that will utilize these functions + -- to validate and change characters in variables. In the procedure, if + -- a character argument is found to be outside the subtype ISO_646, this + -- character is evaluated to determine whether it is also a letter. + -- If it is a letter, the character is converted to a basic character and + -- returned. If it is not a letter, the character is exchanged with an + -- asterisk. In the case of the function subprogram designed for strings, + -- if a character component of a string argument is outside the subtype + -- ISO_646, that character is substituted with an asterisk. + -- + -- Arguments for the defined subprograms consist of ISO_646 characters, + -- non-ISO_646 characters, strings with only ISO_646 characters, and + -- strings with non-ISO_646 characters. The character and string values + -- are then validated to determine that the expected results were + -- obtained. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 29 Apr 95 SAIC Modified identifier string lengths. + -- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. + -- + --! + + with Ada.Characters.Latin_1; + with Ada.Characters.Handling; + with Report; + + procedure CXA3003 is + + begin + + Report.Test ("CXA3003", "Check that the functions defined in package " & + "Ada.Characters.Handling for use in " & + "classifying and converting characters " & + "between the ISO 646 and type Character sets " & + "produce the correct results with both " & + "Character and String input values" ); + + Test_Block: + declare + + -- ISO_646 Characters + + Char_1, + TC_Char_1 : Character := Ada.Characters.Latin_1.NUL; -- Control Char + Char_2, + TC_Char_2 : Character := Ada.Characters.Latin_1.Colon; -- Graphic Char + Char_3, + TC_Char_3 : Character := '4'; + Char_4, + TC_Char_4 : Character := 'Z'; + Char_5, + TC_Char_5 : Character := Ada.Characters.Latin_1.LC_W; -- w + + New_ISO_646_Char : Character := '*'; + + + -- Non-ISO_646 Characters + + Char_Array : array (6..10) of Character := + (Ada.Characters.Latin_1.SSA, + Ada.Characters.Latin_1.Cent_Sign, + Ada.Characters.Latin_1.Cedilla, + Ada.Characters.Latin_1.UC_A_Ring, + Ada.Characters.Latin_1.LC_A_Ring); + + TC_Char : constant Character := '*'; + + -- ISO_646 Strings + + Str_1, + TC_Str_1 : String (1..5) := "ABCDE"; + + Str_2, + TC_Str_2 : String (1..5) := "#$%^&"; + + + -- Non-ISO_646 Strings + + Str_3 : String (1..8) := "$123.45" & + Ada.Characters.Latin_1.Cent_Sign; + TC_Str_3 : String (1..8) := "$123.45*"; + + Str_4 : String (1..7) := "abc" & + Ada.Characters.Latin_1.Cedilla & + "efg"; + TC_Str_4 : String (1..7) := "abc*efg"; + + Str_5 : String (1..3) := Ada.Characters.Latin_1.LC_E_Grave & + Ada.Characters.Latin_1.LC_T & + Ada.Characters.Latin_1.LC_E_Acute; + TC_Str_5 : String (1..3) := "*t*"; + + --- + + procedure Validate_Character (Char : in out Character) is + -- If parameter Char is an ISO_646 character, Char will be returned, + -- otherwise the following constant will be returned. + Star : constant Ada.Characters.Handling.ISO_646 := + Ada.Characters.Latin_1.Asterisk; + begin + if Ada.Characters.Handling.Is_ISO_646(Char) then + -- Check that the Is_ISO_646 function provide a correct result. + if Character'Pos(Char) > 127 then + Report.Failed("Is_ISO_646 returns a false positive result"); + end if; + else + if Character'Pos(Char) < 128 then + Report.Failed("Is_ISO_646 returns a false negative result"); + end if; + end if; + -- Cross-check Is_ISO_646 with To_ISO_646. '*' will be returned + -- if Char is not in the ISO_646 set. + Char := Ada.Characters.Handling.To_ISO_646(Char, Star); + exception + when others => Report.Failed ("Exception in Validate_Character"); + end Validate_Character; + + --- + + function Validate_String (Str : String) return String is + New_ISO_646_Char : constant Ada.Characters.Handling.ISO_646 := + Ada.Characters.Latin_1.Asterisk; + begin + -- Checking that the string contains non-ISO_646 characters at this + -- point is not strictly necessary, since the function To_ISO_646 + -- will perform that check as part of its processing, and would + -- return the original string if no modification were necessary. + -- However, this format allows for the testing of both functions. + + if not Ada.Characters.Handling.Is_ISO_646(Str) then + return Ada.Characters.Handling.To_ISO_646 + (Item => Str, Substitute => New_ISO_646_Char); + else + return Str; + end if; + exception + when others => Report.Failed ("Exception in Validate_String"); + return Str; + end Validate_String; + + + begin + + -- Check each character in turn, and if the character does not belong + -- to the ISO_646 subset of type Character, replace it with an + -- asterisk. If the character is a member of the subset, the character + -- should be returned unchanged. + + Validate_Character (Char_1); + Validate_Character (Char_2); + Validate_Character (Char_3); + Validate_Character (Char_4); + Validate_Character (Char_5); + + if Char_1 /= TC_Char_1 or Char_2 /= TC_Char_2 or + Char_3 /= TC_Char_3 or Char_4 /= TC_Char_4 or + Char_5 /= TC_Char_5 + then + Report.Failed ("Incorrect ISO_646 character substitution"); + end if; + + -- Non-ISO_646 characters + + for i in 6..10 loop + Validate_Character (Char_Array(i)); + end loop; + + for i in 6..10 loop + if Char_Array(i) /= TC_Char then + Report.Failed ("Character position " & Integer'Image(i) & + " not replaced correctly"); + end if; + end loop; + + + + -- Check each string, and if the string contains characters that do not + -- belong to the ISO_646 subset of type Character, replace that character + -- in the string with an asterisk. If the string is comprised of only + -- ISO_646 characters, the string should be returned unchanged. + + + Str_1 := Validate_String (Str_1); + Str_2 := Validate_String (Str_2); + Str_3 := Validate_String (Str_3); + Str_4 := Validate_String (Str_4); + Str_5 := Validate_String (Str_5); + + + if Str_1 /= TC_Str_1 or + Str_2 /= TC_Str_2 or + Str_3 /= TC_Str_3 or + Str_4 /= TC_Str_4 or + Str_5 /= TC_Str_5 + then + Report.Failed ("Incorrect ISO_646 character substitution in string"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA3003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa3004.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,235 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4001.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,218 ---- + -- CXA4001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the types, operations, and other entities defined within + -- the package Ada.Strings.Maps are available and/or produce correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the availability and function of the types and + -- operations defined in package Ada.Strings.Maps. It demonstrates the + -- use of these types and functions as they would be used in common + -- programming practice. + -- Character set creation, assignment, and comparison are evaluated + -- in this test. Each of the functions provided in package + -- Ada.Strings.Maps is utilized in creating or manipulating set objects, + -- and the function results are evaluated for correctness. + -- Character sequences are examined using the functions provided for + -- manipulating objects of this type. Likewise, character maps are + -- created, and their contents evaluated. Exception raising conditions + -- from the function To_Mapping are also created. + -- Note: Throughout this test, the set logical operators are printed in + -- capital letters to enhance their visibility. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Strings.Maps; + with Report; + + procedure CXA4001 is + + use Ada.Strings; + use type Maps.Character_Set; + + begin + + Report.Test ("CXA4001", "Check that the types, operations, and other " & + "entities defined within the package " & + "Ada.Strings.Maps are available and/or produce " & + "correct results"); + + Test_Block: + declare + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Maps.Character_Sequence := "aeiou"; + Quasi_Vowel : constant Character := 'y'; + + Alphabet : Maps.Character_Sequence (1..Last_Letter); + Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); + Inverse_Alphabet : Maps.Character_Sequence (1..Last_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + Full_Vowel_Set, + First_Half_Set, + Second_Half_Set : Maps.Character_Set; + + begin + + -- Load the alphabet string for use in creating sets. + + + for i in 0..12 loop + Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + for i in 0..25 loop + Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + + -- Initialize a series of Character_Set objects. + + Alphabet_Set := Maps.To_Set(Alphabet); + Vowel_Set := Maps.To_Set(Vowels); + Full_Vowel_Set := Vowel_Set OR Maps.To_Set(Quasi_Vowel); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + First_Half_Set := Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + -- Evaluation of Set objects, operators, and functions. + + if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then + Report.Failed("Incorrect set combinations using OR operator"); + end if; + + + for i in 1..5 loop + if not Maps.Is_In(Vowels(i), Vowel_Set) or + not Maps.Is_In(Vowels(i), Alphabet_Set) or + Maps.Is_In(Vowels(i), Consonant_Set) + then + Report.Failed("Incorrect function Is_In use with set " & + "combinations - " & Integer'Image(i)); + end if; + end loop; + + + if Maps.Is_Subset(Vowel_Set, First_Half_Set) or + Maps."<="(Vowel_Set, Second_Half_Set) or + not Maps.Is_Subset(Vowel_Set, Alphabet_Set) + then + Report.Failed("Incorrect set evaluation using Is_Subset function"); + end if; + + + if not (Full_Vowel_Set = Maps.To_Set("aeiouy")) then + Report.Failed("Incorrect result for ""="" set operator"); + end if; + + + if not ((Vowel_Set AND First_Half_Set) OR + (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then + Report.Failed + ("Incorrect result for AND, OR, or ""="" set operators"); + end if; + + + if (Alphabet_Set AND Maps.Null_Set) /= Maps.Null_Set or + (Alphabet_Set OR Maps.Null_Set) /= Alphabet_Set + then + Report.Failed("Incorrect result for AND or OR set operators"); + end if; + + + Vowel_Set := Full_Vowel_Set; + Vowel_Set := Vowel_Set AND (NOT Maps.To_Set(Quasi_Vowel)); + + if not (Vowels = Maps.To_Sequence(Vowel_Set)) then + Report.Failed("Incorrect Set to Sequence translation"); + end if; + + + for i in 1..26 loop + Inverse_Alphabet(i) := Alphabet(27-i); + end loop; + + declare + Inverse_Map : Maps.Character_Mapping := + Maps.To_Mapping(Alphabet, Inverse_Alphabet); + begin + if Maps.Value(Maps.Identity, 'b') /= Maps.Value(Inverse_Map,'y') + then + Report.Failed("Incorrect Inverse mapping"); + end if; + end; + + + -- Check that Translation_Error is raised when a character is + -- repeated in the parameter "From" string. + declare + Bad_Map : Maps.Character_Mapping; + begin + Bad_Map := Maps.To_Mapping(From => "aa", To => "yz"); + Report.Failed("Exception not raised with repeated character"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "a repeated character"); + end; + + + -- Check that Translation_Error is raised when the parameters of the + -- function To_Mapping are of unequal lengths. + declare + Bad_Map : Maps.Character_Mapping; + begin + Bad_Map := Maps.To_Mapping("abc", "yz"); + Report.Failed("Exception not raised with unequal parameter lengths"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "unequal parameter lengths"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4002.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,182 ---- + -- CXA4002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Fixed are + -- available, and that they produce correct results. Specifically, + -- check the subprograms Index, "*" (string constructor function), + -- Count, Trim, and Replace_Slice. + -- + -- TEST DESCRIPTION: + -- This test demonstrates how certain Fixed string functions are used + -- to eliminate specific substrings from portions of text. A procedure + -- is defined that will take as parameters a source string along with + -- a substring that is to be completely removed from the source string. + -- The source string is parsed using the Index function, and any substring + -- slices are replaced in the source string by a series of X's (based on + -- the length of the substring.) + -- Three lines of text are provided to this procedure, and the resulting + -- substitutions are compared with expected results to validate the + -- string processing. + -- A global accumulator is updated with the number of occurrences of the + -- substring in the source string. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Strings; + with Ada.Strings.Fixed; + with Ada.Strings.Maps; + with Report; + + procedure CXA4002 is + + begin + + Report.Test ("CXA4002", "Check that the subprograms defined in package " & + "Ada.Strings.Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + TC_Total : Natural := 0; + Number_Of_Lines : constant := 3; + + type Restricted_Words_Array_Type is array (1..10) of String (1..10); + + Restricted_Words : Restricted_Words_Array_Type := + (" platoon", " marines ", " Marines ", + "north ", "south ", " east", + " beach ", " airport", "airfield ", + " road "); + + subtype Line_Of_Text_Type is String(1..25); + type Page_Of_Text_Type is array (1..Number_Of_Lines) + of Line_Of_Text_Type; + + Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", + "moved south on the south ", + "road to the airfield. "); + + TC_Revised_Line_1 : constant String := "The XXXXXXX of XXXXXXX "; + TC_Revised_Line_2 : constant String := "moved XXXXX on the XXXXX "; + TC_Revised_Line_3 : constant String := "XXXX to the XXXXXXXX. "; + + --- + + procedure Censor (Source_String : in out String; + Pattern_String : in String) is + + -- Create a replacement string that is the same length as the + -- pattern string being removed. + Replacement : constant String := -- "*" + Ada.Strings.Fixed."*"(Pattern_String'Length, 'X'); + + Going : Ada.Strings.Direction := Ada.Strings.Forward; + Map : constant Ada.Strings.Maps.Character_Mapping := + Ada.Strings.Maps.Identity; + Start_Pos, + Index : Natural := Source_String'First; + + + begin -- Censor + + -- Accumulate count of total replacement operations. + + TC_Total := TC_Total + -- Count + Ada.Strings.Fixed.Count (Source => Source_String, + Pattern => Pattern_String, + Mapping => Map); + loop + + Index := Ada.Strings.Fixed.Index -- Index + (Source_String(Start_Pos..Source_String'Last), + Pattern_String, + Going, + Map); + + exit when Index = 0; -- No matches, exit loop. + + -- if a match was found, modify the substring. + Ada.Strings.Fixed.Replace_Slice -- Replace_Slice + (Source_String, + Index, + Index + Pattern_String'Length - 1, + Replacement); + Start_Pos := Index + Pattern_String'Length; + + end loop; + + end Censor; + + + begin + + -- Invoke Censor subprogram to cleanse text. + -- Loop through each line of text, and check for the presence of each + -- restricted word. + -- Use the Trim function to eliminate leading or trailing blanks from + -- the restricted word parameters. + + for Line in 1..Number_Of_Lines loop + for Word in Restricted_Words'Range loop + Censor (Text_Page(Line), + Ada.Strings.Fixed.Trim(Restricted_Words(Word), -- Trim + Ada.Strings.Both)); + end loop; + end loop; + + + -- Validate results. + + if TC_Total /= 6 then + Report.Failed ("Incorrect number of substitutions performed"); + end if; + + if Text_Page(1) /= TC_Revised_Line_1 then + Report.Failed ("Incorrect substitutions on Line 1"); + end if; + + if Text_Page(2) /= TC_Revised_Line_2 then + Report.Failed ("Incorrect substitutions on Line 2"); + end if; + + if Text_Page(3) /= TC_Revised_Line_3 then + Report.Failed ("Incorrect substitutions on Line 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4003.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,326 ---- + -- CXA4003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Fixed are + -- available, and that they produce correct results. Specifically, + -- check the subprograms Index, Index_Non_Blank, Head, Tail, Translate, + -- Find_Token, Move, Overwrite, and Replace_Slice. + -- + -- TEST DESCRIPTION: + -- This test demonstrates how certain fixed string operations could be + -- used in string information processing. A procedure is defined that + -- will extract portions of a 50 character string that correspond to + -- certain data items (i.e., name, address, state, zip code). These + -- parsed items will then be added to the appropriate fields of data + -- base elements. These data base elements are then compared for + -- accuracy against a similar set of predefined data base elements. + -- + -- A variety of fixed string processing subprograms are used in this + -- test. Each parsing operation uses a different combination + -- of the available subprograms to accomplish the same goal, therefore + -- continuity of approach to string parsing is not seen in this test. + -- However, a wide variety of possible approaches are demonstrated, while + -- exercising a large number of the total predefined subprograms of + -- package Ada.Strings.Fixed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Strings.Fixed; + with Ada.Strings.Maps; + with Report; + + procedure CXA4003 is + + begin + + Report.Test ("CXA4003", "Check that the subprograms defined in package " & + "Ada.Strings.Fixed are available, and that they " & + "produce correct results"); + + Test_Block: + declare + + Number_Of_Info_Strings : constant Natural := 3; + DB_Size : constant Natural := Number_Of_Info_Strings; + Count : Natural := 0; + Finished_Processing : Boolean := False; + Blank_String : constant String := " "; + + subtype Info_String_Type is String (1..50); + type Info_String_Storage_Type is + array (1..Number_Of_Info_Strings) of Info_String_Type; + + + subtype Name_Type is String (1..10); + subtype Street_Number_Type is String (1..5); + subtype Street_Name_Type is String (1..10); + subtype City_Type is String (1..10); + subtype State_Type is String (1..2); + subtype Zip_Code_Type is String (1..5); + + type Data_Base_Element_Type is + record + Name : Name_Type := (others => ' '); + Street_Number : Street_Number_Type := (others => ' '); + Street_Name : Street_Name_Type := (others => ' '); + City : City_Type := (others => ' '); + State : State_Type := (others => ' '); + Zip_Code : Zip_Code_Type := (others => ' '); + end record; + + type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; + + Data_Base : Data_Base_Type; + + --- + + Info_String_1 : Info_String_Type := + "Joe_Jones 123 Sixth_St San_Diego CA 98765"; + + Info_String_2 : Info_String_Type := + "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; + + Info_String_3 : Info_String_Type := + "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; + + + Info_Strings : Info_String_Storage_Type := (1 => Info_String_1, + 2 => Info_String_2, + 3 => Info_String_3); + + + + TC_DB_Element_1 : Data_Base_Element_Type := + ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); + + TC_DB_Element_2 : Data_Base_Element_Type := + ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); + + TC_DB_Element_3 : Data_Base_Element_Type := + ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); + + TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, + TC_DB_Element_2, + TC_DB_Element_3); + + --- + + + procedure Store_Information + (Info_String : in Info_String_Type; + DB_Record : in out Data_Base_Element_Type) is + + package AS renames Ada.Strings; + use type AS.Maps.Character_Set; + + UnderScore : AS.Maps.Character_Sequence := "_"; + Blank : AS.Maps.Character_Sequence := " "; + + Start, + Stop : Natural := 0; + + Underscore_to_Blank_Map : constant AS.Maps.Character_Mapping := + AS.Maps.To_Mapping(From => UnderScore, + To => Blank); + + Numeric_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("0123456789"); + + Cal : constant AS.Maps.Character_Sequence := "CA"; + California_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set(Cal); + Arizona_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("AZ"); + Nevada_Set : constant AS.Maps.Character_Set := + AS.Maps.To_Set("NV"); + + begin + + -- Find the starting position of the name field (first non-blank), + -- then, from that position, find the end of the name field (first + -- blank). + + Start := AS.Fixed.Index_Non_Blank(Info_String); + Stop := AS.Fixed.Index (Info_String(Start..Info_String'Length), + AS.Maps.To_Set(' '), + AS.Inside, + AS.Forward) - 1 ; + + -- Store the name field in the data base element field for "Name". + + DB_Record.Name := AS.Fixed.Head(Info_String(1..Stop), + DB_Record.Name'Length); + + -- Replace any underscore characters in the name field + -- that were used to separate first/middle/last names. + + AS.Fixed.Translate (DB_Record.Name, Underscore_to_Blank_Map); + + + -- Continue the extraction process; now find the position of + -- the street number in the string. + + Start := Stop + 1; + + AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), + Numeric_Set, + AS.Inside, + Start, + Stop); + + -- Store the street number field in the appropriate data base + -- element. + -- No modification of the default parameters of procedure Move + -- is required. + + AS.Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.Street_Number); + + + -- Continue the extraction process; find the street name in the + -- info string. Skip blanks to the start of the street name, then + -- search for the index of the next blank character in the string. + + Start := + AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Fixed.Index(Info_String(Start..Info_String'Length), + Blank_String) - 1; + + -- Store the street name in the appropriate data base element field. + + AS.Fixed.Overwrite(DB_Record.Street_Name, + 1, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the street name field + -- that were used as word separation. + + DB_Record.Street_Name := AS.Fixed.Translate(DB_Record.Street_Name, + Underscore_to_Blank_Map); + + + -- Continue the extraction; remove the city name from the string. + + Start := + AS.Fixed.Index_Non_Blank(Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Fixed.Index(Info_String(Start..Info_String'Length), + Blank_String) - 1; + + -- Store the city name field in the appropriate data base element. + + AS.Fixed.Replace_Slice(DB_Record.City, + 1, + DB_Record.City'Length, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the city name field + -- that were used as word separation. + + AS.Fixed.Translate (DB_Record.City, Underscore_to_Blank_Map); + + + -- Continue the extraction; remove the state identifier from the + -- info string. + + Start := Stop + 1; + + AS.Fixed.Find_Token(Info_String(Start..Info_String'Length), + AS.Maps."OR"(California_Set, + AS.Maps."OR"(Nevada_Set, Arizona_Set)), + AS.Inside, + Start, + Stop); + + -- Store the state indicator into the data base element. + + AS.Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.State, + Drop => Ada.Strings.Right, + Justify => Ada.Strings.Left, + Pad => AS.Space); + + + -- Continue the extraction process; remove the final data item in + -- the info string, the zip code, and place it into the + -- corresponding data base element. + + DB_Record.Zip_Code := AS.Fixed.Tail(Info_String, + DB_Record.Zip_Code'Length); + + exception + when AS.Length_Error => + Report.Failed ("Length_Error raised in procedure"); + when AS.Pattern_Error => + Report.Failed ("Pattern_Error raised in procedure"); + when AS.Translation_Error => + Report.Failed ("Translation_Error raised in procedure"); + when others => + Report.Failed ("Exception raised in procedure"); + end Store_Information; + + + begin + + -- Loop thru the information strings, extract the name and address + -- information, place this info into elements of the data base. + + while not Finished_Processing loop + + Count := Count + 1; + + Store_Information (Info_Strings(Count), Data_Base(Count)); + + Finished_Processing := (Count = Number_Of_Info_Strings); + + end loop; + + + -- Verify that the string processing was successful. + + for i in 1..DB_Size loop + if Data_Base(i) /= TC_Data_Base(i) then + Report.Failed + ("Data processing error on record " & Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4004.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,431 ---- + -- CXA4004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Fixed are + -- available, and that they produce correct results. Specifically, check + -- the subprograms Count, Find_Token, Index, Index_Non_Blank, and Move. + -- + -- TEST DESCRIPTION: + -- This test, when combined with tests CXA4002,3, and 5 will provide + -- thorough coverage of the functionality found in Ada.Strings.Fixed. + -- This test contains many small, specific test cases, situations that + -- although common in user environments, are often difficult to generate + -- in large numbers in a application-based test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 95 SAIC Corrected subtest for Move, Drop=Right. + -- + --! + + with Report; + with Ada.Strings; + with Ada.Strings.Fixed; + with Ada.Strings.Maps; + + procedure CXA4004 is + begin + + Report.Test("CXA4004", "Check that the subprograms defined in " & + "package Ada.Strings.Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASF renames Ada.Strings.Fixed; + package Maps renames Ada.Strings.Maps; + + Result_String : String(1..10) := (others => Ada.Strings.Space); + + Source_String1 : String(1..5) := "abcde"; -- odd length string + Source_String2 : String(1..6) := "abcdef"; -- even length string + Source_String3 : String(1..12) := "abcdefghijkl"; + Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Move + + -- Evaluate the Procedure Move with various combinations of + -- parameters. + + -- Justify = Left (default case) + + ASF.Move(Source => Source_String1, -- "abcde" + Target => Result_String); + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Move with Justify = Left"); + end if; + + -- Justify = Right + + ASF.Move(Source => Source_String2, -- "abcdef" + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Move with Justify = Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Move(Source_String1, -- "abcde" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result from Move with Justify = Center-1"); + end if; + + ASF.Move(Source_String2, -- "abcdef" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Move with Justify = Center-2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASF.Move(Source => Source_String3, -- "abcdefghijkl" + Target => Result_String, + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Move with Drop = Left"); + end if; + + -- Drop = Right + + ASF.Move(Source_String3, Result_String, Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result from Move with Drop = Right"); + end if; + + -- Drop = Error + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Move(Source => Source_String4, -- "abcdefghij " + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Move(Source_String5, -- " cdefghijkl" + Result_String, + Ada.Strings.Error, + Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Move(Source_String3, -- 12 characters, no Pad. + Result_String, -- 10 characters + Ada.Strings.Error, + Ada.Strings.Left); + + Report.Failed("Length_Error not raised by Move - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised by Move - 1"); + end; + + + + -- Function Index + -- (Other usage examples of this function found in CXA4002-3.) + -- Check when the pattern is not found in the source. + + if ASF.Index("abcdef", "gh") /= 0 or + ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source + ASF.Index("xyz", + "abcde", + Ada.Strings.Backward) /= 0 or + ASF.Index("", "ab") /= 0 or -- null source string. + ASF.Index("abcde", " ") /= 0 -- blank pattern. + then + Report.Failed("Incorrect result from Index, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is the + -- null string. + begin + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "", -- null pattern string. + Ada.Strings.Forward); + Report.Failed("Pattern_Error not raised by Index"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Index, null pattern"); + end; + + -- Use the search direction "backward" to locate the particular + -- pattern within the source string. + + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "de", -- slice 4..5, 10..11 + Ada.Strings.Backward); -- search from right end. + + if Location /= 10 then + Report.Failed("Incorrect result from Index going Backward"); + end if; + + -- Using the version of Index testing character set membership, + -- check combinations of forward/backward, inside/outside parameter + -- configurations. + + if ASF.Index(Source => Source_String1, -- "abcde" + Set => CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 12 or -- 'f' at position 12 + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Backward) /= 10 or -- 'd' at position 10 + ASF.Index("cdcdcdcdacdcdcdcd", + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Forward) /= 9 -- 'a' at position 9 + then + Report.Failed("Incorrect result from function Index for sets - 1"); + end if; + + -- Additional interesting uses/combinations using Index for sets. + + if ASF.Index("cd", -- same size, str-set + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Forward) /= 1 or -- 'c' at position 1 + ASF.Index("abcd", -- same size, str-set, + Maps.To_Set("efgh"), -- different contents. + Ada.Strings.Outside, + Ada.Strings.Forward) /= 1 or + ASF.Index("abccd", -- set > string + Maps.To_Set("acegik"), + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 or -- 'c' at position 4 + ASF.Index("abcde", + Maps.Null_Set) /= 0 or + ASF.Index("", -- Null string. + CD_Set) /= 0 or + ASF.Index("abc ab", -- blank included + Maps.To_Set("e "), -- in string and set. + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 -- blank in string. + then + Report.Failed("Incorrect result from function Index for sets - 2"); + end if; + + + + -- Function Index_Non_Blank. + -- (Other usage examples of this function found in CXA4002-3.) + + + if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " + Going => Ada.Strings.Backward) /= 10 or + ASF.Index_Non_Blank("abc def ghi jkl ", + Ada.Strings.Backward) /= 15 or + ASF.Index_Non_Blank(" abcdef") /= 3 or + ASF.Index_Non_Blank(" ") /= 0 + then + Report.Failed("Incorrect result from Index_Non_Blank"); + end if; + + + + -- Function Count + -- (Other usage examples of this function found in CXA4002-3.) + + if ASF.Count("abababa", "aba") /= 2 or + ASF.Count("abababa", "ab" ) /= 3 or + ASF.Count("babababa", "ab") /= 3 or + ASF.Count("abaabaaba", "aba") /= 3 or + ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or + ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 + then + Report.Failed("Incorrect result from Function Count"); + end if; + + -- Determine the number of slices of Source that when mapped to a + -- non-identity map, match the pattern string. + + Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" + "xy", + CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' + + if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 + Report.Failed("Incorrect result from Count with non-identity map"); + end if; + + -- If the pattern supplied to Function Count is the null string, then + -- Pattern_Error is propagated. + + declare + The_Null_String : constant String := ""; + begin + Slice_Count := ASF.Count(Source_String6, The_Null_String); + Report.Failed("Pattern_Error not raised by Function Count"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Count with null pattern"); + end; + + + -- Function Count returning the number of characters in a particular + -- set that are found in source string. + + if ASF.Count(Source_String6, CD_Set) /= 4 then -- 2 'c' and 'd' chars. + Report.Failed("Incorrect result from Count with set"); + end if; + + + + -- Function Find_Token. + -- (Other usage examples of this function found in CXA4002-3.) + + ASF.Find_Token(Source => Source_String6, -- First slice with no + Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' + Test => Ada.Strings.Outside, -- is "ef" at 5..6. + First => Slice_Start, + Last => Slice_End); + + if Slice_Start /= 5 or Slice_End /= 6 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + -- If no appropriate slice is contained by the source string, then the + -- value returned in Last is zero, and the value in First is + -- Source'First. + + ASF.Find_Token(Source_String6, -- "abcdefabcdef" + A_to_F_Set, -- Set of characters 'a' thru 'f'. + Ada.Strings.Outside, -- No characters outside this set. + Slice_Start, + Slice_End); + + if Slice_Start /= Source_String6'First or Slice_End /= 0 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + -- Additional testing of Find_Token. + + ASF.Find_Token("eabcdabcddcab", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 2 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + ASF.Find_Token("efghijklabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 8 then + Report.Failed("Incorrect result from Find_Token - 4"); + end if; + + ASF.Find_Token("abcdefgabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 5 or Slice_End /= 7 then + Report.Failed("Incorrect result from Find_Token - 5"); + end if; + + ASF.Find_Token("abcdcbabcdcba", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 6"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4005.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,683 ---- + -- CXA4005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Fixed are + -- available, and that they produce correct results. Specifically, + -- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, + -- Tail, Trim, and "*". + -- + -- TEST DESCRIPTION: + -- This test, when combined with tests CXA4002-4 will provide coverage + -- of the functionality found in Ada.Strings.Fixed. + -- This test contains many small, specific test cases, situations that + -- although common in user environments, are often difficult to generate + -- in large numbers in a application-based test. They represent + -- individual usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 11 Apr 95 SAIC Corrected acceptance conditions of certain + -- subtests. + -- 06 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. + -- 22 Feb 01 PHL Check that the lower bound of the result is 1. + -- 13 Mar 01 RLB Fixed a couple of ACATS style violations; + -- removed pointless checks of procedures. + -- Added checks of other functions. These changes + -- were made to test Defect Report 8652/0049, as + -- reflected in Technical Corrigendum 1. + -- + --! + + with Report; + with Ada.Strings; + with Ada.Strings.Fixed; + with Ada.Strings.Maps; + + procedure CXA4005 is + + type TC_Name_Holder is access String; + Name : TC_Name_Holder; + + function TC_Check (S : String) return String is + begin + if S'First /= 1 then + Report.Failed ("Lower bound of result of function " & Name.all & + " is" & Integer'Image (S'First)); + end if; + return S; + end TC_Check; + + procedure TC_Set_Name (N : String) is + begin + Name := new String'(N); + end TC_Set_Name; + + begin + + Report.Test("CXA4005", "Check that the subprograms defined in " & + "package Ada.Strings.Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASF renames Ada.Strings.Fixed; + package Maps renames Ada.Strings.Maps; + + Result_String, + Delete_String, + Insert_String, + Trim_String, + Overwrite_String : String(1..10) := (others => Ada.Strings.Space); + + Source_String1 : String(1..5) := "abcde"; -- odd length string + Source_String2 : String(1..6) := "abcdef"; -- even length string + Source_String3 : String(1..12) := "abcdefghijkl"; + Source_String4 : String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + X_Set : Maps.Character_Set := Maps.To_Set('x'); + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Replace_Slice + -- The functionality of this procedure + -- is similar to procedure Move, and + -- is tested here in the same manner, evaluated + -- with various combinations of parameters. + + -- Index_Error propagation when Low > Source'Last + 1 + + begin + ASF.Replace_Slice(Result_String, + Result_String'Last + 2, -- should raise exception + Result_String'Last, + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 1"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 1"); + end; + + -- Index_Error propagation when High < Source'First - 1 + + begin + ASF.Replace_Slice(Result_String(5..10), + 5, + 3, -- should raise exception since < 'First - 1. + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 2"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 2"); + end; + + -- Justify = Left (default case) + + Result_String := "XXXXXXXXXX"; + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => 10, + By => Source_String1); -- "abcde" + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); + end if; + + -- Justify = Right + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String2, -- "abcdef" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String1, -- "abcde" + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); + end if; + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String2, -- "abcdef" + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Replace_Slice with " & + "Justify = Center - 2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); + end if; + + -- Drop = Right + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); + end if; + + -- Drop = Error + + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String4, -- "abcdefghij " + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String5, -- " cdefghijkl" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Error); + + Report.Failed("Length_Error not raised by Replace_Slice - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Replace_Slice - 3"); + end; + + + -- Function Replace_Slice + + TC_Set_Name ("Replace_Slice"); + + if TC_Check (ASF.Replace_Slice("abcde", 3, 3, "x")) + /= "abxde" or -- High = Low + TC_Check (ASF.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or + TC_Check (ASF.Replace_Slice("abcd", 4, 1, "xy")) + /= "abcxyd" or -- High < Low + TC_Check (ASF.Replace_Slice("abc", 2, 3, "x")) /= "ax" or + TC_Check (ASF.Replace_Slice("a", 1, 1, "z")) /= "z" + then + Report.Failed("Incorrect result from Function Replace_Slice - 1"); + end if; + + if TC_Check (ASF.Replace_Slice("abcde", 5, 5, "z")) + /= "abcdz" or -- By length 1 + TC_Check (ASF.Replace_Slice("abc", 1, 3, "xyz")) + /= "xyz" or -- High > Low + TC_Check (ASF.Replace_Slice("abc", 3, 2, "xy")) + /= "abxyc" or -- insert + TC_Check (ASF.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" + then + Report.Failed("Incorrect result from Function Replace_Slice - 2"); + end if; + + + + -- Function Insert. + + TC_Set_Name ("Insert"); + + declare + New_String : constant String := + TC_Check ( + ASF.Insert(Source => Source_String1(2..5), -- "bcde" + Before => 3, + New_Item => Source_String2)); -- "abcdef" + begin + if New_String /= "babcdefcde" then + Report.Failed("Incorrect result from Function Insert - 1"); + end if; + end; + + if TC_Check (ASF.Insert("a", 1, "z")) /= "za" or + TC_Check (ASF.Insert("abc", 3, "")) /= "abc" or + TC_Check (ASF.Insert("abc", 1, "z")) /= "zabc" + then + Report.Failed("Incorrect result from Function Insert - 2"); + end if; + + begin + if TC_Check (ASF.Insert(Source => Source_String1(2..5), -- "bcde" + Before => Report.Ident_Int(7), + New_Item => Source_String2)) -- "abcdef" + /= "babcdefcde" then + Report.Failed("Index_Error not raised by Insert - 3A"); + else + Report.Failed("Index_Error not raised by Insert - 3B"); + end if; + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Insert - 3"); + end; + + + -- Procedure Insert + + -- Drop = Right + + ASF.Insert(Source => Insert_String, + Before => 6, + New_Item => Source_String2, -- "abcdef" + Drop => Ada.Strings.Right); + + if Insert_String /= " abcde" then -- last char of New_Item dropped. + Report.Failed("Incorrect result from Insert with Drop = Right"); + end if; + + -- Drop = Left + + ASF.Insert(Source => Insert_String, -- 10 char string + Before => 2, -- 9 chars, 2..10 available + New_Item => Source_String3, -- 12 characters long. + Drop => Ada.Strings.Left); -- truncate from Left. + + if Insert_String /= "l abcde" then -- 10 chars, leading blank. + Report.Failed("Incorrect result from Insert with Drop=Left"); + end if; + + -- Drop = Error + + begin + ASF.Insert(Source => Result_String, -- 10 chars + Before => Result_String'Last, + New_Item => "abcdefghijk", + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Insert"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + + + -- Function Overwrite + + TC_Set_Name ("Overwrite"); + + Overwrite_String := TC_Check ( + ASF.Overwrite(Result_String, -- 10 chars + 1, -- starting at pos=1 + Source_String3(1..10))); + + if Overwrite_String /= Source_String3(1..10) then + Report.Failed("Incorrect result from Function Overwrite - 1"); + end if; + + + if TC_Check (ASF.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or + TC_Check (ASF.Overwrite("a", 1, "xyz")) + /= "xyz" or -- chars appended + TC_Check (ASF.Overwrite("abc", 3, " ")) + /= "ab " or -- blanks appended + TC_Check (ASF.Overwrite("abcde", 1, "z" )) /= "zbcde" + then + Report.Failed("Incorrect result from Function Overwrite - 2"); + end if; + + + + -- Procedure Overwrite, with truncation. + + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Left); + + if Overwrite_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Overwrite with Drop=Left"); + end if; + + -- The default drop value is Right, used here. + + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3); -- 12 characters. + + if Overwrite_String /= "abcdefghij" then + Report.Failed("Incorrect result from Overwrite with Drop=Right"); + end if; + + -- Drop = Error + + begin + ASF.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Overwrite"); + end; + + Overwrite_String := "ababababab"; + ASF.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); + ASF.Overwrite(Overwrite_String, Overwrite_String'First,"z"); + ASF.Overwrite(Overwrite_String, 5, "zz"); + + if Overwrite_String /= "zbabzzabaz" then + Report.Failed("Incorrect result from Procedure Overwrite"); + end if; + + + + -- Function Delete + + TC_Set_Name ("Delete"); + + declare + New_String1 : constant String := -- This returns a 4 char string. + TC_Check (ASF.Delete(Source => Source_String3, + From => 3, + Through => 10)); + New_String2 : constant String := -- This returns Source. + TC_Check (ASF.Delete(Source_String3, 10, 3)); + begin + if New_String1 /= "abkl" or + New_String2 /= Source_String3 + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + end; + + if TC_Check (ASF.Delete("a", 1, 1)) + /= "" or -- Source length = 1 + TC_Check (ASF.Delete("abc", 1, 2)) + /= "c" or -- From = Source'First + TC_Check (ASF.Delete("abc", 3, 3)) + /= "ab" or -- From = Source'Last + TC_Check (ASF.Delete("abc", 3, 1)) + /= "abc" -- From > Through + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Procedure Delete + + -- Justify = Left + + Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" + + ASF.Delete(Source => Delete_String, + From => 6, + Through => Delete_String'Last, + Justify => Ada.Strings.Left, + Pad => 'x'); -- pad with char 'x' + + if Delete_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Delete - Justify = Left"); + end if; + + -- Justify = Right + + ASF.Delete(Source => Delete_String, -- Remove x"s from end and + From => 6, -- shift right. + Through => Delete_String'Last, + Justify => Ada.Strings.Right, + Pad => 'x'); -- pad with char 'x' on left. + + if Delete_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Delete - Justify = Right"); + end if; + + -- Justify = Center + + ASF.Delete(Source => Delete_String, + From => 1, + Through => 5, + Justify => Ada.Strings.Center, + Pad => 'z'); + + if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. + Report.Failed("Incorrect result from Delete - Justify = Center"); + end if; + + + + -- Function Trim + -- Use non-identity character sets to perform the trim operation. + + TC_Set_Name ("Trim"); + + Trim_String := "cdabcdefcd"; + + -- Remove the "cd" from each end of the string. This will not effect + -- the "cd" slice at 5..6. + + declare + New_String : constant String := + TC_Check (ASF.Trim(Source => Trim_String, + Left => CD_Set, Right => CD_Set)); + begin + if New_String /= Source_String2 then -- string "abcdef" + Report.Failed("Incorrect result from Trim with character sets"); + end if; + end; + + if TC_Check (ASF.Trim("abcdef", Maps.Null_Set, Maps.Null_Set)) + /= "abcdef" then + Report.Failed("Incorrect result from Trim with Null sets"); + end if; + + if TC_Check (ASF.Trim("cdxx", CD_Set, X_Set)) /= "" then + Report.Failed("Incorrect result from Trim, string removal"); + end if; + + + -- Procedure Trim + + -- Justify = Right + + ASF.Trim(Source => Trim_String, + Left => CD_Set, + Right => CD_Set, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxabcdef" then + Report.Failed("Incorrect result from Trim with Justify = Right"); + end if; + + -- Justify = Left + + ASF.Trim(Source => Trim_String, + Left => X_Set, + Right => Maps.Null_Set, + Justify => Ada.Strings.Left, + Pad => Ada.Strings.Space); + + if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. + Report.Failed("Incorrect result from Trim with Justify = Left"); + end if; + + -- Justify = Center + + ASF.Trim(Source => Trim_String, + Left => ABCD_Set, + Right => CD_Set, + Justify => Ada.Strings.Center, + Pad => 'x'); + + if Trim_String /= "xxef xx" then -- Padded with 2 pad chars on L/R + Report.Failed("Incorrect result from Trim with Justify = Center"); + end if; + + + + -- Function Head, demonstrating use of padding. + + TC_Set_Name ("Head"); + + -- Use the characters of Source_String1 ("abcde") and pad the + -- last five characters of Result_String with 'x' characters. + + + Result_String := TC_CHeck (ASF.Head(Source_String1, 10, 'x')); + + if Result_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Function Head with padding"); + end if; + + if TC_Check (ASF.Head(" ab ", 2)) /= " " or + TC_Check (ASF.Head("a", 6, 'A')) /= "aAAAAA" or + TC_Check (ASF.Head("abcdefgh", 3, 'x')) /= "abc" or + TC_Check (ASF.Head(ASF.Head("abc ", 7, 'x'), 10, 'X')) + /= "abc xxXXX" + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail, demonstrating use of padding. + + TC_Set_Name ("Tail"); + + -- Use the characters of Source_String1 ("abcde") and pad the + -- first five characters of Result_String with 'x' characters. + + Result_String := TC_Check (ASF.Tail(Source_String1, 10, 'x')); + + if Result_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Function Tail with padding"); + end if; + + if TC_Check (ASF.Tail("abcde ", 5)) + /= "cde " or -- blanks, back + TC_Check (ASF.Tail(" abc ", 8, ' ')) + /= " abc " or -- blanks, front/back + TC_Check (ASF.Tail("", 5, 'Z')) + /= "ZZZZZ" or -- pad characters only + TC_Check (ASF.Tail("abc", 0)) + /= "" or -- null result + TC_Check (ASF.Tail("abcdefgh", 3)) + /= "fgh" or + TC_Check (ASF.Tail(ASF.Tail(" abc ", 6, 'x'), + 10, + 'X')) /= "XXXXx abc " + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + -- Function "*" - with (Natural, String) parameters + + TC_Set_Name ("""*"""); + + if TC_Check (ASF."*"(3, Source_String1)) /= "abcdeabcdeabcde" or + TC_Check (ASF."*"(2, Source_String2)) /= Source_String6 or + TC_Check (ASF."*"(4, Source_String1(1..2))) /= "abababab" or + TC_Check (ASF."*"(0, Source_String1)) /= "" + then + Report.Failed("Incorrect result from Function ""*"" with strings"); + end if; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4006.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,319 ---- + -- CXA4006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Bounded are + -- available, and that they produce correct results. Specifically, check + -- the subprograms Length, Slice, "&", To_Bounded_String, Append, Index, + -- To_String, Replace_Slice, Trim, Overwrite, Delete, Insert, and + -- Translate. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of a variety of the string functions + -- found in the package Ada.Strings.Bounded, simulating the operations + -- found in a text processing package. + -- With bounded strings, the length of each "line" of text can vary up + -- to the instantiated maximum, allowing one to view a page of text as + -- a series of expandable lines. This provides flexibility in text + -- formatting of individual lines (strings). + -- Several subprograms are defined, all of which attempt to take advantage + -- of as many different bounded string utilities as possible. Often, + -- an operation that is being performed in a subprogram using a certain + -- bounded string utility could more efficiently be performed using a + -- a different utility. However, in the interest of including as broad + -- coverage as possible, a mixture of utilities is invoked in this test. + -- A simulated page of text is provided as a parameter to the test + -- defined subprograms, and the appropriate processing performed. The + -- processed page of text is then compared to a predefined "finished" + -- page, and test passage/failure is based on the results of this + -- comparison. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Strings; + with Ada.Strings.Bounded; + with Ada.Strings.Maps; + with Report; + + procedure CXA4006 is + + begin + + Report.Test ("CXA4006", "Check that the subprograms defined in package " & + "Ada.Strings.Bounded are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + Characters_Per_Line : constant Positive := 40; + Lines_Per_Page : constant Natural := 4; + + package BS_40 is new + Ada.Strings.Bounded.Generic_Bounded_Length(Characters_Per_Line); + use type BS_40.Bounded_String; + + type Page_Type is array (1..Lines_Per_Page) of BS_40.Bounded_String; + + -- Note: Misspellings below are intentional. + + Line1 : BS_40.Bounded_String := + BS_40.To_Bounded_String("ada is a progrraming language designed"); + Line2 : BS_40.Bounded_String := + BS_40.To_Bounded_String("to support the construction of long-"); + Line3 : BS_40.Bounded_String := + BS_40.To_Bounded_String("lived, highly reliabel software "); + Line4 : BS_40.Bounded_String := + BS_40.To_Bounded_String("systems"); + + Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); + + Finished_Page : Page_Type := + (BS_40.To_Bounded_String("Ada is a programming language designed"), + BS_40.To_Bounded_String("to support the construction of long-"), + BS_40.To_Bounded_String("lived, HIGHLY RELIABLE software systems."), + BS_40.To_Bounded_String("")); + + --- + + procedure Compress (Page : in out Page_Type) is + Clear_Line : Natural := Lines_Per_Page; + begin + -- If two consecutive lines on the page are together less than the + -- maximum line length, then append those two lines, move up all + -- lower lines on the page, and blank out the last line. + for i in 1..Lines_Per_Page - 1 loop + if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= + BS_40.Max_Length + then + Page(i) := BS_40."&"(Page(i), + Page(i+1)); -- "&" (bounded, bounded) + + for j in i+1..Lines_Per_Page - 1 loop + Page(j) := + BS_40.To_Bounded_String + (BS_40.Slice(Page(j+1), + 1, + BS_40.Length(Page(j+1)))); + Clear_Line := j + 1; + end loop; + Page(Clear_Line) := BS_40.Null_Bounded_String; + end if; + end loop; + end Compress; + + --- + + procedure Format (Page : in out Page_Type) is + Sm_Ada : BS_40.Bounded_String := BS_40.To_Bounded_String("ada"); + Cap_Ada : constant String := "Ada"; + Char_Pos : Natural := 0; + Finished : Boolean := False; + Line : Natural := Page_Type'Last; + begin + + -- Add a period to the end of the last line. + while Line >= Page_Type'First and not Finished loop + if Page(Line) /= BS_40.Null_Bounded_String and + BS_40.Length(Page(Line)) <= BS_40.Max_Length + then + Page(Line) := BS_40.Append(Page(Line), '.'); + Finished := True; + end if; + Line := Line - 1; + end loop; + + -- Replace all occurrences of "ada" with "Ada". + for Line in Page_Type'First .. Page_Type'Last loop + Finished := False; + while not Finished loop + Char_Pos := BS_40.Index(Source => Page(Line), + Pattern => BS_40.To_String(Sm_Ada), + Going => Ada.Strings.Backward); + -- A zero is returned by function Index if no occurrences of + -- the pattern string are found. + Finished := (Char_Pos = 0); + if not Finished then + BS_40.Replace_Slice + (Source => Page(Line), + Low => Char_Pos, + High => Char_Pos + BS_40.Length(Sm_Ada) - 1, + By => Cap_Ada); + end if; + end loop; -- while loop + end loop; -- for loop + + end Format; + + --- + + procedure Spell_Check (Page : in out Page_Type) is + type Spelling_Type is (Incorrect, Correct); + type Word_Array_Type is array (Spelling_Type) + of BS_40.Bounded_String; + type Dictionary_Type is array (1..2) of Word_Array_Type; + + -- Note that the "words" in the dictionary will require various + -- amounts of Trimming prior to their use in the string functions. + Dictionary : Dictionary_Type := + (1 => (BS_40.To_Bounded_String(" reliabel "), + BS_40.To_Bounded_String(" reliable ")), + 2 => (BS_40.To_Bounded_String(" progrraming "), + BS_40.To_Bounded_String(" programming "))); + + Pos : Natural := Natural'First; + Finished : Boolean := False; + + begin + + for Line in Page_Type'Range loop + + -- Search for the first incorrectly spelled word in the Dictionary, + -- if it is found, replace it with the correctly spelled word, + -- using the Overwrite function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_String( + BS_40.Trim(Dictionary(1)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + Finished := (Pos = 0); + if not Finished then + Page(Line) := + BS_40.Overwrite(Page(Line), + Pos, + BS_40.To_String + (BS_40.Trim(Dictionary(1)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + -- Search for the second incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Delete procedure and Insert function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_String( + BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + + Finished := (Pos = 0); + + if not Finished then + BS_40.Delete + (Page(Line), + Pos, + Pos + BS_40.To_String + (BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both))'Length-1); + Page(Line) := + BS_40.Insert(Page(Line), + Pos, + BS_40.To_String + (BS_40.Trim(Dictionary(2)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + end loop; + end Spell_Check; + + --- + + procedure Bold (Page : in out Page_Type) is + Key_Word : constant String := "highly reliable"; + Bold_Mapping : constant Ada.Strings.Maps.Character_Mapping := + Ada.Strings.Maps.To_Mapping(From => " abcdefghijklmnopqrstuvwxyz", + To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + Pos : Natural := Natural'First; + Finished : Boolean := False; + begin + -- This procedure is designed to change the case of the phrase + -- "highly reliable" into upper case (a type of "Bolding"). + -- All instances of the phrase on all lines of the page will be + -- modified. + + for Line in Page_Type'First .. Page_Type'Last loop + while not Finished loop + Pos := BS_40.Index(Page(Line), Key_Word); + Finished := (Pos = 0); + if not Finished then + + BS_40.Overwrite + (Page(Line), + Pos, + BS_40.To_String + (BS_40.Translate + (BS_40.To_Bounded_String + (BS_40.Slice(Page(Line), + Pos, + Pos + Key_Word'Length - 1)), + Bold_Mapping))); + + end if; + end loop; + Finished := False; + end loop; + end Bold; + + + begin + + Compress(Page); + Format(Page); + Spell_Check(Page); + Bold(Page); + + for i in 1..Lines_Per_Page loop + if BS_40.To_String(Page(i)) /= BS_40.To_String(Finished_Page(i)) or + BS_40.Length(Page(i)) /= BS_40.Length(Finished_Page(i)) + then + Report.Failed("Incorrect modification of Page, Line " & + Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4007.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- CXA4007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Bounded are + -- available, and that they produce correct results. Specifically, check + -- the subprograms Append, Count, Element, Find_Token, Head, + -- Index_Non_Blank, Replace_Element, Replicate, Tail, To_Bounded_String, + -- "&", ">", "<", ">=", "<=", and "*". + -- + -- TEST DESCRIPTION: + -- This test, when taken in conjunction with tests CXA400[6,8,9], will + -- constitute a test of all the functionality contained in package + -- Ada.Strings.Bounded. This test uses a variety of the + -- subprograms defined in the bounded string package in ways typical + -- of common usage. Different combinations of available subprograms + -- are used to accomplish similar bounded string processing goals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 22 Dec 94 SAIC Changed obsolete constant to Ada.Strings.Space. + -- + --! + + with Ada.Strings; + with Ada.Strings.Bounded; + with Ada.Strings.Maps; + with Report; + + procedure CXA4007 is + + begin + + Report.Test ("CXA4007", "Check that the subprograms defined in package " & + "Ada.Strings.Bounded are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + use type BS80.Bounded_String; + + Part1 : constant String := "Rum"; + Part2 : Character := 'p'; + Part3 : BS80.Bounded_String := BS80.To_Bounded_String("el"); + Part4 : Character := 's'; + Part5 : BS80.Bounded_String := BS80.To_Bounded_String("tilt"); + Part6 : String(1..3) := "ski"; + + Full_Catenate_String, + Full_Append_String, + Constructed_String, + Drop_String, + Replicated_String, + Token_String : BS80.Bounded_String; + + CharA : Character := 'A'; + CharB : Character := 'B'; + CharC : Character := 'C'; + CharD : Character := 'D'; + CharE : Character := 'E'; + CharF : Character := 'F'; + + ABStr : String(1..15) := "AAAAABBBBBBBBBB"; + StrB : String(1..2) := "BB"; + StrE : String(1..2) := "EE"; + + + begin + + -- Evaluation of the overloaded forms of the "&" operator defined + -- for instantiations of Bounded Strings. + + Full_Catenate_String := + BS80."&"(Part2, -- Char & Bnd Str + BS80."&"(Part3, -- Bnd Str & Bnd Str + BS80."&"(Part4, -- Char & Bnd Str + BS80."&"(Part5, -- Bnd Str & Bnd Str + BS80.To_Bounded_String(Part6))))); + + Full_Catenate_String := + Part1 & Full_Catenate_String; -- Str & Bnd Str + Full_Catenate_String := + Full_Catenate_String & 'n'; -- Bnd Str & Char + + + -- Evaluation of the overloaded forms of function Append. + + Full_Append_String := + BS80.Append(Part2, -- Char,Bnd + BS80.Append(Part3, -- Bnd, Bnd + BS80.Append(Part4, -- Char,Bnd + BS80.Append(BS80.To_String(Part5), -- Str,Bnd + BS80.To_Bounded_String(Part6))))); + + Full_Append_String := + BS80.Append(BS80.To_Bounded_String(Part1), -- Bnd , Str + BS80.To_String(Full_Append_String)); + + Full_Append_String := + BS80.Append(Left => Full_Append_String, + Right => 'n'); -- Bnd, Char + + + -- Validate the resulting bounded strings. + + if Full_Catenate_String < Full_Append_String or + Full_Catenate_String > Full_Append_String or + not (Full_Catenate_String = Full_Append_String and + Full_Catenate_String <= Full_Append_String and + Full_Catenate_String >= Full_Append_String) + then + Report.Failed("Incorrect results from bounded string catenation" & + " and comparison"); + end if; + + + -- Evaluate the overloaded forms of the Constructor function "*" and + -- the Replicate function. + + Constructed_String := + (2 * CharA) & -- "AA" + (2 * StrB) & -- "AABBBB" + (3 * BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" + BS80.Replicate(3, + BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" + BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" + BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" + + + -- Use of Function Replicate that involves dropping characters. The + -- attempt to replicate the 15 character string six times will exceed + -- the 80 character bound of the string. Therefore, the result should + -- be the catenation of 5 copies of the 15 character string, followed + -- by 5 'A' characters (the first five characters of the 6th + -- replication) with the remaining characters of the 6th replication + -- dropped. + + Drop_String := + BS80.Replicate(Count => 6, + Item => ABStr, -- "AAAAABBBBBBBBBB" + Drop => Ada.Strings.Right); + + if BS80.Element(Drop_String, 1) /= 'A' or + BS80.Element(Drop_String, 6) /= 'B' or + BS80.Element(Drop_String, 76) /= 'A' or + BS80.Element(Drop_String, 80) /= 'A' + then + Report.Failed("Incorrect result from Replicate with Drop"); + end if; + + + -- Use function Index_Non_Blank in the evaluation of the + -- Constructed_String. + + if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= + BS80.To_String(Constructed_String)'First or + BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= + BS80.Length(Constructed_String) + then + Report.Failed("Incorrect results from constructor functions"); + end if; + + + + declare + + -- Define character set objects for use with the Count function. + -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. + + A_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,1)); + B_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,3)); + C_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,7)); + D_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,13)); + E_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,19)); + F_Set : Ada.Strings.Maps.Character_Set := + Ada.Strings.Maps.To_Set(BS80.Element(Constructed_String,23)); + + + Start : Positive; + Stop : Natural := 0; + + begin + + -- Evaluate the results from function Count by comparing the number + -- of A's to the number of F's, B's to E's, and C's to D's in the + -- Constructed_String. + -- There should be an equal number of each of the characters that + -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) + + if BS80.Count(Constructed_String, A_Set) /= + BS80.Count(Constructed_String, F_Set) or + BS80.Count(Constructed_String, B_Set) /= + BS80.Count(Constructed_String, E_Set) or + not (BS80.Count(Constructed_String, C_Set) = + BS80.Count(Constructed_String, D_Set)) + then + Report.Failed("Incorrect result from function Count"); + end if; + + + -- Evaluate the functions Head, Tail, and Find_Token. + -- Create the Token_String from the Constructed_String above. + + Token_String := + BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & + BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & + BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" + + if Token_String /= BS80.To_Bounded_String("ABCDEF") then + Report.Failed("Incorrect result from Catenation of Token_String"); + end if; + + + -- Find the starting/ending position of the first A in the + -- Token_String (both should be 1, only one A appears in string). + -- The Function Head uses the default pad character to return a + -- bounded string longer than its input parameter bounded string. + + BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. + A_Set, + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 1 and Stop /= 1 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + + -- Find the starting/ending position of the first non-AB slice in + -- the "head" five characters of Token_String (slice CDE at + -- positions 3-5) + + BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" + Ada.Strings.Maps."OR"(A_Set, B_Set), -- Set (AB) + Ada.Strings.Outside, + Start, + Stop); + + if Start /= 3 and Stop /= 5 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + + -- Find the starting/ending position of the first CD slice in + -- the "tail" eight characters (including two pad characters) + -- of Token_String (slice CD at positions 5-6 of the tail + -- portion specified) + + BS80.Find_Token(BS80.Tail(Token_String, 8, + Ada.Strings.Space), -- " ABCDEF" + Ada.Strings.Maps."OR"(C_Set, D_Set), -- Set (CD) + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 5 and Stop /= 6 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + + -- Evaluate the Replace_Element procedure. + + -- Token_String = "ABCDEF" + + BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); + + -- Token_String = "ABDDEF" + + BS80.Replace_Element(Source => Token_String, + Index => 2, + By => BS80.Element(Token_String, 5)); + + -- Token_String = "AEDDEF" + + BS80.Replace_Element(Token_String, + 1, + BS80.Element(BS80.Tail(Token_String, 2), 2)); + + -- Token_String = "FEDDEF" + -- Evaluate this result. + + if BS80.Element(Token_String, BS80.To_String(Token_String)'First) /= + BS80.Element(Token_String, BS80.To_String(Token_String)'Last) or + BS80.Count(Token_String, D_Set) /= + BS80.Count(Token_String, E_Set) or + BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= + BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or + BS80.Head(Token_String, 1) /= + BS80.Tail(Token_String, 1) + then + Report.Failed("Incorrect result from operations in combination"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4008.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,662 ---- + -- CXA4008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Bounded are + -- available, and that they produce correct results, especially under + -- conditions where truncation of the result is required. Specifically, + -- check the subprograms Append, Count with non-Identity maps, Index with + -- non-Identity maps, Index with Set parameters, Insert (function and + -- procedure), Replace_Slice (function and procedure), To_Bounded_String, + -- and Translate. + -- + -- TEST DESCRIPTION: + -- This test, in conjunction with tests CXA4006, CXA4007, and CXA4009, + -- will provide coverage of the most common usages of the functionality + -- found in the Ada.Strings.Bounded package. It deals in large part + -- with truncation effects and options. This test contains many small, + -- specific test cases, situations that are often difficult to generate + -- in large numbers in an application-based test. These cases represent + -- specific usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 95 SAIC Corrected acceptance condition of subtest for + -- Function Append with Truncation = Left. + -- 31 Oct 95 SAIC Update and repair for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Strings.Maps.Constants; + with Ada.Strings.Bounded; + with Ada.Strings.Maps; + + procedure CXA4008 is + + begin + + Report.Test("CXA4008", "Check that the subprograms defined in " & + "package Ada.Strings.Bounded are available, " & + "and that they produce correct results, " & + "especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Bounded; + package ASC renames Ada.Strings.Maps.Constants; + package Maps renames Ada.Strings.Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_String; + + Result_String : B10.Bounded_String; + Test_String : B10.Bounded_String; + AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); + FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); + AtoJ_Bnd_Str : B10.Bounded_String := + B10.To_Bounded_String("abcdefghij"); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + + AB_to_YZ_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "ab", To => "yz"); + + CD_to_XY_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + + begin + -- Function To_Bounded_String with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + Test_String := + B10.To_Bounded_String("Much too long for this bounded string"); + Report.Failed("Length Error not raised by To_Bounded_String"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by To_Bounded_String"); + end; + + -- Drop = Left + + Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_String("efghijklmn") then + Report.Failed + ("Incorrect result from To_Bounded_String, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := B10.To_Bounded_String(Source => "abcdefghijklmn", + Drop => Ada.Strings.Right); + + if not(Test_String = AtoJ_Bnd_Str) then + Report.Failed + ("Incorrect result from To_Bounded_String, Drop = Right"); + end if; + + + + + -- Function Append with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + -- Append (Bnd Str, Bnd Str); + Result_String := + B10.Append(B10.To_Bounded_String("abcde"), + B10.To_Bounded_String("fghijk")); -- 11 char + Report.Failed("Length_Error not raised by Append - 1"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 1"); + end; + + begin + -- Append (Str, Bnd Str); + Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), + B10.To_Bounded_String("fghijk"), + AS.Error); + Report.Failed("Length_Error not raised by Append - 2"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 2"); + end; + + begin + -- Append (Bnd Str, Char); + Result_String := + B10.Append(B10.To_Bounded_String("abcdefghij"), 'k'); + Report.Failed("Length_Error not raised by Append - 3"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 3"); + end; + + -- Drop = Left + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(B10.To_Bounded_String("abcdefgh"), -- 8 chs + B10.To_Bounded_String("ijklmn"), -- 6 chs + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("efghijklmn") then -- 10 chars + Report.Failed("Incorrect truncation performed by Append - 4"); + end if; + + -- Append (Bnd Str, Str) + Result_String := + B10.Append(B10.To_Bounded_String("abcdefghij"), + "xyz", + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("defghijxyz") then + Report.Failed("Incorrect truncation performed by Append - 5"); + end if; + + -- Append (Char, Bnd Str) + + Result_String := B10.Append('A', + B10.To_Bounded_String("abcdefghij"), + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("abcdefghij") then + Report.Failed("Incorrect truncation performed by Append - 6"); + end if; + + -- Drop = Right + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(FtoJ_Bnd_Str, + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("fghijabcde") then + Report.Failed("Incorrect truncation performed by Append - 7"); + end if; + + -- Append (Str, Bnd Str) + Result_String := B10.Append(B10.To_String(AtoE_Bnd_Str), + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("abcdeabcde") then + Report.Failed("Incorrect truncation performed by Append - 8"); + end if; + + -- Append (Char, Bnd Str) + Result_String := B10.Append('A', AtoJ_Bnd_Str, Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("Aabcdefghi") then + Report.Failed("Incorrect truncation performed by Append - 9"); + end if; + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := B10.Index(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Pattern => "xy", + Going => Ada.Strings.Forward, + Mapping => CD_to_XY_Map); -- change "cd" to "xy" + + if Location /= 3 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := B10.Index(B10.To_Bounded_String("AND IF MAN"), + "an", + Ada.Strings.Backward, + ASC.Lower_Case_Map); + + if Location /= 9 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + Location := B10.Index(Source => B10.To_Bounded_String("The the"), + Pattern => "the", + Going => Ada.Strings.Forward, + Mapping => ASC.Lower_Case_Map); + + if Location /= 1 then + Report.Failed("Incorrect result from Index, non-Identity map - 3"); + end if; + + + if B10.Index(B10.To_Bounded_String("abcd"), -- Pattern = Source + "abcd") /= 1 or + B10.Index(B10.To_Bounded_String("abc"), -- Pattern < Source + "abcd") /= 0 or + B10.Index(B10.Null_Bounded_String, -- Source = Null + "abc") /= 0 + then + Report.Failed("Incorrect result from Index with string patterns"); + end if; + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + B10.Index(Source => B10.To_Bounded_String("abcdeabcde"), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward); + + if not (Location = 3) then -- position of first 'c' in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward. + Location := B10.Index(B10.To_Bounded_String("deddacd"), + CD_Set, + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward); + + if Location /= 2 then -- position of 'e' in source. + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Test = Outside, Going = Backward. + Location := B10.Index(B10.To_Bounded_String("deddacd"), + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward); + + if Location /= 5 then -- correct position of 'a'. + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + if B10.Index(B10.To_Bounded_String("cd"), -- Source = Set + CD_Set) /= 1 or + B10.Index(B10.To_Bounded_String("c"), -- Source < Set + CD_Set) /= 1 or + B10.Index(B10.Null_Bounded_String, -- Source = Null + CD_Set) /= 0 or + B10.Index(AtoE_Bnd_Str, -- "abcde" + Maps.Null_Set) /= 0 or -- Null set + B10.Index(AtoE_Bnd_Str, + Maps.To_Set('x')) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 5"); + end if; + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + B10.Count(Source => B10.To_Bounded_String("abbabaabab"), + Pattern => "yz", + Mapping => AB_to_YZ_Map); + + if Total_Count /= 4 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + -- And a few with identity maps as well. + + if B10.Count(B10.To_Bounded_String("ABABABABAB"), + "ABA", + Maps.Identity) /= 2 or + B10.Count(B10.To_Bounded_String("ADCBADABCD"), + "AB", + Maps.To_Mapping("CD", "AB")) /= 5 or + B10.Count(B10.To_Bounded_String("aaaaaaaaaa"), + "aaa") /= 3 or + B10.Count(B10.To_Bounded_String("XX"), -- Source < Pattern + "XXX", + Maps.Identity) /= 0 or + B10.Count(AtoE_Bnd_Str, -- Source = Pattern + "abcde") /= 1 or + B10.Count(B10.Null_Bounded_String, -- Source = Null + " ") /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + -- Procedure Translate + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_String("abcdeabcab"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_String("yzcdeyzcyz") then + Report.Failed("Incorrect result from procedure Translate - 1"); + end if; + + -- Total mapping of source. + + Test_String := B10.To_Bounded_String("abbaaababb"); + + B10.Translate(Source => Test_String, Mapping => ASC.Upper_Case_Map); + + if Test_String /= B10.To_Bounded_String("ABBAAABABB") then + Report.Failed("Incorrect result from procedure Translate - 2"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_String("xyzsypcc"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_String("xyzsypcc") then + Report.Failed("Incorrect result from procedure Translate - 3"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := B10.To_Bounded_String("have faith"); + + B10.Translate(Test_String, + Maps.To_Mapping("aeiou", "AEIOU")); + + if Test_String /= B10.To_Bounded_String("hAvE fAIth") then + Report.Failed("Incorrect result from procedure Translate - 4"); + end if; + + + -- Function Replace_Slice + -- Evaluate function Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 3, + High => 5, -- 3-5, 3 chars. + By => "xxxxxx"); -- more than 3. + Report.Failed("Length_Error not raised by Function Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + -- Drop = Left + + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 7, + High => 10, -- 7-10, 4 chars. + By => "xxxxxx", -- 6 chars. + Drop => Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("cdefxxxxxx") then -- drop a,b + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 2, + High => 5, -- 2-5, 4 chars. + By => "xxxxxx", -- 6 chars. + Drop => Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("axxxxxxfgh") then -- drop i,j + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Right"); + end if; + + -- Low = High = Source'Last, "By" length = 1. + + if B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'Last, + B10.To_String(AtoE_Bnd_Str)'Last, + "X", + Ada.Strings.Error) /= + B10.To_Bounded_String("abcdX") + then + Report.Failed("Incorrect result from Function Replace_Slice"); + end if; + + + + -- Procedure Replace_Slice + -- Evaluate procedure Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 3, + High => 5, -- 3-5, 3 chars. + By => "xxxxxx"); -- more than 3. + Report.Failed("Length_Error not raised by Procedure Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Replace_Slice"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 7, + High => 9, -- 7-9, 3 chars. + By => "xxxxx", -- 5 chars. + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_String("cdefxxxxxj") then -- drop a,b + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcdefghij" + Low => 1, + High => 3, -- 1-3, 3chars. + By => "xxxx", -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_String("xxxxdefghi") then -- drop j + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Right"); + end if; + + -- High = Source'First, Low > High (Insert before Low). + + Test_String := AtoE_Bnd_Str; + B10.Replace_Slice(Source => Test_String, -- "abcde" + Low => B10.To_String(Test_String)'Last, + High => B10.To_String(Test_String)'First, + By => "XXXX", -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_String("abcdXXXXe") then + Report.Failed + ("Incorrect result from Procedure Replace Slice"); + end if; + + + + -- Function Insert with Truncation + -- Drop = Error (Default). + + begin + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 2, + New_Item => "xyz"); + Report.Failed("Length_Error not raised by Function Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Insert"); + end; + + -- Drop = Left + + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 5, + New_Item => "xyz", -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_String(Result_String) /= "dxyzefghij" then -- drop a, b, c + Report.Failed("Incorrect result from Function Insert, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Insert(Source => B10.To_Bounded_String("abcdef"), + Before => 2, + New_Item => "vwxyz", -- 5 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_String(Result_String) /= "avwxyzbcde" then -- drop f. + Report.Failed("Incorrect result from Function Insert, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Insert(B10.To_Bounded_String("a"), 1, " B") /= + B10.To_Bounded_String(" Ba") or + B10.Insert(B10.Null_Bounded_String, 1, "abcde") /= + AtoE_Bnd_Str or + B10.Insert(B10.To_Bounded_String("ab"), 2, "") /= + B10.To_Bounded_String("ab") + then + Report.Failed("Incorrect result from Function Insert"); + end if; + + + -- Procedure Insert + + -- Drop = Error (Default). + begin + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, -- "abcdefghij" + Before => 9, + New_Item => "wxyz", + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Procedure Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, -- "abcdefghij" + Before => B10.Length(Test_String), -- before last char + New_Item => "xyz", -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_String(Test_String) /= "defghixyzj" then -- drop a, b, c + Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 4, + New_Item => "yz", -- 2 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_String(Test_String) /= "abcyzdefgh" then -- drop i,j + Report.Failed + ("Incorrect result from Procedure Insert, Drop = Right"); + end if; + + -- Before = Source'First, New_Item length = 1. + + Test_String := B10.To_Bounded_String(" abc "); + B10.Insert(Test_String, + B10.To_String(Test_String)'First, + "Z"); + + if Test_String /= B10.To_Bounded_String("Z abc ") then + Report.Failed("Incorrect result from Procedure Insert"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4009.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,619 ---- + -- CXA4009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Bounded are + -- available, and that they produce correct results, especially under + -- conditions where truncation of the result is required. Specifically, + -- check the subprograms Overwrite (function and procedure), Delete, + -- Function Trim (blanks), Trim (Set characters, function and procedure), + -- Head, Tail, and Replicate (characters and strings). + -- + -- TEST DESCRIPTION: + -- This test, in conjunction with tests CXA4006, CXA4007, and CXA4008, + -- will provide coverage of the most common usages of the functionality + -- found in the Ada.Strings.Bounded package. It deals in large part + -- with truncation effects and options. This test contains many small, + -- specific test cases, situations that are often difficult to generate + -- in large numbers in an application-based test. These cases represent + -- specific usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 95 SAIC Corrected errors in Procedure Overwrite subtests. + -- 01 Nov 95 SAIC Fixed bugs for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Strings.Bounded; + with Ada.Strings.Maps; + + procedure CXA4009 is + + begin + + Report.Test("CXA4009", "Check that the subprograms defined in " & + "package Ada.Strings.Bounded are available, " & + "and that they produce correct results, " & + "especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Bounded; + package Maps renames Ada.Strings.Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_String; + + Result_String : B10.Bounded_String; + Test_String : B10.Bounded_String; + AtoE_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("abcde"); + FtoJ_Bnd_Str : B10.Bounded_String := B10.To_Bounded_String("fghij"); + AtoJ_Bnd_Str : B10.Bounded_String := + B10.To_Bounded_String("abcdefghij"); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Character_Set := Maps.To_Set("cd"); + XY_Set : Maps.Character_Set := Maps.To_Set("xy"); + + + begin + + -- Function Overwrite with Truncation + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 9, + New_Item => "xyz", + Drop => AS.Error); + Report.Failed("Exception not raised by Function Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Overwrite"); + end; + + -- Drop = Left + + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String), -- 10 + New_Item => "xyz", + Drop => Ada.Strings.Left); + + if B10.To_String(Result_String) /= "cdefghixyz" then -- drop a,b + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Overwrite(Test_String, -- "abcdefghij" + 3, + "xxxyyyzzz", + Ada.Strings.Right); + + if B10.To_String(Result_String) /= "abxxxyyyzz" then -- one 'z' dropped + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Right"); + end if; + + -- Additional cases of function Overwrite. + + if B10.Overwrite(B10.To_Bounded_String("a"), -- Source length = 1 + 1, + " abc ") /= + B10.To_Bounded_String(" abc ") or + B10.Overwrite(B10.Null_Bounded_String, -- Null source + 1, + "abcdefghij") /= + AtoJ_Bnd_Str or + B10.Overwrite(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'First, + " ") /= -- New_Item = 1 + B10.To_Bounded_String(" bcde") + then + Report.Failed("Incorrect result from Function Overwrite"); + end if; + + + + -- Procedure Overwrite + -- Correct usage, no truncation. + + Test_String := AtoE_Bnd_Str; -- "abcde" + B10.Overwrite(Test_String, 2, "xyz"); + + if Test_String /= B10.To_Bounded_String("axyze") then + Report.Failed("Incorrect result from Procedure Overwrite - 1"); + end if; + + Test_String := B10.To_Bounded_String("abc"); + B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. + + if Test_String /= B10.To_Bounded_String("abc") then + Report.Failed("Incorrect result from Procedure Overwrite - 2"); + end if; + + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 8, + New_Item => "uvwxyz"); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Overwrite"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String) - 2, -- 8 + New_Item => "uvwxyz", + Drop => Ada.Strings.Left); + + if B10.To_String(Test_String) /= "defguvwxyz" then -- drop a-c + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Test_String, -- "abcdefghij" + 3, + "xxxyyyzzz", + Ada.Strings.Right); + + if B10.To_String(Test_String) /= "abxxxyyyzz" then -- one 'z' dropped + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Right"); + end if; + + + + -- Function Delete + + if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" + From => 3, + Through => 8) /= + B10."&"(B10.Head(AtoJ_Bnd_Str, 2), + B10.Tail(AtoJ_Bnd_Str, 2)) or + B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= + AtoE_Bnd_Str or + B10.Delete(AtoJ_Bnd_Str, 1, 5) /= + FtoJ_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, 4, 5) /= + B10.Delete(AtoJ_Bnd_Str, 4, B10.Length(AtoJ_Bnd_Str)) + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + + if B10.Delete(B10.To_Bounded_String("a"), 1, 1) /= + B10.Null_Bounded_String or + B10.Delete(AtoE_Bnd_Str, + 5, + B10.To_String(AtoE_Bnd_Str)'First) /= + AtoE_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'Last, + B10.To_String(AtoE_Bnd_Str)'Last) /= + B10.To_Bounded_String("abcd") + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Function Trim + + declare + + Text : B10.Bounded_String := B10.To_Bounded_String("Text"); + type Bnd_Array_Type is array (1..5) of B10.Bounded_String; + Bnd_Array : Bnd_Array_Type := + (B10.To_Bounded_String(" Text"), + B10.To_Bounded_String("Text "), + B10.To_Bounded_String(" Text "), + B10.To_Bounded_String("Text Text"), -- Ensure no inter-string + B10.To_Bounded_String(" Text Text")); -- trimming of blanks. + + begin + + for i in Bnd_Array_Type'Range loop + case i is + when 4 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + Bnd_Array(i) then -- no change + Report.Failed("Incorrect result from Function Trim - 4"); + end if; + when 5 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + B10."&"(Text, B10."&"(' ', Text)) then + Report.Failed("Incorrect result from Function Trim - 5"); + end if; + when others => + if B10.Trim(Bnd_Array(i), AS.Both) /= Text then + Report.Failed("Incorrect result from Function Trim - " & + Integer'Image(i)); + end if; + end case; + end loop; + + end; + + + + -- Function Trim using Sets + + -- Trim characters in sets from both sides of the bounded string. + if B10.Trim(Source => B10.To_Bounded_String("ddabbaxx"), + Left => CD_Set, + Right => XY_Set) /= + B10.To_Bounded_String("abba") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- string; likewise for the opposite side. Only "cd" trimmed from left + -- side, and only "xy" trimmed from right side. + + if B10.Trim(B10.To_Bounded_String("cdxyabcdxy"), CD_Set, XY_Set) /= + B10.To_Bounded_String("xyabcd") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded string, just the appropriate ends. + + if B10.Trim(B10.To_Bounded_String("cdabdxabxy"), CD_Set, XY_Set) /= + B10.To_Bounded_String("abdxab") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from right side only. No change to Left side. + + if B10.Trim(B10.To_Bounded_String("abxyzddcd"), XY_Set, CD_Set) /= + B10.To_Bounded_String("abxyz") + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Right side"); + end if; + + -- Trim no characters on either side of the bounded string. + + Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); + if Result_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); + end if; + + if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= + AtoE_Bnd_Str or + B10.Trim(B10.To_Bounded_String("dcddcxyyxx"), + CD_Set, + XY_Set) /= + B10.Null_Bounded_String + then + Report.Failed("Incorrect result from Function Trim"); + end if; + + + + -- Procedure Trim using Sets + + -- Trim characters in sets from both sides of the bounded string. + + Test_String := B10.To_Bounded_String("dcabbayx"); + B10.Trim(Source => Test_String, + Left => CD_Set, + Right => XY_Set); + + if Test_String /= B10.To_Bounded_String("abba") then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- string; likewise for the opposite side. Only "cd" trimmed from left + -- side, and only "xy" trimmed from right side. + + Test_String := B10.To_Bounded_String("cdxyabcdxy"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_String("xyabcd") then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded string, just the appropriate ends. + + Test_String := B10.To_Bounded_String("cdabdxabxy"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if not (Test_String = B10.To_Bounded_String("abdxab")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from Left side only. No change to Right side. + + Test_String := B10.To_Bounded_String("cccdabxyz"); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_String("abxyz") then + Report.Failed + ("Incorrect result from Proc Trim for Sets, Left side only"); + end if; + + -- Trim no characters on either side of the bounded string. + + Test_String := AtoJ_Bnd_Str; + B10.Trim(Test_String, CD_Set, CD_Set); + + if Test_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); + end if; + + + + -- Function Head with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => 'X'); + Report.Failed("Length_Error not raised by Function Head"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Head"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the right end of the string + -- (which is initially at its maximum length), then the first five + -- characters of the intermediate result are dropped to conform to + -- the maximum size limit of the bounded string (10). + + Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHIJ"), + 15, + 'x', + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("FGHIJxxxxx") then + Report.Failed("Incorrect result from Function Head, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (6) are appended to the left end of the string + -- (which is initially at one less than its maximum length), then the + -- last five characters of the intermediate result are dropped + -- (which in this case are the pad characters) to conform to the + -- maximum size limit of the bounded string (10). + + Result_String := B10.Head(B10.To_Bounded_String("ABCDEFGHI"), + 15, + 'x', + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("ABCDEFGHIx") then + Report.Failed("Incorrect result from Function Head, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Head(B10.Null_Bounded_String, 5) /= + B10.To_Bounded_String(" ") or + B10.Head(AtoE_Bnd_Str, + B10.Length(AtoE_Bnd_Str)) /= + AtoE_Bnd_Str + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail with Truncation + -- Drop = Error (Default Case) + + begin + Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Ada.Strings.Space, + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Function Tail"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Tail"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the left end of the string + -- (which is initially at two less than its maximum length), then + -- the first three characters of the intermediate result (in this + -- case, 3 pad characters) are dropped. + + Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGH"), -- 8 ch + 13, + 'x', + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("xxABCDEFGH") then + Report.Failed("Incorrect result from Function Tail, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (3) are appended to the left end of the string + -- (which is initially at its maximum length), then the last three + -- characters of the intermediate result are dropped. + + Result_String := B10.Tail(B10.To_Bounded_String("ABCDEFGHIJ"), + 13, + 'x', + Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("xxxABCDEFG") then + Report.Failed("Incorrect result from Function Tail, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Tail(B10.Null_Bounded_String, 3, ' ') /= + B10.To_Bounded_String(" ") or + B10.Tail(AtoE_Bnd_Str, + B10.To_String(AtoE_Bnd_Str)'First) /= + B10.To_Bounded_String("e") + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function Replicate (#, Char) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => B10.Max_Length + 5, + Item => 'A', + Drop => AS.Error); + Report.Failed + ("Length_Error not raised by Replicate for characters"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for characters"); + end; + + -- Drop = Left, Right + -- Since this version of Replicate uses character parameters, the + -- result after truncation from left or right will appear the same. + -- The result will be a 10 character bounded string, composed of 10 + -- "Item" characters. + + if B10.Replicate(Count => 20, Item => 'A', Drop => Ada.Strings.Left) /= + B10.Replicate(15, 'A', Ada.Strings.Right) + then + Report.Failed("Incorrect result from Replicate for characters - 1"); + end if; + + -- Blank-filled 10 character bounded strings. + + if B10.Replicate(B10.Max_Length + 1, ' ', Drop => Ada.Strings.Left) /= + B10.Replicate(B10.Max_Length, Ada.Strings.Space) + then + Report.Failed("Incorrect result from Replicate for characters - 2"); + end if; + + -- Additional cases. + + if B10.Replicate(0, 'a') /= B10.Null_Bounded_String or + B10.Replicate(1, 'a') /= B10.To_Bounded_String("a") + then + Report.Failed("Incorrect result from Replicate for characters - 3"); + end if; + + + + -- Function Replicate (#, String) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => 5, -- result would be 15. + Item => "abc"); + Report.Failed + ("Length_Error not raised by Replicate for strings"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for strings"); + end; + + -- Drop = Left + + Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_String("cdabcdabcd") then + Report.Failed + ("Incorrect result from Replicate for strings, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Replicate(3, "abcd", Drop => Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_String("abcdabcdab") then + Report.Failed + ("Incorrect result from Replicate for strings, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Replicate(10, "X") /= B10.To_Bounded_String("XXXXXXXXXX") or + B10.Replicate(10, "") /= B10.Null_Bounded_String or + B10.Replicate( 0, "ab") /= B10.Null_Bounded_String + then + Report.Failed("Incorrect result from Replicate for strings"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4010.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,275 ---- + -- CXA4010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Unbounded + -- are available, and that they produce correct results. Specifically, + -- check the subprograms To_String, To_Unbounded_String, Insert, "&", + -- "*", Length, Slice, Replace_Slice, Overwrite, Index, Index_Non_Blank, + -- Head, Tail, and "=", "<=", ">=". + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Unbounded for use with unbounded strings. + -- The test simulates how unbounded strings could be used + -- to simulate paragraphs of text. Modifications could be easily be + -- performed using the provided subprograms (although in this test, the + -- main modification performed was the addition of more text to the + -- string). One would not have to worry about the formatting of the + -- paragraph until it was finished and correct in content. Then, once + -- all required editing is complete, the unbounded strings can be divided + -- up into the appropriate lengths based on particular formatting + -- requirements. The test then compares the formatted text product + -- with a predefined "finished product". + -- + -- This test uses a large number of the subprograms provided + -- by package Ada.Strings.Unbounded. Often, the processing involved + -- could have been performed more efficiently using a minimum number + -- of the subprograms, in conjunction with loops, etc. However, for + -- testing purposes, and in the interest of minimizing the number of + -- tests developed, subprogram variety and feature mixing was stressed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with Ada.Strings.Maps; + with Ada.Strings.Unbounded; + + procedure CXA4010 is + begin + + Report.Test ("CXA4010", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASUnb renames Ada.Strings.Unbounded; + use type ASUnb.Unbounded_String; + use Ada.Strings; + + Pamphlet_Paragraph_Count : constant := 2; + Lines : constant := 4; + Line_Length : constant := 40; + + type Document_Type is array (Positive range <>) + of ASUnb.Unbounded_String; + + type Camera_Ready_Copy_Type is array (1..Lines) + of String (1..Line_Length); + + Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); + + Camera_Ready_Copy : Camera_Ready_Copy_Type := + (others => (others => Ada.Strings.Space)); + + TC_Finished_Product : Camera_Ready_Copy_Type := + ( 1 => "Ada is a programming language designed ", + 2 => "to support long-lived, reliable software", + 3 => " systems. ", + 4 => "Go with Ada! "); + + ----- + + + procedure Enter_Text_Into_Document (Document : in out Document_Type) is + begin + + -- Fill in both "paragraphs" of the document. Each unbounded string + -- functions as an individual paragraph, containing an unspecified + -- number of characters. + -- Use a variety of different unbounded string subprograms to load + -- the data. + + Document(1) := ASUnb.To_Unbounded_String("Ada is a language"); + + -- Insert the word "programming" prior to "language". + Document(1) := + ASUnb.Insert(Document(1), + ASUnb.Index(Document(1), + "language"), + ASUnb.To_String("progra" & -- Str & + ASUnb."*"(2,'m') & -- Unbd & + "ing ")); -- Str + + + -- Overwrite the word "language" with "language" + additional text. + Document(1) := + ASUnb.Overwrite(Document(1), + ASUnb.Index(Document(1), + ASUnb.To_String( + ASUnb.Tail(Document(1), 8, ' ')), + Ada.Strings.Backward), + "language designed to support long-lifed"); + + + -- Replace the word "lifed" with "lived". + Document(1) := + ASUnb.Replace_Slice(Document(1), + ASUnb.Index(Document(1), "lifed"), + ASUnb.Length(Document(1)), + "lived"); + + + -- Overwrite the word "lived" with "lived" + additional text. + Document(1) := + ASUnb.Overwrite(Document(1), + ASUnb.Index(Document(1), + ASUnb.To_String( + ASUnb.Tail(Document(1), 5, ' ')), + Ada.Strings.Backward), + "lived, reliable software systems."); + + + -- Use several of the overloaded versions of "&" to form this + -- unbounded string. + + Document(2) := 'G' & + ASUnb.To_Unbounded_String("o ") & + ASUnb.To_Unbounded_String("with") & + ' ' & + "Ada!"; + + end Enter_Text_Into_Document; + + + ----- + + + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type) is + begin + -- Break the unbounded strings into fixed lengths. + + -- Search the first unbounded string for portions of text that + -- are less than or equal to the length of a string in the + -- Camera_Ready_Copy_Type object. + + Camera_Copy(1) := -- Take characters 1-39, + ASUnb.Slice(Document(1), -- and append a blank space. + 1, + ASUnb.Index(ASUnb.To_Unbounded_String( + ASUnb.Slice(Document(1), + 1, + Line_Length)), + Ada.Strings.Maps.To_Set(' '), + Ada.Strings.Inside, + Ada.Strings.Backward)) & ' '; + + Camera_Copy(2) := -- Take characters 40-79. + ASUnb.Slice(Document(1), + 40, + (ASUnb.Index_Non_Blank -- Should return 79 + (ASUnb.To_Unbounded_String + (ASUnb.Slice(Document(1), -- Slice (40..79) + 40, + 79)), + Ada.Strings.Backward) + 39)); -- Increment since + -- this slice starts + -- at 40. + + Camera_Copy(3)(1..9) := ASUnb.Slice(Document(1), -- Characters 80-88 + 80, + ASUnb.Length(Document(1))); + + + -- Break the second unbounded string into the appropriate length. + -- It is only twelve characters in length, so the entire unbounded + -- string will be placed on one string of the output object. + + Camera_Copy(4)(1..ASUnb.Length(Document(2))) := + ASUnb.To_String(ASUnb.Head(Document(2), + ASUnb.Length(Document(2)))); + + end Create_Camera_Ready_Copy; + + + ----- + + + function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) + return Boolean is + begin + + -- Evaluate strings for equality, using the operators defined in + -- package Ada.Strings.Unbounded. The less than/greater than or + -- equal comparisons should evaluate to "equals => True". + + if ASUnb.To_Unbounded_String(Draft(1)) = -- "="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(1)) and + ASUnb.To_Unbounded_String(Draft(2)) <= -- "<="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(2)) and + ASUnb.To_Unbounded_String(Draft(3)) >= -- ">="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(3)) and + ASUnb.To_Unbounded_String(Draft(4)) = -- "="(Unb,Unb) + ASUnb.To_Unbounded_String(Master(4)) + then + return True; + else + return False; + end if; + + end Valid_Proofread; + + + ----- + + + begin + + -- Enter text into the unbounded string paragraphs of the document. + + Enter_Text_Into_Document (Pamphlet); + + + -- Reformat the unbounded strings into fixed string format. + + Create_Camera_Ready_Copy (Document => Pamphlet, + Camera_Copy => Camera_Ready_Copy); + + + -- Verify the conversion process. + + if not Valid_Proofread (Draft => Camera_Ready_Copy, + Master => TC_Finished_Product) + then + Report.Failed ("Incorrect string processing result"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4011.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,376 ---- + -- CXA4011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Unbounded + -- are available, and that they produce correct results. Specifically, + -- check the subprograms To_Unbounded_String, "&", ">", "<", Element, + -- Replace_Element, Count, Find_Token, Translate, Trim, Delete, and + -- "*". + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Unbounded for use with unbounded strings. + -- The test simulates how unbounded strings could be processed in a + -- user environment, using the subprograms provided in this package. + -- + -- This test uses a variety of the subprograms defined in the unbounded + -- string package in ways typical of common usage, with different + -- combinations of available subprograms being used to accomplish + -- similar unbounded string processing goals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 95 SAIC Test description modification. + -- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Strings.Maps; + with Ada.Strings.Unbounded; + + procedure CXA4011 is + begin + + Report.Test ("CXA4011", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASUnb renames Ada.Strings.Unbounded; + use Ada.Strings; + use type Maps.Character_Set; + use type ASUnb.Unbounded_String; + + Cad_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("cad"); + + Complete_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Incomplete") & + Ada.Strings.Space & + ASUnb.To_Unbounded_String("String"); + + Incomplete_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("ncomplete Strin"); + + Incorrect_Spelling : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Guob Dai"); + + Magic_String : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("abracadabra"); + + Incantation : ASUnb.Unbounded_String := Magic_String; + + + A_Small_G : Character := 'g'; + A_Small_D : Character := 'd'; + + ABCD_Set : Maps.Character_Set := Maps.To_Set("abcd"); + B_Set : Maps.Character_Set := Maps.To_Set('b'); + AB_Set : Maps.Character_Set := Maps."OR"(Maps.To_Set('a'), B_Set); + + Code_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "abcd", To => "wxyz"); + Reverse_Code_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "wxyz", To => "abcd"); + Non_Existent_Map : Maps.Character_Mapping := + Maps.To_Mapping(From => "jkl", To => "mno"); + + + Token_Start : Positive; + Token_End : Natural := 0; + Matching_Letters : Natural := 0; + + + begin + + -- "&" + + -- Prepend an 'I' and append a 'g' to the string. + Incomplete_String := ASUnb."&"('I', Incomplete_String); -- Char & Unb + Incomplete_String := ASUnb."&"(Incomplete_String, + A_Small_G); -- Unb & Char + + if Incomplete_String < Complete_String or + Incomplete_String > Complete_String or + Incomplete_String /= Complete_String + then + Report.Failed("Incorrect result from use of ""&"" operator"); + end if; + + + -- Element + + -- Last element of the unbounded string should be a 'g'. + if ASUnb.Element(Incomplete_String, ASUnb.Length(Incomplete_String)) /= + A_Small_G + then + Report.Failed("Incorrect result from use of Function Element - 1"); + end if; + + if ASUnb.Element(Incomplete_String, 2) /= + ASUnb.Element(ASUnb.Tail(Incomplete_String, 2), 1) or + ASUnb.Element(ASUnb.Head(Incomplete_String, 4), 2) /= + ASUnb.Element(ASUnb.To_Unbounded_String("wnqz"), 2) + then + Report.Failed("Incorrect result from use of Function Element - 2"); + end if; + + + -- Replace_Element + + -- The unbounded string Incorrect_Spelling starts as "Guob Dai", and + -- is transformed by the following three procedure calls to "Good Day". + + ASUnb.Replace_Element(Incorrect_Spelling, 2, 'o'); + + ASUnb.Replace_Element(Incorrect_Spelling, + ASUnb.Index(Incorrect_Spelling, B_Set), + A_Small_D); + + ASUnb.Replace_Element(Source => Incorrect_Spelling, + Index => ASUnb.Length(Incorrect_Spelling), + By => 'y'); + + if Incorrect_Spelling /= ASUnb.To_Unbounded_String("Good Day") then + Report.Failed("Incorrect result from Procedure Replace_Element"); + end if; + + + -- Count + + -- Determine the number of characters in the unbounded string that + -- are contained in the set. + + Matching_Letters := ASUnb.Count(Source => Magic_String, + Set => ABCD_Set); + + if Matching_Letters /= 9 then + Report.Failed + ("Incorrect result from Function Count with Set parameter"); + end if; + + -- Determine the number of occurrences of the following pattern strings + -- in the unbounded string Magic_String. + + if ASUnb.Count(Magic_String, "ab") /= + (ASUnb.Count(Magic_String, "ac") + ASUnb.Count(Magic_String, "ad")) or + ASUnb.Count(Magic_String, "ab") /= 2 + then + Report.Failed + ("Incorrect result from Function Count with String parameter"); + end if; + + + -- Find_Token + + ASUnb.Find_Token(Magic_String, -- Find location of first "ab". + AB_Set, -- Should be (1..2). + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Natural(Token_Start) /= ASUnb.To_String(Magic_String)'First or + Token_End /= ASUnb.Index(Magic_String, B_Set) + then + Report.Failed("Incorrect result from Procedure Find_Token - 1"); + end if; + + + ASUnb.Find_Token(Source => Magic_String, -- Find location of char 'r' + Set => ABCD_Set, -- in string, should be (3..3) + Test => Ada.Strings.Outside, + First => Token_Start, + Last => Token_End); + + if Natural(Token_Start) /= 3 or + Token_End /= 3 then + Report.Failed("Incorrect result from Procedure Find_Token - 2"); + end if; + + + ASUnb.Find_Token(Magic_String, -- No 'g' is in the string, so + Maps.To_Set(A_Small_G), -- the result parameters should + Ada.Strings.Inside, -- be First = Source'First and + First => Token_Start, -- Last = 0. + Last => Token_End); + + if Token_Start /= ASUnb.To_String(Magic_String)'First or + Token_End /= 0 + then + Report.Failed("Incorrect result from Procedure Find_Token - 3"); + end if; + + + -- Translate + + -- Use a mapping ("abcd" -> "wxyz") to transform the contents of + -- the unbounded string. + -- Magic_String = "abracadabra" + + Incantation := ASUnb.Translate(Magic_String, Code_Map); + + if Incantation /= ASUnb.To_Unbounded_String("wxrwywzwxrw") then + Report.Failed("Incorrect result from Function Translate"); + end if; + + -- Use the inverse mapping of the one above to return the "translated" + -- unbounded string to its original form. + + ASUnb.Translate(Incantation, Reverse_Code_Map); + + -- The map contained in the following call to Translate contains one + -- element, and this element is not found in the unbounded string, so + -- this call to Translate should have no effect on the unbounded string. + + if Incantation /= ASUnb.Translate(Magic_String, Non_Existent_Map) then + Report.Failed("Incorrect result from Procedure Translate"); + end if; + + + -- Trim + + Trim_Block: + declare + + XYZ_Set : Maps.Character_Set := Maps.To_Set("xyz"); + PQR_Set : Maps.Character_Set := Maps.To_Set("pqr"); + + Pad : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Pad"); + + The_New_Ada : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Ada9X"); + + Space_Array : array (1..4) of ASUnb.Unbounded_String := + (ASUnb.To_Unbounded_String(" Pad "), + ASUnb.To_Unbounded_String("Pad "), + ASUnb.To_Unbounded_String(" Pad"), + Pad); + + String_Array : array (1..5) of ASUnb.Unbounded_String := + (ASUnb.To_Unbounded_String("xyzxAda9Xpqr"), + ASUnb.To_Unbounded_String("Ada9Xqqrp"), + ASUnb.To_Unbounded_String("zxyxAda9Xqpqr"), + ASUnb.To_Unbounded_String("xxxyAda9X"), + The_New_Ada); + + begin + + -- Examine the version of Trim that removes blanks from + -- the left and/or right of a string. + + for i in 1..4 loop + if ASUnb.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then + Report.Failed("Incorrect result from Trim for spaces - " & + Integer'Image(i)); + end if; + end loop; + + -- Examine the version of Trim that removes set characters from + -- the left and right of a string. + + for i in 1..5 loop + if ASUnb.Trim(String_Array(i), + Left => XYZ_Set, + Right => PQR_Set) /= The_New_Ada then + Report.Failed + ("Incorrect result from Trim for set characters - " & + Integer'Image(i)); + end if; + end loop; + + end Trim_Block; + + + -- Delete + + -- Use the Delete function to remove the first four and last four + -- characters from the string. + + if ASUnb.Delete(Source => ASUnb.Delete(Magic_String, + 8, + ASUnb.Length(Magic_String)), + From => ASUnb.To_String(Magic_String)'First, + Through => 4) /= + Cad_String + then + Report.Failed("Incorrect results from Function Delete"); + end if; + + + -- Constructors ("*") + + Constructor_Block: + declare + + SOS : ASUnb.Unbounded_String; + + Dot : constant ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Dot_"); + Dash : constant String := "Dash_"; + + Distress : ASUnb.Unbounded_String := + ASUnb.To_Unbounded_String("Dot_Dot_Dot_") & + ASUnb.To_Unbounded_String("Dash_Dash_Dash_") & + ASUnb.To_Unbounded_String("Dot_Dot_Dot"); + + Repeat : constant Natural := 3; + Separator : constant Character := '_'; + + Separator_Set : Maps.Character_Set := Maps.To_Set(Separator); + + begin + + -- Use the following constructor forms to construct the string + -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the + -- trailing underscore in the string is removed in the call to + -- Trim in the If statement condition. + + SOS := ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) + + SOS := SOS & + ASUnb."*"(Repeat, Dash) & -- "*"(#, Str) + ASUnb."*"(Repeat, Dot); -- "*"(#, Unb Str) + + if ASUnb.Trim(SOS, Maps.Null_Set, Separator_Set) /= Distress then + Report.Failed("Incorrect results from Function ""*"""); + end if; + + end Constructor_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4012.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,305 ---- + -- CXA4012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the types, operations, and other entities defined within + -- the package Ada.Strings.Wide_Maps are available and produce correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the availability and function of the types and + -- operations defined in package Ada.Strings.Wide_Maps. It demonstrates + -- the use of these types and functions as they would be used in common + -- programming practice. + -- Wide_Character set creation, assignment, and comparison are evaluated + -- in this test. Each of the functions provided in package + -- Ada.Strings.Wide_Maps is utilized in creating or manipulating set + -- objects, and the function results are evaluated for correctness. + -- Wide_Character sequences are examined using the functions provided for + -- manipulating objects of this type. Likewise, Wide_Character maps are + -- created, and their contents evaluated. Exception raising conditions + -- from the function To_Mapping are also created. + -- Note: Throughout this test, the set logical operators are printed in + -- capital letters to enhance their visibility. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 01 Nov 95 SAIC Update and repair for ACVC 2.0.1. + -- + --! + + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + + package CXA40120 is + + function Equiv (Ch : Character) return Wide_Character; + function Equiv (Str : String) + return Ada.Strings.Wide_Maps.Wide_Character_Sequence; + function X_Map(From : Wide_Character) return Wide_Character; + + end CXA40120; + + package body CXA40120 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to certain Wide_Map + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Character_Sequences in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + function Equiv (Str : String) + return Ada.Strings.Wide_Maps.Wide_Character_Sequence is + use Ada.Strings; + WS : Wide_Maps.Wide_Character_Sequence(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + function X_Map(From : Wide_Character) return Wide_Character is + begin + return Equiv('X'); + end X_Map; + + end CXA40120; + + + + with CXA40120; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + with Report; + + procedure CXA4012 is + + use CXA40120; + use Ada.Strings; + + begin + + Report.Test ("CXA4012", "Check that the types, operations, and other " & + "entities defined within the package " & + "Ada.Strings.Wide_Maps are available and " & + "produce correct results"); + + Test_Block: + declare + + use type Wide_Maps.Wide_Character_Set; + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Wide_Maps.Wide_Character_Sequence := + Equiv("aeiou"); + Quasi_Vowel : constant Wide_Character := Equiv('y'); + + Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); + Half_Alphabet : Wide_Maps.Wide_Character_Sequence(1..MidPoint_Letter); + Inverse_Alphabet : Wide_Maps.Wide_Character_Sequence(1..Last_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + Full_Vowel_Set, + First_Half_Set, + Second_Half_Set : Wide_Maps.Wide_Character_Set := Wide_Maps.Null_Set; + + begin + + -- Load the alphabet string for use in creating sets. + + for i in 0..MidPoint_Letter-1 loop + Half_Alphabet(i+1) := + Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); + end loop; + + for i in 0..Last_Letter-1 loop + Alphabet(i+1) := + Wide_Character'Val(Wide_Character'Pos(Equiv('a')) + i); + end loop; + + + -- Initialize a series of Wide_Character_Set objects. + + Alphabet_Set := Wide_Maps.To_Set(Alphabet); + Vowel_Set := Wide_Maps.To_Set(Vowels); + Full_Vowel_Set := Vowel_Set OR Wide_Maps.To_Set(Quasi_Vowel); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + First_Half_Set := Wide_Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + -- Evaluation of Set objects, operators, and functions. + + if Alphabet_Set /= (Vowel_Set OR Consonant_Set) then + Report.Failed("Incorrect set combinations using OR operator"); + end if; + + + for i in Vowels'First .. Vowels'Last loop + if not Wide_Maps.Is_In(Vowels(i), Vowel_Set) or + not Wide_Maps.Is_In(Vowels(i), Alphabet_Set) or + Wide_Maps.Is_In(Vowels(i), Consonant_Set) + then + Report.Failed("Incorrect function Is_In use with set " & + "combinations - " & Integer'Image(i)); + end if; + end loop; + + + if Wide_Maps.Is_Subset(Vowel_Set, First_Half_Set) or + Wide_Maps."<="(Vowel_Set, Second_Half_Set) or + not Wide_Maps.Is_Subset(Vowel_Set, Alphabet_Set) + then + Report.Failed + ("Incorrect set evaluation using Is_Subset function"); + end if; + + + if not (Full_Vowel_Set = Wide_Maps.To_Set(Equiv("aeiouy"))) then + Report.Failed("Incorrect result for ""="" set operator"); + end if; + + + if not ((Vowel_Set AND First_Half_Set) OR + (Full_Vowel_Set AND Second_Half_Set)) = Full_Vowel_Set then + Report.Failed + ("Incorrect result for AND, OR, or ""="" set operators"); + end if; + + + if (Alphabet_Set AND Wide_Maps.Null_Set) /= Wide_Maps.Null_Set or + (Alphabet_Set OR Wide_Maps.Null_Set) /= Alphabet_Set + then + Report.Failed("Incorrect result for AND or OR set operators"); + end if; + + + Vowel_Set := Full_Vowel_Set; + Vowel_Set := Vowel_Set AND (NOT Wide_Maps.To_Set(Quasi_Vowel)); + + if not (Vowels = Wide_Maps.To_Sequence(Vowel_Set)) then + Report.Failed("Incorrect Set to Sequence translation"); + end if; + + + for i in 0..Last_Letter-1 loop + Inverse_Alphabet(i+1) := Alphabet(Last_Letter-i); + end loop; + + + -- Wide_Character_Mapping + + declare + Inverse_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Alphabet, Inverse_Alphabet); + begin + if Wide_Maps.Value(Wide_Maps.Identity, Equiv('b')) /= + Wide_Maps.Value(Inverse_Map, Equiv('y')) + then + Report.Failed("Incorrect Inverse mapping"); + end if; + end; + + + -- Check that Translation_Error is raised when a character is + -- repeated in the parameter "From" string. + declare + Bad_Map : Wide_Maps.Wide_Character_Mapping; + begin + Bad_Map := Wide_Maps.To_Mapping(From => Equiv("aa"), + To => Equiv("yz")); + Report.Failed("Exception not raised with repeated character"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "a repeated character"); + end; + + + -- Check that Translation_Error is raised when the parameters of the + -- function To_Mapping are of unequal lengths. + declare + Bad_Map : Wide_Maps.Wide_Character_Mapping; + begin + Bad_Map := Wide_Maps.To_Mapping(Equiv("abc"), Equiv("yz")); + Report.Failed + ("Exception not raised with unequal parameter lengths"); + exception + when Translation_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised in To_Mapping with " & + "unequal parameter lengths"); + end; + + + -- Check that the access-to-subprogram type is defined and available. + -- This provides for one Wide_Character mapping capability only. + -- The actual mapping functionality will be tested in conjunction with + -- the tests of subprograms defined for Wide_String handling. + + declare + + X_Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + X_Map'Access; + + begin + if X_Map_Ptr(Equiv('A')) /= -- both return 'X' + X_Map_Ptr.all(Equiv('Q')) + then + Report.Failed + ("Incorrect result using access-to-subprogram values"); + end if; + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4013.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,203 ---- + -- CXA4013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Fixed + -- are available, and that they produce correct results. Specifically, + -- check the subprograms Index, "*" (Wide_String constructor function), + -- Count, Trim, and Replace_Slice. + -- + -- TEST DESCRIPTION: + -- This test demonstrates how certain Wide_Fixed string functions + -- are used to eliminate specific substrings from portions of text. + -- A procedure is defined that will take as parameters a source + -- Wide_String along with a substring that is to be completely removed + -- from the source string. The source Wide_String is parsed using the + -- Index function, and any substring slices are replaced in the source + -- Wide_String by a series of X's (based on the length of the substring.) + -- Three lines of text are provided to this procedure, and the resulting + -- substitutions are compared with expected results to validate the + -- string processing. + -- A global accumulator is updated with the number of occurrences of the + -- substring in the source string. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Strings; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Maps; + with Report; + + procedure CXA4013 is + + begin + + Report.Test ("CXA4013", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + TC_Total : Natural := 0; + Number_Of_Lines : constant := 3; + WC : Wide_Character := + Wide_Character'Val(Character'Pos('X') + + Character'Pos(Character'Last) + + 1 ); + + subtype WS is Wide_String (1..25); + + type Restricted_Words_Array_Type is + array (1..10) of Wide_String (1..10); + + Restricted_Words : Restricted_Words_Array_Type := + (" platoon", " marines ", " Marines ", + "north ", "south ", " east", + " beach ", " airport", "airfield ", + " road "); + + type Page_Of_Text_Type is array (1..Number_Of_Lines) of WS; + + Text_Page : Page_Of_Text_Type := ("The platoon of Marines ", + "moved south on the south ", + "road to the airfield. "); + + TC_Revised_Line_1 : constant Wide_String := "The XXXXXXX of XXXXXXX "; + TC_Revised_Line_2 : constant Wide_String := "moved XXXXX on the XXXXX "; + TC_Revised_Line_3 : constant Wide_String := "XXXX to the XXXXXXXX. "; + + + function Equivalent (Left : WS; Right : Wide_String) + return Boolean is + begin + for i in WS'range loop + if Left(i) /= Right(i) then + if Left(i) /= WC or Right(i) /= 'X' then + return False; + end if; + end if; + end loop; + return True; + end Equivalent; + + --- + + procedure Censor (Source_String : in out Wide_String; + Pattern_String : in Wide_String) is + + use Ada.Strings.Wide_Fixed; -- allows infix notation of "*" below. + + -- Create a replacement string that is the same length as the + -- pattern string being removed. Use the infix notation of the + -- wide string constructor function. + + Replacement : constant Wide_String := + Pattern_String'Length * WC; -- "*" + + Going : Ada.Strings.Direction := Ada.Strings.Forward; + Start_Pos, + Index : Natural := Source_String'First; + + begin -- Censor + + -- Accumulate count of total replacement operations. + + TC_Total := TC_Total + + Ada.Strings.Wide_Fixed.Count -- Count + (Source => Source_String, + Pattern => Pattern_String, + Mapping => Ada.Strings.Wide_Maps.Identity); + loop + + Index := Ada.Strings.Wide_Fixed.Index -- Index + (Source_String(Start_Pos..Source_String'Last), + Pattern_String, + Going, + Ada.Strings.Wide_Maps.Identity); + + exit when Index = 0; -- No matches, exit loop. + + -- if a match was found, modify the substring. + Ada.Strings.Wide_Fixed.Replace_Slice -- Replace_Slice + (Source_String, + Index, + Index + Pattern_String'Length - 1, + Replacement); + Start_Pos := Index + Pattern_String'Length; + + end loop; + + end Censor; + + + begin + + -- Invoke Censor subprogram to cleanse text. + -- Loop through each line of text, and check for the presence of each + -- restricted word. + -- Use the Trim function to eliminate leading or trailing blanks from + -- the restricted word parameters. + + for Line in 1..Number_Of_Lines loop + for Word in Restricted_Words'Range loop + Censor (Text_Page(Line), -- Trim + Ada.Strings.Wide_Fixed.Trim(Restricted_Words(Word), + Ada.Strings.Both)); + end loop; + end loop; + + + -- Validate results. + + if TC_Total /= 6 then + Report.Failed ("Incorrect number of substitutions performed"); + end if; + + if not Equivalent (Text_Page(1), TC_Revised_Line_1) then + Report.Failed ("Incorrect substitutions on Line 1"); + end if; + + if not Equivalent (Text_Page(2), TC_Revised_Line_2) then + Report.Failed ("Incorrect substitutions on Line 2"); + end if; + + if not Equivalent (Text_Page(3), TC_Revised_Line_3) then + Report.Failed ("Incorrect substitutions on Line 3"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4014.a 2003-10-27 11:28:57.000000000 +0000 *************** *** 0 **** --- 1,359 ---- + -- CXA4014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Fixed + -- are available, and that they produce correct results. Specifically, + -- check the subprograms Find_Token, Head, Index, Index_Non_Blank, Move, + -- Overwrite, and Replace_Slice, Tail, and Translate. + -- Use the access-to-subprogram mapping version of Translate (function + -- and procedure). + -- + -- TEST DESCRIPTION: + -- This test demonstrates how certain wide fixed string operations could + -- be used in wide string information processing. A procedure is defined + -- that will extract portions of a 50 character string that correspond to + -- certain data items (i.e., name, address, state, zip code). These + -- parsed items will then be added to the appropriate fields of data + -- base elements. These data base elements are then compared for + -- accuracy against a similar set of predefined data base + -- elements. + -- A variety of wide fixed string processing subprograms are used in this + -- test. Each parsing operation attempts to use a different combination + -- of the available subprograms to accomplish the same goal, therefore + -- continuity of approach to wide string parsing is not seen in this + -- test. + -- However, a wide variety of possible approaches are demonstrated, while + -- exercising a large number of the total predefined subprograms of + -- package Ada.Strings.Wide_Fixed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 95 SAIC Update and repair for ACVC 2.0.1. + -- + --! + + package CXA40140 is + + UnderScore : Wide_Character := '_'; + Blank : Wide_Character := ' '; + + -- Function providing a mapping to a blank Wide_Character. + function US_to_Blank_Map (From : Wide_Character) return Wide_Character; + + end CXA40140; + + package body CXA40140 is + + function US_to_Blank_Map (From : Wide_Character) return Wide_Character is + begin + if From = UnderScore then + return Blank; + else + return From; + end if; + end US_to_Blank_Map; + + end CXA40140; + + + with CXA40140; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Maps; + with Report; + + procedure CXA4014 is + use CXA40140; + begin + + Report.Test ("CXA4014", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Fixed are available, and that " & + "they produce correct results"); + + Test_Block: + declare + + Number_Of_Info_Strings : constant Natural := 3; + DB_Size : constant Natural := Number_Of_Info_Strings; + Count : Natural := 0; + Finished_Processing : Boolean := False; + Blank_Wide_String : constant Wide_String := " "; + + subtype Info_Wide_String_Type is Wide_String (1..50); + type Info_Wide_String_Storage_Type is + array (1..Number_Of_Info_Strings) of Info_Wide_String_Type; + + + subtype Name_Type is Wide_String (1..10); + subtype Street_Number_Type is Wide_String (1..5); + subtype Street_Name_Type is Wide_String (1..10); + subtype City_Type is Wide_String (1..10); + subtype State_Type is Wide_String (1..2); + subtype Zip_Code_Type is Wide_String (1..5); + + type Data_Base_Element_Type is + record + Name : Name_Type := (others => ' '); + Street_Number : Street_Number_Type := (others => ' '); + Street_Name : Street_Name_Type := (others => ' '); + City : City_Type := (others => ' '); + State : State_Type := (others => ' '); + Zip_Code : Zip_Code_Type := (others => ' '); + end record; + + type Data_Base_Type is array (1..DB_Size) of Data_Base_Element_Type; + + Data_Base : Data_Base_Type; + + --- + + Info_String_1 : Info_Wide_String_Type := + "Joe_Jones 123 Sixth_St San_Diego CA 98765"; + + Info_String_2 : Info_Wide_String_Type := + "Sam_Smith 56789 S._Seventh Carlsbad CA 92177"; + + Info_String_3 : Info_Wide_String_Type := + "Jane_Brown 1219 Info_Lane Tuscon AZ 85643"; + + + Info_Strings : Info_Wide_String_Storage_Type := + (1 => Info_String_1, + 2 => Info_String_2, + 3 => Info_String_3); + + + + TC_DB_Element_1 : Data_Base_Element_Type := + ("Joe Jones ", "123 ", "Sixth St ", "San Diego ", "CA", "98765"); + + TC_DB_Element_2 : Data_Base_Element_Type := + ("Sam Smith ", "56789", "S. Seventh", "Carlsbad ", "CA", "92177"); + + TC_DB_Element_3 : Data_Base_Element_Type := + ("Jane Brown", "1219 ", "Info Lane ", "Tuscon ", "AZ", "85643"); + + TC_Data_Base : Data_Base_Type := (TC_DB_Element_1, + TC_DB_Element_2, + TC_DB_Element_3); + + --- + + + procedure Store_Information + (Info_String : in Info_Wide_String_Type; + DB_Record : in out Data_Base_Element_Type) is + + package AS renames Ada.Strings; + use type AS.Wide_Maps.Wide_Character_Set; + + Start, + Stop : Natural := 0; + + Numeric_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("0123456789"); + + Cal : constant + AS.Wide_Maps.Wide_Character_Sequence := "CA"; + California_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set(Cal); + Arizona_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("AZ"); + Nevada_Set : constant AS.Wide_Maps.Wide_Character_Set := + AS.Wide_Maps.To_Set("NV"); + + Blank_Ftn_Ptr : AS.Wide_Maps.Wide_Character_Mapping_Function := + US_to_Blank_Map'Access; + + begin + + -- Find the starting position of the name field (first non-blank), + -- then, from that position, find the end of the name field (first + -- blank). + + Start := AS.Wide_Fixed.Index_Non_Blank(Info_String); + Stop := AS.Wide_Fixed.Index (Info_String(Start..Info_String'Length), + AS.Wide_Maps.To_Set(Blank), + AS.Inside, + AS.Forward) - 1 ; + + -- Store the name field in the data base element field for "Name". + + DB_Record.Name := AS.Wide_Fixed.Head(Info_String(1..Stop), + DB_Record.Name'Length); + + -- Replace any underscore characters in the name field + -- that were used to separate first/middle/last names. + -- Use the overloaded version of Translate that takes an + -- access-to-subprogram value. + + AS.Wide_Fixed.Translate (DB_Record.Name, Blank_Ftn_Ptr); + + + -- Continue the extraction process; now find the position of + -- the street number in the string. + + Start := Stop + 1; + + AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), + Numeric_Set, + AS.Inside, + Start, + Stop); + + -- Store the street number field in the appropriate data base + -- element. + -- No modification of the default parameters of procedure Move + -- is required. + + AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.Street_Number); + + + -- Continue the extraction process; find the street name in the + -- info string. Skip blanks to the start of the street name, then + -- search for the index of the next blank character in the string. + + Start := AS.Wide_Fixed.Index_Non_Blank + (Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), + Blank_Wide_String) - 1; + + -- Store the street name in the appropriate data base element field. + + AS.Wide_Fixed.Overwrite(DB_Record.Street_Name, + 1, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the street name field + -- that were used as word separation with blanks. Again, use the + -- access-to-subprogram value to provide the mapping. + + DB_Record.Street_Name := + AS.Wide_Fixed.Translate(DB_Record.Street_Name, + Blank_Ftn_Ptr); + + + -- Continue the extraction; remove the city name from the string. + + Start := AS.Wide_Fixed.Index_Non_Blank + (Info_String(Stop+1..Info_String'Length)); + + Stop := + AS.Wide_Fixed.Index(Info_String(Start..Info_String'Length), + Blank_Wide_String) - 1; + + -- Store the city name field in the appropriate data base element. + + AS.Wide_Fixed.Replace_Slice(DB_Record.City, + 1, + DB_Record.City'Length, + Info_String(Start..Stop)); + + -- Replace any underscore characters in the city name field + -- that were used as word separation. + + AS.Wide_Fixed.Translate (DB_Record.City, + Blank_Ftn_Ptr); + + + -- Continue the extraction; remove the state identifier from the + -- info string. + + Start := Stop + 1; + + AS.Wide_Fixed.Find_Token(Info_String(Start..Info_String'Length), + AS.Wide_Maps."OR"(California_Set, + AS.Wide_Maps."OR"(Nevada_Set, + Arizona_Set)), + AS.Inside, + Start, + Stop); + + -- Store the state indicator into the data base element. + + AS.Wide_Fixed.Move(Source => Info_String(Start..Stop), + Target => DB_Record.State, + Drop => Ada.Strings.Right, + Justify => Ada.Strings.Left, + Pad => AS.Wide_Space); + + + -- Continue the extraction process; remove the final data item in + -- the info string, the zip code, and place it into the + -- corresponding data base element. + + DB_Record.Zip_Code := + AS.Wide_Fixed.Tail(Info_String, DB_Record.Zip_Code'Length); + + exception + when AS.Length_Error => + Report.Failed ("Length_Error raised in procedure"); + when AS.Pattern_Error => + Report.Failed ("Pattern_Error raised in procedure"); + when AS.Translation_Error => + Report.Failed ("Translation_Error raised in procedure"); + when others => + Report.Failed ("Exception raised in procedure"); + end Store_Information; + + + begin + + -- Loop thru the information strings, extract the name and address + -- information, place this info into elements of the data base. + + while not Finished_Processing loop + + Count := Count + 1; + + Store_Information (Info_Strings(Count), Data_Base(Count)); + + Finished_Processing := (Count = Number_Of_Info_Strings); + + end loop; + + + -- Verify that the string processing was successful. + + for i in 1..DB_Size loop + if Data_Base(i) /= TC_Data_Base(i) then + Report.Failed + ("Data processing error on record " & Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4015.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,580 ---- + -- CXA4015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Fixed + -- are available, and that they produce correct results. Specifically, + -- check the subprograms Count, Find_Token, Index, Index_Non_Blank, and + -- Move. + -- + -- TEST DESCRIPTION: + -- This test, when combined with tests CXA4013,14,16 will provide + -- coverage of the functionality found in Ada.Strings.Wide_Fixed. + -- This test contains many small, specific test cases, situations that + -- although common in user environments, are often difficult to generate + -- in large numbers in a application-based test. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 02 Nov 95 SAIC Corrected various accesssibility problems and + -- expected result strings for ACVC 2.0.1. + -- + --! + + package CXA40150 is + + -- Wide Character mapping function defined for use with specific + -- versions of functions Index and Count. + + function AK_to_ZQ_Mapping (From : Wide_Character) return Wide_Character; + + end CXA40150; + + package body CXA40150 is + + function AK_to_ZQ_Mapping (From : Wide_Character) + return Wide_Character is + begin + if From = 'a' then + return 'z'; + elsif From = 'k' then + return 'q'; + else + return From; + end if; + end AK_to_ZQ_Mapping; + + end CXA40150; + + + with CXA40150; + with Report; + with Ada.Strings; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Maps; + + procedure CXA4015 is + begin + + Report.Test("CXA4015", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Fixed are available, " & + "and that they produce correct results"); + + + Test_Block: + declare + + use CXA40150; + + package ASF renames Ada.Strings.Wide_Fixed; + package Maps renames Ada.Strings.Wide_Maps; + + Result_String : Wide_String(1..10) := + (others => Ada.Strings.Wide_Space); + + Source_String1 : Wide_String(1..5) := "abcde"; -- odd len Wide_String + Source_String2 : Wide_String(1..6) := "abcdef"; -- even len Wide_String + Source_String3 : Wide_String(1..12) := "abcdefghijkl"; + Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last 2 ch pad + Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first 2 ch pad + Source_String6 : Wide_String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); + ABCD_Set : Maps.Wide_Character_Set := Maps.To_Set("abcd"); + A_to_F_Set : Maps.Wide_Character_Set := Maps.To_Set("abcdef"); + + CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + + -- Access-to-Subprogram object defined for use with specific versions of + -- functions Index and Count. + + Map_Ptr : Maps.Wide_Character_Mapping_Function := + AK_to_ZQ_Mapping'Access; + + + begin + + + -- Procedure Move + -- Evaluate the Procedure Move with various combinations of + -- parameters. + + -- Justify = Left (default case) + + ASF.Move(Source => Source_String1, -- "abcde" + Target => Result_String); + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Move with Justify = Left"); + end if; + + -- Justify = Right + + ASF.Move(Source => Source_String2, -- "abcdef" + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Move with Justify = Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASF.Move(Source_String1, -- "abcde" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result from Move with Justify = Center-1"); + end if; + + ASF.Move(Source_String2, -- "abcdef" + Result_String, + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Move with Justify = Center-2"); + end if; + + -- When the source Wide_String is longer than the target Wide_String, + -- several cases can be examined, with the results depending on the + -- value of the Drop parameter. + + -- Drop = Left + + ASF.Move(Source => Source_String3, -- "abcdefghijkl" + Target => Result_String, + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Move with Drop = Left"); + end if; + + -- Drop = Right + + ASF.Move(Source_String3, Result_String, Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result from Move with Drop = Right"); + end if; + + -- Drop = Error + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASF.Move(Source => Source_String4, -- "abcdefghij " + Target => Result_String, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASF.Move(Source_String5, -- " cdefghijkl" + Result_String, + Ada.Strings.Error, + Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result from Move with Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASF.Move(Source_String3, -- 12 characters, no Pad. + Result_String, -- 10 characters + Ada.Strings.Error, + Ada.Strings.Left); + + Report.Failed("Length_Error not raised by Move - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception raised by Move - 1"); + end; + + + + -- Function Index + -- (Other usage examples of this function found in CXA4013-14.) + -- Check when the pattern is not found in the source. + + if ASF.Index("abcdef", "gh") /= 0 or + ASF.Index("abcde", "abcdef") /= 0 or -- pattern > source + ASF.Index("xyz", + "abcde", + Ada.Strings.Backward) /= 0 or + ASF.Index("", "ab") /= 0 or -- null source Wide_String. + ASF.Index("abcde", " ") /= 0 -- blank pattern. + then + Report.Failed("Incorrect result from Index, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is the + -- null Wide_String. + begin + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "", -- null pattern Wide_String. + Ada.Strings.Forward); + Report.Failed("Pattern_Error not raised by Index"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Index, null pattern"); + end; + + -- Use the search direction "backward" to locate the particular + -- pattern within the source Wide_String. + + Location := ASF.Index(Source_String6, -- "abcdefabcdef" + "de", -- slice 4..5, 10..11 + Ada.Strings.Backward); -- search from right end. + + if Location /= 10 then + Report.Failed("Incorrect result from Index going Backward"); + end if; + + + + -- Function Index + -- Use the version of Index that takes a Wide_Character_Mapping_Function + -- parameter. + -- Use the search directions Forward and Backward to locate the + -- particular pattern wide string within the source wide string. + + Location := ASF.Index("akzqefakzqef", + "qzq", -- slice 8..10 + Ada.Strings.Backward, + Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' + -- translation. + if Location /= 8 then + Report.Failed + ("Incorrect result from Index w/map ptr going Backward"); + end if; + + Location := ASF.Index("ddkkddakcdakdefcadckdfzaaqd", + "zq", -- slice 7..8 + Ada.Strings.Forward, + Map_Ptr); -- perform 'a' to 'z', 'k' to 'q' + -- translation. + if Location /= 7 then + Report.Failed + ("Incorrect result from Index w/map ptr going Forward"); + end if; + + + if ASF.Index("aakkzq", "zq", Ada.Strings.Forward, Map_Ptr) /= 2 or + ASF.Index("qzedka", "qz", Ada.Strings.Backward, Map_Ptr) /= 5 or + ASF.Index("zazaza", "zzzz", Ada.Strings.Backward, Map_Ptr) /= 3 or + ASF.Index("kka", "qqz", Ada.Strings.Forward, Map_Ptr) /= 1 + then + Report.Failed("Incorrect result from Index w/map ptr"); + end if; + + + -- Check when the pattern wide string is not found in the source. + + if ASF.Index("akzqef", "kzq", Ada.Strings.Forward, Map_Ptr) /= 0 or + ASF.Index("abcde", "abcdef", Ada.Strings.Backward, Map_Ptr) /= 0 or + ASF.Index("xyz", "akzde", Ada.Strings.Backward, Map_Ptr) /= 0 or + ASF.Index("", "zq", Ada.Strings.Forward, Map_Ptr) /= 0 or + ASF.Index("akcde", " ", Ada.Strings.Backward, Map_Ptr) /= 0 + then + Report.Failed + ("Incorrect result from Index w/map ptr, no pattern match"); + end if; + + -- Check that Pattern_Error is raised when the pattern is a + -- null Wide_String. + begin + Location := ASF.Index("akzqefakqzef", + "", -- null pattern Wide_String. + Ada.Strings.Forward, + Map_Ptr); + Report.Failed("Pattern_Error not raised by Index w/map ptr"); + exception + when Ada.Strings.Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Index w/map ptr, null pattern"); + end; + + + + -- Function Index + -- Using the version of Index testing wide character set membership, + -- check combinations of forward/backward, inside/outside parameter + -- configurations. + + if ASF.Index(Source => Source_String1, -- "abcde" + Set => CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward) /= 3 or -- 'c' at pos 3. + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 12 or -- 'f' at position 12 + ASF.Index(Source_String6, -- "abcdefabcdef" + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Backward) /= 10 or -- 'd' at position 10 + ASF.Index("cdcdcdcdacdcdcdcd", + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Forward) /= 9 -- 'a' at position 9 + then + Report.Failed("Incorrect result from function Index for sets - 1"); + end if; + + -- Additional interesting uses/combinations using Index for sets. + + if ASF.Index("cd", -- same size, str-set + CD_Set, + Ada.Strings.Inside, + Ada.Strings.Forward) /= 1 or -- 'c' at position 1 + ASF.Index("abcd", -- same size, str-set, + Maps.To_Set("efgh"), -- different contents. + Ada.Strings.Outside, + Ada.Strings.Forward) /= 1 or + ASF.Index("abccd", -- set > Wide_String + Maps.To_Set("acegik"), + Ada.Strings.Inside, + Ada.Strings.Backward) /= 4 or -- 'c' at position 4 + ASF.Index("abcde", + Maps.Null_Set) /= 0 or + ASF.Index("", -- Null string. + CD_Set) /= 0 or + ASF.Index("abc ab", -- blank included + Maps.To_Set("e "), -- in Wide_String and + Ada.Strings.Inside, -- set. + Ada.Strings.Backward) /= 4 -- blank in Wide_Str. + then + Report.Failed("Incorrect result from function Index for sets - 2"); + end if; + + + + -- Function Index_Non_Blank. + -- (Other usage examples of this function found in CXA4013-14.) + + + if ASF.Index_Non_Blank(Source => Source_String4, -- "abcdefghij " + Going => Ada.Strings.Backward) /= 10 or + ASF.Index_Non_Blank("abc def ghi jkl ", + Ada.Strings.Backward) /= 15 or + ASF.Index_Non_Blank(" abcdef") /= 3 or + ASF.Index_Non_Blank(" ") /= 0 + then + Report.Failed("Incorrect result from Index_Non_Blank"); + end if; + + + + -- Function Count + -- (Other usage examples of this function found in CXA4013-14.) + + if ASF.Count("abababa", "aba") /= 2 or + ASF.Count("abababa", "ab" ) /= 3 or + ASF.Count("babababa", "ab") /= 3 or + ASF.Count("abaabaaba", "aba") /= 3 or + ASF.Count("xxxxxxxxxxxxxxxxxxxy", "xy") /= 1 or + ASF.Count("xxxxxxxxxxxxxxxxxxxx", "x") /= 20 + then + Report.Failed("Incorrect result from Function Count"); + end if; + + -- Determine the number of slices of Source that when mapped to a + -- non-identity map, match the pattern Wide_String. + + Slice_Count := ASF.Count(Source_String6, -- "abcdefabcdef" + "xy", + CD_to_XY_Map); -- maps 'c' to 'x', 'd' to 'y' + + if Slice_Count /= 2 then -- two slices "xy" in "mapped" Source_String6 + Report.Failed("Incorrect result from Count with non-identity map"); + end if; + + -- If the pattern supplied to Function Count is the null Wide_String, + -- then Pattern_Error is propagated. + declare + The_Null_Wide_String : constant Wide_String := ""; + begin + Slice_Count := ASF.Count(Source_String6, The_Null_Wide_String); + Report.Failed("Pattern_Error not raised by Function Count"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Count with null pattern"); + end; + + + + + -- Function Count + -- Use the version of Count that takes a Wide_Character_Mapping_Function + -- value as the basis of its source mapping. + + if ASF.Count("akakaka", "zqz", Map_Ptr) /= 2 or + ASF.Count("akakaka", "qz", Map_Ptr) /= 3 or + ASF.Count("kakakaka", "q", Map_Ptr) /= 4 or + ASF.Count("zzqaakzaqzzk", "zzq", Map_Ptr) /= 4 or + ASF.Count(" ", "z", Map_Ptr) /= 0 or + ASF.Count("", "qz", Map_Ptr) /= 0 or + ASF.Count("abbababab", "zq", Map_Ptr) /= 0 or + ASF.Count("aaaaaaaaaaaaaaaaaakk", "zqq", Map_Ptr) /= 1 or + ASF.Count("azaazaazzzaaaaazzzza", "z", Map_Ptr) /= 20 + then + Report.Failed("Incorrect result from Function Count w/map ptr"); + end if; + + -- If the pattern supplied to Function Count is a null Wide_String, + -- then Pattern_Error is propagated. + declare + The_Null_Wide_String : constant Wide_String := ""; + begin + Slice_Count := ASF.Count(Source_String6, + The_Null_Wide_String, + Map_Ptr); + Report.Failed + ("Pattern_Error not raised by Function Count w/map ptr"); + exception + when Ada.Strings.Pattern_Error => null; -- OK + when others => + Report.Failed + ("Incorrect exception from Count w/map ptr, null pattern"); + end; + + + + + -- Function Count returning the number of characters in a particular + -- set that are found in source Wide_String. + + if ASF.Count(Source_String6, CD_Set) /= 4 or -- 2 'c' and 'd' chars. + ASF.Count("cddaccdaccdd", CD_Set) /= 10 + then + Report.Failed("Incorrect result from Count with set"); + end if; + + + + -- Function Find_Token. + -- (Other usage examples of this function found in CXA4013-14.) + + ASF.Find_Token(Source => Source_String6, -- First slice with no + Set => ABCD_Set, -- 'a', 'b', 'c', or 'd' + Test => Ada.Strings.Outside, -- is "ef" at 5..6. + First => Slice_Start, + Last => Slice_End); + + if Slice_Start /= 5 or Slice_End /= 6 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + -- If no appropriate slice is contained by the source Wide_String, + -- then the value returned in Last is zero, and the value in First is + -- Source'First. + + ASF.Find_Token(Source_String6, -- "abcdefabcdef" + A_to_F_Set, -- Set of characters 'a' thru 'f'. + Ada.Strings.Outside, -- No characters outside this set. + Slice_Start, + Slice_End); + + if Slice_Start /= Source_String6'First or Slice_End /= 0 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + -- Additional testing of Find_Token. + + ASF.Find_Token("eabcdabcddcab", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 2 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + ASF.Find_Token("efghijklabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 8 then + Report.Failed("Incorrect result from Find_Token - 4"); + end if; + + ASF.Find_Token("abcdefgabcdabcd", + ABCD_Set, + Ada.Strings.Outside, + Slice_Start, + Slice_End); + + if Slice_Start /= 5 or Slice_End /= 7 then + Report.Failed("Incorrect result from Find_Token - 5"); + end if; + + ASF.Find_Token("abcdcbabcdcba", + ABCD_Set, + Ada.Strings.Inside, + Slice_Start, + Slice_End); + + if Slice_Start /= 1 or Slice_End /= 13 then + Report.Failed("Incorrect result from Find_Token - 6"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4016.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,685 ---- + -- CXA4016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Fixed + -- are available, and that they produce correct results. Specifically, + -- check the subprograms Delete, Head, Insert, Overwrite, Replace_Slice, + -- Tail, Trim, and "*". + -- + -- TEST DESCRIPTION: + -- This test, when combined with tests CXA4013-15 will provide + -- coverage of the functionality found in package Ada.Strings.Wide_Fixed. + -- This test contains many small, specific test cases, situations that + -- although common in user environments, are often difficult to generate + -- in large numbers in a application-based test. They represent + -- individual usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 10 Apr 94 SAIC Modified comments in a subtest failure message. + -- 06 Nov 95 SAIC Corrected subtest results for ACVC 2.0.1 + -- 14 Mar 01 RLB Added checks that the lower bound is 1, similar + -- to CXA4005. These changes were made to test + -- Defect Report 8652/0049, as reflected in + -- Technical Corrigendum 1. + -- + --! + + with Report; + with Ada.Strings; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Maps; + + procedure CXA4016 is + + type TC_Name_Holder is access String; + Name : TC_Name_Holder; + + function TC_Check (S : Wide_String) return Wide_String is + begin + if S'First /= 1 then + Report.Failed ("Lower bound of result of function " & Name.all & + " is" & Integer'Image (S'First)); + end if; + return S; + end TC_Check; + + procedure TC_Set_Name (N : String) is + begin + Name := new String'(N); + end TC_Set_Name; + + begin + + Report.Test("CXA4016", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Fixed are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package ASW renames Ada.Strings.Wide_Fixed; + package Wide_Maps renames Ada.Strings.Wide_Maps; + + Result_String, + Delete_String, + Insert_String, + Trim_String, + Overwrite_String : Wide_String(1..10) := + (others => Ada.Strings.Wide_Space); + Replace_String : Wide_String(10..30) := + (others => Ada.Strings.Wide_Space); + + Source_String1 : Wide_String(1..5) := "abcde"; -- odd len wd str + Source_String2 : Wide_String(1..6) := "abcdef"; -- even len wd str + Source_String3 : Wide_String(1..12) := "abcdefghijkl"; + Source_String4 : Wide_String(1..12) := "abcdefghij "; -- last two ch pad + Source_String5 : Wide_String(1..12) := " cdefghijkl"; -- first two ch pad + Source_String6 : Wide_String(1..12) := "abcdefabcdef"; + + Location : Natural := 0; + Slice_Start : Positive; + Slice_End, + Slice_Count : Natural := 0; + + CD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("cd"); + X_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set('x'); + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("abcd"); + A_to_F_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set("abcdef"); + + CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => "cd", To => "xy"); + + begin + + -- Procedure Replace_Slice + -- The functionality of this procedure is similar to procedure Move, + -- and is tested here in the same manner, evaluated with various + -- combinations of parameters. + + -- Index_Error propagation when Low > Source'Last + 1 + + begin + ASW.Replace_Slice(Result_String, + Result_String'Last + 2, -- should raise exception + Result_String'Last, + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 1"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 1"); + end; + + -- Index_Error propagation when High < Source'First - 1 + + begin + ASW.Replace_Slice(Replace_String(20..30), + Replace_String'First, + Replace_String'First - 2, -- should raise exception + "xxxxxxx"); + Report.Failed("Index_Error not raised by Replace_Slice - 2"); + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Replace_Slice - 2"); + end; + + -- Justify = Left (default case) + + Result_String := "XXXXXXXXXX"; + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => 10, + By => Source_String1); -- "abcde" + + if Result_String /= "abcde " then + Report.Failed("Incorrect result from Replace_Slice - Justify = Left"); + end if; + + -- Justify = Right + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String2, -- "abcdef" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= " abcdef" then + Report.Failed("Incorrect result from Replace_Slice - Justify=Right"); + end if; + + -- Justify = Center (two cases, odd and even pad lengths) + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String1, -- "abcde" + Ada.Strings.Error, + Ada.Strings.Center, + 'x'); -- non-default padding. + + if Result_String /= "xxabcdexxx" then -- Unequal padding added right + Report.Failed("Incorrect result, Replace_Slice - Justify=Center - 1"); + end if; + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String2, -- "abcdef" + Ada.Strings.Error, + Ada.Strings.Center); + + if Result_String /= " abcdef " then -- Equal padding added on L/R. + Report.Failed("Incorrect result from Replace_Slice with " & + "Justify = Center - 2"); + end if; + + -- When the source string is longer than the target string, several + -- cases can be examined, with the results depending on the value of + -- the Drop parameter. + + -- Drop = Left + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Left); + + if Result_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Replace_Slice - Drop=Left"); + end if; + + -- Drop = Right + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String3, -- "abcdefghijkl" + Ada.Strings.Right); + + if Result_String /= "abcdefghij" then + Report.Failed("Incorrect result, Replace_Slice with Drop=Right"); + end if; + + -- Drop = Error + + -- The effect in this case depends on the value of the justify + -- parameter, and on whether any characters in Source other than + -- Pad would fail to be copied. + + -- Drop = Error, Justify = Left, right overflow characters are pad. + + ASW.Replace_Slice(Result_String, + 1, + Result_String'Last, + Source_String4, -- "abcdefghij " + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Left); + + if not(Result_String = "abcdefghij") then -- leftmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 1"); + end if; + + -- Drop = Error, Justify = Right, left overflow characters are pad. + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String5, -- " cdefghijkl" + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right); + + if Result_String /= "cdefghijkl" then -- rightmost 10 characters + Report.Failed("Incorrect result, Replace_Slice - Drop = Error - 2"); + end if; + + -- In other cases of Drop=Error, Length_Error is propagated, such as: + + begin + + ASW.Replace_Slice(Source => Result_String, + Low => 1, + High => Result_String'Last, + By => Source_String3, -- "abcdefghijkl" + Drop => Ada.Strings.Error); + + Report.Failed("Length_Error not raised by Replace_Slice - 1"); + + exception + when Ada.Strings.Length_Error => null; -- OK + when others => + Report.Failed("Incorrect exception from Replace_Slice - 3"); + end; + + + -- Function Replace_Slice + + TC_Set_Name ("Replace_Slice"); + + if TC_Check (ASW.Replace_Slice("abcde", 3, 3, "x")) + /= "abxde" or -- High = Low + TC_Check (ASW.Replace_Slice("abc", 2, 3, "xyz")) /= "axyz" or + TC_Check (ASW.Replace_Slice("abcd", 4, 1, "xy")) + /= "abcxyd" or -- High < Low + TC_Check (ASW.Replace_Slice("abc", 2, 3, "x")) /= "ax" or + TC_Check (ASW.Replace_Slice("a", 1, 1, "z")) /= "z" + then + Report.Failed("Incorrect result from Function Replace_Slice - 1"); + end if; + + if TC_Check (ASW.Replace_Slice("abcde", 5, 5, "z")) + /= "abcdz" or -- By length 1 + TC_Check (ASW.Replace_Slice("abc", 1, 3, "xyz")) + /= "xyz" or -- High > Low + TC_Check (ASW.Replace_Slice("abc", 3, 2, "xy")) + /= "abxyc" or -- insert + TC_Check (ASW.Replace_Slice("a", 1, 1, "xyz")) /= "xyz" + then + Report.Failed("Incorrect result from Function Replace_Slice - 2"); + end if; + + + + -- Function Insert. + + TC_Set_Name ("Insert"); + + declare + New_String : constant Wide_String := + TC_Check ( + ASW.Insert(Source => Source_String1(2..5), -- "bcde" + Before => 2, + New_Item => Source_String2)); -- "abcdef" + begin + if New_String /= "abcdefbcde" then + Report.Failed("Incorrect result from Function Insert - 1"); + end if; + end; + + if TC_Check (ASW.Insert("a", 1, "z")) /= "za" or + TC_Check (ASW.Insert("abc", 3, "")) /= "abc" or + TC_Check (ASW.Insert("abc", 4, "z")) /= "abcz" + then + Report.Failed("Incorrect result from Function Insert - 2"); + end if; + + begin + if TC_Check (ASW.Insert(Source => Source_String1(2..5), -- "bcde" + Before => Report.Ident_Int(7), + New_Item => Source_String2)) -- "abcdef" + /= "babcdefcde" then + Report.Failed("Index_Error not raised by Insert - 3A"); + else + Report.Failed("Index_Error not raised by Insert - 3B"); + end if; + exception + when Ada.Strings.Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception from Insert - 3"); + end; + + + -- Procedure Insert + + -- Drop = Right + + ASW.Insert(Source => Insert_String, + Before => 6, + New_Item => Source_String2, -- "abcdef" + Drop => Ada.Strings.Right); + + if Insert_String /= " abcde" then -- last char of New_Item dropped. + Report.Failed("Incorrect result from Insert with Drop = Right"); + end if; + + -- Drop = Left + + ASW.Insert(Source => Insert_String, -- 10 char string + Before => 2, -- 9 chars, 2..10 available + New_Item => Source_String3, -- 12 characters long. + Drop => Ada.Strings.Left); -- truncate from Left. + + if Insert_String /= "l abcde" then -- 10 chars, leading blank. + Report.Failed("Incorrect result from Insert with Drop=Left"); + end if; + + -- Drop = Error + + begin + ASW.Insert(Source => Result_String, -- 10 chars + Before => Result_String'Last, + New_Item => "abcdefghijk", + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Insert"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + + + -- Function Overwrite + + TC_Set_Name ("Overwrite"); + + Overwrite_String := TC_Check ( + ASW.Overwrite(Result_String, -- 10 chars + 1, -- starting at pos=1 + Source_String3(1..10))); + + if Overwrite_String /= Source_String3(1..10) then + Report.Failed("Incorrect result from Function Overwrite - 1"); + end if; + + + if TC_Check (ASW.Overwrite("abcdef", 4, "xyz")) /= "abcxyz" or + TC_Check (ASW.Overwrite("a", 1, "xyz")) + /= "xyz" or -- chars appended + TC_Check (ASW.Overwrite("abc", 3, " ")) + /= "ab " or -- blanks appended + TC_Check (ASW.Overwrite("abcde", 1, "z" )) /= "zbcde" + then + Report.Failed("Incorrect result from Function Overwrite - 2"); + end if; + + + + -- Procedure Overwrite, with truncation. + + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Left); + + if Overwrite_String /= "cdefghijkl" then + Report.Failed("Incorrect result from Overwrite with Drop=Left"); + end if; + + -- The default drop value is Right, used here. + + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3); -- 12 characters. + + if Overwrite_String /= "abcdefghij" then + Report.Failed("Incorrect result from Overwrite with Drop=Right"); + end if; + + -- Drop = Error + + begin + ASW.Overwrite(Source => Overwrite_String, -- 10 characters. + Position => 1, + New_Item => Source_String3, -- 12 characters. + Drop => Ada.Strings.Error); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when Ada.Strings.Length_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Overwrite"); + end; + + Overwrite_String := "ababababab"; + ASW.Overwrite(Overwrite_String, Overwrite_String'Last, "z"); + ASW.Overwrite(Overwrite_String, Overwrite_String'First,"z"); + ASW.Overwrite(Overwrite_String, 5, "zz"); + + if Overwrite_String /= "zbabzzabaz" then + Report.Failed("Incorrect result from Procedure Overwrite"); + end if; + + + + -- Function Delete + + TC_Set_Name ("Delete"); + + declare + New_String1 : constant Wide_String := -- Returns a 4 char wide str. + TC_Check (ASW.Delete(Source => Source_String3, + From => 3, + Through => 10)); + New_String2 : constant Wide_String := -- This returns Source. + TC_Check (ASW.Delete(Source_String3, 10, 3)); + begin + if New_String1 /= "abkl" or + New_String2 /= Source_String3 + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + end; + + if TC_Check (ASW.Delete("a", 1, 1)) + /= "" or -- Source length = 1 + TC_Check (ASW.Delete("abc", 1, 2)) + /= "c" or -- From = Source'First + TC_Check (ASW.Delete("abc", 3, 3)) + /= "ab" or -- From = Source'Last + TC_Check (ASW.Delete("abc", 3, 1)) + /= "abc" -- From > Through + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Procedure Delete + + -- Justify = Left + + Delete_String := Source_String3(1..10); -- Initialize to "abcdefghij" + + ASW.Delete(Source => Delete_String, + From => 6, + Through => Delete_String'Last, + Justify => Ada.Strings.Left, + Pad => 'x'); -- pad with char 'x' + + if Delete_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Delete - Justify = Left"); + end if; + + -- Justify = Right + + ASW.Delete(Source => Delete_String, -- Remove x"s from end and + From => 6, -- shift right. + Through => Delete_String'Last, + Justify => Ada.Strings.Right, + Pad => 'x'); -- pad with char 'x' on left. + + if Delete_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Delete - Justify = Right"); + end if; + + -- Justify = Center + + ASW.Delete(Source => Delete_String, + From => 1, + Through => 5, + Justify => Ada.Strings.Center, + Pad => 'z'); + + if Delete_String /= "zzabcdezzz" then -- extra pad char on right side. + Report.Failed("Incorrect result from Delete - Justify = Center"); + end if; + + + + -- Function Trim + -- Use non-identity character sets to perform the trim operation. + + TC_Set_Name ("Trim"); + + Trim_String := "cdabcdefcd"; + + -- Remove the "cd" from each end of the string. This will not effect + -- the "cd" slice at 5..6. + + declare + New_String : constant Wide_String := + TC_Check (ASW.Trim(Source => Trim_String, + Left => CD_Set, Right => CD_Set)); + begin + if New_String /= Source_String2 then -- string "abcdef" + Report.Failed + ("Incorrect result from Trim with wide character sets"); + end if; + end; + + if TC_Check (ASW.Trim("abcdef", Wide_Maps.Null_Set, Wide_Maps.Null_Set)) + /= "abcdef" then + Report.Failed("Incorrect result from Trim with Null sets"); + end if; + + if TC_Check (ASW.Trim("cdxx", CD_Set, X_Set)) /= "" then + Report.Failed("Incorrect result from Trim, wide string removal"); + end if; + + + -- Procedure Trim + + -- Justify = Right + + ASW.Trim(Source => Trim_String, + Left => CD_Set, + Right => CD_Set, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxabcdef" then + Report.Failed("Incorrect result from Trim with Justify = Right"); + end if; + + -- Justify = Left + + ASW.Trim(Source => Trim_String, + Left => X_Set, + Right => Wide_Maps.Null_Set, + Justify => Ada.Strings.Left, + Pad => ' '); + + if Trim_String /= "abcdef " then -- Padded with 4 blanks on right. + Report.Failed("Incorrect result from Trim with Justify = Left"); + end if; + + -- Justify = Center + + ASW.Trim(Source => Trim_String, + Left => ABCD_Set, + Right => CD_Set, + Justify => Ada.Strings.Center, + Pad => 'x'); + + if Trim_String /= "xxef xx" then -- Padded with 4 pad chars on L/R + Report.Failed("Incorrect result from Trim with Justify = Center"); + end if; + + + + -- Function Head, testing use of padding. + + TC_Set_Name ("Head"); + + -- Use the wide characters of Source_String1 ("abcde") and pad the + -- last five wide characters of Result_String with 'x' wide characters. + + Result_String := TC_CHeck (ASW.Head(Source_String1, 10, 'x')); + + if Result_String /= "abcdexxxxx" then + Report.Failed("Incorrect result from Function Head with padding"); + end if; + + if TC_Check (ASW.Head(" ab ", 2)) /= " " or + TC_Check (ASW.Head("a", 6, 'A')) /= "aAAAAA" or + TC_Check (ASW.Head(ASW.Head("abc ", 7, 'x'), 10, 'X')) + /= "abc xxXXX" + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail, testing use of padding. + + TC_Set_Name ("Tail"); + + -- Use the wide characters of Source_String1 ("abcde") and pad the + -- first five wide characters of Result_String with 'x' wide characters. + + Result_String := TC_Check (ASW.Tail(Source_String1, 10, 'x')); + + if Result_String /= "xxxxxabcde" then + Report.Failed("Incorrect result from Function Tail with padding"); + end if; + + if TC_Check (ASW.Tail("abcde ", 5)) + /= "cde " or -- blanks, back + TC_Check (ASW.Tail(" abc ", 8, ' ')) + /= " abc " or -- blanks, front/back + TC_Check (ASW.Tail("", 5, 'Z')) + /= "ZZZZZ" or -- pad characters only + TC_Check (ASW.Tail("abc", 0)) + /= "" or -- null result + TC_Check (ASW.Tail(ASW.Tail(" abc ", 6, 'x'), + 10, + 'X')) /= "XXXXx abc " + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function "*" - with (Natural, Wide_String) parameters + + TC_Set_Name ("""*"""); + + if TC_Check (ASW."*"(3, Source_String1)) /= "abcdeabcdeabcde" or + TC_Check (ASW."*"(2, Source_String2)) /= Source_String6 or + TC_Check (ASW."*"(4, Source_String1(1..2))) /= "abababab" or + TC_Check (ASW."*"(0, Source_String1)) /= "" + then + Report.Failed + ("Incorrect result from Function ""*"" with wide strings"); + end if; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4017.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,337 ---- + -- CXA4017.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Bounded + -- are available, and that they produce correct results. Specifically, + -- check the subprograms Append, Delete, Index, Insert , Length, + -- Overwrite, Replace_Slice, Slice, "&", To_Bounded_Wide_String, + -- To_Wide_String, Translate, and Trim. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of a variety of the Wide_String + -- functions found in the package Ada.Strings.Wide_Bounded, simulating + -- the operations found in a text processing environment. + -- With bounded wide strings, the length of each "line" of text can vary + -- up to the instantiated maximum, allowing one to view a page of text as + -- a series of expandable lines. This provides flexibility in text + -- formatting of individual lines (wide strings). + -- Several subprograms are defined, all of which attempt to take + -- advantage of as many different bounded wide string utilities as + -- possible. Often, an operation that is being performed in a subprogram + -- using a certain bounded wide string utility could more efficiently be + -- performed using a different utility. However, in the interest of + -- including as broad coverage as possible, a mixture of utilities is + -- invoked in this test. + -- A simulated page of text is provided as a parameter to the test + -- defined subprograms, and the appropriate processing performed. The + -- processed page of text is then compared to a predefined "finished" + -- page, and test passage/failure is based on the results of this + -- comparison. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 06 Nov 95 SAIC Corrected initialization error for ACVC 2.0.1. + -- + --! + + with Ada.Strings; + with Ada.Strings.Wide_Bounded; + with Ada.Strings.Wide_Maps; + with Report; + + procedure CXA4017 is + + begin + + Report.Test ("CXA4017", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Bounded are available, and " & + "that they produce correct results"); + + Test_Block: + declare + + Characters_Per_Line : constant Positive := 40; + Lines_Per_Page : constant Natural := 4; + + + package BS_40 is new + Ada.Strings.Wide_Bounded.Generic_Bounded_Length(Characters_Per_Line); + + use type BS_40.Bounded_Wide_String; + + type Page_Type is array (1..Lines_Per_Page) of + BS_40.Bounded_Wide_String; + + -- Note: Misspellings below are intentional. + + Line1 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String + ("ada is a progrraming language designed"); + Line2 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("to support the construction of long-"); + Line3 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("lived, highly reliabel software "); + Line4 : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("systems"); + + Page : Page_Type := (1 => Line1, 2 => Line2, 3 => Line3, 4 => Line4); + + Finished_Page : Page_Type := + (BS_40.To_Bounded_Wide_String + ("Ada is a programming language designed"), + BS_40.To_Bounded_Wide_String("to support the construction of long-"), + BS_40.To_Bounded_Wide_String + ("lived, HIGHLY RELIABLE software systems."), + BS_40.To_Bounded_Wide_String("")); + + --- + + procedure Compress (Page : in out Page_Type) is + Clear_Line : Natural := Lines_Per_Page; + begin + -- If two consecutive lines on the page are together less than the + -- maximum line length, then append those two lines, move up all + -- lower lines on the page, and blank out the last line. + -- This algorithm works one time through the page, does not perform + -- repetitive compression, and is designed for use with this test + -- program only. + for i in 1..Lines_Per_Page - 1 loop + if BS_40.Length(Page(i)) + BS_40.Length(Page(i+1)) <= + BS_40.Max_Length + then + Page(i) := BS_40."&"(Page(i), + Page(i+1)); -- "&" (wd bnd, wd bnd) + + for j in i+1..Lines_Per_Page - 1 loop + Page(j) := + BS_40.To_Bounded_Wide_String + (BS_40.Slice(Page(j+1), + 1, + BS_40.Length(Page(j+1)))); + Clear_Line := j + 1; + end loop; + Page(Clear_Line) := BS_40.Null_Bounded_Wide_String; + end if; + end loop; + end Compress; + + --- + + procedure Format (Page : in out Page_Type) is + Sm_Ada : BS_40.Bounded_Wide_String := + BS_40.To_Bounded_Wide_String("ada"); + Cap_Ada : constant Wide_String := "Ada"; + Char_Pos : Natural := 0; + Finished : Boolean := False; + Line : Natural := Page_Type'Last; + begin + + -- Add a period to the end of the last line. + while Line >= Page_Type'First and not Finished loop + if Page(Line) /= BS_40.Null_Bounded_Wide_String and + BS_40.Length(Page(Line)) <= BS_40.Max_Length + then + Page(Line) := BS_40.Append(Page(Line), '.'); + Finished := True; + end if; + Line := Line - 1; + end loop; + + -- Replace all occurrences of "ada" with "Ada". + for Line in Page_Type'First .. Page_Type'Last loop + Finished := False; + while not Finished loop + Char_Pos := + BS_40.Index (Source => Page(Line), + Pattern => BS_40.To_Wide_String(Sm_Ada), + Going => Ada.Strings.Backward); + -- A zero is returned by function Index if no occurrences of + -- the pattern wide string are found. + Finished := (Char_Pos = 0); + if not Finished then + BS_40.Replace_Slice + (Source => Page(Line), + Low => Char_Pos, + High => Char_Pos + BS_40.Length(Sm_Ada) - 1, + By => Cap_Ada); + end if; + end loop; -- while loop + end loop; -- for loop + + end Format; + + --- + + procedure Spell_Check (Page : in out Page_Type) is + type Spelling_Type is (Incorrect, Correct); + type Word_Array_Type is array (Spelling_Type) + of BS_40.Bounded_Wide_String; + type Dictionary_Type is array (1..2) of Word_Array_Type; + + -- Note that the "words" in the dictionary will require various + -- amounts of Trimming prior to their use in the bounded wide string + -- functions. + Dictionary : Dictionary_Type := + (1 => (BS_40.To_Bounded_Wide_String(" reliabel "), + BS_40.To_Bounded_Wide_String(" reliable ")), + 2 => (BS_40.To_Bounded_Wide_String(" progrraming "), + BS_40.To_Bounded_Wide_String(" programming "))); + + Pos : Natural := Natural'First; + Finished : Boolean := False; + + begin + + for Line in Page_Type'Range loop + + -- Search for the first incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Overwrite function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(1)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + Finished := (Pos = 0); + if not Finished then + Page(Line) := + BS_40.Overwrite(Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(1)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + -- Search for the second incorrectly spelled word in the + -- Dictionary, if it is found, replace it with the correctly + -- spelled word, using the Delete procedure and Insert function. + + while not Finished loop + Pos := + BS_40.Index(Page(Line), + BS_40.To_Wide_String( + BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both)), + Ada.Strings.Forward); + + Finished := (Pos = 0); + + if not Finished then + BS_40.Delete + (Page(Line), + Pos, + Pos + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(2)(Incorrect), + Ada.Strings.Both))'Length-1); + Page(Line) := + BS_40.Insert(Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Trim(Dictionary(2)(Correct), + Ada.Strings.Both))); + end if; + end loop; + + Finished := False; + + end loop; + end Spell_Check; + + --- + + procedure Bold (Page : in out Page_Type) is + Key_Word : constant Wide_String := "highly reliable"; + Bold_Mapping : constant + Ada.Strings.Wide_Maps.Wide_Character_Mapping := + Ada.Strings.Wide_Maps.To_Mapping + (From => " abcdefghijklmnopqrstuvwxyz", + To => " ABCDEFGHIJKLMNOPQRSTUVWXYZ"); + Pos : Natural := Natural'First; + Finished : Boolean := False; + begin + -- This procedure is designed to change the case of the phrase + -- "highly reliable" into upper case (a type of "Bolding"). + -- All instances of the phrase on all lines of the page will be + -- modified. + + for Line in Page_Type'First .. Page_Type'Last loop + while not Finished loop + Pos := BS_40.Index(Page(Line), Key_Word); + Finished := (Pos = 0); + if not Finished then + + BS_40.Overwrite + (Page(Line), + Pos, + BS_40.To_Wide_String + (BS_40.Translate + (BS_40.To_Bounded_Wide_String + (BS_40.Slice(Page(Line), + Pos, + Pos + Key_Word'Length - 1)), + Bold_Mapping))); + + end if; + end loop; + Finished := False; + end loop; + end Bold; + + + begin + + Compress(Page); + Format(Page); + Spell_Check(Page); + Bold(Page); + + for i in 1..Lines_Per_Page loop + if BS_40.To_Wide_String(Page(i)) /= + BS_40.To_Wide_String(Finished_Page(i)) or + BS_40.Length(Page(i)) /= + BS_40.Length(Finished_Page(i)) + then + Report.Failed("Incorrect modification of Page, Line " & + Integer'Image(i)); + end if; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4017; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4018.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,379 ---- + -- CXA4018.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package + -- Ada.Strings.Wide_Bounded are available, and that they produce + -- correct results. Specifically, check the subprograms Append, + -- Count, Element, Find_Token, Head, Index_Non_Blank, Replace_Element, + -- Replicate, Tail, To_Bounded_Wide_String, "&", ">", "<", ">=", "<=", + -- and "*". + -- + -- TEST DESCRIPTION: + -- This test, when taken in conjunction with test CXA40[17,19,20], will + -- constitute a test of all the functionality contained in package + -- Ada.Strings.Wide_Bounded. This test uses a variety of the + -- subprograms defined in the wide bounded string package in ways typical + -- of common usage. Different combinations of available subprograms + -- are used to accomplish similar wide bounded string processing goals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. + -- 06 Nov 95 SAIC Corrected evaluation string used in Head/Tail + -- subtests for ACVC 2.0.1. + -- + --! + + with Ada.Strings; + with Ada.Strings.Wide_Bounded; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + with Report; + + procedure CXA4018 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. Blanks are translated to Wide_Character + -- blanks and all other characters are translated into Wide_Characters with + -- position values 256 greater than their (narrow) character position + -- values. + + function Translate (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Translate; + + function Translate (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Translate(Str(i)); + end loop; + return WS; + end Translate; + + + begin + + Report.Test ("CXA4018", "Check that the subprograms defined in package " & + "Ada.Strings.Wide_Bounded are available, and " & + "that they produce correct results"); + + Test_Block: + declare + + package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); + use type BS80.Bounded_Wide_String; + + Part1 : constant Wide_String := Translate("Rum"); + Part2 : Wide_Character := Translate('p'); + Part3 : BS80.Bounded_Wide_String := + BS80.To_Bounded_Wide_String(Translate("el")); + Part4 : Wide_Character := Translate('s'); + Part5 : BS80.Bounded_Wide_String := + BS80.To_Bounded_Wide_String(Translate("tilt")); + Part6 : Wide_String(1..3) := Translate("ski"); + + Full_Catenate_String, + Full_Append_String, + Constructed_String, + Drop_String, + Replicated_String, + Token_String : BS80.Bounded_Wide_String; + + CharA : Wide_Character := Translate('A'); + CharB : Wide_Character := Translate('B'); + CharC : Wide_Character := Translate('C'); + CharD : Wide_Character := Translate('D'); + CharE : Wide_Character := Translate('E'); + CharF : Wide_Character := Translate('F'); + + ABStr : Wide_String(1..15) := Translate("AAAAABBBBBBBBBB"); + StrB : Wide_String(1..2) := Translate("BB"); + StrE : Wide_String(1..2) := Translate("EE"); + + + begin + + -- Evaluation of the overloaded forms of the "&" operator. + + Full_Catenate_String := + BS80."&"(Part2, -- WChar & Bnd WStr + BS80."&"(Part3, -- Bnd WStr & Bnd WStr + BS80."&"(Part4, -- WChar & Bnd WStr + BS80."&"(Part5, -- Bnd WStr & Bnd WStr + BS80.To_Bounded_Wide_String + (Part6))))); + + Full_Catenate_String := + BS80."&"(Part1, Full_Catenate_String); -- WStr & Bnd WStr + Full_Catenate_String := + BS80."&"(Left => Full_Catenate_String, + Right => Translate('n')); -- Bnd WStr & WChar + + + -- Evaluation of the overloaded forms of function Append. + + Full_Append_String := + BS80.Append(Part2, -- WChar,Bnd WStr + BS80.Append(Part3, -- Bnd WStr, Bnd WStr + BS80.Append(Part4, -- WChar,Bnd WStr + BS80.Append(BS80.To_Wide_String(Part5), -- WStr,Bnd WStr + BS80.To_Bounded_Wide_String(Part6))))); + + Full_Append_String := + BS80.Append(BS80.To_Bounded_Wide_String(Part1), -- Bnd WStr, WStr + BS80.To_Wide_String(Full_Append_String)); + + Full_Append_String := + BS80.Append(Left => Full_Append_String, + Right => Translate('n')); -- Bnd WStr, WChar + + + -- Validate the resulting bounded wide strings. + + if BS80."<"(Full_Catenate_String, Full_Append_String) or + BS80.">"(Full_Catenate_String, Full_Append_String) or + not (Full_Catenate_String = Full_Append_String and + BS80."<="(Full_Catenate_String, Full_Append_String) and + BS80.">="(Full_Catenate_String, Full_Append_String)) + then + Report.Failed + ("Incorrect results from bounded wide string catenation" & + " and comparison"); + end if; + + + -- Evaluate the overloaded forms of the Constructor function "*" and + -- the Replicate function. + + Constructed_String := + BS80."*"(2,CharA) & -- "AA" + BS80."*"(2,StrB) & -- "AABBBB" + BS80."*"(3, BS80."*"(2, CharC)) & -- "AABBBBCCCCCC" + BS80.Replicate(3, + BS80.Replicate(2, CharD)) & -- "AABBBBCCCCCCDDDDDD" + BS80.Replicate(2, StrE) & -- "AABBBBCCCCCCDDDDDDEEEE" + BS80.Replicate(2, CharF); -- "AABBBBCCCCCCDDDDDDEEEEFF" + + + -- Use of Function Replicate that involves dropping wide characters. + -- The attempt to replicate the 15 character wide string six times will + -- exceed the 80 wide character bound of the wide string. Therefore, + -- the result should be the catenation of 5 copies of the 15 character + -- wide string, followed by 5 'A' wide characters (the first five wide + -- characters of the 6th replication) with the remaining wide + -- characters of the 6th replication dropped. + + Drop_String := + BS80.Replicate(Count => 6, + Item => ABStr, -- "AAAAABBBBBBBBBB" + Drop => Ada.Strings.Right); + + if BS80.Element(Drop_String, 1) /= Translate('A') or + BS80.Element(Drop_String, 6) /= Translate('B') or + BS80.Element(Drop_String, 76) /= Translate('A') or + BS80.Element(Drop_String, 80) /= Translate('A') + then + Report.Failed("Incorrect result from Replicate with Drop"); + end if; + + + -- Use function Index_Non_Blank in the evaluation of the + -- Constructed_String. + + if BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Forward) /= + BS80.To_Wide_String(Constructed_String)'First or + BS80.Index_Non_Blank(Constructed_String, Ada.Strings.Backward) /= + BS80.Length(Constructed_String) + then + Report.Failed("Incorrect results from constructor functions"); + end if; + + + + declare + + -- Define wide character set objects for use with the Count function. + -- Constructed_String = "AABBBBCCCCCCDDDDDDEEEEFF" from above. + + A_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 1)); + B_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 3)); + C_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 7)); + D_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 13)); + E_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 19)); + F_Set : Ada.Strings.Wide_Maps.Wide_Character_Set := + Ada.Strings.Wide_Maps.To_Set(BS80.Element(Constructed_String, + 23)); + Start : Positive; + Stop : Natural := 0; + + begin + + -- Evaluate the results from function Count by comparing the number + -- of A's to the number of F's, B's to E's, and C's to D's in the + -- Constructed_String. + -- There should be an equal number of each of the wide characters that + -- are being compared (i.e., 2 A's and F's, 4 B's and E's, etc) + + if BS80.Count(Constructed_String, A_Set) /= + BS80.Count(Constructed_String, F_Set) or + BS80.Count(Constructed_String, B_Set) /= + BS80.Count(Constructed_String, E_Set) or + not (BS80.Count(Constructed_String, C_Set) = + BS80.Count(Constructed_String, D_Set)) + then + Report.Failed("Incorrect result from function Count"); + end if; + + + -- Evaluate the functions Head, Tail, and Find_Token. + -- Create the Token_String from the Constructed_String above. + + Token_String := + BS80.Tail(BS80.Head(Constructed_String, 3), 2) & -- "AB" & + BS80.Head(BS80.Tail(Constructed_String, 13), 2) & -- "CD" & + BS80.Head(BS80.Tail(Constructed_String, 3), 2); -- "EF" + + if Token_String /= + BS80.To_Bounded_Wide_String(Translate("ABCDEF")) then + Report.Failed("Incorrect result from Catenation of Token_String"); + end if; + + + -- Find the starting/ending position of the first A in the + -- Token_String (both should be 1, only one A appears in string). + -- The Function Head uses the default pad character to return a + -- bounded wide string longer than its input parameter bounded + -- wide string. + + BS80.Find_Token(BS80.Head(Token_String, 10), -- Default pad. + A_Set, + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 1 and Stop /= 1 then + Report.Failed("Incorrect result from Find_Token - 1"); + end if; + + + -- Find the starting/ending position of the first non-AB slice in + -- the "head" five wide characters of Token_String (slice CDE at + -- positions 3-5) + + BS80.Find_Token(BS80.Head(Token_String, 5), -- "ABCDE" + Ada.Strings.Wide_Maps."OR"(A_Set, B_Set), -- Set (AB) + Ada.Strings.Outside, + Start, + Stop); + + if Start /= 3 and Stop /= 5 then + Report.Failed("Incorrect result from Find_Token - 2"); + end if; + + + -- Find the starting/ending position of the first CD slice in + -- the "tail" eight wide characters (including two pad wide + -- characters) of Token_String (slice CD at positions 5-6 of + -- the tail portion specified) + + BS80.Find_Token(BS80.Tail(Token_String, 8, + Ada.Strings.Wide_Space), + Ada.Strings.Wide_Maps."OR"(C_Set, D_Set), + Ada.Strings.Inside, + Start, + Stop); + + if Start /= 5 and Stop /= 6 then + Report.Failed("Incorrect result from Find_Token - 3"); + end if; + + + -- Evaluate the Replace_Element function. + + -- Token_String = "ABCDEF" + + BS80.Replace_Element(Token_String, 3, BS80.Element(Token_String,4)); + + -- Token_String = "ABDDEF" + + BS80.Replace_Element(Source => Token_String, + Index => 2, + By => BS80.Element(Token_String, 5)); + + -- Token_String = "AEDDEF" + + BS80.Replace_Element(Token_String, + 1, + BS80.Element(BS80.Tail(Token_String, 2), 2)); + + -- Token_String = "FEDDEF" + -- Evaluate this result. + + if BS80.Element(Token_String, + BS80.To_Wide_String(Token_String)'First) /= + BS80.Element(Token_String, + BS80.To_Wide_String(Token_String)'Last) or + BS80.Count(Token_String, D_Set) /= + BS80.Count(Token_String, E_Set) or + BS80.Index_Non_Blank(BS80.Head(Token_String,6)) /= + BS80.Index_Non_Blank(BS80.Tail(Token_String,6)) or + BS80.Head(Token_String, 1) /= + BS80.Tail(Token_String, 1) + then + Report.Failed("Incorrect result from operations in combination"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4018; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4019.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,1027 ---- + -- CXA4019.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Bounded + -- are available, and that they produce correct results, especially + -- under conditions where truncation of the result is required. + -- Specifically, check the subprograms Append, Count with non-Identity + -- maps, Index with non-Identity maps, Index with Set parameters, + -- Insert (function and procedure), Replace_Slice (function and + -- procedure), To_Bounded_Wide_String, and Translate (function and + -- procedure). + -- + -- TEST DESCRIPTION: + -- This test, in conjunction with tests CXA4017, CXA4018, and CXA4020, + -- will provide coverage of the most common usages of the functionality + -- found in the Ada.Strings.Wide_Bounded package. It deals in large part + -- with truncation effects and options. This test contains many small, + -- specific test cases, situations that are often difficult to generate + -- in large numbers in an application-based test. These cases represent + -- specific usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 06 Nov 95 SAIC Corrected expected result string in subtest for + -- ACVC 2.0.1. + -- Moved function Dog_to_Cat_Mapping to library + -- level to correct accessibility problem in test. + -- 22 Aug 96 SAIC Corrected three subtests identified in reviewer + -- comments. + -- 17 Feb 97 PWB.CTA Corrected result strings for Translate and Insert + -- + --! + + package CXA40190 is + + -- Wide Character mapping function defined for use with specific + -- versions of functions Index and Count. + + function Dog_to_Cat_Mapping (From : Wide_Character) + return Wide_Character; + + end CXA40190; + + package body CXA40190 is + + -- Translates "dog" to "cat". + function Dog_to_Cat_Mapping (From : Wide_Character) + return Wide_Character is + begin + if From = 'd' then + return 'c'; + elsif From = 'o' then + return 'a'; + elsif From = 'g' then + return 't'; + else + return From; + end if; + end Dog_to_Cat_Mapping; + + end CXA40190; + + + with CXA40190; + with Report; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Bounded; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Maps.Wide_Constants; + + procedure CXA4019 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + begin + + Report.Test("CXA4019", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Bounded are " & + "available, and that they produce correct " & + "results, especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + use CXA40190; + + package AS renames Ada.Strings; + package ASB renames Ada.Strings.Wide_Bounded; + package ASWC renames Ada.Strings.Wide_Maps.Wide_Constants; + package Maps renames Ada.Strings.Wide_Maps; + + package B10 is new ASB.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_Wide_String; + + Result_String : B10.Bounded_Wide_String; + Test_String : B10.Bounded_Wide_String; + AtoE_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("abcde")); + FtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("fghij")); + AtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Equiv("abcdefghij")); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set("cd"); + Wide_CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Equiv("cd")); + + AB_to_YZ_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "ab", To => "yz"); + + Wide_AB_to_YZ_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => Equiv("ab"), + To => Equiv("yz")); + + CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => "cd", To => "xy"); + + Wide_CD_to_XY_Map : Maps.Wide_Character_Mapping := + Maps.To_Mapping(From => Equiv("cd"), + To => Equiv("xy")); + + + -- Access-to-Subprogram object defined for use with specific versions of + -- functions Index, Count Translate, and procedure Translate. + + Map_Ptr : Maps.Wide_Character_Mapping_Function := + Dog_to_Cat_Mapping'Access; + + + + begin + + -- Function To_Bounded_Wide_String with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + Test_String := + B10.To_Bounded_Wide_String + (Equiv("Much too long for this bounded wide string")); + Report.Failed("Length Error not raised by To_Bounded_Wide_String"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by To_Bounded_Wide_String"); + end; + + -- Drop = Left + + Test_String := + B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), + Drop => Ada.Strings.Left); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("efghijklmn")) then + Report.Failed + ("Incorrect result from To_Bounded_Wide_String, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := + B10.To_Bounded_Wide_String(Source => Equiv("abcdefghijklmn"), + Drop => Ada.Strings.Right); + + if not(Test_String = AtoJ_Bnd_Str) then + Report.Failed + ("Incorrect result from To_Bounded_Wide_String, Drop = Right"); + end if; + + + + + -- Function Append with Truncation + -- Evaluate the function Append with parameters that will + -- cause the truncation of the result. + + -- Drop = Error (default case, Length_Error will be raised) + + begin + -- Append (Bnd Str, Bnd Str); + Result_String := + B10.Append(B10.To_Bounded_Wide_String(Equiv("abcde")), + B10.To_Bounded_Wide_String(Equiv("fghijk"))); -- 11 char + Report.Failed("Length_Error not raised by Append - 1"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 1"); + end; + + begin + -- Append (Str, Bnd Str); + Result_String := + B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), + B10.To_Bounded_Wide_String(Equiv("fghijk")), + AS.Error); + Report.Failed("Length_Error not raised by Append - 2"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 2"); + end; + + begin + -- Append (Bnd Str, Char); + Result_String := + B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), 'k'); + Report.Failed("Length_Error not raised by Append - 3"); + exception + when AS.Length_Error => null; -- OK, correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Append - 3"); + end; + + -- Drop = Left + + -- Append (Bnd Str, Bnd Str) + Result_String := + B10.Append(B10.To_Bounded_Wide_String(Equiv("abcdefgh")), -- 8 chs + B10.To_Bounded_Wide_String(Equiv("ijklmn")), -- 6 chs + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("efghijklmn")) -- 10 chars + then + Report.Failed("Incorrect truncation performed by Append - 4"); + end if; + + -- Append (Bnd Str, Str) + Result_String := + B10.Append(B10.To_Bounded_Wide_String("abcdefghij"), + "xyz", + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_Wide_String("defghijxyz") then + Report.Failed("Incorrect truncation performed by Append - 5"); + end if; + + -- Append (Char, Bnd Str) + + Result_String := + B10.Append(Equiv('A'), + B10.To_Bounded_Wide_String(Equiv("abcdefghij")), + Ada.Strings.Left); + + if Result_String /= B10.To_Bounded_Wide_String(Equiv("abcdefghij")) + then + Report.Failed("Incorrect truncation performed by Append - 6"); + end if; + + -- Drop = Right + + -- Append (Bnd Str, Bnd Str) + Result_String := B10.Append(FtoJ_Bnd_Str, + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("fghijabcde")) + then + Report.Failed("Incorrect truncation performed by Append - 7"); + end if; + + -- Append (Str, Bnd Str) + Result_String := B10.Append(B10.To_Wide_String(AtoE_Bnd_Str), + AtoJ_Bnd_Str, + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("abcdeabcde")) + then + Report.Failed("Incorrect truncation performed by Append - 8"); + end if; + + -- Append (Char, Bnd Str) + Result_String := B10.Append(Equiv('A'), AtoJ_Bnd_Str, Ada.Strings.Right); + + if Result_String /= B10.To_Bounded_Wide_String(Equiv("Aabcdefghi")) then + Report.Failed("Incorrect truncation performed by Append - 9"); + end if; + + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := + B10.Index(Source => B10.To_Bounded_Wide_String("foxy fox 2"), + Pattern => "FOX", + Going => Ada.Strings.Backward, + Mapping => ASWC.Upper_Case_Map); + + if Location /= 6 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := + B10.Index(B10.To_Bounded_Wide_String("THE QUICK "), + "quick", + Ada.Strings.Forward, + Ada.Strings.Wide_Maps.Wide_Constants.Lower_Case_Map); + + if Location /= 5 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + Location := B10.Index(Source => B10.To_Bounded_Wide_String("The the"), + Pattern => "the", + Going => Ada.Strings.Forward, + Mapping => ASWC.Lower_Case_Map); + + if Location /= 1 then + Report.Failed("Incorrect result from Index, non-Identity map - 3"); + end if; + + + + if B10.Index(B10.To_Bounded_Wide_String("abcd"), -- Pattern = Source + "abcd") /= 1 or + B10.Index(B10.To_Bounded_Wide_String("abc"), -- Pattern < Source + "abcd") /= 0 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + "abc") /= 0 + then + Report.Failed("Incorrect result from Index with string patterns"); + end if; + + + + -- Function Index with access-to-subprogram mapping value. + -- Evaluate the function Index with a wide character mapping function + -- object that performs the mapping operation. + + Location := B10.Index(Source => B10.To_Bounded_Wide_String("My dog"), + Pattern => "cat", + Going => Ada.Strings.Forward, + Mapping => Map_Ptr); -- change "dog" to "cat" + + if Location /= 4 then + Report.Failed("Incorrect result from Index, w/map ptr - 1"); + end if; + + Location := B10.Index(B10.To_Bounded_Wide_String("cat or dog"), + "cat", + Ada.Strings.Backward, + Map_Ptr); + + if Location /= 8 then + Report.Failed("Incorrect result from Index, w/map ptr - 2"); + end if; + + if B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern = Source + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("dog"), -- Pattern < Source + "cats", + Ada.Strings.Backward, + Map_Ptr) /= 0 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String("hot dog"), + "dog", + Ada.Strings.Backward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String(" cat dog "), + " cat", + Ada.Strings.Backward, + Map_Ptr) /= 5 or + B10.Index(B10.To_Bounded_Wide_String("dog CatDog"), + "cat", + Ada.Strings.Backward, + Map_Ptr) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("CatandDog"), + "cat", + Ada.Strings.Forward, + Map_Ptr) /= 0 or + B10.Index(B10.To_Bounded_Wide_String("dddd"), + "ccccc", + Ada.Strings.Backward, + Map_Ptr) /= 0 + then + Report.Failed("Incorrect result from Index w/map ptr - 3"); + end if; + + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + B10.Index(Source => B10.To_Bounded_Wide_String(Equiv("abcdeabcde")), + Set => Wide_CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Forward); + + if not (Location = 3) then -- position of first 'c' equivalent in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + B10.Index(Source => B10."&"(AtoE_Bnd_Str, AtoE_Bnd_Str), + Set => Wide_CD_Set, + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward. + Location := B10.Index(B10.To_Bounded_Wide_String("deddacd"), + CD_Set, + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward); + + if Location /= 2 then -- position of 'e' in source. + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Test = Outside, Going = Backward. + Location := B10.Index(B10.To_Bounded_Wide_String(Equiv("deddacd")), + Wide_CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward); + + if Location /= 5 then -- position of 'a', correct. + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + if B10.Index(B10.To_Bounded_Wide_String("cd"), -- Source = Set + CD_Set) /= 1 or + B10.Index(B10.To_Bounded_Wide_String("c"), -- Source < Set + CD_Set) /= 1 or + B10.Index(B10.Null_Bounded_Wide_String, -- Source = Null + Wide_CD_Set) /= 0 or + B10.Index(AtoE_Bnd_Str, + Maps.To_Set('x')) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 5"); + end if; + + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + B10.Count(Source => B10.To_Bounded_Wide_String("THE THE TH"), + Pattern => "th", + Mapping => ASWC.Lower_Case_Map); + + if Total_Count /= 3 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + -- And a few with identity maps as well. + + if B10.Count(B10.To_Bounded_Wide_String(Equiv("ABABABABAB")), + Equiv("ABA"), + Maps.Identity) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("ADCBADABCD"), + "AB", + Maps.To_Mapping("CD", "AB")) /= 5 or + B10.Count(B10.To_Bounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv("aaa")) /= 3 or + B10.Count(B10.To_Bounded_Wide_String(Equiv("XX")), + Equiv("XXX"), + Maps.Identity) /= 0 or + B10.Count(AtoE_Bnd_Str, -- Source = Pattern + Equiv("abcde")) /= 1 or + B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null + " ") /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + + + + -- Function Count with access-to-subprogram mapping. + -- Evaluate the version function Count that uses an access-to-subprogram + -- map parameter. + + Total_Count := + B10.Count(Source => B10.To_Bounded_Wide_String("dogdogdo"), + Pattern => "ca", + Mapping => Map_Ptr); + + if Total_Count /= 3 then + Report.Failed + ("Incorrect result from function Count, w/map ptr - 1"); + end if; + + + if B10.Count(B10.To_Bounded_Wide_String("DdOoGgod"), + "c", + Map_Ptr) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("dododododo"), + "do", + Map_Ptr) /= 0 or + B10.Count(B10.To_Bounded_Wide_String("Dog or dog"), + "cat", + Map_Ptr) /= 1 or + B10.Count(B10.To_Bounded_Wide_String("dddddddddd"), + "ccccc", + Map_Ptr) /= 2 or + B10.Count(B10.To_Bounded_Wide_String("do"), -- Source < Pattern + "cat", + Map_Ptr) /= 0 or + B10.Count(B10.To_Bounded_Wide_String(" dog "), -- Source = Pattern + " cat ", + Map_Ptr) /= 1 or + B10.Count(B10.Null_Bounded_Wide_String, -- Source = Null + " ", + Map_Ptr) /= 0 + then + Report.Failed + ("Incorrect result from function Count, w/map ptr - 2"); + end if; + + + + + -- Procedure Translate + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_Wide_String("abcdeabcab"); + + B10.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_Wide_String("yzcdeyzcyz") then + Report.Failed("Incorrect result from procedure Translate - 1"); + end if; + + -- Total mapping of source. + + Test_String := B10.To_Bounded_Wide_String("abbaaababb"); + + B10.Translate(Source => Test_String, Mapping => ASWC.Upper_Case_Map); + + if Test_String /= B10.To_Bounded_Wide_String("ABBAAABABB") then + Report.Failed("Incorrect result from procedure Translate - 2"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_Wide_String(Equiv("xyzsypcc")); + + B10.Translate(Source => Test_String, Mapping => Wide_AB_to_YZ_Map); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("xyzsypcc")) then + Report.Failed("Incorrect result from procedure Translate - 3"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := B10.To_Bounded_Wide_String("opabcdelmn"); + + B10.Translate(Test_String, + Maps.To_Mapping("abcde", "lmnop")); + + if Test_String /= B10.To_Bounded_Wide_String("oplmnoplmn") then + Report.Failed("Incorrect result from procedure Translate - 4"); + end if; + + + + + -- Procedure Translate with access-to-subprogram mapping. + -- Use the version of Procedure Translate that takes an + -- access-to-subprogram parameter to perform the Source mapping. + + -- Partial mapping of source. + + Test_String := B10.To_Bounded_Wide_String("dogeatdog"); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("cateatcat") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 1"); + end if; + + Test_String := B10.To_Bounded_Wide_String("odogcatlmn"); + + B10.Translate(Test_String, Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("acatcatlmn") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 2"); + end if; + + + -- Total mapping of source. + + Test_String := B10.To_Bounded_Wide_String("gggooooddd"); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("tttaaaaccc") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr- 3"); + end if; + + -- No mapping of source. + + Test_String := B10.To_Bounded_Wide_String(" DOG cat "); + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String(" DOG cat ") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 4"); + end if; + + Test_String := B10.Null_Bounded_Wide_String; + + B10.Translate(Source => Test_String, Mapping => Map_Ptr); + + if Test_String /= B10.To_Bounded_Wide_String("") then + Report.Failed + ("Incorrect result from procedure Translate w/map ptr - 5"); + end if; + + + + + -- Function Translate with access-to-subprogram mapping. + -- Use the version of Function Translate that takes an + -- access-to-subprogram parameter to perform the Source mapping. + + -- Partial mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String("cateatdog"), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("cateatcat") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 1"); + end if; + + if B10.Translate(B10.To_Bounded_Wide_String("cadogtac"), + Map_Ptr) /= + B10.To_Bounded_Wide_String("cacattac") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 2"); + end if; + + -- Total mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String("dogodggdo"), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("catacttca") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr- 3"); + end if; + + -- No mapping of source. + + if B10.Translate(Source => B10.To_Bounded_Wide_String(" DOG cat "), + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String(" DOG cat ") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 4"); + end if; + + if B10.Translate(B10.To_Bounded_Wide_String("d "), Map_Ptr) /= + B10.To_Bounded_Wide_String("c ") or + B10.Translate(B10.To_Bounded_Wide_String(" god"), Map_Ptr) /= + B10.To_Bounded_Wide_String(" tac") or + B10.Translate(B10.To_Bounded_Wide_String("d o g D og"), Map_Ptr) /= + B10.To_Bounded_Wide_String("c a t D at") or + B10.Translate(B10.To_Bounded_Wide_String(" "), Map_Ptr) /= + B10.To_Bounded_Wide_String(" ") or + B10.Translate(B10.To_Bounded_Wide_String("dddddddddd"), Map_Ptr) /= + B10.To_Bounded_Wide_String("cccccccccc") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 5"); + end if; + + if B10.Translate(Source => B10.Null_Bounded_Wide_String, + Mapping => Map_Ptr) /= + B10.To_Bounded_Wide_String("") + then + Report.Failed + ("Incorrect result from function Translate w/map ptr - 6"); + end if; + + + + + -- Function Replace_Slice + -- Evaluate function Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 3, + High => 5, -- 3-5, 3 chars. + By => Equiv("xxxxxx")); -- more than 3. + Report.Failed("Length_Error not raised by Function Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + -- Drop = Left + + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 7, + High => 10, -- 7-10, 4 chars. + By => Equiv("xxxxxx"), -- 6 chars. + Drop => Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("cdefxxxxxx")) -- drop a,b + then + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Replace_Slice(Source => Test_String, + Low => 2, + High => 5, -- 2-5, 4 chars. + By => Equiv("xxxxxx"), -- 6 chars. + Drop => Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Equiv("axxxxxxfgh")) -- drop i,j + then + Report.Failed + ("Incorrect result from Function Replace Slice, Drop = Right"); + end if; + + -- Low = High = Source'Last, "By" length = 1. + + if B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + Equiv("X"), + Ada.Strings.Error) /= + B10.To_Bounded_Wide_String(Equiv("abcdX")) + then + Report.Failed("Incorrect result from Function Replace_Slice"); + end if; + + -- Index_Error raised when High < Source'First - 1. + begin + Test_String := + B10.Replace_Slice(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First, + B10.To_Wide_String(AtoE_Bnd_Str)'First - 2, + Equiv("hijklm")); + Report.Failed("Index_Error not raised by Function Replace_Slice"); + exception + when AS.Index_Error => null; -- OK, expected exception + when Constraint_Error => null; -- Also OK, since RM is not clear + when others => + Report.Failed + ("Incorrect exception raised by Function Replace_Slice"); + end; + + + + -- Procedure Replace_Slice + -- Evaluate procedure Replace_Slice with + -- a variety of Truncation options. + + -- Drop = Error (Default) + + begin + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 3, + High => 5, -- 3-5, 3 chars. + By => Equiv("xxxxxx")); -- more than 3. + Report.Failed("Length_Error not raised by Procedure Replace_Slice"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Procedure Replace_Slice"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 7, + High => 9, -- 7-9, 3 chars. + By => Equiv("xxxxx"), -- 5 chars. + Drop => Ada.Strings.Left); + + if Test_String /= + B10.To_Bounded_Wide_String(Equiv("cdefxxxxxj")) -- drop a,b + then + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => 1, + High => 3, -- 1-3, 3chars. + By => Equiv("xxxx"), -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= + B10.To_Bounded_Wide_String(Equiv("xxxxdefghi")) -- drop j + then + Report.Failed + ("Incorrect result from Procedure Replace Slice, Drop = Right"); + end if; + + -- High = Source'First, Low > High (Insert before Low). + + Test_String := AtoE_Bnd_Str; + B10.Replace_Slice(Source => Test_String, + Low => B10.To_Wide_String(Test_String)'Last, + High => B10.To_Wide_String(Test_String)'First, + By => Equiv("XXXX"), -- 4 chars. + Drop => Ada.Strings.Right); + + if Test_String /= B10.To_Bounded_Wide_String(Equiv("abcdXXXXe")) then + Report.Failed + ("Incorrect result from Procedure Replace Slice"); + end if; + + + + + -- Function Insert with Truncation + -- Drop = Error (Default). + + begin + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 2, + New_Item => Equiv("xyz")); + Report.Failed("Length_Error not raised by Function Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Insert"); + end; + + -- Drop = Left + + Result_String := + B10.Insert(Source => AtoJ_Bnd_Str, -- "abcdefghij" + Before => 5, + New_Item => Equiv("xyz"), -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Result_String) /= Equiv("dxyzefghij") then + Report.Failed("Incorrect result from Function Insert, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := + B10.Insert(Source => B10.To_Bounded_Wide_String("abcdef"), + Before => 2, + New_Item => "vwxyz", -- 5 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_Wide_String(Result_String) /= "avwxyzbcde" then -- drop f. + Report.Failed("Incorrect result from Function Insert, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Insert(B10.To_Bounded_Wide_String("a"), 1, " B") /= + B10.To_Bounded_Wide_String(" Ba") or + B10.Insert(B10.Null_Bounded_Wide_String, 1, Equiv("abcde")) /= + AtoE_Bnd_Str or + B10.Insert(B10.To_Bounded_Wide_String("ab"), 2, "") /= + B10.To_Bounded_Wide_String("ab") + then + Report.Failed("Incorrect result from Function Insert"); + end if; + + + + -- Procedure Insert + + -- Drop = Error (Default). + begin + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 9, + New_Item => Equiv("wxyz"), + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Procedure Insert"); + exception + when AS.Length_Error => null; -- Correct exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Insert"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => B10.Length(Test_String), -- before last char + New_Item => Equiv("xyz"), -- 3 additional chars. + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Test_String) /= Equiv("defghixyzj") then + Report.Failed("Incorrect result from Procedure Insert, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Insert(Source => Test_String, + Before => 4, + New_Item => Equiv("yz"), -- 2 additional chars. + Drop => Ada.Strings.Right); + + if B10.To_Wide_String(Test_String) /= Equiv("abcyzdefgh") then + Report.Failed + ("Incorrect result from Procedure Insert, Drop = Right"); + end if; + + -- Before = Source'First, New_Item length = 1. + + Test_String := B10.To_Bounded_Wide_String(" abc "); + B10.Insert(Test_String, + B10.To_Wide_String(Test_String)'First, + "Z"); + + if Test_String /= B10.To_Bounded_Wide_String("Z abc ") then + Report.Failed("Incorrect result from Procedure Insert"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4019; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4020.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,688 ---- + -- CXA4020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Wide_Bounded + -- are available, and that they produce correct results, especially under + -- conditions where truncation of the result is required. Specifically, + -- check the subprograms Overwrite (function and procedure), Delete, + -- Function Trim (blanks), Trim (Set wide characters, function and + -- procedure), Head, Tail, and Replicate (wide characters and wide + -- strings). + -- + -- TEST DESCRIPTION: + -- This test, in conjunction with tests CXA4017, CXA4018, CXA4019, + -- will provide coverage of the most common usages of the functionality + -- found in the Ada.Strings.Wide_Bounded package. It deals in large part + -- with truncation effects and options. This test contains many small, + -- specific test cases, situations that are often difficult to generate + -- in large numbers in an application-based test. These cases represent + -- specific usage paradigms in-the-small. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 22 Dec 94 SAIC Changed obsolete constant to Strings.Wide_Space. + -- 13 Apr 95 SAIC Corrected certain subtest acceptance conditions. + -- + --! + + with Report; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Bounded; + with Ada.Strings.Wide_Maps; + + procedure CXA4020 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram parameters to simulate the use of Wide_Characters and + -- Wide_Strings in actual practice. Blanks are translated to Wide_Character + -- blanks and all other characters are translated into Wide_Characters with + -- position values 256 greater than their (narrow) character position + -- values. + + function Translate (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Translate; + + + function Translate (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Translate(Str(i)); + end loop; + return WS; + end Translate; + + + begin + + Report.Test("CXA4020", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Bounded are " & + "available, and that they produce correct " & + "results, especially under conditions where " & + "truncation of the result is required"); + + Test_Block: + declare + + package AS renames Ada.Strings; + package ASW renames Ada.Strings.Wide_Bounded; + package Maps renames Ada.Strings.Wide_Maps; + + package B10 is new ASW.Generic_Bounded_Length(Max => 10); + use type B10.Bounded_Wide_String; + + Result_String : B10.Bounded_Wide_String; + Test_String : B10.Bounded_Wide_String; + AtoE_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("abcde")); + FtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("fghij")); + AtoJ_Bnd_Str : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("abcdefghij")); + + Location : Natural := 0; + Total_Count : Natural := 0; + + CD_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("cd")); + XY_Set : Maps.Wide_Character_Set := Maps.To_Set(Translate("xy")); + + + begin + + -- Function Overwrite with Truncation + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 9, + New_Item => Translate("xyz"), + Drop => AS.Error); + Report.Failed("Exception not raised by Function Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Overwrite"); + end; + + -- Drop = Left + + Result_String := + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String), -- 10 + New_Item => Translate("xyz"), + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Result_String) /= + Translate("cdefghixyz") then -- drop a,b + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Overwrite(Test_String, -- "abcdefghij" + 3, + Translate("xxxyyyzzz"), + Ada.Strings.Right); + + if B10.To_Wide_String(Result_String) /= + Translate("abxxxyyyzz") + then + Report.Failed + ("Incorrect result from Function Overwrite, Drop = Right"); + end if; + + -- Additional cases of function Overwrite. + + if B10.Overwrite(B10.To_Bounded_Wide_String(Translate("a")), + 1, -- Source length = 1 + Translate(" abc ")) /= + B10.To_Bounded_Wide_String(Translate(" abc ")) or + B10.Overwrite(B10.Null_Bounded_Wide_String, -- Null source + 1, + Translate("abcdefghij")) /= + AtoJ_Bnd_Str or + B10.Overwrite(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First, + Translate(" ")) /= -- New_Item = 1 + B10.To_Bounded_Wide_String(Translate(" bcde")) + then + Report.Failed("Incorrect result from Function Overwrite"); + end if; + + + + -- Procedure Overwrite + -- Correct usage, no truncation. + + Test_String := AtoE_Bnd_Str; -- "abcde" + B10.Overwrite(Test_String, 2, Translate("xyz")); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("axyze")) then + Report.Failed("Incorrect result from Procedure Overwrite - 1"); + end if; + + Test_String := B10.To_Bounded_Wide_String(Translate("abc")); + B10.Overwrite(Test_String, 2, ""); -- New_Item is null string. + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abc")) then + Report.Failed("Incorrect result from Procedure Overwrite - 2"); + end if; + + -- Drop = Error (Default). + + begin + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => 8, + New_Item => Translate("uvwxyz")); + Report.Failed("Exception not raised by Procedure Overwrite"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Procedure Overwrite"); + end; + + -- Drop = Left + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Source => Test_String, -- "abcdefghij" + Position => B10.Length(Test_String) - 2, -- 8 + New_Item => Translate("uvwxyz"), + Drop => Ada.Strings.Left); + + if B10.To_Wide_String(Test_String) /= + Translate("defguvwxyz") + then + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Left"); + end if; + + -- Drop = Right + + Test_String := AtoJ_Bnd_Str; + B10.Overwrite(Test_String, -- "abcdefghij" + 3, + Translate("xxxyyyzzz"), + Ada.Strings.Right); + + if B10.To_Wide_String(Test_String) /= Translate("abxxxyyyzz") then + Report.Failed + ("Incorrect result from Procedure Overwrite, Drop = Right"); + end if; + + + + -- Function Delete + + if B10.Delete(Source => AtoJ_Bnd_Str, -- "abcdefghij" + From => 3, + Through => 8) /= + B10."&"(B10.Head(AtoJ_Bnd_Str, 2), + B10.Tail(AtoJ_Bnd_Str, 2)) or + B10.Delete(AtoJ_Bnd_Str, 6, B10.Length(AtoJ_Bnd_Str)) /= + AtoE_Bnd_Str or + B10.Delete(AtoJ_Bnd_Str, 1, 5) /= + FtoJ_Bnd_Str + then + Report.Failed("Incorrect result from Function Delete - 1"); + end if; + + if B10.Delete(B10.To_Bounded_Wide_String(Translate("a")), 1, 1) /= + B10.Null_Bounded_Wide_String or + B10.Delete(AtoE_Bnd_Str, + 5, + B10.To_Wide_String(AtoE_Bnd_Str)'First) /= + AtoE_Bnd_Str or + B10.Delete(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'Last, + B10.To_Wide_String(AtoE_Bnd_Str)'Last) /= + B10.To_Bounded_Wide_String(Translate("abcd")) + then + Report.Failed("Incorrect result from Function Delete - 2"); + end if; + + + + -- Function Trim + + declare + + Text : B10.Bounded_Wide_String := + B10.To_Bounded_Wide_String(Translate("Text")); + type Bnd_Array_Type is array (1..5) of B10.Bounded_Wide_String; + Bnd_Array : Bnd_Array_Type := + (B10.To_Bounded_Wide_String(Translate(" Text")), + B10.To_Bounded_Wide_String(Translate("Text ")), + B10.To_Bounded_Wide_String(Translate(" Text ")), + B10.To_Bounded_Wide_String(Translate("Text Text")), + B10.To_Bounded_Wide_String(Translate(" Text Text"))); + + begin + + for i in Bnd_Array_Type'Range loop + case i is + when 4 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + Bnd_Array(i) then -- no change + Report.Failed("Incorrect result from Function Trim - 4"); + end if; + when 5 => + if B10.Trim(Bnd_Array(i), AS.Both) /= + B10."&"(Text, B10."&"(Translate(' '), Text)) + then + Report.Failed("Incorrect result from Function Trim - 5"); + end if; + when others => + if B10.Trim(Bnd_Array(i), AS.Both) /= Text then + Report.Failed("Incorrect result from Function Trim - " & + Integer'Image(i)); + end if; + end case; + end loop; + + end; + + + + -- Function Trim using Sets + + -- Trim characters in sets from both sides of the bounded wide string. + if B10.Trim(Source => B10.To_Bounded_Wide_String(Translate("ddabbaxx")), + Left => CD_Set, + Right => XY_Set) /= + B10.To_Bounded_Wide_String(Translate("abba")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- wide string; likewise for the opposite side. Only "cd" trimmed + -- from left side, and only "xy" trimmed from right side. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")), + CD_Set, + XY_Set) /= + B10.To_Bounded_Wide_String(Translate("xyabcd")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded wide string, just the appropriate ends. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("cdabdxabxy")), + CD_Set, + XY_Set) /= + B10.To_Bounded_Wide_String(Translate("abdxab")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from right side only. No change to Left side. + + if B10.Trim(B10.To_Bounded_Wide_String(Translate("abxyzddcd")), + XY_Set, + CD_Set) /= + B10.To_Bounded_Wide_String(Translate("abxyz")) + then + Report.Failed + ("Incorrect result from Fn Trim - Sets, Right side"); + end if; + + -- Trim no characters on either side of the bounded string. + + Result_String := B10.Trim(AtoJ_Bnd_Str, CD_Set, XY_Set); + if Result_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Fn Trim - Sets, Neither side"); + end if; + + if B10.Trim(AtoE_Bnd_Str, Maps.Null_Set, Maps.Null_Set) /= + AtoE_Bnd_Str or + B10.Trim(B10.To_Bounded_Wide_String(Translate("dcddcxyyxx")), + CD_Set, + XY_Set) /= + B10.Null_Bounded_Wide_String + then + Report.Failed("Incorrect result from Function Trim"); + end if; + + + + -- Procedure Trim using Sets + + -- Trim characters in sets from both sides of the bounded wide string. + + Test_String := B10.To_Bounded_Wide_String(Translate("dcabbayx")); + B10.Trim(Source => Test_String, + Left => CD_Set, + Right => XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abba")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 1"); + end if; + + -- Ensure that the characters in the set provided as the actual to + -- parameter Right are not trimmed from the left side of the bounded + -- wide string; likewise for the opposite side. Only "cd" trimmed + -- from left side, and only "xy" trimmed from right side. + + Test_String := B10.To_Bounded_Wide_String(Translate("cdxyabcdxy")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("xyabcd")) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 2"); + end if; + + -- Ensure that characters contained in the sets are not trimmed from + -- the "interior" of the bounded wide string, just the appropriate ends. + + Test_String := B10.To_Bounded_Wide_String(Translate("cdabdxabxy")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if not + (Test_String = B10.To_Bounded_Wide_String(Translate("abdxab"))) then + Report.Failed + ("Incorrect result from Proc Trim - Sets, Left & Right side - 3"); + end if; + + -- Trim characters in set from Left side only. No change to Right side. + + Test_String := B10.To_Bounded_Wide_String(Translate("cccdabxyz")); + B10.Trim(Test_String, CD_Set, XY_Set); + + if Test_String /= B10.To_Bounded_Wide_String(Translate("abxyz")) then + Report.Failed + ("Incorrect result from Proc Trim for Sets, Left side only"); + end if; + + -- Trim no characters on either side of the bounded wide string. + + Test_String := AtoJ_Bnd_Str; + B10.Trim(Test_String, CD_Set, CD_Set); + + if Test_String /= AtoJ_Bnd_Str then + Report.Failed("Incorrect result from Proc Trim-Sets, Neither side"); + end if; + + + + -- Function Head with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Head(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Translate('X')); + Report.Failed("Length_Error not raised by Function Head"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Head"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the right end of the bounded + -- wide string (which is initially at its maximum length), then the + -- first five characters of the intermediate result are dropped to + -- conform to the maximum size limit of the bounded wide string (10). + + Result_String := + B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), + 15, + Translate('x'), + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("FGHIJxxxxx")) + then + Report.Failed("Incorrect result from Function Head, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (6) are appended to the left end of the bounded + -- wide string (which is initially at one less than its maximum length), + -- then the last five characters of the intermediate result are dropped + -- (which in this case are the pad characters) to conform to the + -- maximum size limit of the bounded wide string (10). + + Result_String := + B10.Head(B10.To_Bounded_Wide_String(Translate("ABCDEFGHI")), + 15, + Translate('x'), + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("ABCDEFGHIx")) + then + Report.Failed("Incorrect result from Function Head, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Head(B10.Null_Bounded_Wide_String, 5, Translate('a')) /= + B10.To_Bounded_Wide_String(Translate("aaaaa")) or + B10.Head(AtoE_Bnd_Str, + B10.Length(AtoE_Bnd_Str)) /= + AtoE_Bnd_Str + then + Report.Failed("Incorrect result from Function Head"); + end if; + + + + -- Function Tail with Truncation + -- Drop = Error (Default Case) + + begin + Result_String := B10.Tail(Source => AtoJ_Bnd_Str, -- max length + Count => B10.Length(AtoJ_Bnd_Str) + 1, + Pad => Ada.Strings.Wide_Space, + Drop => Ada.Strings.Error); + Report.Failed("Length_Error not raised by Function Tail"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed("Incorrect exception raised by Function Tail"); + end; + + -- Drop = Left + + -- Pad characters (5) are appended to the left end of the bounded wide + -- string (which is initially at two less than its maximum length), + -- then the first three characters of the intermediate result (in this + -- case, 3 pad characters) are dropped. + + Result_String := + B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGH")), + 13, + Translate('x'), + Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("xxABCDEFGH")) + then + Report.Failed("Incorrect result from Function Tail, Drop = Left"); + end if; + + -- Drop = Right + + -- Pad characters (3) are appended to the left end of the bounded wide + -- string (which is initially at its maximum length), then the last + -- three characters of the intermediate result are dropped. + + Result_String := + B10.Tail(B10.To_Bounded_Wide_String(Translate("ABCDEFGHIJ")), + 13, + Translate('x'), + Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("xxxABCDEFG")) + then + Report.Failed("Incorrect result from Function Tail, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Tail(B10.Null_Bounded_Wide_String, 3, Translate(' ')) /= + B10.To_Bounded_Wide_String(Translate(" ")) or + B10.Tail(AtoE_Bnd_Str, + B10.To_Wide_String(AtoE_Bnd_Str)'First) /= + B10.To_Bounded_Wide_String(Translate("e")) + then + Report.Failed("Incorrect result from Function Tail"); + end if; + + + + -- Function Replicate (#, Char) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => B10.Max_Length + 5, + Item => Translate('A'), + Drop => AS.Error); + Report.Failed + ("Length_Error not raised by Replicate for characters"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for characters"); + end; + + -- Drop = Left, Right + -- Since this version of Replicate uses wide character parameters, the + -- result after truncation from left or right will appear the same. + -- The result will be a 10 character bounded wide string, composed of + -- 10 "Item" wide characters. + + if B10.Replicate(Count => 20, + Item => Translate('A'), + Drop => Ada.Strings.Left) /= + B10.Replicate(15, Translate('A'), Ada.Strings.Right) + then + Report.Failed("Incorrect result from Replicate for characters - 1"); + end if; + + -- Blank-filled, 10 character bounded wide strings. + + if B10.Replicate(B10.Max_Length + 1, + Translate(' '), + Drop => Ada.Strings.Left) /= + B10.Replicate(B10.Max_Length, Ada.Strings.Wide_Space) + then + Report.Failed("Incorrect result from Replicate for characters - 2"); + end if; + + -- Additional cases. + + if B10.Replicate(0, Translate('a')) /= B10.Null_Bounded_Wide_String or + B10.Replicate(1, Translate('a')) /= + B10.To_Bounded_Wide_String(Translate("a")) + then + Report.Failed("Incorrect result from Replicate for characters - 3"); + end if; + + + + -- Function Replicate (#, String) with Truncation + -- Drop = Error (Default). + + begin + Result_String := B10.Replicate(Count => 5, -- result would be 15. + Item => Translate("abc")); + Report.Failed + ("Length_Error not raised by Replicate for wide strings"); + exception + when AS.Length_Error => null; -- Expected exception raised. + when others => + Report.Failed + ("Incorrect exception raised by Replicate for wide strings"); + end; + + -- Drop = Left + + Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Left); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("cdabcdabcd")) + then + Report.Failed + ("Incorrect result from Replicate for wide strings, Drop = Left"); + end if; + + -- Drop = Right + + Result_String := B10.Replicate(3, Translate("abcd"), Ada.Strings.Right); + + if Result_String /= + B10.To_Bounded_Wide_String(Translate("abcdabcdab")) then + Report.Failed + ("Incorrect result from Replicate for wide strings, Drop = Right"); + end if; + + -- Additional cases. + + if B10.Replicate(5, Translate("X")) /= + B10.To_Bounded_Wide_String(Translate("XXXXX")) or + B10.Replicate(10, "") /= + B10.Null_Bounded_Wide_String or + B10.Replicate(0, Translate("ab")) /= + B10.Null_Bounded_Wide_String + then + Report.Failed("Incorrect result from Replicate for wide strings"); + end if; + + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4020; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4021.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,311 ---- + -- CXA4021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package + -- Ada.Strings.Wide_Unbounded are available, and that they produce + -- correct results. Specifically, check the subprograms Head, Index, + -- Index_Non_Blank, Insert, Length, Overwrite, Replace_Slice, Slice, + -- Tail, To_Wide_String, To_Unbounded_Wide_String, "*", "&", + -- and "=", "<=", ">=". + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Wide_Unbounded for use with unbounded wide + -- strings. + -- The test attempts to simulate how unbounded wide strings could be used + -- to simulate paragraphs of text. Modifications could be easily be + -- performed using the provided subprograms (although in this test, the + -- main modification performed was the addition of more text to the + -- string). One would not have to worry about the formatting of the + -- paragraph until it was finished and correct in content. Then, once + -- all required editing is complete, the unbounded strings can be divided + -- up into the appropriate lengths based on particular formatting + -- requirements. The test then compares the formatted text product + -- with a predefined "finished product". + -- + -- This test attempts to use a large number of the subprograms provided + -- by package Ada.Strings.Wide_Unbounded. Often, the processing involved + -- could have been performed more efficiently using a minimum number + -- of the subprograms, in conjunction with loops, etc. However, for + -- testing purposes, and in the interest of minimizing the number of + -- tests developed, subprogram variety and feature mixing was stressed. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Report; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Unbounded; + + procedure CXA4021 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram character and string parameters to simulate the use of non- + -- character Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + begin + + Report.Test ("CXA4021", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + package ASW renames Ada.Strings.Wide_Unbounded; + use type ASW.Unbounded_Wide_String; + use Ada.Strings; + + Pamphlet_Paragraph_Count : constant := 2; + Lines : constant := 4; + Line_Length : constant := 40; + + type Document_Type is array (Positive range <>) + of ASW.Unbounded_Wide_String; + + type Camera_Ready_Copy_Type is array (1..Lines) + of Wide_String (1..Line_Length); + + Pamphlet : Document_Type (1..Pamphlet_Paragraph_Count); + + Camera_Ready_Copy : Camera_Ready_Copy_Type := + (others => (others => Ada.Strings.Wide_Space)); + + TC_Finished_Product : Camera_Ready_Copy_Type := + ( 1 => Equiv("Ada is a programming language designed "), + 2 => Equiv("to support long-lived, reliable software"), + 3 => Equiv(" systems. "), + 4 => Equiv("Go with Ada! ")); + + ----- + + + procedure Enter_Text_Into_Document (Document : in out Document_Type) is + begin + + -- Fill in both "paragraphs" of the document. Each unbounded wide + -- string functions as an individual paragraph, containing an + -- unspecified number of characters. + -- Use a variety of different unbounded wide string subprograms to + -- load the data. + + Document(1) := + ASW.To_Unbounded_Wide_String(Equiv("Ada is a language")); + + -- Insert the word "programming" prior to "language". + Document(1) := + ASW.Insert(Document(1), + ASW.Index(Document(1), + Equiv("language")), + ASW.To_Wide_String(Equiv("progra") & -- Wd Str & + ASW."*"(2,Equiv('m')) & -- Wd Unbd & + Equiv("ing "))); -- Wd Str + + + -- Overwrite the word "language" with "language" + additional text. + Document(1) := + ASW.Overwrite(Document(1), + ASW.Index(Document(1), + ASW.To_Wide_String( + ASW.Tail(Document(1), 8, Equiv(' '))), + Ada.Strings.Backward), + Equiv("language designed to support long-lifed")); + + + -- Replace the word "lifed" with "lived". + Document(1) := + ASW.Replace_Slice(Document(1), + ASW.Index(Document(1), Equiv("lifed")), + ASW.Length(Document(1)), + Equiv("lived")); + + + -- Overwrite the word "lived" with "lived" + additional text. + Document(1) := + ASW.Overwrite(Document(1), + ASW.Index(Document(1), + ASW.To_Wide_String + (ASW.Tail(Document(1), 5, Equiv(' '))), + Ada.Strings.Backward), + Equiv("lived, reliable software systems.")); + + + -- Use several of the overloaded versions of "&" to form this + -- unbounded wide string. + + Document(2) := Equiv('G') & + ASW.To_Unbounded_Wide_String(Equiv("o ")) & + ASW.To_Unbounded_Wide_String(Equiv("with")) & + Equiv(' ') & + Equiv("Ada!"); + + end Enter_Text_Into_Document; + + + ----- + + + procedure Create_Camera_Ready_Copy + (Document : in Document_Type; + Camera_Copy : out Camera_Ready_Copy_Type) is + begin + -- Break the unbounded wide strings into fixed lengths. + + -- Search the first unbounded wide string for portions of text that + -- are less than or equal to the length of a wide string in the + -- Camera_Ready_Copy_Type object. + + Camera_Copy(1) := -- Take characters 1-39, + ASW.Slice(Document(1), -- and append a blank space. + 1, + ASW.Index(ASW.To_Unbounded_Wide_String + (ASW.Slice(Document(1), + 1, + Line_Length)), + Ada.Strings.Wide_Maps.To_Set(Equiv(' ')), + Ada.Strings.Inside, + Ada.Strings.Backward)) & Equiv(' '); + + Camera_Copy(2) := -- Take characters 40-79. + ASW.Slice(Document(1), + 40, + (ASW.Index_Non_Blank -- Should return 79 + (ASW.To_Unbounded_Wide_String + (ASW.Slice(Document(1), -- Slice (40..79) + 40, + 79)), + Ada.Strings.Backward) + 39)); -- Increment since + -- this slice starts + -- at 40. + + Camera_Copy(3)(1..9) := ASW.Slice(Document(1), -- Characters 80-88 + 80, + ASW.Length(Document(1))); + + + -- Break the second unbounded wide string into the appropriate + -- length. It is only twelve characters in length, so the entire + -- unbounded wide string will be placed on one string of the output + -- object. + + Camera_Copy(4)(1..ASW.Length(Document(2))) := + ASW.To_Wide_String(ASW.Head(Document(2), + ASW.Length(Document(2)))); + + end Create_Camera_Ready_Copy; + + + ----- + + + function Valid_Proofread (Draft, Master : Camera_Ready_Copy_Type) + return Boolean is + begin + + -- Evaluate wide strings for equality, using the operators defined + -- in package Ada.Strings.Wide_Unbounded. The less than/greater + -- than or equal comparisons should evaluate to "equals => True". + + if ASW.To_Unbounded_Wide_String(Draft(1)) = -- "="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(1)) and + ASW.To_Unbounded_Wide_String(Draft(2)) <= -- "<="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(2)) and + ASW.To_Unbounded_Wide_String(Draft(3)) >= -- ">="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(3)) and + ASW.To_Unbounded_Wide_String(Draft(4)) = -- "="(WUnb,WUnb) + ASW.To_Unbounded_Wide_String(Master(4)) + then + return True; + else + return False; + end if; + + end Valid_Proofread; + + + ----- + + + begin + + -- Enter text into the unbounded wide string paragraphs of the document. + + Enter_Text_Into_Document (Pamphlet); + + + -- Reformat the unbounded wide strings into fixed wide string format. + + Create_Camera_Ready_Copy (Document => Pamphlet, + Camera_Copy => Camera_Ready_Copy); + + + -- Verify the conversion process. + + if not Valid_Proofread (Draft => Camera_Ready_Copy, + Master => TC_Finished_Product) + then + Report.Failed ("Incorrect unbounded wide string processing result"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4022.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,531 ---- + -- CXA4022.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package + -- Ada.Strings.Wide_Unbounded are available, and that they produce + -- correct results. Specifically, check the subprograms Count, Element, + -- Index, Replace_Element, To_Unbounded_Wide_String, and "&", ">", "<". + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Wide_Unbounded for use with unbounded wide + -- strings. The test simulates how unbounded wide strings + -- will be processed in a user environment, using the subprograms + -- provided in this package. + -- + -- Taken in conjunction with tests CXA4021 and CXA4023, this test will + -- constitute a test of the functionality contained in package + -- Ada.Strings.Wide Unbounded. This test uses a variety + -- of the subprograms defined in the unbounded wide string package + -- in ways typical of common usage, with different combinations of + -- available subprograms being used to accomplish similar + -- unbounded wide string processing goals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 08 Nov 95 SAIC Corrected accessibility level, type visibility, + -- and subtest acceptance criteria problems for + -- ACVC 2.0.1 + -- + --! + + with Ada.Characters.Handling; + with Ada.Strings; + + package CXA40220 is + + -- The following two functions are used to translate character and string + -- values to "Wide" values. They will be applied to all the Wide_Bounded + -- subprogram character and string parameters to simulate the use of non- + -- character Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character; + + function Equiv (Str : String) return Wide_String; + + + -- Functions and access-to-subprogram value used to supply mapping + -- capability to the appropriate versions of Count, Index, and + -- Translate. + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character; + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character; + + end CXA40220; + + package body CXA40220 is + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character is + UnderScore : constant Wide_Character := Equiv('_'); + begin + if From = Equiv('a') or From = Equiv('b') then + return UnderScore; + else + return From; + end if; + end AB_to_US_Mapping_Function; + + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character is + begin + if From = Equiv('a') or From = Equiv('b') then + return Ada.Strings.Wide_Space; + else + return From; + end if; + end AB_to_Blank_Mapping_Function; + + end CXA40220; + + + with CXA40220; + with Report; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Unbounded; + + procedure CXA4022 is + begin + + Report.Test ("CXA4022", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + use CXA40220; + + package ASW renames Ada.Strings.Wide_Unbounded; + use Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type ASW.Unbounded_Wide_String; + + Test_String : ASW.Unbounded_Wide_String; + AtoE_Str : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abcde")); + + Complete_String : ASW.Unbounded_Wide_String := + ASW."&"(ASW.To_Unbounded_Wide_String(Equiv("Incomplete")), + ASW."&"(Ada.Strings.Wide_Space, + ASW.To_Unbounded_Wide_String(Equiv("String")))); + + Incomplete_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String + (Equiv("ncomplete Strin")); + + Incorrect_Spelling : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Guob Dai")); + + Magic_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); + + Incantation : ASW.Unbounded_Wide_String := Magic_String; + + + A_Small_G : Wide_Character := Equiv('g'); + A_Small_D : Wide_Character := Equiv('d'); + + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("abcd")); + B_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv('b')); + CD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("cd")); + + CD_to_XY_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => Equiv("cd"), + To => Equiv("xy")); + AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("ab"), Equiv("yz")); + + + Matching_Letters : Natural := 0; + Location, + Total_Count : Natural := 0; + + + Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + AB_to_US_Mapping_Function'Access; + + + begin + + + -- Function "&" + + -- Prepend an 'I' and append a 'g' to the wide string. + Incomplete_String := ASW."&"(Equiv('I'), + Incomplete_String); -- Ch & W Unb + Incomplete_String := ASW."&"(Incomplete_String, + A_Small_G); -- W Unb & Ch + + if ASW."<"(Incomplete_String, Complete_String) or + ASW.">"(Incomplete_String, Complete_String) or + Incomplete_String /= Complete_String + then + Report.Failed("Incorrect result from use of ""&"" operator"); + end if; + + + + -- Function Element + + -- Last element of the unbounded wide string should be a 'g'. + if ASW.Element(Incomplete_String, ASW.Length(Incomplete_String)) /= + A_Small_G + then + Report.Failed("Incorrect result from use of Function Element - 1"); + end if; + + if ASW.Element(Incomplete_String, 2) /= + ASW.Element(ASW.Tail(Incomplete_String, 2), 1) or + ASW.Element(ASW.Head(Incomplete_String, 4), 2) /= + ASW.Element(ASW.To_Unbounded_Wide_String(Equiv("wnqz")), 2) + then + Report.Failed("Incorrect result from use of Function Element - 2"); + end if; + + + + -- Procedure Replace_Element + + -- The unbounded wide string Incorrect_Spelling starts as "Guob Dai", + -- and is transformed by the following three procedure calls to + -- "Good Day". + + ASW.Replace_Element(Incorrect_Spelling, 2, Equiv('o')); + + ASW.Replace_Element(Incorrect_Spelling, + ASW.Index(Incorrect_Spelling, B_Set), + A_Small_D); + + ASW.Replace_Element(Source => Incorrect_Spelling, + Index => ASW.Length(Incorrect_Spelling), + By => Equiv('y')); + + if Incorrect_Spelling /= + ASW.To_Unbounded_Wide_String(Equiv("Good Day")) + then + Report.Failed("Incorrect result from Procedure Replace_Element"); + end if; + + + + -- Function Index with non-Identity map. + -- Evaluate the function Index with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the index position search. + + Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String + (Equiv("abcdefghij")), + Pattern => Equiv("xy"), + Going => Ada.Strings.Forward, + Mapping => CD_to_XY_Map); -- change "cd" to "xy" + + if Location /= 3 then + Report.Failed("Incorrect result from Index, non-Identity map - 1"); + end if; + + Location := ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcdabcdab")), + Equiv("yz"), + Ada.Strings.Backward, + AB_to_YZ_Map); -- change all "ab" to "yz" + + if Location /= 9 then + Report.Failed("Incorrect result from Index, non-Identity map - 2"); + end if; + + -- A couple with identity maps (default) as well. + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), -- Pat = Src + Equiv("abcd")) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), -- Pat < Src + Equiv("abcd")) /= 0 or + ASW.Index(ASW.Null_Unbounded_Wide_String, -- Src = Null + Equiv("abc")) /= 0 + then + Report.Failed + ("Incorrect result from Index with wide string patterns"); + end if; + + + + -- Function Index (for Sets). + -- This version of Index uses Sets as the basis of the search. + + -- Test = Inside, Going = Forward (Default case). + Location := + ASW.Index(Source => ASW.To_Unbounded_Wide_String(Equiv("abcdeabcde")), + Set => CD_Set); -- set containing 'c' and 'd' + + if not (Location = 3) then -- position of first 'c' in source. + Report.Failed("Incorrect result from Index using Sets - 1"); + end if; + + -- Test = Inside, Going = Backward. + Location := + ASW.Index(Source => ASW."&"(AtoE_Str, AtoE_Str), + Set => CD_Set, -- set containing 'c' and 'd' + Test => Ada.Strings.Inside, + Going => Ada.Strings.Backward); + + if not (Location = 9) then -- position of last 'd' in source. + Report.Failed("Incorrect result from Index using Sets - 2"); + end if; + + -- Test = Outside, Going = Forward, Backward + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + Wide_Maps.To_Set(Equiv("xydcgf")), + Test => Ada.Strings.Outside, + Going => Ada.Strings.Forward) /= 2 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + Wide_Maps.To_Set(Equiv("xydcgf")), + Test => Ada.Strings.Outside, + Going => Ada.Strings.Backward) /= 5 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("deddacd")), + CD_Set, + Ada.Strings.Outside, + Ada.Strings.Backward) /= 5 + then + Report.Failed("Incorrect result from Index using Sets - 3"); + end if; + + -- Default direction (forward) and mapping (identity). + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("cd")), -- Source = Set + CD_Set) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("c")), -- Source < Set + CD_Set) /= 1 or + ASW.Index(ASW.Null_Unbounded_Wide_String, -- Source = Null + CD_Set) /= 0 or + ASW.Index(AtoE_Str, + Wide_Maps.Null_Set) /= 0 or -- Null set + ASW.Index(AtoE_Str, + Wide_Maps.To_Set(Equiv('x'))) /= 0 -- No match. + then + Report.Failed("Incorrect result from Index using Sets - 4"); + end if; + + + + -- Function Index using access-to-subprogram mapping. + -- Evaluate the function Index with an access value that supplies the + -- mapping function for this version of Index. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Location := ASW.Index(Source => ASW.To_Unbounded_Wide_String + (Equiv("xAxabbxax xaax _cx")), + Pattern => Equiv("_x"), + Going => Ada.Strings.Forward, + Mapping => Map_Ptr); -- change 'a'or 'b' to '_' + + if Location /= 6 then -- location of "bx" substring + Report.Failed("Incorrect result from Index, access value map - 1"); + end if; + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Location := ASW.Index(ASW.To_Unbounded_Wide_String + (Equiv("ccacdcbbcdacc")), + Equiv("cd "), + Ada.Strings.Backward, + Map_Ptr); -- change 'a' or 'b' to ' ' + + if Location /= 9 then + Report.Failed("Incorrect result from Index, access value map - 2"); + end if; + + if ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abcd")), + Equiv(" cd"), + Ada.Strings.Forward, + Map_Ptr) /= 1 or + ASW.Index(ASW.To_Unbounded_Wide_String(Equiv("abc")), + Equiv(" c "), -- No match + Ada.Strings.Backward, + Map_Ptr) /= 0 + then + Report.Failed("Incorrect result from Index, access value map - 3"); + end if; + + + + -- Function Count + + -- Determine the number of characters in the unbounded wide string that + -- are contained in the set. + + Matching_Letters := ASW.Count(Source => Magic_String, + Set => ABCD_Set); + + if Matching_Letters /= 9 then + Report.Failed + ("Incorrect result from Function Count with Set parameter"); + end if; + + -- Determine the number of occurrences of the following pattern wide + -- strings in the unbounded wide string Magic_String. + + if ASW.Count(Magic_String, Equiv("ab")) /= + (ASW.Count(Magic_String, Equiv("ac")) + + ASW.Count(Magic_String, Equiv("ad"))) or + ASW.Count(Magic_String, Equiv("ab")) /= 2 + then + Report.Failed + ("Incorrect result from Function Count, wide string parameter"); + end if; + + + + -- Function Count with non-Identity mapping. + -- Evaluate the function Count with a non-identity map + -- parameter which will cause mapping of the source parameter + -- prior to the evaluation of the number of matching patterns. + + Total_Count := + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abbabbabbabba")), + Pattern => Equiv("yz"), + Mapping => AB_to_YZ_Map); + + if Total_Count /= 4 then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 1"); + end if; + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ADCBADABCD")), + Equiv("AB"), + Wide_Maps.To_Mapping(Equiv("CD"), Equiv("AB"))) /= 5 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("dcccddcdccdddccccd")), + Equiv("xxy"), + CD_to_XY_Map) /= 3 + then + Report.Failed + ("Incorrect result from function Count, non-Identity map - 2"); + end if; + + -- And a few with identity Wide_Maps as well. + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("ABABABABAB")), + Equiv("ABA"), + Wide_Maps.Identity) /= 2 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv("aaa")) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat + Equiv("XXX"), + Wide_Maps.Identity) /= 0 or + ASW.Count(AtoE_Str, -- Source = Pattern + Equiv("abcde")) /= 1 or + ASW.Count(ASW.Null_Unbounded_Wide_String, -- Source = Null + Equiv(" ")) /= 0 + then + Report.Failed + ("Incorrect result from function Count, w,w/o mapping"); + end if; + + + + -- Function Count using access-to-subprogram mapping. + -- Evaluate the function Count with an access value specifying the + -- mapping that is going to occur to Source. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Total_Count := + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("abcbacbadbaAbbB")), + Pattern => Equiv("__"), + Mapping => Map_Ptr); -- change 'a' and 'b' to '_' + + if Total_Count /= 5 then + Report.Failed + ("Incorrect result from function Count, access value map - 1"); + end if; + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + if ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("cccaccBcbcaccacAc")), + Equiv("c c"), + Map_Ptr) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String + (Equiv("aBBAAABaBBBBAaBABBABaBBbBB")), + Equiv(" BB"), + Map_Ptr) /= 4 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("aaaaaaaaaa")), + Equiv(" "), + Map_Ptr) /= 3 or + ASW.Count(ASW.To_Unbounded_Wide_String(Equiv("XX")), -- Src < Pat + Equiv("XX "), + Map_Ptr) /= 0 or + ASW.Count(AtoE_Str, -- Source'Length = Pattern'Length + Equiv(" cde"), + Map_Ptr) /= 1 + then + Report.Failed + ("Incorrect result from function Count, access value map - 3"); + end if; + + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4023.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,585 ---- + -- CXA4023.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package + -- Ada.Strings.Wide_Unbounded are available, and that they produce + -- correct results. Specifically, check the subprograms Delete, + -- Find_Token, Translate, Trim, and "*". + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Wide_Unbounded for use with unbounded wide + -- strings. The test simulates how unbounded wide strings + -- will be processed in a user environment, using the subprograms + -- provided in this package. + -- + -- This test, when taken in conjunction with tests CXA4021-22, will + -- constitute a test of the functionality contained in package + -- Ada.Strings.Wide_Unbounded. This test uses a variety + -- of the subprograms defined in the unbounded wide string package + -- in ways typical of common usage, with different combinations of + -- available subprograms being used to accomplish similar + -- unbounded wide string processing goals. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 08 Nov 95 SAIC Corrected accessibility level and type + -- visibility problems for ACVC 2.0.1. + -- + --! + + with Ada.Characters.Handling; + with Ada.Strings; + + package CXA40230 is + + -- The following two functions are used to translate character and string + -- values to non-character "Wide" values. They will be applied to all the + -- Wide_Bounded subprogram character and string parameters to simulate the + -- use of Wide_Characters and Wide_Strings in actual practice. + -- Note: These functions do not actually return "equivalent" wide + -- characters to their character inputs, just "non-character" + -- wide characters. + + function Equiv (Ch : Character) return Wide_Character; + + function Equiv (Str : String) return Wide_String; + + -- Functions and access-to-subprogram object used to supply mapping + -- capability to the appropriate versions of Translate. + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character; + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character; + + end CXA40230; + + + package body CXA40230 is + + function Equiv (Ch : Character) return Wide_Character is + C : Character := Ch; + begin + if Ch = ' ' then + return Ada.Characters.Handling.To_Wide_Character(C); + else + return Wide_Character'Val(Character'Pos(Ch) + + Character'Pos(Character'Last) + 1); + end if; + end Equiv; + + + function Equiv (Str : String) return Wide_String is + WS : Wide_String(Str'First..Str'Last); + begin + for i in Str'First..Str'Last loop + WS(i) := Equiv(Str(i)); + end loop; + return WS; + end Equiv; + + + function AB_to_US_Mapping_Function (From : Wide_Character) + return Wide_Character is + UnderScore : constant Wide_Character := Equiv('_'); + begin + if From = Equiv('a') or From = Equiv('b') then + return UnderScore; + else + return From; + end if; + end AB_to_US_Mapping_Function; + + + function AB_to_Blank_Mapping_Function (From : Wide_Character) + return Wide_Character is + begin + if From = Equiv('a') or From = Equiv('b') then + return Ada.Strings.Wide_Space; + else + return From; + end if; + end AB_to_Blank_Mapping_Function; + + end CXA40230; + + + with CXA40230; + with Report; + with Ada.Characters.Handling; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Unbounded; + + procedure CXA4023 is + begin + + Report.Test ("CXA4023", "Check that the subprograms defined in " & + "package Ada.Strings.Wide_Unbounded are " & + "available, and that they produce correct " & + "results"); + + Test_Block: + declare + + use CXA40230; + + package ASW renames Ada.Strings.Wide_Unbounded; + use Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type ASW.Unbounded_Wide_String; + + Test_String : ASW.Unbounded_Wide_String; + AtoE_Str : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abcde")); + + Cad_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("cad")); + + Magic_String : ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("abracadabra")); + + Incantation : ASW.Unbounded_Wide_String := Magic_String; + + + A_Small_G : Wide_Character := Equiv('g'); + + ABCD_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("abcd")); + B_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv('b')); + AB_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps."OR"(Wide_Maps.To_Set(Equiv('a')), B_Set); + + + AB_to_YZ_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(From => Equiv("ab"), + To => Equiv("yz")); + Code_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("abcd"), Equiv("wxyz")); + Reverse_Code_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("wxyz"), Equiv("abcd")); + Non_Existent_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(Equiv("jkl"), Equiv("mno")); + + + Token_Start : Positive; + Token_End : Natural := 0; + + Map_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + AB_to_US_Mapping_Function'Access; + + + begin + + -- Find_Token + + ASW.Find_Token(Magic_String, -- Find location of first "ab" equiv. + AB_Set, -- Should be (1..2). + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Natural(Token_Start) /= ASW.To_Wide_String(Magic_String)'First or + Token_End /= ASW.Index(Magic_String, B_Set) or + Token_End /= 2 + then + Report.Failed("Incorrect result from Procedure Find_Token - 1"); + end if; + + + ASW.Find_Token(Source => Magic_String, -- Find location of char 'r'equiv + Set => ABCD_Set, -- in wide str, should be (3..3) + Test => Ada.Strings.Outside, + First => Token_Start, + Last => Token_End); + + if Natural(Token_Start) /= 3 or Token_End /= 3 then + Report.Failed("Incorrect result from Procedure Find_Token - 2"); + end if; + + + ASW.Find_Token(Magic_String, -- No 'g' "equivalent in + Wide_Maps.To_Set(A_Small_G), -- the wide str, so the + Ada.Strings.Inside, -- result params should be + First => Token_Start, -- First = Source'First and + Last => Token_End); -- Last = 0. + + + if Token_Start /= ASW.To_Wide_String(Magic_String)'First or + Token_End /= 0 + then + Report.Failed("Incorrect result from Procedure Find_Token - 3"); + end if; + + + ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), + Wide_Maps.To_Set(Equiv("trpq")), + Ada.Strings.Inside, + Token_Start, + Token_End); + + if Token_Start /= 3 or + Token_End /= 10 + then + Report.Failed("Incorrect result from Procedure Find_Token - 4"); + end if; + + ASW.Find_Token(ASW.To_Unbounded_Wide_String(Equiv("abpqpqrttrcpqr")), + Wide_Maps.To_Set(Equiv("abpq")), + Ada.Strings.Outside, + Token_Start, + Token_End); + + if Token_Start /= 7 or + Token_End /= 11 + then + Report.Failed("Incorrect result from Procedure Find_Token - 5"); + end if; + + + + -- Translate + + -- Use a mapping ("abcd" -> "wxyz") to transform the contents of + -- the unbounded wide string. + -- Magic_String = "abracadabra" + + Incantation := ASW.Translate(Magic_String, Code_Map); + + if Incantation /= + ASW.To_Unbounded_Wide_String(Equiv("wxrwywzwxrw")) + then + Report.Failed("Incorrect result from Function Translate - 1"); + end if; + + -- (Note: See below for additional testing of Function Translate) + + -- Use the inverse mapping of the one above to return the "translated" + -- unbounded wide string to its original form. + + ASW.Translate(Incantation, Reverse_Code_Map); + + -- The map contained in the following call to Translate contains three + -- elements, and these elements are not found in the unbounded wide + -- string, so this call to Translate should have no effect on it. + + if Incantation /= ASW.Translate(Magic_String, Non_Existent_Map) then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + -- Partial mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abcdeabcab")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyz")) then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + -- Total mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbaaababb")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzz")) then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + -- No mapping of source. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); + + ASW.Translate(Source => Test_String, Mapping => AB_to_YZ_Map); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + -- Map > 2 characters, partial mapping. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("opabcdelmn")); + + ASW.Translate(Test_String, + Wide_Maps.To_Mapping(Equiv("abcde"), Equiv("lmnop"))); + + if Test_String /= ASW.To_Unbounded_Wide_String(Equiv("oplmnoplmn")) then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + + + -- Various degrees of mapping of source (full, partial, none) used + -- with Function Translate. + + if ASW.Translate( + ASW.To_Unbounded_Wide_String(Equiv("abcdeabcabbbaaacaa")), + AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("yzcdeyzcyzzzyyycyy")) or + + ASW.Translate( + ASW.To_Unbounded_Wide_String(Equiv("abbaaababbaaaaba")), + AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("yzzyyyzyzzyyyyzy")) or + + ASW.Translate(ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")), + Mapping => AB_to_YZ_Map) /= + ASW.To_Unbounded_Wide_String(Equiv("cABcABBAc")) or + + ASW.Translate(ASW.To_Unbounded_Wide_String("opabcdelmnddeaccabec"), + Wide_Maps.To_Mapping("abcde", "lmnop")) /= + ASW.To_Unbounded_Wide_String("oplmnoplmnooplnnlmpn") + then + Report.Failed("Incorrect result from Function Translate - 2"); + end if; + + + + -- Procedure Translate using access-to-subprogram mapping. + -- Partial mapping of source. + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abABaABbaBAbba")); + + ASW.Translate(Source => Test_String, -- change equivalent of 'a' and + Mapping => Map_Ptr); -- 'b' to ' ' + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv(" AB AB BA ")) + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 1"); + end if; + + -- Total mapping of source to blanks. + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abbbab")); + + ASW.Translate(Source => Test_String, + Mapping => Map_Ptr); + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 2"); + end if; + + -- No mapping of source. + + Map_Ptr := AB_to_US_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")); + + ASW.Translate(Source => Test_String, + Mapping => Map_Ptr); + + if Test_String /= + ASW.To_Unbounded_Wide_String(Equiv("xyzsypcc")) -- no change + then + Report.Failed + ("Incorrect result from Proc Translate, w/ access value map - 3"); + end if; + + + -- Function Translate using access-to-subprogram mapping value. + + Map_Ptr := AB_to_Blank_Mapping_Function'Access; + + Test_String := ASW.To_Unbounded_Wide_String(Equiv("abAbBBAabbacD")); + + if ASW.Translate(ASW.Translate(Test_String, Map_Ptr), Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" A BBA cD")) + then + Report.Failed + ("Incorrect result from Function Translate, access value map - 1"); + end if; + + if ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) or + ASW.Translate(ASW.To_Unbounded_Wide_String + (Equiv(" aa Aa A AAaaa a aA")), + Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" A A AA A")) or + ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("a ")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv(" ")) or + ASW.Translate(Source => ASW.To_Unbounded_Wide_String(Equiv("xyz")), + Mapping => Map_Ptr) /= + ASW.To_Unbounded_Wide_String(Equiv("xyz")) + then + Report.Failed + ("Incorrect result from Function Translate, access value map - 2"); + end if; + + + + -- Trim + + Trim_Block: + declare + + XYZ_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("xyz")); + PQR_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Equiv("pqr")); + + Pad : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Pad")); + + The_New_Ada : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Ada9X")); + + Space_Array : array (1..4) of ASW.Unbounded_Wide_String := + (ASW.To_Unbounded_Wide_String(Equiv(" Pad ")), + ASW.To_Unbounded_Wide_String(Equiv("Pad ")), + ASW.To_Unbounded_Wide_String(Equiv(" Pad")), + Pad); + + String_Array : array (1..5) of ASW.Unbounded_Wide_String := + (ASW.To_Unbounded_Wide_String(Equiv("xyzxAda9Xpqr")), + ASW.To_Unbounded_Wide_String(Equiv("Ada9Xqqrp")), + ASW.To_Unbounded_Wide_String(Equiv("zxyxAda9Xqpqr")), + ASW.To_Unbounded_Wide_String(Equiv("xxxyAda9X")), + The_New_Ada); + + begin + + -- Examine the version of Trim that removes blanks from + -- the left and/or right of a wide string. + + for i in 1..4 loop + if ASW.Trim(Space_Array(i), Ada.Strings.Both) /= Pad then + Report.Failed("Incorrect result from Trim for spaces - " & + Integer'Image(i)); + end if; + end loop; + + -- Examine the version of Trim that removes set characters from + -- the left and right of a wide string. + + for i in 1..5 loop + if ASW.Trim(String_Array(i), + Left => XYZ_Set, + Right => PQR_Set) /= The_New_Ada then + Report.Failed + ("Incorrect result from Trim for set characters - " & + Integer'Image(i)); + end if; + end loop; + + -- No trimming. + + if ASW.Trim( + ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")), + XYZ_Set, + PQR_Set) /= + ASW.To_Unbounded_Wide_String(Equiv("prqqprAda9Xyzzxyzzyz")) + then + Report.Failed + ("Incorrect result from Trim for set, no trimming"); + end if; + + end Trim_Block; + + + + -- Delete + + -- Use the Delete function to remove the first four and last four + -- characters from the wide string. + + if ASW.Delete(Source => ASW.Delete(Magic_String, + 8, + ASW.Length(Magic_String)), + From => ASW.To_Wide_String(Magic_String)'First, + Through => 4) /= + Cad_String + then + Report.Failed("Incorrect results from Function Delete"); + end if; + + + + -- Constructors ("*") + + Constructor_Block: + declare + + SOS : ASW.Unbounded_Wide_String; + + Dot : constant ASW.Unbounded_Wide_String := + ASW.To_Unbounded_Wide_String(Equiv("Dot_")); + Dash : constant Wide_String := Equiv("Dash_"); + + Distress : ASW.Unbounded_Wide_String := + ASW."&"(ASW.To_Unbounded_Wide_String + (Equiv("Dot_Dot_Dot_")), + ASW."&"(ASW.To_Unbounded_Wide_String + (Equiv("Dash_Dash_Dash_")), + ASW.To_Unbounded_Wide_String + (Equiv("Dot_Dot_Dot")))); + + Repeat : constant Natural := 3; + Separator : constant Wide_Character := Equiv('_'); + + Separator_Set : Wide_Maps.Wide_Character_Set := + Wide_Maps.To_Set(Separator); + + begin + + -- Use the following constructor forms to construct the wide string + -- "Dot_Dot_Dot_Dash_Dash_Dash_Dot_Dot_Dot". Note that the + -- trailing underscore in the wide string is removed in the call to + -- Trim in the If statement condition. + + SOS := ASW."*"(Repeat, Dot); -- "*"(#, W Unb Str) + + SOS := ASW."&"(SOS, + ASW."&"(ASW."*"(Repeat, Dash), -- "*"(#, W Str) + ASW."*"(Repeat, Dot))); -- "*"(#, W Unb Str) + + if ASW.Trim(SOS, Wide_Maps.Null_Set, Separator_Set) /= Distress then + Report.Failed("Incorrect results from Function ""*"""); + end if; + + end Constructor_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4023; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4024.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,350 ---- + -- CXA4024.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function "-", To_Ranges, To_Domain, and To_Range are + -- available in the package Ada.Strings.Maps, and that they produce + -- correct results based on the Character_Set/Character_Mapping input + -- provided. + -- + -- TEST DESCRIPTION: + -- This test examines the operation of four functions from within the + -- Ada.Strings.Maps package. A variety of Character_Sequence, + -- Character_Set, and Character_Mapping objects are created and + -- initialized for use with these functions. In each subtest of + -- function operation, specific inputs are provided to the functions as + -- input parameters, and the results are evaluated against expected + -- values. Wherever appropriate, additional characteristics of the + -- function results are verified against the prescribed result + -- characteristics. + -- + -- + -- CHANGE HISTORY: + -- 03 Feb 95 SAIC Initial prerelease version + -- 10 Mar 95 SAIC Incorporated reviewer comments. + -- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 05 Oct 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + with Ada.Strings.Maps; + with Ada.Strings.Maps.Constants; + with Ada.Characters.Latin_1; + with Report; + + procedure CXA4024 is + + begin + + Report.Test ("CXA4024", "Check that the function ""-"", To_Ranges, " & + "To_Domain, and To_Range are available in " & + "the package Ada.Strings.Maps, and that " & + "they produce correct results"); + + Test_Block: + declare + + use Ada.Strings, Ada.Strings.Maps; + use type Maps.Character_Set; -- To allow logical set operator + -- infix notation. + package ACL1 renames Ada.Characters.Latin_1; + + MidPoint_Letter : constant := 13; + Last_Letter : constant := 26; + + Vowels : constant Maps.Character_Sequence := "aeiou"; + Quasi_Vowel : constant Character := 'y'; + + Alphabet : Maps.Character_Sequence (1..Last_Letter); + Half_Alphabet : Maps.Character_Sequence (1..MidPoint_Letter); + + Alphabet_Set, + Consonant_Set, + Vowel_Set, + First_Half_Set, + Second_Half_Set : Maps.Character_Set; + + + begin + + -- Load the alphabet strings for use in creating sets. + for i in 0..12 loop + Half_Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + for i in 0..25 loop + Alphabet(i+1) := Character'Val(Character'Pos('a') + i); + end loop; + + -- Initialize a series of Character_Set objects. + + Alphabet_Set := Maps.To_Set(Alphabet); + Vowel_Set := Maps.To_Set(Vowels); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + First_Half_Set := Maps.To_Set(Half_Alphabet); + Second_Half_Set := Alphabet_Set XOR First_Half_Set; + + + + -- Evaluation of Set operator "-". + + if Consonant_Set /= "-"(Alphabet_Set, Vowel_Set) or + Vowel_Set /= (Alphabet_Set - Consonant_Set) or + Alphabet_Set /= Alphabet_Set - Maps.Null_Set or + First_Half_Set /= "-"(Alphabet_Set, Second_Half_Set) or + (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) + then + Report.Failed("Incorrect result from ""-"" operator for sets"); + end if; + + + + -- Evaluation of Function "To_Ranges". + + declare + + use type Maps.Character_Range; + use type Maps.Character_Ranges; + + Set_A_to_C : Maps.Character_Set := Maps.To_Set("ABC"); + Set_J : Maps.Character_Set := Maps.To_Set("J"); + Set_M_to_P : Maps.Character_Set := Maps.To_Set("MNOP"); + Set_X_to_Z : Maps.Character_Set := Maps.To_Set("XYZ"); + Set_Of_Five : Maps.Character_Set := Set_A_to_C OR -- Union of the + Set_M_to_P OR -- five sets. + Set_X_to_Z OR + Set_J OR + Maps.Null_Set; + + TC_Range_A_to_C : Maps.Character_Range := (Low => 'A', High => 'C'); + TC_Range_J : Maps.Character_Range := ('J', 'J'); + TC_Range_M_to_P : Maps.Character_Range := ('M', 'P'); + TC_Range_X_to_Z : Maps.Character_Range := (Low => 'X', High => 'Z'); + + TC_Ranges : Maps.Character_Ranges (1..4) := + (1 => TC_Range_A_to_C, + 2 => TC_Range_J, + 3 => TC_Range_M_to_P, + 4 => TC_Range_X_to_Z); + + begin + + -- Based on input of a set containing four separate "spans" of + -- character sequences, Function To_Ranges is required to produce + -- the shortest array of contiguous ranges of Character values in + -- the input set, in increasing order of Low. + + declare + + -- This Character_Ranges constant should consist of array + -- components, each component being a Character_Range from Low + -- to High containing the appropriate characters. + + Ranges_Result : constant Maps.Character_Ranges := + Maps.To_Ranges(Set => Set_Of_Five); + begin + + -- Check the structure and components of the Character_Ranges + -- constant. + + if Ranges_Result(1) /= TC_Range_A_to_C or + Ranges_Result(1).Low /= TC_Ranges(1).Low or + Ranges_Result(2) /= TC_Range_J or + Ranges_Result(2).High /= TC_Ranges(2).High or + Ranges_Result(3) /= TC_Range_M_to_P or + Ranges_Result(3).Low /= TC_Ranges(3).Low or + Ranges_Result(3).High /= TC_Ranges(3).High or + Ranges_Result(4) /= TC_Range_X_To_Z or + Ranges_Result(4).Low /= TC_Ranges(4).Low or + Ranges_Result(4).High /= TC_Ranges(4).High + then + Report.Failed ("Incorrect structure or components in " & + "Character_Ranges constant"); + end if; + + exception + when others => + Report.Failed("Exception raised using the Function To_Ranges " & + "to initialize a Character_Ranges constant"); + end; + end; + + + + -- Evaluation of Functions To_Domain and To_Range. + + declare + + Null_Sequence : constant Maps.Character_Sequence := ""; + + TC_Upper_Case_Sequence : constant Maps.Character_Sequence := + "ZYXWVUTSRQPONMABCDEFGHIJKL"; + TC_Lower_Case_Sequence : constant Maps.Character_Sequence := + "zyxwvutsrqponmabcdefghijkl"; + TC_Unordered_Sequence : Maps.Character_Sequence(1..6) := + "BxACzy"; + + TC_Upper_to_Lower_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Upper_Case_Sequence, + TC_Lower_Case_Sequence); + + TC_Lower_to_Upper_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Lower_Case_Sequence, + TC_Upper_Case_Sequence); + + TC_Unordered_Map : Maps.Character_Mapping := + Maps.To_Mapping(TC_Unordered_Sequence, + "ikglja"); + begin + + declare + + TC_Domain_1 : constant Maps.Character_Sequence := + Maps.To_Domain(TC_Upper_to_Lower_Map); + + TC_Domain_2 : constant Maps.Character_Sequence := + Maps.To_Domain(TC_Lower_to_Upper_Map); + + TC_Domain_3 : Maps.Character_Sequence(1..6); + + TC_Range_1 : constant Maps.Character_Sequence := + Maps.To_Range(TC_Upper_to_Lower_Map); + + TC_Range_2 : constant Maps.Character_Sequence := + Maps.To_Range(TC_Lower_to_Upper_Map); + + TC_Range_3 : Maps.Character_Sequence(1..6); + + begin + + -- Function To_Domain returns the shortest Character_Sequence + -- value such that each character not in the result maps to + -- itself, and all characters in the result are in ascending + -- order. + + TC_Domain_3 := Maps.To_Domain(TC_Unordered_Map); + + -- Check contents of result of To_Domain, must be in ascending + -- order. + + if TC_Domain_1 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + if TC_Domain_2 /= "abcdefghijklmnopqrstuvwxyz" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + if TC_Domain_3 /= "ABCxyz" then + Report.Failed("Incorrect result from To_Domain with " & + "an unordered mapping as input"); + end if; + + + -- The lower bound on the returned Character_Sequence value + -- from To_Domain must be 1. + + if TC_Domain_1'First /= 1 or + TC_Domain_2'First /= 1 or + TC_Domain_3'First /= 1 + then + Report.Failed("Incorrect lower bound returned from To_Domain"); + end if; + + + -- Check contents of result of To_Range. + + TC_Range_3 := Maps.To_Range(TC_Unordered_Map); + + if TC_Range_1 /= "abcdefghijklmnopqrstuvwxyz" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + if TC_Range_2 /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + if TC_Range_3 /= "gilkaj" then + Report.Failed("Incorrect result from To_Range with " & + "an unordered mapping as input"); + end if; + + + -- The lower bound on the returned Character_Sequence value + -- must be 1. + + if TC_Range_1'First /= 1 or + TC_Range_2'First /= 1 or + TC_Range_3'First /= 1 + then + Report.Failed("Incorrect lower bound returned from To_Range"); + end if; + + + -- The upper bound on the returned Character_Sequence value + -- must be Map'Length. + + if TC_Range_1'Last /= TC_Lower_Case_Sequence'Length or + TC_Range_2'Last /= TC_Upper_Case_Sequence'Length or + TC_Range_3'Last /= TC_Unordered_Sequence'Length + then + Report.Failed("Incorrect upper bound returned from To_Range"); + end if; + + end; + + -- Both function To_Domain and To_Range return the null string + -- when provided the Identity character map as an input parameter. + + if Maps.To_Domain(Maps.Identity) /= Null_Sequence then + Report.Failed("Function To_Domain did not return the null " & + "string when provided the Identity map as " & + "input"); + end if; + + if Maps.To_Range(Maps.Identity) /= Null_Sequence then + Report.Failed("Function To_Range did not return the null " & + "string when provided the Identity map as " & + "input"); + end if; + + exception + when others => + Report.Failed("Exception raised during the evaluation of " & + "Function To_Domain and To_Range"); + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4024; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4025.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,376 ---- + -- CXA4025.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functionality found in packages Ada.Strings.Wide_Maps, + -- Ada.Strings.Wide_Fixed, and Ada.Strings.Wide_Maps.Wide_Constants + -- is available and produces correct results. + -- + -- TEST DESCRIPTION: + -- This test validates the subprograms found in the various Wide_Map + -- and Wide_String packages. It is based on the tests CXA4024 and + -- CXA4026, which are tests for the complementary "non-wide" packages. + -- + -- The functions found in CXA4025_0 provide mapping capability, when + -- used in conjunction with Wide_Character_Mapping_Function objects. + -- + -- + -- CHANGE HISTORY: + -- 23 Jun 95 SAIC Initial prerelease version. + -- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + package CXA4025_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; + end CXA4025_0; + + with Ada.Characters.Handling; + package body CXA4025_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + + end CXA4025_0; + + + with CXA4025_0; + with Report; + with Ada.Characters.Handling; + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Strings; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Maps.Wide_Constants; + with Ada.Strings.Wide_Fixed; + + procedure CXA4025 is + begin + Report.Test ("CXA4025", + "Check that subprograms defined in packages " & + "Ada.Strings.Wide_Maps and Ada.Strings.Wide_Fixed " & + "produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + + use Ada.Characters, Ada.Strings; + use Ada.Exceptions; + use type Wide_Maps.Wide_Character_Set; + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + Last_Letter : constant := 26; + Vowels : constant Wide_Maps.Wide_Character_Sequence := "aeiou"; + TC_String : constant Wide_String := "A Standard String"; + + Alphabet : Wide_Maps.Wide_Character_Sequence (1..Last_Letter); + Alphabet_Set, + Consonant_Set, + Vowel_Set : Wide_Maps.Wide_Character_Set; + + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..12) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn & + ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); + + -- Note that there is no upper case version of the last two + -- characters from above. + + TC_New_Character_String : Wide_String(1..12) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn & + ACL1.LC_German_Sharp_S & ACL1.LC_Y_Diaeresis); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4025_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4025_0.Map_To_Upper_Case'Access; + + begin + + -- + -- Testing of functionality found in Package Ada.Strings.Wide_Maps. + -- + + -- Load the alphabet strings for use in creating sets. + for i in 0..25 loop + Alphabet(i+1) := Wide_Character'Val(Wide_Character'Pos('a')+i); + end loop; + + -- Initialize a series of Character_Set objects. + Alphabet_Set := Wide_Maps.To_Set(Alphabet); + Vowel_Set := Wide_Maps.To_Set(Vowels); + Consonant_Set := Vowel_Set XOR Alphabet_Set; + + -- Evaluation of Set operator "-". + if + (Alphabet_Set - Consonant_Set) /= + "AND"(Alphabet_Set, "NOT"(Consonant_Set)) or + (Alphabet_Set - Vowel_Set) /= "AND"(Alphabet_Set, "NOT"(Vowel_Set)) + then + Report.Failed("Incorrect result from ""-"" operator for sets"); + end if; + + -- Evaluation of Functions To_Domain and To_Range. + declare + Null_Sequence : constant Wide_Maps.Wide_Character_Sequence := ""; + TC_UC_Sequence : constant Wide_Maps.Wide_Character_Sequence := + "ZYXWVUTSRQPONMABCDEFGHIJKL"; + TC_LC_Sequence : constant Wide_Maps.Wide_Character_Sequence := + "zyxwvutsrqponmabcdefghijkl"; + TC_Upper_to_Lower_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(TC_UC_Sequence, + TC_LC_Sequence); + TC_Lower_to_Upper_Map : Wide_Maps.Wide_Character_Mapping := + Wide_Maps.To_Mapping(TC_LC_Sequence, + TC_UC_Sequence); + begin + declare + TC_Domain : constant Wide_Maps.Wide_Character_Sequence := + Wide_Maps.To_Domain(TC_Upper_to_Lower_Map); + TC_Range : constant Wide_Maps.Wide_Character_Sequence := + Wide_Maps.To_Range(TC_Lower_to_Upper_Map); + begin + -- Function To_Domain returns the shortest Wide_Character_Sequence + -- value such that each wide character not in the result maps to + -- itself, and all wide characters in the result are in ascending + -- order. + if TC_Domain /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Domain with " & + "TC_Upper_to_Lower_Map as input"); + end if; + + -- The lower bound on the returned Wide_Character_Sequence value + -- from To_Domain must be 1. + if TC_Domain'First /= 1 then + Report.Failed("Incorrect lower bound returned from To_Domain"); + end if; + + -- Check contents of result of To_Range. + if TC_Range /= "ABCDEFGHIJKLMNOPQRSTUVWXYZ" then + Report.Failed("Incorrect result from To_Range with " & + "TC_Lower_to_Upper_Map as input"); + end if; + + -- The lower bound on the returned Character_Sequence value + -- must be 1. + if TC_Range'First /= 1 then + Report.Failed("Incorrect lower bound returned from To_Range"); + end if; + + if TC_Range'Last /= TC_LC_Sequence'Length then + Report.Failed("Incorrect upper bound returned from To_Range"); + end if; + end; + + -- Both function To_Domain and To_Range return the null string + -- when provided the Identity character map as an input parameter. + if Wide_Maps.To_Domain(Wide_Maps.Identity) /= Null_Sequence or + Wide_Maps.To_Range(Wide_Maps.Identity) /= Null_Sequence + then + Report.Failed("Null sequence not returned from To_Domain or " & + "To_Range when provided the Identity map as input"); + end if; + exception + when others => + Report.Failed("Exception raised during the evaluation of " & + "Function To_Domain and To_Range"); + end; + + -- Testing of functionality found in Package Ada.Strings.Wide_Fixed. + -- + -- Function Index, Forward direction search. + + if Wide_Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + Wide_Fixed.Index("STRING WITH NO MATCHING PATTERNS", + "WITH", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Index, Backward direction search. + if Wide_Fixed.Index("Case of a Mixed Case String", + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + Wide_Fixed.Index("WOULD MATCH BUT FOR THE CASE", + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Count. + if Wide_Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or + Wide_Fixed.Count("", "match", Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + -- Function Translate. + if Wide_Fixed.Translate(Source => "A Sample Mixed Case String", + Mapping => Map_To_Lower_Case_Ptr) /= + "a sample mixed case string" or + Wide_Fixed.Translate(New_Character_String, + Map_To_Upper_Case_Ptr) /= + TC_New_Character_String + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Wide_Character Mapping Function parameter"); + end if; + + -- Procedure Translate. + declare + use Ada.Strings.Wide_Fixed; + Str : Wide_String(1..19) := "A Mixed Case String"; + begin + Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); + if Str /= "a mixed case string" then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + end; + + -- Procedure Trim. + declare + use Ada.Strings.Wide_Fixed; + Trim_String : Wide_String(1..30) := " A string of characters "; + begin + Trim(Trim_String, Ada.Strings.Left, Ada.Strings.Right, 'x'); + if Trim_String /= "xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = left, justify = right, pad = x"); + end if; + + Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); + if Trim_String /= " xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = right, justify = center, default pad"); + end if; + end; + + -- Procedure Head. + declare + Fixed_String : Wide_String(1..20) := "A sample test string"; + begin + Wide_Fixed.Head(Source => Fixed_String, Count => 14, + Justify => Ada.Strings.Center, Pad => '$'); + if Fixed_String /= "$$$A sample test $$$" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = center, pad = $"); + end if; + + Wide_Fixed.Head(Fixed_String, 11, Ada.Strings.Right); + if Fixed_String /= " $$$A sample" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = right, default pad"); + end if; + end; + + -- Procedure Tail. + declare + use Ada.Strings.Wide_Fixed; + Tail_String : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + begin + -- Default left justify. + Tail(Source => Tail_String, Count => 10, Pad => '-'); + if Tail_String /= "KLMNOPQRST----------" then + Report.Failed("Incorrect result from Procedure Tail, " & + "default justify, pad = -"); + end if; + + Tail(Tail_String, 6, Ada.Strings.Center, 'a'); + if Tail_String /= "aaaaaaa------aaaaaaa" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = center, pad = a"); + end if; + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA4025; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4026.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,526 ---- + -- CXA4026.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Strings.Fixed procedures Head, Tail, and Trim, as well + -- as the versions of subprograms Translate (procedure and function), + -- Index, and Count, available in the package which use a + -- Maps.Character_Mapping_Function input parameter, produce correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines the operation of several subprograms contained in + -- the Ada.Strings.Fixed package. + -- This includes procedure versions of Head, Tail, and Trim, as well as + -- four subprograms that use a Character_Mapping_Function as a parameter + -- to provide the mapping capability. + -- + -- Two functions are defined to provide the mapping. Access values + -- are defined to refer to these functions. One of the functions will + -- map upper case characters in the range 'A'..'Z' to their lower case + -- counterparts, while the other function will map lower case characters + -- ('a'..'z', or a character whose position is in one of the ranges + -- 223..246 or 248..255, provided the character has an upper case form) + -- to their upper case form. + -- + -- Function Index uses the mapping function access value to map the input + -- string prior to searching for the appropriate index value to return. + -- Function Count uses the mapping function access value to map the input + -- string prior to counting the occurrences of the pattern string. + -- Both the Procedure and Function version of Translate use the mapping + -- function access value to perform the translation. + -- + -- Results of all subprograms are compared with expected results. + -- + -- + -- CHANGE HISTORY: + -- 10 Feb 95 SAIC Initial prerelease version + -- 21 Apr 95 SAIC Modified definition of string variable Str_2. + -- + --! + + + package CXA4026_0 is + + -- Function Map_To_Lower_Case will return the lower case form of + -- Characters in the range 'A'..'Z' only, and return the input + -- character otherwise. + + function Map_To_Lower_Case (From : Character) return Character; + + + -- Function Map_To_Upper_Case will return the upper case form of + -- Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the character has + -- an upper case form. + + function Map_To_Upper_Case (From : Character) return Character; + + end CXA4026_0; + + + with Ada.Characters.Handling; + package body CXA4026_0 is + + function Map_To_Lower_Case (From : Character) return Character is + begin + if From in 'A'..'Z' then + return Character'Val(Character'Pos(From) - + (Character'Pos('A') - Character'Pos('a'))); + else + return From; + end if; + end Map_To_Lower_Case; + + function Map_To_Upper_Case (From : Character) return Character is + begin + return Ada.Characters.Handling.To_Upper(From); + end Map_To_Upper_Case; + + end CXA4026_0; + + + with CXA4026_0; + with Ada.Strings.Fixed; + with Ada.Strings.Maps; + with Ada.Characters.Handling; + with Ada.Characters.Latin_1; + with Report; + + procedure CXA4026 is + + begin + + Report.Test ("CXA4026", "Check that procedures Trim, Head, and Tail, " & + "as well as the versions of subprograms " & + "Translate, Index, and Count, which use the " & + "Character_Mapping_Function input parameter," & + "produce correct results"); + + Test_Block: + declare + + use Ada.Strings, CXA4026_0; + + -- The following strings are used in examination of the Translation + -- subprograms. + + New_Character_String : String(1..10) := + Ada.Characters.Latin_1.LC_A_Grave & + Ada.Characters.Latin_1.LC_A_Ring & + Ada.Characters.Latin_1.LC_AE_Diphthong & + Ada.Characters.Latin_1.LC_C_Cedilla & + Ada.Characters.Latin_1.LC_E_Acute & + Ada.Characters.Latin_1.LC_I_Circumflex & + Ada.Characters.Latin_1.LC_Icelandic_Eth & + Ada.Characters.Latin_1.LC_N_Tilde & + Ada.Characters.Latin_1.LC_O_Oblique_Stroke & + Ada.Characters.Latin_1.LC_Icelandic_Thorn; + + + TC_New_Character_String : String(1..10) := + Ada.Characters.Latin_1.UC_A_Grave & + Ada.Characters.Latin_1.UC_A_Ring & + Ada.Characters.Latin_1.UC_AE_Diphthong & + Ada.Characters.Latin_1.UC_C_Cedilla & + Ada.Characters.Latin_1.UC_E_Acute & + Ada.Characters.Latin_1.UC_I_Circumflex & + Ada.Characters.Latin_1.UC_Icelandic_Eth & + Ada.Characters.Latin_1.UC_N_Tilde & + Ada.Characters.Latin_1.UC_O_Oblique_Stroke & + Ada.Characters.Latin_1.UC_Icelandic_Thorn; + + + -- Functions used to supply mapping capability. + + + -- Access objects that will be provided as parameters to the + -- subprograms. + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Lower_Case'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Upper_Case'Access; + + + begin + + -- Function Index, Forward direction search. + -- Note: Several of the following cases use the default value + -- Forward for the Going parameter. + + if Fixed.Index(Source => "The library package Strings.Fixed", + Pattern => "fix", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 29 or + Fixed.Index("THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN", + "ain", + Mapping => Map_To_Lower_Case_Ptr) /= 6 or + Fixed.Index("maximum number", + "um", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 6 or + Fixed.Index("CoMpLeTeLy MiXeD CaSe StRiNg", + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + Fixed.Index("STRING WITH NO MATCHING PATTERNS", + "WITH", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Index("THIS STRING IS IN UPPER CASE", + "IS", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 3 or + Fixed.Index("", -- Null string. + "is", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Index("AAABBBaaabbb", + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Backward direction search. + + if Fixed.Index("Case of a Mixed Case String", + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + Fixed.Index("Case of a Mixed Case String", + "CASE", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 17 or + Fixed.Index("rain, Rain, and more RAIN", + "rain", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 22 or + Fixed.Index("RIGHT place, right time", + "RIGHT", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 14 or + Fixed.Index("WOULD MATCH BUT FOR THE CASE", + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Fixed; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index("A Valid String", + Null_Pattern_String, + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Count. + + if Fixed.Count(Source => "ABABABA", + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Fixed.Count("ABABABA", "ABA", Map_To_Lower_Case_Ptr) /= 0 or + Fixed.Count("This IS a MISmatched issue", + "is", + Map_To_Lower_Case_Ptr) /= 4 or + Fixed.Count("ABABABA", "ABA", Map_To_Upper_Case_Ptr) /= 2 or + Fixed.Count("This IS a MISmatched issue", + "is", + Map_To_Upper_Case_Ptr) /= 0 or + Fixed.Count("She sells sea shells by the sea shore", + "s", + Map_To_Lower_Case_Ptr) /= 8 or + Fixed.Count("", -- Null string. + "match", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Fixed; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count("A Valid String", + Null_Pattern_String, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character Mapping Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Translate. + + if Fixed.Translate(Source => "A Sample Mixed Case String", + Mapping => Map_To_Lower_Case_Ptr) /= + "a sample mixed case string" or + + Fixed.Translate("ALL LOWER CASE", + Map_To_Lower_Case_Ptr) /= + "all lower case" or + + Fixed.Translate("end with lower case", + Map_To_Lower_Case_Ptr) /= + "end with lower case" or + + Fixed.Translate("", Map_To_Lower_Case_Ptr) /= + "" or + + Fixed.Translate("start with lower case", + Map_To_Upper_Case_Ptr) /= + "START WITH LOWER CASE" or + + Fixed.Translate("ALL UPPER CASE STRING", + Map_To_Upper_Case_Ptr) /= + "ALL UPPER CASE STRING" or + + Fixed.Translate("LoTs Of MiXeD CaSe ChArAcTeRs", + Map_To_Upper_Case_Ptr) /= + "LOTS OF MIXED CASE CHARACTERS" or + + Fixed.Translate("", Map_To_Upper_Case_Ptr) /= + "" or + + Fixed.Translate(New_Character_String, + Map_To_Upper_Case_Ptr) /= + TC_New_Character_String + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Procedure Translate. + + declare + + use Ada.Strings.Fixed; + + Str_1 : String(1..24) := "AN ALL UPPER CASE STRING"; + Str_2 : String(1..19) := "A Mixed Case String"; + Str_3 : String(1..32) := "a string with lower case letters"; + TC_Str_1 : constant String := Str_1; + TC_Str_3 : constant String := Str_3; + + begin + + Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); + + if Str_1 /= "an all upper case string" then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); + + if Str_1 /= TC_Str_1 then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + Translate(Source => Str_2, Mapping => Map_To_Lower_Case_Ptr); + + if Str_2 /= "a mixed case string" then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + Translate(Source => Str_2, Mapping => Map_To_Upper_Case_Ptr); + + if Str_2 /= "A MIXED CASE STRING" then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + Translate(Source => Str_3, Mapping => Map_To_Lower_Case_Ptr); + + if Str_3 /= TC_Str_3 then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + Translate(Source => Str_3, Mapping => Map_To_Upper_Case_Ptr); + + if Str_3 /= "A STRING WITH LOWER CASE LETTERS" then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + end; + + + -- Procedure Trim. + + declare + Use Ada.Strings.Fixed; + Trim_String : String(1..30) := " A string of characters "; + begin + + Trim(Source => Trim_String, + Side => Ada.Strings.Left, + Justify => Ada.Strings.Right, + Pad => 'x'); + + if Trim_String /= "xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = left, justify = right, pad = x"); + end if; + + Trim(Trim_String, Ada.Strings.Right, Ada.Strings.Center); + + if Trim_String /= " xxxxA string of characters " then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = right, justify = center, default pad"); + end if; + + Trim(Trim_String, Ada.Strings.Both, Pad => '*'); + + if Trim_String /= "xxxxA string of characters****" then + Report.Failed("Incorrect result from Procedure Trim, trim " & + "side = both, default justify, pad = *"); + end if; + + end; + + + -- Procedure Head. + + declare + Fixed_String : String(1..20) := "A sample test string"; + begin + + Fixed.Head(Source => Fixed_String, + Count => 14, + Justify => Ada.Strings.Center, + Pad => '$'); + + if Fixed_String /= "$$$A sample test $$$" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = center, pad = $"); + end if; + + Fixed.Head(Fixed_String, 11, Ada.Strings.Right); + + if Fixed_String /= " $$$A sample" then + Report.Failed("Incorrect result from Procedure Head, " & + "justify = right, default pad"); + end if; + + Fixed.Head(Fixed_String, 9, Pad => '*'); + + if Fixed_String /= " ***********" then + Report.Failed("Incorrect result from Procedure Head, " & + "default justify, pad = *"); + end if; + + end; + + + -- Procedure Tail. + + declare + Use Ada.Strings.Fixed; + Tail_String : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + begin + + Tail(Source => Tail_String, Count => 10, Pad => '-'); + + if Tail_String /= "KLMNOPQRST----------" then + Report.Failed("Incorrect result from Procedure Tail, " & + "default justify, pad = -"); + end if; + + Tail(Tail_String, 6, Justify => Ada.Strings.Center, Pad => 'a'); + + if Tail_String /= "aaaaaaa------aaaaaaa" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = center, pad = a"); + end if; + + Tail(Tail_String, 1, Ada.Strings.Right); + + if Tail_String /= " a" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = right, default pad"); + end if; + + Tail(Tail_String, 19, Ada.Strings.Right, 'A'); + + if Tail_String /= "A a" then + Report.Failed("Incorrect result from Procedure Tail, " & + "justify = right, pad = A"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + Report.Result; + + end CXA4026; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4027.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,342 ---- + -- CXA4027.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that versions of Ada.Strings.Bounded subprograms Translate, + -- (procedure and function), Index, and Count, which use the + -- Maps.Character_Mapping_Function input parameter, produce correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines the operation of several subprograms from within + -- the Ada.Strings.Bounded package that use the + -- Character_Mapping_Function mapping parameter to provide a mapping + -- capability. + -- + -- Two functions are defined to provide the mapping. Access values + -- are defined to refer to these functions. One of the functions will + -- map upper case characters in the range 'A'..'Z' to their lower case + -- counterparts, while the other function will map lower case characters + -- ('a'..'z', or a character whose position is in one of the ranges + -- 223..246 or 248..255, provided the character has an upper case form) + -- to their upper case form. + -- + -- Function Index uses the mapping function access value to map the input + -- string prior to searching for the appropriate index value to return. + -- Function Count uses the mapping function access value to map the input + -- string prior to counting the occurrences of the pattern string. + -- Both the Procedure and Function version of Translate use the mapping + -- function access value to perform the translation. + -- + -- + -- CHANGE HISTORY: + -- 16 FEB 95 SAIC Initial prerelease version + -- 17 Jul 95 SAIC Incorporated reviewer comments. Replaced two + -- internally declared functions with two library + -- level functions to eliminate accessibility + -- problems. + -- + --! + + + -- Function CXA4027_0 will return the lower case form of + -- the character input if it is in upper case, and return the input + -- character otherwise. + + with Ada.Characters.Handling; + function CXA4027_0 (From : Character) return Character; + + function CXA4027_0 (From : Character) return Character is + begin + return Ada.Characters.Handling.To_Lower(From); + end CXA4027_0; + + + + -- Function CXA4027_1 will return the upper case form of + -- Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the character has + -- an upper case form. + + with Ada.Characters.Handling; + function CXA4027_1 (From : Character) return Character; + + function CXA4027_1 (From : Character) return Character is + begin + return Ada.Characters.Handling.To_Upper(From); + end CXA4027_1; + + + with CXA4027_0, CXA4027_1; + with Ada.Strings.Bounded; + with Ada.Strings.Maps; + with Ada.Characters.Handling; + with Report; + + procedure CXA4027 is + begin + + Report.Test ("CXA4027", "Check that Ada.Strings.Bounded subprograms " & + "Translate, Index, and Count, which use the " & + "Character_Mapping_Function input parameter, " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Strings; + + -- Functions used to supply mapping capability. + + function Map_To_Lower_Case (From : Character) return Character + renames CXA4027_0; + + function Map_To_Upper_Case (From : Character) return Character + renames CXA4027_1; + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Lower_Case'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Map_To_Upper_Case'Access; + + + -- Instantiations of Bounded String generic package. + + package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + + use type BS1.Bounded_String, BS20.Bounded_String, + BS40.Bounded_String, BS80.Bounded_String; + + String_1 : String(1..1) := "A"; + String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; + String_80 : String(1..80) := String_40 & String_40; + + BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; + BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; + BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; + BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; + + + begin + + -- Function Index. + + if BS40.Index(BS40.To_Bounded_String("Package Strings.Bounded"), + Pattern => "s.b", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 15 or + BS80.Index(BS80.To_Bounded_String("STRING TRANSLATIONS SUBPROGRAMS"), + "tr", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS20.Index(BS20.To_Bounded_String("maximum number"), + "um", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 10 or + BS80.Index(BS80.To_Bounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + BS40.Index(BS40.To_Bounded_String("STRING WITH NO MATCHING PATTERN"), + "WITH", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 or + BS80.Index(BS80.To_Bounded_String("THIS STRING IS IN UPPER CASE"), + "I", + Ada.Strings.Backward, + Map_To_Upper_Case_Ptr) /= 16 or + BS1.Index(BS1.Null_Bounded_String, + "i", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + BS40.Index(BS40.To_Bounded_String("AAABBBaaabbb"), + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS80.Index(BS80.To_Bounded_String("WOULD MATCH BUT FOR THE CASE"), + "WOULD MATCH BUT FOR THE CASE", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, using a " & + "Character Mapping Function parameter"); + end if; + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use BS20; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index(To_Bounded_String("A Valid String"), + "", + Ada.Strings.Forward, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character_Mapping_Function parameter " & + "when given a null pattern string"); + end; + + + -- Function Count. + + if BS20.Count(BS20.To_Bounded_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + BS20.Count(BS20.To_Bounded_String("ABABABA"), + "ABA", + Map_To_Lower_Case_Ptr) /= 0 or + BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), + "is", + Map_To_Lower_Case_Ptr) /= 4 or + BS80.Count(BS80.To_Bounded_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 or + BS40.Count(BS40.To_Bounded_String("This IS a MISmatched issue"), + "is", + Map_To_Upper_Case_Ptr) /= 0 or + BS80.Count(BS80.To_Bounded_String + ("Peter Piper and his Pickled Peppers"), + "p", + Map_To_Lower_Case_Ptr) /= 7 or + BS20.Count(BS20.To_Bounded_String("She sells sea shells"), + "s", + Map_To_Upper_Case_Ptr) /= 0 or + BS80.Count(BS80.To_Bounded_String("No matches what-so-ever"), + "matches", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character_Mapping_Function parameter"); + end if; + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use BS80; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count(To_Bounded_String("A Valid String"), + "", + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character_Mapping_Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character_Mapping_Function parameter " & + "when given a null pattern string"); + end; + + + -- Function Translate. + + if BS40.Translate(BS40.To_Bounded_String("A Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + BS40.To_Bounded_String("a mixed case string") or + + BS20."/="(BS20.Translate(BS20.To_Bounded_String("ALL LOWER CASE"), + Map_To_Lower_Case_Ptr), + "all lower case") or + + BS20."/="("end with lower case", + BS20.Translate( + BS20.To_Bounded_String("end with lower case"), + Map_To_Lower_Case_Ptr)) or + + BS1.Translate(BS1.Null_Bounded_String, + Map_To_Lower_Case_Ptr) /= + BS1.Null_Bounded_String or + + BS80."/="(BS80.Translate(BS80.To_Bounded_String + ("start with lower case, end with upper case"), + Map_To_Upper_Case_Ptr), + "START WITH LOWER CASE, END WITH UPPER CASE") or + + BS40.Translate(BS40.To_Bounded_String("ALL UPPER CASE STRING"), + Map_To_Upper_Case_Ptr) /= + BS40.To_Bounded_String("ALL UPPER CASE STRING") or + + BS80."/="(BS80.Translate(BS80.To_Bounded_String + ("LoTs Of MiXeD CaSe ChArAcTeRs In ThE StRiNg"), + Map_To_Upper_Case_Ptr), + "LOTS OF MIXED CASE CHARACTERS IN THE STRING") + + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character_Mapping_Function parameter"); + end if; + + + -- Procedure Translate. + + BString_1 := BS1.To_Bounded_String("A"); + + BS1.Translate(Source => BString_1, Mapping => Map_To_Lower_Case_Ptr); + + if not BS1."="(BString_1, "a") then -- "=" for Bounded_String, String + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + BString_20 := BS20.To_Bounded_String(String_20); + BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); + + if BString_20 /= BS20.To_Bounded_String("abcdefghijklmnopqrst") then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + BString_40 := BS40.To_Bounded_String("String needing highlighting"); + BS40.Translate(BString_40, Map_To_Upper_Case_Ptr); + + if not (BString_40 = "STRING NEEDING HIGHLIGHTING") then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + BString_80 := BS80.Null_Bounded_String; + BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); + + if not (BString_80 = BS80.Null_Bounded_String) then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4027; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4028.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,331 ---- + -- CXA4028.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Strings.Bounded procedures Append, Head, Tail, and + -- Trim, and relational operator functions "=", ">", ">=", "<", "<=" + -- with parameter combinations of type String and Bounded_String, + -- produce correct results. + -- + -- TEST DESCRIPTION: + -- This test examines the operation of several subprograms from within + -- the Ada.Strings.Bounded package. Four different instantiations of + -- Ada.Strings.Bounded.Generic_Bounded_Length provide packages defined + -- to manipulate bounded strings of lengths 1, 20, 40, and 80. + -- Examples of the above mentioned procedures and relational operators + -- from each of these instantiations are tested, with results compared + -- against expected output. + -- + -- Testing of the function versions of many of the subprograms tested + -- here is performed in tests CXA4006-CXA4009. + -- + -- + -- CHANGE HISTORY: + -- 16 Feb 95 SAIC Initial prerelease version + -- 10 Mar 95 SAIC Incorporated reviewer comments. + -- 15 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + with Ada.Exceptions; + with Ada.Strings.Bounded; + with Report; + + procedure CXA4028 is + + begin + + Report.Test ("CXA4028", "Check that Ada.Strings.Bounded procedures " & + "Append, Head, Tail, and Trim, and relational " & + "operator functions =, >, >=, <, <= with " & + "parameter combinations of type String and " & + "Bounded_String, produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Strings; + + -- Instantiations of Bounded String generic package. + + package BS1 is new Ada.Strings.Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Bounded.Generic_Bounded_Length(80); + + use type BS1.Bounded_String, BS20.Bounded_String, + BS40.Bounded_String, BS80.Bounded_String; + + String_1 : String(1..1) := "A"; + String_20 : String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : String(1..40) := "abcdefghijklmnopqrst" & String_20; + String_80 : String(1..80) := String_40 & String_40; + + BString_1 : BS1.Bounded_String := BS1.Null_Bounded_String; + BString_20 : BS20.Bounded_String := BS20.Null_Bounded_String; + BString_40 : BS40.Bounded_String := BS40.Null_Bounded_String; + BString_80 : BS80.Bounded_String := BS80.Null_Bounded_String; + + begin + + -- Procedure Append. + + declare + use BS1, BS20; + begin + Append(Source => BString_1, New_Item => To_Bounded_String("A")); + Append(BString_1, "B", Ada.Strings.Left); + Append(BString_1, 'C', Drop => Ada.Strings.Right); -- Drop appended + -- character. + if BString_1 /= To_Bounded_String("B") then + Report.Failed("Incorrect results from BS1 versions of " & + "procedure Append"); + end if; + + Append(BString_20, 'T'); -- Character. + Append(BString_20, "his string"); -- String. + Append(BString_20, + To_Bounded_String(" is complete."), -- Bounded string. + Drop => Ada.Strings.Right); -- Drop 4 characters. + + if BString_20 /= To_Bounded_String("This string is compl") then + Report.Failed("Incorrect results from BS20 versions of " & + "procedure Append"); + end if; + end; + + + -- Operator "=". + + BString_40 := BS40.To_Bounded_String(String_40); + BString_80 := BS80.To_Bounded_String( + BS40.To_String(BString_40) & + BS40.To_String(BString_40)); + + if not (BString_40 = String_40 and -- (Bounded_String, String) + BS80."="(String_80, BString_80)) -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator "<". + + BString_1 := BS1.To_Bounded_String("cat", -- string "c" only. + Drop => Ada.Strings.Right); + BString_20 := BS20.To_Bounded_String("Santa Claus"); + + if BString_1 < "C" or -- (Bounded_String, String) + BS1."<"(BString_1,"c") or -- (Bounded_String, String) + "x" < BString_1 or -- (String, Bounded_String) + BString_20 < "Santa " or -- (Bounded_String, String) + "Santa and his Elves" < BString_20 -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""<"" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator "<=". + + BString_20 := BS20.To_Bounded_String("Sample string"); + + if BString_20 <= "Sample strin" or -- (Bounded_String, String) + "sample string" <= BString_20 or -- (String, Bounded_String) + not("Sample string" <= BString_20) -- (String, Bounded_String) + then + Report.Failed("Incorrect results from function ""<="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator ">". + + BString_40 := BS40.To_Bounded_String("A MUCH LONGER SAMPLE STRING."); + + if BString_40 > "A much longer sample string" or -- (Bnd_Str, Str) + String_20 > BS40.To_Bounded_String(String_40) or -- (Str, Bnd_Str) + BS40.To_Bounded_String("ABCDEFGH") > "abcdefgh" -- (Str, Bnd_Str) + then + Report.Failed("Incorrect results from function "">"" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Operator ">=". + + BString_80 := BS80.To_Bounded_String(String_80); + + if not (BString_80 >= String_80 and + BS80.To_Bounded_String("Programming") >= "PROGRAMMING" and + "test" >= BS80.To_Bounded_String("tess")) + then + Report.Failed("Incorrect results from function "">="" with " & + "string - bounded string parameter combinations"); + end if; + + + -- Procedure Trim + + BString_20 := BS20.To_Bounded_String(" Left Spaces "); + BS20.Trim(Source => BString_20, + Side => Ada.Strings.Left); + + if "Left Spaces " /= BString_20 then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Left"); + end if; + + BString_40 := BS40.To_Bounded_String(" Right Spaces "); + BS40.Trim(BString_40, Side => Ada.Strings.Right); + + if BString_40 /= " Right Spaces" then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Right"); + end if; + + BString_20 := BS20.To_Bounded_String(" Both Sides "); + BS20.Trim(BString_20, Ada.Strings.Both); + + if BString_20 /= BS20.To_Bounded_String("Both Sides") then + Report.Failed("Incorrect results from Procedure Trim with " & + "Side = Both"); + end if; + + BString_80 := BS80.To_Bounded_String("Centered Spaces"); + BS80.Trim(BString_80, Ada.Strings.Both); + + if BString_80 /= BS80.To_Bounded_String("Centered Spaces") then + Report.Failed("Incorrect results from Procedure Trim with " & + "no blank spaces on the ends of the string"); + end if; + + + -- Procedure Head + + BString_40 := BS40.To_Bounded_String("Test String"); + BS40.Head(Source => BString_40, + Count => 4); -- Count < Source'Length + + if BString_40 /= BS40.To_Bounded_String("Test") then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter less than Source'Length"); + end if; + + BString_1 := BS1.To_Bounded_String("X"); + BS1.Head(BString_1, BS1.Length(BString_1)); -- Count = Source'Length + + if BString_1 /= "X" then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter equal to Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Sample string"); + BS20.Head(BString_20, + Count => BS20.Max_Length, -- Count > Source'Length + Pad => '*'); + + if BString_20 /= BS20.To_Bounded_String("Sample string*******") then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Twenty Characters 20"); + BS20.Head(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); + + if BString_20 /= "enty Characters 20**" then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Left"); + end if; + + BString_20 := BS20.To_Bounded_String("Short String"); + BS20.Head(BString_20, 23, '-', Ada.Strings.Right); + + if ("Short String--------") /= BString_20 then + Report.Failed("Incorrect results from Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + + -- Procedure Tail + + BString_40 := BS40.To_Bounded_String("Test String"); + BS40.Tail(Source => BString_40, + Count => 6); -- Count < Source'Length + + if BString_40 /= BS40.To_Bounded_String("String") then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter less than Source'Length"); + end if; + + BString_1 := BS1.To_Bounded_String("X"); + BS1.Tail(BString_1, BS1.Length(BString_1)); -- Count = Source'Length + + if BString_1 /= "X" then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter equal to Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Sample string"); + BS20.Tail(BString_20, + Count => BS20.Max_Length, -- Count > Source'Length + Pad => '*'); + + if BString_20 /= BS20.To_Bounded_String("*******Sample string") then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_String("Twenty Characters"); -- Len = 17 + BS20.Tail(BString_20, 22, Pad => '*', Drop => Ada.Strings.Left); + + if BString_20 /= "***Twenty Characters" then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Left"); + end if; + + BString_20 := BS20.To_Bounded_String("Maximum Length Chars"); + BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); + + if ("---Maximum Length Ch") /= BString_20 then + Report.Failed("Incorrect results from Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA4028; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4029.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,333 ---- + -- CXA4029.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functionality found in packages Ada.Strings.Wide_Maps, + -- Ada.Strings.Wide_Bounded, and Ada.Strings.Wide_Maps.Wide_Constants + -- is available and produces correct results. + -- + -- TEST DESCRIPTION: + -- This test tests the subprograms found in the + -- Ada.Strings.Wide_Bounded package. It is based on the tests + -- CXA4027-28, which are tests for the complementary "non-wide" + -- packages. + -- + -- The functions found in CXA4029_0 provide mapping capability, when + -- used in conjunction with Wide_Character_Mapping_Function objects. + -- + -- + -- CHANGE HISTORY: + -- 23 Jun 95 SAIC Initial prerelease version. + -- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + package CXA4029_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; + end CXA4029_0; + + with Ada.Characters.Handling; + package body CXA4029_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + + end CXA4029_0; + + + with CXA4029_0; + with Report; + with Ada.Characters.Handling; + with Ada.Characters.Latin_1; + with Ada.Strings; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Maps.Wide_Constants; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Bounded; + + procedure CXA4029 is + begin + Report.Test ("CXA4029", + "Check that subprograms defined in package " & + "Ada.Strings.Wide_Bounded produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + package BS1 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(1); + package BS20 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(20); + package BS40 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(40); + package BS80 is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length(80); + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + use Ada.Characters, Ada.Strings; + use type Wide_Maps.Wide_Character_Set; + use type BS1.Bounded_Wide_String, BS20.Bounded_Wide_String, + BS40.Bounded_Wide_String, BS80.Bounded_Wide_String; + + TC_String : constant Wide_String := "A Standard String"; + + BString_1 : BS1.Bounded_Wide_String := + BS1.Null_Bounded_Wide_String; + BString_20 : BS20.Bounded_Wide_String := + BS20.Null_Bounded_Wide_String; + BString_40 : BS40.Bounded_Wide_String := + BS40.Null_Bounded_Wide_String; + BString_80 : BS80.Bounded_Wide_String := + BS80.Null_Bounded_Wide_String; + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); + + TC_New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4029_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4029_0.Map_To_Upper_Case'Access; + + begin + + -- Testing of functionality found in Package Ada.Strings.Wide_Bounded. + -- + -- Function Index. + + if BS80.Index(BS80.To_Bounded_Wide_String("CoMpLeTeLy MiXeD CaSe"), + "MIXED CASE", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + BS1.Index(BS1.Null_Bounded_Wide_String, + "i", + Mapping => Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from BND Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + -- Function Count. + if BS40.Count(BS40.To_Bounded_Wide_String("This IS a MISmatched issue"), + "is", + Map_To_Lower_Case_Ptr) /= 4 or + BS80.Count(BS80.To_Bounded_Wide_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 + then + Report.Failed("Incorrect results from BND Function Count, using " & + "a Character_Mapping_Function parameter"); + end if; + + -- Function Translate. + if BS40.Translate(BS40.To_Bounded_Wide_String("A Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + BS40.To_Bounded_Wide_String("a mixed case string") or + BS20."/="("end with lower case", + BS20.Translate( + BS20.To_Bounded_Wide_String("end with lower case"), + Map_To_Lower_Case_Ptr)) + then + Report.Failed("Incorrect results from BND Function Translate, " & + "using a Character_Mapping_Function parameter"); + end if; + + -- Procedure Translate. + BString_20 := BS20.To_Bounded_Wide_String(String_20); + BS20.Translate(BString_20, Mapping => Map_To_Lower_Case_Ptr); + if BString_20 /= BS20.To_Bounded_Wide_String("abcdefghijklmnopqrst") + then + Report.Failed("Incorrect result from BND Procedure Translate - 1"); + end if; + + BString_80 := BS80.Null_Bounded_Wide_String; + BS80.Translate(BString_80, Map_To_Upper_Case_Ptr); + if not (BString_80 = BS80.Null_Bounded_Wide_String) then + Report.Failed("Incorrect result from BND Procedure Translate - 2"); + end if; + + -- Procedure Append. + declare + use BS20; + begin + BString_20 := BS20.Null_Bounded_Wide_String; + Append(BString_20, 'T'); + Append(BString_20, "his string"); + Append(BString_20, + To_Bounded_Wide_String(" is complete."), + Drop => Ada.Strings.Right); -- Drop 4 characters. + if BString_20 /= To_Bounded_Wide_String("This string is compl") then + Report.Failed("Incorrect results from BS20 versions of " & + "procedure Append"); + end if; + exception + when others => Report.Failed("Exception raised in block checking " & + "BND Procedure Append"); + end; + + -- Operator "=". + BString_40 := BS40.To_Bounded_Wide_String(String_40); + BString_80 := BS80.To_Bounded_Wide_String( + BS40.To_Wide_String(BString_40) & + BS40.To_Wide_String(BString_40)); + if not (BString_40 = String_40 and + BS80."="(String_80, BString_80)) then + Report.Failed("Incorrect results from BND Function ""="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator "<". + BString_1 := BS1.To_Bounded_Wide_String("cat", + Drop => Ada.Strings.Right); + BString_20 := BS20.To_Bounded_Wide_String("Santa Claus"); + if BString_1 < "C" or + BS1."<"(BString_1,"c") or + BS1."<"("x", BString_1) or + BS20."<"(BString_20,"Santa ") or + BS20."<"("Santa and his Elves", BString_20) + then + Report.Failed("Incorrect results from BND Function ""<"" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator "<=". + BString_20 := BS20.To_Bounded_Wide_String("Sample string"); + if BS20."<="(BString_20,"Sample strin") or + not(BS20."<="("Sample string",BString_20)) + then + Report.Failed("Incorrect results from BND Function ""<="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator ">". + BString_40 := BS40.To_Bounded_Wide_String( + "A MUCH LONGER SAMPLE STRING."); + if BString_40 > "A much longer sample string" or + BS40.To_Bounded_Wide_String("ABCDEFGH") > "abcdefgh" + then + Report.Failed("Incorrect results from BND Function "">"" with " & + "string - bounded string parameter combinations"); + end if; + + -- Operator ">=". + BString_80 := BS80.To_Bounded_Wide_String(String_80); + if not (BString_80 >= String_80 and + BS80.To_Bounded_Wide_String("Programming") >= "PROGRAMMING" and + BS80.">="("test", BS80.To_Bounded_Wide_String("tess"))) + then + Report.Failed("Incorrect results from BND Function "">="" with " & + "string - bounded string parameter combinations"); + end if; + + -- Procedure Trim + BString_20 := BS20.To_Bounded_Wide_String(" Both Sides "); + BS20.Trim(BString_20, Ada.Strings.Both); + if BString_20 /= BS20.To_Bounded_Wide_String("Both Sides") then + Report.Failed("Incorrect results from BND Procedure Trim with " & + "Side = Both"); + end if; + + -- Procedure Head + BString_40 := BS40.To_Bounded_Wide_String("Test String"); + BS40.Head(Source => BString_40, + Count => 4); -- Count < Source'Length + if BString_40 /= BS40.To_Bounded_Wide_String("Test") then + Report.Failed("Incorrect results from BND Procedure Head with " & + "the Count parameter less than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_Wide_String("Short String"); + BS20.Head(BString_20, 23, '-', Ada.Strings.Right); + if BS20.To_Bounded_Wide_String("Short String--------") /= BString_20 then + Report.Failed("Incorrect results from BND Procedure Head with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + -- Procedure Tail + BString_40 := BS40.To_Bounded_Wide_String("Test String"); + BS40.Tail(Source => BString_40, + Count => 6); + if BString_40 /= BS40.To_Bounded_Wide_String("String") then + Report.Failed("Incorrect results from BND Procedure Tail with " & + "the Count parameter less than Source'Length"); + end if; + + BString_20 := BS20.To_Bounded_Wide_String("Maximum Length Chars"); + BS20.Tail(BString_20, 23, '-', Ada.Strings.Right); + if BS20.To_Bounded_Wide_String("---Maximum Length Ch") /= BString_20 then + Report.Failed("Incorrect results from BND Procedure Tail with " & + "the Count parameter greater than Source'Length, " & + "and the Drop parameter = Right"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4029; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4030.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,414 ---- + -- CXA4030.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Strings.Unbounded versions of subprograms Translate + -- (procedure and function), Index, and Count, which use a + -- Maps.Character_Mapping_Function input parameter, produce correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines the operation of the four subprograms contained + -- in the Ada.Strings.Unbounded package that use a + -- Character_Mapping_Function parameter to provide the mapping + -- capability. + -- Two Character_Mapping_Function objects are defined that reference + -- subprograms contained in the Ada.Characters.Handling package; + -- To_Lower will return the lower-case form of the character provided + -- as the input parameter, To_Upper will return the upper-case form + -- of the character input parameter (provided there is an upper-case + -- form). + -- In several instances in this test, the character handling functions + -- are referenced directly in the parameter list of the subprograms + -- under test, demonstrating another form of expected common usage. + -- + -- Results of all subprograms are compared with expected results. + -- + -- This test, when taken in conjunction with tests CXA4010, CXA4011, + -- CXA4031, and CXA4032 will constitute a test of all the functionality + -- contained in package Ada.Strings.Unbounded. This test uses a variety + -- of the subprograms defined in the unbounded string package in ways + -- typical of common usage. + -- + -- + -- CHANGE HISTORY: + -- 21 Feb 95 SAIC Initial prerelease version + -- 21 Apr 95 SAIC Modified header commentary. + -- + --! + + with Ada.Strings.Unbounded; + with Ada.Strings.Maps; + with Ada.Characters.Handling; + with Ada.Characters.Latin_1; + with Report; + + procedure CXA4030 is + + begin + + Report.Test ("CXA4030", "Check that Ada.Strings.Unbounded versions " & + "of subprograms Translate (procedure and " & + "function), Index, and Count, which use a " & + "Maps.Character_Mapping_Function input " & + "parameter, produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use type Unb.Unbounded_String; + use Ada.Strings; + use Ada.Characters; + + + -- The following strings are used in examination of the Translation + -- subprograms. + + New_Character_String : Unb.Unbounded_String := + Unb.To_Unbounded_String( + Latin_1.LC_A_Grave & + Latin_1.LC_A_Ring & + Latin_1.LC_AE_Diphthong & + Latin_1.LC_C_Cedilla & + Latin_1.LC_E_Acute & + Latin_1.LC_I_Circumflex & + Latin_1.LC_Icelandic_Eth & + Latin_1.LC_N_Tilde & + Latin_1.LC_O_Oblique_Stroke & + Latin_1.LC_Icelandic_Thorn); + + + TC_New_Character_String : Unb.Unbounded_String := + Unb.To_Unbounded_String( + Latin_1.UC_A_Grave & + Latin_1.UC_A_Ring & + Latin_1.UC_AE_Diphthong & + Latin_1.UC_C_Cedilla & + Latin_1.UC_E_Acute & + Latin_1.UC_I_Circumflex & + Latin_1.UC_Icelandic_Eth & + Latin_1.UC_N_Tilde & + Latin_1.UC_O_Oblique_Stroke & + Latin_1.UC_Icelandic_Thorn); + + + -- In this test, access objects are defined to refer to two functions + -- from the Ada.Characters.Handling package. These access objects + -- will be provided as parameters to the subprograms under test. + -- Note: There will be several examples in this test of these character + -- handling functions being referenced directly within the + -- parameter list of the subprograms under test. + + Map_To_Lower_Case_Ptr : Maps.Character_Mapping_Function := + Handling.To_Lower'Access; + + Map_To_Upper_Case_Ptr : Maps.Character_Mapping_Function := + Handling.To_Upper'Access; + + begin + + -- Function Index, Forward direction search. + -- Note: Several of the following cases use the default value + -- Forward for the Going parameter. + + if Unb.Index(Source => Unb.To_Unbounded_String( + "The library package Strings.Unbounded"), + Pattern => "unb", + Going => Ada.Strings.Forward, + Mapping => Map_To_Lower_Case_Ptr) /= 29 or + + Unb.Index(Unb.To_Unbounded_String( + "THE RAIN IN SPAIN FALLS MAINLY ON THE PLAIN"), + "ain", + Mapping => Map_To_Lower_Case_Ptr) /= 6 or + + Unb.Index(Unb.To_Unbounded_String("maximum number"), + "um", + Ada.Strings.Forward, + Handling.To_Lower'Access) /= 6 or + + Unb.Index(Unb.To_Unbounded_String("CoMpLeTeLy MiXeD CaSe StRiNg"), + "MIXED CASE STRING", + Ada.Strings.Forward, + Map_To_Upper_Case_Ptr) /= 12 or + + Unb.Index(Unb.To_Unbounded_String( + "STRING WITH NO MATCHING PATTERNS"), + "WITH", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Index(Unb.To_Unbounded_String("THIS STRING IS IN UPPER CASE"), + "IS", + Ada.Strings.Forward, + Handling.To_Upper'Access) /= 3 or + + Unb.Index(Unb.Null_Unbounded_String, + "is", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Index(Unb.To_Unbounded_String("AAABBBaaabbb"), + "aabb", + Mapping => Handling.To_Lower'Access) /= 2 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Forward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Backward direction search. + + if Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 or + + Unb.Index(Unb.To_Unbounded_String("Case of a Mixed Case String"), + "CASE", + Ada.Strings.Backward, + Mapping => Map_To_Upper_Case_Ptr) /= 17 or + + Unb.Index(Unb.To_Unbounded_String("rain, Rain, and more RAIN"), + "rain", + Ada.Strings.Backward, + Handling.To_Lower'Access) /= 22 or + + Unb.Index(Unb.To_Unbounded_String("RIGHT place, right time"), + "RIGHT", + Ada.Strings.Backward, + Handling.To_Upper'Access) /= 14 or + + Unb.Index(Unb.To_Unbounded_String("WOULD MATCH BUT FOR THE CASE"), + "WOULD MATCH BUT FOR THE CASE", + Going => Ada.Strings.Backward, + Mapping => Map_To_Lower_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Index, going " & + "in Backward direction, using a Character Mapping " & + "Function parameter"); + end if; + + + + -- Function Index, Pattern_Error if Pattern = Null_String + + declare + use Unbounded; + Null_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Index(To_Unbounded_String("A Valid Unbounded String"), + Null_String, + Going => Ada.Strings.Forward, + Mapping => Handling.To_Lower'Access); + Report.Failed("Pattern_Error not raised by Function Index when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Index " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Count. + + if Unb.Count(Source => Unb.To_Unbounded_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + + Unb.Count(Unb.To_Unbounded_String("ABABABA"), + "ABA", + Mapping => Map_To_Lower_Case_Ptr) /= 0 or + + Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), + "is", + Handling.To_Lower'Access) /= 4 or + + Unb.Count(Unb.To_Unbounded_String("ABABABA"), + "ABA", + Map_To_Upper_Case_Ptr) /= 2 or + + Unb.Count(Unb.To_Unbounded_String("This IS a MISmatched issue"), + "is", + Mapping => Map_To_Upper_Case_Ptr) /= 0 or + + Unb.Count(Unb.To_Unbounded_String( + "She sells sea shells by the sea shore"), + "s", + Handling.To_Lower'Access) /= 8 or + + Unb.Count(Unb.Null_Unbounded_String, + "match", + Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Function Count, Pattern_Error if Pattern = Null_String + + declare + use Ada.Strings.Unbounded; + Null_Pattern_String : constant String := ""; + TC_Natural : Natural := 1000; + begin + TC_Natural := Count(To_Unbounded_String("A Valid String"), + Null_Pattern_String, + Map_To_Lower_Case_Ptr); + Report.Failed("Pattern_Error not raised by Function Count using " & + "a Character Mapping Function parameter when " & + "given a null pattern string"); + exception + when Pattern_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Count " & + "using a Character Mapping Function parameter " & + "when given a null pattern string"); + end; + + + + -- Function Translate. + + if Unb.Translate(Source => Unb.To_Unbounded_String( + "A Sample Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + Unb.To_Unbounded_String("a sample mixed case string") or + + Unb.Translate(Unb.To_Unbounded_String("ALL LOWER CASE"), + Handling.To_Lower'Access) /= + Unb.To_Unbounded_String("all lower case") or + + Unb.Translate(Unb.To_Unbounded_String("end with lower case"), + Map_To_Lower_Case_Ptr) /= + Unb.To_Unbounded_String("end with lower case") or + + Unb.Translate(Unb.Null_Unbounded_String, + Handling.To_Lower'Access) /= + Unb.Null_Unbounded_String or + + Unb.Translate(Unb.To_Unbounded_String("start with lower case"), + Map_To_Upper_Case_Ptr) /= + Unb.To_Unbounded_String("START WITH LOWER CASE") or + + Unb.Translate(Unb.To_Unbounded_String("ALL UPPER CASE STRING"), + Handling.To_Upper'Access) /= + Unb.To_Unbounded_String("ALL UPPER CASE STRING") or + + Unb.Translate(Unb.To_Unbounded_String( + "LoTs Of MiXeD CaSe ChArAcTeRs"), + Map_To_Upper_Case_Ptr) /= + Unb.To_Unbounded_String("LOTS OF MIXED CASE CHARACTERS") or + + Unb.Translate(New_Character_String, + Handling.To_Upper'Access) /= + TC_New_Character_String + + then + Report.Failed("Incorrect results from Function Translate, using " & + "a Character Mapping Function parameter"); + end if; + + + + -- Procedure Translate. + + declare + + use Ada.Strings.Unbounded; + use Ada.Characters.Handling; + + Str_1 : Unbounded_String := + To_Unbounded_String("AN ALL UPPER CASE STRING"); + Str_2 : Unbounded_String := + To_Unbounded_String("A Mixed Case String"); + Str_3 : Unbounded_String := + To_Unbounded_String("a string with lower case letters"); + TC_Str_1 : constant Unbounded_String := Str_1; + TC_Str_3 : constant Unbounded_String := Str_3; + + begin + + Translate(Source => Str_1, Mapping => Map_To_Lower_Case_Ptr); + + if Str_1 /= To_Unbounded_String("an all upper case string") then + Report.Failed("Incorrect result from Procedure Translate - 1"); + end if; + + Translate(Source => Str_1, Mapping => Map_To_Upper_Case_Ptr); + + if Str_1 /= TC_Str_1 then + Report.Failed("Incorrect result from Procedure Translate - 2"); + end if; + + Translate(Str_2, Mapping => Map_To_Lower_Case_Ptr); + + if Str_2 /= To_Unbounded_String("a mixed case string") then + Report.Failed("Incorrect result from Procedure Translate - 3"); + end if; + + Translate(Str_2, Mapping => To_Upper'Access); + + if Str_2 /= To_Unbounded_String("A MIXED CASE STRING") then + Report.Failed("Incorrect result from Procedure Translate - 4"); + end if; + + Translate(Str_3, To_Lower'Access); + + if Str_3 /= TC_Str_3 then + Report.Failed("Incorrect result from Procedure Translate - 5"); + end if; + + Translate(Str_3, To_Upper'Access); + + if Str_3 /= + To_Unbounded_String("A STRING WITH LOWER CASE LETTERS") + then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + Translate(New_Character_String, Map_To_Upper_Case_Ptr); + + if New_Character_String /= TC_New_Character_String then + Report.Failed("Incorrect result from Procedure Translate - 6"); + end if; + + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4030; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4031.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,291 ---- + -- CXA4031.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Strings.Unbounded + -- are available, and that they produce correct results. Specifically, + -- check the functions To_Unbounded_String (version with Length + -- parameter), "=", "<", "<=", ">", ">=" (all with String-Unbounded + -- String parameter mix), as well as three versions of Procedure Append. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the subprograms defined + -- in package Ada.Strings.Unbounded for use with unbounded strings. + -- The test simulates how unbounded strings could be processed in a + -- user environment, using the subprograms provided in this package. + -- + -- This test, when taken in conjunction with tests CXA4010, CXA4011, + -- CXA4030, and CXA4032 will constitute a test of all the functionality + -- contained in package Ada.Strings.Unbounded. This test uses a variety + -- of the subprograms defined in the unbounded string package in ways + -- typical of common usage. + -- + -- + -- CHANGE HISTORY: + -- 27 Feb 95 SAIC Initial prerelease version. + -- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + with Report; + with Ada.Exceptions; + with Ada.Strings.Maps; + with Ada.Strings.Unbounded; + + procedure CXA4031 is + begin + + Report.Test ("CXA4031", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use Unb; + use Ada.Exceptions; + + subtype LC_Characters is Character range 'a'..'z'; + + Null_String : constant String := ""; + TC_String : constant String := "A Standard String"; + + TC_Unb_String, + TC_New_Unb_String : Unb.Unbounded_String := Unb.Null_Unbounded_String; + + begin + + -- Function To_Unbounded_String (version with Length parameter) + -- returns an unbounded string that represents an uninitialized String + -- whose length is Length. + -- Note: Unbounded_String length can vary conceptually between 0 and + -- Natural'Last. + + if Unb.Length(Unb.To_Unbounded_String(Length => 10)) /= 10 or + Unb.Length(Unb.To_Unbounded_String(1)) /= 1 or + Unb.Length(Unb.To_Unbounded_String(0)) /= 0 or + Unb.Length(Unb."&"(Unb.To_Unbounded_String(Length => 10), + Unb."&"(Unb.To_Unbounded_String(1), + Unb.To_Unbounded_String(0) ))) /= 10+1+0 + then + Report.Failed + ("Incorrect results from Function To_Unbounded_String with " & + "Length parameter"); + end if; + + + -- Procedure Append (Unbounded - Unbounded) + -- Note: For each of the Append procedures, the resulting string + -- represented by the Source parameter is given by the + -- concatenation of the original value of Source and the value + -- of New_Item. + + TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); + TC_New_Unb_String := Unb.To_Unbounded_String(" and then some"); + + Unb.Append(Source => TC_Unb_String, New_Item => TC_New_Unb_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Sample string of length L and then some") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 1"); + end if; + + + TC_Unb_String := Unb.To_Unbounded_String("Sample string of length L"); + TC_New_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, TC_New_Unb_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Sample string of length L") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 2"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, + Unb.To_Unbounded_String("New Unbounded String")); + + if TC_Unb_String /= + Unb.To_Unbounded_String("New Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded string parameters - 3"); + end if; + + + -- Procedure Append (Unbounded - String) + + TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String and "); + + Unb.Append(Source => TC_Unb_String, New_Item => TC_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("An Unbounded String and A Standard String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 1"); + end if; + + + TC_Unb_String := Unb.To_Unbounded_String("An Unbounded String"); + + Unb.Append(TC_Unb_String, New_Item => Null_String); + + if TC_Unb_String /= + Unb.To_Unbounded_String("An Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 2"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, TC_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("A Standard String") then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a string " & + "parameter - 3"); + end if; + + + -- Procedure Append (Unbounded - Character) + + TC_Unb_String := Unb.To_Unbounded_String("Lower Case = "); + + for i in LC_Characters'Range loop + Unb.Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); + end loop; + + if TC_Unb_String /= + Unb.To_Unbounded_String("Lower Case = abcdefghijklmnopqrstuvwxyz") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a character " & + "parameter - 1"); + end if; + + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Append(TC_Unb_String, New_Item => 'a'); + + if TC_Unb_String /= Unb.To_Unbounded_String("a") then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded string parameter and a character " & + "parameter - 2"); + end if; + + + -- Function "=" + + TC_Unb_String := Unb.To_Unbounded_String(TC_String); + + if not (TC_Unb_String = TC_String) or -- (Unb_Str, Str) + not Unb."="("A Standard String", TC_Unb_String) or -- (Str, Unb_Str) + not ((Unb.Null_Unbounded_String = "") and -- (Unb_Str, Str) + ("Test String" = -- (Str, Unb_Str) + Unb.To_Unbounded_String("Test String"))) + then + Report.Failed("Incorrect results from function ""="" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function "<" + + if not ("Extra Space" < Unb.To_Unbounded_String("Extra Space ") and + Unb.To_Unbounded_String("tess") < "test" and + Unb.To_Unbounded_String("best") < "test") or + Unb.Null_Unbounded_String < Null_String or + " leading blank" < Unb.To_Unbounded_String(" leading blank") or + "ending blank " < Unb.To_Unbounded_String("ending blank ") + then + Report.Failed("Incorrect results from function ""<"" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function "<=" + + TC_Unb_String := Unb.To_Unbounded_String("Sample string"); + + if TC_Unb_String <= "Sample strin" or -- (Unb_Str, Str) + "sample string" <= TC_Unb_String or -- (Str, Unb_Str) + not(Unb.Null_Unbounded_String <= "") or -- (Unb_Str, Str) + not("Sample string" <= TC_Unb_String) -- (Str, Unb_Str) + then + Report.Failed("Incorrect results from function ""<="" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function ">" + + TC_Unb_String := Unb.To_Unbounded_String("A MUCH LONGER STRING"); + + if not ("A much longer string" > TC_Unb_String and + Unb.To_Unbounded_String(TC_String) > "A Standard Strin" and + "abcdefgh" > Unb.To_Unbounded_String("ABCDEFGH")) or + Unb.Null_Unbounded_String > Null_String + then + Report.Failed("Incorrect results from function "">"" with " & + "string - unbounded string parameter combinations"); + end if; + + + -- Function ">=" + + TC_Unb_String := Unb.To_Unbounded_String(TC_String); + + if not (TC_Unb_String >= TC_String and + Null_String >= Unb.Null_Unbounded_String and + "test" >= Unb.To_Unbounded_String("tess") and + Unb.To_Unbounded_String("Programming") >= "PROGRAMMING") + then + Report.Failed("Incorrect results from function "">="" with " & + "string - unbounded string parameter combinations"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA4031; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4032.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,457 ---- + -- CXA4032.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that procedures defined in package Ada.Strings.Unbounded + -- are available, and that they produce correct results. Specifically, + -- check the procedures Replace_Slice, Insert, Overwrite, Delete, + -- Trim (2 versions), Head, and Tail. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of many of the procedures defined + -- in package Ada.Strings.Unbounded for use with unbounded strings. + -- The test simulates how unbounded strings could be processed in a + -- user environment, using the procedures provided in this package. + -- + -- This test, when taken in conjunction with tests CXA4010, CXA4011, + -- CXA4030, and CXA4031 will constitute a test of all the functionality + -- contained in package Ada.Strings.Unbounded. This test uses a variety + -- of the procedures defined in the unbounded string package in ways + -- typical of common usage. + -- + -- + -- CHANGE HISTORY: + -- 02 Mar 95 SAIC Initial prerelease version. + -- + --! + + with Report; + with Ada.Strings; + with Ada.Strings.Maps; + with Ada.Strings.Maps.Constants; + with Ada.Strings.Unbounded; + + procedure CXA4032 is + begin + + Report.Test ("CXA4032", "Check that the subprograms defined in " & + "package Ada.Strings.Unbounded are available, " & + "and that they produce correct results"); + + Test_Block: + declare + + package Unb renames Ada.Strings.Unbounded; + use Unb; + use Ada.Strings; + + TC_Null_String : constant String := ""; + TC_String_5 : String(1..5) := "ABCDE"; + + TC_Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String("Test String"); + + begin + + -- Procedure Replace_Slice + + begin -- Low > Source'Last+1 + Unb.Replace_Slice(Source => TC_Unb_String, + Low => Unb.Length(TC_Unb_String) + 2, + High => Unb.Length(TC_Unb_String), + By => TC_String_5); + Report.Failed("Index_Error not raised by Replace_Slice when Low " & + "> Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Replace_Slice" & + "when Low > Source'Last+1"); + end; + + -- High >= Low + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); + + if TC_Unb_String /= Unb.To_Unbounded_String("TestABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 1"); + end if; + + Unb.Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 2"); + end if; + + Unb.Replace_Slice(TC_Unb_String, + 11, + Unb.Length(TC_Unb_String), + TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 3"); + end if; + + -- High < Low + + Unb.Replace_Slice(TC_Unb_String, Low => 4, High => 1, By => "xxx"); + + if TC_Unb_String /= Unb.To_Unbounded_String("ABCxxxDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 4"); + end if; + + Unb.Replace_Slice(TC_Unb_String, Low => 1, High => 0, By => "yyy"); + + if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDE") then + Report.Failed("Incorrect results from Replace_Slice - 5"); + end if; + + Unb.Replace_Slice(TC_Unb_String, + Unb.Length(TC_Unb_String) + 1, + Unb.Length(TC_Unb_String), + By => "zzz"); + + if TC_Unb_String /= Unb.To_Unbounded_String("yyyABCxxxDEABCDEzzz") then + Report.Failed("Incorrect results from Replace_Slice - 6"); + end if; + + + -- Procedure Insert + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + begin -- Before not in Source'First..Source'Last + 1 + Unb.Insert(Source => TC_Unb_String, + Before => Unb.Length(TC_Unb_String) + 2, + New_Item => TC_String_5); + Report.Failed("Index_Error not raised by Insert when Before " & + "not in the range Source'First..Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Insert when Before not in " & + "the range Source'First..Source'Last+1"); + end; + + Unb.Insert(TC_Unb_String, 1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test String") then + Report.Failed("Incorrect results from Insert - 1"); + end if; + + Unb.Insert(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test String**") then + Report.Failed("Incorrect results from Insert - 2"); + end if; + + Unb.Insert(TC_Unb_String, 8, "---"); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then + Report.Failed("Incorrect results from Insert - 3"); + end if; + + Unb.Insert(TC_Unb_String, 3, TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("**Test ---String**") then + Report.Failed("Incorrect results from Insert - 4"); + end if; + + + -- Procedure Overwrite + + begin -- Position not in Source'First..Source'Last + 1 + Unb.Overwrite(Source => TC_Unb_String, + Position => Unb.Length(TC_Unb_String) + 2, + New_Item => TC_String_5); + Report.Failed("Index_Error not raised by Overwrite when Position " & + "not in the range Source'First..Source'Last+1"); + exception + when Index_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Overwrite when Position not " & + "in the range Source'First..Source'Last+1"); + end; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Overwrite(Source => TC_Unb_String, + Position => 1, + New_Item => "XXXX"); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String") then + Report.Failed("Incorrect results from Overwrite - 1"); + end if; + + Unb.Overwrite(TC_Unb_String, Unb.Length(TC_Unb_String)+1, "**"); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then + Report.Failed("Incorrect results from Overwrite - 2"); + end if; + + Unb.Overwrite(TC_Unb_String, 3, TC_Null_String); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXXX String**") then + Report.Failed("Incorrect results from Overwrite - 3"); + end if; + + Unb.Overwrite(TC_Unb_String, 1, "abcdefghijklmn"); + + if TC_Unb_String /= Unb.To_Unbounded_String("abcdefghijklmn") then + Report.Failed("Incorrect results from Overwrite - 4"); + end if; + + + -- Procedure Delete + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + -- From > Through (No change to Source) + + Unb.Delete(Source => TC_Unb_String, + From => Unb.Length(TC_Unb_String), + Through => Unb.Length(TC_Unb_String)-1); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Delete - 1"); + end if; + + Unb.Delete(TC_Unb_String, 1, 0); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Delete - 2"); + end if; + + -- From <= Through + + Unb.Delete(TC_Unb_String, 1, 5); + + if TC_Unb_String /= Unb.To_Unbounded_String("String") then + Report.Failed("Incorrect results from Delete - 3"); + end if; + + Unb.Delete(TC_Unb_String, 3, 3); + + if TC_Unb_String /= Unb.To_Unbounded_String("Sting") then + Report.Failed("Incorrect results from Delete - 4"); + end if; + + + -- Procedure Trim + + TC_Unb_String := Unb.To_Unbounded_String("No Spaces"); + + Unb.Trim(Source => TC_Unb_String, Side => Ada.Strings.Both); + + if TC_Unb_String /= Unb.To_Unbounded_String("No Spaces") then + Report.Failed("Incorrect results from Trim - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String(" Leading Spaces "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Left); + + if TC_Unb_String /= Unb.To_Unbounded_String("Leading Spaces ") then + Report.Failed("Incorrect results from Trim - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String(" Ending Spaces "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Right); + + if TC_Unb_String /= Unb.To_Unbounded_String(" Ending Spaces") then + Report.Failed("Incorrect results from Trim - 3"); + end if; + + TC_Unb_String := + Unb.To_Unbounded_String(" Spaces on both ends "); + + Unb.Trim(TC_Unb_String, Ada.Strings.Both); + + if TC_Unb_String /= + Unb.To_Unbounded_String("Spaces on both ends") + then + Report.Failed("Incorrect results from Trim - 4"); + end if; + + + -- Procedure Trim (with Character Set parameters) + + TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); + + Unb.Trim(Source => TC_Unb_String, + Left => Ada.Strings.Maps.Constants.Lower_Set, + Right => Ada.Strings.Maps.Constants.Lower_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("CASE") then + Report.Failed("Incorrect results from Trim with Sets - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("lowerCASEletters"); + + Unb.Trim(TC_Unb_String, + Ada.Strings.Maps.Constants.Upper_Set, + Ada.Strings.Maps.Constants.Upper_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("lowerCASEletters") then + Report.Failed("Incorrect results from Trim with Sets - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("012abcdefghGFEDCBA789ab"); + + Unb.Trim(TC_Unb_String, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set, + Ada.Strings.Maps.Constants.Hexadecimal_Digit_Set); + + if TC_Unb_String /= Unb.To_Unbounded_String("ghG") then + Report.Failed("Incorrect results from Trim with Sets - 3"); + end if; + + + -- Procedure Head + + -- Count <= Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => 0, + Pad => '*'); + + if TC_Unb_String /= Unb.Null_Unbounded_String then + Report.Failed("Incorrect results from Head - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => 4, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test") then + Report.Failed("Incorrect results from Head - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String), + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Head - 3"); + end if; + + -- Count > Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 4, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String****") then + Report.Failed("Incorrect results from Head - 4"); + end if; + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Head(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 3, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("***") then + Report.Failed("Incorrect results from Head - 5"); + end if; + + + -- Procedure Tail + + -- Count <= Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => 0, + Pad => '*'); + + if TC_Unb_String /= Unb.Null_Unbounded_String then + Report.Failed("Incorrect results from Tail - 1"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => 6, + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("String") then + Report.Failed("Incorrect results from Tail - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String), + Pad => '*'); + + if TC_Unb_String /= Unb.To_Unbounded_String("Test String") then + Report.Failed("Incorrect results from Tail - 3"); + end if; + + -- Count > Source'Length + + TC_Unb_String := Unb.To_Unbounded_String("Test String"); + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 5, + Pad => 'x'); + + if TC_Unb_String /= Unb.To_Unbounded_String("xxxxxTest String") then + Report.Failed("Incorrect results from Tail - 4"); + end if; + + TC_Unb_String := Unb.Null_Unbounded_String; + + Unb.Tail(Source => TC_Unb_String, + Count => Unb.Length(TC_Unb_String) + 3, + Pad => 'X'); + + if TC_Unb_String /= Unb.To_Unbounded_String("XXX") then + Report.Failed("Incorrect results from Tail - 5"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4032; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4033.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,405 ---- + -- CXA4033.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functionality found in packages Ada.Strings.Wide_Maps, + -- Ada.Strings.Wide_Unbounded, and Ada.Strings.Wide_Maps.Wide_Constants + -- is available and produces correct results. + -- + -- TEST DESCRIPTION: + -- This test tests the subprograms found in the + -- Ada.Strings.Wide_Unbounded package. It is based on the tests + -- CXA4030-32, which are tests for the complementary "non-wide" + -- packages. + -- + -- The functions found in CXA4033_0 provide mapping capability, when + -- used in conjunction with Wide_Character_Mapping_Function objects. + -- + -- + -- CHANGE HISTORY: + -- 23 Jun 95 SAIC Initial prerelease version. + -- 24 Feb 97 PWB.CTA Removed attempt to create wide string of length + -- Natural'Last + --! + + package CXA4033_0 is + -- Functions used to supply mapping capability. + function Map_To_Lower_Case (From : Wide_Character) return Wide_Character; + function Map_To_Upper_Case (From : Wide_Character) return Wide_Character; + end CXA4033_0; + + with Ada.Characters.Handling; + package body CXA4033_0 is + -- Function Map_To_Lower_Case will return the lower case form of + -- Wide_Characters in the range 'A'..'Z' only, and return the input + -- wide_character otherwise. + + function Map_To_Lower_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Lower( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Lower_Case; + + -- Function Map_To_Upper_Case will return the upper case form of + -- Wide_Characters in the range 'a'..'z', or whose position is in one + -- of the ranges 223..246 or 248..255, provided the wide_character has + -- an upper case form. + + function Map_To_Upper_Case (From : Wide_Character) + return Wide_Character is + begin + return Ada.Characters.Handling.To_Wide_Character( + Ada.Characters.Handling.To_Upper( + Ada.Characters.Handling.To_Character(From))); + end Map_To_Upper_Case; + + end CXA4033_0; + + + with CXA4033_0; + with Report; + with Ada.Characters.Handling; + with Ada.Characters.Latin_1; + with Ada.Strings; + with Ada.Strings.Wide_Maps; + with Ada.Strings.Wide_Maps.Wide_Constants; + with Ada.Strings.Wide_Fixed; + with Ada.Strings.Wide_Unbounded; + + procedure CXA4033 is + begin + Report.Test ("CXA4033", + "Check that subprograms defined in the package " & + "Ada.Strings.Wide_Unbounded produce correct results"); + + Test_Block: + declare + + package ACL1 renames Ada.Characters.Latin_1; + package Unb renames Ada.Strings.Wide_Unbounded; + + subtype LC_Characters is Wide_Character range 'a'..'z'; + + use Ada.Characters, Ada.Strings, Unb; + use type Wide_Maps.Wide_Character_Set; + + TC_String : constant Wide_String := "A Standard String"; + + String_20 : Wide_String(1..20) := "ABCDEFGHIJKLMNOPQRST"; + String_40 : Wide_String(1..40) := "abcdefghijklmnopqrst" & + String_20; + String_80 : Wide_String(1..80) := String_40 & String_40; + TC_String_5 : Wide_String(1..5) := "ABCDE"; + TC_Unb_String : Unbounded_Wide_String := Null_Unbounded_Wide_String; + + -- The following strings are used in examination of the Translation + -- subprograms. + New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.LC_A_Grave & ACL1.LC_A_Ring & ACL1.LC_AE_Diphthong & + ACL1.LC_C_Cedilla & ACL1.LC_E_Acute & ACL1.LC_I_Circumflex & + ACL1.LC_Icelandic_Eth & ACL1.LC_N_Tilde & + ACL1.LC_O_Oblique_Stroke & ACL1.LC_Icelandic_Thorn); + + TC_New_Character_String : Wide_String(1..10) := + Handling.To_Wide_String( + ACL1.UC_A_Grave & ACL1.UC_A_Ring & ACL1.UC_AE_Diphthong & + ACL1.UC_C_Cedilla & ACL1.UC_E_Acute & ACL1.UC_I_Circumflex & + ACL1.UC_Icelandic_Eth & ACL1.UC_N_Tilde & + ACL1.UC_O_Oblique_Stroke & ACL1.UC_Icelandic_Thorn); + + New_UB_Character_String : Unbounded_Wide_String := + To_Unbounded_Wide_String(New_Character_String); + + TC_New_UB_Character_String : Unbounded_Wide_String := + To_Unbounded_Wide_String(TC_New_Character_String); + + -- Access objects that will be provided as parameters to the + -- subprograms. + Map_To_Lower_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4033_0.Map_To_Lower_Case'Access; + Map_To_Upper_Case_Ptr : Wide_Maps.Wide_Character_Mapping_Function := + CXA4033_0.Map_To_Upper_Case'Access; + + begin + + -- Testing functionality found in Package Ada.Strings.Wide_Unbounded. + -- + -- Function Index. + + if Index(To_Unbounded_Wide_String("AAABBBaaabbb"), + "aabb", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Index(To_Unbounded_Wide_String("Case of a Mixed Case String"), + "case", + Ada.Strings.Backward, + Map_To_Lower_Case_Ptr) /= 17 + then + Report.Failed("Incorrect results from Function Index, " & + "using a Wide Character Mapping Function parameter"); + end if; + + -- Function Count. + if Count(Source => To_Unbounded_Wide_String("ABABABA"), + Pattern => "aba", + Mapping => Map_To_Lower_Case_Ptr) /= 2 or + Count(Null_Unbounded_Wide_String, "mat", Map_To_Upper_Case_Ptr) /= 0 + then + Report.Failed("Incorrect results from Function Count, using " & + "a Character Mapping Function parameter"); + end if; + + -- Function Translate. + if Translate(To_Unbounded_Wide_String("A Sample Mixed Case String"), + Mapping => Map_To_Lower_Case_Ptr) /= + To_Unbounded_Wide_String("a sample mixed case string") or + Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr) /= + TC_New_UB_Character_String + then + Report.Failed("Incorrect results from Function Translate, " & + "using a Character Mapping Function parameter"); + end if; + + -- Procedure Translate. + declare + use Ada.Characters.Handling; + Str : Unbounded_Wide_String := + To_Unbounded_Wide_String("AN ALL UPPER CASE STRING"); + begin + Translate(Source => Str, Mapping => Map_To_Lower_Case_Ptr); + if Str /= To_Unbounded_Wide_String("an all upper case string") then + Report.Failed("Incorrect result from Procedure Translate 1"); + end if; + + Translate(New_UB_Character_String, Map_To_Upper_Case_Ptr); + if New_UB_Character_String /= TC_New_UB_Character_String then + Report.Failed("Incorrect result from Procedure Translate 2"); + end if; + end; + + -- Function To_Unbounded_Wide_String (version with Length parameter) + if Length(To_Unbounded_Wide_String(Length => 10)) /= 10 or + Length(To_Unbounded_Wide_String(0)) /= 0 or + Length( To_Unbounded_Wide_String(10) & + To_Unbounded_Wide_String(1) & + To_Unbounded_Wide_String(0) ) /= 10 + 1 + 0 + then + Report.Failed + ("Incorrect results from Function To_Unbounded_Wide_String " & + "with Length parameter"); + end if; + + -- Procedure Append (Wide_Unbounded - Wide_Unbounded) + TC_Unb_String := Null_Unbounded_Wide_String; + Append(TC_Unb_String, To_Unbounded_Wide_String("New Unbounded String")); + if TC_Unb_String /= To_Unbounded_Wide_String("New Unbounded String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "unbounded wide string parameters"); + end if; + + + -- Procedure Append (Wide_Unbounded - Wide_String) + TC_Unb_String := To_Unbounded_Wide_String("An Unbounded String and "); + Append(Source => TC_Unb_String, New_Item => TC_String); + if TC_Unb_String /= + To_Unbounded_Wide_String("An Unbounded String and A Standard String") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded wide string parameter and a wide " & + "string parameter"); + end if; + + -- Procedure Append (Wide_Unbounded - Wide_Character) + TC_Unb_String := To_Unbounded_Wide_String("Lower Case = "); + for i in LC_Characters'Range loop + Append(Source => TC_Unb_String, New_Item => LC_Characters(i)); + end loop; + if TC_Unb_String /= + Unb.To_Unbounded_Wide_String + ("Lower Case = abcdefghijklmnopqrstuvwxyz") + then + Report.Failed("Incorrect results from Procedure Append with " & + "an unbounded wide string parameter and a wide " & + "character parameter"); + end if; + + -- Function "=" + TC_Unb_String := To_Unbounded_Wide_String(TC_String); + if not (TC_Unb_String = TC_String) or + not "="("A Standard String", TC_Unb_String) or + not ((Null_Unbounded_Wide_String = "") and + ("Test String" = To_Unbounded_Wide_String("Test String"))) + then + Report.Failed("Incorrect results from Function ""="" with " & + "wide_string - unbounded wide string parameters"); + end if; + + -- Function "<" + if not ("Extra Space" < To_Unbounded_Wide_String("Extra Space ") and + To_Unbounded_Wide_String("tess") < "test" and + To_Unbounded_Wide_String("best") < "test") + then + Report.Failed("Incorrect results from Function ""<"" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function "<=" + TC_Unb_String := To_Unbounded_Wide_String("Sample string"); + if TC_Unb_String <= "Sample strin" or + not("Sample string" <= TC_Unb_String) + then + Report.Failed("Incorrect results from Function ""<="" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function ">" + TC_Unb_String := To_Unbounded_Wide_String("A MUCH LONGER STRING"); + if not ("A much longer string" > TC_Unb_String and + To_Unbounded_Wide_String(TC_String) > "A Standard Strin" and + "abcdefgh" > To_Unbounded_Wide_String("ABCDEFGH")) + then + Report.Failed("Incorrect results from Function "">"" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Function ">=" + TC_Unb_String := To_Unbounded_Wide_String(TC_String); + if not (TC_Unb_String >= TC_String and + "test" >= To_Unbounded_Wide_String("tess") and + To_Unbounded_Wide_String("Programming") >= "PROGRAMMING") + then + Report.Failed("Incorrect results from Function "">="" with " & + "wide string - unbounded wide string parameters"); + end if; + + -- Procedure Replace_Slice + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Replace_Slice(TC_Unb_String, 5, 5, TC_String_5); + if TC_Unb_String /= To_Unbounded_Wide_String("TestABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 1"); + end if; + + Replace_Slice(TC_Unb_String, 1, 4, TC_String_5); + if TC_Unb_String /= To_Unbounded_Wide_String("ABCDEABCDEString") then + Report.Failed("Incorrect results from Replace_Slice - 2"); + end if; + + -- Procedure Insert + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Insert(TC_Unb_String, 1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("**Test String") then + Report.Failed("Incorrect results from Procedure Insert - 1"); + end if; + + Insert(TC_Unb_String, Length(TC_Unb_String)+1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("**Test String**") then + Report.Failed("Incorrect results from Procedure Insert - 2"); + end if; + + -- Procedure Overwrite + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Overwrite(TC_Unb_String, 1, New_Item => "XXXX"); + if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String") then + Report.Failed("Incorrect results from Procedure Overwrite - 1"); + end if; + + Overwrite(TC_Unb_String, Length(TC_Unb_String)+1, "**"); + if TC_Unb_String /= To_Unbounded_Wide_String("XXXX String**") then + Report.Failed("Incorrect results from Procedure Overwrite - 2"); + end if; + + -- Procedure Delete + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Delete(TC_Unb_String, 1, 0); + if TC_Unb_String /= To_Unbounded_Wide_String("Test String") then + Report.Failed("Incorrect results from Procedure Delete - 1"); + end if; + + Delete(TC_Unb_String, 1, 5); + if TC_Unb_String /= To_Unbounded_Wide_String("String") then + Report.Failed("Incorrect results from Procedure Delete - 2"); + end if; + + -- Procedure Trim + TC_Unb_String := To_Unbounded_Wide_String(" Leading Spaces "); + Trim(TC_Unb_String, Ada.Strings.Left); + if TC_Unb_String /= To_Unbounded_Wide_String("Leading Spaces ") then + Report.Failed("Incorrect results from Procedure Trim - 1"); + end if; + + TC_Unb_String := + To_Unbounded_Wide_String(" Spaces on both ends "); + Trim(TC_Unb_String, Ada.Strings.Both); + if TC_Unb_String /= + To_Unbounded_Wide_String("Spaces on both ends") + then + Report.Failed("Incorrect results from Procedure Trim - 2"); + end if; + + -- Procedure Trim (with Wide_Character_Set parameters) + TC_Unb_String := To_Unbounded_Wide_String("012abcdefghGFEDCBA789ab"); + Trim(TC_Unb_String, + Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set, + Ada.Strings.Wide_Maps.Wide_Constants.Hexadecimal_Digit_Set); + if TC_Unb_String /= To_Unbounded_Wide_String("ghG") then + Report.Failed("Incorrect results from Procedure Trim with Sets"); + end if; + + -- Procedure Head + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Head(Source => TC_Unb_String, Count => 0, Pad => '*'); + if TC_Unb_String /= Null_Unbounded_Wide_String then + Report.Failed("Incorrect results from Procedure Head - 1"); + end if; + + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Head(Source => TC_Unb_String, Count => 4, Pad => '*'); + if TC_Unb_String /= To_Unbounded_Wide_String("Test") then + Report.Failed("Incorrect results from Procedure Head - 2"); + end if; + + -- Procedure Tail + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Tail(Source => TC_Unb_String, Count => 0, Pad => '*'); + if TC_Unb_String /= Null_Unbounded_Wide_String then + Report.Failed("Incorrect results from Procedure Tail - 1"); + end if; + + TC_Unb_String := To_Unbounded_Wide_String("Test String"); + Tail(TC_Unb_String, Length(TC_Unb_String) + 5, 'x'); + if TC_Unb_String /= To_Unbounded_Wide_String("xxxxxTest String") then + Report.Failed("Incorrect results from Procedure Tail - 2"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA4033; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa4034.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,281 ---- + -- CXA4034.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Strings.Bounded.Slice raises Index_Error if + -- High > Length (Source) or Low > Length (Source) + 1. + -- (Defect Report 8652/0049). + -- + -- Check that Ada.Strings.Wide_Bounded.Slice raises Index_Error if + -- High > Length (Source) or Low > Length (Source) + 1. + -- + -- CHANGE HISTORY: + -- 12 FEB 2001 PHL Initial version + -- 14 MAR 2001 RLB Added Wide_Bounded subtest. + -- + --! + with Ada.Exceptions; + use Ada.Exceptions; + with Ada.Strings.Bounded; + with Ada.Strings.Wide_Bounded; + use Ada.Strings; + with Report; + use Report; + procedure CXA4034 is + + package Bs is new Ada.Strings.Bounded.Generic_Bounded_Length (40); + + package WBs is new Ada.Strings.Wide_Bounded.Generic_Bounded_Length (32); + + Source : String (Ident_Int (1) .. Ident_Int (30)); + + Wide_Source : Wide_String (Ident_Int (1) .. Ident_Int (24)); + + X : Bs.Bounded_String; + + WX : WBs.Bounded_Wide_String; + + begin + Test ("CXA4034", + "Check that Slice raises Index_Error if either Low or High is " & + "greater than the Length(Source) for Ada.Strings.Bounded and " & + "Ada.Strings.Wide_Bounded"); + + -- Fill Source with "ABC..." + for I in Source'Range loop + Source (I) := Ident_Char (Character'Val (I + + Character'Pos ('A') - Source'First)); + end loop; + -- and W with "ABC..." + for I in Wide_Source'Range loop + Wide_Source (I) := Ident_Wide_Char (Wide_Character'Val (I + + Wide_Character'Pos ('A') - Wide_Source'First)); + end loop; + + X := Bs.To_Bounded_String (Source); + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (28), High => Ident_Int (41)); + begin + Failed ("No exception raised by Slice - 1"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 1"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (8), High => Ident_Int (31)); + begin + Failed ("No exception raised by Slice - 2"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 2"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (15), High => Ident_Int (30)); + begin + if S /= Source(15..30) then + Failed ("Wrong result - 3"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 3"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (42), High => Ident_Int (28)); + begin + Failed ("No exception raised by Slice - 4"); + if S = Source then + Comment ("Don't optimize S"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 4"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (31), High => Ident_Int (28)); + begin + if S /= "" then + Failed ("Wrong result - 5"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 5"); + end; + + begin + declare + S : constant String := + Bs.Slice (X, Low => Ident_Int (30), High => Ident_Int (30)); + begin + if S /= Source(30..30) then + Failed ("Wrong result - 6"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 6"); + end; + + WX := WBs.To_Bounded_Wide_String (Wide_Source); + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (21), High => Ident_Int (33)); + begin + Failed ("No exception raised by Slice - 7"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 7"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (8), High => Ident_Int (25)); + begin + Failed ("No exception raised by Slice - 8"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 8"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (15), High => Ident_Int (24)); + begin + if W /= Wide_Source(15..24) then + Failed ("Wrong result - 8"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 9"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (36), High => Ident_Int (20)); + begin + Failed ("No exception raised by Slice - 10"); + if W = Wide_Source then + Comment ("Don't optimize W"); + end if; + end; + exception + when Index_Error => + null; -- Expected exception. + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 10"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (25), High => Ident_Int (21)); + begin + if W /= "" then + Failed ("Wrong result - 11"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 11"); + end; + + begin + declare + W : constant Wide_String := + WBs.Slice (WX, Low => Ident_Int (24), High => Ident_Int (24)); + begin + if W /= Wide_Source(24..24) then + Failed ("Wrong result - 12"); + end if; + end; + exception + when E: others => + Failed ("Exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E) & " - 12"); + end; + + Result; + end CXA4034; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5011.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,471 ---- + -- CXA5011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for both Float_Random and Discrete_Random packages, + -- the following are true: + -- 1) two objects of type Generator are initialized to the same state. + -- 2) when the Function Reset is used to reset two generators + -- to different time-dependent states, the resulting random values + -- from each generator are different. + -- 3) when the Function Reset uses the same integer initiator + -- to reset two generators to the same state, the resulting random + -- values from each generator are identical. + -- 4) when the Function Reset uses different integer initiator + -- values to reset two generators, the resulting random numbers are + -- different. + -- + -- TEST DESCRIPTION: + -- This test evaluates components of the Ada.Numerics.Float_Random and + -- Ada.Numerics.Discrete_Random packages. + -- This test checks to see that objects of type Generator are initialized + -- to the same state. In addition, the functionality of Function Reset is + -- validated. + -- For each of the objectives above, evaluation of the various generators + -- is performed using each of the following techniques. When the states of + -- two generators are to be compared, each state is saved, then + -- transformed to a bounded-string variable. The bounded-strings can + -- then be compared for equality. In this case, matching bounded-strings + -- are evidence that the states of two generators are the same. + -- In addition, two generators are compared by evaluating a series of + -- random numbers they produce. A matching series of random numbers + -- implies that the generators were in the same state prior to producing + -- the numbers. + -- + -- + -- CHANGE HISTORY: + -- 20 Apr 95 SAIC Initial prerelease version. + -- 07 Jul 95 SAIC Incorporated reviewer comments/suggestions. + -- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 17 Aug 96 SAIC Deleted Subtest #2. + -- 09 Feb 01 RLB Repaired to work on implementations with a 16-bit + -- Integer. + + --! + + with Ada.Exceptions; + with Ada.Numerics.Float_Random; + with Ada.Numerics.Discrete_Random; + with Ada.Strings.Bounded; + with ImpDef; + with Report; + + procedure CXA5011 is + begin + + Report.Test ("CXA5011", "Check the effect of Function Reset on the " & + "state of random number generators"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use Ada.Strings.Bounded; + + -- Declare an modular subtype, and use it to instantiate the discrete + -- random number generator generic package. + + type Discrete_Range is mod 2**(Integer'Size-1); + package Discrete_Package is new Discrete_Random(Discrete_Range); + + -- Declaration of random number generator objects. + + Discrete_Generator_1, + Discrete_Generator_2 : Discrete_Package.Generator; + Float_Generator_1, + Float_Generator_2 : Float_Random.Generator; + + -- Declaration of bounded string packages instantiated with the + -- value of Max_Image_Width constant from each random number generator + -- package, and bounded string variables used to hold the image of + -- random number generator states. + + package Discrete_String_Pack is + new Generic_Bounded_Length(Discrete_Package.Max_Image_Width); + + package Float_String_Pack is + new Generic_Bounded_Length(Float_Random.Max_Image_Width); + + use Discrete_String_Pack, Float_String_Pack; + + TC_Seed : Integer; + TC_Max_Loop_Count : constant Natural := 1000; + Allowed_Matches : constant Natural := 2; + -- + -- In a sequence of TC_Max_Loop_Count random numbers that should + -- not match, some may match by chance. Up to Allowed_Matches + -- numbers may match before the test is considered to fail. + -- + + + procedure Check_Float_State (Gen_1, Gen_2 : Float_Random.Generator; + Sub_Test : Integer; + States_Should_Match : Boolean) is + + use type Float_Random.State; + + State_1, + State_2 : Float_Random.State; + + State_String_1, + State_String_2 : Float_String_Pack.Bounded_String := + Float_String_Pack.Null_Bounded_String; + begin + + Float_Random.Save(Gen => Gen_1, To_State => State_1); + Float_Random.Save(Gen_2, State_2); + + State_String_1 := + Float_String_Pack.To_Bounded_String(Source => + Float_Random.Image(Of_State => State_1)); + + State_String_2 := + Float_String_Pack.To_Bounded_String(Float_Random.Image(State_2)); + + case States_Should_Match is + when True => + if State_1 /= State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Float generators " & + "are not the same"); + end if; + if State_String_1 /= State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Float generators " & + "are not the same"); + end if; + when False => + if State_1 = State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Float generators " & + "are the same"); + end if; + if State_String_1 = State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Float generators " & + "are the same"); + end if; + end case; + end Check_Float_State; + + + + procedure Check_Discrete_State (Gen_1, + Gen_2 : Discrete_Package.Generator; + Sub_Test : Integer; + States_Should_Match : Boolean) is + + use type Discrete_Package.State; + + State_1, State_2 : Discrete_Package.State; + + State_String_1, + State_String_2 : Discrete_String_Pack.Bounded_String := + Discrete_String_Pack.Null_Bounded_String; + begin + + Discrete_Package.Save(Gen => Gen_1, + To_State => State_1); + Discrete_Package.Save(Gen_2, To_State => State_2); + + State_String_1 := + Discrete_String_Pack.To_Bounded_String(Source => + Discrete_Package.Image(Of_State => State_1)); + + State_String_2 := + Discrete_String_Pack.To_Bounded_String(Source => + Discrete_Package.Image(Of_State => State_2)); + + case States_Should_Match is + when True => + if State_1 /= State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Discrete " & + "generators are not the same"); + end if; + if State_String_1 /= State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Discrete " & + "generators are not the same"); + end if; + when False => + if State_1 = State_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State values from Discrete " & + "generators are the same"); + end if; + if State_String_1 = State_String_2 then + Report.Failed("Subtest #" & Integer'Image(Sub_Test) & + " State strings from Discrete " & + "generators are the same"); + end if; + end case; + end Check_Discrete_State; + + + + procedure Check_Float_Values (Gen_1, Gen_2 : Float_Random.Generator; + Sub_Test : Integer; + Values_Should_Match : Boolean) is + Matches : Natural := 0; + Check_Failed : Boolean := False; + begin + case Values_Should_Match is + when True => + for i in 1..TC_Max_Loop_Count loop + if Float_Random.Random(Gen_1) /= Float_Random.Random(Gen_2) + then + Check_Failed := True; + exit; + end if; + end loop; + if Check_Failed then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Float generators " & + "Failed check"); + end if; + when False => + for i in 1..TC_Max_Loop_Count loop + if Float_Random.Random(Gen_1) = Float_Random.Random(Gen_2) + then + Matches := Matches + 1; + end if; + end loop; + end case; + + if (Values_Should_Match and Check_Failed) or + (not Values_Should_Match and Matches > Allowed_Matches) + then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Float generators " & + "Failed check"); + end if; + + end Check_Float_Values; + + + + procedure Check_Discrete_Values (Gen_1, + Gen_2 : Discrete_Package.Generator; + Sub_Test : Integer; + Values_Should_Match : Boolean) is + Matches : Natural := 0; + Check_Failed : Boolean := False; + begin + case Values_Should_Match is + when True => + for i in 1..TC_Max_Loop_Count loop + if Discrete_Package.Random(Gen_1) /= + Discrete_Package.Random(Gen_2) + then + Check_Failed := True; + exit; + end if; + end loop; + when False => + for i in 1..TC_Max_Loop_Count loop + if Discrete_Package.Random(Gen_1) = + Discrete_Package.Random(Gen_2) + then + Matches := Matches + 1; + end if; + end loop; + end case; + + if (Values_Should_Match and Check_Failed) or + (not Values_Should_Match and Matches > Allowed_Matches) + then + Report.Failed("Sub_Test # " & Integer'Image(Sub_Test) & + " Random numbers from Discrete generators " & + "Failed check"); + end if; + + end Check_Discrete_Values; + + + + begin + + Sub_Test_1: + -- Check that two objects of type Generator are initialized to the + -- same state. + begin + + -- Since the discrete and float random generators are in the initial + -- state, using Procedure Save to save the states of the generator + -- objects, and transforming these states into strings using + -- Function Image, should yield identical strings. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 1, + States_Should_Match => True); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 1, + States_Should_Match => True); + + -- Since the two random generator objects are in their initial + -- state, the values produced from each (upon calls to Random) + -- should be identical. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 1, + Values_Should_Match => True); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 1, + Values_Should_Match => True); + + end Sub_Test_1; + + + + Sub_Test_3: + -- Check that when the Function Reset uses the same integer + -- initiator to reset two generators to the same state, the + -- resulting random values and the state from each generator + -- are identical. + declare + use Discrete_Package, Float_Random; + begin + + -- Reset the generators to the same states, using the version of + -- Function Reset with both generator parameter and initiator + -- specified. + + TC_Seed := Integer(Random(Discrete_Generator_1)); + Reset(Gen => Discrete_Generator_1, Initiator => TC_Seed); + Reset(Discrete_Generator_2, Initiator => TC_Seed); + Reset(Float_Generator_1, TC_Seed); + Reset(Float_Generator_2, TC_Seed); + + -- Since the random generators have been reset to identical states, + -- bounded string images of these states should yield identical + -- strings. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 3, + States_Should_Match => True); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 3, + States_Should_Match => True); + + -- Since the random generators have been reset to identical states, + -- the values produced from each (upon calls to Random) should + -- be identical. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 3, + Values_Should_Match => True); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 3, + Values_Should_Match => True); + + end Sub_Test_3; + + + + Sub_Test_4: + -- Check that when the Function Reset uses different integer + -- initiator values to reset two generators, the resulting random + -- numbers and states are different. + begin + + -- Reset the generators to different states. + + TC_Seed := + Integer(Discrete_Package.Random(Discrete_Generator_1)); + + Discrete_Package.Reset(Gen => Discrete_Generator_1, + Initiator => TC_Seed); + + -- Set the seed value to a different value for the second call + -- to Reset. + -- Note: A second call to Random could be made, as above, but that + -- would not ensure that the resulting seed value was + -- different from the first. + + if TC_Seed /= Integer'Last then + TC_Seed := TC_Seed + 1; + else + TC_Seed := TC_Seed - 1; + end if; + + Discrete_Package.Reset(Gen => Discrete_Generator_2, + Initiator => TC_Seed); + + Float_Random.Reset(Float_Generator_1, 16#FF#); -- 255 + Float_Random.Reset(Float_Generator_2, 2#1110_0000#); -- 224 + + -- Since the two float random generators are in different + -- states, the bounded string images depicting their states should + -- differ. + + Check_Discrete_State (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 4, + States_Should_Match => False); + + Check_Float_State (Float_Generator_1, + Float_Generator_2, + Sub_Test => 4, + States_Should_Match => False); + + -- Since the two discrete random generator objects were reset + -- to different states, the values produced from each (upon calls + -- to Random) should differ. + + Check_Discrete_Values (Discrete_Generator_1, + Discrete_Generator_2, + Sub_Test => 4, + Values_Should_Match => False); + + Check_Float_Values (Float_Generator_1, + Float_Generator_2, + Sub_Test => 4, + Values_Should_Match => False); + + end Sub_Test_4; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA5011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5012.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,536 ---- + -- CXA5012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that, for both Float_Random and Discrete_Random packages, + -- the following are true: + -- 1) the procedures Save and Reset can be used to save the + -- specific state of a random number generator, and then restore + -- the specific state to the generator following some intermediate + -- generator activity. + -- 2) the Function Image can be used to obtain a string + -- representation of the state of a generator; and that the + -- Function Value will transform a string representation of the + -- state of a random number generator into the actual state object. + -- 3) a call to Function Value, with a string value that is + -- not the image of any generator state, is a bounded error. This + -- error either raises Constraint_Error or Program_Error, or is + -- accepted. (See Technical Corrigendum 1). + -- + -- TEST DESCRIPTION: + -- This test evaluates components of the Ada.Numerics.Float_Random and + -- Ada.Numerics.Discrete_Random packages. + -- The first objective block of this test uses Procedure Save to + -- save the particular state of a random number generator. The random + -- number generator then generates a series of random numbers. The + -- saved state variable is then used to reset (using Procedure Reset) + -- the generator back to the state it was in at the point of the call + -- to Save. Random values are then generated from this restored + -- generator, and compared with expected values. + -- The second objective block of this test uses Function Image to + -- provide a string representation of a state code. This string is + -- then transformed back to a state code value, and used to reset a + -- random number generator to the saved state. Random values are + -- likewise generated from this restored generator, and compared with + -- expected values. + -- + -- + -- CHANGE HISTORY: + -- 25 Apr 95 SAIC Initial prerelease version. + -- 17 Jul 95 SAIC Incorporated reviewer comments. + -- 17 Dec 97 EDS Change subtype upper limit from 100_000 to 10_000. + -- 16 Sep 99 RLB Updated objective 3 for Technical Corrigendum 1 + -- changes. + + --! + + with Ada.Numerics.Float_Random; + with Ada.Numerics.Discrete_Random; + with Ada.Strings.Bounded; + with ImpDef; + with Report; + + procedure CXA5012 is + + begin + + Report.Test ("CXA5012", "Check the effect of Procedures Save and " & + "Reset, and Functions Image and Value " & + "from the Ada.Numerics.Discrete_Random " & + "and Float_Random packages"); + + Test_Block: + declare + + use Ada.Numerics, Ada.Strings.Bounded; + + -- Declare an integer subtype and an enumeration subtype, and use them + -- to instantiate the discrete random number generator generic package. + + subtype Discrete_Range is Integer range 1..10_000; + type Suit_Of_Cards is (Ace, One, Two, Three, Four, Five, Six, + Seven, Eight, Nine, Ten, Jack, Queen, King); + package Discrete_Pack is new Discrete_Random(Discrete_Range); + package Card_Pack is new Discrete_Random(Suit_Of_Cards); + + -- Declaration of random number generator objects. + + DGen_1, DGen_2 : Discrete_Pack.Generator; + EGen_1, EGen_2 : Card_Pack.Generator; + FGen_1, FGen_2 : Float_Random.Generator; + + -- Variables declared to hold random numbers over the inclusive range + -- of their corresponding type. + + DVal_1, DVal_2 : Discrete_Range; + EVal_1, EVal_2 : Suit_Of_Cards; + FVal_1, FVal_2 : Float_Random.Uniformly_Distributed; + + -- Declaration of State variables used to hold the state of the + -- random number generators. + + DState_1, DState_2 : Discrete_Pack.State; + EState_1, EState_2 : Card_Pack.State; + FState_1, FState_2 : Float_Random.State; + + -- Declaration of bounded string packages instantiated with the + -- value of Max_Image_Width constant, and bounded string variables + -- used to hold the image of random number generator states. + + package DString_Pack is + new Generic_Bounded_Length(Discrete_Pack.Max_Image_Width); + package EString_Pack is + new Generic_Bounded_Length(Card_Pack.Max_Image_Width); + package FString_Pack is + new Generic_Bounded_Length(Float_Random.Max_Image_Width); + + use DString_Pack, EString_Pack, FString_Pack; + + DString_1, DString_2 : DString_Pack.Bounded_String := + DString_Pack.Null_Bounded_String; + EString_1, EString_2 : EString_Pack.Bounded_String := + EString_Pack.Null_Bounded_String; + FString_1, FString_2 : FString_Pack.Bounded_String := + FString_Pack.Null_Bounded_String; + + -- Test variables. + + TC_Count : Natural; + TC_Discrete_Check_Failed, + TC_Enum_Check_Failed, + TC_Float_Check_Failed : Boolean := False; + TC_Seed : Integer; + + begin + + Objective_1: + -- Check that the procedures Save and Reset can be used to save the + -- specific state of a random number generator, and then restore the + -- specific state to the generator following some intermediate + -- generator activity. + declare + + First_Row : constant := 1; + Second_Row : constant := 2; + TC_Max_Values : constant := 100; + + TC_Discrete_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Discrete_Range; + TC_Enum_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Suit_Of_Cards; + TC_Float_Array : array (First_Row..Second_Row, 1..TC_Max_Values) + of Float_Random.Uniformly_Distributed; + begin + + -- The state of the random number generators are saved to state + -- variables using the procedure Save. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Card_Pack.Save (Gen => EGen_1, To_State => EState_1); + Float_Random.Save (Gen => FGen_1, To_State => FState_1); + + -- Random number generators are used to fill the first half of the + -- first row of the arrays with randomly generated values. + + for i in 1..TC_Max_Values/2 loop + TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- The random number generators are reset to the states saved in the + -- state variables, using the procedure Reset. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- The same random number generators are used to fill the first half + -- of the second row of the arrays with randomly generated values. + + for i in 1..TC_Max_Values/2 loop + TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- Run the random number generators many times (not using results). + + for i in Discrete_Range'Range loop + DVal_1 := Discrete_Pack.Random(DGen_1); + EVal_1 := Card_Pack.Random(EGen_1); + FVal_1 := Float_Random.Random(FGen_1); + end loop; + + -- The states of the random number generators are saved to state + -- variables using the procedure Save. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Card_Pack.Save(Gen => EGen_1, To_State => EState_1); + Float_Random.Save (Gen => FGen_1, To_State => FState_1); + + -- The last half of the first row of the arrays are filled with + -- values generated from the same random number generators. + + for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop + TC_Discrete_Array(First_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(First_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(First_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- The random number generators are reset to the states saved in the + -- state variables, using the procedure Reset. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset(Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- The last half of the second row of the arrays are filled with + -- values generated from the same random number generator. + -- These values should exactly mirror the values in the last half + -- of the first row of the arrays that had been previously generated. + + for i in (TC_Max_Values/2 + 1)..TC_Max_Values loop + TC_Discrete_Array(Second_Row, i) := Discrete_Pack.Random(DGen_1); + TC_Enum_Array(Second_Row, i) := Card_Pack.Random(EGen_1); + TC_Float_Array(Second_Row, i) := Float_Random.Random(FGen_1); + end loop; + + -- Check that the values in the two rows of the arrays are identical. + + for i in 1..TC_Max_Values loop + if TC_Discrete_Array(First_Row,i) /= + TC_Discrete_Array(Second_Row,i) + then + TC_Discrete_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..TC_Max_Values loop + if TC_Enum_Array(First_Row,i) /= TC_Enum_Array(Second_Row,i) then + TC_Enum_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..TC_Max_Values loop + if TC_Float_Array(First_Row,i) /= TC_Float_Array(Second_Row,i) + then + TC_Float_Check_Failed := True; + exit; + end if; + end loop; + + if TC_Discrete_Check_Failed then + Report.Failed("Discrete random values generated following use " & + "of procedures Save and Reset were not the same"); + TC_Discrete_Check_Failed := False; + end if; + + if TC_Enum_Check_Failed then + Report.Failed("Enumeration random values generated following " & + "use of procedures Save and Reset were not the " & + "same"); + TC_Enum_Check_Failed := False; + end if; + + if TC_Float_Check_Failed then + Report.Failed("Float random values generated following use " & + "of procedures Save and Reset were not the same"); + TC_Float_Check_Failed := False; + end if; + + end Objective_1; + + + + Objective_2: + -- Check that the Function Image can be used to obtain a string + -- representation of the state of a generator. + -- Check that the Function Value will transform a string + -- representation of the state of a random number generator + -- into the actual state object. + begin + + -- Use two discrete and float random number generators to generate + -- a series of values (so that the generators are no longer in their + -- initial states, and they have generated the same number of + -- random values). + + TC_Seed := Integer(Discrete_Pack.Random(DGen_1)); + Discrete_Pack.Reset(DGen_1, TC_Seed); + Discrete_Pack.Reset(DGen_2, TC_Seed); + Card_Pack.Reset (EGen_1, TC_Seed); + Card_Pack.Reset (EGen_2, TC_Seed); + Float_Random.Reset (FGen_1, TC_Seed); + Float_Random.Reset (FGen_2, TC_Seed); + + for i in 1..1000 loop + DVal_1 := Discrete_Pack.Random(DGen_1); + DVal_2 := Discrete_Pack.Random(DGen_2); + EVal_1 := Card_Pack.Random(EGen_1); + EVal_2 := Card_Pack.Random(EGen_2); + FVal_1 := Float_Random.Random(FGen_1); + FVal_2 := Float_Random.Random(FGen_2); + end loop; + + -- Use the Procedure Save to save the states of the generators + -- to state variables. + + Discrete_Pack.Save(Gen => DGen_1, To_State => DState_1); + Discrete_Pack.Save(DGen_2, To_State => DState_2); + Card_Pack.Save (Gen => EGen_1, To_State => EState_1); + Card_Pack.Save (EGen_2, To_State => EState_2); + Float_Random.Save (FGen_1, To_State => FState_1); + Float_Random.Save (FGen_2, FState_2); + + -- Use the Function Image to produce a representation of the state + -- codes as (bounded) string objects. + + DString_1 := DString_Pack.To_Bounded_String( + Discrete_Pack.Image(Of_State => DState_1)); + DString_2 := DString_Pack.To_Bounded_String( + Discrete_Pack.Image(DState_2)); + EString_1 := EString_Pack.To_Bounded_String( + Card_Pack.Image(Of_State => EState_1)); + EString_2 := EString_Pack.To_Bounded_String( + Card_Pack.Image(EState_2)); + FString_1 := FString_Pack.To_Bounded_String( + Float_Random.Image(Of_State => FState_1)); + FString_2 := FString_Pack.To_Bounded_String( + Float_Random.Image(FState_2)); + + -- Compare the bounded string objects for equality. + + if DString_1 /= DString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Discrete generators"); + end if; + if EString_1 /= EString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Enumeration " & + "generators"); + end if; + if FString_1 /= FString_2 then + Report.Failed("String values returned from Function Image " & + "depict different states of Float generators"); + end if; + + -- The string representation of a state code is transformed back + -- to a state code variable using the Function Value. + + DState_1 := Discrete_Pack.Value(Coded_State => + DString_Pack.To_String(DString_1)); + EState_1 := Card_Pack.Value(EString_Pack.To_String(EString_1)); + FState_1 := Float_Random.Value(FString_Pack.To_String(FString_1)); + + -- One of the (pair of each type of ) generators is used to generate + -- a series of random values, getting them "out of synch" with the + -- specific generation sequence of the other generators. + + for i in 1..100 loop + DVal_1 := Discrete_Pack.Random(DGen_1); + EVal_1 := Card_Pack.Random(EGen_1); + FVal_1 := Float_Random.Random (FGen_1); + end loop; + + -- The "out of synch" generators are reset to the previous state they + -- had when their states were saved, and they should now have the same + -- states as the generators that did not generate the values above. + + Discrete_Pack.Reset(Gen => DGen_1, From_State => DState_1); + Card_Pack.Reset (Gen => EGen_1, From_State => EState_1); + Float_Random.Reset (Gen => FGen_1, From_State => FState_1); + + -- All generators should now be in the same state, so the + -- random values they produce should be the same. + + for i in 1..1000 loop + if Discrete_Pack.Random(DGen_1) /= Discrete_Pack.Random(DGen_2) + then + TC_Discrete_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..1000 loop + if Card_Pack.Random(EGen_1) /= Card_Pack.Random(EGen_2) then + TC_Enum_Check_Failed := True; + exit; + end if; + end loop; + + for i in 1..1000 loop + if Float_Random.Random(FGen_1) /= Float_Random.Random(FGen_2) + then + TC_Float_Check_Failed := True; + exit; + end if; + end loop; + + if TC_Discrete_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Discrete generator"); + end if; + if TC_Enum_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Enumeration generator"); + end if; + if TC_Float_Check_Failed then + Report.Failed("Random values generated following use of " & + "procedures Image and Value were not the same " & + "for Float generator"); + end if; + + end Objective_2; + + + + Objective_3: + -- Check that a call to Function Value, with a string value that is + -- not the image of any generator state, is a bounded error. This + -- error either raises Constraint_Error or Program_Error, or is + -- accepted. (See Technical Corrigendum 1). + declare + Not_A_State : constant String := ImpDef.Non_State_String; + begin + + begin + DState_1 := Discrete_Pack.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Discrete_Random.Value"); + end if; + Discrete_Pack.Reset(DGen_1, DState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + Report.Comment("Constraint_Error raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + when Program_Error => -- OK, expected exception. + Report.Comment("Program_Error raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + when others => + Report.Failed("Unexpected exception raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + end; + + begin + EState_1 := Card_Pack.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of an enumeration " & + "random number generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Discrete_Random.Value"); + end if; + Card_Pack.Reset(EGen_1, EState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + when Program_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function " & + "Ada.Numerics.Discrete_Random.Value when " & + "provided a string input that does not " & + "represent the state of an enumeration " & + "random number generator"); + end; + + begin + FState_1 := Float_Random.Value(Not_A_State); + if Not_A_State /= "**NONE**" then + Report.Failed("Exception not raised by an " & + "instantiated version of " & + "Ada.Numerics.Float_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + else + Report.Comment("All strings represent states for Function " & + "Ada.Numerics.Float_Random.Value"); + end if; + Float_Random.Reset(FGen_1, FState_1); + exception + when Constraint_Error => null; -- OK, expected exception. + when Program_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by an " & + "instantiated version of " & + "Ada.Numerics.Float_Random.Value when " & + "provided a string input that does not " & + "represent the state of a random number " & + "generator"); + end; + + end Objective_3; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5015.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,342 ---- + -- CXA5015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the following representation-oriented attributes are + -- available and that the produce correct results: + -- 'Denorm, 'Signed_Zeros, 'Exponent 'Fraction, 'Compose, 'Scaling, + -- 'Floor, 'Ceiling, 'Rounding, 'Unbiased_Rounding, 'Truncation, + -- 'Remainder, 'Adjacent, 'Copy_Sign, 'Leading_Part, 'Machine, and + -- 'Model_Small. + -- + -- TEST DESCRIPTION: + -- This test checks whether certain attributes of floating point types + -- are available from an implementation. Where attribute correctness + -- can be verified in a straight forward manner, the appropriate checks + -- are included here. However, this test is not intended to ensure the + -- correctness of the results returned from all of the attributes + -- examined in this test; that process will occur in the tests of the + -- Numerics_Annex. + -- + -- + -- CHANGE HISTORY: + -- 26 Jun 95 SAIC Initial prerelease version. + -- 29 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 01 DEC 97 EDS Fix value for checking the S'Adjacent attribute + --! + + with Report; + + procedure CXA5015 is + + subtype Float_Subtype is Float range -10.0..10.0; + type Derived_Float_1 is digits 8; + type Derived_Float_2 is new Derived_Float_1 range -10.0..10.0E10; + + use type Float, Float_Subtype, Derived_Float_1, Derived_Float_2; + + TC_Boolean : Boolean; + TC_Float : Float; + TC_SFloat : Float_Subtype; + TC_DFloat_1 : Derived_Float_1; + TC_DFloat_2 : Derived_Float_2; + TC_Tolerance : Float := 0.001; + + function Not_Equal (Actual_Result, Expected_Result, Tolerance : Float) + return Boolean is + begin + return abs(Actual_Result - Expected_Result) > Tolerance; + end Not_Equal; + + + begin + + Report.Test ("CXA5015", "Check that certain representation-oriented " & + "attributes are available and that they " & + "produce correct results"); + + -- New Representation-Oriented Attributes. + -- + -- Check the S'Denorm attribute. + + TC_Boolean := Float'Denorm; + TC_Boolean := Float_Subtype'Denorm; + TC_Boolean := Derived_Float_1'Denorm; + TC_Boolean := Derived_Float_2'Denorm; + + + -- Check the S'Signed_Zeroes attribute. + + TC_Boolean := Float'Signed_Zeros; + TC_Boolean := Float_Subtype'Signed_Zeros; + TC_Boolean := Derived_Float_1'Signed_Zeros; + TC_Boolean := Derived_Float_2'Signed_Zeros; + + + -- New Primitive Function Attributes. + -- + -- Check the S'Exponent attribute. + + TC_Float := 0.5; + TC_SFloat := 0.99; + TC_DFloat_1 := 2.45; + TC_DFloat_2 := 2.65; + + if Float'Exponent(TC_Float) > Float_Subtype'Exponent(TC_SFloat) or + Float'Exponent(TC_Float) > 2 + then + Report.Failed("Incorrect result from the 'Exponent attribute"); + end if; + + + -- Check the S'Fraction attribute. + + if Not_Equal + (Float'Fraction(TC_Float), + TC_Float * Float(Float'Machine_Radix)**(-Float'Exponent(TC_Float)), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Fraction attribute - 1"); + end if; + + if Float'Fraction(TC_Float) < + (1.0/Float(Float'Machine_Radix)) - TC_Tolerance or + Float'Fraction(TC_Float) >= 1.0 - TC_Tolerance + then + Report.Failed("Incorrect result from the 'Fraction attribute - 2"); + end if; + + + -- Check the S'Compose attribute. + + if Not_Equal + (Float'Compose(TC_Float, 3), + TC_Float * Float(Float'Machine_Radix)**(3-Float'Exponent(TC_Float)), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Compose attribute"); + end if; + + + -- Check the S'Scaling attribute. + + if Not_Equal + (Float'Scaling(TC_Float, 2), + TC_Float * Float(Float'Machine_Radix)**2, + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Scaling attribute"); + end if; + + + -- Check the S'Floor attribute. + + TC_Float := 0.99; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Floor(TC_Float) /= 0.0 or + Float_Subtype'Floor(TC_SFloat) /= 1.0 or + Derived_Float_1'Floor(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Floor(TC_DFloat_2) /= -3.0 + then + Report.Failed("Incorrect result from the 'Floor attribute"); + end if; + + + -- Check the S'Ceiling attribute. + + TC_Float := 0.99; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.99; + + if Float'Ceiling(TC_Float) /= 1.0 or + Float_Subtype'Ceiling(TC_SFloat) /= 1.0 or + Derived_Float_1'Ceiling(TC_DFloat_1) /= 3.0 or + Derived_Float_2'Ceiling(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Ceiling attribute"); + end if; + + + -- Check the S'Rounding attribute. + + TC_Float := 0.49; + TC_SFloat := 1.00; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Rounding(TC_Float) /= 0.0 or + Float_Subtype'Rounding(TC_SFloat) /= 1.0 or + Derived_Float_1'Rounding(TC_DFloat_1) /= 3.0 or + Derived_Float_2'Rounding(TC_DFloat_2) /= -3.0 + then + Report.Failed("Incorrect result from the 'Rounding attribute"); + end if; + + + -- Check the S'Unbiased_Rounding attribute. + + TC_Float := 0.50; + TC_SFloat := 1.50; + TC_DFloat_1 := 2.50; + TC_DFloat_2 := -2.50; + + if Float'Unbiased_Rounding(TC_Float) /= 0.0 or + Float_Subtype'Unbiased_Rounding(TC_SFloat) /= 2.0 or + Derived_Float_1'Unbiased_Rounding(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Unbiased_Rounding(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Unbiased_Rounding " & + "attribute"); + end if; + + + -- Check the S'Truncation attribute. + + TC_Float := -0.99; + TC_SFloat := 1.50; + TC_DFloat_1 := 2.99; + TC_DFloat_2 := -2.50; + + if Float'Truncation(TC_Float) /= 0.0 or + Float_Subtype'Truncation(TC_SFloat) /= 1.0 or + Derived_Float_1'Truncation(TC_DFloat_1) /= 2.0 or + Derived_Float_2'Truncation(TC_DFloat_2) /= -2.0 + then + Report.Failed("Incorrect result from the 'Truncation attribute"); + end if; + + + -- Check the S'Remainder attribute. + + TC_Float := 9.0; + TC_SFloat := 7.5; + TC_DFloat_1 := 5.0; + TC_DFloat_2 := 8.0; + + if Float'Remainder(TC_Float, 2.0) /= 1.0 or + Float_Subtype'Remainder(TC_SFloat, 3.0) /= 1.5 or + Derived_Float_1'Remainder(TC_DFloat_1, 2.0) /= 1.0 or + Derived_Float_2'Remainder(TC_DFloat_2, 4.0) /= 0.0 + then + Report.Failed("Incorrect result from the 'Remainder attribute"); + end if; + + + -- Check the S'Adjacent attribute. + + TC_Float := 4.0; + TC_SFloat := -1.0; + + if Float'Adjacent(TC_Float, TC_Float) /= TC_Float or + Float_Subtype'Adjacent(TC_SFloat, -1.0) /= TC_SFloat + then + Report.Failed("Incorrect result from the 'Adjacent attribute"); + end if; + + + -- Check the S'Copy_Sign attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.0; + TC_DFloat_2 := -2.5; + + if Float'Copy_Sign(TC_Float, -2.0) /= 0.0 or + Float_Subtype'Copy_Sign(TC_SFloat, 4.0) /= 1.0 or + Derived_Float_1'Copy_Sign(TC_DFloat_1, -2.0) /= -5.0 or + Derived_Float_2'Copy_Sign(TC_DFloat_2, -2.0) /= -2.5 + then + Report.Failed("Incorrect result from the 'Copy_Sign attribute"); + end if; + + + -- Check the S'Leading_Part attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.88; + TC_DFloat_2 := -2.52; + + -- Leading part obtained in the variables. + TC_Float := Float'Leading_Part(TC_Float, 2); + TC_SFloat := Float_Subtype'Leading_Part(TC_SFloat, 2); + TC_DFloat_1 := Derived_Float_1'Leading_Part(TC_DFloat_1, 2); + TC_DFloat_2 := Derived_Float_2'Leading_Part(TC_DFloat_2, 2); + + -- Checking for the leading part of the variables at this point should + -- produce the same values. + if Float'Leading_Part(TC_Float, 2) /= TC_Float or + Float_Subtype'Leading_Part(TC_SFloat, 2) /= TC_SFloat or + Derived_Float_1'Leading_Part(TC_DFloat_1, 2) /= TC_DFloat_1 or + Derived_Float_2'Leading_Part(TC_DFloat_2, 2) /= TC_DFloat_2 + then + Report.Failed("Incorrect result from the 'Leading_Part attribute"); + end if; + + + -- Check the S'Machine attribute. + + TC_Float := 0.0; + TC_SFloat := -1.0; + TC_DFloat_1 := 5.88; + TC_DFloat_2 := -2.52; + + -- Closest machine number obtained in the variables. + TC_Float := Float'Machine(TC_Float); + TC_SFloat := Float_Subtype'Machine(TC_SFloat); + TC_DFloat_1 := Derived_Float_1'Machine(TC_DFloat_1); + TC_DFloat_2 := Derived_Float_2'Machine(TC_DFloat_2); + + -- Checking for the closest machine number to each of the variables at + -- this point should produce the same values. + if Float'Machine(TC_Float) /= TC_Float or + Float_Subtype'Machine(TC_SFloat) /= TC_SFloat or + Derived_Float_1'Machine(TC_DFloat_1) /= TC_DFloat_1 or + Derived_Float_2'Machine(TC_DFloat_2) /= TC_DFloat_2 + then + Report.Failed("Incorrect result from the 'Machine attribute"); + end if; + + + -- New Model-Oriented Attributes. + -- + -- Check the S'Model_Small attribute. + + if Not_Equal + (Float'Model_Small, + Float(Float'Machine_Radix)**(Float'Model_Emin-1), + TC_Tolerance) + then + Report.Failed("Incorrect result from the 'Model_Small attribute"); + end if; + + + Report.Result; + + end CXA5015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- CXA5A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Sin and Sinh provide correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Sin and Sinh resulting from + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, as well as instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Mar 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 26 Jun 98 EDS Protected exception tests by first testing + -- for 'Machine_Overflows + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A01 is + begin + + Report.Test ("CXA5A01", "Check that the functions Sin and Sinh provide " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Sin Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Sin with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "positive value"); + end; + + begin + The_Result := EF.Sin (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "negative value"); + end; + + + -- Test of Sin for prescribed result at zero. + + if GEF.Sin (0.0) /= 0.0 or + EF.Sin (0.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sin(0.0)"); + end if; + + + -- Test of Sin with expected result value between 0.0 and 1.0. + + if not (GEF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or + not ( EF.Sin (Ada.Numerics.Pi/4.0) < 1.0) or + not FXA5A00.Result_Within_Range(GEF.Sin(0.35), 0.343, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sin(1.18), 0.924, 0.001) + then + Report.Failed("Incorrect value returned from Sin function when " & + "the expected result is between 0.0 and 1.0"); + end if; + + + -- Test of Sin with expected result value between -1.0 and 0.0. + + if not (GEF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or + not ( EF.Sin (-Ada.Numerics.Pi/4.0) > -1.0) or + not FXA5A00.Result_Within_Range(GEF.Sin(-0.24), -0.238, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sin(-1.00), -0.841, 0.001) + then + Report.Failed("Incorrect value returned from Sin function when " & + "the expected result is between -1.0 and 0.0"); + end if; + + + -- Testing of the Sin function with Cycle parameter. + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is zero. + + begin + New_Float_Result := GEF.Sin (X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Sin function " & + "when the Cycle parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Sin function " & + "when the Cycle parameter is zero"); + end; + + begin + The_Result := EF.Sin (X => 0.34, Cycle => 0.0); + Report.Failed("Argument_Error not raised by EF.Sin function when " & + "the Cycle parameter is zero"); + Dont_Optimize_Float(The_Result, 4); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Sin function " & + "when the Cycle parameter is zero"); + end; + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is negative. + + begin + New_Float_Result := GEF.Sin (X => 0.45, Cycle => -1.0); + Report.Failed("Argument_Error not raised by GEF.Sin function " & + "when the Cycle parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Sin function " & + "when the Cycle parameter is negative"); + end; + + begin + The_Result := EF.Sin (X => 0.10, Cycle => -4.0); + Report.Failed("Argument_Error not raised by EF.Sin function when " & + "the Cycle parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Sin function " & + "when the Cycle parameter is negative"); + end; + + + -- Check that no exception occurs on computing the Sin with very + -- large (positive and negative) input values and Cycle parameter. + + begin + New_Float_Result := GEF.Sin (New_Float(FXA5A00.Large), 360.0); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sin with large " & + "positive value and Cycle parameter"); + end; + + begin + The_Result := EF.Sin (FXA5A00.Minus_Large, 720.0); + Dont_Optimize_Float(The_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on EF.Sin with large " & + "negative value and Cycle parameter"); + end; + + + -- Test of Sin with Cycle parameter for prescribed result at zero. + + if GEF.Sin (0.0, 360.0) /= 0.0 or + EF.Sin (0.0, 180.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sin function with " & + "cycle parameter for a zero input parameter value"); + end if; + + + -- Tests of Sin function with Cycle parameter for prescribed results. + + if GEF.Sin(0.0, 360.0) /= 0.0 or + EF.Sin(180.0, 360.0) /= 0.0 or + GEF.Sin(90.0, 360.0) /= 1.0 or + EF.Sin(450.0, 360.0) /= 1.0 or + GEF.Sin(270.0, 360.0) /= -1.0 or + EF.Sin(630.0, 360.0) /= -1.0 + then + Report.Failed("Incorrect result from the Sin function with " & + "various cycle values for prescribed results"); + end if; + + + -- Testing of Sinh Function, both instantiated and pre-instantiated + -- version. + + -- Test for Constraint_Error on parameter with large positive magnitude. + + begin + + if New_Float'Machine_Overflows then + New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Large)); + Report.Failed("Constraint_Error not raised when the GEF.Sinh " & + "function is provided a parameter with a large " & + "positive value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the GEF.Sinh " & + "function is provided a parameter with a large " & + "positive value"); + end; + + -- Test for Constraint_Error on parameter with large negative magnitude. + + begin + + if Float'Machine_Overflows then + The_Result := EF.Sinh (FXA5A00.Minus_Large); + Report.Failed("Constraint_Error not raised when the EF.Sinh " & + "function is provided a parameter with a " & + "large negative value"); + Dont_Optimize_Float(The_Result, 10); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the EF.Sinh " & + "function is provided a parameter with a " & + "large negative value"); + end; + + + -- Test that no exception occurs when the Sinh function is provided a + -- very small positive or negative value. + + begin + New_Float_Result := GEF.Sinh (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on GEF.Sinh with a very" & + "small positive value"); + end; + + begin + The_Result := EF.Sinh (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 12); + exception + when others => + Report.Failed("Unexpected exception on EF.Sinh with a very" & + "small negative value"); + end; + + + -- Test for prescribed 0.0 result of Function Sinh with 0.0 parameter. + + if GEF.Sinh (0.0) /= 0.0 or + EF.Sinh (0.0) /= 0.0 + then + Report.Failed("Incorrect value returned from Sinh(0.0)"); + end if; + + + -- Test of Sinh function with various input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Sinh(0.01), 0.010, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sinh(0.61), 0.649, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Sinh(1.70), 2.65, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sinh(3.15), 11.65, 0.01) + then + Report.Failed("Incorrect result returned from Sinh function " & + "with various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a02.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,328 ---- + -- CXA5A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Cos and Cosh provide correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Cos and Cosh resulting from + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with type derived from type Float, as well as the pre-instantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A02.A + -- + -- + -- CHANGE HISTORY: + -- 09 Mar 95 SAIC Initial prerelease version. + -- 03 Apr 95 SAIC Removed reference to derived type. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 28 Feb 97 PWB.CTA Removed checks specifying Cycle => 2.0 * Pi + -- 26 Jun 98 EDS Protected exception checks by first testing + -- for 'Machine_Overflows. Removed code deleted + -- by comment. + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks have been deleted. + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A02 is + begin + + Report.Test ("CXA5A02", "Check that the functions Cos and Cosh provide " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Cos Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Cos with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Cos (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cos with large " & + "positive value"); + end; + + begin + The_Result := EF.Cos (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cos with large " & + "negative value"); + end; + + + -- Test of Cos for prescribed result at zero. + + if GEF.Cos (0.0) /= 1.0 or + EF.Cos (0.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cos(0.0)"); + end if; + + + -- Test of Cos with expected result value between 1.0 and -1.0. + + if not (Result_Within_Range( EF.Cos(Ada.Numerics.Pi/3.0), + 0.500, + 0.001) and + Result_Within_Range(GEF.Cos(0.6166), 0.816, 0.001) and + Result_Within_Range(GEF.Cos(0.1949), 0.981, 0.001) and + Result_Within_Range( EF.Cos(Ada.Numerics.Pi/2.0), + 0.00, + 0.001) and + Result_Within_Range( EF.Cos(2.0*Ada.Numerics.Pi/3.0), + -0.500, + 0.001) and + Result_Within_Range(GEF.Cos(New_Float(Ada.Numerics.Pi)), + -1.00, + 0.001)) + then + Report.Failed("Incorrect value returned from Cos function when " & + "the expected result is between 1.0 and -1.0"); + end if; + + + -- Testing of the Cos function with Cycle parameter. + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is zero. + + begin + New_Float_Result := GEF.Cos (X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Cos function " & + "when the Cycle parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.cos function " & + "when the Cycle parameter is zero"); + end; + + begin + The_Result := EF.Cos (X => 0.55, Cycle => 0.0); + Report.Failed("Argument_Error not raised by EF.Cos function when " & + "the Cycle parameter is zero"); + Dont_Optimize_Float(The_Result, 4); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Cos function " & + "when the Cycle parameter is zero"); + end; + + -- Check that Argument_Error is raised when the value of the Cycle + -- parameter is negative. + + begin + New_Float_Result := GEF.Cos (X => 0.45, Cycle => -2.0*Pi); + Report.Failed("Argument_Error not raised by GEF.Cos function " & + "when the Cycle parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Cos function " & + "when the Cycle parameter is negative"); + end; + + begin + The_Result := EF.Cos (X => 0.10, Cycle => -Pi/2.0); + Report.Failed("Argument_Error not raised by EF.Cos function when " & + "the Cycle parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Ada.Numerics.Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Cos function " & + "when the Cycle parameter is negative"); + end; + + -- Test of Cos with Cycle parameter for prescribed result at zero. + + if GEF.Cos (0.0, 360.0) /= 1.0 or + EF.Cos (0.0, 360.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cos function with " & + "cycle parameter for a zero input parameter value"); + end if; + + + -- Tests of Cos function with specified Cycle, using various input + -- parameter values for prescribed results. + + if GEF.Cos(0.0, 360.0) /= 1.0 or + EF.Cos(360.0, 360.0) /= 1.0 or + GEF.Cos(90.0, 360.0) /= 0.0 or + EF.Cos(270.0, 360.0) /= 0.0 or + GEF.Cos(180.0, 360.0) /= -1.0 or + EF.Cos(540.0, 360.0) /= -1.0 + then + Report.Failed("Incorrect result from the Cos function with " & + "specified cycle for prescribed results"); + end if; + + + + -- Testing of Cosh Function, both instantiated and pre-instantiated + -- version. + + -- Test for Constraint_Error on parameter with large positive magnitude. + + begin + + if New_Float'Machine_Overflows then + + New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Large)); + Report.Failed("Constraint_Error not raised when the GEF.Cosh " & + "function is provided a parameter with a large " & + "positive value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the GEF.Cosh " & + "function is provided a parameter with a large " & + "positive value"); + end; + + -- Test for Constraint_Error on parameter with large negative magnitude. + + begin + + if Float'Machine_Overflows then + The_Result := EF.Cosh (FXA5A00.Minus_Large); + Report.Failed("Constraint_Error not raised when the EF.Cosh " & + "function is provided a parameter with a " & + "large negative value"); + Dont_Optimize_Float(The_Result, 10); + end if; + + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Constraint_Error not raised when the EF.Cosh " & + "function is provided a parameter with a " & + "large negative value"); + end; + + + -- Test that no exception occurs when the Cosh function is provided a + -- very small positive or negative value. + + begin + New_Float_Result := GEF.Cosh (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cosh with a very" & + "small positive value"); + end; + + begin + The_Result := EF.Cosh (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 12); + exception + when others => + Report.Failed("Unexpected exception on EF.Cosh with a very" & + "small negative value"); + end; + + + -- Test for prescribed 1.0 result of Function Cosh with 0.0 parameter. + + if GEF.Cosh (0.0) /= 1.0 or + EF.Cosh (0.0) /= 1.0 + then + Report.Failed("Incorrect value returned from Cosh(0.0)"); + end if; + + + -- Test of Cosh function with various input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Cosh(0.24), 1.029, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(0.59), 1.179, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Cosh(1.06), 1.616, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(1.50), 2.352, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Cosh(1.84), 3.228, 0.001) or + not FXA5A00.Result_Within_Range( EF.Cosh(3.40), 14.99, 0.01) + then + Report.Failed("Incorrect result from Cosh function with " & + "various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a03.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,426 ---- + -- CXA5A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Tan, Tanh, and Arctanh provide correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Tan, Tanh, and Arctanh + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A03.A + -- + -- + -- CHANGE HISTORY: + -- 14 Mar 95 SAIC Initial prerelease version. + -- 06 Apr 95 SAIC Corrected errors in context clause references + -- and usage of Cycle parameter. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 29 Jun 98 EDS Protected exception tests by first testing + -- for 'Machine_Overflows + -- + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A03 is + begin + + Report.Test ("CXA5A03", "Check that the functions Tan, Tanh, and " & + "Arctanh provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Tan Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with large " & + "positive value"); + end; + + begin + The_Result := EF.Tan (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with large " & + "negative value"); + end; + + + -- Check that no exception occurs on computing the Tan with very + -- small (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with small " & + "positive value"); + end; + + begin + The_Result := EF.Tan (-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 4); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with small " & + "negative value"); + end; + + + -- Check prescribed result from Tan function. When the parameter X + -- has the value zero, the Tan function yields a result of zero. + + if GEF.Tan(0.0) /= 0.0 or + EF.Tan(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Tan function with zero " & + "value input parameter"); + end if; + + + -- Check the results of the Tan function with various input parameters. + + if not (Result_Within_Range(GEF.Tan(0.7854), 1.0, 0.001) and + Result_Within_Range(GEF.Tan(0.8436), 1.124, 0.001) and + Result_Within_Range( EF.Tan(Pi), 0.0, 0.001) and + Result_Within_Range( EF.Tan(-Pi), 0.0, 0.001) and + Result_Within_Range(GEF.Tan(0.5381), 0.597, 0.001) and + Result_Within_Range( EF.Tan(0.1978), 0.200, 0.001)) + then + Report.Failed("Incorrect result from Tan function with various " & + "input parameters"); + end if; + + + -- Testing of Tan function with cycle parameter. + + -- Check that Constraint_Error is raised by the Tan function with + -- specified cycle, when the value of the parameter X is an odd + -- multiple of the quarter cycle. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Tan(270.0, 360.0); + Report.Failed("Constraint_Error not raised by GEF.Tan on odd " & + "multiple of the quarter cycle"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Tan on odd " & + "multiple of the quarter cycle"); + end; + end if; + + -- Check that the exception Numerics.Argument_Error is raised, when + -- the value of the parameter Cycle is zero or negative. + + begin + New_Float_Result := GEF.Tan(X => 1.0, Cycle => -360.0); + Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & + "parameter has negative value"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by GEF.Tan when Cycle " & + "parameter has negative value"); + end; + + begin + The_Result := EF.Tan(1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by GEF.Tan when Cycle " & + "parameter has a zero value"); + Dont_Optimize_Float(The_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by EF.Tan when Cycle " & + "parameter has a zero value"); + end; + + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tan (New_Float(FXA5A00.Large), 360.0); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tan with large " & + "positive value"); + end; + + begin + The_Result := EF.Tan (FXA5A00.Minus_Large, Cycle => 360.0); + Dont_Optimize_Float(The_Result, 9); + exception + when others => + Report.Failed("Unexpected exception on EF.Tan with large " & + "negative value"); + end; + + + -- Check prescribed result from Tan function with Cycle parameter. + + if GEF.Tan(0.0, 360.0) /= 0.0 or + EF.Tan(0.0, Cycle => 360.0) /= 0.0 + then + Report.Failed("Incorrect result from Tan function with cycle " & + "parameter, using a zero value input parameter"); + end if; + + + -- Check the Tan function, with specified Cycle parameter, with a + -- variety of input parameters. + + if not Result_Within_Range(GEF.Tan(30.0, 360.0), 0.577, 0.001) or + not Result_Within_Range( EF.Tan(57.0, 360.0), 1.540, 0.001) or + not Result_Within_Range(GEF.Tan(115.0, 360.0), -2.145, 0.001) or + not Result_Within_Range( EF.Tan(299.0, 360.0), -1.804, 0.001) or + not Result_Within_Range(GEF.Tan(390.0, 360.0), 0.577, 0.001) or + not Result_Within_Range( EF.Tan(520.0, 360.0), -0.364, 0.001) + then + Report.Failed("Incorrect result from the Tan function with " & + "cycle parameter, with various input parameter " & + "values"); + end if; + + + + -- Testing of Tanh Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Tan with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Tanh (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 10); + exception + when others => + Report.Failed("Unexpected exception on GEF.Tanh with large " & + "positive value"); + end; + + begin + The_Result := EF.Tanh (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 11); + exception + when others => + Report.Failed("Unexpected exception on EF.Tanh with large " & + "negative value"); + end; + + + -- Check for prescribed result of Tanh with zero value input parameter. + + if GEF.Tanh (0.0) /= 0.0 or + EF.Tanh (0.0) /= 0.0 + then + Report.Failed("Incorrect result from Tanh with zero parameter"); + end if; + + + -- Check the results of the Tanh function with various input + -- parameters. + + if not (FXA5A00.Result_Within_Range(GEF.Tanh(2.99), 0.995, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(0.130), 0.129, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(Pi), 0.996, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(-Pi), -0.996, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(0.60), 0.537, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(1.04), 0.778, 0.001) and + FXA5A00.Result_Within_Range(GEF.Tanh(1.55), 0.914, 0.001) and + FXA5A00.Result_Within_Range( EF.Tanh(-2.14), -0.973, 0.001)) + then + Report.Failed("Incorrect result from Tanh function with various " & + "input parameters"); + end if; + + + + -- Testing of Arctanh Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised by the Arctanh function + -- when the absolute value of the parameter X is one. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Arctanh(X => 1.0); + Report.Failed("Constraint_Error not raised by Function Arctanh " & + "when provided a parameter value of 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 12); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " + & "when provided a parameter value of 1.0"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Arctanh(-1.0); + Report.Failed("Constraint_Error not raised by Function Arctanh " & + "when provided a parameter value of -1.0"); + Dont_Optimize_Float(The_Result, 13); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " + & "when provided a parameter value of -1.0"); + end; + end if; + + -- Check that Function Arctanh raises Argument_Error when the absolute + -- value of the parameter X exceeds one. + + begin + New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a parameter value greater than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 14); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a parameter value greater than 1.0"); + end; + + + begin + The_Result := EF.Arctanh(FXA5A00.Minus_One_Minus_Delta); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a parameter value less than -1.0"); + Dont_Optimize_Float(The_Result, 15); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a parameter value less than -1.0"); + end; + + + begin + New_Float_Result := GEF.Arctanh(New_Float(FXA5A00.Large)); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a large positive parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 16); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a large positive parameter value"); + end; + + + begin + The_Result := EF.Arctanh(FXA5A00.Minus_Large); + Report.Failed("Argument_Error not raised by Function Arctanh " & + "when provided a large negative parameter value"); + Dont_Optimize_Float(The_Result, 17); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arctanh " & + "when provided a large negative parameter value"); + end; + + + -- Prescribed results for Function Arctanh with zero input value. + + if GEF.Arctanh(0.0) /= 0.0 or + EF.Arctanh(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arctanh with a " & + "parameter value of zero"); + end if; + + + -- Check the results of the Arctanh function with various input + -- parameters. + + if not (Result_Within_Range(GEF.Arctanh(0.15), 0.151, 0.001) and + Result_Within_Range( EF.Arctanh(0.44), 0.472, 0.001) and + Result_Within_Range(GEF.Arctanh(0.81), 1.127, 0.001) and + Result_Within_Range( EF.Arctanh(0.99), 2.647, 0.001)) + then + Report.Failed("Incorrect result from Arctanh function with " & + "various input parameters"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a04.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,434 ---- + -- CXA5A04.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Cot, Coth, and Arccoth provide correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Cot, Coth, and Arccoth + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A04.A + -- + -- + -- CHANGE HISTORY: + -- 15 Mar 95 SAIC Initial prerelease version. + -- 07 Apr 95 SAIC Corrected errors in context clause reference, + -- added trigonometric relationship checks. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi + -- 29 Jun 98 EDS Protected exception tests by first testing + -- for 'Machine_Overflows + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with Ada.Exceptions; + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A04 is + begin + + Report.Test ("CXA5A04", "Check that the functions Cot, Coth, and " & + "Arccoth provide correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Cot Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised with the Cot function is + -- given a parameter input value of 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (0.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "when provided a zero input parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "when provided a zero input parameter value"); + end; + end if; + + -- Check that no exception occurs on computing the Cot with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 2); + exception + when others => + Report.Failed("Unexpected exception on GEF.Cot with large " & + "positive value"); + end; + + begin + The_Result := EF.Cot (FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 3); + exception + when others => + Report.Failed("Unexpected exception on EF.Cot with large " & + "negative value"); + end; + + + -- Check the results of the Cot function with various input parameters. + + if not (FXA5A00.Result_Within_Range(GEF.Cot(Pi/4.0), 1.0, 0.001) and + FXA5A00.Result_Within_Range( EF.Cot(Pi/2.0), 0.0, 0.001) and + FXA5A00.Result_Within_Range(GEF.Cot(3.0*Pi/4.0),-1.0, 0.001) and + FXA5A00.Result_Within_Range( EF.Cot(3.0*Pi/2.0), 0.0, 0.001)) + then + Report.Failed("Incorrect result from Cot function with various " & + "input parameters"); + end if; + + + -- Check the results of the Cot function against the results of + -- various trigonometric relationships. + + if not FXA5A00.Result_Within_Range(GEF.Cot(New_Float(Pi/4.0)), + 1.0/EF.Tan(Pi/4.0), + 0.001) or + not FXA5A00.Result_Within_Range(EF.Cot(Pi/4.0), + EF.Cos(Pi/4.0)/EF.Sin(Pi/4.0), + 0.001) or + not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(Pi/4.0)), + Pi/4.0, + 0.001) + then + Report.Failed("Incorrect result from Cot function with respect " & + "to various trigonometric relationship expected " & + "results"); + end if; + + + -- Testing of Cot with Cycle parameter. + + -- Check that Argument_Error is raised by the Cot function when the + -- value of the Cycle parameter is zero or negative. + + begin + New_Float_Result := GEF.Cot (1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Cot Function " & + "with a specified cycle value of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by the Cot Function with " & + "a specified cycle value of 0.0"); + end; + + begin + The_Result := EF.Cot (X => 1.0, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Cot Function " & + "with a specified cycle value of -360.0"); + Dont_Optimize_Float(The_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by the Cot Function with " & + "a specified cycle value of -360.0"); + end; + + + -- Check that Constraint_Error is raised by the Cot Function with + -- specified cycle, when the value of the parameter X is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (0.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is 0.0"); + end; + end if; + + -- Check that Constraint_Error is raised by the Cot Function with + -- specified cycle, when the value of the parameter X is a multiple + -- of the half cycle. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Cot (180.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (180.0, 360.0)"); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle" & + " (180.0, 360.0)"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Cot (540.0, 360.0); + Report.Failed("Constraint_Error not raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (540.0, 360.0)"); + Dont_Optimize_Float(The_Result, 8); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Cot " & + "with specified cycle, when value of parameter " & + "X is a multiple of the half cycle (540.0, 360.0)"); + end; + end if; + + --pwb-math -- Check that no exception occurs on computing the Cot with very + --pwb-math -- large (positive and negative) input values. + --pwb-math + --pwb-math begin + --pwb-math New_Float_Result := GEF.Cot (New_Float(FXA5A00.Large), 2.0*Pi); + --pwb-math Dont_Optimize_New_Float(New_Float_Result, 9); + --pwb-math exception + --pwb-math when others => + --pwb-math Report.Failed("Unexpected exception on GEF.Cot with large " & + --pwb-math "positive value"); + --pwb-math end; + --pwb-math + --pwb-math begin + --pwb-math The_Result := EF.Cot (FXA5A00.Minus_Large, Cycle => 2.0*Pi); + --pwb-math Dont_Optimize_Float(The_Result, 10); + --pwb-math exception + --pwb-math when others => + --pwb-math Report.Failed("Unexpected exception on EF.Cot with large " & + --pwb-math "negative value"); + --pwb-math end; + --pwb-math + --pwb-math + --pwb-math -- Check prescribed result from Cot function with Cycle parameter. + --pwb-math + --pwb-math if not FXA5A00.Result_Within_Range + --pwb-math (GEF.Cot(New_Float(FXA5A00.Half_Pi), 2.0*Pi), 0.0, 0.001) or + --pwb-math not FXA5A00.Result_Within_Range + --pwb-math (EF.Cot(3.0*Pi/2.0, Cycle => 2.0*Pi), 0.0, 0.001) + --pwb-math then + --pwb-math Report.Failed("Incorrect result from Cot function with cycle " & + --pwb-math "parameter, using a multiple of Pi/2 as the " & + --pwb-math "input parameter"); + --pwb-math end if; + + + -- Testing of Coth Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Coth with very + -- large (positive and negative) input values. + + begin + The_Result := EF.Coth (FXA5A00.Large); + if The_Result > 1.0 then + Report.Failed("Result of Coth function with large positive " & + "value greater than 1.0"); + end if; + exception + when others => + Report.Failed("Unexpected exception on EF.Coth with large " & + "positive value"); + end; + + begin + The_Result := EF.Coth (FXA5A00.Minus_Large); + if The_Result < -1.0 then + Report.Failed("Result of Coth function with large negative " & + "value less than -1.0"); + end if; + exception + when others => + Report.Failed("Unexpected exception on EF.Coth with large " & + "negative value"); + end; + + + -- Check that Constraint_Error is raised by the Coth function, when + -- the value of the parameter X is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Coth (X => 0.0); + Report.Failed("Constraint_Error not raised by the Coth function " & + "when the value of parameter X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Coth " & + "function when the value of parameter X is 0.0"); + end; + end if; + + + -- Testing of Arccoth Function, both instantiated and pre-instantiated + -- version. + + -- Check that Constraint_Error is raised by the Arccoth function + -- when the absolute value of the parameter X is 1.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Arccoth (X => 1.0); + Report.Failed("Constraint_Error not raised by the Arccoth " & + "function when the value of parameter X is 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 12); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function when the value of parameter X is 1.0"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + The_Result := EF.Arccoth (-1.0); + Report.Failed("Constraint_Error not raised by the Arccoth " & + "function when the value of parameter X is -1.0"); + Dont_Optimize_Float(The_Result, 13); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function when the value of parameter X is -1.0"); + end; + end if; + + -- Check that Argument_Error is raised by the Arccoth function when + -- the absolute value of the parameter X is less than 1.0. + + begin + New_Float_Result := GEF.Arccoth (X => New_Float(One_Minus_Delta)); + Report.Failed("Argument_Error not raised by the Arccoth " & + "function with parameter value less than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 14); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function with parameter value less than 1.0"); + end; + + begin + The_Result := EF.Arccoth (X => FXA5A00.Minus_One_Plus_Delta); + Report.Failed("Argument_Error not raised by the Arccoth function " & + "with parameter value between 0.0 and -1.0"); + Dont_Optimize_Float(The_Result, 15); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccoth " & + "function with parameter value between 0.0 " & + "and -1.0"); + end; + + + -- Check the results of the Arccoth function with various input + -- parameters. + + if not (Result_Within_Range(GEF.Arccoth(1.01), 2.652, 0.01) and + Result_Within_Range( EF.Arccoth(1.25), 1.099, 0.01) and + Result_Within_Range(GEF.Arccoth(1.56), 0.760, 0.001) and + Result_Within_Range( EF.Arccoth(1.97), 0.560, 0.001) and + Result_Within_Range(GEF.Arccoth(2.40), 0.444, 0.001) and + Result_Within_Range( EF.Arccoth(4.30), 0.237, 0.001) and + Result_Within_Range(GEF.Arccoth(5.80), 0.174, 0.001) and + Result_Within_Range( EF.Arccoth(7.00), 0.144, 0.001)) + then + Report.Failed("Incorrect result from Arccoth function with various " & + "input parameters"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA5A04; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a05.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- CXA5A05.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Arcsin and Arcsinh provide correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Arcsin and Arcsinh + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A05.A + -- + -- + -- CHANGE HISTORY: + -- 20 Mar 95 SAIC Initial prerelease version. + -- 06 Apr 95 SAIC Corrected errors in context clause reference and + -- use of Cycle parameter. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 28 Feb 97 PWB.CTA Removed checks with explict Cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A05 is + begin + + Report.Test ("CXA5A05", "Check that the functions Arcsin and Arcsinh " & + "provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Function Arcsin, both instantiated and pre-instantiated + -- versions. + + -- Check that Argument_Error is raised by the Arcsin function when + -- the absolute value of the parameter X is greater than 1.0. + + begin + New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by Arcsin function " & + "when provided a parameter value larger than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Arcsin function " & + "when provided a parameter value larger than 1.0"); + end; + + begin + The_Result := EF.Arcsin(FXA5A00.Minus_Large); + Report.Failed("Argument_Error not raised by Arcsin function " & + "when provided a large negative parameter value"); + Dont_Optimize_Float(The_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Arcsin function " & + "when provided a large negative parameter value"); + end; + + + -- Check the prescribed result of function Arcsin with parameter 0.0. + + if GEF.Arcsin(X => 0.0) /= 0.0 or + EF.Arcsin(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arcsin when the " & + "value of the parameter X is 0.0"); + end if; + + + -- Check the results of the Arcsin function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arcsin(1.0), 1.571, 0.001) or + not Result_Within_Range( EF.Arcsin(0.62), 0.669, 0.001) or + not Result_Within_Range(GEF.Arcsin(0.01), 0.010, 0.001) or + not Result_Within_Range( EF.Arcsin(-0.29), -0.294, 0.001) or + not Result_Within_Range(GEF.Arcsin(-0.50), -0.524, 0.001) or + not Result_Within_Range( EF.Arcsin(-1.0), -1.571, 0.001) + then + Report.Failed("Incorrect result from Function Arcsin with " & + "various input parameters"); + end if; + + + -- Testing of Function Arcsin with specified Cycle parameter. + + --pwb-math -- Check that Argument_Error is raised by the Arcsin function with + --pwb-math -- specified cycle, whenever the absolute value of the parameter X + --pwb-math -- is greater than 1.0. + --pwb-math + --pwb-math begin + --pwb-math New_Float_Result := GEF.Arcsin(New_Float(FXA5A00.Large), 2.0*Pi); + --pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & + --pwb-math "with specified cycle, when provided a large " & + --pwb-math "positive input parameter"); + --pwb-math Dont_Optimize_New_Float(New_Float_Result, 3); + --pwb-math exception + --pwb-math when Argument_Error => null; -- OK, expected exception. + --pwb-math when others => + --pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & + --pwb-math "with specified cycle, when provided a large " & + --pwb-math "positive input parameter"); + --pwb-math end; + --pwb-math + --pwb-math begin + --pwb-math The_Result := EF.Arcsin(FXA5A00.Minus_One_Minus_Delta, 2.0*Pi); + --pwb-math Report.Failed("Argument_Error not raised by Function Arcsin " & + --pwb-math "with specified cycle, when provided an input " & + --pwb-math "parameter less than -1.0"); + --pwb-math Dont_Optimize_Float(The_Result, 4); + --pwb-math exception + --pwb-math when Argument_Error => null; -- OK, expected exception. + --pwb-math when others => + --pwb-math Report.Failed("Unexpected exception raised by Function Arcsin " & + --pwb-math "with specified cycle, when provided an input " & + --pwb-math "parameter less than -1.0"); + --pwb-math end; + --pwb-math + -- Check that Argument_Error is raised by the Arcsin function with + -- specified cycle, whenever the Cycle parameter is zero or negative. + + begin + New_Float_Result := GEF.Arcsin(2.0, 0.0); + Report.Failed("Argument_Error not raised by Function Arcsin " & + "with specified cycle of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arcsin " & + "with specified cycle of 0.0"); + end; + + begin + The_Result := EF.Arcsin(2.0, -2.0*Pi); + Report.Failed("Argument_Error not raised by Function Arcsin " & + "with specified negative cycle parameter"); + Dont_Optimize_Float(The_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Arcsin " & + "with specified negative cycle parameter"); + end; + + + --pwb-math -- Check the prescribed result of function Arcsin with specified Cycle + --pwb-math -- parameter, when the value of parameter X is 0.0. + --pwb-math + --pwb-math if GEF.Arcsin(X => 0.0, Cycle => 2.0*Pi) /= 0.0 or + --pwb-math EF.Arcsin(0.0, 2.0*Pi) /= 0.0 + --pwb-math then + --pwb-math Report.Failed("Incorrect result from Function Arcsin with " & + --pwb-math "specified Cycle parameter, when the value " & + --pwb-math "of parameter X is 0.0"); + --pwb-math end if; + --pwb-math + --pwb-math + --pwb-math -- Test of the Arcsin function with specified Cycle parameter with + --pwb-math -- various input parameters. + --pwb-math + --pwb-math if not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.01, 2.0*Pi), + --pwb-math 0.010, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.14, 2.0*Pi), + --pwb-math 0.141, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin( 0.37, 2.0*Pi), + --pwb-math 0.379, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin( 0.55, 2.0*Pi), + --pwb-math 0.582, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range(GEF.Arcsin(-0.22, 2.0*Pi), + --pwb-math -0.222, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(-0.99, 2.0*Pi), + --pwb-math -1.43, + --pwb-math 0.01) or + --pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 360.0), + --pwb-math 90.0, + --pwb-math 0.1) or + --pwb-math not FXA5A00.Result_Within_Range( EF.Arcsin(1.0, 100.0), + --pwb-math 25.0, + --pwb-math 0.1) + --pwb-math then + --pwb-math Report.Failed("Incorrect result from Arcsin with specified " & + --pwb-math "cycle parameter with various input parameters"); + --pwb-math end if; + + -- Testing of Arcsinh Function, both instantiated and pre-instantiated + -- version. + + -- Check that no exception occurs on computing the Arcsinh with very + -- large (positive and negative) input values. + + begin + New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with large " & + "positive value"); + end; + + begin + The_Result := EF.Arcsinh(FXA5A00.Minus_Large); + Dont_Optimize_Float(The_Result, 8); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with large " & + "negative value"); + end; + + + -- Check that no exception occurs on computing the Arcsinh with very + -- small (positive and negative) input values. + + begin + New_Float_Result := GEF.Arcsinh(New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with small " & + "positive value"); + end; + + begin + The_Result := EF.Arcsinh(-FXA5A00.Small); + Dont_Optimize_Float(The_Result, 10); + exception + when others => + Report.Failed("Unexpected exception on Arcsinh with small " & + "negative value"); + end; + + + -- Check function Arcsinh for prescribed result with parameter 0.0. + + if GEF.Arcsinh(X => 0.0) /= 0.0 or + EF.Arcsinh(X => 0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Arcsinh when " & + "provided a 0.0 input parameter"); + end if; + + + -- Check the results of the Arcsinh function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arcsinh(0.15), 0.149, 0.001) or + not Result_Within_Range( EF.Arcsinh(0.82), 0.748, 0.001) or + not Result_Within_Range(GEF.Arcsinh(1.44), 1.161, 0.001) or + not Result_Within_Range(GEF.Arcsinh(6.70), 2.601, 0.001) or + not Result_Within_Range( EF.Arcsinh(Pi), 1.862, 0.001) or + not Result_Within_Range( EF.Arcsinh(-Pi), -1.862, 0.001) or + not Result_Within_Range(GEF.Arcsinh(-1.0), -0.881, 0.001) or + not Result_Within_Range( EF.Arcsinh(-5.5), -2.406, 0.001) + then + Report.Failed("Incorrect result from Function Arcsin with " & + "various input parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A05; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a06.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- CXA5A06.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Arccos and Arccosh provide correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Arccos and Arccosh + -- the instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A06.A + -- + -- + -- CHANGE HISTORY: + -- 27 Mar 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A06 is + begin + + Report.Test ("CXA5A06", "Check that the functions Arccos and Arccosh " & + "provide correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + The_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arccos Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccos function when the + -- absolute value of the input parameter is greater than 1.0. + + begin + New_Float_Result := GEF.Arccos(New_Float(FXA5A00.One_Plus_Delta)); + Report.Failed("Argument_Error not raised by the Arccos function " & + "when the input parameter is greater than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function when the input parameter is greater " & + "than 1.0"); + end; + + begin + The_Result := EF.Arccos(-FXA5A00.Large); + Report.Failed("Argument_Error not raised by the Arccos function " & + "when the input parameter is a large negative value"); + Dont_Optimize_Float(The_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function when the input parameter is a " & + "large negative value"); + end; + + + -- Check the prescribed results of the Arccos function. + + if GEF.Arccos(X => 1.0) /= 0.0 or + EF.Arccos(1.0) /= 0.0 + then + Report.Failed("Incorrect result returned by the Arccos function " & + "when provided a parameter value of 0.0"); + end if; + + + -- Check the results of the Arccos function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arccos(0.77), 0.692, 0.001) or + not Result_Within_Range( EF.Arccos(0.37), 1.19, 0.01) or + not Result_Within_Range(GEF.Arccos(0.0), Pi/2.0, 0.01) or + not Result_Within_Range( EF.Arccos(-0.11), 1.68, 0.01) or + not Result_Within_Range(GEF.Arccos(-0.67), 2.31, 0.01) or + not Result_Within_Range( EF.Arccos(-0.94), 2.79, 0.01) or + not Result_Within_Range(GEF.Arccos(-1.0), Pi, 0.01) + then + Report.Failed("Incorrect result returned from the Arccos " & + "function when provided a variety of input " & + "parameters"); + end if; + + + -- Testing of the Arccos function with specified Cycle parameter. + + -- Check that Argument_Error is raised by the Arccos function, with + -- specified Cycle parameter, when the absolute value of the input + -- parameter is greater than 1.0. + + begin + --pwb-math: Next line: Changed 2.0*Pi to 360.0 + New_Float_Result := GEF.Arccos(New_Float(Large), Cycle => 360.0); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the input " & + "parameter is a large positive value"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the input parameter is a large positive value"); + end; + + begin + --pwb-math: Next line: Changed 2.0*Pi to 360.0 + The_Result := EF.Arccos(FXA5A00.Minus_One_Minus_Delta, 360.0); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the input " & + "parameter is less than -1.0"); + Dont_Optimize_Float(The_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, " & + "when the input parameter is less than -1.0"); + end; + + + -- Check that Argument_Error is raised by the Arccos function with + -- specified cycle when the value of the Cycle parameter is zero or + -- negative. + + begin + New_Float_Result := GEF.Arccos(X => 1.0, Cycle => 0.0 ); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the Cycle parameter is 0.0"); + end; + + begin + The_Result := EF.Arccos(1.0, Cycle => -2.0*Pi); + Report.Failed("Argument_Error not raised by the Arccos function " & + "with specified Cycle parameter, when the Cycle " & + "parameter is negative"); + Dont_Optimize_Float(The_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccos " & + "function with specified Cycle parameter, when " & + "the Cycle parameter is negative"); + end; + + + -- Check the prescribed result of the Arccos function with specified + -- Cycle parameter. + + --pwb-math: Next two lines: Changed 2.0*Pi to 360.0 + if GEF.Arccos(X => 1.0, Cycle => 360.0) /= 0.0 or + EF.Arccos(1.0, 360.0) /= 0.0 + then + Report.Failed("Incorrect result from the Arccos function with " & + "specified Cycle parameter, when the input " & + "parameter value is 1.0"); + end if; + + + -- Check the results of the Arccos function, with specified Cycle + -- parameter, with various input parameters. + + if --pwb-math not Result_Within_Range(GEF.Arccos( 0.04, 2.0*Pi), 1.53, 0.01) or + --pwb-math not Result_Within_Range( EF.Arccos( 0.14, 2.0*Pi), 1.43, 0.01) or + --pwb-math not Result_Within_Range(GEF.Arccos( 0.57, 2.0*Pi), 0.96, 0.01) or + --pwb-math not Result_Within_Range( EF.Arccos( 0.99, 2.0*Pi), 0.14, 0.01) or + not Result_Within_Range(GEF.Arccos(-1.0, 360.0), 180.0, 0.1) or + not Result_Within_Range(GEF.Arccos(-1.0, 100.0), 50.0, 0.1) or + not Result_Within_Range(GEF.Arccos( 0.0, 360.0), 90.0, 0.1) or + not Result_Within_Range(GEF.Arccos( 0.0, 100.0), 25.0, 0.1) + then + Report.Failed("Incorrect result returned from the Arccos " & + "function with specified Cycle parameter, " & + "when provided a variety of input parameters"); + end if; + + + + -- Testing of Arccosh Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccosh function when + -- the value of the parameter X is less than 1.0. + + begin + New_Float_Result := GEF.Arccosh(New_Float(FXA5A00.One_Minus_Delta)); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the parameter value is less than 1.0"); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a parameter value less " & + "than 1.0"); + end; + + begin + The_Result := EF.Arccosh(0.0); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the parameter value is 0.0"); + Dont_Optimize_Float(The_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a parameter value of 0.0"); + end; + + begin + New_Float_Result := GEF.Arccosh(New_Float(-FXA5A00.Large)); + Report.Failed("Argument_Error not raised by the Arccosh function " & + "when the large negative parameter value"); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Arccosh " & + "function when given a large negative parameter " & + "value"); + end; + + + -- Check the prescribed results of the Arccosh function. + + if GEF.Arccosh(X => 1.0) /= 0.0 or + EF.Arccosh(1.0) /= 0.0 + then + Report.Failed("Incorrect result returned by the Arccosh " & + "function when provided a parameter value of 0.0"); + end if; + + + -- Check the results of the Arccosh function with various input + -- parameters. + + if not Result_Within_Range(GEF.Arccosh(1.03), 0.244, 0.001) or + not Result_Within_Range( EF.Arccosh(1.28), 0.732, 0.001) or + not Result_Within_Range(GEF.Arccosh(1.50), 0.962, 0.001) or + not Result_Within_Range( EF.Arccosh(1.77), 1.17, 0.01) or + not Result_Within_Range(GEF.Arccosh(2.00), 1.32, 0.01) or + not Result_Within_Range( EF.Arccosh(4.30), 2.14, 0.01) or + not Result_Within_Range(GEF.Arccosh(6.90), 2.62, 0.01) + then + Report.Failed("Incorrect result returned from the Arccosh " & + "function when provided a variety of input " & + "parameters"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A06; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a07.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,413 ---- + -- CXA5A07.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Arctan provides correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Arctan resulting from the + -- instantiation of the Ada.Numerics.Generic_Elementary_Functions with + -- a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A07.A + -- + -- + -- CHANGE HISTORY: + -- 04 Apr 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 28 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A07 is + begin + + Report.Test ("CXA5A07", "Check that the Arctan function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Float_Result : Float; + New_Float_Result : New_Float; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arctan Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arctan function when + -- provided parameter values of 0.0, 0.0. + + begin + New_Float_Result := GEF.Arctan(Y => 0.0, X => 0.0); + Report.Failed("Argument_Error not raised when the Arctan " & + "function is provided input of 0.0, 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided 0.0, 0.0 input parameters"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided a large positive or negative Y parameter value, when + -- using the default value for parameter X. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 2); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large negative Y parameter value"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided a small positive or negative Y parameter value, when + -- using the default value for parameter X. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Small); + Dont_Optimize_Float(Float_Result, 4); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => New_Float(-FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small negative Y parameter value"); + end; + + + -- Check that no exception is raised by the Arctan function when + -- provided combinations of large and small positive or negative + -- parameter values for both Y and X input parameters. + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Large, X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 6); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided large positive X and Y parameter values"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Large), + X => New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a large negative Y parameter value " & + "and a small positive X parameter value"); + end; + + + begin + Float_Result := EF.Arctan(Y => FXA5A00.Small, X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 8); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small positive Y parameter value " & + "and a large positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(-FXA5A00.Small), + New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Exception raised when the Arctan function is " & + "provided a small negative Y parameter value " & + "and a large negative parameter value"); + end; + + + -- Check that when the Arctan function is provided a Y parameter value + -- of 0.0 and a positive X parameter input value, the prescribed result + -- of zero is returned. + + if GEF.Arctan(Y => 0.0) /= 0.0 or -- Default X value + EF.Arctan(Y => 0.0, X => FXA5A00.Large) /= 0.0 or + --pwb-math: Next line: changed 2.0*Pi to 360.0 + GEF.Arctan(0.0, 360.0) /= 0.0 or + EF.Arctan(0.0, FXA5A00.Small) /= 0.0 + then + Report.Failed("Incorrect results from the Arctan function when " & + "provided a Y parameter value of 0.0 and various " & + "positive X parameter values"); + end if; + + + -- Check that the Arctan function provides correct results when provided + -- a variety of Y parameter values. + + if not FXA5A00.Result_Within_Range(EF.Arctan(Pi), 1.26, 0.01) or + not FXA5A00.Result_Within_Range(EF.Arctan(-Pi), -1.26, 0.01) or + not FXA5A00.Result_Within_Range(GEF.Arctan(1.0), 0.785, 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(-1.0), -0.785, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arctan(0.25), 0.245, 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(0.92), 0.744, 0.001) + then + Report.Failed("Incorrect results from the Arctan function when " & + "provided a variety of Y parameter values"); + end if; + + + + -- Check the results of the Arctan function with specified cycle + -- parameter. + + -- Check that the Arctan function with specified Cycle parameter + -- raises Argument_Error when the value of the Cycle parameter is zero + -- or negative. + + begin + Float_Result := EF.Arctan(Y => Pi, Cycle => 0.0); -- Default X value + Report.Failed("Argument_Error not raised by the Arctan function " & + "with default X parameter value, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_Float(Float_Result, 10); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function with default X parameter value, when " & + "provided a 0.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Arctan function " & + "when the Cycle parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided a 0.0 cycle parameter " & + "value"); + end; + + begin + Float_Result := EF.Arctan(Y => Pi, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Arctan function " & + "with a default X parameter value, when the Cycle " & + "parameter is -360.0"); + Dont_Optimize_Float(Float_Result, 12); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function with a default X parameter value, when " & + "provided a -360.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(Y => Pi, X => 1.0, Cycle => -Pi); + Report.Failed("Argument_Error not raised by the Arctan function " & + "when the Cycle parameter is -Pi"); + Dont_Optimize_New_Float(New_Float_Result, 13); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arctan " & + "function when provided a -Pi cycle parameter " & + "value"); + end; + + + -- Check that no exception is raised by the Arctan function with + -- specified Cycle parameter, when provided large and small positive + -- or negative parameter values for both Y and X input parameters. + + begin + Float_Result := EF.Arctan(Y => -FXA5A00.Large, + X => -FXA5A00.Large, + --pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 14); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "negative X and Y parameter values"); + end; + + + begin + New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Large), + X => New_Float(-FXA5A00.Small), + --pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_New_Float(New_Float_Result, 15); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "positive Y parameter value and a small negative " & + "X parameter value"); + end; + + + begin + Float_Result := EF.Arctan(Y => -FXA5A00.Small, + X => -FXA5A00.Large, + --pwb-math: Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 16); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided large " & + "negative Y parameter value and a large negative " & + "X parameter value"); + end; + + begin + New_Float_Result := GEF.Arctan(New_Float(FXA5A00.Small), + New_Float(FXA5A00.Large), + --pwb-math: Next line: changed 2.0*Pi to 360.0 + 360.0); + Dont_Optimize_New_Float(New_Float_Result, 17); + exception + when others => + Report.Failed("Exception raised when the Arctan function with " & + "specified Cycle parameter, when provided a " & + "small negative Y parameter value and a large " & + "positive X parameter value"); + end; + + + -- Check that the Arctan function with specified Cycle parameter + -- provides correct results when provided a variety of Y parameter + -- input values. + + --pwb-math if not FXA5A00.Result_Within_Range(EF.Arctan(Pi, Cycle => 2.0*Pi), + --pwb-math 1.26, + --pwb-math 0.01) or + --pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-Pi, Cycle => 2.0*Pi), + --pwb-math -1.26, + --pwb-math 0.01) or + --pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*Pi), + --pwb-math 0.785, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*Pi), + --pwb-math -0.785, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(0.16, Cycle => 2.0*Pi), + --pwb-math 0.159, + --pwb-math 0.001) or + --pwb-math not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), + --pwb-math 45.0, + --pwb-math 0.1) or + --pwb-math not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), + --pwb-math 12.5, + --pwb-math 0.1) + + --pwb-math Next 12 lines are replacements for 21 commented lines above + if not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 2.0*180.0), + 45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(-1.0, Cycle => 2.0*180.0), + -45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arctan(1.0, Cycle => 360.0), + 45.0, + 0.1) or + not FXA5A00.Result_Within_Range(GEF.Arctan(1.0, Cycle => 100.0), + 12.5, + 0.1) + then + Report.Failed("Incorrect results from the Arctan function with " & + "specified Cycle parameter when provided a variety " & + "of Y parameter values"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A07; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a08.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,474 ---- + -- CXA5A08.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Arccot provides correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Arccot resulting from the + -- instantiation of the Ada.Numerics.Generic_Elementary_Functions + -- with a type derived from type Float, as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A08.A + -- + -- + -- CHANGE HISTORY: + -- 06 Apr 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 28 Feb 97 CTA.PWB Removed checks with explicit Cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with Ada.Exceptions; + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A08 is + begin + + Report.Test ("CXA5A08", "Check that the Arccot function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Float_Result : Float; + Angle : Float; + New_Float_Result : New_Float; + New_Float_Angle : New_Float; + Incorrect_Inverse : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Arccot Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Arccot function when + -- provided parameter values of 0.0, 0.0. + + begin + New_Float_Result := GEF.Arccot(X => 0.0, Y => 0.0); + Report.Failed("Argument_Error not raised when the Arccot " & + "function is provided input of 0.0, 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided 0.0, 0.0 input parameters"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided a large positive or negative X parameter value, when + -- using the default value for parameter Y. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 2); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large negative X parameter value"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided a small positive or negative X parameter value, when + -- using the default value for parameter Y. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Small); + Dont_Optimize_Float(Float_Result, 4); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small positive X parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => New_Float(-FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small negative X parameter value"); + end; + + + -- Check that no exception is raised by the Arccot function when + -- provided combinations of large and small positive or negative + -- parameter values for both X and Y input parameters. + + begin + Float_Result := EF.Arccot(X => FXA5A00.Large, Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 6); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided large positive X and Y parameter values"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Large), + Y => New_Float(FXA5A00.Small)); + Dont_Optimize_New_Float(New_Float_Result, 7); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a large negative X parameter value " & + "and a small positive Y parameter value"); + end; + + + begin + Float_Result := EF.Arccot(X => FXA5A00.Small, Y => FXA5A00.Large); + Dont_Optimize_Float(Float_Result, 8); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small positive X parameter value " & + "and a large positive Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(-FXA5A00.Small), + New_Float(-FXA5A00.Large)); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when others => + Report.Failed("Exception raised when the Arccot function is " & + "provided a small negative X parameter value " & + "and a large negative Y parameter value"); + end; + + + -- Check that when the Arccot function is provided a Y parameter value + -- of 0.0 and a positive X parameter input value, the prescribed result + -- of zero is returned. + + if EF.Arccot(X => FXA5A00.Large, Y => 0.0) /= 0.0 or + GEF.Arccot(2.0*Pi, Y => 0.0) /= 0.0 or + EF.Arccot(FXA5A00.Small, 0.0) /= 0.0 or + EF.Arccot(X => FXA5A00.Large, Y => 0.0, Cycle => 360.0) /= 0.0 or + GEF.Arccot(2.0*Pi, Y => 0.0, Cycle => 360.0) /= 0.0 or + EF.Arccot(FXA5A00.Small, 0.0, Cycle => 360.0) /= 0.0 + then + Report.Failed("Incorrect results from the Arccot function when " & + "provided a Y parameter value of 0.0 and various " & + "positive X parameter values"); + end if; + + + -- Check that the Arccot function provides correct results when + -- provided a variety of X parameter values. + + if not Result_Within_Range( EF.Arccot( 1.0), Pi/4.0, 0.001) or + not Result_Within_Range(GEF.Arccot( 0.0), Pi/2.0, 0.001) or + not Result_Within_Range( EF.Arccot(-1.0), 3.0*Pi/4.0, 0.001) + then + Report.Failed("Incorrect results from the Arccot function when " & + "provided a variety of Y parameter values"); + end if; + + + -- Check the results of the Arccot function with specified cycle + -- parameter. + + -- Check that the Arccot function with specified Cycle parameter + -- raises Argument_Error when the value of the Cycle parameter is zero + -- or negative. + + begin + Float_Result := EF.Arccot(X => Pi, Cycle => 0.0); -- Default Y value + Report.Failed("Argument_Error not raised by the Arccot function " & + "with default Y parameter value, when the Cycle " & + "parameter is 0.0"); + Dont_Optimize_Float(Float_Result, 10); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function with default Y parameter value, when " & + "provided a 0.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => 0.0); + Report.Failed("Argument_Error not raised by the Arccot function " & + "when the Cycle parameter is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 11); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided a 0.0 cycle parameter " & + "value"); + end; + + begin + Float_Result := EF.Arccot(X => Pi, Cycle => -360.0); + Report.Failed("Argument_Error not raised by the Arccot function " & + "with a default Y parameter value, when the Cycle " & + "parameter is -360.0"); + Dont_Optimize_Float(Float_Result, 12); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function with a default Y parameter value, when " & + "provided a -360.0 cycle parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(X => Pi, Y => 1.0, Cycle => -Pi); + Report.Failed("Argument_Error not raised by the Arccot function " & + "when the Cycle parameter is -Pi"); + Dont_Optimize_New_Float(New_Float_Result, 13); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by the Arccot " & + "function when provided a -Pi cycle parameter " & + "value"); + end; + + + -- Check that no exception is raised by the Arccot function with + -- specified Cycle parameter, when provided large and small positive + -- or negative parameter values for both X and Y input parameters. + + begin + Float_Result := EF.Arccot(X => -FXA5A00.Large, + Y => -FXA5A00.Large, + --pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 14); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided large " & + "negative X and Y parameter values"); + end; + + + begin + New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Large), + Y => New_Float(-FXA5A00.Small), + --pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_New_Float(New_Float_Result, 15); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided large " & + "positive X parameter value and a small negative " & + "Y parameter value"); + end; + + + begin + Float_Result := EF.Arccot(X => -FXA5A00.Small, + Y => -FXA5A00.Large, + --pwb-math Next line: changed 2.0*Pi to 360.0 + Cycle => 360.0); + Dont_Optimize_Float(Float_Result, 16); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided small " & + "negative X parameter value and a large negative " & + "Y parameter value"); + end; + + begin + New_Float_Result := GEF.Arccot(New_Float(FXA5A00.Small), + New_Float(FXA5A00.Large), + --pwb-math Next line: changed 2.0*Pi to 360.0 + 360.0); + Dont_Optimize_New_Float(New_Float_Result, 17); + exception + when others => + Report.Failed("Exception raised when the Arccot function with " & + "specified Cycle parameter, when provided a " & + "small positive X parameter value and a large " & + "positive Y parameter value"); + end; + + + -- Check that the Arccot function with specified Cycle parameter + -- provides correct results when provided a variety of X parameter + -- input values. + + if not FXA5A00.Result_Within_Range(GEF.Arccot( 0.0, Cycle => 360.0), + 90.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot( 0.0, Cycle => 100.0), + 25.0, + 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arccot( 1.0, Cycle => 360.0), + 45.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot( 1.0, Cycle => 100.0), + 12.5, + 0.001) or + not FXA5A00.Result_Within_Range(GEF.Arccot(-1.0, Cycle => 360.0), + 135.0, + 0.001) or + not FXA5A00.Result_Within_Range(EF.Arccot(-1.0, Cycle => 100.0), + 37.5, + 0.001) + then + Report.Failed("Incorrect results from the Arccot function with " & + "specified Cycle parameter when provided a variety " & + "of X parameter values"); + end if; + + + if not FXA5A00.Result_Within_Range(EF.Arccot(0.2425355, 0.9701420), + EF.Arccot(0.25), + 0.01) or + not FXA5A00.Result_Within_Range(EF.Arccot(0.3162277, 0.9486831), + Ef.Arccot(0.33), + 0.01) + then + Report.Failed("Incorrect results from the Arccot function with " & + "comparison to other Arccot function results"); + end if; + + + if not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.4472135, + 0.8944270)), + 0.5, + 0.01) or + not FXA5A00.Result_Within_Range(EF.Cot(EF.Arccot(0.9987380, + 0.0499369)), + 20.0, + 0.1) + then + Report.Failed("Incorrect results from the Arccot function when " & + "used as argument to Cot function"); + end if; + + + -- Check that inverse function results are correct. + -- Default Cycle test. + + Angle := 0.001; + while Angle < Pi and not Incorrect_Inverse loop + if not Result_Within_Range(EF.Arccot(EF.Cot(Angle)), Angle, 0.001) + then + Incorrect_Inverse := True; + end if; + Angle := Angle + 0.001; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect results returned from the Inverse " & + "comparison of Cot and Arccot using the default " & + "cycle value"); + Incorrect_Inverse := False; + end if; + + -- Non-Default Cycle test. + + New_Float_Angle := 0.01; + while New_Float_Angle < 180.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF.Arccot(EF.Cot(Float(New_Float_Angle), + Cycle => 360.0), + Cycle => 360.0), + Float(New_Float_Angle), + 0.01) or + not Result_Within_Range(GEF.Arccot( + New_Float(GEF.Cot(New_Float_Angle, + Cycle => 360.0)), + Cycle => 360.0), + Float(New_Float_Angle), + 0.01) + then + Incorrect_Inverse := True; + end if; + New_Float_Angle := New_Float_Angle + 0.01; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect results returned from the Inverse " & + "comparison of Cot and Arccot using non-default " & + "cycle value"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA5A08; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a09.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,400 ---- + -- CXA5A09.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Log provides correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the version of Log resulting from the + -- instantiation of the Ada.Numerics.Generic_Elementary_Functions with + -- with a type derived from type Float,as well as the preinstantiated + -- version of this package for type Float. + -- Prescribed results, including instances prescribed to raise + -- exceptions, are examined in the test cases. In addition, + -- certain evaluations are performed where the actual function result + -- is compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A09.A + -- + -- + -- CHANGE HISTORY: + -- 11 Apr 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 29 Jun 98 EDS Protected exception tests by first testing + -- for 'Machine_Overflows + -- + --! + + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A09 is + begin + + Report.Test ("CXA5A09", "Check that the Log function provides " & + "correct results"); + + Test_Block: + declare + + use Ada.Numerics; + use FXA5A00; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + Arg, + Float_Result : Float := 0.0; + New_Float_Result : New_Float := 0.0; + + Incorrect_Inverse, + Incorrect_Inverse_Base_2, + Incorrect_Inverse_Base_8, + Incorrect_Inverse_Base_10, + Incorrect_Inverse_Base_16 : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of Log Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised when the parameter X is negative. + + begin + New_Float_Result := GEF.Log(X => -1.0); + Report.Failed("Argument_Error not raised by the Log function " & + "when the input parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "when the input parameter is negative"); + end; + + begin + Float_Result := EF.Log(X => -FXA5A00.Large); + Report.Failed("Argument_Error not raised by the Log function " & + "when the input parameter is negative"); + Dont_Optimize_Float(Float_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "when the input parameter is negative"); + end; + + + -- Check that Constraint_Error is raised when the Log function is + -- provided an input parameter of zero. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Log(X => 0.0); + Report.Failed("Constraint_Error not raised by the Log function " & + "when the input parameter is zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " + & "when the input parameter is zero"); + end; + end if; + + + -- Check for the reference manual prescribed results of the Log function. + + if GEF.Log(X => 1.0) /= 0.0 or + EF.Log(X => 1.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Log when provided " & + "an input parameter value of 1.0"); + end if; + + + -- Check that the Log function provides correct results when provided + -- a variety of input parameters. + + if not FXA5A00.Result_Within_Range(GEF.Log(0.015), -4.20, 0.01) or + not FXA5A00.Result_Within_Range(GEF.Log(0.592), -0.524, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Log(0.997), -0.003, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Log(1.341), 0.293, 0.001) or + not FXA5A00.Result_Within_Range( EF.Log(2.826), 1.04, 0.01) or + not FXA5A00.Result_Within_Range( EF.Log(10.052), 2.31, 0.01) or + not FXA5A00.Result_Within_Range( EF.Log(2569.143), 7.85, 0.01) + then + Report.Failed("Incorrect results from Function Log when provided " & + "a variety of input parameter values"); + end if; + + Arg := 0.001; + while Arg < 1.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.001) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 0.001; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 0.001..1.0"); + Incorrect_Inverse := False; + end if; + + Arg := 1.0; + while Arg < 10.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.01) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 0.01; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 1.0..10.0"); + Incorrect_Inverse := False; + end if; + + Arg := 1.0; + while Arg < 1000.0 and not Incorrect_Inverse loop + if not Result_Within_Range(EF."**"(e,EF.Log(Arg)), Arg, 0.1) then + Incorrect_Inverse := True; + end if; + Arg := Arg + 1.0; + end loop; + + if Incorrect_Inverse then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function over argument range 1.0..1000.0"); + end if; + + + -- Testing of Log Function, with specified Base parameter, both + -- instantiated and pre-instantiated versions. + + -- Check that Argument_Error is raised by the Log function with + -- specified Base parameter, when the X parameter value is negative. + + begin + New_Float_Result := GEF.Log(X => -1.0, Base => 16.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter, when the input parameter " & + "value is -1.0"); + Dont_Optimize_New_Float(New_Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter, when the X parameter value " & + "is -1.0"); + end; + + begin + Float_Result := EF.Log(X => -FXA5A00.Large, Base => 8.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter, when the X parameter " & + "value is a large negative value"); + Dont_Optimize_Float(Float_Result, 5); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter, when the X parameter " & + "value is a large negative value"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is zero. + + begin + New_Float_Result := GEF.Log(X => 10.0, Base => 0.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter of 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 6); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter of 0.0"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is one. + + begin + Float_Result := EF.Log(X => 12.3, Base => 1.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with Base parameter of 1.0"); + Dont_Optimize_Float(Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with Base parameter of 1.0"); + end; + + + -- Check that Argument_Error is raised by the Log function when + -- the specified Base parameter is negative. + + begin + New_Float_Result := GEF.Log(X => 12.3, Base => -10.0); + Report.Failed("Argument_Error not raised by the Log function " & + "with negative Base parameter"); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the Log function " & + "with negative Base parameter"); + end; + + + -- Check that Constraint_Error is raised by the Log function when the + -- input X parameter value is 0.0. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF.Log(X => 0.0, Base => 16.0); + Report.Failed("Constraint_Error not raised by the Log function " & + "with specified Base parameter, when the value of " & + "the parameter X is 0.0"); + Dont_Optimize_New_Float(New_Float_Result, 9); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Log" & + "with specified Base parameter, when the value " & + "of the parameter X is 0.0"); + end; + end if; + + -- Check for the prescribed results of the Log function with specified + -- Base parameter. + + if GEF.Log(X => 1.0, Base => 16.0) /= 0.0 or + EF.Log(X => 1.0, Base => 10.0) /= 0.0 or + GEF.Log(1.0, Base => 8.0) /= 0.0 or + EF.Log(1.0, 2.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Log with specified " & + "Base parameter when provided an parameter X input " & + "value of 1.0"); + end if; + + + -- Check that the Log function with specified Base parameter provides + -- correct results when provided a variety of input parameters. + + if not Result_Within_Range(GEF.Log( 10.0, e), 2.30, 0.01) or + not Result_Within_Range( EF.Log( 8.0, 2.0), 3.0, 0.01) or + not Result_Within_Range(GEF.Log(256.0, 2.0), 8.0, 0.01) or + not Result_Within_Range( EF.Log(512.0, 8.0), 3.0, 0.01) or + not Result_Within_Range(GEF.Log(0.5649, e), -0.57, 0.01) or + not Result_Within_Range( EF.Log(1.7714, e), 0.57, 0.01) or + not Result_Within_Range(GEF.Log(0.5718, 10.0), -0.243, 0.001) or + not Result_Within_Range( EF.Log(466.25, 10.0), 2.67, 0.01) + then + Report.Failed("Incorrect results from Function Log with specified " & + "Base parameter, when provided a variety of input " & + "parameter values"); + end if; + + + Arg := 1.0; + while Arg < 1000.0 and + not (Incorrect_Inverse_Base_2 and Incorrect_Inverse_Base_8 and + Incorrect_Inverse_Base_10 and Incorrect_Inverse_Base_16) + loop + if not FXA5A00.Result_Within_Range(EF."**"(2.0,EF.Log(Arg,2.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_2 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(8.0,EF.Log(Arg,8.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_8 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(10.0,EF.Log(Arg,10.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_10 := True; + end if; + if not FXA5A00.Result_Within_Range(EF."**"(16.0,EF.Log(Arg,16.0)), + Arg, + 0.001) + then + Incorrect_Inverse_Base_16 := True; + end if; + Arg := Arg + 1.0; + end loop; + + if Incorrect_Inverse_Base_2 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 2"); + end if; + + if Incorrect_Inverse_Base_8 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 8"); + end if; + + if Incorrect_Inverse_Base_10 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 10"); + end if; + + if Incorrect_Inverse_Base_16 then + Report.Failed("Incorrect inverse result comparing ""**"" and " & + "Log function for Base 16"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXA5A09; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa5a10.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,551 ---- + -- CXA5A10.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions Exp and Sqrt, and the exponentiation + -- operator "**" provide correct results. + -- + -- TEST DESCRIPTION: + -- This test examines both the versions of Exp, Sqrt, and "**" + -- resulting from the instantiation of the + -- Ada.Numerics.Generic_Elementary_Functions with a type derived from + -- type Float, as well as the preinstantiated version of this package + -- for type Float. + -- Prescribed results (stated as such in the reference manual), + -- including instances prescribed to raise exceptions, are examined + -- in the test cases. In addition, certain evaluations are performed + -- for the preinstantiated package where the actual function result is + -- compared with the expected result (within an epsilon range of + -- accuracy). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXA5A00.A (foundation code) + -- CXA5A10.A + -- + -- + -- CHANGE HISTORY: + -- 17 Apr 95 SAIC Initial prerelease version. + -- 13 Jun 95 SAIC Incorporated use of Dont_Optimize procedure, and + -- use of Result_Within_Range function overloaded for + -- FXA5A00.New_Float_Type. + -- 18 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 01 Oct 01 RLB Protected Constraint_Error exception tests by + -- first testing for 'Machine_Overflows. + -- + --! + + with Ada.Exceptions; + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Elementary_Functions; + with FXA5A00; + with Report; + + procedure CXA5A10 is + begin + + Report.Test ("CXA5A10", "Check that Exp, Sqrt, and the ""**"" operator " & + "provide correct results"); + + Test_Block: + declare + + use FXA5A00, Ada.Numerics; + use Ada.Exceptions; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions(New_Float); + package EF renames Ada.Numerics.Elementary_Functions; + + use GEF, EF; + + Arg, + Float_Result : Float; + New_Float_Result : New_Float; + + Flag_1, Flag_2, Flag_3, Flag_4, + Incorrect_Inverse_Base_e, + Incorrect_Inverse_Base_2, + Incorrect_Inverse_Base_8, + Incorrect_Inverse_Base_10, + Incorrect_Inverse_Base_16 : Boolean := False; + + procedure Dont_Optimize_Float is new Dont_Optimize(Float); + procedure Dont_Optimize_New_Float is new Dont_Optimize(New_Float); + + begin + + -- Testing of the "**" operator, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the exponentiation operator + -- when the value of the Left parameter (operand) is negative. + + begin + New_Float_Result := GEF."**"(Left => -10.0, + Right => 2.0); + Report.Failed("Argument_Error not raised by the instantiated " & + "version of the exponentiation operator when the " & + "value of the Left parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 1); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when the value of the Left parameter " & + "is negative"); + end; + + begin + Float_Result := (-FXA5A00.Small) ** 4.0; + Report.Failed("Argument_Error not raised by the preinstantiated " & + "version of the exponentiation operator when the " & + "value of the Left parameter is negative"); + Dont_Optimize_Float(Float_Result, 2); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the value of the Left parameter " & + "is negative"); + end; + + + -- Check that Argument_Error is raised by the exponentiation operator + -- when both parameters (operands) have the value 0.0. + + begin + New_Float_Result := GEF."**"(0.0, Right => 0.0); + Report.Failed("Argument_Error not raised by the instantiated " & + "version of the exponentiation operator when " & + "both operands are zero"); + Dont_Optimize_New_Float(New_Float_Result, 3); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when both operands are zero"); + end; + + begin + Float_Result := 0.0**0.0; + Report.Failed("Argument_Error not raised by the preinstantiated " & + "version of the exponentiation operator when both " & + "operands are zero"); + Dont_Optimize_Float(Float_Result, 4); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when both operands are zero"); + end; + + + -- Check that Constraint_Error is raised by the exponentiation + -- operator when the value of the left parameter (operand) is zero, + -- and the value of the right parameter (exponent) is negative. + -- This check applies only if Machine_Overflows is true [A.5.1(28, 30)]. + + if New_Float'Machine_Overflows = True then + begin + New_Float_Result := GEF."**"(0.0, Right => -2.0); + Report.Failed("Constraint_Error not raised by the instantiated " & + "version of the exponentiation operator when " & + "the left parameter is 0.0, and the right " & + "parameter is negative"); + Dont_Optimize_New_Float(New_Float_Result, 5); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "instantiated version of the exponentiation " & + "operator when the left parameter is 0.0, " & + "and the right parameter is negative"); + end; + end if; + + if Float'Machine_Overflows = True then + begin + Float_Result := 0.0 ** (-FXA5A00.Small); + Report.Failed("Constraint_Error not raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the left parameter is 0.0, and the " & + "right parameter is negative"); + Dont_Optimize_Float(Float_Result, 6); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by the " & + "preinstantiated version of the exponentiation " & + "operator when the left parameter is 0.0, and " & + "the right parameter is negative"); + end; + end if; + + -- Prescribed results. + -- Check that exponentiation by a 0.0 exponent yields the value one. + + if GEF."**"(Left => 10.0, Right => 0.0) /= 1.0 or + EF."**"(FXA5A00.Large, Right => 0.0) /= 1.0 or + GEF."**"(3.0, 0.0) /= 1.0 or + FXA5A00.Small ** 0.0 /= 1.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the exponent is 0.0"); + end if; + + + -- Check that exponentiation by a unit exponent yields the value + -- of the left operand. + + if GEF."**"(Left => 50.0, Right => 1.0) /= 50.0 or + EF."**"(FXA5A00.Large, Right => 1.0) /= FXA5A00.Large or + GEF."**"(6.0, 1.0) /= 6.0 or + FXA5A00.Small ** 1.0 /= FXA5A00.Small + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the exponent is 1.0"); + end if; + + + -- Check that exponentiation of the value 1.0 yields the value 1.0. + + if GEF."**"(Left => 1.0, Right => 16.0) /= 1.0 or + EF."**"(1.0, Right => FXA5A00.Large) /= 1.0 or + GEF."**"(1.0, 3.0) /= 1.0 or + 1.0 ** FXA5A00.Small /= 1.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the operand is 1.0"); + end if; + + + -- Check that exponentiation of the value 0.0 yields the value 0.0. + + if GEF."**"(Left => 0.0, Right => 10.0) /= 0.0 or + EF."**"(0.0, Right => FXA5A00.Large) /= 0.0 or + GEF."**"(0.0, 4.0) /= 0.0 or + 0.0 ** FXA5A00.Small /= 0.0 + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator when the value of the operand is 0.0"); + end if; + + + -- Check that exponentiation of various operands with a variety of + -- of exponent values yield correct results. + + if not Result_Within_Range(GEF."**"(5.0, 2.0), 25.0, 0.01) or + not Result_Within_Range(GEF."**"(1.225, 1.5), 1.36, 0.01) or + not Result_Within_Range(GEF."**"(0.26, 2.0), 0.068, 0.001) or + not Result_Within_Range( EF."**"(e, 5.0), 148.4, 0.1) or + not Result_Within_Range( EF."**"(10.0, e), 522.7, 0.1) or + not Result_Within_Range( EF."**"(e, (-3.0)), 0.050, 0.001) or + not Result_Within_Range(GEF."**"(10.0,(-2.0)), 0.010, 0.001) + then + Report.Failed("Incorrect results returned from the ""**"" " & + "operator with a variety of operand and exponent " & + "values"); + end if; + + + -- Use the following loops to check for internal consistency between + -- inverse functions. + + declare + -- Use the relative error value to account for non-exact + -- computations. + TC_Relative_Error: Float := 0.005; + begin + for i in 1..5 loop + for j in 0..5 loop + if not Incorrect_Inverse_Base_e and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + e**(Float(j)*EF.Log(Float(i))), + TC_Relative_Error) + then + Incorrect_Inverse_Base_e := True; + Report.Failed("Incorrect Log-** Inverse calc for Base e " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_2 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 2.0**(Float(j)*EF.Log(Float(i),2.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_2 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 2 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_8 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 8.0**(Float(j)*EF.Log(Float(i),8.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_8 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 8 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_10 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 10.0**(Float(j)*EF.Log(Float(i),10.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_10 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 10 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + if not Incorrect_Inverse_Base_16 and + not FXA5A00.Result_Within_Range + (Float(i)**Float(j), + 16.0**(Float(j)*EF.Log(Float(i),16.0)), + TC_Relative_Error) + then + Incorrect_Inverse_Base_16 := True; + Report.Failed("Incorrect Log-** Inverse calc for Base 16 " & + "with i= " & Integer'Image(i) & " and j= " & + Integer'Image(j)); + end if; + end loop; + end loop; + end; + + -- Reset Flags. + Incorrect_Inverse_Base_e := False; + Incorrect_Inverse_Base_2 := False; + Incorrect_Inverse_Base_8 := False; + Incorrect_Inverse_Base_10 := False; + Incorrect_Inverse_Base_16 := False; + + + -- Testing of Exp Function, both instantiated and pre-instantiated + -- version. + + -- Check that the result of the Exp Function, when provided an X + -- parameter value of 0.0, is 1.0. + + if GEF.Exp(X => 0.0) /= 1.0 or + EF.Exp(0.0) /= 1.0 + then + Report.Failed("Incorrect result returned by Function Exp when " & + "given a parameter value of 0.0"); + end if; + + + -- Check that the Exp Function provides correct results when provided + -- a variety of input parameter values. + + if not Result_Within_Range(GEF.Exp(0.001), 1.01, 0.01) or + not Result_Within_Range( EF.Exp(0.1), 1.11, 0.01) or + not Result_Within_Range(GEF.Exp(1.2697), 3.56, 0.01) or + not Result_Within_Range( EF.Exp(3.2525), 25.9, 0.1) or + not Result_Within_Range(GEF.Exp(-0.2198), 0.803, 0.001) or + not Result_Within_Range( EF.Exp(-1.6621), 0.190, 0.001) or + not Result_Within_Range(GEF.Exp(-2.3888), 0.092, 0.001) or + not Result_Within_Range( EF.Exp(-5.4415), 0.004, 0.001) + then + Report.Failed("Incorrect result from Function Exp when provided " & + "a variety of input parameter values"); + end if; + + -- Use the following loops to check for internal consistency between + -- inverse functions. + + Arg := 0.01; + while Arg < 10.0 loop + if not Incorrect_Inverse_Base_e and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + e**(Arg*EF.Log(Arg)), + 0.001) + then + Incorrect_Inverse_Base_e := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base e"); + end if; + if not Incorrect_Inverse_Base_2 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 2.0**(Arg*EF.Log(Arg,2.0)), + 0.001) + then + Incorrect_Inverse_Base_2 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 2"); + end if; + if not Incorrect_Inverse_Base_8 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 8.0**(Arg*EF.Log(Arg,8.0)), + 0.001) + then + Incorrect_Inverse_Base_8 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 8"); + end if; + if not Incorrect_Inverse_Base_10 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 10.0**(Arg*EF.Log(Arg,10.0)), + 0.001) + then + Incorrect_Inverse_Base_10 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 10"); + end if; + if not Incorrect_Inverse_Base_16 and + FXA5A00.Result_Within_Range(EF.Exp(Arg), + 16.0**(Arg*EF.Log(Arg,16.0)), + 0.001) + then + Incorrect_Inverse_Base_16 := True; + Report.Failed("Incorrect Exp-** Inverse calc for Base 16"); + end if; + Arg := Arg + 0.01; + end loop; + + + -- Testing of Sqrt Function, both instantiated and pre-instantiated + -- version. + + -- Check that Argument_Error is raised by the Sqrt Function when + -- the value of the input parameter X is negative. + + begin + Float_Result := EF.Sqrt(X => -FXA5A00.Small); + Report.Failed("Argument_Error not raised by Function Sqrt " & + "when provided a small negative input parameter " & + "value"); + Dont_Optimize_Float(Float_Result, 7); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Sqrt " & + "when provided a small negative input parameter " & + "value"); + end; + + begin + New_Float_Result := GEF.Sqrt(X => -64.0); + Report.Failed("Argument_Error not raised by Function Sqrt " & + "when provided a large negative input parameter " & + "value"); + Dont_Optimize_New_Float(New_Float_Result, 8); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function Sqrt " & + "when provided a large negative input parameter " & + "value"); + end; + + + -- Check that the Sqrt Function, when given an X parameter value of 0.0, + -- returns a result of 0.0. + + if GEF.Sqrt(X => 0.0) /= 0.0 or + EF.Sqrt(0.0) /= 0.0 + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "an input parameter value of 0.0"); + end if; + + + -- Check that the Sqrt Function, when given an X parameter input value + -- of 1.0, returns a result of 1.0. + + if GEF.Sqrt(X => 1.0) /= 1.0 or + EF.Sqrt(1.0) /= 1.0 + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "an input parameter value of 1.0"); + end if; + + + -- Check that the Sqrt Function provides correct results when provided + -- a variety of input parameter values. + + if not FXA5A00.Result_Within_Range(GEF.Sqrt(0.0327), 0.181, 0.001) or + not FXA5A00.Result_Within_Range( EF.Sqrt(0.1808), 0.425, 0.001) or + not FXA5A00.Result_Within_Range(GEF.Sqrt(1.0556), 1.03, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sqrt(32.8208), 5.73, 0.01) or + not FXA5A00.Result_Within_Range( EF.Sqrt(27851.0), 166.9, 0.1) or + not FXA5A00.Result_Within_Range( EF.Sqrt(61203.4), 247.4, 0.1) or + not FXA5A00.Result_Within_Range( EF.Sqrt(655891.0), 809.9, 0.1) + then + Report.Failed("Incorrect result from Function Sqrt when provided " & + "a variety of input parameter values"); + end if; + + -- Check internal consistency between functions. + + Arg := 0.01; + while Arg < 10.0 loop + if not Flag_1 and + not FXA5A00.Result_Within_Range(Arg, + EF.Sqrt(Arg)*EF.Sqrt(Arg), + 0.01) + then + Report.Failed("Inconsistency found in Case 1"); + Flag_1 := True; + end if; + if not Flag_2 and + not FXA5A00.Result_Within_Range(Arg, EF.Sqrt(Arg)**2.0, 0.01) + then + Report.Failed("Inconsistency found in Case 2"); + Flag_2 := True; + end if; + if not Flag_3 and + not FXA5A00.Result_Within_Range(EF.Log(Arg), + EF.Log(Sqrt(Arg)**2.0), 0.01) + then + Report.Failed("Inconsistency found in Case 3"); + Flag_3 := True; + end if; + if not Flag_4 and + not FXA5A00.Result_Within_Range(EF.Log(Arg), + 2.00*EF.Log(EF.Sqrt(Arg)), + 0.01) + then + Report.Failed("Inconsistency found in Case 4"); + Flag_4 := True; + end if; + Arg := Arg + 1.0; + end loop; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXA5A10; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,243 ---- + -- CXA8001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that all elements to be transferred to a sequential file of + -- mode Append_File will be placed following the last element currently + -- in the file. + -- Check that it is possible to append data to a file that has been + -- previously appended to. + -- Check that the predefined procedure Write will place an element after + -- the last element in the file in mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test implements a sequential file system that has the capability + -- to store data records at the end of a file. Initially, the file is + -- opened with mode Out_File, and data is written to the file. The file + -- is closed, then reopened with mode Append_File. An additional record + -- is written, and again the file is closed. The file is then reopened, + -- again with mode Append_File, and another record is written to the + -- file. + -- The file is closed again, the reopened with mode In_File, and the data + -- in the file is read and checked for proper ordering within the file. + -- + -- An expected common usage of Append_File mode would be in the opening + -- of a file that currently contains data. Likewise, the reopening of + -- files in Append_Mode that have been previously appended to for the + -- addition of more data would be frequently encountered. This test + -- attempts to simulate both situations. (Of course, in an actual user + -- environment, the open/write/close processing would be performed using + -- looping structures, rather than the straight-line processing displayed + -- here.) + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all systems capable of supporting IO operations on + -- external Sequential_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Sequential_IO; + with Report; + + procedure CXA8001 is + + -- Declare data types and objects to be stored in the file. + subtype Name_Type is String (1 .. 10); + type Tickets is range 0 .. 1000; + + type Order_Type is record + Name : Name_Type; + No_of_Tickets : Tickets; + end record; + + package Order_IO is new Sequential_IO (Order_Type); -- Declare Seq_IO + -- package, + Order_File : Order_IO.File_Type; -- and file object. + Order_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXA8001" ); + Incomplete : exception; + + begin + + Report.Test ("CXA8001", "Check that all elements to be transferred to a " & + "sequential file of mode Append_File will be " & + "placed following the last element currently " & + "in the file"); + + Test_for_Sequential_IO_Support: + begin + + -- An implementation that does not support Sequential_IO in a particular + -- environment will raise Use_Error or Name_Error on calls to various + -- Sequential_IO operations. This block statement encloses a call to + -- Create, which should produce an exception in a non-supportive + -- environment. These exceptions will be handled to produce a + -- Not_Applicable result. + + Order_IO.Create (File => Order_File, -- Create Sequential_IO file + Mode => Order_IO.Out_File, -- with mode Out_File. + Name => Order_Filename); + + exception + + when Order_IO.Use_Error | Order_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Sequential_IO" ); + raise Incomplete; + + end Test_for_Sequential_IO_Support; + + Operational_Test_Block: + declare + -- Assign values into the component fields of the data objects. + Buyer_1 : constant Order_Type := ("John Smith", 3); + Buyer_2 : constant Order_Type := + (Name => "Jane Jones", No_of_Tickets => 2); + Buyer_3 : Order_Type := ("Mike Brown", 5); + + begin + Order_IO.Write (File => Order_File, -- Write initial data item + Item => Buyer_1); -- to file. + + Order_IO.Close (File => Order_File); -- Close file. + + -- + -- Enter additional data records into the file. (Append to a file of + -- previous mode Out_File). + -- + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.Append_File, -- with mode Append_File. + Order_Filename); + + Order_IO.Write (Order_File, Buyer_2); -- Write second data item + -- to file. + Order_IO.Close (File => Order_File); -- Close file. + + -- Check to determine whether file is actually closed. + begin + Order_IO.Write (Order_File, Buyer_2); + Report.Failed("Exception not raised on Write to Closed file"); + exception + when Order_IO.Status_Error => null; -- Expected exception. + when others => + Report.Failed("Incorrect exception on Write to Closed file"); + end; + + -- + -- The following code segment demonstrates appending data to a file + -- that has been previously appended to. + -- + + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.Append_File, -- with mode Append_File. + Order_Filename ); + + Order_IO.Write (Order_File, Buyer_3); -- Write third data item + -- to file. + Order_IO.Close (File => Order_File); -- Close file. + + + Test_Verification_Block: + declare + TC_Order1, TC_Order2, TC_Order3 : Order_Type; + begin + + Order_IO.Open (Order_File, -- Open Sequential_IO file + Order_IO.In_File, -- with mode In_File. + Order_Filename ); + + Order_IO.Read (File => Order_File, -- Read records from file. + Item => TC_Order1); + Order_IO.Read (Order_File, TC_Order2); + Order_IO.Read (Order_File, TC_Order3); + + -- Compare the contents of each with the individual data items. + -- If items read from file do not match the items placed into + -- the file, in the appropriate order, then fail. + + if ((TC_Order1 /= Buyer_1) or + (TC_Order2.Name /= Buyer_2.Name) or + (TC_Order2.No_of_Tickets /= Buyer_2.No_of_Tickets) or + not ((TC_Order3.Name = "Mike Brown") and + (TC_Order3.No_of_Tickets = 5))) then + Report.Failed ("Incorrect appending of record data in file"); + end if; + + -- Check to determine that no more than three data records were + -- actually written to the file. + if not Order_IO.End_Of_File (Order_File) then + Report.Failed("File not empty after three reads"); + end if; + + exception + + when Order_IO.End_Error => -- If three items not in + -- file (data overwritten), + -- then fail. + Report.Failed ("Incorrect number of record elements in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when others => + Report.Failed("Exception raised during Sequential_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Check that file is open prior to deleting it. + if Order_IO.Is_Open(Order_File) then + Order_IO.Delete (Order_File); + else + Order_IO.Open(Order_File, Order_IO.In_File, Order_Filename); + Order_IO.Delete (Order_File); + end if; + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Sequential_IO" ); + + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXA8001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,285 ---- + -- CXA8002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that resetting a file using mode Append_File allows for the + -- writing of elements to the file starting after the last element in + -- the file. + -- Check that the result of function Name can be used on a subsequent + -- reopen of the file. + -- Check that a mode change occurs on reset of a file to/from mode + -- Append_File. + -- + -- TEST DESCRIPTION: + -- This test simulates the read/write of data from/to an individual + -- sequential file. New data can be appended to the end of the existing + -- file, and the same file can be reset to allow reading of data from + -- the file. This process can occur multiple times. + -- When the mode of the file is changed with a Reset, the current mode + -- value assigned to the file is checked using the result of function + -- Mode. This, in conjunction with the read/write operations, verifies + -- that a mode change has taken place on Reset. + -- + -- An expected common usage of the scenarios found in this test would + -- be a case where a single data file is kept open continuously, being + -- reset for read/append of data. For systems that do not support a + -- direct form of I/O, this would allow for efficient use of a sequential + -- I/O file. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all systems capable of supporting IO operations on + -- external Sequential_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Feb 97 PWB.CTA Fixed handling for file non-support and Reset + -- non-support. + --! + + with Sequential_IO; + with Report; + + procedure CXA8002 is + subtype Employee_Data is String (1 .. 11); + package Data_IO is new Sequential_IO (Employee_Data); + + Employee_Data_File : Data_IO.File_Type; + Employee_Filename : constant String := + Report.Legal_File_Name (Nam => "CXA8002"); + + Incomplete : exception; + + begin + + Report.Test ("CXA8002", "Check that resetting a file using mode " & + "Append_File allows for the writing of " & + "elements to the file starting after the " & + "last element in the file"); + + Test_for_Sequential_IO_Support: + begin + + -- An implementation that does not support Sequential_IO in a particular + -- environment will raise Use_Error or Name_Error on calls to various + -- Sequential_IO operations. This block statement encloses a call to + -- Create, which should produce an exception in a non-supportive + -- environment. These exceptions will be handled to produce a + -- Not_Applicable result. + + Data_IO.Create (File => Employee_Data_File, -- Create file in + Mode => Data_IO.Append_File, -- mode Append_File. + Name => Employee_Filename); + + -- + -- The following portion of code demonstrates the fact that a sequential + -- file can be created in Append_File mode, and that data can be written + -- to the file. + -- + + exception + when Data_IO.Use_Error | Data_IO.Name_Error => + Report.Not_Applicable + ( "Sequential files not supported - Create as Append_File"); + raise Incomplete; + end Test_for_Sequential_IO_Support; + Operational_Test_Block: + declare + Blank_Data : constant Employee_Data := " "; + Employee_1 : constant Employee_Data := "123-45-6789"; + Employee_2 : Employee_Data := "987-65-4321"; + + -- Note: Artificial numerical data chosen above to prevent any + -- unintended similarity with persons alive or dead. + + TC_Employee_Data : Employee_Data := Blank_Data; + + + function TC_Mode_Selection (Selector : Integer) + return Data_IO.File_Mode is + begin + case Report.Ident_Int(Selector) is + when 1 => return Data_IO.In_File; + when 2 => return Data_IO.Out_File; + when others => return Data_IO.Append_File; + end case; + end TC_Mode_Selection; + + Employee_Filename : constant String := -- Use function Name to + Data_IO.Name (File => Employee_Data_File); -- store filename in + -- string variable. + begin + + Data_IO.Write (File => Employee_Data_File, -- Write initial data + Item => Employee_1); -- entry to file. + + -- + -- The following portion of code demonstrates that a sequential file + -- can be reset to various file modes, including Append_File mode, + -- allowing data to be added to the end of the file. + -- + begin + Data_IO.Reset (File => Employee_Data_File, -- Reset file with + Mode => Data_IO.In_File); -- mode In_File. + exception + when Data_IO.Use_Error => + Report.Not_Applicable + ("Reset to In_File not supported for Sequential_IO"); + raise Incomplete; + when others => + Report.Failed + ("Unexpected exception on Reset to In_File (Sequential_IO)"); + raise Incomplete; + end; + if Data_IO."="(Data_IO.Mode (Employee_Data_File), + TC_Mode_Selection (1)) then -- Compare In_File mode + -- Reset successful, + Data_IO.Read (File => Employee_Data_File, -- now verify file data. + Item => TC_Employee_Data); + + if ((TC_Employee_Data (1 .. 7) /= "123-45-") or + (TC_Employee_Data (5 .. 11) /= "45-6789")) then + Report.Failed ("Data read error"); + end if; + + else + Report.Failed ("File mode not changed by Reset"); + end if; + + -- + -- Simulate appending data to a file that has previously been written + -- to and read from. + -- + begin + Data_IO.Reset (File => Employee_Data_File, -- Reset file with + Mode => Data_IO.Append_File); -- mode Append_File. + exception + when Data_IO.Use_Error => + Report.Not_Applicable + ("Reset to Append_File not supported for Sequential_IO"); + raise Incomplete; + when others => + Report.Failed + ("Unexpected exception on Reset to Append_File (Sequential_IO)"); + raise Incomplete; + end; + + if Data_IO.Is_Open (Employee_Data_File) then -- File remains open + -- following Reset to + -- Append_File mode? + + if Data_IO."=" (Data_IO.Mode (Employee_Data_File), + TC_Mode_Selection (3)) then -- Compare to + -- Append_File mode. + Data_IO.Write (File => Employee_Data_File, -- Write additional + Item => Employee_2); -- data to file. + else + Report.Failed ("File mode not changed by Reset"); + end if; + + else + Report.Failed + ("File status not Open following Reset to Append mode"); + end if; + + Data_IO.Close (Employee_Data_File); + + + Test_Verification_Block: + begin + + Data_IO.Open (File => Employee_Data_File, -- Reopen file, using + Mode => Data_IO.In_File, -- previous result of + Name => Employee_Filename); -- function Name. + + TC_Employee_Data := Blank_Data; -- Clear record field. + Data_IO.Read (Employee_Data_File, -- Read first record, + TC_Employee_Data); -- check ordering of + -- records. + + if not ((TC_Employee_Data (1 .. 3) = "123") and then + (TC_Employee_Data (4 .. 11) = "-45-6789")) then + Report.Failed ("Data read error - first record"); + end if; + + TC_Employee_Data := Blank_Data; -- Clear record field. + Data_IO.Read (Employee_Data_File, -- Read second record, + TC_Employee_Data); -- check for ordering of + -- records. + + if ((TC_Employee_Data (1 .. 6) /= "987-65") or else + not (TC_Employee_Data (3 .. 11) = "7-65-4321")) then + Report.Failed ("Data read error - second record"); + end if; + + -- Check that only two items were written to the file. + if not Data_IO.End_Of_File(Employee_Data_File) then + Report.Failed("Incorrect number of records in file"); + end if; + + exception + + when Data_IO.End_Error => -- If two items not in + -- file (data overwritten), + -- then fail. + Report.Failed ("Incorrect number of record elements in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when others => + Report.Failed("Exception raised during Sequential_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Check that file is open prior to deleting it. + if Data_IO.Is_Open(Employee_Data_File) then + Data_IO.Delete (Employee_Data_File); + else + Data_IO.Open(Employee_Data_File, + Data_IO.In_File, + Employee_Filename); + Data_IO.Delete (Employee_Data_File); + end if; + exception + when others => + Report.Failed ("Sequential_IO Delete not properly supported"); + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ("Unexpected exception"); + Report.Result; + end CXA8002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa8003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,214 ---- + -- CXA8003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Append_File mode has not been added to package Direct_IO. + -- + -- TEST DESCRIPTION: + -- This test uses a procedure to change the mode of an existing Direct_IO + -- file. The file descriptor is passed as a parameter, along with a + -- numeric indicator for the new mode. Based on the numeric parameter, + -- a Direct_IO.Reset is performed using a File_Mode'Value transformation + -- of a string constant into a File_Mode value. An attempt to reset a + -- Direct_IO file to mode Append_File should cause an Constraint_Error + -- to be raised, as Append_File mode has not been added to Direct_IO in + -- Ada 9X. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations supporting Direct_IO + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 19 Feb 97 PWB.CTA Allowed for non-support of Reset for certain + -- modes. + --! + + with Direct_IO; + with Report; + + procedure CXA8003 is + Incomplete : exception; + begin + + Report.Test ("CXA8003", "Check that Append_File mode has not " & + "been added to package Direct_IO"); + + Test_for_Direct_IO_Support: + declare + + subtype String_Data_Type is String (1 .. 20); + type Numeric_Data_Type is range 1 .. 512; + type Composite_Data_Type is array (1 .. 3) of String_Data_Type; + + type File_Data_Type is record + Data_Field_1 : String_Data_Type; + Data_Field_2 : Numeric_Data_Type; + Data_Field_3 : Composite_Data_Type; + end record; + + package Dir_IO is new Direct_IO (File_Data_Type); + + Data_File : Dir_IO.File_Type; + Dir_Filename : constant String := Report.Legal_File_Name; + + begin + + -- An application creates a text file with mode Out_File. + -- Use_Error will be raised if Direct_IO operations or external + -- files are not supported. + + Dir_IO.Create (Data_File, + Dir_IO.Out_File, + Dir_Filename); + + Change_File_Mode: + declare + + TC_Append_Test_Executed : Boolean := False; + + type Mode_Selection_Type is ( A, I, IO, O ); + + + procedure Change_Mode (File : in out Dir_IO.File_Type; + To : in Mode_Selection_Type) is + begin + case To is + when A => + TC_Append_Test_Executed := True; + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Append_File")); + when I => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("In_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to In_File not supported: Direct_IO"); + raise Incomplete; + end; + when IO => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Inout_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to InOut_File not supported: Direct_IO"); + raise Incomplete; + end; + when O => + begin + Dir_IO.Reset + (File, Dir_IO.File_Mode'Value("Out_File")); + exception + when Dir_IO.Use_Error => + Report.Not_Applicable + ("Reset to Out_File not supported: Direct_IO"); + raise Incomplete; + end; + end case; + end Change_Mode; + + + begin + + -- At some point in the processing, the application may call a + -- procedure to change the mode of the file (perhaps for + -- additional data entry, data verification, etc.). It is at + -- this point that a use of Append_File mode for a Direct_IO + -- file would cause an exception. + + for I in reverse Mode_Selection_Type loop + Change_Mode (Data_File, I); + Report.Comment + ("Mode changed to " & + Dir_IO.File_Mode'Image (Dir_IO.Mode (Data_File))); + end loop; + + Report.Failed("No error raised on change to Append_File mode"); + + exception + + -- A handler has been provided in the application, which + -- handles the constraint error, allowing processing to + -- continue. + + when Constraint_Error => + + if TC_Append_Test_Executed then + Report.Comment ("Constraint_Error correctly raised on " & + "attempted Append_File mode selection " & + "for a Direct_IO file"); + else + Report.Failed ("Append test was not executed"); + end if; + + when Incomplete => raise; + + when others => Report.Failed ("Unexpected exception raised"); + + end Change_File_Mode; + + Final_Block: + begin + if Dir_IO.Is_Open (Data_File) then + Dir_IO.Delete (Data_File); + else + Dir_IO.Open (Data_File, Dir_IO.In_File, Dir_Filename); + Dir_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ("Delete not properly supported: Direct_IO"); + end Final_Block; + + exception + + -- Since Use_Error or Name_Error can be raised if, for the + -- specified mode, the environment does not support Direct_IO + -- operations, the following handlers are included: + + when Dir_IO.Name_Error => + Report.Not_Applicable("Name_Error raised on Direct IO Create"); + + when Dir_IO.Use_Error => + Report.Not_Applicable("Use_Error raised on Direct IO Create"); + + when others => + Report.Failed + ("Unexpected exception raised on Direct IO Create"); + + end Test_for_Direct_IO_Support; + + Report.Result; + + exception + when Incomplete => + Report.Result; + + end CXA8003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa9001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,287 ---- + -- CXA9001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the operations defined in the generic package + -- Ada.Storage_IO provide the ability to store and retrieve objects + -- which may include implicit levels of indirection in their + -- implementation, from an in-memory buffer. + -- + -- TEST DESCRIPTION: + -- The following scenario demonstrates how an object of a type with + -- (potential) levels of indirection (based on the implementation) + -- can be "flattened" and written/read to/from a Direct_IO file. + -- In this small example, we have attempted to simulate the situation + -- where two independent programs are using a particular Direct_IO file, + -- one writing data to the file, and the second program reading that file. + -- The Storage_IO Read and Write procedures are used to "flatten" + -- and reconstruct objects of the record type. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to implementations capable of supporting external + -- Direct_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 07 Jun 95 SAIC Modified to constrain type used with Storage_IO. + -- 20 Nov 95 SAIC Corrected and enhanced for ACVC 2.0.1. + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Report; + with Ada.Storage_IO; + with Ada.Direct_IO; + + procedure CXA9001 is + package Dir_IO is new Ada.Direct_IO (Integer); + Test_File : Dir_IO.File_Type; + Incomplete : exception; + begin + + Report.Test ("CXA9001", "Check that the operations defined in the " & + "generic package Ada.Storage_IO provide the " & + "ability to store and retrieve objects which " & + "may include implicit levels of indirection in " & + "their implementation, from an in-memory buffer"); + + + Test_For_Direct_IO_Support: + begin + + -- The following Create does not have any bearing on the test scenario, + -- but is included to check that the implementation supports Direct_IO + -- files. An exception on this Create statement will raise a Name_Error + -- or Use_Error, which will be handled to produce a Not_Applicable + -- result. If created, the file is immediately deleted, as it is not + -- needed for the program scenario. + + Dir_IO.Create (Test_File, Dir_IO.Out_File, Report.Legal_File_Name(1)); + + exception + + when Dir_IO.Use_Error | Dir_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Direct_IO" ); + raise Incomplete; + + end Test_for_Direct_IO_Support; + + Deletion1: + begin + Dir_IO.Delete (Test_File); + exception + when others => + Report.Failed + ( "Delete not properly implemented for Direct_IO - 1" ); + end Deletion1; + + + Test_Block: + declare + + The_Filename : constant String := Report.Legal_File_Name(2); + + -- The following type is the basic unit used in this test. It is + -- incorporated into the definition of the Unit_Array_Type. + + type Unit_Type is + record + Position : Natural := 19; + String_Value : String (1..9) := (others => 'X'); + end record; + + TC_Size : Natural := Natural'First; + + procedure Data_Storage (Number_Of_Units : in Natural; + Result : out Natural) is + + -- Type based on input parameter. Uses type Unit_Type + -- as the array element. + type Unit_Array_Type is array (1..Number_Of_Units) + of Unit_Type; + + -- This type definition is the ultimate storage type used + -- in this test; uses type Unit_Array_Type as a record + -- component field. + -- This record type contains a component that is an array of + -- records, with each of these records containing a Natural + -- and a String value (i.e., a record containing an array of + -- records). + + type Data_Storage_Type is + record + Data_Value : Natural := Number_Of_Units; + Unit_Array : Unit_Array_Type; + end record; + + -- The instantiation of the following generic package is a + -- central point in this test. Storage_IO is instantiated for + -- a specific data type, and will be used to "flatten" objects + -- of that type into buffers. Direct_IO is instantiated for + -- these Storage_IO buffers. + + package Flat_Storage_IO is + new Ada.Storage_IO (Data_Storage_Type); + package Buffer_IO is + new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); + + Buffer_File : Buffer_IO.File_Type; + Outbound_Buffer : Flat_Storage_IO.Buffer_Type; + Storage_Item : Data_Storage_Type; + + begin -- procedure Data_Storage + + Buffer_IO.Create (Buffer_File, + Buffer_IO.Out_File, + The_Filename); + + Flat_Storage_IO.Write (Buffer => Outbound_Buffer, + Item => Storage_Item); + + -- At this point, any levels of indirection have been removed + -- by the Storage_IO procedure, and the buffered data can be + -- written to a file. + + Buffer_IO.Write (Buffer_File, Outbound_Buffer); + Buffer_IO.Close (Buffer_File); + Result := Storage_Item.Unit_Array'Last + -- 5 + + Storage_Item.Unit_Array -- 9 + (Storage_Item.Unit_Array'First).String_Value'Length; + + exception + when others => + Report.Failed ("Data storage error"); + if Buffer_IO.Is_Open (Buffer_File) then + Buffer_IO.Close (Buffer_File); + end if; + end Data_Storage; + + procedure Data_Retrieval (Number_Of_Units : in Natural; + Result : out Natural) is + type Unit_Array_Type is array (1..Number_Of_Units) + of Unit_Type; + + type Data_Storage_Type is + record + Data_Value : Natural := Number_Of_Units; + Unit_Array : Unit_Array_Type; + end record; + + package Flat_Storage_IO is + new Ada.Storage_IO (Data_Storage_Type); + package Reader_IO is + new Ada.Direct_IO (Flat_Storage_IO.Buffer_Type); + + Reader_File : Reader_IO.File_Type; + Inbound_Buffer : Flat_Storage_IO.Buffer_Type; + Storage_Item : Data_Storage_Type; + TC_Item : Data_Storage_Type; + + begin -- procedure Data_Retrieval + + Reader_IO.Open (Reader_File, Reader_IO.In_File, The_Filename); + Reader_IO.Read (Reader_File, Inbound_Buffer); + + Flat_Storage_IO.Read (Inbound_Buffer, Storage_Item); + + -- Validate the reconstructed value against an "unflattened" + -- value. + + if Storage_Item.Data_Value /= TC_Item.Data_Value + then + Report.Failed ("Data_Retrieval Error - 1"); + end if; + + for i in 1..Number_Of_Units loop + if Storage_Item.Unit_Array(i).String_Value'Length /= + TC_Item.Unit_Array(i).String_Value'Length or + Storage_Item.Unit_Array(i).Position /= + TC_Item.Unit_Array(i).Position or + Storage_Item.Unit_Array(i).String_Value /= + TC_Item.Unit_Array(i).String_Value + then + Report.Failed ("Data_Retrieval Error - 2"); + end if; + end loop; + + Result := Storage_Item.Unit_Array'Last + -- 5 + + Storage_Item.Unit_Array -- 9 + (Storage_Item.Unit_Array'First).String_Value'Length; + + if Reader_IO.Is_Open (Reader_File) then + Reader_IO.Delete (Reader_File); + else + Reader_IO.Open (Reader_File, + Reader_IO.In_File, + The_Filename); + Reader_IO.Delete (Reader_File); + end if; + + exception + when others => + Report.Failed ("Exception raised in Data_Retrieval"); + if Reader_IO.Is_Open (Reader_File) then + Reader_IO.Delete (Reader_File); + else + Reader_IO.Open (Reader_File, + Reader_IO.In_File, + The_Filename); + Reader_IO.Delete (Reader_File); + end if; + end Data_Retrieval; + + + begin -- Test_Block + + -- The number of Units is provided in this call to Data_Storage. + Data_Storage (Number_Of_Units => Natural(Report.Ident_Int(5)), + Result => TC_Size); + + if TC_Size /= 14 then + Report.Failed ("Data_Storage error in Data_Storage"); + end if; + + Data_Retrieval (Number_Of_Units => Natural(Report.Ident_Int(5)), + Result => TC_Size); + + if TC_Size /= 14 then + Report.Failed ("Data retrieval error in Data_Retrieval"); + end if; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXA9001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxa9002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,482 ---- + -- CXA9002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the operations defined in the generic package + -- Ada.Storage_IO provide the ability to store and retrieve objects + -- of tagged types from in-memory buffers. + -- + -- TEST DESCRIPTION: + -- The following scenario demonstrates how objects of a tagged type, + -- extended types, and twice extended types can be written/read + -- to/from Direct_IO files. The Storage_IO subprograms, Read and Write, + -- demonstrated in this scenario, perform tag "fixing" prior to/following + -- transfer to the Direct_IO files. + -- This method is especially important for those implementations that + -- represent tags as pointers, or for cases where the tagged objects + -- are read in by a program other than the one that wrote them. + -- + -- In this small example, we have attempted to simulate the situation + -- where two independent programs are using a series of Direct_IO files, + -- one writing data to the files, and the second program reading the + -- data from those files. Two procedures are defined, the first + -- simulating the program responsible for writing, the second simulating + -- a separate program opening and reading the data from the files. + -- + -- The hierarchy of types used in this test can be displayed as follows: + -- + -- Account_Type + -- / \ + -- / \ + -- / \ + -- Cash_Account_Type Investment_Account_Type + -- / \ + -- / \ + -- / \ + -- Checking_Account_Type Savings_Account_Type + -- + -- APPLICABILITY CRITERIA: + -- Applicable to implementations capable of supporting external + -- Direct_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 08 Nov 95 SAIC Corrected incorrect prefix of 'Tag for ACVC 2.0.1, + -- and mode of files in Procedure Read_Data. + -- Added verification of objects reconstructed from + -- files. + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + package CXA9002_0 is + + type Investment_Type is (Stocks, Bonds, Mutual_Funds); + type Savings_Type is (Standard, Business, Impound); + + type Account_Type is tagged + record + Num : String (1..3); + end record; + + type Cash_Account_Type is new Account_Type with + record + Years_As_Customer : Natural := 1; + end record; + + type Investment_Account_Type is new Account_Type with + record + Investment_Vehicle : Investment_Type := Stocks; + end record; + + type Checking_Account_Type is new Cash_Account_Type with + record + Checks_Per_Year : Positive := 200; + Interest_Bearing : Boolean := False; + end record; + + type Savings_Account_Type is new Cash_Account_Type with + record + Kind : Savings_Type := Standard; + end record; + + end CXA9002_0; + + --- + + with Report; + with Ada.Storage_IO; + with Ada.Direct_IO; + with Ada.Tags; + with CXA9002_0; + + procedure CXA9002 is + package Dir_IO is new Ada.Direct_IO (Integer); + Test_File : Dir_IO.File_Type; + Incomplete : exception; + begin + + Report.Test ("CXA9002", "Check that the operations defined in the " & + "generic package Ada.Storage_IO provide the " & + "ability to store and retrieve objects of " & + "tagged types from in-memory buffers"); + + + Test_For_Direct_IO_Support: + begin + + -- The following Create does not have any bearing on the test scenario, + -- but is included to check that the implementation supports Direct_IO + -- files. An exception on this Create statement will raise a Name_Error + -- or Use_Error, which will be handled to produce a Not_Applicable + -- result. If created, the file is immediately deleted, as it is not + -- needed for the program scenario. + + Dir_IO.Create (Test_File, + Dir_IO.Out_File, + Report.Legal_File_Name(1)); + exception + + when Dir_IO.Use_Error | Dir_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Direct_IO" ); + raise Incomplete; + + end Test_for_Direct_IO_Support; + + Deletion: + begin + Dir_IO.Delete (Test_File); + exception + when others => + Report.Failed + ( "Delete not properly implemented for Direct_IO" ); + end Deletion; + + Test_Block: + declare + + use CXA9002_0; + + Acct_Filename : constant String := Report.Legal_File_Name(1); + Cash_Filename : constant String := Report.Legal_File_Name(2); + Inv_Filename : constant String := Report.Legal_File_Name(3); + Chk_Filename : constant String := Report.Legal_File_Name(4); + Sav_Filename : constant String := Report.Legal_File_Name(5); + + type Tag_Pointer_Type is access String; + + TC_Account_Type_Tag, + TC_Cash_Account_Type_Tag, + TC_Investment_Account_Type_Tag, + TC_Checking_Account_Type_Tag, + TC_Savings_Account_Type_Tag : Tag_Pointer_Type; + + TC_Account : Account_Type := + (Num => "123"); + + TC_Cash_Account : Cash_Account_Type := + (Num => "234", + Years_As_Customer => 3); + + TC_Investment_Account : Investment_Account_Type := + (Num => "456", + Investment_Vehicle => Bonds); + + TC_Checking_Account : Checking_Account_Type := + (Num => "567", + Years_As_Customer => 2, + Checks_Per_Year => 300, + Interest_Bearing => True); + + TC_Savings_Account : Savings_Account_Type := + (Num => "789", + Years_As_Customer => 14, + Kind => Business); + + procedure Buffer_Data is + + Account : Account_Type := + TC_Account; + Cash_Account : Cash_Account_Type := + TC_Cash_Account; + Investment_Account : Investment_Account_Type := + TC_Investment_Account; + Checking_Account : Checking_Account_Type := + TC_Checking_Account; + Savings_Account : Savings_Account_Type := + TC_Savings_Account; + + -- The instantiations below are a central point in this test. + -- Storage_IO is instantiated for each of the specific tagged + -- type. These instantiated packages will be used to compress + -- tagged objects of these various types into buffers that will + -- be written to the Direct_IO files declared below. + + package Acct_SIO is new Ada.Storage_IO (Account_Type); + package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); + package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); + package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); + package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); + + -- Direct_IO is instantiated for the buffer types defined in the + -- instantiated Storage_IO packages. + + package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); + package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); + package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); + package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); + package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); + + Acct_Buffer : Acct_SIO.Buffer_Type; + Cash_Buffer : Cash_SIO.Buffer_Type; + Inv_Buffer : Inv_SIO.Buffer_Type; + Chk_Buffer : Chk_SIO.Buffer_Type; + Sav_Buffer : Sav_SIO.Buffer_Type; + + Acct_File : Acct_DIO.File_Type; + Cash_File : Cash_DIO.File_Type; + Inv_File : Inv_DIO.File_Type; + Chk_File : Chk_DIO.File_Type; + Sav_File : Sav_DIO.File_Type; + + begin + + Acct_DIO.Create (Acct_File, Acct_DIO.Out_File, Acct_Filename); + Cash_DIO.Create (Cash_File, Cash_DIO.Out_File, Cash_Filename); + Inv_DIO.Create (Inv_File, Inv_DIO.Out_File, Inv_Filename); + Chk_DIO.Create (Chk_File, Chk_DIO.Out_File, Chk_Filename); + Sav_DIO.Create (Sav_File, Sav_DIO.Out_File, Sav_Filename); + + -- Store the tag values of the objects declared above for + -- comparison with tag values of objects following processing. + + TC_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Account_Type'Tag)); + + TC_Cash_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Cash_Account_Type'Tag)); + + TC_Investment_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Investment_Account_Type'Tag)); + + TC_Checking_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Checking_Account_Type'Tag)); + + TC_Savings_Account_Type_Tag := + new String'(Ada.Tags.External_Tag(Savings_Account_Type'Tag)); + + -- Prepare tagged data for writing to the Direct_IO files using + -- Storage_IO procedure to place data in buffers. + + Acct_SIO.Write (Buffer => Acct_Buffer, Item => Account); + Cash_SIO.Write (Cash_Buffer, Cash_Account); + Inv_SIO.Write (Inv_Buffer, Item => Investment_Account); + Chk_SIO.Write (Buffer => Chk_Buffer, Item => Checking_Account); + Sav_SIO.Write (Sav_Buffer, Savings_Account); + + -- At this point, the data and associated tag values have been + -- buffered by the Storage_IO procedure, and the buffered data + -- can be written to the appropriate Direct_IO file. + + Acct_DIO.Write (File => Acct_File, Item => Acct_Buffer); + Cash_DIO.Write (Cash_File, Cash_Buffer); + Inv_DIO.Write (Inv_File, Item => Inv_Buffer); + Chk_DIO.Write (File => Chk_File, Item =>Chk_Buffer); + Sav_DIO.Write (Sav_File, Sav_Buffer); + + -- Close all Direct_IO files. + + Acct_DIO.Close (Acct_File); + Cash_DIO.Close (Cash_File); + Inv_DIO.Close (Inv_File); + Chk_DIO.Close (Chk_File); + Sav_DIO.Close (Sav_File); + + exception + when others => Report.Failed("Exception raised in Buffer_Data"); + end Buffer_Data; + + procedure Read_Data is + + Account : Account_Type; + Cash_Account : Cash_Account_Type; + Investment_Account : Investment_Account_Type; + Checking_Account : Checking_Account_Type; + Savings_Account : Savings_Account_Type; + + -- Storage_IO is instantiated for each of the specific tagged + -- type. + + package Acct_SIO is new Ada.Storage_IO (Account_Type); + package Cash_SIO is new Ada.Storage_IO (Cash_Account_Type); + package Inv_SIO is new Ada.Storage_IO (Investment_Account_Type); + package Chk_SIO is new Ada.Storage_IO (Checking_Account_Type); + package Sav_SIO is new Ada.Storage_IO (Savings_Account_Type); + + -- Direct_IO is instantiated for the buffer types defined in the + -- instantiated Storage_IO packages. + + package Acct_DIO is new Ada.Direct_IO (Acct_SIO.Buffer_Type); + package Cash_DIO is new Ada.Direct_IO (Cash_SIO.Buffer_Type); + package Inv_DIO is new Ada.Direct_IO (Inv_SIO.Buffer_Type); + package Chk_DIO is new Ada.Direct_IO (Chk_SIO.Buffer_Type); + package Sav_DIO is new Ada.Direct_IO (Sav_SIO.Buffer_Type); + + Acct_Buffer : Acct_SIO.Buffer_Type; + Cash_Buffer : Cash_SIO.Buffer_Type; + Inv_Buffer : Inv_SIO.Buffer_Type; + Chk_Buffer : Chk_SIO.Buffer_Type; + Sav_Buffer : Sav_SIO.Buffer_Type; + + Acct_File : Acct_DIO.File_Type; + Cash_File : Cash_DIO.File_Type; + Inv_File : Inv_DIO.File_Type; + Chk_File : Chk_DIO.File_Type; + Sav_File : Sav_DIO.File_Type; + + begin + + -- Open the Direct_IO files. + + Acct_DIO.Open (Acct_File, Acct_DIO.In_File, Acct_Filename); + Cash_DIO.Open (Cash_File, Cash_DIO.In_File, Cash_Filename); + Inv_DIO.Open (Inv_File, Inv_DIO.In_File, Inv_Filename); + Chk_DIO.Open (Chk_File, Chk_DIO.In_File, Chk_Filename); + Sav_DIO.Open (Sav_File, Sav_DIO.In_File, Sav_Filename); + + -- Read the buffer data from the files using Direct_IO. + + Acct_DIO.Read (File => Acct_File, Item => Acct_Buffer); + Cash_DIO.Read (Cash_File, Cash_Buffer); + Inv_DIO.Read (Inv_File, Item => Inv_Buffer); + Chk_DIO.Read (File => Chk_File, Item =>Chk_Buffer); + Sav_DIO.Read (Sav_File, Sav_Buffer); + + -- At this point, the data and associated tag values are stored + -- in buffers. Use the Storage_IO procedure Read to recreate the + -- tagged objects from the buffers. + + Acct_SIO.Read (Buffer => Acct_Buffer, Item => Account); + Cash_SIO.Read (Cash_Buffer, Cash_Account); + Inv_SIO.Read (Inv_Buffer, Item => Investment_Account); + Chk_SIO.Read (Buffer => Chk_Buffer, Item => Checking_Account); + Sav_SIO.Read (Sav_Buffer, Savings_Account); + + -- Delete all Direct_IO files. + + Acct_DIO.Delete (Acct_File); + Cash_DIO.Delete (Cash_File); + Inv_DIO.Delete (Inv_File); + Chk_DIO.Delete (Chk_File); + Sav_DIO.Delete (Sav_File); + + Data_Verification_Block: + begin + + if Account /= TC_Account then + Report.Failed("Incorrect Account object reconstructed"); + end if; + + if Cash_Account /= TC_Cash_Account then + Report.Failed + ("Incorrect Cash_Account object reconstructed"); + end if; + + if Investment_Account /= TC_Investment_Account then + Report.Failed + ("Incorrect Investment_Account object reconstructed"); + end if; + + if Checking_Account /= TC_Checking_Account then + Report.Failed + ("Incorrect Checking_Account object reconstructed"); + end if; + + if Savings_Account /= TC_Savings_Account then + Report.Failed + ("Incorrect Savings_Account object reconstructed"); + end if; + + exception + when others => + Report.Failed + ("Exception raised during Data_Verification Block"); + end Data_Verification_Block; + + + -- To ensure that the tags of the values reconstructed by + -- Storage_IO were properly preserved, object tag values following + -- object reconstruction are compared with tag values of objects + -- stored prior to processing. + + Tag_Verification_Block: + begin + + if TC_Account_Type_Tag.all /= + Ada.Tags.External_Tag(Account_Type'Class(Account)'Tag) + then + Report.Failed("Incorrect Account tag"); + end if; + + if TC_Cash_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Cash_Account_Type'Class(Cash_Account)'Tag) + then + Report.Failed("Incorrect Cash_Account tag"); + end if; + + if TC_Investment_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Investment_Account_Type'Class(Investment_Account)'Tag) + then + Report.Failed("Incorrect Investment_Account tag"); + end if; + + if TC_Checking_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Checking_Account_Type'Class(Checking_Account)'Tag) + then + Report.Failed("Incorrect Checking_Account tag"); + end if; + + if TC_Savings_Account_Type_Tag.all /= + Ada.Tags.External_Tag( + Savings_Account_Type'Class(Savings_Account)'Tag) + then + Report.Failed("Incorrect Savings_Account tag"); + end if; + + exception + when others => + Report.Failed ("Exception raised during tag evaluation"); + end Tag_Verification_Block; + + exception + when others => Report.Failed ("Exception in Read_Data"); + end Read_Data; + + begin -- Test_Block + + -- Enter the data into the appropriate files. + Buffer_Data; + + -- Reconstruct the data from files, and verify the results. + Read_Data; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXA9002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,279 ---- + -- CXAA001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Line_Length and Page_Length maximums for a Text_IO + -- file of mode Append_File are initially zero (unbounded) after a + -- Create, Open, or Reset, and that these values can be modified using + -- the procedures Set_Line_Length and Set_Page_Length. + -- Check that setting the Line_Length and Page_Length attributes to zero + -- results in an unbounded Text_IO file. + -- Check that setting the line length when in Append_Mode doesn't + -- change the length of lines previously written to the Text_IO file. + -- + -- TEST DESCRIPTION: + -- This test attempts to simulate a possible text processing environment. + -- String values, from a number of different string types, are written to + -- a Text_IO file. Prior to the writing of each, the line length is set + -- to the particular length of the data being written. In addition, the + -- default line and page lengths are checked, to determine whether they + -- are unbounded (length = 0) following a create, reset, or open of a + -- Text_IO file with mode Append_File. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA001 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA001" ); + Incomplete : exception; + begin + + Report.Test ("CXAA001","Check that the Line_Length and Page_Length " & + "maximums for a Text_IO file of mode Append_File " & + "are initially zero (unbounded) after a Create, " & + "Open, or Reset, and that these values can be " & + "modified using the procedures Set_Line_Length " & + "and Set_Page_Length"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise an exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Append_File, + Name => Data_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + subtype Confidential_Data_Type is string (1 .. 10); + subtype Secret_Data_Type is string (1 .. 20); + subtype Top_Secret_Data_Type is string (1 .. 30); + + Zero : constant Text_IO.Count := 0; + Confidential_Data_Size : constant Text_IO.Count := 10; + Secret_Data_Size : constant Text_IO.Count := 20; + Top_Secret_Data_Size : constant Text_IO.Count := 30; + + -- The following generic procedure is designed to simulate a text + -- processing environment where line and page sizes are set and + -- verified prior to the writing of data to a file. + + generic + Data_Size : Text_IO.Count; + procedure Write_Data_To_File (Data_Item : in String); + + procedure Write_Data_To_File (Data_Item : in String) is + use Text_IO; -- Used to provide visibility to the "/=" operator. + begin + if (Text_IO.Line_Length (Data_File) /= Zero) then -- Check default + Report.Failed("Line not of unbounded length"); -- line length, + elsif (Text_IO.Page_Length (Data_File) /= Zero) then -- default + Report.Failed ("Page not of unbounded length"); -- page length. + end if; + + Text_IO.Set_Line_Length (File => Data_File, -- Set the line + To => Data_Size); -- length. + Text_IO.Set_Page_Length (File => Data_File, -- Set the page + To => Data_Size); -- length. + -- Verify the lengths set. + if (Integer(Text_IO.Line_Length (Data_File)) /= + Report.Ident_Int(Integer(Data_Size))) then + Report.Failed ("Line length not set to appropriate length"); + elsif (Integer(Text_IO.Page_Length (Data_File)) /= + Report.Ident_Int(Integer(Data_Size))) then + Report.Failed ("Page length not set to appropriate length"); + end if; + + Text_IO.Put_Line (File => Data_File, -- Write data to + Item => Data_Item); -- file. + + end Write_Data_To_File; + + -- Instantiation for the three data types/sizes. + + procedure Write_Confidential_Data is + new Write_Data_To_File (Data_Size => Confidential_Data_Size); + + procedure Write_Secret_Data is + new Write_Data_To_File (Data_Size => Secret_Data_Size); + + procedure Write_Top_Secret_Data is + new Write_Data_To_File (Data_Size => Top_Secret_Data_Size); + + Confidential_Item : Confidential_Data_Type := "Confidenti"; + Secret_Item : Secret_Data_Type := "Secret Data Values "; + Top_Secret_Item : Top_Secret_Data_Type := + "Extremely Top Secret Data "; + + begin + + -- The following call simulates processing occurring after the create + -- of a Text_IO file with mode Append_File. + + Write_Confidential_Data (Confidential_Item); + + -- The following call simulates processing occurring after the reset + -- of a Text_IO file with mode Append_File. + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.Append_File); -- Reset to + -- Append_File mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Write_Secret_Data (Data_Item => Secret_Item); + + Text_IO.Close (Data_File); -- Close file. + + -- The following processing simulates processing occurring after the + -- opening of an existing file with mode Append_File. + + Text_IO.Open (Data_File, -- Open file in + Text_IO.Append_File, -- Append_File mode. + Data_Filename); + + Write_Top_Secret_Data (Top_Secret_Item); + + Test_Verification_Block: + declare + TC_String1, + TC_String2, + TC_String3 : String (1..80) := (others => ' '); + TC_Length1, + TC_Length2, + TC_Length3 : Natural := 0; + begin + + Reset2: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); -- Reset for reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Text_IO.Get_Line (Data_File, TC_String1, TC_Length1); + Text_IO.Get_Line (Data_File, TC_String2, TC_Length2); + Text_IO.Get_Line (Data_File, TC_String3, TC_Length3); + + -- Verify that the line lengths of each line were accurate. + -- Note: Each data line was written to the file after the + -- particular line length had been set (to the data length). + + if not ((TC_Length1 = Natural(Confidential_Data_Size)) and + (TC_Length2 = Natural(Secret_Data_Size)) and + (TC_Length3 = Natural(Top_Secret_Data_Size))) then + Report.Failed ("Inaccurate line lengths read from file"); + end if; + + -- Verify that the data read from the file are accurate. + + if (TC_String1(1..TC_Length1) /= Confidential_Item) or else + (TC_String2(1..TC_Length2) /= Secret_Item) or else + (TC_String3(1..TC_Length3) /= Top_Secret_Item) then + Report.Failed ("Corrupted data items read from file"); + end if; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Check that the file is open prior to deleting it. + if Text_IO.Is_Open(Data_File) then + Text_IO.Delete(Data_File); + else + Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete(Data_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- CXAA002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line + -- subprograms perform properly on a text file created with mode + -- Append_File. + -- Check that the attributes Page, Line, and Column are all set to 1 + -- following the creation of a text file with mode Append_File. + -- Check that the functions Page, Line, and Col perform properly on a + -- text file created with mode Append_File. + -- Check that the procedures Put and Put_Line perform properly on text + -- files created with mode Append_File. + -- Check that the procedure Set_Line sets the current line number to + -- the value specified by the parameter "To" for text files created with + -- mode Append_File. + -- Check that the procedure Set_Col sets the current column number to + -- the value specified by the parameter "To" for text files created with + -- mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test is designed to simulate the text processing that could + -- occur with files that have been created in Append_File mode. Various + -- calls to Text_IO formatting subprograms are called to properly + -- position text appended to a document. The text content and position + -- are subsequently verified for accuracy. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA002 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA002" ); + Incomplete : exception; + begin + + Report.Test ("CXAA002", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "created with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Append_File, + Name => Data_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + Default_Position : constant Text_IO.Positive_Count := 1; + Section_Header : constant String := "VII. "; + Appendix_Title : constant String := "Appendix A"; + Appendix_Content : constant String := "TBD"; + + -- The following procedure simulates the addition of an Appendix page + -- to an existing text file. + procedure Position_Appendix_Text is + use Text_IO; -- To provide visibility to the "/=" operator. + begin + + -- Test control code. + -- Verify initial page, line, column number. + if "/="(Text_IO.Page (Data_File), Default_Position) then + Report.Failed ("Incorrect default page number"); + end if; + if Text_IO.Line (Data_File) /= Default_Position then + Report.Failed ("Incorrect default line number"); + end if; + if "/="(Text_IO.Col (Data_File), Default_Position) then + Report.Failed ("Incorrect default column number"); + end if; + + -- Simulated usage code. + -- Set new page/line positions. + Text_IO.Put_Line + (Data_File, "Add some optional data to the file here"); + Text_IO.New_Page (Data_File); + Text_IO.New_Line (File => Data_File, Spacing => 2); + + -- Test control code. + if Integer(Text_IO.Page (Data_File)) /= Report.Ident_Int(2) or else + Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(3) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. + Text_IO.Put (Data_File, Section_Header); -- Position title + Text_IO.Put_Line (Data_File, Appendix_Title); -- of Appendix. + + Text_IO.Set_Line (File => Data_File, To => 5); -- Set new + Text_IO.Set_Col (File => Data_File, To => 8); -- position. + + -- Test control code. + if (Integer(Text_IO.Line (Data_File)) /= Report.Ident_Int(5)) or + (Integer(Text_IO.Col (Data_File)) /= Report.Ident_Int(8)) then + Report.Failed ("Incorrect results from line/column positioning"); + end if; + + -- Simulated usage code. -- Position + Text_IO.Put_Line (Data_File, Appendix_Content); -- content of + -- Appendix. + end Position_Appendix_Text; + + begin + + -- This code section simulates a scenario that could occur in a + -- text processing environment: + -- A document is created/modified/edited Then... + -- Text is to be appended to the document. + -- A procedure is called to perform that operation. + -- The position on the appended page is set, verified, and text is + -- appended to the existing file. + -- + -- Note: The text file has been originally created in Append_File + -- mode, and has not been closed prior to this processing. + + Position_Appendix_Text; + + Test_Verification_Block: + declare + TC_Page, + TC_Line, + TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + Blanks : constant String := " "; + TC_String : String (1 .. 17) := Blanks; + begin + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Text_IO.Skip_Page (Data_File); + -- Loop to the third line + for I in 1 .. 3 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 16) or else -- Verify the title line. + (TC_String (1..4) /= "VII.") or else + (TC_String (3..16) /= ("I. " & Appendix_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + + TC_String := Blanks; -- Clear string. + -- Loop to the fifth line + for I in 4 .. 5 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 10) or -- Verify the contents. + (TC_String (8..10) /= Appendix_Content) then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open(Data_File) then + Text_IO.Delete(Data_File); + else + Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete(Data_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,293 ---- + -- CXAA003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line + -- subprograms perform properly on a text file reset (from Out_File) + -- with mode Append_File. + -- Check that the attributes Page, Line, and Column are all set to 1 + -- following the reset of a text file with mode Append_File. + -- Check that the functions Page, Line, and Col perform properly on a + -- text file reset with mode Append_File. + -- Check that the procedures Put and Put_Line perform properly on text + -- files reset with mode Append_File. + -- Check that the procedure Set_Line sets the current line number to + -- the value specified by the parameter "To" for text files reset with + -- mode Append_File. Check that Set_Line has no effect if the specified + -- line equals the current line. + -- Check that the procedure Set_Col sets the current column number to + -- the value specified by the parameter "To" for text files reset with + -- mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test is designed to simulate the text processing that could + -- occur with files that have been created in Out_File mode, + -- and then reset to Append_File mode. + -- Various calls to Text_IO formatting subprograms are called to properly + -- position text appended to a document. The text content and position + -- are subsequently verified for accuracy. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA003 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA003" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA003", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "reset with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Out_File, + Name => Data_Filename); + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Text files not supported - Create as Out_File" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + Default_Position : constant Text_IO.Positive_Count := 1; + + Section_Header : constant String := "IX. "; + Glossary_Title : constant String := "GLOSSARY"; + Glossary_Content : constant String := "TBD"; + + -- The following procedure simulates the addition of a Glossary page + -- to an existing text file that has been reset with mode + -- Append_File. + + procedure Position_Glossary_Text + (The_File : in out Text_IO.File_Type) is + use Text_IO; -- To provide visibility to the "/=" operator. + begin + + -- Test control code. + -- Verify initial page value. + if (Text_IO.Page (The_File) /= Default_Position) then + Report.Failed ("Incorrect default page number"); + end if; + -- Verify initial line number. + if (Text_IO.Line (The_File) /= Default_Position) then + Report.Failed ("Incorrect default line number"); + end if; + -- Verify initial column number. + if (Text_IO.Col (The_File) /= Default_Position) then + Report.Failed ("Incorrect default column number"); + end if; + -- Simulated usage code. Set new page/line positions. + Text_IO.New_Page (The_File); + Text_IO.New_Page (The_File); + Text_IO.New_Line (File => The_File, Spacing => 1); + + -- Test control code. + if (Integer(Text_IO.Page(The_File)) /= + Report.Ident_Int(3)) or else + (Integer(Text_IO.Line (The_File)) /= + Report.Ident_Int(2)) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. Position title of Glossary. + Text_IO.Put (The_File, Section_Header); + Text_IO.Put_Line (The_File, Glossary_Title); + -- Set line to the current line. + Text_IO.Set_Line (File => The_File, To => 3); + + -- Test control code. + if (Integer(Text_IO.Page (The_File)) /= Report.Ident_Int(3)) or + (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(3)) or + (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(1)) then + Report.Failed ("Set_Line failed for current line"); + end if; + + -- Simulated usage code. + Text_IO.Set_Line (File => The_File, To => 4); -- Set new + Text_IO.Set_Col (File => The_File, To => 10); -- position. + + -- Test control code. + if (Integer(Text_IO.Line (The_File)) /= Report.Ident_Int(4)) or + (Integer(Text_IO.Col (The_File)) /= Report.Ident_Int(10)) then + Report.Failed + ("Incorrect results from line/column positioning"); + end if; + + -- Simulated usage code. -- Position + Text_IO.Put_Line (The_File, Glossary_Content); -- content of + -- Glossary. + end Position_Glossary_Text; + + + begin + + -- In the scenario, data is added to the file here. + Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); + + -- This code section simulates a scenario that could occur in a + -- text processing environment. Text is to be appended to an + -- existing document: + -- The file is reset to append mode. + -- A procedure is called to perform the positioning and placement + -- of text. + -- The position on the appended page is set, verified, and text is + -- placed in the file. + -- + -- Note: The text file has been originally created in Out_File + -- mode, and has subsequently been reset to Append_File mode. + + Reset1: + begin + -- Reset has effect of calling New_Page. + Text_IO.Reset (Data_File, Text_IO.Append_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Position_Glossary_Text (The_File => Data_File); + + Test_Verification_Block: + declare + TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + Blanks : constant String := + " "; + TC_String : String (1 .. 15) := Blanks; + begin + Reset2: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Text_IO.Skip_Page (Data_File); + Text_IO.Skip_Page (Data_File); + + -- If the Reset to Append_File mode actually put a page terminator + -- on the file, as allowed (but not required) by RM A.10.2(4), then + -- we are now on page 3, an empty page. We'll need to skip one more. + + if Text_IO.End_Of_Page (Data_File) then + Text_IO.Skip_Page (Data_File); + end if; + + -- Now we're on the Glossary page. + + -- Loop to the second line + for I in 1 .. 2 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + if (TC_Position /= 13) or else -- Verify the title line. + (TC_String (1..2) /= "IX") or else + (TC_String (3..13) /= (". " & Glossary_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + + TC_String := Blanks; -- Clear string. + -- Loop to the fourth line + for I in 3 .. 4 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 12) or -- Verify the contents. + (TC_String (8..12) /= " " & Glossary_Content) then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Data_File) then + Text_IO.Delete (Data_File); + else + Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa004.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,260 ---- + -- CXAA004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedures New_Page, Set_Line, Set_Col, and New_Line + -- perform properly on a text file opened with mode Append_File. + -- Check that the attributes Page, Line, and Column are all set to 1 + -- following the opening of a text file with mode Append_File. + -- Check that the functions Page, Line, and Col perform properly on a + -- text file opened with mode Append_File. + -- Check that the procedures Put and Put_Line perform properly on text + -- files opened with mode Append_File. + -- Check that the procedure Set_Line sets the current line number to + -- the value specified by the parameter "To" for text files opened with + -- mode Append_File. + -- Check that the procedure Set_Col sets the current column number to + -- the value specified by the parameter "To" for text files reset with + -- mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test is designed to simulate the text processing that could + -- occur with files that have been created in Out_File mode, + -- and then reset to Append_File mode. + -- Various calls to Text_IO formatting subprograms are called to properly + -- position text appended to a document. The text content and position + -- are subsequently verified for accuracy. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 24 Feb 97 PWB.CTA Allowed for non-support of some IO operations. + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA004 is + use Ada; + Data_File : Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA004" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA004", "Check that page, line, and column formatting " & + "subprograms perform properly on text files " & + "opened with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Text_IO.Out_File, + Name => Data_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + use Text_IO; -- To provide visibility to the "/=" operator. + + Default_Position : constant Text_IO.Positive_Count := 1; + + Section_Header : constant String := "X. "; + Reference_Title : constant String := "REFERENCES"; + Reference_Content : constant String := "Available Upon Request"; + + begin + + -- Some amount of text processing would occur here in the scenario + -- following file creation, prior to file closure. + Text_IO.Put_Line (File => Data_File, Item => "Some optional data"); + + -- Close has the effect of a call to New_Page (adding a page + -- terminator). + Text_IO.Close (Data_File); + + -- This code section simulates a scenario that could occur in a + -- text processing environment: + -- Certain text is to be appended to a document. + -- The file is opened in Append_File mode. + -- The position on the appended page is set, verified, and text + -- is placed in the file. + -- + -- Note: The text file has been originally created in Out_File + -- mode, has been subsequently closed and is now being reopened in + -- Append_File mode for further processing. + + Text_IO.Open (Data_File, Text_IO.Append_File, Data_Filename); + + -- Test control code. + if (Text_IO.Page(Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default page number"); -- page value. + end if; + if (Text_IO.Line(Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default line number"); -- line number. + end if; + if (Text_IO.Col (Data_File) /= Default_Position) then -- Verify init. + Report.Failed ("Incorrect default column number"); -- column no. + end if; + + -- Simulated usage code. + Text_IO.New_Page (Data_File); -- Set new page/ + Text_IO.New_Line (File => Data_File, Spacing => 2); -- line pos. + Text_IO.Put (Data_File, Section_Header); -- Position + Text_IO.Put_Line (Data_File, Reference_Title); -- title. + + -- Test control code. -- Verify new + if (Integer(Text_IO.Page (Data_File)) /= -- page and + Report.Ident_Int(2)) or else -- line. + (Integer(Text_IO.Line (Data_File)) /= + Report.Ident_Int(4)) then + Report.Failed ("Incorrect results from page/line positioning"); + end if; + + -- Simulated usage code. + Text_IO.Set_Line (File => Data_File, To => 8); -- Set new + Text_IO.Set_Col (File => Data_File, To => 30); -- position. + Text_IO.Put_Line (Data_File, Reference_Content); + + -- Test control code. + if (Integer(Text_IO.Line (Data_File)) /= + Report.Ident_Int(9)) or -- Verify new + (Integer(Text_IO.Col (Data_File)) /= -- position. + Report.Ident_Int(1)) then + Report.Failed ("Incorrect results from line/column positioning"); + end if; + + Test_Verification_Block: + declare + TC_Page, TC_Line, TC_Column : Text_IO.Positive_Count; + TC_Position : Natural := 0; + TC_String : String (1 .. 55) := (others => ' '); + begin + + Reset1: + begin + Text_IO.Reset (Data_File, Text_IO.In_File); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Text_IO.Skip_Page (Data_File); + + -- If the Reset to Append_File mode actually put a page terminator + -- in the file, as allowed (but not required) by RM A.10.2(4), then + -- we are now on page 2, an empty page. Therefore, we need to skip + -- one more page. + + if Text_IO.End_Of_Page (Data_File) then + Text_IO.Skip_Page (Data_File); + end if; + + -- Now we're on the reference page. + + -- Loop to the third line + for I in 1 .. 3 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 14) or else -- Verify the title line. + (TC_String (1..6) /= "X. RE") or else + (TC_String (2..14) /= (". " & Reference_Title)) then + Report.Failed ("Incorrect positioning of title line"); + end if; + -- Loop to the eighth line + for I in 4 .. 8 loop -- and read the contents. + Text_IO.Get_Line (Data_File, TC_String, TC_Position); + end loop; + + if (TC_Position /= 51) or -- Verify the contents. + (TC_String (30..51) /= "Available Upon Request") then + Report.Failed ("Incorrect positioning of contents line"); + end if; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised during Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Data_File) then + Text_IO.Delete (Data_File); + else + Text_IO.Open (Data_File, Text_IO.In_File, Data_Filename); + Text_IO.Delete (Data_File); + end if; + exception + when others => + Report.Failed ( "Delete not properly implemented - Text_IO" ); + end Final_Block; + + Report.Result; + + exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ("Unexpected exception"); + Report.Result; + + end CXAA004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa005.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,292 ---- + -- CXAA005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedure Put, when called with string parameters, does + -- not update the line number of a text file of mode Append_File, when + -- the line length is unbounded (i.e., only the column number is + -- updated). + -- Check that a call to the procedure Put with a null string argument + -- has no measurable effect on a text file of mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test is designed to ensure that when a string is appended to an + -- unbounded text file, it is placed following the last element currently + -- in the file. For an unbounded text file written with Put procedures + -- only (not Put_Line), the line number should not be incremented by + -- subsequent calls to Put in Append_File mode. Only the column number + -- should be incremented based on the length of the string parameter + -- placed in the file. If a call to Put with a null string argument is + -- made, no change to the line or column number should occur, and no + -- element(s) should be added to the file, so that there would be no + -- measurable change to the file. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support Text_IO + -- processing and external files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 24 Feb 97 CTA.PWB Allowed for non-support of some IO operations. + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA005 is + An_Unbounded_File : Ada.Text_IO.File_Type; + Unbounded_File_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA005" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA005", "Check that the procedure Put does not " & + "increment line numbers when used with " & + "unbounded text files of mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An application creates a text file in mode Out_File, with the intention + -- of entering string data packets into the file as appropriate. In the + -- event that the particular environment where the application is running + -- does not support Text_IO, Use_Error will be raised on calls to Text_IO + -- operations. + -- This exception will be handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (File => An_Unbounded_File, + Mode => Ada.Text_IO.Out_File, + Name => Unbounded_File_Name); + exception + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + subtype String_Sequence_Type is string (1 .. 20); + type String_Pointer_Type is access String_Sequence_Type; + + -- During the course of processing, the application creates a variety of data + -- pointers that refer to particular data items. The possibility of having + -- null data values in this environment exists. + + Data_Packet_1 : String_Pointer_Type := + new String_Sequence_Type'("One Data Sequence 01"); + + Data_Packet_2 : String_Pointer_Type := + new String_Sequence_Type'("New Data Sequence 02"); + + Blank_Data_Packet : String_Pointer_Type := + new String_Sequence_Type'(" "); + + Null_Data_Packet : constant String := ""; + + TC_Line, TC_Col : Natural := 0; + + function TC_Mode_Selection (Selector : Integer) + return Ada.Text_IO.File_Mode is + begin + case Selector is + when 1 => return Ada.Text_IO.In_File; + when 2 => return Ada.Text_IO.Out_File; + when others => return Ada.Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + begin + + -- The application places some data into the file, using the Put subroutine. + -- This operation can occur one-to-many times. + + Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_1.all); + + -- Test control code. + if (Integer(Ada.Text_IO.Col (An_Unbounded_File)) /= + Report.Ident_Int(21)) or + (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= + Report.Ident_Int(1)) then + Report.Failed ("Incorrect Col position after 1st Put"); + end if; + + -- The application may close the file at some point following its initial + -- entry of data. + + Ada.Text_IO.Close (An_Unbounded_File); + + -- At some later point in the processing, more data needs to be added to the + -- file, so the application opens the file in Append_File mode. + + Ada.Text_IO.Open (File => An_Unbounded_File, + Mode => Ada.Text_IO.Append_File, + Name => Unbounded_File_Name); + + -- Test control code. + -- Store line/column number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); + TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); + + -- Additional data items can then be appended to the file. + + Ada.Text_IO.Put (An_Unbounded_File, Blank_Data_Packet.all); + + -- Test control code. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + (TC_Col + 20)) or + (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 2nd Put"); + end if; + + -- In order to accommodate various scenarios, the application may have changed + -- the mode of the data file to In_File in order to retrieve/verify some of + -- the data contained there. However, with the need to place more data into + -- the file, the file can be reset to Append_File mode. + + Reset1: + begin + Ada.Text_IO.Reset (An_Unbounded_File, + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + -- Test control code. + -- Store line/column number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(An_Unbounded_File)); + TC_Col := Natural(Ada.Text_IO.Col(An_Unbounded_File)); + + -- Additional data can then be appended to the file. On some occasions, an + -- attempt to enter a null string value into the file may occur. This should + -- have no effect on the file, leaving it unchanged. + + -- No measurable effect from Put with null string. + Ada.Text_IO.Put (An_Unbounded_File, Null_Data_Packet); + + -- Test control code. + -- There should be no change following the Put above. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + TC_Col) or + (Natural(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 3rd Put"); + end if; + + -- Additional data can be appended to the file. + + Ada.Text_IO.Put (An_Unbounded_File, Data_Packet_2.all); + + -- Test control code. + if (Natural(Ada.Text_IO.Col (An_Unbounded_File)) /= + (TC_Col + 20)) or + (Integer(Ada.Text_IO.Line (An_Unbounded_File)) /= + TC_Line) then + Report.Failed ("Incorrect Col position after 4th Put"); + end if; + + Test_Verification_Block: + declare + File_Data : String (1 .. 80); + TC_Width : Natural; + begin + + -- The application has the capability to reset the file to In_File mode to + -- verify some of the data that is contained there. + + Reset2: + begin + Ada.Text_IO.Reset (An_Unbounded_File, Ada.Text_IO.In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported - Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Text_IO.Get_Line (An_Unbounded_File, + File_Data, + TC_Width); + + -- Test control code. + -- Since it is implementation defined whether a page + -- terminator separates preexisting text from new text + -- following an open in append mode (as occurred above), + -- verify only that the first data item written to the + -- file was not overwritten by any subsequent call to Put. + + if (File_Data (File_Data'First) /= 'O') or + (File_Data (20) /= '1') then + Report.Failed ("Data placed incorrectly in file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Ada.Text_IO.Is_Open(An_Unbounded_File) then + Ada.Text_IO.Delete (An_Unbounded_File); + else + Ada.Text_IO.Open(An_Unbounded_File, + Ada.Text_IO.In_File, + Unbounded_File_Name); + Ada.Text_IO.Delete (An_Unbounded_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented -- Text_IO" ); + end Final_Block; + + Report.Result; + + exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa006.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,285 ---- + -- CXAA006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that for a bounded line length text file of mode Append_File, + -- when the number of characters to be output exceeds the number of + -- columns remaining on the current line, a call to Put will output + -- characters of the string sufficient to fill the remaining columns of + -- the line (up to line length), then output a line terminator, reset the + -- column number, increment the line number, then output the balance of + -- the item. + -- + -- Check that the procedure Put does not raise Layout_Error when the + -- number of characters to be output exceeds the line length of a bounded + -- text file of mode Append_File. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the situation where an application intends to + -- output variable length string elements to a text file in the most + -- efficient manner possible. This is the case in a typesetting + -- environment where text is compressed and split between lines of a + -- bounded length. + -- + -- The procedure Put will break string parameters placed in the file at + -- the point of the line length. Two examples are demonstrated in this + -- test, one being the case where only one column remains on a line, and + -- the other being the case where a larger portion of the line remains + -- unfilled, but still not sufficient to contain the entire output + -- string. + -- + -- During the course of the test, the file is reset to Append_File mode, + -- and the bounded line length is modified for different lines of the + -- file. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support Text_IO + -- processing and external files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA006 is + + A_Bounded_File : Ada.Text_IO.File_Type; + Bounded_File_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA006" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA006", "Check that procedure Put will correctly " & + "output string items to a bounded line " & + "length text file of mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An application creates a text file in mode Append_File, with the intention + -- of using the procedure Put to compress variable length string data into the + -- file in the most efficient manner possible. + + Ada.Text_IO.Create (File => A_Bounded_File, + Mode => Ada.Text_IO.Append_File, + Name => Bounded_File_Name); + exception + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + Twelve_Characters : constant String := "12Characters"; + Nineteen_Characters : constant String := "Nineteen_Characters"; + TC_Line : Natural := 0; + + function TC_Mode_Selection (Selector : Integer) + return Ada.Text_IO.File_Mode is + begin + case Selector is + when 1 => return Ada.Text_IO.In_File; + when 2 => return Ada.Text_IO.Out_File; + when others => return Ada.Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + begin + + -- The application sets the line length of the file to be bound at 20. All + -- lines in this file will be limited to that length. + + Ada.Text_IO.Set_Line_Length (A_Bounded_File, 20); + + Ada.Text_IO.Put (A_Bounded_File, Nineteen_Characters); + + -- Test control code. + if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= + Report.Ident_Int(1)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(20)) then + Report.Failed ("Incorrect position after 1st Put"); + end if; + + -- The application finds that there is only one column available on the + -- current line, so the next string item to be output must be broken at + -- the appropriate place (following the first character). + + Ada.Text_IO.Put (File => A_Bounded_File, + Item => Twelve_Characters); + + -- Test control code. + if (Integer(Ada.Text_IO.Line (A_Bounded_File)) /= + Report.Ident_Int(2)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(12)) then + Report.Failed ("Incorrect position after 2nd Put"); + end if; + + -- The application subsequently modifies the processing, resetting the file + -- at this point to In_File mode in order to verify data that has been written + -- to the file. Following this, the application resets the file to Append_File + -- mode in order to continue the placement of data into the file, but modifies + -- the original bounded line length for subsequent lines to be appended. + + -- Reset to Append mode; call outputs page terminator and + -- resets line length to Unbounded. + Reset1: + begin + Ada.Text_IO.Reset (A_Bounded_File, + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Ada.Text_IO.Set_Line_Length (A_Bounded_File, 15); + + -- Store line number for later comparison. + TC_Line := Natural(Ada.Text_IO.Line(A_Bounded_File)); + + -- The application finds that fifteen columns are available on the current + -- line but that the string item to be output exceeds this available space. + -- It must be split at the end of the line, and the balance placed on the + -- next file line. + + Ada.Text_IO.Put (File => A_Bounded_File, + Item => Nineteen_Characters); + + -- Test control code. + -- Positioned on new line at col 5. + if (Natural(Ada.Text_IO.Line (A_Bounded_File)) /= + (TC_Line + 1)) or + (Integer(Ada.Text_IO.Col (A_Bounded_File)) /= + Report.Ident_Int(5)) then + Report.Failed ("Incorrect position after 3rd Put"); + end if; + + + Test_Verification_Block: + declare + First_String : String (1 .. 80); + Second_String : String (1 .. 80); + Third_String : String (1 .. 80); + Fourth_String : String (1 .. 80); + TC_Width1 : Natural; + TC_Width2 : Natural; + TC_Width3 : Natural; + TC_Width4 : Natural; + begin + + -- The application has the capability to reset the file to In_File mode to + -- verify some or all of the data that is contained there. + + Reset2: + begin + Ada.Text_IO.Reset (A_Bounded_File, Ada.Text_IO.In_File); + exception + when others => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Text_IO.Get_Line + (A_Bounded_File, First_String, TC_Width1); + Ada.Text_IO.Get_Line + (A_Bounded_File, Second_String, TC_Width2); + Ada.Text_IO.Get_Line + (A_Bounded_File, Third_String, TC_Width3); + Ada.Text_IO.Get_Line + (A_Bounded_File, Fourth_String, TC_Width4); + + -- Test control code. + if (First_String (1..TC_Width1) /= Nineteen_Characters & "1") or + (Second_String (1..TC_Width2) /= "2Characters") or + (Third_String (1..TC_Width3) /= + Nineteen_Characters(1..15)) or + (Fourth_String (1..TC_Width4) /= "ters") + then + Report.Failed ("Data placed incorrectly in file"); + end if; + + exception + + when Incomplete => + raise; + + when Ada.Text_IO.End_Error => + Report.Failed ("Incorrect number of lines in file"); + + when others => + Report.Failed ("Error raised during data verification"); + + end Test_Verification_Block; + + exception + + when Ada.Text_IO.Layout_Error => + Report.Failed ("Layout Error raised when positioning text"); + + when others => + Report.Failed ("Exception in Text_IO processing"); + + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Ada.Text_IO.Is_Open(A_Bounded_File) then + Ada.Text_IO.Delete (A_Bounded_File); + else + Ada.Text_IO.Open (A_Bounded_File, + Ada.Text_IO.In_File, + Bounded_File_Name); + Ada.Text_IO.Delete (A_Bounded_File); + end if; + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Final_Block; + + Report.Result; + + exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa007.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,263 ---- + -- CXAA007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the capabilities of Text_IO.Integer_IO perform correctly + -- on files of Append_File mode, for instantiations with integer and + -- user-defined subtypes. + -- Check that the formatting parameters available in the package can + -- be used and modified successfully in the storage and retrieval of + -- data. + -- + -- TEST DESCRIPTION: + -- This test simulates a receiving department inventory system. Data on + -- items received is entered into an inventory database. This information + -- consists of integer entry number, item number, and bar code. + -- One item is placed into the inventory file immediately following file + -- creation, subsequent items are entered following file opening in + -- Append_File mode. Data items are validated by reading all data from + -- the file and comparing against known values (those used to enter the + -- data originally). + -- + -- This test verifies issues of create in Append_File mode, appending to + -- a file previously appended to, opening in Append_File mode, resetting + -- from Append_File mode to In_File mode, as well as a variety of Text_IO + -- and Integer_IO predefined subprograms. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA007 is + use Ada; + + Inventory_File : Text_IO.File_Type; + Inventory_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA007" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA007", "Check that the capabilities of " & + "Text_IO.Integer_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Inventory_File, + Mode => Text_IO.Append_File, + Name => Inventory_Filename); + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + + Max_Entries_Per_Order : constant Natural := 4; + + type Bar_Code_Type is range 0 .. 127; -- Values to be stored as base + -- two numbers in file. + type Item_Type is record + Entry_Number : Natural := 0; + Item_Number : Integer := 0; + Bar_Code : Bar_Code_Type := 0; + end record; + + type Inventory_Type is + array (1 .. Max_Entries_Per_Order) of Item_Type; + + Inventory_List : Inventory_Type := ((1, 119, 87), -- Items received + (2, 206, 44), -- this order. + (3, -25, 126), + (4, -18, 31)); + + Daily_Order : constant := 1; + Entry_Field_Width : constant Natural := 1; + Item_Base : constant Natural := 16; + Items_Inventoried : Natural := 1; + Items_To_Inventory : Natural := 4; + + package Entry_IO is new Text_IO.Integer_IO (Natural); + package Item_IO is new Text_IO.Integer_IO (Integer); + package Bar_Code_IO is new Text_IO.Integer_IO (Bar_Code_Type); + + + -- The following procedure simulates the addition of inventory item + -- information into a data file. + + procedure Update_Inventory (The_Item : in Item_Type) is + Spacer : constant String := " "; + begin + -- Enter all the incoming data into the inventory file. + Entry_IO.Put (Inventory_File, The_Item.Entry_Number); + Text_IO.Put (Inventory_File, Spacer); + Item_IO.Put (Inventory_File, The_Item.Item_Number); + Text_IO.Put (Inventory_File, Spacer); + Bar_Code_IO.Put(File => Inventory_File, + Item => The_Item.Bar_Code, + Width => 13, + Base => 2); + Text_IO.New_Line(Inventory_File); + end Update_Inventory; + + + begin + + -- This code section simulates a receiving department maintaining a + -- data file containing information on items that have been ordered + -- and received. + -- + -- As new orders are received, the file is opened in Append_File + -- mode. + -- Data is taken from the inventory list and entered into the file, + -- in specific format. + -- Enter the order into the inventory file. This is item 1 in + -- the inventory list. + -- The data entry process can be repeated numerous times as required. + + Entry_IO.Put (Inventory_File, + Inventory_List(Daily_Order).Entry_Number); + Item_IO.Put (Inventory_File, + Inventory_List(Daily_Order).Item_Number); + Bar_Code_IO.Put (File => Inventory_File, + Item => Inventory_List(Daily_Order).Bar_Code); + Text_IO.New_Line (Inventory_File); + + Text_IO.Close (Inventory_File); + + + Entry_IO.Default_Width := Entry_Field_Width; -- Modify the default + -- width of Entry_IO. + Item_IO.Default_Base := Item_Base; -- Modify the default + -- number base of + -- Item_IO + Text_IO.Open (Inventory_File, + Text_IO.Append_File, -- Open in Append mode. + Inventory_Filename); + -- Enter items + while (Items_Inventoried < Items_To_Inventory) loop -- 2-4 into the + Items_Inventoried := Items_Inventoried + 1; -- inventory file. + Update_Inventory (The_Item => Inventory_List (Items_Inventoried)); + end loop; + + Test_Verification_Block: -- Read and check + declare -- all the data + TC_Entry : Natural; -- values that + TC_Item : Integer; -- have been + TC_Bar_Code : Bar_Code_Type; -- entered in the + TC_Item_Count : Natural := 0; -- data file. + begin + + Reset1: + begin + Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to mode In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + while not Text_IO.End_Of_File (Inventory_File) loop + Entry_IO.Get (Inventory_File, TC_Entry); + Item_IO.Get (Inventory_File, TC_Item); + Bar_Code_IO.Get (Inventory_File, TC_Bar_Code); + Text_IO.Skip_Line (Inventory_File); + TC_Item_Count := TC_Item_Count + 1; + + if (TC_Item /= Inventory_List(TC_Entry).Item_Number) or + (TC_Bar_Code /= Inventory_List(TC_Entry).Bar_Code) then + Report.Failed ("Error in integer data read from file"); + end if; + end loop; + + if (TC_Item_Count /= Max_Entries_Per_Order) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Integer_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open(Inventory_File) then + Text_IO.Delete (Inventory_File); + else + Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); + Text_IO.Delete (Inventory_File); + end if; + + exception + + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + + exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa008.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,271 ---- + -- CXAA008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the capabilities provided in instantiations of the + -- Ada.Text_IO.Fixed_IO package operate correctly when the mode of + -- the file is Append_File. Check that Fixed_IO procedures Put and Get + -- properly transfer fixed point data to/from data files that are in + -- Append_File mode. Check that the formatting parameters available in + -- the package can be used and modified successfully in the appending and + -- retrieval of data. + -- + -- TEST DESCRIPTION: + -- This test simulates order processing, with data values being written + -- to a file, in a specific format, using Fixed_IO. Validation is done + -- on this process by reading the data values from the file, and + -- comparing them for equality with the values originally written to + -- the file. + -- + -- This test verifies issues of create in Append_File mode, appending to + -- a file previously appended to, resetting to Append_File mode, + -- resetting from Append_File mode to In_File mode, as well as a + -- variety of Text_IO and Fixed_IO predefined subprograms. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA008 is + use Ada; + + Inventory_File : Text_IO.File_Type; + Inventory_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA008" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA008", "Check that the capabilities of " & + "Text_IO.Fixed_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Inventory_File, + Mode => Text_IO.Append_File, + Name => Inventory_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create with Append_File for Text_IO" ); + raise Incomplete; + end Test_For_Text_IO_Support; + + Operational_Test_Block: + declare + + Daily_Orders_Received : constant Natural := 4; + + type Item_Type is delta 0.1 range 0.0 .. 5000.0; + type Cost_Type is delta 0.01 range 0.0 .. 10_000.0; + type Profit_Type is delta 0.01 range -100.0 .. 1000.0; + + type Product_Type is record + Item_Number : Item_Type := 0.0; + Unit_Cost : Cost_Type := 0.00; + Percent_Markup : Profit_Type := 0.00; + end record; + + type Inventory_Type is + array (1 .. Daily_Orders_Received) of Product_Type; + + Daily_Inventory : Inventory_Type := (( 1.0, 1.75, 50.00), + ( 155.0, 20.00, -5.50), + (3343.5, 2.50, 126.50), + (4986.0, 180.00, 31.75)); + + package Item_IO is new Text_IO.Fixed_IO (Item_Type); + package Cost_IO is new Text_IO.Fixed_IO (Cost_Type); + package Markup_IO is new Text_IO.Fixed_IO (Profit_Type); + + + function TC_Mode_Selection (Selector : Integer) + return Text_IO.File_Mode is + begin + case Selector is + when 1 => return Text_IO.In_File; + when 2 => return Text_IO.Out_File; + when others => return Text_IO.Append_File; + end case; + end TC_Mode_Selection; + + + -- The following function simulates the addition of inventory item + -- information into a data file. Boolean status of True is returned + -- if all of the data entry was successful, False otherwise. + + function Update_Inventory (The_List : Inventory_Type) + return Boolean is + begin + for I in 1 .. Daily_Orders_Received loop + Item_IO.Put (Inventory_File, The_List(I).Item_Number); + Cost_IO.Put (Inventory_File, The_List(I).Unit_Cost, 10, 4, 0); + Markup_IO.Put(File => Inventory_File, + Item => The_List(I).Percent_Markup, + Fore => 6, + Aft => 3, + Exp => 2); + Text_IO.New_Line (Inventory_File); + end loop; + return (True); -- Return a Status value. + exception + when others => return False; + end Update_Inventory; + + + begin + + -- This code section simulates a receiving department maintaining a + -- data file containing information on items that have been ordered + -- and received. + + -- Whenever items are received, the file is reset to Append_File + -- mode. Data is taken from an inventory list and entered into the + -- file, in specific format. + + Reset1: + begin -- Reset to + Text_IO.Reset (Inventory_File, -- Append mode. + TC_Mode_Selection (Report.Ident_Int(3))); + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + end Reset1; + + -- Enter data. + if not Update_Inventory (The_List => Daily_Inventory) then + Report.Failed ("Exception occurred during inventory update"); + raise Incomplete; + end if; + + Test_Verification_Block: + declare + TC_Item : Item_Type; + TC_Cost : Cost_Type; + TC_Markup : Profit_Type; + TC_Item_Count : Natural := 0; + begin + + Reset2: + begin + Text_IO.Reset (Inventory_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + while not Text_IO.End_Of_File (Inventory_File) loop + Item_IO.Get (Inventory_File, TC_Item); + Cost_IO.Get (Inventory_File, TC_Cost); + Markup_IO.Get (File => Inventory_File, + Item => TC_Markup, + Width => 0); + Text_IO.Skip_Line (Inventory_File); + TC_Item_Count := TC_Item_Count + 1; + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Item /= Daily_Inventory(TC_Item_Count).Item_Number) then + Report.Failed ("Error in Item_Number read from file"); + end if; + if (TC_Cost /= Daily_Inventory(TC_Item_Count).Unit_Cost) then + Report.Failed ("Error in Unit_Cost read from file"); + end if; + if not (TC_Markup = + Daily_Inventory(TC_Item_Count).Percent_Markup) then + Report.Failed ("Error in Percent_Markup read from file"); + end if; + + end loop; + + if (TC_Item_Count /= Daily_Orders_Received) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Fixed_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Inventory_File) then + Text_IO.Delete (Inventory_File); + else + Text_IO.Open (Inventory_File, Text_IO.In_File, Inventory_Filename); + Text_IO.Delete (Inventory_File); + end if; + + exception + + when others => + Report.Failed ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa009.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,290 ---- + -- CXAA009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the capabilities provided in instantiations of the + -- Ada.Text_IO.Float_IO package operate correctly when the mode of + -- the file is Append_File. Check that Float_IO procedures Put and Get + -- properly transfer floating point data to/from data files that are in + -- Append_File mode. Check that the formatting parameters available in + -- the package can be used and modified successfully in the appending and + -- retrieval of data. + -- + -- TEST DESCRIPTION: + -- This test is designed to simulate an environment where a data file + -- that holds floating point information is created, written to, and + -- closed. In the future, the file can be reopened in Append_File mode, + -- additional data can be appended to it, and then closed. This process + -- of Open/Append/Close can be repeated as necessary. All data written + -- to the file is verified for accuracy when retrieved from the file. + -- + -- This test verifies issues of create in Append_File mode, appending to + -- a file previously appended to, opening in Append_File mode, resetting + -- from Append_File mode to In_File mode, as well as a variety of Text_IO + -- and Float_IO predefined subprograms. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA009 is + + use Ada; + Loan_File : Text_IO.File_Type; + Loan_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA009" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA009", "Check that the capabilities of " & + "Text_IO.Float_IO operate correctly for files " & + "with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Loan_File, -- Create in + Mode => Text_IO.Out_File, -- Out_File mode. + Name => Loan_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + Operational_Test_Block: + declare + Total_Loans_Outstanding : constant Natural := 3; + Transaction_Status : Boolean := False; + + type Account_Balance_Type is digits 6 range 0.0 .. 1.0E6; + type Loan_Balance_Type is digits 6; + type Interest_Rate_Type is digits 4 range 0.0 .. 30.00; + + type Loan_Info_Type is record + Account_Balance : Account_Balance_Type := 0.00; + Loan_Balance : Loan_Balance_Type := 0.00; + Loan_Interest_Rate : Interest_Rate_Type := 0.00; + end record; + + Home_Refinance_Loan : Loan_Info_Type := + (14_500.00, 135_000.00, 6.875); + Line_Of_Credit_Loan : Loan_Info_Type := + ( 5490.00, -3000.00, 13.75); + Small_Business_Loan : Loan_Info_Type := + (Account_Balance => 45_000.00, + Loan_Balance => 10_500.00, + Loan_Interest_Rate => 5.875); + + package Acct_IO is new Text_IO.Float_IO (Account_Balance_Type); + package Loan_IO is new Text_IO.Float_IO (Loan_Balance_Type); + package Rate_IO is new Text_IO.Float_IO (Interest_Rate_Type); + + + -- The following procedure performs the addition of loan information + -- into a data file. Boolean status of True is returned if all of + -- the data entry was successful, False otherwise. + -- This demonstrates use of Float_IO using a variety of data formats. + + procedure Update_Loan_Info (The_File : in out Text_IO.File_Type; + The_Loan : in Loan_Info_Type; + Status : out Boolean ) is + begin + Acct_IO.Put (The_File, The_Loan.Account_Balance); + Loan_IO.Put (The_File, The_Loan.Loan_Balance, 15, 2, 0); + Rate_IO.Put (File => The_File, + Item => The_Loan.Loan_Interest_Rate, + Fore => 6, + Aft => 3, + Exp => 0); + Text_IO.New_Line (The_File); + Status := True; + exception + when others => Status := False; + end Update_Loan_Info; + + + begin + + -- This code section simulates a bank maintaining a data file + -- containing information on loans that have been made. + -- The scenario: + -- The loan file was created in Out_File mode. + -- Some number of data records are added. + -- The file is closed. + -- The file is subsequently reopened in Append_File mode. + -- Data is appended to the file. + -- The file is closed. + -- Repeat the Open/Append/Close process as required. + -- Verify data in the file. + -- etc. + + Update_Loan_Info(Loan_File, Home_Refinance_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed ("Failure in update of first loan data"); + end if; + + Text_IO.Close (Loan_File); + + -- When subsequent data items are to be added to the file, the file + -- is opened in Append_File mode. + + Text_IO.Open (Loan_File, -- Open with + Text_IO.Append_File, -- Append mode. + Loan_Filename); + + Update_Loan_Info(Loan_File, Line_Of_Credit_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed("Failure in update of first loan data"); + end if; + + Text_IO.Close(Loan_File); + + -- To add additional data to the file, the file + -- is again opened in Append_File mode (appending to a file + -- previously appended to). + + Text_IO.Open (Loan_File, -- Open with + Text_IO.Append_File, -- Append mode. + Loan_Filename); + + Update_Loan_Info(Loan_File, Small_Business_Loan, Transaction_Status); + + if not Transaction_Status then + Report.Failed("Failure in update of first loan data"); + end if; + + Test_Verification_Block: + declare + type Ledger_Type is + array (1 .. Total_Loans_Outstanding) of Loan_Info_Type; + TC_Bank_Ledger : Ledger_Type; + TC_Item_Count : Natural := 0; + begin + + Reset1: + begin + Text_IO.Reset (Loan_File, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + while not Text_IO.End_Of_File (Loan_File) loop + TC_Item_Count := TC_Item_Count + 1; + Acct_IO.Get (Loan_File, + TC_Bank_Ledger(TC_Item_Count).Account_Balance); + Loan_IO.Get (Loan_File, + TC_Bank_Ledger(TC_Item_Count).Loan_Balance, + 0); + Rate_IO.Get(File => Loan_File, + Item => + TC_Bank_Ledger(TC_Item_Count).Loan_Interest_Rate, + Width => 0); + Text_IO.Skip_Line(Loan_File); + + end loop; + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Bank_Ledger(1) /= Home_Refinance_Loan) or + (TC_Bank_Ledger(2) /= Line_Of_Credit_Loan) or + (TC_Bank_Ledger(3) /= Small_Business_Loan) then + Report.Failed("Error in data read from file"); + end if; + + if (TC_Item_Count /= Total_Loans_Outstanding) then + Report.Failed ("Incorrect number of records read from file"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Float_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open(Loan_File) then + Text_IO.Delete(Loan_File); + else + Text_IO.Open(Loan_File, Text_IO.In_File, Loan_Filename); + Text_IO.Delete(Loan_File); + end if; + + exception + + when Text_IO.Use_Error => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa010.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,335 ---- + -- CXAA010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the operations defined in package Ada.Text_IO.Decimal_IO + -- are available, and that they function correctly when used for the + -- input/output of Decimal types. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the Put and Get procedures found in the + -- generic package Ada.Text_IO.Decimal_IO. Both Put and Get are + -- overloaded to allow placement or extraction of decimal values + -- to/from a text file or a string. This test demonstrates both forms + -- of each subprogram. + -- The test defines an array of records containing decimal value + -- and string component fields. All component values are placed in a + -- Text_IO file, with the decimal values being placed there using the + -- version of Put defined for files, and using user-specified formatting + -- parameters. The data is later extracted from the file, with the + -- decimal values being removed using the version of Get defined for + -- files. Decimal values are then written to strings, using the + -- appropriate Put procedure. Finally, extraction of the decimal data + -- from the strings completes the evaluation of the Decimal_IO package + -- subprograms. + -- The reconstructed data is verified at the end of the test against the + -- data originally written to the file. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all implementations capable of supporting external + -- Text_IO files and Decimal Fixed Point Types + -- + -- All implementations must attempt to compile this test. + -- + -- For implementations validating against Information Systems Annex (F): + -- this test must execute and report PASSED. + -- + -- For implementations not validating against Annex F: + -- this test may report compile time errors at one or more points + -- indicated by "-- ANX-F RQMT", in which case it may be graded as inapplicable. + -- Otherwise, the test must execute and report PASSED. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 20 Feb 95 SAIC Modified test to allow for Use_Error/Name_Error + -- generation by an implementation not supporting + -- Text_IO operations. + -- 14 Nov 95 SAIC Corrected string indexing for ACVC 2.0.1. + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + -- 16 FEB 98 EDS Modified documentation. + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA010 is + use Ada.Text_IO; + Tax_Roll : Ada.Text_IO.File_Type; + Tax_Roll_Name : constant String := + Report.Legal_File_Name ( Nam => "CXAA010" ); + Incomplete : exception; + begin + + Report.Test ("CXAA010", "Check that the operations defined in package " & + "Ada.Text_IO.Decimal_IO are available, and " & + "that they function correctly when used for " & + "the input/output of Decimal types"); + + Test_for_Decimal_IO_Support: + begin + + -- An implementation that does not support Text_IO creation or naming + -- of external files in a particular environment will raise Use_Error + -- or Name_Error on a call to Text_IO Create. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. Either of these exceptions will be + -- handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); + + exception + + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Decimal_IO_Support; + + Taxation: + declare + + ID_Length : constant := 5; + Price_String_Length : constant := 5; + Value_String_Length : constant := 6; + Total_String_Length : constant := 20; + Spacer : constant String := " "; -- Two blanks. + + type Price_Type is delta 0.1 digits 4; -- ANX-F RQMT + type Value_Type is delta 0.01 digits 5; -- ANX-F RQMT + + type Property_Type is + record + Parcel_ID : String (1..ID_Length); + Purchase_Price : Price_Type; + Assessed_Value : Value_Type; + end record; + + type City_Block_Type is array (1..4) of Property_Type; + + subtype Tax_Bill_Type is string (1..Total_String_Length); + type Tax_Bill_Array_Type is array (1..4) of Tax_Bill_Type; + + Neighborhood : City_Block_Type := + (("X9254", 123.0, 135.00), ("X3569", 345.0, 140.50), + ("X3434", 234.0, 179.50), ("X8838", 456.0, 158.00)); + + Neighborhood_Taxes : Tax_Bill_Array_Type; + + package Price_IO is new Ada.Text_IO.Decimal_IO (Price_Type); + package Value_IO is new Ada.Text_IO.Decimal_IO (Value_Type); + + begin -- Taxation + + Assessors_Office: + begin + + for Parcel in City_Block_Type'Range loop + -- Note: All data in the file will be separated with a + -- two-character blank spacer. + Ada.Text_IO.Put(Tax_Roll, Neighborhood(Parcel).Parcel_ID); + Ada.Text_IO.Put(Tax_Roll, Spacer); + + -- Use Decimal_IO.Put with non-default format parameters to + -- place decimal data into file. + Price_IO.Put (Tax_Roll, Neighborhood(Parcel).Purchase_Price, + Fore => 3, Aft =>1, Exp => 0); + Ada.Text_IO.Put(Tax_Roll, Spacer); + + Value_IO.Put (Tax_Roll, Neighborhood(Parcel).Assessed_Value, + Fore => 3, Aft =>2, Exp => 0); + Ada.Text_IO.New_Line(Tax_Roll); + end loop; + + Ada.Text_IO.Close (Tax_Roll); + + exception + when others => + Report.Failed ("Exception raised in Assessor's Office"); + end Assessors_Office; + + + Twice_A_Year: + declare + + procedure Collect_Tax(Index : in Integer; + Tax_Array : in out Tax_Bill_Array_Type) is + ID : String (1..ID_Length); + Price : Price_Type := 0.0; + Value : Value_Type := 0.00; + Price_String : String (1..Price_String_Length); + Value_String : String (1..Value_String_Length); + begin + + -- Extract information from the Text_IO file; one string, two + -- decimal values. + -- Note that the Spacers that were put in the file above are + -- not individually read here, due to the fact that each call + -- to Decimal_IO.Get below uses a zero in the Width field, + -- which allows each Get procedure to skip these leading blanks + -- prior to extracting the numeric value. + + Ada.Text_IO.Get (Tax_Roll, ID); + + -- A zero value of Width is provided, so the following + -- two calls to Decimal_IO.Get will skip the leading blanks, + -- (from the Spacer variable above), then read the numeric + -- literals. + + Price_IO.Get (Tax_Roll, Price, 0); + Value_IO.Get (Tax_Roll, Value, 0); + Ada.Text_IO.Skip_Line (Tax_Roll); + + -- Convert the values read from the file into string format, + -- using user-specified format parameters. + -- Format of the Price_String should be "nnn.n" + -- Format of the Value_String should be "nnn.nn" + + Price_IO.Put (To => Price_String, + Item => Price, + Aft => 1); + Value_IO.Put (Value_String, Value, 2); + + -- Construct a string of length 20 that contains the Parcel_ID, + -- the Purchase_Price, and the Assessed_Value, separated by + -- two-character blank data spacers. Store this string + -- into the string array out parameter. + -- Format of each Tax_Array element should be + -- "Xnnnn nnn.n nnn.nn" (with an 'n' signifying a digit). + + Tax_Array(Index) := ID & Spacer & + Price_String & Spacer & + Value_String; + exception + when Data_Error => + Report.Failed("Data Error raised during the extraction " & + "of decimal data from the file"); + when others => + Report.Failed("Exception in Collect_Tax procedure"); + end Collect_Tax; + + + begin -- Twice_A_Year + + Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.In_File, Tax_Roll_Name); + + -- Determine property tax bills for the entire neighborhood from + -- the information that is stored in the file. Store information + -- in the Neighborhood_Taxes string array. + + for Parcel in City_Block_Type'Range loop + Collect_Tax (Parcel, Neighborhood_Taxes); + end loop; + + exception + when others => + Report.Failed ("Exception in Twice_A_Year Block"); + end Twice_A_Year; + + -- Use Decimal_IO Get procedure to extract information from a string. + -- Verify data against original values. + Validation_Block: + declare + TC_ID : String (1..ID_Length); -- 1..5 + TC_Price : Price_Type; + TC_Value : Value_Type; + Length : Positive; + Front, + Rear : Integer := 0; + begin + + for Parcel in City_Block_Type'Range loop + -- Extract values from the strings of the string array. + -- Each element of the string array is 20 characters long; the + -- first five characters are the Parcel_ID, two blank characters + -- separate data, the next five characters contain the Price + -- decimal value, two blank characters separate data, the last + -- six characters contain the Value decimal value. + -- Extract each of these components in turn. + + Front := 1; -- 1 + Rear := ID_Length; -- 5 + TC_ID := Neighborhood_Taxes(Parcel)(Front..Rear); + + -- Extract the decimal value from the next slice of the string. + Front := Rear + 3; -- 8 + Rear := Front + Price_String_Length - 1; -- 12 + Price_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), + Item => TC_Price, + Last => Length); + + -- Extract next decimal value from slice of string, based on + -- length of preceding strings read from string array element. + Front := Rear + 3; -- 15 + Rear := Total_String_Length; -- 20 + Value_IO.Get (Neighborhood_Taxes(Parcel)(Front..Rear), + Item => TC_Value, + Last => Length); + + if TC_ID /= Neighborhood(Parcel).Parcel_ID or + TC_Price /= Neighborhood(Parcel).Purchase_Price or + TC_Value /= Neighborhood(Parcel).Assessed_Value + then + Report.Failed ("Incorrect data validation"); + end if; + + end loop; + + exception + when others => Report.Failed ("Exception in Validation Block"); + end Validation_Block; + + -- Check that the Text_IO file is open, then delete. + + if not Ada.Text_IO.Is_Open (Tax_Roll) then + Report.Failed ("File not left open after processing"); + Ada.Text_IO.Open (Tax_Roll, Ada.Text_IO.Out_File, Tax_Roll_Name); + end if; + + Ada.Text_IO.Delete (Tax_Roll); + + exception + when others => + Report.Failed ("Exception in Taxation block"); + -- Check that the Text_IO file is open, then delete. + if not Ada.Text_IO.Is_Open (Tax_Roll) then + Ada.Text_IO.Open (Tax_Roll, + Ada.Text_IO.Out_File, + Tax_Roll_Name); + end if; + Ada.Text_IO.Delete (Tax_Roll); + end Taxation; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa011.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- CXAA011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the operations of Text_IO.Enumeration_IO perform correctly + -- on files of Append_File mode, for instantiations using + -- enumeration types. Check that Enumeration_IO procedures Put and Get + -- properly transfer enumeration data to/from data files. + -- Check that the formatting parameters available in the package can + -- be used and modified successfully in the storage and retrieval of data. + -- + -- TEST DESCRIPTION: + -- This test is designed to simulate an environment where a data file + -- that holds enumeration type information is reset from it current mode + -- to allow the appending of data to the end of the This process + -- of Reset/Write can be repeated as necessary. All data written + -- to the file is verified for accuracy when retrieved from the file. + -- + -- This test verifies issues of resetting a file created in Out_File mode + -- to Append_File mode, resetting from Append_File mode to In_File mode, + -- as well as a variety of Text_IO and Enumeration_IO predefined + -- subprograms. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA011 is + use Ada; + + Status_Log : Text_IO.File_Type; + Status_Log_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA011" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA011", "Check that the operations of " & + "Text_IO.Enumeration_IO operate correctly for " & + "files with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An implementation that does not support Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Text_IO operations. This block statement encloses a call to + -- Create, which should raise the exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Text_IO.Create (File => Status_Log, + Mode => Text_IO.Out_File, + Name => Status_Log_Filename); + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + + Operational_Test_Block: + declare + + type Days_In_Week is (Monday, Tuesday, Wednesday, Thursday, Friday, + Saturday, Sunday); + type Hours_In_Day is (A0000, A0600, P1200, P0600); -- Six hour + -- blocks. + type Status_Type is (Operational, Off_Line); + + type Status_Record_Type is record + Day : Days_In_Week; + Hour : Hours_In_Day; + Status : Status_Type; + end record; + + Morning_Reading : Status_Record_Type := + (Wednesday, A0600, Operational); + Evening_Reading : Status_Record_Type := + (Saturday, P0600, Off_Line); + + package Day_IO is new Text_IO.Enumeration_IO (Days_In_Week); + package Hours_IO is new Text_IO.Enumeration_IO (Hours_In_Day); + package Status_IO is new Text_IO.Enumeration_IO (Status_Type); + + + -- The following function simulates the hourly recording of equipment + -- status. + + function Record_Status (Reading : Status_Record_Type) + return Boolean is + use Text_IO; -- To provide visibility to type Type_Set and + -- enumeration literal Upper_Case. + begin + Day_IO.Put (File => Status_Log, + Item => Reading.Day, + Set => Type_Set'(Upper_Case)); + Hours_IO.Put (Status_Log, Reading.Hour, 7); + Status_IO.Put (Status_Log, Reading.Status, + Width => 8, Set => Lower_Case); + Text_IO.New_Line (Status_Log); + return (True); + exception + when others => return False; + end Record_Status; + + begin + + -- The usage scenario intended is as follows: + -- File is created. + -- Unrelated/unknown file processing occurs. + -- On six hour intervals, file is reset to Append_File mode. + -- Data is appended to file. + -- Unrelated/unknown file processing resumes. + -- Reset/Append process is repeated. + + Reset1: + begin + Text_IO.Reset (Status_Log, -- Reset to + Text_IO.Append_File); -- Append mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + Day_IO.Default_Width := Days_In_Week'Width + 5; -- Default values + -- are modifiable. + + if not Record_Status (Morning_Reading) then -- Enter data. + Report.Failed ("Exception occurred during data file update"); + end if; + + Reset2: + begin + Text_IO.Reset (Status_Log, -- Reset to + Text_IO.Append_File); -- Append mode. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO" ); + raise Incomplete; + end Reset2; + + if not Record_Status (Evening_Reading) then -- Enter data. + Report.Failed ("Exception occurred during data file update"); + end if; + + Test_Verification_Block: + declare + TC_Reading1 : Status_Record_Type; + TC_Reading2 : Status_Record_Type; + begin + + Reset3: + begin + Text_IO.Reset (Status_Log, Text_IO.In_File); -- Reset for + -- reading. + exception + when Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset3; + + Day_IO.Get (Status_Log, TC_Reading1.Day); -- Read data from + Hours_IO.Get (Status_Log, TC_Reading1.Hour); -- first record. + Status_IO.Get (Status_Log, TC_Reading1.Status); + Text_IO.Skip_Line (Status_Log); + + -- Verify the data read from the file. Compare with the + -- record that was originally entered into the file. + + if (TC_Reading1 /= Morning_Reading) then + Report.Failed ("Data error on reading first record"); + end if; + + Day_IO.Get (Status_Log, TC_Reading2.Day); -- Read data from + Hours_IO.Get (Status_Log, TC_Reading2.Hour); -- second record. + Status_IO.Get (Status_Log, TC_Reading2.Status); + Text_IO.Skip_Line (Status_Log); + + -- Verify all of the data fields read from the file. Compare + -- with the values that were originally entered into the file. + + if (TC_Reading2.Day /= Evening_Reading.Day) or + (TC_Reading2.Hour /= Evening_Reading.Hour) or + (TC_Reading2.Status /= Evening_Reading.Status) then + Report.Failed ("Data error on reading second record"); + end if; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Error raised during data verification"); + end Test_Verification_Block; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Text_IO.Enumeration_IO processing"); + end Operational_Test_Block; + + Final_Block: + begin + -- Delete the external file. + if Text_IO.Is_Open (Status_Log) then + Text_IO.Delete (Status_Log); + else + Text_IO.Open (Status_Log, Text_IO.Out_File, Status_Log_Filename); + Text_IO.Delete (Status_Log); + end if; + exception + when Text_IO.Use_Error => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Final_Block; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa012.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- CXAA012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exception Mode_Error is raised when an attempt is made + -- to read from (perform a Get_Line) or use the predefined End_Of_File + -- function on a text file with mode Append_File. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential for the + -- incorrect usage of predefined text processing subprograms, resulting + -- from their use with files of the wrong Mode. This results in the + -- raising of Mode_Error exceptions, which is handled within blocks + -- embedded in the test. + -- A count is kept to ensure that each anticipated exception is in fact + -- raised and handled properly. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 27 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA012 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA012" ); + Incomplete : exception; + begin + + Report.Test ("CXAA012", "Check that the exception Mode_Error is " & + "raised when an attempt is made to read " & + "from (perform a Get_Line) or use the " & + "predefined End_Of_File function on a " & + "text file with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- Use_Error or Name_Error will be raised if Text_IO operations + -- or external files are not supported. + + Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); + + exception + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + end Test_for_Text_IO_Support; + + -- The application writes some amount of data to the file. + + Text_IO.Put_Line (Text_File, "Data entered into the file"); + + Text_IO.Close (Text_File); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + + Test_for_Reading: + declare + TC_Data : String (1..80); + TC_Length : Natural := 0; + begin + + -- During the course of its processing, the application may become confused + -- and erroneously attempt to read data from the file that is currently in + -- Append_File mode (instead of the anticipated In_File mode). + -- This would result in the raising of Mode_Error. + + Text_IO.Get_Line (Text_File, TC_Data, TC_Length); + Report.Failed ("Exception not raised by Get_Line"); + + -- An exception handler present within the application handles the exception + -- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed ("Exception in Get_Line processing"); + end Test_for_Reading; + + + Test_for_End_Of_File: + declare + TC_End_Of_File : Boolean; + begin + + -- Again, during the course of its processing, the application attempts to + -- call the End_Of_File function for the file that is currently in + -- Append_File mode (instead of the anticipated In_File mode). + + TC_End_Of_File := Text_IO.End_Of_File (Text_File); + Report.Failed ("Exception not raised by End_Of_File"); + + -- Once again, an exception handler present within the application handles + -- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_File processing"); + end Test_for_End_Of_File; + + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa013.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- CXAA013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exception Mode_Error is raised when an attempt is made + -- to skip a line or page using the predefined Skip_Line and Skip_Page + -- procedures on a text file with mode Append_File. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential for the + -- incorrect usage of predefined text processing subprograms, which + -- results in the raising of a Mode_Error exception. + -- A count is kept to ensure that each anticipated exception is in fact + -- raised and handled properly. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA013 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA013" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA013", "Check that the exception Mode_Error is " & + "raised when an attempt is made to skip " & + "a line or page using the predefined " & + "Skip_Line and Skip_Page procedures on " & + "a text file with mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An application creates a text file with mode Append_File. + -- Use_Error will be raised if Text_IO operations or external files are not + -- supported. + + Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + -- The application writes some amount of data to the file. + + Text_IO.Put_Line (Text_File, "Data entered into the file"); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Test_for_Skip_Line: + declare + TC_Spacing : constant Text_IO.Count := 3; + begin + + -- During the course of its processing, the application may attempt to + -- invoke the Skip_Line procedure on a file that is currently in Append_File + -- mode (instead of the anticipated In_File mode). This results in the + -- raising of Mode_Error. + + Text_IO.Skip_Line (Text_File, TC_Spacing); + Report.Failed ("Exception not raised by Skip_Line"); + + -- An exception handler present within the application handles the exception + -- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in Skip_Line processing"); + end Test_for_Skip_Line; + + Test_for_Skip_Page: + begin + + -- Again, during the course of its processing, the application incorrectly + -- assumes that the file mode is In_File, this time attempting to call the + -- Skip_Page procedure for the file (that is currently in Append_File mode). + + Text_IO.Skip_Page (Text_File); + Report.Failed ("Exception not raised by Skip_Page"); + + -- Once again, an exception handler present within the application handles + -- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in Skip_Page processing"); + end Test_for_Skip_Page; + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa014.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + -- CXAA014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exception Mode_Error is raised when an attempt is made + -- to check for the end of a line or page using the predefined functions + -- End_Of_Line or End_Of_Page on a text file with mode Append_File. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential for the + -- incorrect usage of predefined text processing subprograms, which + -- results in the raising of a Mode_Error exception. + -- A count is kept to ensure that each anticipated exception is in fact + -- raised and handled properly. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA014 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA014" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA014", "Check that the exception Mode_Error is " & + "raised when an attempt is made to check " & + "for the end of a line or page using the " & + "predefined functions End_Of_Line or " & + "End_Of_Page on a text file with mode " & + "Append_File"); + + Test_for_Text_IO_Support: + begin + + -- Use_Error will be raised if Text_IO operations or external files are not + -- supported. + + Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); + + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + + -- The application writes some amount of data to the file. + + for I in 1 .. 10 loop + Text_IO.Put_Line (Text_File, "Data entered into the file"); + end loop; + + Text_IO.Close (Text_File); + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Mode_Errors : constant Natural := 2; + TC_Mode_Errors : Natural := 0; + begin + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + + Test_for_End_Of_Line: + declare + TC_End_Of_Line : Boolean; + begin + + -- During the course of its processing, the application may attempt to + -- invoke the End_Of_Line function on a file that is currently in Append_File + -- mode (instead of the anticipated In_File mode). This results in the + -- raising of Mode_Error. + + TC_End_Of_Line := Text_IO.End_Of_Line (Text_File); + Report.Failed ("Exception not raised by End_Of_Line"); + + -- An exception handler present within the application handles the exception + -- and processing can continue. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_Line processing"); + end Test_for_End_Of_Line; + + + Test_for_End_Of_Page: + declare + TC_End_Of_Page : Boolean; + begin + + -- Again, during the course of its processing, the application incorrectly + -- assumes that the file mode is In_File, this time attempting to call the + -- End_Of_Page function for the file (that is currently in Append_File mode). + + TC_End_Of_Page := Text_IO.End_Of_Page (Text_File); + Report.Failed ("Exception not raised by End_Of_Page"); + + -- Once again, an exception handler present within the application handles + -- the exception and processing continues. + + exception + when Text_IO.Mode_Error => + TC_Mode_Errors := TC_Mode_Errors + 1; + when others => + Report.Failed("Exception in End_Of_Page processing"); + end Test_for_End_Of_Page; + + + if (TC_Mode_Errors /= TC_Number_Of_Forced_Mode_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa015.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,227 ---- + -- CXAA015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exception Status_Error is raised when an attempt is + -- made to create or open a file in Append_File mode when the file is + -- already open. + -- Check that the exception Name_Error is raised by procedure Open when + -- attempting to open a file in Append_File mode when the name supplied + -- as the filename does not correspond to an existing external file. + -- + -- TEST DESCRIPTION: + -- A scenario is created that demonstrates the potential for the + -- inappropriate usage of text processing subprograms Create and Open, + -- resulting in the raising of Status_Error and Name_Error exceptions. + -- A count is kept to ensure that each anticipated exception is in fact + -- raised and handled properly. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support text + -- files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 97 PWB.CTA Allowed for non-support of some IO operations + --! + + with Ada.Text_IO; + with Report; + + procedure CXAA015 is + use Ada; + Text_File : Text_IO.File_Type; + Text_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAA015" ); + Incomplete : exception; + + begin + + Report.Test ("CXAA015", "Check that the appropriate exceptions " & + "are raised when procedures Create and " & + "Open are used to inappropriately operate " & + "on files of mode Append_File"); + + Test_for_Text_IO_Support: + begin + + -- An application creates a text file with mode Append_File. + -- Use_Error will be raised if Text_IO operations or external files are not + -- supported. + + Text_IO.Create (Text_File, Text_IO.Append_File, Text_Filename); + exception + + when Text_IO.Use_Error | Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Append_File for Text_IO" ); + raise Incomplete; + + end Test_for_Text_IO_Support; + + + -- The application writes some amount of data to the file. + + for I in 1 .. 5 loop + Text_IO.Put_Line (Text_File, "Data entered into the file"); + end loop; + + Operational_Test_Block: + declare + TC_Number_Of_Forced_Errors : constant Natural := 3; + TC_Errors : Natural := 0; + begin + + + Test_for_Create: + begin + + -- During the course of its processing, the application may (erroneously) + -- attempt to create the same file already in existence in Append_File mode. + -- This results in the raising of Status_Error. + + Text_IO.Create (Text_File, + Text_IO.Append_File, + Text_Filename); + Report.Failed ("Exception not raised by Create"); + + -- An exception handler present within the application handles the exception + -- and processing can continue. + + exception + when Text_IO.Status_Error => + TC_Errors := TC_Errors + 1; + when others => + Report.Failed("Exception in Create processing"); + end Test_for_Create; + + + First_Test_For_Open: + begin + + -- Again, during the course of its processing, the application incorrectly + -- attempts to Open a file (in Append_File mode) that is already open. + + Text_IO.Open (Text_File, Text_IO.Append_File, Text_Filename); + Report.Failed ("Exception not raised by improper Open - 1"); + + -- Once again, an exception handler present within the application handles + -- the exception and processing continues. + + exception + when Text_IO.Status_Error => + TC_Errors := TC_Errors + 1; + + -- At some point in its processing, the application closes the file that is + -- currently open. + + Text_IO.Close (Text_File); + when others => + Report.Failed("Exception in Open processing - 1"); + end First_Test_For_Open; + + + Open_With_Wrong_Filename: + declare + TC_Wrong_Filename : constant String := + Report.Legal_File_Name(2); + begin + + -- At this point, the application attempts to Open (in Append_File mode) the + -- file used in previous processing, but it attempts this Open using a name + -- string that does not correspond to any existing external file. + -- First make sure the file doesn't exist. (If it did, then the check + -- for open in append mode wouldn't work.) + + Verify_No_File: + begin + Text_IO.Open (Text_File, + Text_IO.In_File, + TC_Wrong_Filename); + exception + when Text_IO.Name_Error => + null; + when others => + Report.Failed ( "Unexpected exception on Open check" ); + end Verify_No_File; + + Delete_No_File: + begin + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed ( "Unexpected exception - Delete check" ); + end Delete_No_File; + + Text_IO.Open (Text_File, + Text_IO.Append_File, + TC_Wrong_Filename); + Report.Failed ("Exception not raised by improper Open - 2"); + + -- An exception handler for the Name_Error, present within the application, + -- catches the exception and processing continues. + + exception + when Text_IO.Name_Error => + TC_Errors := TC_Errors + 1; + when others => + Report.Failed("Exception in Open processing - 2"); + end Open_With_Wrong_Filename; + + + if (TC_Errors /= TC_Number_Of_Forced_Errors) then + Report.Failed ("Incorrect number of exceptions handled"); + end if; + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAA015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa016.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,462 ---- + -- CXAA016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the type File_Access is available in Ada.Text_IO, and that + -- objects of this type designate File_Type objects. + -- Check that function Set_Error will set the current default error file. + -- Check that versions of Ada.Text_IO functions Standard_Input, + -- Standard_Output, Standard_Error return File_Access values designating + -- the standard system input, output, and error files. + -- Check that versions of Ada.Text_IO functions Current_Input, + -- Current_Output, Current_Error return File_Access values designating + -- the current system input, output, and error files. + -- + -- TEST DESCRIPTION: + -- This test tests the use of File_Access objects in referring + -- to File_Type objects, as well as several new functions that return + -- File_Access objects as results. + -- Four user-defined files are created. These files will be set to + -- function as current system input, output, and error files. + -- Data will be read from and written to these files during the + -- time at which they function as the current system files. + -- An array of File_Access objects will be defined. It will be + -- initialized using functions that return File_Access objects + -- referencing the Standard and Current Input, Output, and Error files. + -- This "saves" the initial system environment, which will be modified + -- to use the user-defined files as the current default Input, Output, + -- and Error files. At the end of the test, the data in this array + -- will be used to restore the initial system environment. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to implementations capable of supporting + -- external Text_IO files. + -- + -- + -- CHANGE HISTORY: + -- 25 May 95 SAIC Initial prerelease version. + -- 22 Apr 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. + -- 18 Jan 99 RLB Repaired to allow Not_Applicable systems to + -- fail delete. + --! + + with Ada.Text_IO; + package CXAA016_0 is + New_Input_File, + New_Output_File, + New_Error_File_1, + New_Error_File_2 : aliased Ada.Text_IO.File_Type; + end CXAA016_0; + + + with Report; + with Ada.Exceptions; + with Ada.Text_IO; use Ada.Text_IO; + with CXAA016_0; use CXAA016_0; + + procedure CXAA016 is + + Non_Applicable_System : exception; + No_Reset : exception; + Not_Applicable_System : Boolean := False; + + procedure Delete_File ( A_File : in out Ada.Text_IO.File_Type; + ID_Num : in Integer ) is + begin + if not Ada.Text_IO.Is_Open ( A_File ) then + Ada.Text_IO.Open ( A_File, + Ada.Text_IO.In_File, + Report.Legal_File_Name ( ID_Num ) ); + end if; + Ada.Text_IO.Delete ( A_File ); + exception + when Ada.Text_IO.Name_Error => + if Not_Applicable_System then + null; -- File probably wasn't created. + else + Report.Failed ( "Can't open file for Text_IO" ); + end if; + when Ada.Text_IO.Use_Error => + if Not_Applicable_System then + null; -- File probably wasn't created. + else + Report.Failed ( "Delete not properly implemented for Text_IO" ); + end if; + when others => + Report.Failed ( "Unexpected exception in Delete_File" ); + end Delete_File; + + begin + + Report.Test ("CXAA016", "Check that the type File_Access is available " & + "in Ada.Text_IO, and that objects of this " & + "type designate File_Type objects"); + Test_Block: + declare + + use Ada.Exceptions; + + type System_File_Array_Type is + array (Integer range <>) of File_Access; + + -- Fill the following array with the File_Access results of six + -- functions. + + Initial_Environment : System_File_Array_Type(1..6) := + ( Standard_Input, + Standard_Output, + Standard_Error, + Current_Input, + Current_Output, + Current_Error ); + + New_Input_Ptr : File_Access := New_Input_File'Access; + New_Output_Ptr : File_Access := New_Output_File'Access; + New_Error_Ptr : File_Access := New_Error_File_1'Access; + + Line : String(1..80); + Length : Natural := 0; + + Line_1 : constant String := "This is the first line in the Output file"; + Line_2 : constant String := "This is the next line in the Output file"; + Line_3 : constant String := "This is the first line in Error file 1"; + Line_4 : constant String := "This is the next line in Error file 1"; + Line_5 : constant String := "This is the first line in Error file 2"; + Line_6 : constant String := "This is the next line in Error file 2"; + + + + procedure New_File (The_File : in out File_Type; + Mode : in File_Mode; + Next : in Integer) is + begin + Create (The_File, Mode, Report.Legal_File_Name(Next)); + exception + -- The following two exceptions may be raised if a system is not + -- capable of supporting external Text_IO files. The handler will + -- raise a user-defined exception which will result in a + -- Not_Applicable result for the test. + when Use_Error | Name_Error => raise Non_Applicable_System; + end New_File; + + + + procedure Check_Initial_Environment (Env : System_File_Array_Type) is + begin + -- Check that the system has defined the following sources/ + -- destinations for input/output/error, and that the six functions + -- returning File_Access values are available. + if not (Env(1) = Standard_Input and + Env(2) = Standard_Output and + Env(3) = Standard_Error and + Env(4) = Current_Input and + Env(5) = Current_Output and + Env(6) = Current_Error) + then + Report.Failed("At the start of the test, the Standard and " & + "Current File_Access values associated with " & + "system Input, Output, and Error files do " & + "not correspond"); + end if; + end Check_Initial_Environment; + + + + procedure Load_Input_File (Input_Ptr : in File_Access) is + begin + -- Load data into the file that will function as the user-defined + -- system input file. + Put_Line(Input_Ptr.all, Line_1); + Put_Line(Input_Ptr.all, Line_2); + Put_Line(Input_Ptr.all, Line_3); + Put_Line(Input_Ptr.all, Line_4); + Put_Line(Input_Ptr.all, Line_5); + Put_Line(Input_Ptr.all, Line_6); + end Load_Input_File; + + + + procedure Restore_Initial_Environment + (Initial_Env : System_File_Array_Type) is + begin + -- Restore the Current Input, Output, and Error files to their + -- original states. + + Set_Input (Initial_Env(4).all); + Set_Output(Initial_Env(5).all); + Set_Error (Initial_Env(6).all); + + -- At this point, the user-defined files that were functioning as + -- the Current Input, Output, and Error files have been replaced in + -- that capacity by the state of the original environment. + + declare + + -- Capture the state of the current environment. + + Current_Env : System_File_Array_Type (1..6) := + (Standard_Input, Standard_Output, Standard_Error, + Current_Input, Current_Output, Current_Error); + begin + + -- Compare the current environment with that of the saved + -- initial environment. + + if Current_Env /= Initial_Env then + Report.Failed("Restored file environment was not the same " & + "as the initial file environment"); + end if; + end; + end Restore_Initial_Environment; + + + + procedure Verify_Files (O_File, E_File_1, E_File_2 : in File_Type) is + Str_1, Str_2, Str_3, Str_4, Str_5, Str_6 : String (1..80); + Len_1, Len_2, Len_3, Len_4, Len_5, Len_6 : Natural; + begin + + -- Get the lines that are contained in all the files, and verify + -- them against the expected results. + + Get_Line(O_File, Str_1, Len_1); -- The user defined output file + Get_Line(O_File, Str_2, Len_2); -- should contain two lines of data. + + if Str_1(1..Len_1) /= Line_1 or + Str_2(1..Len_2) /= Line_2 + then + Report.Failed("Incorrect results from Current_Output file"); + end if; + + Get_Line(E_File_1, Str_3, Len_3); -- The first error file received + Get_Line(E_File_1, Str_4, Len_4); -- two lines of data originally, + Get_Line(E_File_1, Str_5, Len_5); -- then had two additional lines + Get_Line(E_File_1, Str_6, Len_6); -- appended from the second error + -- file. + if Str_3(1..Len_3) /= Line_3 or + Str_4(1..Len_4) /= Line_4 or + Str_5(1..Len_5) /= Line_5 or + Str_6(1..Len_6) /= Line_6 + then + Report.Failed("Incorrect results from first Error file"); + end if; + + Get_Line(E_File_2, Str_5, Len_5); -- The second error file + Get_Line(E_File_2, Str_6, Len_6); -- received two lines of data. + + if Str_5(1..Len_5) /= Line_5 or + Str_6(1..Len_6) /= Line_6 + then + Report.Failed("Incorrect results from second Error file"); + end if; + + end Verify_Files; + + + + begin + + Check_Initial_Environment (Initial_Environment); + + -- Create user-defined text files that will be set to serve as current + -- system input, output, and error files. + + New_File (New_Input_File, Out_File, 1); -- Will be reset prior to use. + New_File (New_Output_File, Out_File, 2); + New_File (New_Error_File_1, Out_File, 3); + New_File (New_Error_File_2, Out_File, 4); + + -- Enter several lines of text into the new input file. This file will + -- be reset to mode In_File to function as the current system input file. + -- Note: File_Access value used as parameter to this procedure. + + Load_Input_File (New_Input_Ptr); + + -- Reset the New_Input_File to mode In_File, to allow it to act as the + -- current system input file. + + Reset1: + begin + Reset (New_Input_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 1" ); + raise No_Reset; + end Reset1; + + -- Establish new files that will function as the current system Input, + -- Output, and Error files. + + Set_Input (New_Input_File); + Set_Output(New_Output_Ptr.all); + Set_Error (New_Error_Ptr.all); + + -- Perform various file processing tasks, exercising specific new + -- Text_IO functionality. + -- + -- Read two lines from Current_Input and write them to Current_Output. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Output, Line(1..Length)); + end loop; + + -- Read two lines from Current_Input and write them to Current_Error. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- Reset the Current system error file. + + Set_Error (New_Error_File_2); + + -- Read two lines from Current_Input and write them to Current_Error. + + for i in 1..2 loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- At this point in the processing, the new Output file, and each of + -- the two Error files, contain two lines of data. + -- Note that New_Error_File_1 has been replaced by New_Error_File_2 + -- as the current system error file, allowing New_Error_File_1 to be + -- reset (Mode_Error raised otherwise). + -- + -- Reset the first Error file to Append_File mode, and then set it to + -- function as the current system error file. + + Reset2: + begin + Reset (New_Error_File_1, Append_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Text_IO - 2" ); + raise No_Reset; + end Reset2; + + Set_Error (New_Error_File_1); + + -- Reset the second Error file to In_File mode, then set it to become + -- the current system input file. + + Reset3: + begin + Reset (New_Error_File_2, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 3" ); + raise No_Reset; + end Reset3; + + New_Error_Ptr := New_Error_File_2'Access; + Set_Input (New_Error_Ptr.all); + + -- Append all of the text lines (2) in the new current system input + -- file onto the current system error file. + + while not End_Of_File(Current_Input) loop + Get_Line(Current_Input, Line, Length); + Put_Line(Current_Error, Line(1..Length)); + end loop; + + -- Restore the original system file environment, based upon the values + -- stored at the start of this test. + -- Check that the original environment has been restored. + + Restore_Initial_Environment (Initial_Environment); + + -- Reset all three files to In_File_Mode prior to verification. + -- Note: If these three files had still been the designated Current + -- Input, Output, or Error files for the system, a Reset + -- operation at this point would raise Mode_Error. + -- However, at this point, the environment has been restored to + -- its original state, and these user-defined files are no longer + -- designated as current system files, allowing a Reset. + + Reset4: + begin + Reset(New_Error_File_1, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 4" ); + raise No_Reset; + end Reset4; + + Reset5: + begin + Reset(New_Error_File_2, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 5" ); + raise No_Reset; + end Reset5; + + Reset6: + begin + Reset(New_Output_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO - 6" ); + raise No_Reset; + end Reset6; + + -- Check that all the files contain the appropriate data. + + Verify_Files (New_Output_File, New_Error_File_1, New_Error_File_2); + + exception + when No_Reset => + null; + when Non_Applicable_System => + Report.Not_Applicable("System not capable of supporting external " & + "text files -- Name_Error/Use_Error raised " & + "during text file creation"); + Not_Applicable_System := True; + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Delete_Block: + begin + Delete_File ( New_Input_File, 1 ); + Delete_File ( New_Output_File, 2 ); + Delete_File ( New_Error_File_1, 3 ); + Delete_File ( New_Error_File_2, 4 ); + end Delete_Block; + + Report.Result; + + end CXAA016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa017.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,400 ---- + -- CXAA017.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Text_IO function Look_Ahead sets parameter End_Of_Line + -- to True if at the end of a line; otherwise check that it returns the + -- next character from a file (without consuming it), while setting + -- End_Of_Line to False. + -- + -- Check that Ada.Text_IO function Get_Immediate will return the next + -- control or graphic character in parameter Item from the specified + -- file. Check that the version of Ada.Text_IO function Get_Immediate + -- with the Available parameter will, if a character is available in the + -- specified file, return the character in parameter Item, and set + -- parameter Available to True. + -- + -- TEST DESCRIPTION: + -- This test exercises specific capabilities of two Text_IO subprograms, + -- Look_Ahead and Get_Immediate. A file is prepared that contains a + -- variety of graphic and control characters on several lines. + -- In processing this file, a call to Look_Ahead is performed to ensure + -- that characters are available, then individual characters are + -- extracted from the current line using Get_Immediate. The characters + -- returned from both subprogram calls are compared with the expected + -- character result. Processing on each file line continues until + -- Look_Ahead indicates that the end of the line is next. Separate + -- verification is performed to ensure that all characters of each line + -- are processed, and that the Available and End_Of_Line parameters + -- of the subprograms are properly set in the appropriate instances. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to implementations capable of supporting + -- external Text_IO files. + -- + -- + -- CHANGE HISTORY: + -- 30 May 95 SAIC Initial prerelease version. + -- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. + --! + + with Ada.Text_IO; + package CXAA017_0 is + + User_Defined_Input_File : aliased Ada.Text_IO.File_Type; + + end CXAA017_0; + + + with CXAA017_0; use CXAA017_0; + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Text_IO; + with Report; + + procedure CXAA017 is + + use Ada.Characters.Latin_1; + use Ada.Exceptions; + use Ada.Text_IO; + + Non_Applicable_System : exception; + No_Reset : exception; + + begin + + Report.Test ("CXAA017", "Check that Ada.Text_IO subprograms " & + "Look_Ahead and Get_Immediate are available " & + "and produce correct results"); + + Test_Block: + declare + + User_Input_Ptr : File_Access := User_Defined_Input_File'Access; + + UDLA_Char, -- Acronym UDLA => "User Defined Look Ahead" + UDGI_Char, -- Acronym UDGI => "User Defined Get Immediate" + TC_Char : Character := Ada.Characters.Latin_1.NUL; + + UDLA_End_Of_Line, + UDGI_Available : Boolean := False; + + Char_Pos : Natural; + + -- This string contains five ISO 646 Control characters and six ISO 646 + -- Graphic characters: + TC_String_1 : constant String := STX & + SI & + DC2 & + CAN & + US & + Space & + Ampersand & + Solidus & + 'A' & + LC_X & + DEL; + + -- This string contains two ISO 6429 Control and six ISO 6429 Graphic + -- characters: + TC_String_2 : constant String := IS4 & + SCI & + Yen_Sign & + Masculine_Ordinal_Indicator & + UC_I_Grave & + Multiplication_Sign & + LC_C_Cedilla & + LC_Icelandic_Thorn; + + TC_Number_Of_Strings : constant := 2; + + type String_Access_Type is access constant String; + type String_Ptr_Array_Type is + array (1..TC_Number_Of_Strings) of String_Access_Type; + + TC_String_Ptr_Array : String_Ptr_Array_Type := + (new String'(TC_String_1), + new String'(TC_String_2)); + + + + procedure Create_New_File (The_File : in out File_Type; + Mode : in File_Mode; + Next : in Integer) is + begin + Create (The_File, Mode, Report.Legal_File_Name(Next)); + exception + -- The following two exceptions can be raised if a system is not + -- capable of supporting external Text_IO files. The handler will + -- raise a user-defined exception which will result in a + -- Not_Applicable result for the test. + when Use_Error | Name_Error => raise Non_Applicable_System; + end Create_New_File; + + + + procedure Load_File (The_File : in out File_Type) is + -- This procedure will load several strings into the file denoted + -- by the input parameter. A call to New_Line will add line/page + -- termination characters, which will be available for processing + -- along with the text in the file. + begin + Put_Line (The_File, TC_String_Ptr_Array(1).all); + New_Line (The_File, Spacing => 1); + Put_Line (The_File, TC_String_Ptr_Array(2).all); + end Load_File; + + + begin + + -- Create user-defined text file that will serve as the appropriate + -- sources of input to the procedures under test. + + Create_New_File (User_Defined_Input_File, Out_File, 1); + + -- Enter several lines of text into the new input file. + -- The characters that make up these text strings will be processed + -- using the procedures being exercised in this test. + + Load_File (User_Defined_Input_File); + + -- Check that Mode_Error is raised by Look_Ahead and Get_Immedidate + -- if the mode of the file object is not In_File. + -- Currently, the file mode is Out_File. + + begin + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + Report.Failed("Mode_Error not raised by Look_Ahead"); + Report.Comment("This char should never be printed: " & UDLA_Char); + exception + when Mode_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed ("The following exception was raised during the " & + "check that Look_Ahead raised Mode_Error when " & + "provided a file object that is not in In_File " & + "mode: " & Exception_Name(The_Error)); + end; + + begin + Get_Immediate(User_Defined_Input_File, UDGI_Char); + Report.Failed("Mode_Error not raised by Get_Immediate"); + Report.Comment("This char should never be printed: " & UDGI_Char); + exception + when Mode_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed ("The following exception was raised during the " & + "check that Get_Immediate raised Mode_Error " & + "when provided a file object that is not in " & + "In_File mode: " & Exception_Name(The_Error)); + end; + + + -- The file will then be reset to In_File mode to properly function as + -- a source of input. + + Reset1: + begin + Reset (User_Defined_Input_File, In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise No_Reset; + end Reset1; + + -- Process the input file, exercising various Text_IO + -- functionality, and validating the results at each step. + -- Note: The designated File_Access object is used in processing + -- the New_Default_Input_File in the second loop below. + + -- Process characters in first line of text of each file. + + Char_Pos := 1; + + -- Check that the first line is not blank. + + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + + while not UDLA_End_Of_Line loop + + -- Use the Get_Immediate procedure on the file to get the next + -- available character on the current line. + + Get_Immediate(User_Defined_Input_File, UDGI_Char); + + -- Check that the characters returned by both procedures are the + -- same, and that they match the expected character from the file. + + if UDLA_Char /= TC_String_Ptr_Array(1).all(Char_Pos) or + UDGI_Char /= TC_String_Ptr_Array(1).all(Char_Pos) + then + Report.Failed("Incorrect retrieval of character " & + Integer'Image(Char_Pos) & " of first string"); + end if; + + -- Increment the character position counter. + Char_Pos := Char_Pos + 1; + + -- Check the next character on the line. If at the end of line, + -- the processing flow will exit the While loop. + + Look_Ahead(User_Defined_Input_File, UDLA_Char, UDLA_End_Of_Line); + + end loop; + + -- Check to ensure that the "end of line" results returned from the + -- Look_Ahead procedure (used to exit the above While loop) corresponds + -- with the result of Function End_Of_Line. + + if not End_Of_Line(User_Defined_Input_File) + then + Report.Failed("Result of procedure Look_Ahead that indicated " & + "being at the end of the line does not correspond " & + "with the result of function End_Of_Line"); + end if; + + -- Check that all characters in the string were processed. + + if Char_Pos-1 /= TC_String_1'Length then + Report.Failed("Not all of the characters on the first line " & + "were processed"); + end if; + + + -- Call procedure Skip_Line to advance beyond the end of the first line. + + Skip_Line(User_Defined_Input_File); + + + -- Process the second line in the file (a blank line). + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + if not UDLA_End_Of_Line then + Report.Failed("Incorrect end of line determination from procedure " & + "Look_Ahead when processing a blank line"); + end if; + + -- Call procedure Skip_Line to advance beyond the end of the second line. + + Skip_Line(User_Input_Ptr.all); + + + -- Process characters in the third line of the file (second line + -- of text) + -- Note: The version of Get_Immediate used in processing this line has + -- the Boolean parameter Available. + + Char_Pos := 1; + + -- Check whether the line is blank (i.e., at end of line, page, or file). + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + while not UDLA_End_Of_Line loop + + -- Use the Get_Immediate procedure on the file to get access to the + -- next character on the current line. + + Get_Immediate(User_Input_Ptr.all, UDGI_Char, UDGI_Available); + + -- Check that the Available parameter of Get_Immediate was set + -- to indicate that a character was available in the file. + -- Check that the characters returned by both procedures are the + -- same, and they all match the expected character from the file. + + if not UDGI_Available or + UDLA_Char /= TC_String_Ptr_Array(2).all(Char_Pos) or + UDGI_Char /= TC_String_Ptr_Array(2).all(Char_Pos) + then + Report.Failed("Incorrect retrieval of character " & + Integer'Image(Char_Pos) & " of second string"); + end if; + + -- Increment the character position counter. + + Char_Pos := Char_Pos + 1; + + -- Check the next character on the line. If at the end of line, + -- the processing flow will exit the While loop. + + Look_Ahead(User_Input_Ptr.all, UDLA_Char, UDLA_End_Of_Line); + + end loop; + + -- Check to ensure that the "end of line" results returned from the + -- Look_Ahead procedure (used to exit the above While loop) corresponds + -- with the result of Function End_Of_Line. + + if not End_Of_Line(User_Defined_Input_File) + then + Report.Failed("Result of procedure Look_Ahead that indicated " & + "being at the end of the line does not correspond " & + "with the result of function End_Of_Line"); + end if; + + -- Check that all characters in the second string were processed. + + if Char_Pos-1 /= TC_String_2'Length then + Report.Failed("Not all of the characters on the second line " & + "were processed"); + end if; + + + Deletion: + begin + -- Delete the user defined file. + + if Is_Open(User_Defined_Input_File) then + Delete(User_Defined_Input_File); + else + Open(User_Defined_Input_File, Out_File, Report.Legal_File_Name(1)); + Delete(User_Defined_Input_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + end Deletion; + + + exception + + when No_Reset => + null; + + when Non_Applicable_System => + Report.Not_Applicable("System not capable of supporting external " & + "text files -- Name_Error/Use_Error raised " & + "during text file creation"); + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXAA017; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa018.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,277 ---- + -- CXAA018.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in the package Text_IO.Modular_IO + -- provide correct results. + -- + -- TEST DESCRIPTION: + -- This test checks that the subprograms defined in the + -- Ada.Text_IO.Modular_IO package provide correct results. + -- A modular type is defined and used to instantiate the generic + -- package Ada.Text_IO.Modular_IO. Values of the modular type are + -- written to a Text_IO file, and to a series of string variables, using + -- different versions of the procedure Put from the instantiated IO + -- package. These modular data items are retrieved from the file and + -- string variables using the appropriate instantiated version of + -- procedure Get. A variety of Base and Width parameter values are + -- used in the procedure calls. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support Text_IO + -- processing and external files. + -- + -- + -- CHANGE HISTORY: + -- 03 Jul 95 SAIC Initial prerelease version. + -- 01 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + with Ada.Text_IO; + with System; + with Report; + + procedure CXAA018 is + begin + + Report.Test ("CXAA018", "Check that the subprograms defined in " & + "the package Text_IO.Modular_IO provide " & + "correct results"); + + Test_for_Text_IO_Support: + declare + Data_File : Ada.Text_IO.File_Type; + Data_Filename : constant String := Report.Legal_File_Name; + begin + + -- An application creates a text file in mode Out_File, with the + -- intention of entering modular data into the file as appropriate. + -- In the event that the particular environment where the application + -- is running does not support Text_IO, Use_Error or Name_Error will be + -- raised on calls to Text_IO operations. Either of these exceptions + -- will be handled to produce a Not_Applicable result. + + Ada.Text_IO.Create (File => Data_File, + Mode => Ada.Text_IO.Out_File, + Name => Data_Filename); + + Test_Block: + declare + + type Mod_Type is mod System.Max_Binary_Modulus; + -- Max_Binary_Modulus must be at least 2**16, which would result + -- in a base range of 0..65535 (zero to one less than the given + -- modulus) for this modular type. + + package Mod_IO is new Ada.Text_IO.Modular_IO(Mod_Type); + use Ada.Text_IO, Mod_IO; + use type Mod_Type; + + Number_Of_Modular_Items : constant := 6; + Number_Of_Error_Items : constant := 1; + + TC_Modular : Mod_Type; + TC_Last_Character_Read : Positive; + + Modular_Array : array (1..Number_Of_Modular_Items) of Mod_Type := + ( 0, 97, 255, 1025, 12097, 65535 ); + + + procedure Load_File (The_File : in out Ada.Text_IO.File_Type) is + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- This procedure is designed to load Modular_Type data into a + -- data file. + -- + -- Use the Modular_IO procedure Put to enter modular data items + -- into the data file. + + for i in 1..Number_Of_Modular_Items loop + -- Use default Base parameter of 10. + Mod_IO.Put(File => Data_File, + Item => Modular_Array(i), + Width => 6, + Base => Mod_IO.Default_Base); + end loop; + + -- Enter data into the file such that on the corresponding "Get" + -- of this data, Data_Error must be raised. This value is outside + -- the base range of Modular_Type. + -- Text_IO is used to enter the value in the file. + + for i in 1..Number_Of_Error_Items loop + Ada.Text_IO.Put(The_File, "-10"); + end loop; + + end Load_File; + + + + procedure Process_File(The_File : in out Ada.Text_IO.File_Type) is + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- Use procedure Get (for Files) to extract the modular data from + -- the Text_IO file. + + for i in 1..Number_Of_Modular_Items loop + Mod_IO.Get(The_File, TC_Modular, Width => 6); + + if TC_Modular /= Modular_Array(i) then + Report.Failed("Incorrect modular data read from file " & + "data item #" & Integer'Image(i)); + end if; + end loop; + + -- The final item in the Data_File is a modular value that is + -- outside the base range 0..Num'Last. This value should raise + -- Data_Error on an attempt to "Get" it from the file. + + for i in 1..Number_Of_Error_Items loop + begin + Mod_IO.Get(The_File, TC_Modular, Mod_IO.Default_Width); + Report.Failed + ("Exception Data_Error not raised when Get " & + "was used to read modular data outside base " & + "range of type, item # " & + Integer'Image(i)); + exception + when Ada.Text_IO.Data_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised when Get " & + "was used to read modular data outside " & + "base range of type from Data_File, " & + "data item #" & Integer'Image(i)); + end; + end loop; + + exception + when others => + Report.Failed + ("Unexpected exception raised in Process_File"); + end Process_File; + + + + begin -- Test_Block. + + -- Place modular values into data file. + + Load_File(Data_File); + Ada.Text_IO.Close(Data_File); + + -- Read modular values from data file. + + Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); + Process_File(Data_File); + + -- Verify versions of Modular_IO procedures Put and Get for Strings. + + Modular_IO_in_Strings: + declare + TC_String_Array : array (1..Number_Of_Modular_Items) + of String(1..30) := (others =>(others => ' ')); + begin + + -- Place modular values into strings using the Procedure Put, + -- Use a variety of different "Base" parameter values. + -- Note: This version of Put uses the length of the given + -- string as the value of the "Width" parameter. + + for i in 1..2 loop + Mod_IO.Put(To => TC_String_Array(i), + Item => Modular_Array(i), + Base => Mod_IO.Default_Base); + end loop; + for i in 3..4 loop + Mod_IO.Put(TC_String_Array(i), + Modular_Array(i), + Base => 2); + end loop; + for i in 5..6 loop + Mod_IO.Put(TC_String_Array(i), Modular_Array(i), 16); + end loop; + + -- Get modular values from strings using the Procedure Get. + -- Compare with expected modular values. + + for i in 1..Number_Of_Modular_Items loop + + Mod_IO.Get(From => TC_String_Array(i), + Item => TC_Modular, + Last => TC_Last_Character_Read); + + if TC_Modular /= Modular_Array(i) then + Report.Failed("Incorrect modular data value obtained " & + "from String following use of Procedures " & + "Put and Get from Strings, Modular_Array " & + "item #" & Integer'Image(i)); + end if; + end loop; + + exception + when others => + Report.Failed("Unexpected exception raised during the " & + "evaluation of Put and Get for Strings"); + end Modular_IO_in_Strings; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + -- Delete the external file. + if Ada.Text_IO.Is_Open(Data_File) then + Ada.Text_IO.Delete(Data_File); + else + Ada.Text_IO.Open(Data_File, + Ada.Text_IO.In_File, + Data_Filename); + Ada.Text_IO.Delete(Data_File); + end if; + + exception + + -- Since Use_Error can be raised if, for the specified mode, + -- the environment does not support Text_IO operations, the + -- following handlers are included: + + when Ada.Text_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Text_IO Create"); + + when Ada.Text_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Text_IO Create"); + + when others => + Report.Failed ("Unexpected exception raised on text file Create"); + + end Test_for_Text_IO_Support; + + Report.Result; + + end CXAA018; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaa019.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,138 ---- + -- CXAA019.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Standard_Output can be flushed. Check that 'in' parameters of + -- types Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type can be + -- flushed. (Defect Report 8652/0051). + -- + -- CHANGE HISTORY: + -- 12 FEB 2001 PHL Initial version + -- 16 MAR 2001 RLB Readied for release; fixed Not_Applicable check + -- to terminate test gracefully. + -- + --! + with Ada.Streams.Stream_Io; + use Ada.Streams; + with Ada.Text_Io; + with Ada.Wide_Text_Io; + with Report; + use Report; + procedure CXAA019 is + + procedure Check (File : in Ada.Text_Io.File_Type) is + begin + Ada.Text_Io.Put_Line + (File, " - CXAA019 About to flush a Text_IO file passed " & + "as 'in' parameter"); + Ada.Text_Io.Flush (File); + end Check; + + procedure Check (File : in Ada.Wide_Text_Io.File_Type) is + begin + Ada.Wide_Text_Io.Put_Line + (File, " - CXAA019 About to flush a Wide_Text_IO file passed " & + "as 'in' parameter"); + Ada.Wide_Text_Io.Flush (File); + end Check; + + procedure Check (File : in Stream_Io.File_Type) is + S : Stream_Element_Array (1 .. 10); + begin + for I in S'Range loop + S (I) := Stream_Element (Character'Pos ('A') + I); + end loop; + Stream_Io.Write (File, S); + Comment ("About to flush a Stream_IO file passed as 'in' parameter"); + Stream_Io.Flush (File); + end Check; + + + begin + Test ("CXAA019", + "Check that Standard_Output can be flushed; check that " & + "'in' Ada.Text_IO.File_Type and Ada.Streams.Stream_IO.File_Type" & + "parameters can be flushed"); + + Ada.Text_Io.Put_Line (Ada.Text_Io.Standard_Output, + " - CXAA019 About to flush Standard_Output"); + Ada.Text_Io.Flush (Ada.Text_Io.Standard_Output); + + Check (Ada.Text_Io.Current_Output); + + declare + TC_OK : Boolean := False; + F : Ada.Text_Io.File_Type; + begin + begin + Ada.Text_Io.Create (F, Name => Legal_File_Name (X => 1)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Text_IO file"); + end; + if TC_OK then + Check (F); + Ada.Text_Io.Delete (F); + end if; + end; + + declare + TC_OK : Boolean := False; + F : Ada.Wide_Text_Io.File_Type; + begin + begin + Ada.Wide_Text_Io.Create (F, Name => Legal_File_Name (X => 2)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Wide_Text_IO file"); + end; + if TC_OK then + Check (F); + Ada.Wide_Text_Io.Delete (F); + end if; + end; + + declare + TC_OK : Boolean := False; + F : Stream_Io.File_Type; + begin + begin + Stream_Io.Create (F, Name => Legal_File_Name (X => 3)); + TC_OK := True; + exception + when others => + Not_Applicable ("Unable to create Out mode Stream_IO file"); + end; + if TC_OK then + Check (F); + Stream_Io.Delete (F); + end if; + end; + + Result; + end CXAA019; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxab001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxab001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxab001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxab001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,272 ---- + -- CXAB001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the operations defined in package Wide_Text_IO allow for + -- the input/output of Wide_Character and Wide_String data. + -- + -- TEST DESCRIPTION: + -- This test is designed to exercise the components of the Wide_Text_IO + -- package, including the Put/Get utilities for Wide_Characters and + -- Wide_String objects. + -- The test utilizes the Put and Get procedures defined for + -- Wide_Characters, as well as the Put, Get, Put_Line, and Get_Line + -- procedures defined for Wide_Strings. In addition, many of the + -- additional subprograms found in package Wide_Text_IO are used in this + -- test. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations capable of supporting + -- external Wide_Text_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. + --! + + with Ada.Wide_Text_IO; + with Report; + + procedure CXAB001 is + + Filter_File : Ada.Wide_Text_IO.File_Type; + Filter_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAB001" ); + Incomplete : exception; + + + begin + + Report.Test ("CXAB001", "Check that the operations defined in package " & + "Wide_Text_IO allow for the input/output of " & + "Wide_Character and Wide_String data"); + + + Test_for_Wide_Text_IO_Support: + begin + + -- An implementation that does not support Wide_Text_IO in a particular + -- environment will raise Use_Error on calls to various + -- Wide_Text_IO operations. This block statement encloses a call to + -- Create, which should raise an exception in a non-supportive + -- environment. This exception will be handled to produce a + -- Not_Applicable result. + + Ada.Wide_Text_IO.Create (File => Filter_File, -- Create. + Mode => Ada.Wide_Text_IO.Out_File, + Name => Filter_Filename); + + exception + + when Ada.Wide_Text_IO.Use_Error | Ada.Wide_Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Wide_Text_IO" ); + raise Incomplete; + + end Test_for_Wide_Text_IO_Support; + + Operational_Test_Block: + declare + + First_String : constant Wide_String := "Somewhere "; + Second_String : constant Wide_String := "Over The "; + Third_String : constant Wide_String := "Rainbow"; + Current_Char : Wide_Character := ' '; + + begin + + Enter_Data_In_File: + declare + Pos : Natural := 1; + Bad_Character_Found : Boolean := False; + begin + -- Use the Put procedure defined for Wide_Character data to + -- write all of the wide characters of the First_String into + -- the file individually, followed by a call to New_Line. + + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Put (Filter_File, First_String (Pos)); -- Put. + Pos := Pos + 1; + end loop; + Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. + + -- Reset to In_File mode and read file contents, using the Get + -- procedure defined for Wide_Character data. + Reset1: + begin + Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. + Ada.Wide_Text_IO.In_File); + exception + when Ada.Wide_Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Wide_Text_IO" ); + raise Incomplete; + end Reset1; + + Pos := 1; + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. + -- Verify the wide character against the original string. + if Current_Char /= First_String(Pos) then + Bad_Character_Found := True; + end if; + Pos := Pos + 1; + end loop; + + if Bad_Character_Found then + Report.Failed ("Incorrect Wide_Character read from file - 1"); + end if; + + -- Following user file/string processing, the Wide_String data + -- of the Second_String and Third_String Wide_String objects are + -- appended to the file. + -- The Put procedure defined for Wide_String data is used to + -- transfer the Second_String, followed by a call to New_Line. + -- The Put_Line procedure defined for Wide_String data is used + -- to transfer the Third_String. + Reset2: + begin + Ada.Wide_Text_IO.Reset (Filter_File, -- Reset. + Ada.Wide_Text_IO.Append_File); + + exception + when Ada.Wide_Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Wide_Text_IO" ); + raise Incomplete; + end Reset2; + + Ada.Wide_Text_IO.Put (Filter_File, Second_String); -- Put. + Ada.Wide_Text_IO.New_Line (Filter_File); -- New_Line. + + Ada.Wide_Text_IO.Put_Line (Filter_File, Third_String); -- Put_Line. + Ada.Wide_Text_IO.Close (Filter_File); -- Close. + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception in Enter_Data_In_File block"); + raise; + + end Enter_Data_In_File; + + --- + + Filter_Block: + declare + + Pos : Positive := 1; + TC_String2 : Wide_String (1..Second_String'Length); + TC_String3 : Wide_String (1..Third_String'Length); + Last : Natural := Natural'First; + + begin + + Ada.Wide_Text_IO.Open (Filter_File, -- Open. + Ada.Wide_Text_IO.In_File, + Filter_Filename); + + + -- Read the data of the First_String from the file, using the + -- Get procedure defined for Wide_Character data. + -- Verify that the character corresponds to the data originally + -- written to the file. + + while Pos <= First_String'Length loop + Ada.Wide_Text_IO.Get (Filter_File, Current_Char); -- Get. + if Current_Char /= First_String(Pos) then + Report.Failed + ("Incorrect Wide_Character read from file - 2"); + end if; + Pos := Pos + 1; + end loop; + + -- The first line of the file has been read, move to the second. + Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. + + -- Read the Wide_String data from the second and third lines of + -- the file. + Ada.Wide_Text_IO.Get (Filter_File, TC_String2); -- Get. + Ada.Wide_Text_IO.Skip_Line (Filter_File); -- Skip_Line. + Ada.Wide_Text_IO.Get_Line (Filter_File, -- Get_Line. + TC_String3, Last); + + -- Verify data of second and third strings. + if TC_String2 /= Second_String then + Report.Failed ("Incorrect Wide_String read from file - 1"); + end if; + if TC_String3 /= Third_String then + Report.Failed ("Incorrect Wide_String read from file - 2"); + end if; + + -- The file should now be at EOF. + if not Ada.Wide_Text_IO.End_Of_File (Filter_File) then -- EOF. + Report.Failed ("File not empty following filtering"); + end if; + + exception + when others => + Report.Failed ("Exception in Filter_Block"); + raise; + end Filter_Block; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Wide_Text_IO.Is_Open (Filter_File) then -- Is_Open. + Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. + else + Ada.Wide_Text_IO.Open (Filter_File, -- Open. + Ada.Wide_Text_IO.Out_File, + Filter_Filename); + Ada.Wide_Text_IO.Delete (Filter_File); -- Delete. + end if; + exception + when others => + Report.Failed ("Delete not properly implemented for Wide_Text_IO"); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAB001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,292 ---- + -- CXAC001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the attribute T'Write will, for any specific non-limited + -- type T, write an item of the subtype to the stream. + -- + -- Check that the attribute T'Read will, for a specific non-limited + -- type T, read a value of the subtype from the stream. + -- + -- TEST DESCRIPTION: + -- The scenario depicted in this test is that of an environment where + -- product data is stored in stream form, then reconstructed into the + -- appropriate data structures. Several records of product information + -- are stored in an array; the array is passed as a parameter to a + -- procedure for storage in the stream. A header is created based on the + -- number of data records stored in the array. The header is then written + -- to the stream, followed by each record maintained in the array. + -- In order to retrieve data from the stream, the header information is + -- read from the stream, and the data stored in the header is used to + -- perform the appropriate number of read operations of record data from + -- the stream. All data read from the stream is validated against the + --- values that were written to the stream. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all systems capable of supporting IO operations on + -- external Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 08 Nov 95 SAIC Corrected call to Read in Procedure Retrieve_Data + -- for ACVC 2.0.1. + -- 27 Feb 08 PWB.CTA Allowed for non-support of certain IO operations. + --! + + with Ada.Streams.Stream_IO; + with Report; + + procedure CXAC001 is + + package Strm_Pack renames Ada.Streams.Stream_IO; + The_File : Strm_Pack.File_Type; + The_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC001" ); + Incomplete : exception; + + + begin + + Report.Test ("CXAC001", "Check that the 'Read and 'Write attributes " & + "will transfer an object of a specific, " & + "non-limited type to/from a stream"); + + Test_for_Stream_IO_Support: + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Strm_Pack.Create (The_File, Strm_Pack.Out_File, The_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | + Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + The_Stream : Strm_Pack.Stream_Access; + Todays_Date : String (1 .. 6) := "271193"; + + type ID_Type is range 1 .. 100; + type Size_Type is (Small, Medium, Large, XLarge); + + type Header_Type is record + Number_of_Elements : Natural := 0; + Origination_Date : String (1 .. 6); + end record; + + type Data_Type is record + ID : ID_Type; + Size : Size_Type; + end record; + + type Data_Array_Type is array (Positive range <>) of Data_Type; + + Product_Information_1 : Data_Array_Type (1 .. 3) := ((20, Large), + (55, Small), + (89, XLarge)); + + Product_Information_2 : Data_Array_Type (1 .. 4) := (( 5, XLarge), + (27, Small), + (79, Medium), + (93, XLarge)); + + procedure Store_Data ( The_Stream : in Strm_Pack.Stream_Access; + The_Array : in Data_Array_Type ) is + Header : Header_Type; + begin + + -- Fill in header info. + Header.Number_of_Elements := The_Array'Length; + Header.Origination_Date := Todays_Date; + + -- Write header to stream. + Header_Type'Write (The_Stream, Header); + + -- Write each record in the array to the stream. + for I in 1 .. Header.Number_of_Elements loop + Data_Type'Write (The_Stream, The_Array (I)); + end loop; + + end Store_Data; + + procedure Retrieve_Data (The_Stream : in Strm_Pack.Stream_Access; + The_Header : out Header_Type; + The_Array : out Data_Array_Type ) is + begin + + -- Read header from the stream. + Header_Type'Read (The_Stream, The_Header); + + -- Read the records from the stream into the array. + for I in 1 .. The_Header.Number_of_Elements loop + Data_Type'Read (The_Stream, The_Array (I)); + end loop; + + end Retrieve_Data; + + begin + + -- Assign access value. + The_Stream := Strm_Pack.Stream (The_File); + + -- Product information is to be stored in the stream file. These + -- data arrays are of different sizes (actually, the records + -- are stored individually, not as a single array). Prior to the + -- record data being written, a header record is initialized with + -- information about the data to be written, then itself is written + -- to the stream. + + Store_Data (The_Stream, Product_Information_1); + Store_Data (The_Stream, Product_Information_2); + + Test_Verification_Block: + declare + Product_Header_1 : Header_Type; + Product_Header_2 : Header_Type; + Product_Array_1 : Data_Array_Type (1 .. 3); + Product_Array_2 : Data_Array_Type (1 .. 4); + begin + + Reset1: + begin + Strm_Pack.Reset (The_File, Strm_Pack.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset1; + + -- Data is read from the stream, first the appropriate header, + -- then the associated data records, which are then reconstructed + -- into a data array of product information. + + Retrieve_Data (The_Stream, Product_Header_1, Product_Array_1); + + -- Validate a field in the header. + if (Product_Header_1.Origination_Date /= Todays_Date) or + (Product_Header_1.Number_of_Elements /= 3) + then + Report.Failed ("Incorrect Header_1 info read from stream"); + end if; + + -- Validate the data records read from the file. + for I in 1 .. Product_Header_1.Number_of_Elements loop + if (Product_Array_1(I) /= Product_Information_1(I)) then + Report.Failed ("Incorrect Product 1 info read from" & + " record: " & Integer'Image (I)); + end if; + end loop; + + -- Repeat this read and verify operation for the next parcel of + -- data. Again, header and data record information are read from + -- the same stream file. + Retrieve_Data (The_Stream, Product_Header_2, Product_Array_2); + + if (Product_Header_2.Origination_Date /= Todays_Date) or + (Product_Header_2.Number_of_Elements /= 4) + then + Report.Failed ("Incorrect Header_2 info read from stream"); + end if; + + for I in 1 .. Product_Header_2.Number_of_Elements loop + if (Product_Array_2(I) /= Product_Information_2(I)) then + Report.Failed ("Incorrect Product_2 info read from" & + " record: " & Integer'Image (I)); + end if; + end loop; + + exception + + when Incomplete => + raise; + + when Strm_Pack.End_Error => -- If correct number of + -- items not in file (data + -- overwritten), then fail. + Report.Failed ("Incorrect number of record elements in file"); + if not Strm_Pack.Is_Open (The_File) then + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + end if; + + when others => + Report.Failed ("Exception raised in Data Verification Block"); + if not Strm_Pack.Is_Open (The_File) then + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + end if; + + end Test_Verification_Block; + + exception + + when Incomplete => + raise; + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + -- Delete the file. + if Strm_Pack.Is_Open (The_File) then + Strm_Pack.Delete (The_File); + else + Strm_Pack.Open (The_File, Strm_Pack.Out_File, The_Filename); + Strm_Pack.Delete (The_File); + end if; + + exception + + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAC001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,426 ---- + -- CXAC002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in package Ada.Streams.Stream_IO + -- are accessible, and that they provide the appropriate functionality. + -- + -- TEST DESCRIPTION: + -- This test simulates a user filter designed to capitalize the + -- characters of a string. It utilizes a variety of the subprograms + -- contained in the package Ada.Streams.Stream_IO. + -- Its purpose is to demonstrate the use of a variety of the capabilities + -- found in the Ada.Streams.Stream_IO package. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations capable of supporting + -- external Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Nov 95 SAIC Corrected visibility problems; corrected + -- subtest validating result from function Name + -- for ACVC 2.0.1. + -- 05 Oct 96 SAIC Removed calls to Close/Open in test and replaced + -- them with a single call to Reset (per AI95-0001) + -- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations. + -- 09 Feb 01 RLB Corrected non-support check to avoid unintended + -- failures. + --! + + package CXAC002_0 is + + -- This function searches for the first instance of a specified substring + -- within a specified string, returning boolean result. (Case insensitive + -- analysis) + + function Find (Str : in String; Sub : in String) return Boolean; + + end CXAC002_0; + + package body CXAC002_0 is + + function Find (Str : in String; Sub : in String) return Boolean is + + New_Str : String(Str'First..Str'Last); + New_Sub : String(Sub'First..Sub'Last); + Pos : Integer := Str'First; -- Character index. + + function Upper_Case (Str : in String) return String is + subtype Upper is Character range 'A'..'Z'; + subtype Lower is Character range 'a'..'z'; + Ret : String(Str'First..Str'Last); + Pos : Integer; + begin + for I in Str'Range loop + if (Str(I) in Lower) then + Pos := Upper'Pos(Upper'First) + + (Lower'Pos(Str(I)) - Lower'Pos(Lower'First)); + Ret(I) := Upper'Val(Pos); + else + Ret(I) := Str (I); + end if; + end loop; + return Ret; + end Upper_Case; + + begin + + New_Str := Upper_Case(Str); -- Convert Str and Sub to upper + New_Sub := Upper_Case(Sub); -- case for comparison. + + while (Pos <= New_Str'Last-New_Sub'Length+1) -- Search until no more + and then -- sub-string-length + (New_Str(Pos..Pos+New_Sub'Length-1) /= New_Sub) -- slices remain. + loop + Pos := Pos + 1; + end loop; + + if (Pos > New_Str'Last-New_Sub'Length+1) then -- Substring not found. + return False; + else + return True; + end if; + + end Find; + + end CXAC002_0; + + + with Ada.Streams.Stream_IO, CXAC002_0, Report; + procedure CXAC002 is + Filter_File : Ada.Streams.Stream_IO.File_Type; + Filter_Stream : Ada.Streams.Stream_IO.Stream_Access; + Filter_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC002" ); + Incomplete : Exception; + + begin + + Report.Test ("CXAC002", "Check that the subprograms defined in " & + "package Ada.Streams.Stream_IO are accessible, " & + "and that they provide the appropriate " & + "functionality"); + + Test_for_Stream_IO_Support: + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Filter_File, -- Create. + Ada.Streams.Stream_IO.Out_File, + Filter_Filename); + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + use CXAC002_0; + use type Ada.Streams.Stream_IO.File_Mode; + use type Ada.Streams.Stream_IO.Count; + + File_Size : Ada.Streams.Stream_IO.Count := -- Count. + Ada.Streams.Stream_IO.Count'First; -- (0) + File_Index : Ada.Streams.Stream_IO.Positive_Count := -- Pos. Count. + Ada.Streams.Stream_IO.Positive_Count'First; -- (1) + + First_String : constant String := "this is going to be "; + Second_String : constant String := "the best year of your life"; + Total_Length : constant Natural := First_String'Length + + Second_String'Length; + Current_Char : Character := ' '; + + Cap_String : String (1..Total_Length) := (others => ' '); + + TC_Capital_String : constant String := + "THIS IS GOING TO BE THE BEST YEAR OF YOUR LIFE"; + + begin + + if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open + Report.Failed ("File not open following Create"); + end if; + + -- Call function Find to determine if the filename (Sub) is contained + -- in the result of Function Name. + + if not Find(Str => Ada.Streams.Stream_IO.Name(Filter_File), -- Name. + Sub => Filter_Filename) + then + Report.Failed ("Function Name provided incorrect filename"); + end if; + -- Stream. + Filter_Stream := Ada.Streams.Stream_IO.Stream (Filter_File); + + --- + + Enter_Data_In_Stream: + declare + Pos : Natural := 1; + Bad_Character_Found : Boolean := False; + begin + + -- Enter data from the first string into the stream. + while Pos <= Natural(First_String'Length) loop + -- Write all characters of the First_String to the stream. + Character'Write (Filter_Stream, First_String (Pos)); + Pos := Pos + 1; + -- Ensure data put in file on a regular basis. + if Pos mod 5 = 0 then + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + end if; + end loop; + + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + -- Reset to In_File mode and read stream contents. + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset1; + + Pos := 1; + while Pos <= First_String'Length loop + -- Read one character from the stream. + Character'Read (Filter_Stream, Current_Char); -- 'Read + -- Verify character against the original string. + if Current_Char /= First_String(Pos) then + Bad_Character_Found := True; + end if; + Pos := Pos + 1; + end loop; + + if Bad_Character_Found then + Report.Failed ("Incorrect character read from stream"); + end if; + + -- Following user stream/string processing, the stream file is + -- appended to as follows: + + Reset2: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported for Stream_IO" ); + raise Incomplete; + end Reset2; + + if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. + Ada.Streams.Stream_IO.Append_File + then + Report.Failed ("Incorrect mode following Reset to Append"); + end if; + + Pos := 1; + while Pos <= Natural(Second_String'Length) loop + -- Write all characters of the Second_String to the stream. + Character'Write (Filter_Stream, Second_String (Pos)); -- 'Write + Pos := Pos + 1; + end loop; + + Ada.Streams.Stream_IO.Flush (Filter_File); -- Flush. + + -- Record file statistics. + File_Size := Ada.Streams.Stream_IO.Size (Filter_File); -- Size. + + Index_Might_Not_Be_Supported: + begin + File_Index := Ada.Streams.Stream_IO.Index (Filter_File); -- Index. + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ( "Index not supported for Stream_IO" ); + raise Incomplete; + end Index_Might_Not_Be_Supported; + + exception + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Enter_Data_In_Stream block"); + raise; + end Enter_Data_In_Stream; + + --- + + Filter_Block: + declare + Pos : Positive := 1; + Full_String : constant String := First_String & Second_String; + + function Capitalize (Char : Character) return Character is + begin + if Char /= ' ' then + return Character'Val( Character'Pos(Char) - + (Character'Pos('a') - Character'Pos('A'))); + else + return Char; + end if; + end Capitalize; + + begin + + Reset3: + begin + Ada.Streams.Stream_IO.Reset (Filter_File, -- Reset. + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO" ); + raise Incomplete; + end Reset3; + + if Ada.Streams.Stream_IO.Mode (Filter_File) /= -- Mode. + Ada.Streams.Stream_IO.In_File + then + Report.Failed ("Incorrect mode following Reset to In_File"); + end if; + + if not Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open + Report.Failed ( "Reset command did not leave file open" ); + end if; + + if Ada.Streams.Stream_IO.Size (Filter_File) /= -- Size. + File_Size + then + Report.Failed ("Reset file is not correct size"); + end if; + + if Ada.Streams.Stream_IO.Index (Filter_File) /= 1 then -- Index. + -- File position should have been reset to start of file. + Report.Failed ("Index of file not set to 1 following Reset"); + end if; + + while Pos <= Full_String'Length loop + -- Read one character from the stream. + Character'Read (Filter_Stream, Current_Char); -- 'Read + -- Verify character against the original string. + if Current_Char /= Full_String(Pos) then + Report.Failed ("Incorrect character read from stream"); + else + -- Capitalize the characters read from the stream, and + -- place them in a string variable. + Cap_String(Pos) := Capitalize (Current_Char); + end if; + Pos := Pos + 1; + end loop; + + -- File index should now be set to the position following the final + -- character in the file (the same as the index value stored at + -- the completion of the Enter_Data_In_Stream block). + if Ada.Streams.Stream_IO.Index (Filter_File) /= -- Index. + File_Index + then + Report.Failed ("Incorrect file index position"); + end if; + + -- The stream file should now be at EOF. -- EOF. + if not Ada.Streams.Stream_IO.End_Of_File (Filter_File) then + Report.Failed ("File not empty following filtering"); + end if; + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception in Filter_Block"); + raise; + end Filter_Block; + + --- + + Verification_Block: + begin + + -- Verify that the entire string was examined, and that the + -- process of capitalizing the character data was successful. + if Cap_String /= TC_Capital_String then + Report.Failed ("Incorrect Capitalization"); + end if; + + exception + when others => + Report.Failed ("Exception in Verification_Block"); + end Verification_Block; + + + exception + + when Incomplete => + raise; + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Filter_File) then -- Is_Open. + Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. + else + Ada.Streams.Stream_IO.Open (Filter_File, -- Open. + Ada.Streams.Stream_IO.Out_File, + Filter_Filename); + Ada.Streams.Stream_IO.Delete (Filter_File); -- Delete. + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAC002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,376 ---- + -- CXAC003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the correct exceptions are raised when improperly + -- manipulating stream file objects. + -- + -- TEST DESCRIPTION: + -- This test is designed to focus on Stream_IO file manipulation + -- exceptions. Several potentially common user errors are examined in + -- the test: + -- + -- A Status_Error should be raised whenever an attempt is made to perform + -- an operation on a file that is closed. + -- + -- A Status_Error should be raised when an attempt is made to open a + -- stream file that is currently open. + -- + -- A Mode_Error should be raised when attempting to read from (use the + -- 'Read attribute) on an Out_File or Append_Mode file. + -- + -- A Mode_Error should be raised when checking for End Of File on a + -- file with mode Out_File or Append_Mode. + -- + -- A Mode_Error should be raised when attempting to write to (use the + -- 'Output attribute) on a file with mode In_File. + -- + -- A Name_Error should be raised when the string provided to the Name + -- parameter of an Open operation does not allow association of an + -- external file. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations capable of supporting + -- external Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 25 Feb 97 PWB.CTA Allowed for non-support of some IO operations + -- 02 Mar 01 PHL Check that Ada.Streams.Stream_IO.Stream raises + -- Status_Error if the file is not open. (DR 8652/ + -- 0056). + -- 15 Mar 01 RLB Readied for release. + --! + + with Ada.Streams.Stream_IO; + with Report; + + procedure CXAC003 is + + Stream_File_Object : Ada.Streams.Stream_IO.File_Type; + Stream_Access_Value : Ada.Streams.Stream_IO.Stream_Access; + Stream_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC003" ); + Incomplete : exception; + + begin + + Report.Test ("CXAC003", "Check that the correct exceptions are " & + "raised when improperly manipulating stream " & + "file objects"); + + Test_for_Stream_IO_Support: + begin + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File, + Stream_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + begin + -- A potentially common error in a file processing environment + -- is to attempt to perform an operation on a stream file that is + -- not currently open. Status_Error should be raised in this case. + Check_Status_Error: + begin + Ada.Streams.Stream_IO.Close (Stream_File_Object); + -- Attempt to reset a file that is closed. + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + Report.Failed ("Exception not raised on Reset of closed file"); + exception + when Ada.Streams.Stream_IO.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 1"); + end Check_Status_Error; + + -- A similar error is to use Ada.Streams.Stream_IO.Stream + -- to attempt to perform an operation on a stream file that is + -- not currently open. Status_Error should be raised in this case. + -- (Defect Report 8652/0046, as reflected in Technical Corrigendum 1.) + Check_Status_Error2: + begin + -- Ensure that the file is not open. + if Ada.Streams.Stream_Io.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_Io.Close (Stream_File_Object); + end if; + Stream_Access_Value := + Ada.Streams.Stream_Io.Stream (Stream_File_Object); + Report.Failed ("Exception not raised on Stream of closed file"); + exception + when Ada.Streams.Stream_Io.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 2"); + end Check_Status_Error2; + + -- Another potentially common error in a file processing environment + -- is to attempt to Open a stream file that is currently open. + -- Status_Error should be raised in this case. + Check_Status_Error3: + begin + -- Ensure that the file is open. + if not Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.In_File, + Stream_Filename); + end if; + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.In_File, + Stream_Filename); + Report.Failed ("Exception not raised on Open of open file"); + exception + when Ada.Streams.Stream_IO.Status_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 3"); + end Check_Status_Error3; + + -- Another example of a potential error occurring in a file + -- processing environment is to attempt to use the 'Read attribute + -- on a stream file that is currently in Out_File or Append_File + -- mode. Mode_Error should be raised in both of these cases. + Check_Mode_Error: + declare + Int_Var : Integer := -10; + begin + + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Out_File not supported for Stream_IO - 1" ); + raise Incomplete; + end Reset1; + + Stream_Access_Value := + Ada.Streams.Stream_IO.Stream (Stream_File_Object); + Integer'Write (Stream_Access_Value, Int_Var); + + -- File contains an integer value, but is of mode Out_File. + Integer'Read (Stream_Access_Value, Int_Var); + Report.Failed ("Exception not raised by 'Read of Out_File"); + exception + when Incomplete => + raise; + when Ada.Streams.Stream_IO.Mode_Error => + null; + Try_Read: + begin + Reset2: + begin + Ada.Streams.Stream_IO.Reset + (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported " & + "for Stream_IO - 2" ); + raise Incomplete; + end Reset2; + + Integer'Write (Stream_Access_Value, Int_Var); + -- Attempt read from Append_File mode file. + Integer'Read (Stream_Access_Value, Int_Var); + Report.Failed + ("Exception not raised by 'Read of Append file"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 4b"); + end Try_Read; + + when others => Report.Failed ("Incorrect exception raised - 4a"); + end Check_Mode_Error; + + -- Another example of a this type of potential error is to attempt + -- to check for End Of File on a stream file that is currently in + -- Out_File or Append_File mode. Mode_Error should also be raised + -- in both of these cases. + Check_End_File: + declare + Test_Boolean : Boolean := False; + begin + Reset3: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Out_File not supported for Stream_IO - 3" ); + raise Incomplete; + end Reset3; + + Test_Boolean := + Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); + Report.Failed ("Exception not raised by EOF on Out_File"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + EOF_For_Append_File: + begin + Reset4: + begin + Ada.Streams.Stream_IO.Reset + (Stream_File_Object, Ada.Streams.Stream_IO.Append_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to Append_File not supported " & + "for Stream_IO - 4" ); + raise Incomplete; + end Reset4; + + Test_Boolean := + Ada.Streams.Stream_IO.End_Of_File (Stream_File_Object); + Report.Failed + ("Exception not raised by EOF of Append file"); + exception + when Incomplete => + raise; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 5b"); + end EOF_For_Append_File; + + when others => Report.Failed ("Incorrect exception raised - 5a"); + end Check_End_File; + + + + -- In a similar situation to the above cases for attribute 'Read, + -- an attempt to use the 'Output attribute on a stream file that + -- is currently in In_File mode should result in Mode_Error being + -- raised. + Check_Output_Mode_Error: + begin + Reset5: + begin + Ada.Streams.Stream_IO.Reset (Stream_File_Object, + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO - 6" ); + raise Incomplete; + end Reset5; + + Stream_Access_Value := + Ada.Streams.Stream_IO.Stream (Stream_File_Object); + String'Output (Stream_Access_Value, "User-Oriented String"); + Report.Failed ("Exception not raised by 'Output to In_File"); + exception + when Incomplete => + null; + when Ada.Streams.Stream_IO.Mode_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 6"); + end Check_Output_Mode_Error; + + -- Any case of attempting to Open a stream file with a string for + -- the parameter Name that does not allow the identification of an + -- external file will result in the exception Name_Error being + -- raised. + Check_Illegal_File_Name: + begin + if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Close (Stream_File_Object); + end if; + -- No external file exists with this filename, allowing no + -- association with an internal file object, resulting in the + -- raising of the exception Name_Error. + Ada.Streams.Stream_IO.Open(File => Stream_File_Object, + Mode => Ada.Streams.Stream_IO.Out_File, + Name => Report.Legal_File_Name(2)); + Report.Failed ("Exception not raised by bad filename on Open"); + exception + when Ada.Streams.Stream_IO.Name_Error => + null; + when others => + Report.Failed ("Incorrect exception raised - 7"); + end Check_Illegal_File_Name; + + exception + when Incomplete => + null; + when others => + Report.Failed ("Unexpected exception in Operational Test Block"); + + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Stream_File_Object) then + Ada.Streams.Stream_IO.Delete (Stream_File_Object); + else + Ada.Streams.Stream_IO.Open (Stream_File_Object, + Ada.Streams.Stream_IO.Out_File, + Stream_Filename); + Ada.Streams.Stream_IO.Delete (Stream_File_Object); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAC003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac004.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,310 ---- + -- CXAC004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Stream_Access type and Stream function found in package + -- Ada.Text_IO.Text_Streams allows a text file to be processed with the + -- functionality of streams. + -- + -- TEST DESCRIPTION: + -- This test verifies that the package Ada.Text_IO.Text_Streams is + -- available and that the functionality it contains allows a text file to + -- be manipulated as a stream. + -- The test defines data objects of a variety of types that can be stored + -- in a text file. A text file and associated text stream are then + -- defined, and the 'Write attribute is used to enter the individual data + -- items into the text stream. Once all the individual data items have + -- been written to the stream, the 'Output attribute is used to write + -- arrays of these same data objects to the stream. + -- The text file is reset to serve as an input file, and the 'Read + -- attribute is used to extract the individual data items from the + -- stream. These items are then verified against the data originally + -- written to the stream. Finally, the 'Input attribute is used to + -- extract the data arrays from the stream. These arrays are then + -- verified against the original data written to the stream. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to implementations that support external text files. + -- + -- CHANGE HISTORY: + -- 06 Jul 95 SAIC Initial prerelease version. + -- 26 Feb 97 PWB.CTA Allowed for non-support of some IO operations; + -- removed requirement for support of decimal types. + --! + + with Report; + with Ada.Text_IO; + with Ada.Text_IO.Text_Streams; + with Ada.Characters.Latin_1; + with Ada.Strings.Unbounded; + + procedure CXAC004 is + + Data_File : Ada.Text_IO.File_Type; + Data_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXAC004" ); + Incomplete : exception; + + begin + + Report.Test ("CXAC004", "Check that the Stream_Access type and Stream " & + "function found in package " & + "Ada.Text_IO.Text_Streams allows a text file to " & + "be processed with the functionality of streams"); + + Test_for_IO_Support: + begin + + -- Check for Text_IO support in creating the data file. If the + -- implementation does not support external files, Name_Error or + -- Use_Error will be raised at the point of the following call to + -- Create, resulting in a Not_Applicable test result. + + Ada.Text_IO.Create(Data_File, Ada.Text_IO.Out_File, Data_Filename); + + exception + + when Ada.Text_IO.Use_Error | Ada.Text_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Text_IO" ); + raise Incomplete; + + end Test_for_IO_Support; + + Test_Block: + declare + use Ada.Characters.Latin_1, Ada.Strings.Unbounded; + TC_Items : constant := 3; + + -- Declare types and objects that will be used as data values to be + -- written to and read from the text file/stream. + + type Enum_Type is (Red, Yellow, Green, Blue, Indigo); + type Fixed_Type is delta 0.125 range 0.0..255.0; + type Float_Type is digits 7 range 0.0..1.0E5; + type Modular_Type is mod 256; + subtype Str_Type is String(1..4); + + type Char_Array_Type is array (1..TC_Items) of Character; + type Enum_Array_Type is array (1..TC_Items) of Enum_Type; + type Fixed_Array_Type is array (1..TC_Items) of Fixed_Type; + type Float_Array_Type is array (1..TC_Items) of Float_Type; + type Int_Array_Type is array (1..TC_Items) of Integer; + type Mod_Array_Type is array (1..TC_Items) of Modular_Type; + type Str_Array_Type is array (1..TC_Items) of Str_Type; + type Unb_Str_Array_Type is array (1..TC_Items) of Unbounded_String; + + Char_Array : Char_Array_Type := ('A', 'z', Yen_Sign); + TC_Char_Array_1, + TC_Char_Array_2 : Char_Array_Type := (others => Space); + + Enum_Array : Enum_Array_Type := (Blue, Yellow, Indigo); + TC_Enum_Array_1, + TC_Enum_Array_2 : Enum_Array_Type := (others => Red); + + Fix_Array : Fixed_Array_Type := (0.125, 123.5, 250.750); + TC_Fix_Array_1, + TC_Fix_Array_2 : Fixed_Array_Type := (others => 0.0); + + Flt_Array : Float_Array_Type := (1.0, 150.0, 1500.0); + TC_Flt_Array_1, + TC_Flt_Array_2 : Float_Array_Type := (others => 0.0); + + Int_Array : Int_Array_Type := (124, 2349, -24_001); + TC_Int_Array_1, + TC_Int_Array_2 : Int_Array_Type := (others => -99); + + Mod_Array : Mod_Array_Type := (10, 127, 255); + TC_Mod_Array_1, + TC_Mod_Array_2 : Mod_Array_Type := (others => 0); + + Str_Array : Str_Array_Type := ("abcd", "klmn", "wxyz"); + TC_Str_Array_1, + TC_Str_Array_2 : Str_Array_Type := (others => " "); + + UStr_Array : Unb_Str_Array_Type := + (To_Unbounded_String("cat"), + To_Unbounded_String("testing"), + To_Unbounded_String("ACVC")); + TC_UStr_Array_1, + TC_UStr_Array_2 : Unb_Str_Array_Type := + (others => Null_Unbounded_String); + + -- Create a stream access object pointing to the data file. + + Data_Stream : Ada.Text_IO.Text_Streams.Stream_Access := + Ada.Text_IO.Text_Streams.Stream(File => Data_File); + + begin + + -- Use the 'Write attribute to enter the three sets of data items + -- into the data stream. + -- Note that the data will be mixed within the text file. + + for i in 1..TC_Items loop + Character'Write (Data_Stream, Char_Array(i)); + Enum_Type'Write (Data_Stream, Enum_Array(i)); + Fixed_Type'Write (Data_Stream, Fix_Array(i)); + Float_Type'Write (Data_Stream, Flt_Array(i)); + Integer'Write (Data_Stream, Int_Array(i)); + Modular_Type'Write (Data_Stream, Mod_Array(i)); + Str_Type'Write (Data_Stream, Str_Array(i)); + Unbounded_String'Write(Data_Stream, UStr_Array(i)); + end loop; + + -- Use the 'Output attribute to enter the entire arrays of each + -- type of data items into the data stream. + -- Note that the array bounds will be written to the stream as part + -- of the action of the 'Output attribute. + + Char_Array_Type'Output (Data_Stream, Char_Array); + Enum_Array_Type'Output (Data_Stream, Enum_Array); + Fixed_Array_Type'Output (Data_Stream, Fix_Array); + Float_Array_Type'Output (Data_Stream, Flt_Array); + Int_Array_Type'Output (Data_Stream, Int_Array); + Mod_Array_Type'Output (Data_Stream, Mod_Array); + Str_Array_Type'Output (Data_Stream, Str_Array); + Unb_Str_Array_Type'Output (Data_Stream, UStr_Array); + + -- Reset the data file to mode In_File. The data file will now serve + -- as the source of data which will be compared to the original data + -- written to the file above. + Reset1: + begin + Ada.Text_IO.Reset (File => Data_File, Mode => Ada.Text_IO.In_File); + exception + when Ada.Text_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Text_IO" ); + raise Incomplete; + end Reset1; + + -- Extract and validate all the single data items from the stream. + + for i in 1..TC_Items loop + Character'Read (Data_Stream, TC_Char_Array_1(i)); + Enum_Type'Read (Data_Stream, TC_Enum_Array_1(i)); + Fixed_Type'Read (Data_Stream, TC_Fix_Array_1(i)); + Float_Type'Read (Data_Stream, TC_Flt_Array_1(i)); + Integer'Read (Data_Stream, TC_Int_Array_1(i)); + Modular_Type'Read (Data_Stream, TC_Mod_Array_1(i)); + Str_Type'Read (Data_Stream, TC_Str_Array_1(i)); + Unbounded_String'Read (Data_Stream, TC_UStr_Array_1(i)); + end loop; + + if TC_Char_Array_1 /= Char_Array then + Report.Failed("Character values do not match"); + end if; + if TC_Enum_Array_1 /= Enum_Array then + Report.Failed("Enumeration values do not match"); + end if; + if TC_Fix_Array_1 /= Fix_Array then + Report.Failed("Fixed point values do not match"); + end if; + if TC_Flt_Array_1 /= Flt_Array then + Report.Failed("Floating point values do not match"); + end if; + if TC_Int_Array_1 /= Int_Array then + Report.Failed("Integer values do not match"); + end if; + if TC_Mod_Array_1 /= Mod_Array then + Report.Failed("Modular values do not match"); + end if; + if TC_Str_Array_1 /= Str_Array then + Report.Failed("String values do not match"); + end if; + if TC_UStr_Array_1 /= UStr_Array then + Report.Failed("Unbounded_String values do not match"); + end if; + + -- Extract and validate all data arrays from the data stream. + -- Note that the 'Input attribute denotes a function, whereas the + -- other stream oriented attributes in this test denote procedures. + + TC_Char_Array_2 := Char_Array_Type'Input(Data_Stream); + TC_Enum_Array_2 := Enum_Array_Type'Input(Data_Stream); + TC_Fix_Array_2 := Fixed_Array_Type'Input(Data_Stream); + TC_Flt_Array_2 := Float_Array_Type'Input(Data_Stream); + TC_Int_Array_2 := Int_Array_Type'Input(Data_Stream); + TC_Mod_Array_2 := Mod_Array_Type'Input(Data_Stream); + TC_Str_Array_2 := Str_Array_Type'Input(Data_Stream); + TC_UStr_Array_2 := Unb_Str_Array_Type'Input(Data_Stream); + + if TC_Char_Array_2 /= Char_Array then + Report.Failed("Character array values do not match"); + end if; + if TC_Enum_Array_2 /= Enum_Array then + Report.Failed("Enumeration array values do not match"); + end if; + if TC_Fix_Array_2 /= Fix_Array then + Report.Failed("Fixed point array values do not match"); + end if; + if TC_Flt_Array_2 /= Flt_Array then + Report.Failed("Floating point array values do not match"); + end if; + if TC_Int_Array_2 /= Int_Array then + Report.Failed("Integer array values do not match"); + end if; + if TC_Mod_Array_2 /= Mod_Array then + Report.Failed("Modular array values do not match"); + end if; + if TC_Str_Array_2 /= Str_Array then + Report.Failed("String array values do not match"); + end if; + if TC_UStr_Array_2 /= UStr_Array then + Report.Failed("Unbounded_String array values do not match"); + end if; + + exception + when Incomplete => + raise; + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Deletion: + begin + -- Delete the data file. + if not Ada.Text_IO.Is_Open(Data_File) then + Ada.Text_IO.Open(Data_File, Ada.Text_IO.In_File, Data_Filename); + end if; + Ada.Text_IO.Delete(Data_File); + + exception + when others => + Report.Failed + ( "Delete not properly implemented for Text_IO" ); + + end Deletion; + + Report.Result; + + exception + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXAC004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxac005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxac005.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,343 ---- + -- CXAC005.A + -- + -- Grant of Unlimited Rights + -- + -- The Ada Conformity Assessment Authority (ACAA) holds unlimited + -- rights in the software and documentation contained herein. Unlimited + -- rights are the same as those granted by the U.S. Government for older + -- parts of the Ada Conformity Assessment Test Suite, and are defined + -- in DFAR 252.227-7013(a)(19). By making this public release, the ACAA + -- intends to confer upon all recipients unlimited rights equal to those + -- held by the ACAA. These rights include rights to use, duplicate, + -- release or disclose the released technical data and computer software + -- in whole or in part, in any manner and for any purpose whatsoever, and + -- to have or permit others to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that stream file positioning work as specified. (Defect Report + -- 8652/0055). + -- + -- CHANGE HISTORY: + -- 12 FEB 2001 PHL Initial version. + -- 14 MAR 2001 RLB Readied for release; fixed Not_Applicable check + -- to terminate test gracefully. + -- + --! + with Ada.Streams.Stream_Io; + use Ada.Streams; + with Ada.Exceptions; + use Ada.Exceptions; + with Report; + use Report; + procedure CXAC005 is + + Incomplete : exception; + + procedure TC_Assert (Condition : Boolean; Message : String) is + begin + if not Condition then + Failed (Message); + end if; + end TC_Assert; + + package Checked_Stream_Io is + + type File_Type (Max_Size : Stream_Element_Count) is limited private; + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type; + + procedure Create (File : in out File_Type; + Mode : in Stream_Io.File_Mode := Stream_Io.Out_File; + Name : in String := ""; + Form : in String := ""); + + procedure Open (File : in out File_Type; + Mode : in Stream_Io.File_Mode; + Name : in String; + Form : in String := ""); + + procedure Close (File : in out File_Type); + procedure Delete (File : in out File_Type); + + procedure Reset (File : in out File_Type; + Mode : in Stream_Io.File_Mode); + procedure Reset (File : in out File_Type); + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : in Stream_Io.Positive_Count); + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset); + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array; + To : in Stream_Io.Positive_Count); + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array); + + procedure Set_Index (File : in out File_Type; + To : in Stream_Io.Positive_Count); + + function Index (File : in File_Type) return Stream_Io.Positive_Count; + + procedure Set_Mode (File : in out File_Type; + Mode : in Stream_Io.File_Mode); + + private + type File_Type (Max_Size : Stream_Element_Count) is + record + File : Stream_Io.File_Type; + Index : Stream_Io.Positive_Count; + Contents : + Stream_Element_Array + (Stream_Element_Offset (Ident_Int (1)) .. Max_Size); + end record; + end Checked_Stream_Io; + + package body Checked_Stream_Io is + + use Stream_Io; + + function Stream_Io_File (File : File_Type) return Stream_Io.File_Type is + begin + return File.File; + end Stream_Io_File; + + procedure Create (File : in out File_Type; + Mode : in Stream_Io.File_Mode := Stream_Io.Out_File; + Name : in String := ""; + Form : in String := "") is + begin + Stream_Io.Create (File.File, Mode, Name, Form); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Create - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Create - " & + File_Mode'Image (Mode)); + end if; + end Create; + + procedure Open (File : in out File_Type; + Mode : in Stream_Io.File_Mode; + Name : in String; + Form : in String := "") is + begin + Stream_Io.Open (File.File, Mode, Name, Form); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Open - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Open - " & + File_Mode'Image (Mode)); + end if; + end Open; + + procedure Close (File : in out File_Type) is + begin + Stream_Io.Close (File.File); + end Close; + + procedure Delete (File : in out File_Type) is + begin + Stream_Io.Delete (File.File); + end Delete; + + procedure Reset (File : in out File_Type; + Mode : in Stream_Io.File_Mode) is + begin + Stream_Io.Reset (File.File, Mode); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Reset - Append_File"); + else + TC_Assert (File.Index = 1, "Index /= 1 -- Reset - " & + File_Mode'Image (Mode)); + end if; + end Reset; + + procedure Reset (File : in out File_Type) is + begin + Reset (File, Stream_Io.Mode (File.File)); + end Reset; + + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset; + From : in Stream_Io.Positive_Count) is + begin + Set_Index (File, From); + Read (File, Item, Last); + end Read; + + procedure Read (File : in out File_Type; + Item : out Stream_Element_Array; + Last : out Stream_Element_Offset) is + Index : constant Stream_Element_Offset := + Stream_Element_Offset (File.Index); + begin + Stream_Io.Read (File.File, Item, Last); + if Last < Item'Last then + TC_Assert (Item (Item'First .. Last) = + File.Contents (Index .. Index + Last - Item'First), + "Incorrect data read from file - 1"); + TC_Assert (Count (Index + Last - Item'First) = + Stream_Io.Size (File.File), + "Read stopped before end of file"); + File.Index := Count (Index + Last - Item'First) + 1; + else + TC_Assert (Item = File.Contents (Index .. Index + Item'Length - 1), + "Incorrect data read from file - 2"); + File.Index := File.Index + Item'Length; + end if; + end Read; + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array; + To : in Stream_Io.Positive_Count) is + begin + Set_Index (File, To); + Write (File, Item); + end Write; + + procedure Write (File : in out File_Type; + Item : in Stream_Element_Array) is + Index : constant Stream_Element_Offset := + Stream_Element_Offset (File.Index); + begin + Stream_Io.Write (File.File, Item); + File.Contents (Index .. Index + Item'Length - 1) := Item; + File.Index := File.Index + Item'Length; + TC_Assert (File.Index = Stream_Io.Index (File.File), + "Write failed to move the index"); + end Write; + + procedure Set_Index (File : in out File_Type; + To : in Stream_Io.Positive_Count) is + begin + Stream_Io.Set_Index (File.File, To); + File.Index := Stream_Io.Index (File.File); + TC_Assert (File.Index = To, "Set_Index failed"); + end Set_Index; + + function Index (File : in File_Type) return Stream_Io.Positive_Count is + New_Index : constant Count := Stream_Io.Index (File.File); + begin + TC_Assert (New_Index = File.Index, "Index changed unexpectedly"); + return New_Index; + end Index; + + procedure Set_Mode (File : in out File_Type; + Mode : in Stream_Io.File_Mode) is + Old_Index : constant Count := File.Index; + begin + Stream_Io.Set_Mode (File.File, Mode); + File.Index := Stream_Io.Index (File.File); + if Mode = Append_File then + TC_Assert (File.Index = Stream_Io.Size (File.File) + 1, + "Index /= Size + 1 -- Set_Mode - Append_File"); + else + TC_Assert (File.Index = Old_Index, "Set_Mode changed the index"); + end if; + end Set_Mode; + + end Checked_Stream_Io; + + package Csio renames Checked_Stream_Io; + + F : Csio.File_Type (100); + S : Stream_Element_Array (1 .. 10); + Last : Stream_Element_Offset; + + begin + + Test ("CXAC005", "Check that stream file positioning work as specified"); + + declare + Name : constant String := Legal_File_Name; + begin + begin + Csio.Create (F, Name => Name); + exception + when others => + Not_Applicable ("Files not supported - Creation with Out_File for Stream_IO"); + raise Incomplete; + end; + + for I in Stream_Element range 1 .. 10 loop + Csio.Write (F, ((1 => I + 2))); + end loop; + Csio.Write (F, (1 .. 15 => 11)); + Csio.Write (F, (1 .. 15 => 12), To => 15); + + Csio.Reset (F); + + for I in Stream_Element range 1 .. 10 loop + Csio.Write (F, (1 => I)); + end loop; + Csio.Write (F, (1 .. 15 => 13)); + Csio.Write (F, (1 .. 15 => 14), To => 15); + Csio.Write (F, (1 => 90)); + + Csio.Set_Mode (F, Stream_Io.In_File); + + Csio.Read (F, S, Last); + Csio.Read (F, S, Last, From => 3); + Csio.Read (F, S, Last, From => 28); + + Csio.Set_Mode (F, Stream_Io.Append_File); + Csio.Write (F, (1 .. 5 => 88)); + + Csio.Close (F); + + Csio.Open (F, Name => Name, Mode => Stream_Io.Append_File); + Csio.Write (F, (1 .. 3 => 33)); + + Csio.Set_Mode (F, Stream_Io.In_File); + Csio.Read (F, S, Last, From => 20); + Csio.Read (F, S, Last); + Csio.Reset (F, Stream_Io.Out_File); + + Csio.Write (F, (1 .. 9 => 99)); + + -- Check the contents of the entire file. + declare + S : Stream_Element_Array + (1 .. Stream_Element_Offset + (Stream_Io.Size (Csio.Stream_Io_File (F)))); + begin + Csio.Reset (F, Stream_Io.In_File); + Csio.Read (F, S, Last); + end; + + Csio.Delete (F); + end; + + Result; + exception + when Incomplete => + Report.Result; + when E:others => + Report.Failed ("Unexpected exception raised - " & Exception_Name (E) & + " - " & Exception_Message (E)); + Report.Result; + + end CXAC005; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaca01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,291 ---- + -- CXACA01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the default attributes 'Write and 'Read work properly when + -- used with objects of a variety of types, including records with + -- default discriminants, records without default discriminants, but + -- which have the discriminant described in a representation clause for + -- the type, and arrays. + -- + -- TEST DESCRIPTION: + -- This test simulates a basic sales record system, using Stream_IO to + -- allow the storage of heterogeneous data in a single stream file. + -- + -- Four types of data are written to the stream file for each product. + -- First, the "header" information on the product is written. + -- This is an object of a discriminated (with default) record + -- type. This is followed by an integer object containing a count of + -- the number of sales data records to follow. The corresponding number + -- of sales records follow in the stream. These are of a record type + -- with a discriminant without a default, but where the discriminant is + -- included in the representation clause for the type. Finally, an + -- array object with statistical sales information for the product is + -- written to the stream. + -- + -- Objects of both record types specified below (discriminated records + -- with defaults, and discriminated records w/o defaults that have the + -- discriminant included in a representation clause for the type) should + -- have their discriminants included in the stream when using 'Write. + -- Likewise, discriminants should be extracted from the stream when + -- using 'Read. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all implementations that support external + -- Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FXACA00; + with Ada.Streams.Stream_IO; + with Report; + + procedure CXACA01 is + + begin + + Report.Test ("CXACA01", "Check that 'Write and 'Read work properly " & + "when used with complex data types"); + + Test_for_Stream_IO_Support: + declare + + Info_File : Ada.Streams.Stream_IO.File_Type; + Info_Stream : Ada.Streams.Stream_IO.Stream_Access; + The_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Info_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + + Operational_Test_Block: + declare + + begin + + Info_Stream := Ada.Streams.Stream_IO.Stream (Info_File); + + -- Write all of the product information (record, integer, and array + -- objects) defined in package FXACA00 into the stream. + + Store_Data_Block: + begin + + -- Write information about first product to the stream. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_01); + Integer'Write (Info_Stream, FXACA00.Sale_Count_01); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_01); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_02); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_01_Stats); + + -- Write information about second product to the stream. + -- Note: No Sales_Record_Type objects. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_02); + Integer'Write (Info_Stream, FXACA00.Sale_Count_02); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_02_Stats); + + -- Write information about third product to the stream. + FXACA00.Product_Type'Write (Info_Stream, FXACA00.Product_03); + Integer'Write (Info_Stream, FXACA00.Sale_Count_03); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_03); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_04); + FXACA00.Sales_Record_Type'Write(Info_Stream, FXACA00.Sale_Rec_05); + FXACA00.Sales_Statistics_Type'Write + (Info_Stream, FXACA00.Product_03_Stats); + + end Store_Data_Block; + + + Verify_Data_Block: + declare + + use FXACA00; -- Used within this block only. + + type Domestic_Rec_Array_Type is + array (Positive range <>) of Sales_Record_Type (Domestic); + + type Foreign_Rec_Array_Type is + array (Positive range <>) of Sales_Record_Type (Foreign); + + TC_Rec1 : Domestic_Rec_Array_Type (1..2); + TC_Rec3 : Foreign_Rec_Array_Type (1..3); + + TC_Product1 : Product_Type; + TC_Product2, + TC_Product3 : Product_Type (Foreign); + + TC_Count1, + TC_Count2, + TC_Count3 : Integer := -10; -- Initialized to dummy value. + + TC_Stat1, + TC_Stat2, + TC_Stat3 : Sales_Statistics_Type := (others => 500); + + begin + + Ada.Streams.Stream_IO.Reset (Info_File, + Ada.Streams.Stream_IO.In_File); + + -- Read all of the data that is contained in the stream. + -- Compare all data with the original data in package FXACA00 + -- that was written to the stream. + -- The calls to the read attribute are in anticipated order, based + -- on the order of data written to the stream. Possible errors, + -- such as data placement, overwriting, etc., will be manifest as + -- exceptions raised by the attribute during an unsuccessful read + -- attempt. + + -- Extract data on first product. + Product_Type'Read (Info_Stream, TC_Product1); + Integer'Read (Info_Stream, TC_Count1); + + -- Two "domestic" variant sales records will be read from the + -- stream. + for i in 1 .. TC_Count1 loop + Sales_Record_Type'Read (Info_Stream, TC_Rec1(i) ); + end loop; + + Sales_Statistics_Type'Read (Info_Stream, TC_Stat1); + + + -- Extract data on second product. + Product_Type'Read (Info_Stream, TC_Product2); + Integer'Read (Info_Stream, TC_Count2); + Sales_Statistics_Type'Read (Info_Stream, TC_Stat2); + + + -- Extract data on third product. + Product_Type'Read (Info_Stream, TC_Product3); + Integer'Read (Info_Stream, TC_Count3); + + -- Three "foreign" variant sales records will be read from the + -- stream. + for i in 1 .. TC_Count3 loop + Sales_Record_Type'Read (Info_Stream, TC_Rec3(i) ); + end loop; + + Sales_Statistics_Type'Read (Info_Stream, TC_Stat3); + + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Info_File) then + Report.Failed ("Stream file not empty"); + end if; + + -- Verify that the data values read from the stream are the same + -- as those written to the stream. + + -- Verify the information of the first product. + if ((Product_01 /= TC_Product1) or else + (Product_01.Manufacture /= TC_Product1.Manufacture) or else + (Sale_Count_01 /= TC_Count1) or else + (Sale_Rec_01 /= TC_Rec1(1)) or else + (Sale_Rec_01.Buyer /= TC_Rec1(1).Buyer) or else + (Sale_Rec_02 /= TC_Rec1(2)) or else + (Sale_Rec_02.Buyer /= TC_Rec1(2).Buyer) or else + (Product_01_Stats /= TC_Stat1)) + then + Report.Failed ("Product 1 information incorrect"); + end if; + + -- Verify the information of the second product. + if not ((Product_02 = TC_Product2) and then + (Sale_Count_02 = TC_Count2) and then + (Product_02_Stats = TC_Stat2)) + then + Report.Failed ("Product 2 information incorrect"); + end if; + + -- Verify the information of the third product. + if ((Product_03 /= TC_Product3) or else + (Product_03.Manufacture /= TC_Product3.Manufacture) or else + (Sale_Count_03 /= TC_Count3) or else + (Sale_Rec_03 /= TC_Rec3(1)) or else + (Sale_Rec_03.Buyer /= TC_Rec3(1).Buyer) or else + (Sale_Rec_04 /= TC_Rec3(2)) or else + (Sale_Rec_04.Buyer /= TC_Rec3(2).Buyer) or else + (Sale_Rec_05 /= TC_Rec3(3)) or else + (Sale_Rec_05.Buyer /= TC_Rec3(3).Buyer) or else + (Product_03_Stats /= TC_Stat3)) + then + Report.Failed ("Product 3 information incorrect"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Info_File) then + Ada.Streams.Stream_IO.Delete (Info_File); + else + Ada.Streams.Stream_IO.Open (Info_File, + Ada.Streams.Stream_IO.In_File, + The_Filename); + Ada.Streams.Stream_IO.Delete (Info_File); + end if; + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised on Stream IO Create"); + + end Test_for_Stream_IO_Support; + + Report.Result; + + end CXACA01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaca02.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,360 ---- + -- CXACA02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that user defined subprograms can override the default + -- attributes 'Read and 'Write using attribute definition clauses. + -- Use objects of record types. + -- + -- TEST DESCRIPTION: + -- This test demonstrates that the default implementations of the + -- 'Read and 'Write attributes can be overridden by user specified + -- subprograms in conjunction with attribute definition clauses. + -- These attributes have been overridden below, and in the user defined + -- substitutes, values are added or subtracted to global variables. + -- The global variables are evaluated to ensure that the user defined + -- subprograms were used in overriding the type-related default + -- attributes. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all implementations that support external + -- Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 21 Nov 95 SAIC Corrected recursive attribute definitions + -- for ACVC 2.0.1. + -- 24 Aug 96 SAIC Corrected typo in test verification criteria. + -- + --! + + with Report; + with Ada.Streams.Stream_IO; + + procedure CXACA02 is + begin + + Report.Test ("CXACA02", "Check that user defined subprograms can " & + "override the default attributes 'Read and " & + "'Write using attribute definition clauses"); + + Test_for_Stream_IO_Support: + declare + + Data_File : Ada.Streams.Stream_IO.File_Type; + Data_Stream : Ada.Streams.Stream_IO.Stream_Access; + The_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Data_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + + Operational_Test_Block: + declare + + type Origin_Type is (Foreign, Domestic); + subtype String_Data_Type is String(1..8); + + type Product_Type is + record + Item : String_Data_Type; + ID : Natural range 1..100; + Manufacture : Origin_Type := Domestic; + Distributor : String_Data_Type; + Importer : String_Data_Type; + end record; + + type Sales_Record_Type is + record + Name : String_Data_Type; + Sale_Item : Boolean := False; + Buyer : Origin_Type; + Quantity_Discount : Boolean; + Cash_Discount : Boolean; + end record; + + + -- Mode conformant, user defined subprograms that will override + -- the type-related attributes. + -- In this test, the user defines these subprograms to add/subtract + -- specific values from global variables. + + procedure Product_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Product_Type ); + + procedure Product_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Product_Type ); + + procedure Sales_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Sales_Record_Type ); + + procedure Sales_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Sales_Record_Type ); + + -- Attribute definition clauses. + + for Product_Type'Read use Product_Read; + for Product_Type'Write use Product_Write; + + for Sales_Record_Type'Read use Sales_Read; + for Sales_Record_Type'Write use Sales_Write; + + + -- Object Declarations + + Product_01 : Product_Type := + ("Product1", 1, Domestic, "Distrib1", "Import 1"); + Product_02 : Product_Type := + ("Product2", 2, Foreign, "Distrib2", "Import 2"); + + Sale_Rec_01 : Sales_Record_Type := + ("Buyer 01", False, Domestic, True, True); + Sale_Rec_02 : Sales_Record_Type := + ("Buyer 02", True, Domestic, True, False); + Sale_Rec_03 : Sales_Record_Type := (Name => "Buyer 03", + Sale_Item => True, + Buyer => Foreign, + Quantity_Discount => False, + Cash_Discount => True); + Sale_Rec_04 : Sales_Record_Type := + ("Buyer 04", True, Foreign, False, False); + Sale_Rec_05 : Sales_Record_Type := + ("Buyer 05", False, Foreign, False, False); + + TC_Read_Total : Integer := 100; + TC_Write_Total : Integer := 0; + + + -- Subprogram bodies. + -- These subprograms are designed to override the default attributes + -- 'Read and 'Write for the specified types. Each adds/subtracts + -- a quantity to/from a program control variable, indicating its + -- activity. In addition, each component of the record is + -- individually read from or written to the stream, using the + -- appropriate 'Read or 'Write attribute for the component type. + -- The string components are moved to/from the stream using the + -- 'Input and 'Output attributes for the string subtype, so that + -- the bounds of the strings are also written/read. + + procedure Product_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Product_Type ) is + begin + TC_Read_Total := TC_Read_Total - 10; + + The_Item.Item := String_Data_Type'Input(Data_Stream); -- Field 1. + Natural'Read(Data_Stream, The_Item.ID); -- Field 2. + Origin_Type'Read(Data_Stream, -- Field 3. + The_Item.Manufacture); + The_Item.Distributor := -- Field 4. + String_Data_Type'Input(Data_Stream); + The_Item.Importer := -- Field 5. + String_Data_Type'Input(Data_Stream); + end Product_Read; + + + procedure Product_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Product_Type ) is + begin + TC_Write_Total := TC_Write_Total + 5; + + String_Data_Type'Output(Data_Stream, The_Item.Item); -- Field 1. + Natural'Write(Data_Stream, The_Item.ID); -- Field 2. + Origin_Type'Write(Data_Stream, -- Field 3. + The_Item.Manufacture); + String_Data_Type'Output(Data_Stream, -- Field 4. + The_Item.Distributor); + String_Data_Type'Output(Data_Stream, -- Field 5. + The_Item.Importer); + end Product_Write; + + + procedure Sales_Read + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : out Sales_Record_Type ) is + begin + TC_Read_Total := TC_Read_Total - 20; + + The_Item.Name := String_Data_Type'Input(Data_Stream); -- Field 1. + Boolean'Read(Data_Stream, The_Item.Sale_Item); -- Field 2. + Origin_Type'Read(Data_Stream, The_Item.Buyer); -- Field 3. + Boolean'Read(Data_Stream, The_Item.Quantity_Discount); -- Field 4. + Boolean'Read(Data_Stream, The_Item.Cash_Discount); -- Field 5. + end Sales_Read; + + + procedure Sales_Write + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + The_Item : Sales_Record_Type ) is + begin + TC_Write_Total := TC_Write_Total + 10; + + String_Data_Type'Output(Data_Stream, The_Item.Name); -- Field 1. + Boolean'Write(Data_Stream, The_Item.Sale_Item); -- Field 2. + Origin_Type'Write(Data_Stream, The_Item.Buyer); -- Field 3. + Boolean'Write(Data_Stream, The_Item.Quantity_Discount); -- Field 4. + Boolean'Write(Data_Stream, The_Item.Cash_Discount); -- Field 5. + end Sales_Write; + + + + begin + + Data_Stream := Ada.Streams.Stream_IO.Stream (Data_File); + + -- Write product and sales data to the stream. + + Product_Type'Write (Data_Stream, Product_01); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_01); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_02); + + Product_Type'Write (Data_Stream, Product_02); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_03); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_04); + Sales_Record_Type'Write (Data_Stream, Sale_Rec_05); + + -- Read data from the stream, and verify the use of the user specified + -- attributes. + + Verify_Data_Block: + declare + + TC_Product1, + TC_Product2 : Product_Type; + + TC_Sale1, + TC_Sale2, + TC_Sale3, + TC_Sale4, + TC_Sale5 : Sales_Record_Type; + + begin + + -- Reset the mode of the stream file so that Read/Input + -- operations may be performed. + + Ada.Streams.Stream_IO.Reset (Data_File, + Ada.Streams.Stream_IO.In_File); + + -- Data is read/reconstructed from the stream, in the order that + -- the data was placed into the stream. + + Product_Type'Read (Data_Stream, TC_Product1); + Sales_Record_Type'Read (Data_Stream, TC_Sale1); + Sales_Record_Type'Read (Data_Stream, TC_Sale2); + + Product_Type'Read (Data_Stream, TC_Product2); + Sales_Record_Type'Read (Data_Stream, TC_Sale3); + Sales_Record_Type'Read (Data_Stream, TC_Sale4); + Sales_Record_Type'Read (Data_Stream, TC_Sale5); + + -- Verify product data was correctly written to/read from stream. + + if TC_Product1 /= Product_01 then + Report.Failed ("Data verification error, Product 1"); + end if; + if TC_Product2 /= Product_02 then + Report.Failed ("Data verification error, Product 2"); + end if; + + if TC_Sale1 /= Sale_Rec_01 then + Report.Failed ("Data verification error, Sale_Rec_01"); + end if; + if TC_Sale2 /= Sale_Rec_02 then + Report.Failed ("Data verification error, Sale_Rec_02"); + end if; + if TC_Sale3 /= Sale_Rec_03 then + Report.Failed ("Data verification error, Sale_Rec_03"); + end if; + if TC_Sale4 /= Sale_Rec_04 then + Report.Failed ("Data verification error, Sale_Rec_04"); + end if; + if TC_Sale5 /= Sale_Rec_05 then + Report.Failed ("Data verification error, Sale_Rec_05"); + end if; + + -- Verify that the user defined subprograms were used to + -- override the default 'Read and 'Write attributes. + -- There were two "product" reads and two writes; there + -- were five "sale record" reads and five writes. + + if (TC_Read_Total /= -20) or (TC_Write_Total /= 60) then + Report.Failed ("Incorrect use of user defined attributes"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Data_File) then + Ada.Streams.Stream_IO.Delete (Data_File); + else + Ada.Streams.Stream_IO.Open (Data_File, + Ada.Streams.Stream_IO.Out_File, + The_Filename); + Ada.Streams.Stream_IO.Delete (Data_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + + end CXACA02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacb01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,264 ---- + -- CXACB01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the default attributes 'Input and 'Output work properly when + -- used with objects of a variety of types, including two-dimensional + -- arrays and records without default discriminants. + -- + -- TEST DESCRIPTION: + -- This test simulates utility company service record storage, using + -- Stream_IO to allow the storage of heterogeneous data in a single + -- stream file. + -- + -- Three types of data are written to the stream file for each utility + -- service customer. + -- First, the general information on the customer is written. + -- This is an object of a discriminated (without default) record + -- type. This is followed by an integer object containing a count of + -- the number of service months for the customer. Finally, a + -- two-dimensional array object with monthly consumption information for + -- the customer is written to the stream. + -- + -- Objects of record types with discriminants without defaults should + -- have their discriminants included in the stream when using 'Output. + -- Likewise, discriminants should be extracted + -- from the stream when using 'Input. Similarly, array bounds are written + -- to and read from the stream when using 'Output and 'Input with array + -- objects. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all implementations that support external + -- Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FXACB00; + with Ada.Streams.Stream_IO; + with Report; + + procedure CXACB01 is + begin + + Report.Test ("CXACB01", "Check that the default attributes 'Input and " & + "'Output work properly when used with objects " & + "of record, natural, and array types" ); + + Test_for_Stream_IO_Support: + declare + + Util_File : Ada.Streams.Stream_IO.File_Type; + Util_Stream : Ada.Streams.Stream_IO.Stream_Access; + Utility_Service_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Service_Filename); + + Operational_Test_Block: + declare + + -- The following procedure will store all of the customer specific + -- information into the stream. + + procedure Store_Data_In_Stream + (Customer : in FXACB00.Service_Type; + Months : in FXACB00.Months_In_Service_Type; + History : in FXACB00.Service_History_Type) is + begin + FXACB00.Service_Type'Output (Util_Stream, Customer); + FXACB00.Months_In_Service_Type'Output (Util_Stream, Months); + FXACB00.Service_History_Type'Output (Util_Stream, History); + end Store_Data_In_Stream; + + + -- The following procedure will remove from the stream all of the + -- customer related information. + + procedure Retrieve_Data_From_Stream + (Customer : out FXACB00.Service_Type; + Months : out FXACB00.Months_In_Service_Type; + History : out FXACB00.Service_History_Type) is + begin + Customer := FXACB00.Service_Type'Input (Util_Stream); + Months := FXACB00.Months_In_Service_Type'Input (Util_Stream); + History := FXACB00.Service_History_Type'Input (Util_Stream); + end Retrieve_Data_From_Stream; + + + begin + + Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); + + -- Write all of the customer service information (record, numeric, + -- and array objects) defined in package FXACB00 into the stream. + + Data_Storage_Block: + begin + + Store_Data_In_Stream (Customer => FXACB00.Customer1, + Months => FXACB00.C1_Months, + History => FXACB00.C1_Service_History); + + Store_Data_In_Stream (FXACB00.Customer2, + FXACB00.C2_Months, + History => FXACB00.C2_Service_History); + + Store_Data_In_Stream (Months => FXACB00.C3_Months, + History => FXACB00.C3_Service_History, + Customer => FXACB00.Customer3); + end Data_Storage_Block; + + + Data_Verification_Block: + declare + + TC_Residence : FXACB00.Service_Type (FXACB00.Residence); + TC_Apartment : FXACB00.Service_Type (FXACB00.Apartment); + TC_Commercial : FXACB00.Service_Type (FXACB00.Commercial); + + + TC_Months1, + TC_Months2, + TC_Months3 : FXACB00.Months_In_Service_Type := + FXACB00.Months_In_Service_Type'First; + + + TC_History1 : + FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + TC_History2 : + FXACB00.Service_History_Type + (FXACB00.Quarterly_Period_Type range + FXACB00.Spring .. FXACB00.Summer, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + TC_History3 : + FXACB00.Service_History_Type (FXACB00.Quarterly_Period_Type, + FXACB00.Month_In_Quarter_Type) := + (others => (others => FXACB00.Electric_Usage_Type'Last)); + + begin + + Ada.Streams.Stream_IO.Reset (Util_File, + Ada.Streams.Stream_IO.In_File); + + -- Input all of the data that is contained in the stream. + -- Compare all data with the original data in package FXACB00 + -- that was written to the stream. + + Retrieve_Data_From_Stream (TC_Residence, TC_Months1, TC_History1); + Retrieve_Data_From_Stream (TC_Apartment, TC_Months2, TC_History2); + Retrieve_Data_From_Stream (Customer => TC_Commercial, + Months => TC_Months3, + History => TC_History3); + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Util_File) then + Report.Failed ("Stream file not empty"); + end if; + + -- Verify that the data values read from the stream are the same + -- as those written to the stream. + + if ((FXACB00."/="(FXACB00.Customer1, TC_Residence)) or else + (FXACB00."/="(FXACB00.Customer2, TC_Apartment)) or else + (FXACB00."/="(FXACB00.Customer3, TC_Commercial))) + then + Report.Failed ("Customer information incorrect"); + end if; + + if ((FXACB00."/="(FXACB00.C1_Months, TC_Months1)) or + (FXACB00."/="(FXACB00.C2_Months, TC_Months2)) or + (FXACB00."/="(FXACB00.C3_Months, TC_Months3))) + then + Report.Failed ("Number of Months information incorrect"); + end if; + + if not ((FXACB00."="(FXACB00.C1_Service_History, TC_History1)) and + (FXACB00."="(FXACB00.C2_Service_History, TC_History2)) and + (FXACB00."="(FXACB00.C3_Service_History, TC_History3))) + then + Report.Failed ("Service history information incorrect"); + end if; + + end Data_Verification_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + -- Delete the file. + if Ada.Streams.Stream_IO.Is_Open (Util_File) then + Ada.Streams.Stream_IO.Delete (Util_File); + else + Ada.Streams.Stream_IO.Open (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Service_Filename); + Ada.Streams.Stream_IO.Delete (Util_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + + end CXACB01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacb02.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,421 ---- + -- CXACB02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that user defined subprograms can override the default + -- attributes 'Input and 'Output using attribute definition clauses, + -- when used with objects of discriminated record and multi-dimensional + -- array types. + -- + -- TEST DESCRIPTION: + -- This test demonstrates that the default implementations of the + -- 'Input and 'Output attributes can be overridden by user specified + -- subprograms in conjunction with attribute definition clauses. + -- These attributes have been overridden below, and in the user defined + -- substitutes, values are added or subtracted to global variables. + -- Following the completion of the writing/reading test, the global + -- variables are evaluated to ensure that the user defined subprograms + -- were used in overriding the type-related default attributes. + -- + -- APPLICABILITY CRITERIA: + -- Applicable to all implementations that support external + -- Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Nov 95 SAIC Corrected test errors for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Streams.Stream_IO; + + procedure CXACB02 is + begin + + Report.Test ("CXACB02", "Check that user defined subprograms can " & + "override the default attributes 'Input and " & + "'Output using attribute definition clauses"); + + Test_for_Stream_IO_Support: + declare + + Util_File : Ada.Streams.Stream_IO.File_Type; + Util_Stream : Ada.Streams.Stream_IO.Stream_Access; + Utility_Filename : constant String := Report.Legal_File_Name; + + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Filename); + + Operational_Test_Block: + declare + + type Customer_Type is (Residence, Apartment, Commercial); + type Electric_Usage_Type is range 0..100000; + type Months_In_Service_Type is range 1..12; + type Quarterly_Period_Type is (Spring, Summer, Autumn, Winter); + subtype Month_In_Quarter_Type is Positive range 1..3; + type Service_History_Type is + array (Quarterly_Period_Type range <>, + Month_In_Quarter_Type range <>) of Electric_Usage_Type; + + type Service_Type (Customer : Customer_Type) is + record + Name : String (1..21); + Account_ID : Natural range 0..100; + case Customer is + when Residence | Apartment => + Low_Income_Credit : Boolean := False; + when Commercial => + Baseline_Allowance : Natural range 0..1000; + Quantity_Discount : Boolean := False; + end case; + end record; + + + -- Mode conformant, user defined subprograms that will override + -- the type-related attributes. + -- In this test, the user defines these subprograms to add/subtract + -- specific values from global variables. + + function Service_Input + (Stream : access Ada.Streams.Root_Stream_Type'Class) + return Service_Type; + + procedure Service_Output + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_Type); + + function History_Input + (Stream : access Ada.Streams.Root_Stream_Type'Class) + return Service_History_Type; + + procedure History_Output + (Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_History_Type); + + + -- Attribute definition clauses. + + for Service_Type'Input use Service_Input; + for Service_Type'Output use Service_Output; + + for Service_History_Type'Input use History_Input; + for Service_History_Type'Output use History_Output; + + + -- Object Declarations + + Customer1 : Service_Type (Residence) := + (Residence, "1221 Morningstar Lane", 44, False); + Customer2 : Service_Type (Apartment) := + (Customer => Apartment, + Account_ID => 67, + Name => "15 South Front St. #8", + Low_Income_Credit => True); + Customer3 : Service_Type (Commercial) := + (Commercial, + "12442 Central Avenue ", + 100, + Baseline_Allowance => 938, + Quantity_Discount => True); + + C1_Service_History : + Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (Spring => (1 => 35, 2 => 39, 3 => 32), + Summer => (1 => 34, 2 => 33, 3 => 39), + Autumn => (1 => 45, 2 => 40, 3 => 38), + Winter => (1 => 53, 2 => 0, 3 => 0)); + + C2_Service_History : + Service_History_Type (Quarterly_Period_Type range Spring..Summer, + Month_In_Quarter_Type) := + (Spring => (23, 22, 0), Summer => (0, 0, 0)); + + C3_Service_History : + Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => 200)); + + + TC_Input_Total : Integer := 0; + TC_Output_Total : Integer := 0; + + + -- Subprogram bodies. + -- These subprograms are designed to override the default attributes + -- 'Input and 'Output for the specified types. Each adds/subtracts + -- a quantity to/from a program control variable, indicating its + -- activity. Each user defined "Input" function uses the 'Read + -- attribute for the type to accomplish the operation. Likewise, + -- each user defined "Output" subprogram uses the 'Write attribute + -- for the type. + + function Service_Input + ( Stream : access Ada.Streams.Root_Stream_Type'Class ) + return Service_Type is + Customer : Customer_Type; + begin + TC_Input_Total := TC_Input_Total + 1; + + -- Extract the discriminant value from the stream. + -- This discriminant would not otherwise be extracted from the + -- stream when the Service_Type'Read attribute is used below. + Customer_Type'Read (Stream, Customer); + + declare + -- Declare a constant of Service_Type, using the value just + -- read from the stream as the discriminant value of the + -- object. + Service : Service_Type(Customer); + begin + Service_Type'Read (Stream, Service); + return Service; + end; + end Service_Input; + + + procedure Service_Output + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_Type ) is + begin + TC_Output_Total := TC_Output_Total + 2; + -- Write the discriminant value to the stream. + -- The attribute 'Write (for the record type) will not write the + -- discriminant of the record object to the stream. Therefore, it + -- must be explicitly written using the 'Write attribute of the + -- discriminant type. + Customer_Type'Write (Stream, Item.Customer); + -- Write the record component values (but not the discriminant) to + -- the stream. + Service_Type'Write (Stream, Item); + end Service_Output; + + + function History_Input + ( Stream : access Ada.Streams.Root_Stream_Type'Class ) + return Service_History_Type is + Quarter_Bound_Low : Quarterly_Period_Type; + Quarter_Bound_High : Quarterly_Period_Type; + Month_Bound_Low : Month_In_Quarter_Type; + Month_Bound_High : Month_In_Quarter_Type; + begin + TC_Input_Total := TC_Input_Total + 3; + + -- Read the value of the array bounds from the stream. + -- Use these bounds in the creation of an array object that will + -- be used to store data from the stream. + -- The array bound values would not otherwise be read from the + -- stream by use of the Service_History_Type'Read attribute. + Quarterly_Period_Type'Read (Stream, Quarter_Bound_Low); + Quarterly_Period_Type'Read (Stream, Quarter_Bound_High); + Month_In_Quarter_Type'Read (Stream, Month_Bound_Low); + Month_In_Quarter_Type'Read (Stream, Month_Bound_High); + + declare + Service_History_Array : + Service_History_Type + (Quarterly_Period_Type range + Quarter_Bound_Low..Quarter_Bound_High, + Month_In_Quarter_Type range + Month_Bound_Low .. Month_Bound_High); + begin + Service_History_Type'Read (Stream, Service_History_Array); + return Service_History_Array; + end; + end History_Input; + + + procedure History_Output + ( Stream : access Ada.Streams.Root_Stream_Type'Class; + Item : Service_History_Type ) is + begin + TC_Output_Total := TC_Output_Total + 7; + -- Write the upper/lower bounds of the array object dimensions to + -- the stream. + Quarterly_Period_Type'Write (Stream, Item'First(1)); + Quarterly_Period_Type'Write (Stream, Item'Last(1)); + Month_In_Quarter_Type'Write (Stream, Item'First(2)); + Month_In_Quarter_Type'Write (Stream, Item'Last(2)); + -- Write the array values to the stream in canonical order (last + -- dimension varying fastest). + Service_History_Type'Write (Stream, Item); + end History_Output; + + + + begin + + Util_Stream := Ada.Streams.Stream_IO.Stream (Util_File); + + -- Write data to the stream. A customer service record is followed + -- by a service history array. + + Service_Type'Output (Util_Stream, Customer1); + Service_History_Type'Output (Util_Stream, C1_Service_History); + + Service_Type'Output (Util_Stream, Customer2); + Service_History_Type'Output (Util_Stream, C2_Service_History); + + Service_Type'Output (Util_Stream, Customer3); + Service_History_Type'Output (Util_Stream, C3_Service_History); + + + -- Read data from the stream, and verify the use of the user specified + -- attributes. + + Verify_Data_Block: + declare + + TC_Residence : Service_Type (Residence); + TC_Apartment : Service_Type (Apartment); + TC_Commercial : Service_Type (Commercial); + + TC_History1 : Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + TC_History2 : Service_History_Type (Quarterly_Period_Type + range Spring .. Summer, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + TC_History3 : Service_History_Type (Quarterly_Period_Type, + Month_In_Quarter_Type) := + (others => (others => Electric_Usage_Type'First)); + + begin + + -- Reset Stream file to mode In_File. + + Ada.Streams.Stream_IO.Reset (Util_File, + Ada.Streams.Stream_IO.In_File); + + -- Read data from the stream. + + TC_Residence := Service_Type'Input (Util_Stream); + TC_History1 := Service_History_Type'Input (Util_Stream); + + TC_Apartment := Service_Type'Input (Util_Stream); + TC_History2 := Service_History_Type'Input (Util_Stream); + + TC_Commercial := Service_Type'Input (Util_Stream); + TC_History3 := Service_History_Type'Input (Util_Stream); + + + -- Verify product data was correctly written to/read from stream, + -- including discriminants and array bounds. + + if (TC_Residence /= Customer1) or + (TC_Residence.Customer /= Customer1.Customer) or + (TC_History1'Last(1) /= C1_Service_History'Last(1)) or + (TC_History1'First(1) /= C1_Service_History'First(1)) or + (TC_History1'Last(2) /= C1_Service_History'Last(2)) or + (TC_History1'First(2) /= C1_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 1"); + end if; + + if (TC_Apartment /= Customer2) or + (TC_Apartment.Customer /= Customer2.Customer) or + (TC_History2 /= C2_Service_History) or + (TC_History2'Last(1) /= C2_Service_History'Last(1)) or + (TC_History2'First(1) /= C2_Service_History'First(1)) or + (TC_History2'Last(2) /= C2_Service_History'Last(2)) or + (TC_History2'First(2) /= C2_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 2"); + end if; + + if (TC_Commercial /= Customer3) or + (TC_Commercial.Customer /= Customer3.Customer) or + (TC_History3 /= C3_Service_History) or + (TC_History3'Last(1) /= C3_Service_History'Last(1)) or + (TC_History3'First(1) /= C3_Service_History'First(1)) or + (TC_History3'Last(2) /= C3_Service_History'Last(2)) or + (TC_History3'First(2) /= C3_Service_History'First(2)) + then + Report.Failed ("Incorrect data from stream - 3"); + end if; + + -- Verify that the user defined subprograms were used to override + -- the default 'Input and 'Output attributes. + -- There were three calls on each of the user defined attributes. + + if (TC_Input_Total /= 12 ) or (TC_Output_Total /= 27 ) then + Report.Failed ("Incorrect use of user defined attributes"); + end if; + + end Verify_Data_Block; + + exception + + when others => + Report.Failed ("Exception raised in Operational Test Block"); + + end Operational_Test_Block; + + if Ada.Streams.Stream_IO.Is_Open (Util_File) then + Ada.Streams.Stream_IO.Delete (Util_File); + else + Ada.Streams.Stream_IO.Open (Util_File, + Ada.Streams.Stream_IO.Out_File, + Utility_Filename); + Ada.Streams.Stream_IO.Delete (Util_File); + end if; + + + exception + + -- Since Use_Error or Name_Error can be raised if, for the specified + -- mode, the environment does not support Stream_IO operations, + -- the following handlers are included: + + when Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Stream IO Create"); + + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Stream IO Create"); + + when others => + Report.Failed ("Unexpected exception raised"); + + end Test_for_Stream_IO_Support; + + Report.Result; + + end CXACB02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxacc01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,299 ---- + -- CXACC01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the use of 'Class'Output and 'Class'Input allow stream + -- manipulation of objects of non-limited class-wide types. + -- + -- TEST DESCRIPTION: + -- This test demonstrates the uses of 'Class'Output and 'Class'Input + -- in moving objects of a particular class to and from a stream file. + -- A procedure uses a class-wide parameter to move objects of specific + -- types in the class to the stream, using the 'Class'Output attribute + -- of the root type of the class. A function returns a class-wide object, + -- using the 'Class'Input attribute of the root type of the class to + -- extract the object from the stream. + -- A field-by-field comparison of record objects is performed to validate + -- the data read from the stream. Operator precedence rules are used + -- in the comparison rather than parentheses. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations capable of supporting + -- external Stream_IO files. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 14 Nov 95 SAIC Corrected prefix of 'Tag attribute for ACVC 2.0.1. + -- 24 Aug 96 SAIC Changed a call to "Create" to "Reset". + -- 26 Feb 97 CTA.PWB Allowed for non-support of some IO operations. + --! + + with FXACC00, Ada.Streams.Stream_IO, Ada.Tags, Report; + + procedure CXACC01 is + + Order_File : Ada.Streams.Stream_IO.File_Type; + Order_Stream : Ada.Streams.Stream_IO.Stream_Access; + Order_Filename : constant String := + Report.Legal_File_Name ( Nam => "CXACC01" ); + Incomplete : exception; + + begin + + Report.Test ("CXACC01", "Check that the use of 'Class'Output " & + "and 'Class'Input allow stream manipulation " & + "of objects of non-limited class-wide types"); + + Test_for_Stream_IO_Support: + begin + + -- If an implementation does not support Stream_IO in a particular + -- environment, the exception Use_Error or Name_Error will be raised on + -- calls to various Stream_IO operations. This block statement + -- encloses a call to Create, which should produce an exception in a + -- non-supportive environment. These exceptions will be handled to + -- produce a Not_Applicable result. + + Ada.Streams.Stream_IO.Create (Order_File, + Ada.Streams.Stream_IO.Out_File, + Order_Filename); + + exception + + when Ada.Streams.Stream_IO.Use_Error | Ada.Streams.Stream_IO.Name_Error => + Report.Not_Applicable + ( "Files not supported - Create as Out_File for Stream_IO" ); + raise Incomplete; + + end Test_for_Stream_IO_Support; + + Operational_Test_Block: + declare + + -- Store tag values associated with objects of tagged types. + + TC_Box_Office_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Ticket_Request'Tag); + + TC_Summer_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Subscriber_Request'Tag); + + TC_Mayoral_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.VIP_Request'Tag); + + TC_Late_Tag : constant String := + Ada.Tags.External_Tag(FXACC00.Last_Minute_Request'Tag); + + -- The following procedure will take an object of the Ticket_Request + -- class and output it to the stream. Objects of any extended type + -- in the class can be output to the stream with this procedure. + + procedure Order_Entry (Order : FXACC00.Ticket_Request'Class) is + begin + FXACC00.Ticket_Request'Class'Output (Order_Stream, Order); + end Order_Entry; + + + -- The following function will retrieve from the stream an object of + -- the Ticket_Request class. + + function Order_Retrieval return FXACC00.Ticket_Request'Class is + begin + return FXACC00.Ticket_Request'Class'Input (Order_Stream); + end Order_Retrieval; + + begin + + Order_Stream := Ada.Streams.Stream_IO.Stream (Order_File); + + -- Store the data objects in the stream. + -- Each of the objects is of a different type within the class. + + Order_Entry (FXACC00.Box_Office_Request); -- Object of root type + Order_Entry (FXACC00.Summer_Subscription); -- Obj. of extended type + Order_Entry (FXACC00.Mayoral_Ticket_Request); -- Obj. of extended type + Order_Entry (FXACC00.Late_Request); -- Object of twice + -- extended type. + + -- Reset mode of stream to In_File prior to reading data from it. + Reset1: + begin + Ada.Streams.Stream_IO.Reset (Order_File, + Ada.Streams.Stream_IO.In_File); + exception + when Ada.Streams.Stream_IO.Use_Error => + Report.Not_Applicable + ( "Reset to In_File not supported for Stream_IO - 1" ); + raise Incomplete; + end Reset1; + + Process_Order_Block: + declare + + use FXACC00; + + -- Declare variables of the root type class, + -- and initialize them with class-wide objects returned from + -- the stream as function result. + + Order_1 : Ticket_Request'Class := Order_Retrieval; + Order_2 : Ticket_Request'Class := Order_Retrieval; + Order_3 : Ticket_Request'Class := Order_Retrieval; + Order_4 : Ticket_Request'Class := Order_Retrieval; + + -- Declare objects of the specific types from within the class + -- that correspond to the types of the data written to the + -- stream. Perform a type conversion on the class-wide objects. + + Ticket_Order : Ticket_Request := + Ticket_Request(Order_1); + Subscriber_Order : Subscriber_Request := + Subscriber_Request(Order_2); + VIP_Order : VIP_Request := + VIP_Request(Order_3); + Last_Minute_Order : Last_Minute_Request := + Last_Minute_Request(Order_4); + + begin + + -- Perform a field-by-field comparison of all the class-wide + -- objects input from the stream with specific type objects + -- originally written to the stream. + + if Ticket_Order.Location /= + Box_Office_Request.Location or + Ticket_Order.Number_Of_Tickets /= + Box_Office_Request.Number_Of_Tickets + then + Report.Failed ("Ticket_Request object validation failure"); + end if; + + if Subscriber_Order.Location /= + Summer_Subscription.Location or + Subscriber_Order.Number_Of_Tickets /= + Summer_Subscription.Number_Of_Tickets or + Subscriber_Order.Subscription_Number /= + Summer_Subscription.Subscription_Number + then + Report.Failed ("Subscriber_Request object validation failure"); + end if; + + if VIP_Order.Location /= + Mayoral_Ticket_Request.Location or + VIP_Order.Number_Of_Tickets /= + Mayoral_Ticket_Request.Number_Of_Tickets or + VIP_Order.Rank /= + Mayoral_Ticket_Request.Rank + then + Report.Failed ("VIP_Request object validation failure"); + end if; + + if Last_Minute_Order.Location /= + Late_Request.Location or + Last_Minute_Order.Number_Of_Tickets /= + Late_Request.Number_Of_Tickets or + Last_Minute_Order.Rank /= + Late_Request.Rank or + Last_Minute_Order.Special_Consideration /= + Late_Request.Special_Consideration or + Last_Minute_Order.Donation /= + Late_Request.Donation + then + Report.Failed ("Last_Minute_Request object validation failure"); + end if; + + -- Verify tag values from before and after processing. + -- The 'Tag attribute is used with objects of a class-wide type. + + if TC_Box_Office_Tag /= + Ada.Tags.External_Tag(Order_1'Tag) + then + Report.Failed("Failed tag comparison - 1"); + end if; + + if TC_Summer_Tag /= + Ada.Tags.External_Tag(Order_2'Tag) + then + Report.Failed("Failed tag comparison - 2"); + end if; + + if TC_Mayoral_Tag /= + Ada.Tags.External_Tag(Order_3'Tag) + then + Report.Failed("Failed tag comparison - 3"); + end if; + + if TC_Late_Tag /= + Ada.Tags.External_Tag(Order_4'Tag) + then + Report.Failed("Failed tag comparison - 4"); + end if; + + end Process_Order_Block; + + -- After all the data has been correctly extracted, the file + -- should be empty. + + if not Ada.Streams.Stream_IO.End_Of_File (Order_File) then + Report.Failed ("Stream file not empty"); + end if; + + exception + when Incomplete => + raise; + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Operational Block"); + when others => + Report.Failed ("Exception raised in Operational Test Block"); + end Operational_Test_Block; + + Deletion: + begin + if Ada.Streams.Stream_IO.Is_Open (Order_File) then + Ada.Streams.Stream_IO.Delete (Order_File); + else + Ada.Streams.Stream_IO.Open (Order_File, + Ada.Streams.Stream_IO.Out_File, + Order_Filename); + Ada.Streams.Stream_IO.Delete (Order_File); + end if; + exception + when others => + Report.Failed + ( "Delete not properly implemented for Stream_IO" ); + end Deletion; + + Report.Result; + + exception + + when Incomplete => + Report.Result; + when others => + Report.Failed ( "Unexpected exception" ); + Report.Result; + + end CXACC01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxa/cxaf001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,199 ---- + -- CXAF001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that an implementation supports the functionality defined + -- in Package Ada.Command_Line. + -- + -- TEST DESCRIPTION: + -- This test verifies that an implementation supports the subprograms + -- contained in package Ada.Command_Line. Each of the subprograms + -- is exercised in a general sense, to ensure that it is available, + -- and that it provides the prescribed results in a known test + -- environment. Function Argument_Count must return zero, or the + -- number of arguments passed to the program calling it. Function + -- Argument is called with a parameter value one greater than the + -- actual number of arguments passed to the executing program, which + -- must result in Constraint_Error being raised. Function Command_Name + -- should return the name of the executing program that called it + -- (specifically, this test name). Function Set_Exit_Status is called + -- with two different parameter values, the constants Failure and + -- Success defined in package Ada.Command_Line. + -- + -- The setting of the variable TC_Verbose allows for some additional + -- output to be displayed during the running of the test as an aid in + -- tracing the processing flow of the test. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to implementations that support the + -- declaration of package Command_Line as defined in the Ada Reference + -- manual. + -- An alternative declaration is allowed for package Command_Line if + -- different functionality is appropriate for the external execution + -- environment. + -- + -- + -- CHANGE HISTORY: + -- 10 Jul 95 SAIC Initial prerelease version. + -- 02 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 05 AUG 98 EDS Allow Null string result to be returned from + -- Function Command + --! + + with Ada.Command_Line; + with Ada.Exceptions; + with Report; + + procedure CXAF001 is + begin + + Report.Test ("CXAF001", "Check that an implementation supports the " & + "functionality defined in Package " & + "Ada.Command_Line"); + + Test_Block: + declare + + use Ada.Exceptions; + + type String_Access is access all String; + + TC_Verbose : Boolean := False; + Number_Of_Arguments : Natural := Natural'Last; + Name_Of_Command : String_Access; + + begin + + -- Check the result of function Argument_Count. + -- Note: If the external environment does not support passing arguments + -- to the program invoking the function, the function result + -- will be zero. + + Number_Of_Arguments := Ada.Command_Line.Argument_Count; + if Number_Of_Arguments = Natural'Last then + Report.Failed("Argument_Count did not provide a return result"); + end if; + if TC_Verbose then + Report.Comment + ("Argument_Count = " & Integer'Image(Number_Of_Arguments)); + end if; + + + -- Check that the result of Function Argument is Constraint_Error + -- when the Number argument is outside the range of 1..Argument_Count. + + Test_Function_Argument_1 : + begin + declare + + -- Define a value that will be outside the range of + -- 1..Argument_Count. + -- Note: If the external execution environment does not support + -- passing arguments to a program, then Argument(N) for + -- any N will raise Constraint_Error, since + -- Argument_Count = 0; + + Arguments_Plus_One : Positive := + Ada.Command_Line.Argument_Count + 1; + + -- Using the above value in a call to Argument must result in + -- the raising of Constraint_Error. + + Argument_String : constant String := + Ada.Command_Line.Argument(Arguments_Plus_One); + + begin + Report.Failed("Constraint_Error not raised by Function " & + "Argument when provided a Number argument " & + "out of range"); + end; + exception + when Constraint_Error => null; -- OK, expected exception. + if TC_Verbose then + Report.Comment ("Argument_Count raised Constraint_Error"); + end if; + when others => + Report.Failed ("Unexpected exception raised by Argument " & + "in Test_Function_Argument_1 block"); + end Test_Function_Argument_1; + + + -- Check that Function Argument returns a string result. + + Test_Function_Argument_2 : + begin + if Ada.Command_Line.Argument_Count > 0 then + Report.Comment + ("Last argument is: " & + Ada.Command_Line.Argument(Ada.Command_Line.Argument_Count)); + elsif TC_Verbose then + Report.Comment("Argument_Count is zero, no test of Function " & + "Argument for string result"); + end if; + exception + when others => + Report.Failed ("Unexpected exception raised by Argument " & + "in Test_Function_Argument_2 block"); + end Test_Function_Argument_2; + + + -- Check the result of Function Command_Name. + + Name_Of_Command := new String'(Ada.Command_Line.Command_Name); + + if Name_Of_Command = null then + Report.Failed("Null string pointer returned from Function Command"); + elsif Name_Of_Command.all = "" then + Report.Comment("Null string result returned from Function Command"); + elsif TC_Verbose then + Report.Comment("Invoking command is " & Name_Of_Command.all); + end if; + + + -- Check that procedure Set_Exit_Status is available. + -- Note: If the external execution environment does not support + -- returning an exit value from a program, then Set_Exit_Status + -- does nothing. + + Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Failure); + if TC_Verbose then + Report.Comment("Exit status set to Failure"); + end if; + + Ada.Command_Line.Set_Exit_Status(Ada.Command_Line.Success); + if TC_Verbose then + Report.Comment("Exit status set to Success"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXAF001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,633 ---- + -- CXB2001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprograms Shift_Left, Shift_Right, + -- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available + -- and produce correct results for values of signed and modular + -- integer types of 8 bits. + -- + -- TEST DESCRIPTION: + -- This test uses the shift and rotate functions of package Interfaces + -- with a modular type representative of 8 bits. The functions + -- are used as the right hand of assignment statements, as part of + -- conditional statements, and as arguments in other function calls. + -- + -- A check is performed in the test to determine whether the bit + -- ordering method used by the machine/implementation is high-order + -- first ("Big Endian") or low-order first ("Little Endian"). The + -- specific subtests use this information to evaluate the results of + -- each of the functions under test. + -- + -- Note: In the string associated with each Report.Failed statement, the + -- acronym BE refers to Big Endian, LE refers to Little Endian. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support signed + -- and modular integer types of 8 bits. + -- + -- + -- CHANGE HISTORY: + -- 21 Aug 95 SAIC Initial prerelease version. + -- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- + --! + + with Report; + with Interfaces; + with Ada.Exceptions; + + procedure CXB2001 is + begin + + Report.Test ("CXB2001", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "produce correct results for values of signed and " & + "modular integer types of 8 bits"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces; + + TC_Amount : Natural := Natural'First; + Big_Endian : Boolean := False; + + -- Range of type Unsigned_8 is 0..255 (0..Modulus-1). + TC_Val_Unsigned_8, + TC_Result_Unsigned_8 : Unsigned_8 := Unsigned_8'First; + + begin + + -- Determine whether the machine uses high-order first or low-order + -- first bit ordering. + -- On a high-order first machine, bit zero of a storage element is + -- the most significant bit (interpreting the sequence of bits that + -- represent a component as an unsigned integer value). + -- On a low-order first machine, bit zero is the least significant. + -- In this check, a right shift of one place on a Big Endian machine + -- will yield a result of one, while on a Little Endian machine the + -- result would be four. + + TC_Val_Unsigned_8 := 2; + Big_Endian := (Shift_Right(TC_Val_Unsigned_8, 1) = 1); + + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + -- Function Shift_Left. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Left(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed("Incorrect result from BE Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_8, 2) /= 252 or + Shift_Left(TC_Val_Unsigned_8, 3) /= 248 or + Shift_Left(TC_Val_Unsigned_8, 5) /= 224 or + Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 9) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Shift_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Left(TC_Val_Unsigned_8, 1) /= 2 or + Shift_Left(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from BE Shift_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 7; + if Shift_Left(TC_Val_Unsigned_8, Amount => 4) /= 112 or + Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Left - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Left(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 127 then + Report.Failed("Incorrect result from LE Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_8, 2) /= 63 or + Shift_Left(TC_Val_Unsigned_8, 3) /= 31 or + Shift_Left(TC_Val_Unsigned_8, 5) /= 7 or + Shift_Left(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Shift_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Left(TC_Val_Unsigned_8, 1) /= 0 or + Shift_Left(TC_Val_Unsigned_8, 7) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 129; + if Shift_Left(TC_Val_Unsigned_8, 4) /= 8 or + Shift_Left(Shift_Left(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Left - 4"); + end if; + + end if; + + + + -- Function Shift_Right. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Right(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 127 then + Report.Failed("Incorrect result from BE Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_8, 2) /= 63 or + Shift_Right(TC_Val_Unsigned_8, 3) /= 31 or + Shift_Right(TC_Val_Unsigned_8, 5) /= 7 or + Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Shift_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right(TC_Val_Unsigned_8, 1) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 7) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 129; + if Shift_Right(TC_Val_Unsigned_8, 4) /= 8 or + Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Right - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := Unsigned_8'Last; -- 255. + TC_Result_Unsigned_8 := Shift_Right(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed("Incorrect result from LE Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_8, 2) /= 252 or + Shift_Right(TC_Val_Unsigned_8, 3) /= 248 or + Shift_Right(TC_Val_Unsigned_8, 5) /= 224 or + Shift_Right(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 9) /= 0 or + Shift_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Shift_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right(TC_Val_Unsigned_8, 1) /= 2 or + Shift_Right(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from LE Shift_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 7; + if Shift_Right(TC_Val_Unsigned_8, Amount => 4) /= 112 or + Shift_Right(Shift_Right(TC_Val_Unsigned_8, 7), 1) /= 0 + then + Report.Failed("Incorrect result from LE Shift_Right - 4"); + end if; + + end if; + + + + -- Tests of Shift_Left and Shift_Right in combination. + + if Big_Endian then -- High-order first bit ordering. + + TC_Val_Unsigned_8 := 32; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 128 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 6) /= 2 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 8) /= 0 + then + Report.Failed("Incorrect result from BE Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + else -- Low-order first bit ordering. + + TC_Val_Unsigned_8 := 32; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Shift_Left(Shift_Right(TC_Val_Unsigned_8, 1), 3) /= 8 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 3) /= 64 or + Shift_Right(Shift_Left(TC_Val_Unsigned_8, 2), 4) /= 128 + then + Report.Failed("Incorrect result from LE Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + end if; + + + + -- Function Shift_Right_Arithmetic. + + if Big_Endian then -- High-order first bit ordering. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + -- Modulus of type Unsigned_8 is 256; half of the modulus is 128. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 127; -- Less than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + TC_Amount); + if TC_Result_Unsigned_8 /= 63 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 15 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 3 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 3"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 128; -- One half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 192 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 4"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 192 then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 5"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 224 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 240 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 252 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 6"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /= + Unsigned_8'Last + then + Report.Failed + ("Incorrect result from BE Shift_Right_Arithmetic - 7"); + end if; + + else -- Low-order first bit ordering + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 127; -- Less than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + TC_Amount); + if TC_Result_Unsigned_8 /= 254 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 1"); + end if; + + TC_Val_Unsigned_8 := 2; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 8 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= 64 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 8) /= 0 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 2"); + end if; + + TC_Val_Unsigned_8 := 64; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, Amount => 1) /= 128 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 0 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 3"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 128; -- One half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + + if TC_Result_Unsigned_8 /= 3 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 4"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; -- Greater than one half of modulus. + TC_Result_Unsigned_8 := Shift_Right_Arithmetic(TC_Val_Unsigned_8, + Amount => TC_Amount); + + if TC_Result_Unsigned_8 /= 3 then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 5"); + end if; + + TC_Val_Unsigned_8 := 135; -- Greater than one half of modulus. + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 2) /= 31 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 3) /= 63 or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 5) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 7) /= Unsigned_8'Last or + Shift_Right_Arithmetic(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 6"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Shift_Right_Arithmetic(TC_Val_Unsigned_8, 1) /= + Unsigned_8'Last + then + Report.Failed + ("Incorrect result from LE Shift_Right_Arithmetic - 7"); + end if; + + end if; + + + + -- Function Rotate_Left. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; + TC_Result_Unsigned_8 := Rotate_Left(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 3 then + Report.Failed("Incorrect result from BE Rotate_Left - 1"); + end if; + + if Rotate_Left(TC_Val_Unsigned_8, 2) /= 6 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 12 or + Rotate_Left(TC_Val_Unsigned_8, 5) /= 48 or + Rotate_Left(TC_Val_Unsigned_8, 8) /= 129 or + Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Rotate_Left - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Rotate_Left(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or + Rotate_Left(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from BE Rotate_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 82; + if Rotate_Left(TC_Val_Unsigned_8, Amount => 4) /= 37 or + Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 82 + then + Report.Failed("Incorrect result from BE Rotate_Left - 4"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 1; + TC_Result_Unsigned_8 := Rotate_Left(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 128 then + Report.Failed("Incorrect result from LE Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_8 := 15; + if Rotate_Left(TC_Val_Unsigned_8, 2) /= 195 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 225 or + Rotate_Left(TC_Val_Unsigned_8, 5) /= 120 or + Rotate_Left(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or + Rotate_Left(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Rotate_Left - 2"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Rotate_Left(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then + Report.Failed("Incorrect result from LE Rotate_Left - 3"); + end if; + + TC_Val_Unsigned_8 := 12; + if Rotate_Left(TC_Val_Unsigned_8, 1) /= 6 or + Rotate_Left(TC_Val_Unsigned_8, 3) /= 129 + then + Report.Failed("Incorrect result from LE Rotate_Left - 4"); + end if; + + TC_Val_Unsigned_8 := 129; + if Rotate_Left(TC_Val_Unsigned_8, 4) /= 24 or + Rotate_Left(Rotate_Left(TC_Val_Unsigned_8, 7), 1) /= 129 + then + Report.Failed("Incorrect result from LE Rotate_Left - 5"); + end if; + + end if; + + + + -- Function Rotate_Right. + + if Big_Endian then -- High-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 1; + TC_Result_Unsigned_8 := Rotate_Right(TC_Val_Unsigned_8, TC_Amount); + + if TC_Result_Unsigned_8 /= 128 then + Report.Failed("Incorrect result from BE Rotate_Right - 1"); + end if; + + TC_Val_Unsigned_8 := 15; + if Rotate_Right(TC_Val_Unsigned_8, 2) /= 195 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 225 or + Rotate_Right(TC_Val_Unsigned_8, 5) /= 120 or + Rotate_Right(TC_Val_Unsigned_8, 8) /= TC_Val_Unsigned_8 or + Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from BE Rotate_Right - 2"); + end if; + + TC_Val_Unsigned_8 := Unsigned_8'Last; + if Rotate_Right(TC_Val_Unsigned_8, 1) /= Unsigned_8'Last then + Report.Failed("Incorrect result from BE Rotate_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 12; + if Rotate_Right(TC_Val_Unsigned_8, 1) /= 6 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 129 + then + Report.Failed("Incorrect result from BE Rotate_Right - 4"); + end if; + + TC_Val_Unsigned_8 := 129; + if Rotate_Right(TC_Val_Unsigned_8, 4) /= 24 or + Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 129 + then + Report.Failed("Incorrect result from BE Rotate_Right - 5"); + end if; + + else -- Low-order first bit ordering. + + TC_Amount := 1; + TC_Val_Unsigned_8 := 129; + TC_Result_Unsigned_8 := Rotate_Right(Value => TC_Val_Unsigned_8, + Amount => TC_Amount); + if TC_Result_Unsigned_8 /= 3 then + Report.Failed("Incorrect result from LE Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_8, 2) /= 6 or + Rotate_Right(TC_Val_Unsigned_8, 3) /= 12 or + Rotate_Right(TC_Val_Unsigned_8, 5) /= 48 or + Rotate_Right(TC_Val_Unsigned_8, 8) /= 129 or + Rotate_Right(TC_Val_Unsigned_8, 0) /= TC_Val_Unsigned_8 + then + Report.Failed("Incorrect result from LE Rotate_Right - 2"); + end if; + + TC_Val_Unsigned_8 := 1; + if Rotate_Right(Value => TC_Val_Unsigned_8, Amount => 1) /= 2 or + Rotate_Right(TC_Val_Unsigned_8, Amount => 3) /= 8 + then + Report.Failed("Incorrect result from LE Rotate_Right - 3"); + end if; + + TC_Val_Unsigned_8 := 82; + if Rotate_Right(TC_Val_Unsigned_8, Amount => 4) /= 37 or + Rotate_Right(Rotate_Right(TC_Val_Unsigned_8, 7), 1) /= 82 + then + Report.Failed("Incorrect result from LE Rotate_Right - 4"); + end if; + + end if; + + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + if Big_Endian then -- High-order first bit ordering. + + TC_Val_Unsigned_8 := 17; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 68 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 17 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 68 + then + Report.Failed("Incorrect result from BE Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + else -- Low-order first bit ordering. + + TC_Val_Unsigned_8 := 4; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 2), 2) /= + TC_Val_Unsigned_8 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_8, 1), 3) /= 1 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 3), 7) /= 64 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_8, 2), 8) /= 1 + then + Report.Failed("Incorrect result from LE Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + end if; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB2001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,259 ---- + -- CXB2002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprograms Shift_Left, Shift_Right, + -- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available + -- and produce correct results for values of signed and modular + -- integer types of 16 bits. + -- + -- TEST DESCRIPTION: + -- This test uses the shift and rotate functions of package Interfaces + -- with a modular type representative of 16 bits. The functions + -- are used as the right hand of assignment statements, as part of + -- conditional statements, and as arguments in other function calls. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support signed + -- and modular integer types of 16 bits. + -- + -- + -- CHANGE HISTORY: + -- 21 Aug 95 SAIC Initial prerelease version. + -- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Removed subtests based on Big/Little Endian. + -- 17 Feb 97 PWB.CTA Corrected "-" to "+" in parenthesized expressions. + --! + + with Report; + with Interfaces; + with Ada.Exceptions; + + procedure CXB2002 is + begin + + Report.Test ("CXB2002", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "produce correct results for values of signed and " & + "modular integer types of 16 bits"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces; + + TC_Amount : Natural := Natural'First; + + -- Range of type Unsigned_16 is 0..65535 (0..Modulus-1). + TC_Val_Unsigned_16, + TC_Result_Unsigned_16 : Unsigned_16 := Unsigned_16'First; + + begin + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + -- Function Shift_Left. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Shift_Left(TC_Val_Unsigned_16, TC_Amount); + + if TC_Result_Unsigned_16 /= Unsigned_16'Last - (2**0 + 2**1 + 2**2) + then + Report.Failed("Incorrect result from Shift_Left - 1"); + end if; + + if Shift_Left(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or + Shift_Left(TC_Val_Unsigned_16, 5) /= + Unsigned_16'Last - (2**0 + 2**1 + 2**2 + 2**3 +2**4) or + Shift_Left(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Left - 2"); + end if; + + + -- Function Shift_Right. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Shift_Right(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + + if TC_Result_Unsigned_16 /= Unsigned_16'Last-(2**15 + 2**14 + 2**13) + then + Report.Failed("Incorrect result from Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_16, 0) /= Unsigned_16'Last or + Shift_Right(TC_Val_Unsigned_16, 5) /= + Unsigned_16'Last-(2**15 + 2**14 + 2**13 + 2**12 + 2**11) or + Shift_Right(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Right - 2"); + end if; + + + -- Tests of Shift_Left and Shift_Right in combination. + + TC_Val_Unsigned_16 := Unsigned_16'Last; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_16, 4), 4) /= + Unsigned_16'Last-(2**0 + 2**1 + 2**2 + 2**3) or + Shift_Left(Shift_Right(TC_Val_Unsigned_16, 1), 3) /= + Unsigned_16'Last-(2**0 + 2**1 + 2**2) or + Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 4) /= + Unsigned_16'Last-(2**15+ 2**14 + 2**13 + 2**12) or + Shift_Right(Shift_Left(TC_Val_Unsigned_16, 2), 16) /= 0 + then + Report.Failed("Incorrect result from Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + + -- Function Shift_Right_Arithmetic. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + -- Modulus of type Unsigned_16 is 2**16; one half is 2**15. + + TC_Amount := 3; + TC_Val_Unsigned_16 := 2**15 - 1; -- Less than one half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= + TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /= + TC_Val_Unsigned_16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 5) /= + TC_Val_Unsigned_16 - (2**14 + 2**13 + 2**12 + 2**11 + 2**10) or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= 0 + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 2"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**15; -- One half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 3"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**15 + 1; -- Greater than half of modulus. + TC_Result_Unsigned_16 := Shift_Right_Arithmetic(TC_Val_Unsigned_16, + TC_Amount); + if TC_Result_Unsigned_16 /= TC_Val_Unsigned_16 + 2**14 - 2**0 then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 4"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_16, 0) /= + TC_Val_Unsigned_16 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 4) /= + TC_Val_Unsigned_16 - 2**0 + 2**14 + 2**13 + 2**12 + 2**11 or + Shift_Right_Arithmetic(TC_Val_Unsigned_16, 16) /= Unsigned_16'Last + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 5"); + end if; + + + -- Function Rotate_Left. + + TC_Amount := 3; + TC_Val_Unsigned_16 := Unsigned_16'Last; -- 65535. + TC_Result_Unsigned_16 := Rotate_Left(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + if TC_Result_Unsigned_16 /= Unsigned_16'Last then + Report.Failed("Incorrect result from Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_16 := 2**15 + 2**14 + 2**1 + 2**0; + if Rotate_Left(TC_Val_Unsigned_16, 0) /= + 2**15 + 2**14 + 2**1 + 2**0 or + Rotate_Left(TC_Val_Unsigned_16, 5) /= + 2**6 + 2**5 + 2**4 + 2**3 or + Rotate_Left(TC_Val_Unsigned_16, 16) /= TC_Val_Unsigned_16 + then + Report.Failed("Incorrect result from Rotate_Left - 2"); + end if; + + + -- Function Rotate_Right. + + TC_Amount := 1; + TC_Val_Unsigned_16 := 2**1 + 2**0; + TC_Result_Unsigned_16 := Rotate_Right(Value => TC_Val_Unsigned_16, + Amount => TC_Amount); + if TC_Result_Unsigned_16 /= 2**15 + 2**0 then + Report.Failed("Incorrect result from Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_16, 0) /= 2**1 + 2**0 or + Rotate_Right(TC_Val_Unsigned_16, 5) /= 2**12 + 2**11 or + Rotate_Right(TC_Val_Unsigned_16, 16) /= 2**1 + 2**0 + then + Report.Failed("Incorrect result from Rotate_Right - 2"); + end if; + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + TC_Val_Unsigned_16 := 32769; + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 4), 3) /= 49152 or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_16, 1), 3) /= 6 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 3), 7) /= 6144 or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_16, 1), 16) /= 3 + then + Report.Failed("Incorrect result from Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB2002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb2003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,255 ---- + -- CXB2003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that subprograms Shift_Left, Shift_Right, + -- Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right are available + -- and produce correct results for values of signed and modular + -- integer types of 32 bits. + -- + -- TEST DESCRIPTION: + -- This test uses the shift and rotate functions of package Interfaces + -- with a modular type representative of 32 bits. The functions + -- are used as the right hand of assignment statements, as part of + -- conditional statements, and as arguments in other function calls. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that support signed + -- and modular integer types of 32 bits. + -- + -- + -- CHANGE HISTORY: + -- 23 Aug 95 SAIC Initial prerelease version. + -- 07 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Removed all references to Big/Little endian. + -- + --! + + with Report; + with Interfaces; + with Ada.Exceptions; + + procedure CXB2003 is + begin + + Report.Test ("CXB2003", + "Check that subprograms Shift_Left, Shift_Right, " & + "Shift_Right_Arithmetic, Rotate_Left, and Rotate_Right " & + "are available and produce correct results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + + TC_Amount : Natural := Natural'First; + + -- Range of type Unsigned_32 is 0..(2**32)-1 (0..Modulus-1). + TC_Val_Unsigned_32, + TC_Result_Unsigned_32 : Unsigned_32 := Unsigned_32'First; + + begin + + -- Note: The shifting and rotating subprograms operate on a bit-by-bit + -- basis, using the binary representation of the value of the + -- operands to yield a binary representation for the result. + + + -- Function Shift_Left. + + TC_Amount := 2; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Shift_Left(TC_Val_Unsigned_32, TC_Amount); + + if TC_Result_Unsigned_32 /= Unsigned_32'Last - (2**0 + 2**1) then + Report.Failed("Incorrect result from Shift_Left - 1"); + end if; + + TC_Result_Unsigned_32 := Unsigned_32'Last - (2**0 + 2**1 + 2**2 + + 2**3 + 2**4); + if Shift_Left(TC_Val_Unsigned_32, 5) /= TC_Result_Unsigned_32 or + Shift_Left(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last + then + Report.Failed("Incorrect result from Shift_Left - 2"); + end if; + + + -- Function Shift_Right. + + TC_Amount := 3; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Shift_Right(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= + Unsigned_32'Last - (2**31 + 2**30 + 2**29) + then + Report.Failed("Incorrect result from Shift_Right - 1"); + end if; + + if Shift_Right(TC_Val_Unsigned_32, 0) /= Unsigned_32'Last or + Shift_Right(TC_Val_Unsigned_32, 2) /= Unsigned_32'Last - + (2**31 + 2**30) + then + Report.Failed("Incorrect result from Shift_Right - 2"); + end if; + + + -- Tests of Shift_Left and Shift_Right in combination. + + TC_Val_Unsigned_32 := Unsigned_32'Last; + + if Shift_Left(Shift_Right(TC_Val_Unsigned_32, 4), 4) /= + Unsigned_32'Last - (2**0 + 2**1 + 2**2 + 2**3) or + Shift_Left(Shift_Right(TC_Val_Unsigned_32, 3), 1) /= + Unsigned_32'Last - (2**31 + 2**30 + 2**0) or + Shift_Left(Shift_Right(TC_Val_Unsigned_32, 5), 3) /= + Unsigned_32'Last - (2**31 + 2**30 + 2**2 + 2**1 + 2**0) or + Shift_Right(Shift_Left(TC_Val_Unsigned_32, 2), 1) /= + Unsigned_32'Last - (2**31 + 2**0) + then + Report.Failed("Incorrect result from Shift_Left - " & + "Shift_Right functions used in combination"); + end if; + + + -- Function Shift_Right_Arithmetic. + + -- Case where the parameter Value is less than + -- one half of the modulus. Zero bits will be shifted in. + + TC_Amount := 3; + TC_Val_Unsigned_32 := 2**15 + 2**10 + 2**1; + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**12 + 2**7) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 1"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /= + TC_Val_Unsigned_32 or + Shift_Right_Arithmetic(TC_Val_Unsigned_32, 5) /= + (2**10 + 2**5) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 2"); + end if; + + -- Case where the parameter Value is greater than or equal to + -- one half of the modulus. One bits will be shifted in. + + TC_Amount := 1; + TC_Val_Unsigned_32 := 2**31; -- One half of modulus + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 3"); + end if; + + TC_Amount := 1; + TC_Val_Unsigned_32 := (2**31 + 2**1); + TC_Result_Unsigned_32 := Shift_Right_Arithmetic(TC_Val_Unsigned_32, + TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30 + 2**0) then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 4"); + end if; + + if Shift_Right_Arithmetic(TC_Val_Unsigned_32, 0) /= + TC_Val_Unsigned_32 or + Shift_Right_Arithmetic(TC_Val_Unsigned_32, 3) /= + (2**31 + 2**30 + 2**29 + 2**28) + then + Report.Failed + ("Incorrect result from Shift_Right_Arithmetic - 5"); + end if; + + + -- Function Rotate_Left. + + TC_Amount := 3; + TC_Val_Unsigned_32 := Unsigned_32'Last; + TC_Result_Unsigned_32 := Rotate_Left(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= Unsigned_32'Last then + Report.Failed("Incorrect result from Rotate_Left - 1"); + end if; + + TC_Val_Unsigned_32 := 2**31 + 2**30; + if Rotate_Left(TC_Val_Unsigned_32, 1) /= (2**31 + 2**0) or + Rotate_Left(TC_Val_Unsigned_32, 5) /= (2**4 + 2**3) or + Rotate_Left(TC_Val_Unsigned_32, 32) /= TC_Val_Unsigned_32 + then + Report.Failed("Incorrect result from Rotate_Left - 2"); + end if; + + + -- Function Rotate_Right. + + TC_Amount := 2; + TC_Val_Unsigned_32 := (2**1 + 2**0); + TC_Result_Unsigned_32 := Rotate_Right(Value => TC_Val_Unsigned_32, + Amount => TC_Amount); + if TC_Result_Unsigned_32 /= (2**31 + 2**30) then + Report.Failed("Incorrect result from Rotate_Right - 1"); + end if; + + if Rotate_Right(TC_Val_Unsigned_32, 3) /= (2**30 + 2**29) or + Rotate_Right(TC_Val_Unsigned_32, 6) /= (2**27 + 2**26) or + Rotate_Right(TC_Val_Unsigned_32, 32) /= (2**1 + 2**0) + then + Report.Failed("Incorrect result from Rotate_Right - 2"); + end if; + + + -- Tests of Rotate_Left and Rotate_Right in combination. + + TC_Val_Unsigned_32 := (2**31 + 2**15 + 2**3); + + if Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 4), 3) /= + (2**30 + 2**14 + 2**2) or + Rotate_Left(Rotate_Right(TC_Val_Unsigned_32, 1), 3) /= + (2**17 + 2**5 + 2**1) or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 3), 7) /= + (2**31 + 2**27 + 2**11) or + Rotate_Right(Rotate_Left(TC_Val_Unsigned_32, 1), 32) /= + (2**16 + 2**4 + 2**0) + then + Report.Failed("Incorrect result from Rotate_Left - " & + "Rotate_Right functions used in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB2003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,179 ---- + -- CXB3001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specifications of the package Interfaces.C are + -- available for use. + -- + -- TEST DESCRIPTION: + -- This test verifies that the types and subprograms specified for the + -- interface are present. It just checks for the presence of + -- the subprograms. Other tests are designed to exercise the interface. + -- + -- APPLICABILITY CRITERIA: + -- If an implementation provides package Interfaces.C, this test + -- must compile, execute, and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Corrected To_C parameter list for ACVC 2.0.1. + -- 28 Feb 96 SAIC Added applicability criteria. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + + procedure CXB3001 is + package C renames Interfaces.C; + use type C.signed_char; + use type C.unsigned_char; + use type C.char; + + begin + + Report.Test ("CXB3001", "Check the specification of Interfaces.C"); + + declare -- encapsulate the test + + + tst_CHAR_BIT : constant := C.CHAR_BIT; + tst_SCHAR_MIN : constant := C.SCHAR_MIN; + tst_SCHAR_MAX : constant := C.SCHAR_MAX; + tst_UCHAR_MAX : constant := C.UCHAR_MAX; + + -- Signed and Unsigned Integers + + tst_int : C.int := C.int'first; + tst_short : C.short := C.short'first; + tst_long : C.long := C.long'first; + + tst_signed_char_min : C.signed_char := C.signed_char'first; + tst_signed_char_max : C.signed_char := C.signed_char'last; + + tst_unsigned : C.unsigned; + tst_unsigned_short : C.unsigned_short; + tst_unsigned_long : C.unsigned_long; + + tst_unsigned_char : C.unsigned_char; + tst_plain_char : C.plain_char; + + tst_ptrdiff_t : C.ptrdiff_t; + tst_size_t : C.size_t; + + -- Floating-Point + + tst_C_float : C.C_float; + tst_double : C.double; + tst_long_double : C.long_double; + + -- Characters and Strings + + tst_char : C.char; + tst_nul : C.char := C.nul; + + -- Collect all the subprogram calls such that they are compiled + -- but not executed + -- + procedure Collect_All_Calls is + + CAC_char : C.char; + CAC_Character : Character; + CAC_String : string (1..5); + CAC_Boolean : Boolean := false; + CAC_char_array : C.char_array(1..5); + CAC_Integer : integer; + CAC_Natural : natural; + CAC_wchar_t : C.wchar_t; + CAC_Wide_Character : Wide_Character; + CAC_wchar_array : C.wchar_array(1..5); + CAC_Wide_String : Wide_String(1..5); + CAC_size_t : C.size_t; + + begin + + CAC_char := C.To_C (CAC_Character); + CAC_Character := C.To_Ada (CAC_char); + + CAC_char_array := C.To_C (CAC_String, CAC_Boolean); + CAC_String := C.To_Ada (CAC_char_array, CAC_Boolean); + + -- This call is out of LRM order so that we can use the + -- array initialized above + CAC_Boolean := C.Is_Nul_Terminated (CAC_char_array); + + C.To_C (CAC_String, CAC_char_array, CAC_size_t, CAC_Boolean); + C.To_Ada (CAC_char_array, CAC_String, CAC_Natural, CAC_Boolean); + + CAC_wchar_t := C.To_C (CAC_Wide_Character); + CAC_Wide_Character := C.To_Ada (CAC_wchar_t); + CAC_wchar_t := C.wide_nul; + + CAC_wchar_array := C.To_C (CAC_Wide_String, CAC_Boolean); + CAC_Wide_String := C.To_Ada (CAC_wchar_array, CAC_Boolean); + + -- This call is out of LRM order so that we can use the + -- array initialized above + CAC_Boolean := C.Is_Nul_Terminated (CAC_wchar_array); + + C.To_C (CAC_Wide_String, CAC_wchar_array, CAC_size_t, CAC_Boolean); + C.To_Ada (CAC_wchar_array, CAC_Wide_String, CAC_Natural, CAC_Boolean); + + raise C.Terminator_Error; + + end Collect_All_Calls; + + + + begin -- encapsulation + + if tst_signed_char_min /= C.SCHAR_MIN then + Report.Failed ("tst_signed_char_min is incorrect"); + end if; + if tst_signed_char_max /= C.SCHAR_MAX then + Report.Failed ("tst_signed_char_max is incorrect"); + end if; + if C.signed_char'Size /= C.CHAR_BIT then + Report.Failed ("C.signed_char'Size is incorrect"); + end if; + + if C.unsigned_char'first /= 0 or + C.unsigned_char'last /= C.UCHAR_MAX or + C.unsigned_char'size /= C.CHAR_BIT then + + Report.Failed ("unsigned_char is incorrectly defined"); + + end if; + + if tst_nul /= C.char'first then + Report.Failed ("tst_nul is incorrect"); + end if; + + end; -- encapsulation + + Report.Result; + + end CXB3001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,158 ---- + -- CXB3002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specifications of the package Interfaces.C.Strings + -- are available for use. + -- + -- TEST DESCRIPTION: + -- This test verifies that the types and subprograms specified for the + -- interface are present + -- + -- APPLICABILITY CRITERIA: + -- If an implementation provides packages Interfaces.C and + -- Interfaces.C.Strings, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 96 SAIC Added applicability criteria. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + with Interfaces.C.Strings; -- N/A => ERROR + + procedure CXB3002 is + package Strings renames Interfaces.C.Strings; + package C renames Interfaces.C; + + begin + + Report.Test ("CXB3002", "Check the specification of Interfaces.C.Strings"); + + + declare -- encapsulate the test + + TC_Int_1 : integer := 1; + TC_Int_2 : integer := 1; + TC_String : String := "ABCD"; + TC_Boolean : Boolean := true; + TC_char_array : C.char_array (1..5); + TC_size_t : C.size_t := C.size_t'first; + + + -- Note In all of the following the Strings spec. being tested + -- is shown in comment lines + -- + -- type char_array_access is access all char_array; + TST_char_array_access : Strings.char_array_access := + new Interfaces.C.char_array (1..5); + + -- type chars_ptr is private; + -- Null_Ptr : constant chars_ptr; + TST_chars_ptr : Strings.chars_ptr := Strings.Null_ptr; + + -- type chars_ptr_array is array (size_t range <>) of chars_ptr; + TST_chars_ptr_array : Strings.chars_ptr_array(1..5); + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int_1, TC_Int_2 ) then + + -- function To_Chars_Ptr (Item : in char_array_access; + -- Nul_Check : in Boolean := False) + -- return chars_ptr; + TST_chars_ptr := Strings.To_Chars_Ptr + (TST_char_array_access, TC_Boolean); + + -- This one is out of LRM order so that we can "initialize" + -- TC_char_array for the "in" parameter of the next one + -- + -- function Value (Item : in chars_ptr) return char_array; + TC_char_array := Strings.Value (TST_chars_ptr); + + -- function New_Char_Array (Chars : in char_array) + -- return chars_ptr; + TST_chars_ptr := Strings.New_Char_Array (TC_char_array); + + -- function New_String (Str : in String) return chars_ptr; + TST_chars_ptr := Strings.New_String ("TEST STRING"); + + -- procedure Free (Item : in out chars_ptr); + Strings.Free (TST_chars_ptr); + + -- function Value (Item : in chars_ptr; Length : in size_t) + -- return char_array; + TC_char_array := Strings.Value (TST_chars_ptr, TC_size_t); + + -- Use Report.Comment as a known procedure which takes a string as + -- a parameter (this does not actually get output) + -- function Value (Item : in chars_ptr) return String; + Report.Comment ( Strings.Value (TST_chars_ptr) ); + + -- function Value (Item : in chars_ptr; Length : in size_t) + -- return String; + TC_String := Strings.Value (TST_chars_ptr, TC_size_t); + + -- function Strlen (Item : in chars_ptr) return size_t; + TC_size_t := Strings.Strlen (TST_chars_ptr); + + -- procedure Update (Item : in chars_ptr; + -- Offset : in size_t; + -- Chars : in char_array; + -- Check : in Boolean := True); + Strings.Update (TST_chars_ptr, TC_size_t, TC_char_array, TC_Boolean); + + -- procedure Update (Item : in chars_ptr; + -- Offset : in size_t; + -- Str : in String; + -- Check : in Boolean := True); + Strings.Update (TST_chars_ptr, TC_size_t, TC_String, TC_Boolean); + + -- Update_Error : exception; + raise Strings.Update_Error; + + end if; + + if not Report.Equal ( TC_Int_2, TC_Int_1 ) then + + -- This exception is out of LRM presentation order to avoid + -- compiler warnings about unreachable code + -- Dereference_Error : exception; + raise Strings.Dereference_Error; + + end if; + + end; -- encapsulation + + Report.Result; + + end CXB3002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- CXB3003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specifications of the package Interfaces.C.Pointers + -- are available for use. + -- + -- TEST DESCRIPTION: + -- This test verifies that the types and subprograms specified for the + -- interface are present + -- + -- APPLICABILITY CRITERIA: + -- If an implementation provides package Interfaces.C.Pointers, this + -- test must compile, execute, and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 96 SAIC Added applicability criteria. + -- + --! + + with Report; + with Interfaces.C.Pointers; -- N/A => ERROR + + procedure CXB3003 is + package C renames Interfaces.C; + + package Test_Ptrs is new C.Pointers + (Index => C.size_t, + Element => C.Char, + Element_Array => C.Char_Array, + Default_Terminator => C.Nul); + + begin + + Report.Test ("CXB3003", "Check the specification of Interfaces.C.Pointers"); + + + declare -- encapsulate the test + + TC_Int : integer := 1; + + -- Note: In all of the following the Pointers spec. being tested + -- is shown in comments + -- + -- type Pointer is access all Element; + subtype TST_Pointer_Type is Test_Ptrs.Pointer; + + TST_Element : C.Char := C.Char'First; + TST_Pointer : TST_Pointer_Type := null; + TST_Pointer_2 : TST_Pointer_Type := null; + TST_Array : C.char_array (1..5); + TST_Index : C.ptrdiff_t := C.ptrdiff_t'First; + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int, TC_Int ) then + + + -- function Value (Ref : in Pointer; + -- Terminator : in Element := Default_Terminator) + -- return Element_Array; + + TST_Array := Test_Ptrs.Value ( TST_Pointer ); -- default + TST_Array := Test_Ptrs.Value ( TST_Pointer, TST_Element ); + + -- function Value (Ref : in Pointer; Length : in ptrdiff_t) + -- return Element_Array; + + TST_Array := Test_Ptrs.Value (TST_Pointer, TST_Index); + + -- + -- -- C-style Pointer arithmetic + -- + -- function "+" (Left : in Pointer; Right : in ptrdiff_t) + -- return Pointer; + TST_Pointer := Test_Ptrs."+" (TST_Pointer, TST_Index); + + -- function "+" (Left : in Ptrdiff_T; Right : in Pointer) + -- return Pointer; + TST_Pointer := Test_Ptrs."+" (TST_Index, TST_Pointer); + + -- function "-" (Left : in Pointer; Right : in ptrdiff_t) + -- return Pointer; + TST_Pointer := Test_Ptrs."-" (TST_Pointer, TST_Index); + + -- function "-" (Left : in Pointer; Right : in Pointer) + -- return ptrdiff_t; + TST_Index := Test_Ptrs."-" (TST_Pointer, TST_Pointer); + + -- procedure Increment (Ref : in out Pointer); + Test_Ptrs.Increment (TST_Pointer); + + -- procedure Decrement (Ref : in out Pointer); + Test_Ptrs.Decrement (TST_Pointer); + + -- function Virtual_Length + -- ( Ref : in Pointer; + -- Terminator : in Element := Default_Terminator) + -- return ptrdiff_t; + TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer); + TST_Index := Test_Ptrs.Virtual_Length (TST_Pointer, TST_Element); + + -- procedure Copy_Terminated_Array + -- (Source : in Pointer; + -- Target : in Pointer; + -- Limit : in ptrdiff_t := ptrdiff_t'Last; + -- Terminator : in Element := Default_Terminator); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, TST_Pointer_2); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, + TST_Pointer_2, + TST_Index); + + Test_Ptrs.Copy_Terminated_Array (TST_Pointer, + TST_Pointer_2, + TST_Index, + TST_Element); + + + -- procedure Copy_Array + -- (Source : in Pointer; + -- Target : in Pointer; + -- Length : in ptrdiff_t); + + Test_Ptrs.Copy_Array (TST_Pointer, TST_Pointer_2, TST_Index); + + -- This is out of LRM order to avoid complaints from compilers + -- about inaccessible code + -- Pointer_Error : exception; + + raise Test_Ptrs.Pointer_Error; + + end if; + + end; -- encapsulation + + Report.Result; + + end CXB3003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30040.c 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,172 ---- + /* + -- CXB30040.C + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FUNCTION NAME: CXB30040 ("char_gen") + -- + -- FUNCTION DESCRIPTION: + -- This C function returns the value of type char corresponding to the + -- value of its parameter, where + -- Val 0 .. 9 ==> '0' .. '9' + -- Val 10 .. 19 ==> 'A' .. 'J' + -- Val 20 .. 29 ==> 'k' .. 't' + -- Val 30 ==> ' ' + -- Val 31 ==> '.' + -- Val 32 ==> ',' + -- + -- INPUT: + -- This function requires that one int parameter be passed to it. + -- + -- OUTPUT: + -- The function will return the appropriate value of type char. + -- + -- CHANGE HISTORY: + -- 13 Sep 99 RLB Created function to replace incorrect + -- Unchecked_Conversion. + -- + --! + */ + + char CXB30040 (int val) + + /* NOTE: The above function definition should be accepted by an ANSI-C */ + /* compiler. Older C compilers may reject it; they may, however */ + /* accept the following two lines. An implementation may comment */ + /* out the above function definition and uncomment the following */ + /* one. Otherwise, an implementation must provide the necessary */ + /* modifications to this C code to satisfy the function */ + /* requirements (see Function Description). */ + /* */ + /* char CXB30040 (val) */ + /* int val; */ + /* */ + + { char return_value = ';'; + + switch (val) + { + case 0: + return_value = '0'; + break; + case 1: + return_value = '1'; + break; + case 2: + return_value = '2'; + break; + case 3: + return_value = '3'; + break; + case 4: + return_value = '4'; + break; + case 5: + return_value = '5'; + break; + case 6: + return_value = '6'; + break; + case 7: + return_value = '7'; + break; + case 8: + return_value = '8'; + break; + case 9: + return_value = '9'; + break; + case 10: + return_value = 'A'; + break; + case 11: + return_value = 'B'; + break; + case 12: + return_value = 'C'; + break; + case 13: + return_value = 'D'; + break; + case 14: + return_value = 'E'; + break; + case 15: + return_value = 'F'; + break; + case 16: + return_value = 'G'; + break; + case 17: + return_value = 'H'; + break; + case 18: + return_value = 'I'; + break; + case 19: + return_value = 'J'; + break; + case 20: + return_value = 'k'; + break; + case 21: + return_value = 'l'; + break; + case 22: + return_value = 'm'; + break; + case 23: + return_value = 'n'; + break; + case 24: + return_value = 'o'; + break; + case 25: + return_value = 'p'; + break; + case 26: + return_value = 'q'; + break; + case 27: + return_value = 'r'; + break; + case 28: + return_value = 's'; + break; + case 29: + return_value = 't'; + break; + case 30: + return_value = ' '; + break; + case 31: + return_value = '.'; + break; + case 32: + return_value = ','; + break; + } + + return (return_value); /* Return character value */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30041.am 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,377 ---- + -- CXB30041.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functions To_C and To_Ada map between the Ada type + -- Character and the C type char. + -- + -- Check that the function Is_Nul_Terminated returns True if the + -- char_array parameter contains nul, and otherwise False. + -- + -- Check that the function To_C produces a correct char_array result, + -- with lower bound of 0, and length dependent upon the Item and + -- Append_Nul parameters. + -- + -- Check that the function To_Ada produces a correct string result, with + -- lower bound of 1, and length dependent upon the Item and Trim_Nul + -- parameters. + -- + -- Check that the function To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the nul char. + -- + -- TEST DESCRIPTION: + -- This test uses a variety of Character, char, String, and char_array + -- objects to test versions of the To_C, To_Ada, and Is_Nul_Terminated + -- functions. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C. If an implementation provides + -- package Interfaces.C, this test must compile, execute, and + -- report "PASSED". + -- + -- SPECIAL REQUIREMENTS: + -- The file CXB30040.C must be compiled with a C compiler. + -- Implementation dialects of C may require alteration of + -- the C program syntax (see individual C files). + -- + -- Note that the compiled C code must be bound with the compiled Ada + -- code to create an executable image. An implementation must provide + -- the necessary commands to accomplish this. + -- + -- Note that the C code included in CXB30040.C conforms + -- to ANSI-C. Modifications to these files may be required for other + -- C compilers. An implementation must provide the necessary + -- modifications to satisfy the function requirements. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CXB30040.C + -- CXB30041.AM + -- + -- CHANGE HISTORY: + -- 30 Aug 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a + -- C function character generator. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Strings.Fixed; + with Impdef; + + procedure CXB30041 is + begin + + Report.Test ("CXB3004", "Check that the functions To_C and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters, Ada.Characters.Latin_1; + use Ada.Exceptions; + use Ada.Strings.Fixed; + + Start_Character, + Stop_Character, + TC_Character : Character := Character'First; + TC_char, + TC_Low_char, + TC_High_char : char := char'First; + TC_String : String(1..8) := (others => Latin_1.NUL); + TC_char_array : char_array(0..7) := (others => C.nul); + + -- The function Char_Gen returns a character corresponding to its + -- argument. + -- Value 0 .. 9 ==> '0' .. '9' + -- Value 10 .. 19 ==> 'A' .. 'J' + -- Value 20 .. 29 ==> 'k' .. 't' + -- Value 30 ==> ' ' + -- Value 31 ==> '.' + -- Value 32 ==> ',' + + function Char_Gen (Value : in int) return char; + + -- Use the user-defined C function char_gen as a completion to the + -- function specification above. + + pragma Import (Convention => C, + Entity => Char_Gen, + External_Name => Impdef.CXB30040_External_Name); + + begin + + -- Check that the functions To_C and To_Ada map between the Ada type + -- Character and the C type char. + + if To_C(Ada.Characters.Latin_1.NUL) /= Interfaces.C.nul then + Report.Failed("Incorrect result from To_C with NUL character input"); + end if; + + Start_Character := Report.Ident_Char('k'); + Stop_Character := Report.Ident_Char('t'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('k') + 20) then + Report.Failed("Incorrect result from To_C with lower case " & + "alphabetic character input"); + end if; + end loop; + + Start_Character := Report.Ident_Char('A'); + Stop_Character := Report.Ident_Char('J'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('A') + 10) then + Report.Failed("Incorrect result from To_C with upper case " & + "alphabetic character input"); + end if; + end loop; + + Start_Character := Report.Ident_Char('0'); + Stop_Character := Report.Ident_Char('9'); + for TC_Character in Start_Character..Stop_Character loop + if To_C(Item => TC_Character) /= + Char_Gen(Character'Pos(TC_Character) - Character'Pos('0')) then + Report.Failed("Incorrect result from To_C with digit " & + "character input"); + end if; + end loop; + if To_C(Item => ' ') /= Char_Gen(30) then + Report.Failed("Incorrect result from To_C with space " & + "character input"); + end if; + if To_C(Item => '.') /= Char_Gen(31) then + Report.Failed("Incorrect result from To_C with dot " & + "character input"); + end if; + if To_C(Item => ',') /= Char_Gen(32) then + Report.Failed("Incorrect result from To_C with comma " & + "character input"); + end if; + + if To_Ada(Interfaces.C.nul) /= Ada.Characters.Latin_1.NUL then + Report.Failed("Incorrect result from To_Ada with nul char input"); + end if; + + for Code in int range + int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop + -- 'k' .. 't' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('k') + (Code - 20)) then + Report.Failed("Incorrect result from To_Ada with lower case " & + "alphabetic char input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop + -- 'A' .. 'J' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('A') + (Code - 10)) then + Report.Failed("Incorrect result from To_Ada with upper case " & + "alphabetic char input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop + -- '0' .. '9' + if To_Ada(Item => Char_Gen(Code)) /= + Character'Val (Character'Pos('0') + (Code)) then + Report.Failed("Incorrect result from To_Ada with digit " & + "char input"); + end if; + end loop; + + if To_Ada(Item => Char_Gen(30)) /= ' ' then + Report.Failed("Incorrect result from To_Ada with space " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(31)) /= '.' then + Report.Failed("Incorrect result from To_Ada with dot " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(32)) /= ',' then + Report.Failed("Incorrect result from To_Ada with comma " & + "char input"); + end if; + + -- Check that the function Is_Nul_Terminated produces correct results + -- whether or not the char_array argument contains the + -- Ada.Interfaces.C.nul character. + + TC_String := "abcdefgh"; + if Is_Nul_Terminated(Item => To_C(TC_String, Append_Nul => False)) then + Report.Failed("Incorrect result from Is_Nul_Terminated when no " & + "nul char is present"); + end if; + + if not Is_Nul_Terminated(To_C(TC_String, Append_Nul => True)) then + Report.Failed("Incorrect result from Is_Nul_Terminated when the " & + "nul char is present"); + end if; + + + -- Now that we've tested the character/char versions of To_Ada and To_C, + -- use them to test the string versions. + + declare + i : size_t := 0; + j : integer := 1; + Incorrect_Conversion : Boolean := False; + + TC_No_nul : constant char_array := To_C(TC_String, False); + TC_nul_Appended : constant char_array := To_C(TC_String, True); + begin + + -- Check that the function To_C produces a char_array result with + -- lower bound of 0, and length dependent upon the Item and + -- Append_Nul parameters (if Append_Nul is True, length is + -- Item'Length + 1; if False, length is Item'Length). + + if TC_No_nul'First /= 0 or TC_nul_Appended'First /= 0 then + Report.Failed("Incorrect lower bound from Function To_C"); + end if; + + if TC_No_nul'Length /= TC_String'Length then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => False"); + end if; + + for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop + if TC_No_nul(i) /= To_C(TC_char) or -- Single character To_C. + TC_nul_Appended(i) /= To_C(TC_char) then + Incorrect_Conversion := True; + end if; + i := i + 1; + end loop; + + if Incorrect_Conversion then + Report.Failed("Incorrect result from To_C with string input " & + "and char_array result"); + end if; + + + if TC_nul_Appended'Length /= TC_String'Length + 1 then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => True"); + end if; + + if not Is_Nul_Terminated(TC_nul_Appended) then + Report.Failed("No nul appended to the string parameter during " & + "conversion to char_array by function To_C"); + end if; + + + -- Check that the function To_Ada produces a string result with + -- lower bound of 1, and length dependent upon the Item and + -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length; + -- if True, length will be the length of the slice of Item prior to + -- the first nul). + + declare + TC_No_NUL_String : constant String := + To_Ada(Item => TC_nul_Appended, + Trim_Nul => True); + TC_NUL_Appended_String : constant String := + To_Ada(TC_nul_Appended, False); + begin + + if TC_No_NUL_String'First /= 1 or + TC_NUL_Appended_String'First /= 1 + then + Report.Failed("Incorrect lower bound from Function To_Ada"); + end if; + + if TC_No_NUL_String'Length /= TC_String'Length then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => True"); + end if; + + if TC_NUL_Appended_String'Length /= TC_String'Length + 1 then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => False"); + end if; + + Start_Character := Report.Ident_Char('a'); + Stop_Character := Report.Ident_Char('h'); + for TC_Character in Start_Character..Stop_Character loop + if TC_No_NUL_String(j) /= TC_Character or + TC_NUL_Appended_String(j) /= TC_Character + then + Report.Failed("Incorrect result from To_Ada with " & + "char_array input, index = " & + Integer'Image(j)); + end if; + j := j + 1; + end loop; + + end; + + + -- Check that the function To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the nul char. + + begin + TC_String := To_Ada(TC_No_nul, Trim_Nul => True); + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "nul char, but parameter Trim_Nul => True"); + Report.Comment(TC_String & " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by function " & + "To_Ada when the Item parameter does not " & + "contain the nul char, but parameter " & + "Trim_Nul => True"); + end; + + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB30041; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3005.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,396 ---- + -- CXB3005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedure To_C converts the character elements of + -- a string parameter into char elements of the char_array parameter + -- Target, with nul termination if parameter Append_Nul is true. + -- + -- Check that the out parameter Count of procedure To_C is set to the + -- appropriate value for both the nul/no nul terminated cases. + -- + -- Check that Constraint_Error is propagated by procedure To_C if the + -- length of the char_array parameter Target is not sufficient to + -- hold the converted string value. + -- + -- Check that the Procedure To_Ada converts char elements of the + -- char_array parameter Item to the corresponding character elements + -- of string out parameter Target. + -- + -- Check that Constraint_Error is propagated by Procedure To_Ada if the + -- length of string parameter Target is not long enough to hold the + -- converted char_array value. + -- + -- Check that Terminator_Error is propagated by Procedure To_Ada if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- contains no nul char. + -- + -- TEST DESCRIPTION: + -- This test uses a variety of String, and char_array objects to test + -- versions of the To_C and To_Ada procedures. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '-'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C. If an implementation provides + -- package Interfaces.C, this test must compile, execute, and + -- report "PASSED". + -- + -- CHANGE HISTORY: + -- 01 Sep 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 14 Sep 99 RLB Removed incorrect and unnecessary + -- Unchecked_Conversion. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Strings.Fixed; + + procedure CXB3005 is + begin + + Report.Test ("CXB3005", "Check that the procedures To_C and To_Ada " & + "produce correct results"); + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters; + use Ada.Exceptions; + use Ada.Strings.Fixed; + + TC_Short_String : String(1..4) := (others => 'x'); + TC_String : String(1..8) := (others => 'y'); + TC_char_array : char_array(0..7) := (others => char'Last); + TC_size_t_Count : size_t := size_t'First; + TC_Natural_Count : Natural := Natural'First; + + + -- We can use the character forms of To_Ada and To_C here to check + -- the results; they were tested in CXB3004. We give them different + -- names to avoid confusion below. + + function Character_to_char (Source : in Character) return char + renames To_C; + function char_to_Character (Source : in char) return Character + renames To_Ada; + + begin + + -- Check that the procedure To_C converts the character elements of + -- a string parameter into char elements of char_array out parameter + -- Target. + -- + -- Case of nul termination. + + TC_String(1..6) := "abcdef"; + + To_C (Item => TC_String(1..6), -- Source slice of length 6. + Target => TC_char_array, -- Length 8 will accommodate nul. + Count => TC_size_t_Count, + Append_Nul => True); + + -- Check that the out parameter Count is set to the appropriate value + -- for the nul terminated case. + + if TC_size_t_Count /= 7 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => True"); + end if; + + for i in 1..TC_size_t_Count-1 loop + if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual char values, case of " & + "Append_Nul => True; " & + "char position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if not Is_Nul_Terminated(TC_char_array) then + Report.Failed("No nul char appended to the char_array result " & + "from Procedure To_C when Append_Nul => True"); + end if; + + if TC_char_array(0..6) /= To_C("abcdef", True) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing char_array results, case " & + "of Append_Nul => True"); + end if; + + + -- Check Procedure To_C with no nul termination. + + TC_char_array := (others => Character_to_char('M')); -- Reinitialize. + TC_String(1..4) := "WXYZ"; + + To_C (Item => TC_String(1..4), -- Source slice of length 4. + Target => TC_char_array, + Count => TC_size_t_Count, + Append_Nul => False); + + -- Check that the out parameter Count is set to the appropriate value + -- for the non-nul terminated case. + + if TC_size_t_Count /= 4 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => False"); + end if; + + for i in 1..TC_size_t_Count loop + if char_to_Character(TC_char_array(i-1)) /= TC_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual char values, case of " & + "Append_Nul => False; " & + "char position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if Is_Nul_Terminated(TC_char_array) then + Report.Failed("The nul char was appended to the char_array " & + "result of Procedure To_C when Append_Nul => False"); + end if; + + if TC_char_array(0..3) /= To_C("WXYZ", False) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing char_array results, case " & + "of Append_Nul => False"); + end if; + + + + -- Check that Constraint_Error is raised by procedure To_C if the + -- length of the target char_array parameter is not sufficient to + -- hold the converted string value (plus nul if Append_Nul is True). + + begin + To_C("A string too long", + TC_char_array, + TC_size_t_Count, + Append_Nul => True); + + Report.Failed("Constraint_Error not raised when the Target " & + "parameter of Procedure To_C is not long enough " & + "to hold the converted string"); + Report.Comment(char_to_Character(TC_char_array(0)) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_C when the Target parameter is not long " & + "enough to contain the char_array result"); + end; + + + + -- Check that the procedure To_Ada converts char elements of the + -- char_array parameter Item to the corresponding character elements + -- of string out parameter Target, with result string length based on + -- the Trim_Nul parameter. + -- + -- Case of appended nul char on the char_array In parameter. + + TC_char_array := To_C ("ACVC-95", Append_Nul => True); -- 8 total chars. + TC_String := (others => '*'); -- Reinitialize. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => False, when a nul is present in " & + "the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) /= Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is not Nul, even though a nul was present " & + "in the char_array argument, and the Trim_Nul " & + "parameter was set to False"); + end if; + + + TC_char_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars. + TC_String := (others => '*'); -- Reinit. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + if TC_Natural_Count /= 3 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => True"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => True, when a nul is present in " & + "the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) = Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is Nul, even though the Trim_Nul " & + "parameter was set to True"); + end if; + + -- Check that TC_String(TC_Natural_Count+1) is unchanged by procedure + -- To_Ada. + + if TC_String(TC_Natural_Count+1) /= '*' then + Report.Failed("Incorrect modification to TC_String at position " & + Integer'Image(TC_Natural_Count+1) & " expected = " & + "*, found = " & TC_String(TC_Natural_Count+1)); + end if; + + + -- Case of no nul char being present in the char_array argument. + + TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False); + TC_String := (others => '*'); -- Reinitialize. + + To_Ada (Item => TC_char_array, + Target => TC_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False, " & + "with no nul char present in the parameter Item"); + end if; + + for i in 1..TC_Natural_Count loop + if Character_to_char(TC_String(i)) /= TC_char_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual char values, case of " & + "Trim_Nul => False, when a nul is not present " & + "in the char_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_String(TC_Natural_Count) = Latin_1.Nul then + Report.Failed("Last character of String result of Procedure " & + "To_Ada is Nul, even though the nul char was " & + "not present in the parameter Item, with the " & + "parameter Trim_Nul => False"); + end if; + + + + -- Check that the Procedure To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the nul char. + + begin + TC_char_array := To_C ("ABCDWXYZ", Append_Nul => False); + TC_String := (others => '*'); + + To_Ada(TC_char_array, + TC_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "nul char, but parameter Trim_Nul => True"); + Report.Comment(TC_String & " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when the Item parameter does not " & + "contain the nul char, but parameter " & + "Trim_Nul => True"); + end; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada if the + -- length of string parameter Target is not long enough to hold the + -- converted char_array value (plus nul if Trim_Nul is False). + + begin + TC_char_array(0..4) := To_C ("ABCD", Append_Nul => True); + + To_Ada(TC_char_array(0..4), -- 4 chars plus nul char. + TC_Short_String, -- Length of 4. + Count => TC_Natural_Count, + Trim_Nul => False); + + Report.Failed("Constraint_Error not raised when string " & + "parameter Target of Procedure To_Ada is not " & + "long enough to hold the converted chars"); + Report.Comment(TC_Short_String & " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when string parameter Target is " & + "not long enough to hold the converted chars"); + end; + + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30060.c 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + /* + -- CXB30060.C + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FUNCTION NAME: CXB30060 ("wchar_gen") + -- + -- FUNCTION DESCRIPTION: + -- This C function returns the value of type wchar_t corresponding to the + -- value of its parameter, where + -- Val 0 .. 9 ==> '0' .. '9' + -- Val 10 .. 19 ==> 'A' .. 'J' + -- Val 20 .. 29 ==> 'k' .. 't' + -- Val 30 ==> ' ' + -- Val 31 ==> '.' + -- Val 32 ==> ',' + -- + -- INPUT: + -- This function requires that one int parameter be passed to it. + -- + -- OUTPUT: + -- The function will return the appropriate value of type wchar_t. + -- + -- CHANGE HISTORY: + -- 13 Sep 99 RLB Created function to replace incorrect + -- Unchecked_Conversion. + -- + --! + */ + + #include + + wchar_t CXB30060 (int val) + + /* NOTE: The above function definition should be accepted by an ANSI-C */ + /* compiler. Older C compilers may reject it; they may, however */ + /* accept the following two lines. An implementation may comment */ + /* out the above function definition and uncomment the following */ + /* one. Otherwise, an implementation must provide the necessary */ + /* modifications to this C code to satisfy the function */ + /* requirements (see Function Description). */ + /* */ + /* wchar_t CXB30060 (val) */ + /* int val; */ + /* */ + + { wchar_t return_value = ';'; + + switch (val) + { + case 0: + return_value = '0'; + break; + case 1: + return_value = '1'; + break; + case 2: + return_value = '2'; + break; + case 3: + return_value = '3'; + break; + case 4: + return_value = '4'; + break; + case 5: + return_value = '5'; + break; + case 6: + return_value = '6'; + break; + case 7: + return_value = '7'; + break; + case 8: + return_value = '8'; + break; + case 9: + return_value = '9'; + break; + case 10: + return_value = 'A'; + break; + case 11: + return_value = 'B'; + break; + case 12: + return_value = 'C'; + break; + case 13: + return_value = 'D'; + break; + case 14: + return_value = 'E'; + break; + case 15: + return_value = 'F'; + break; + case 16: + return_value = 'G'; + break; + case 17: + return_value = 'H'; + break; + case 18: + return_value = 'I'; + break; + case 19: + return_value = 'J'; + break; + case 20: + return_value = 'k'; + break; + case 21: + return_value = 'l'; + break; + case 22: + return_value = 'm'; + break; + case 23: + return_value = 'n'; + break; + case 24: + return_value = 'o'; + break; + case 25: + return_value = 'p'; + break; + case 26: + return_value = 'q'; + break; + case 27: + return_value = 'r'; + break; + case 28: + return_value = 's'; + break; + case 29: + return_value = 't'; + break; + case 30: + return_value = ' '; + break; + case 31: + return_value = '.'; + break; + case 32: + return_value = ','; + break; + } + + return (return_value); /* Return character value */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30061.am 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,404 ---- + -- CXB30061.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function To_C maps between the Ada type Wide_Character + -- and the C type wchar_t. + -- + -- Check that the function To_Ada maps between the C type wchar_t and + -- the Ada type Wide_Character. + -- + -- Check that the function Is_Nul_Terminated returns True if the + -- wchar_array parameter contains wide_nul, and otherwise False. + -- + -- Check that the function To_C produces a correct wchar_array result, + -- with lower bound of 0, and length dependent upon the Item and + -- Append_Nul parameters. + -- + -- Check that the function To_Ada produces a correct wide_string result, + -- with lower bound of 1, and length dependent upon the Item and + -- Trim_Nul parameters. + -- + -- Check that the function To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the wide_nul wchar_t. + -- + -- TEST DESCRIPTION: + -- This test uses a variety of Wide_Character, wchar_t, Wide_String, and + -- wchar_array objects to test versions of the To_C, To_Ada, and + -- Is_Nul_Terminated functions. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.wchar_t: + -- ' ', ',', '.', '0'..'9', 'a'..'z' and 'A'..'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C. If an implementation provides + -- package Interfaces.C, this test must compile, execute, and + -- report "PASSED". + -- + -- SPECIAL REQUIREMENTS: + -- The file CXB30060.C must be compiled with a C compiler. + -- Implementation dialects of C may require alteration of + -- the C program syntax (see individual C files). + -- + -- Note that the compiled C code must be bound with the compiled Ada + -- code to create an executable image. An implementation must provide + -- the necessary commands to accomplish this. + -- + -- Note that the C code included in CXB30060.C conforms + -- to ANSI-C. Modifications to these files may be required for other + -- C compilers. An implementation must provide the necessary + -- modifications to satisfy the function requirements. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CXB30060.C + -- CXB30061.AM + -- + -- CHANGE HISTORY: + -- 07 Sep 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 13 Sep 99 RLB Replaced (bogus) Unchecked_Conversions with a + -- C function character generator. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + with Ada.Characters.Latin_1; + with Ada.Characters.Handling; + with Ada.Exceptions; + with Ada.Strings.Wide_Fixed; + with Impdef; + + procedure CXB30061 is + begin + + Report.Test ("CXB3006", "Check that the functions To_C and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters, Ada.Characters.Latin_1, Ada.Characters.Handling; + use Ada.Strings.Wide_Fixed; + + First_Character, + Last_Character : Character; + TC_wchar_t, + TC_Low_wchar_t, + TC_High_wchar_t : wchar_t := wchar_t'First; + TC_Wide_String : Wide_String(1..8) := (others => Wide_Character'First); + TC_wchar_array : wchar_array(0..7) := (others => C.wide_nul); + + -- The function Char_Gen returns a character corresponding to its + -- argument. + -- Value 0 .. 9 ==> '0' .. '9' + -- Value 10 .. 19 ==> 'A' .. 'J' + -- Value 20 .. 29 ==> 'k' .. 't' + -- Value 30 ==> ' ' + -- Value 31 ==> '.' + -- Value 32 ==> ',' + + function Char_Gen (Value : in int) return wchar_t; + + -- Use the user-defined C function char_gen as a completion to the + -- function specification above. + + pragma Import (Convention => C, + Entity => Char_Gen, + External_Name => Impdef.CXB30060_External_Name); + + begin + + -- Check that the functions To_C and To_Ada map between the Ada type + -- Wide_Character and the C type wchar_t. + + if To_C(To_Wide_Character(Ada.Characters.Latin_1.NUL)) /= + Interfaces.C.wide_nul + then + Report.Failed("Incorrect result from To_C with NUL character input"); + end if; + + First_Character := Report.Ident_Char('k'); + Last_Character := Report.Ident_Char('t'); + for i in First_Character..Last_Character loop + if To_C(Item => To_Wide_Character(i)) /= + Char_Gen(Character'Pos(i) - Character'Pos('k') + 20) + then + Report.Failed("Incorrect result from To_C with lower case " & + "alphabetic wide character input"); + end if; + end loop; + + First_Character := Report.Ident_Char('A'); + Last_Character := Report.Ident_Char('J'); + for i in First_Character..Last_Character loop + if To_C(Item => To_Wide_Character(i)) /= + Char_Gen(Character'Pos(i) - Character'Pos('A') + 10) + then + Report.Failed("Incorrect result from To_C with upper case " & + "alphabetic wide character input"); + end if; + end loop; + + First_Character := Report.Ident_Char('0'); + Last_Character := Report.Ident_Char('9'); + for i in First_Character..Last_Character loop + if To_C(Item => To_Wide_Character(i)) /= + Char_Gen(Character'Pos(i) - Character'Pos('0')) + then + Report.Failed("Incorrect result from To_C with digit " & + "wide character input"); + end if; + end loop; + + if To_C(Item => To_Wide_Character(' ')) /= Char_Gen(30) + then + Report.Failed("Incorrect result from To_C with space " & + "wide character input"); + end if; + + if To_C(Item => To_Wide_Character('.')) /= Char_Gen(31) + then + Report.Failed("Incorrect result from To_C with dot " & + "wide character input"); + end if; + + if To_C(Item => To_Wide_Character(',')) /= Char_Gen(32) + then + Report.Failed("Incorrect result from To_C with comma " & + "wide character input"); + end if; + + if To_Ada(Interfaces.C.wide_nul) /= + To_Wide_Character(Ada.Characters.Latin_1.NUL) + then + Report.Failed("Incorrect result from To_Ada with wide_nul " & + "wchar_t input"); + end if; + + for Code in int range + int(Report.Ident_Int(20)) .. int(Report.Ident_Int(29)) loop + -- 'k' .. 't' + if To_Ada(Item => Char_Gen(Code)) /= + To_Wide_Character(Character'Val (Character'Pos('k') + (Code - 20))) + then + Report.Failed("Incorrect result from To_Ada with lower case " & + "alphabetic wchar_t input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(10)) .. int(Report.Ident_Int(19)) loop + -- 'A' .. 'J' + if To_Ada(Item => Char_Gen(Code)) /= + To_Wide_Character(Character'Val (Character'Pos('A') + (Code - 10))) + then + Report.Failed("Incorrect result from To_Ada with upper case " & + "alphabetic wchar_t input"); + end if; + end loop; + + for Code in int range + int(Report.Ident_Int(0)) .. int(Report.Ident_Int(9)) loop + -- '0' .. '9' + if To_Ada(Item => Char_Gen(Code)) /= + To_Wide_Character(Character'Val (Character'Pos('0') + (Code))) + then + Report.Failed("Incorrect result from To_Ada with digit " & + "wchar_t input"); + end if; + end loop; + + if To_Ada(Item => Char_Gen(30)) /= ' ' then + Report.Failed("Incorrect result from To_Ada with space " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(31)) /= '.' then + Report.Failed("Incorrect result from To_Ada with dot " & + "char input"); + end if; + if To_Ada(Item => Char_Gen(32)) /= ',' then + Report.Failed("Incorrect result from To_Ada with comma " & + "char input"); + end if; + + -- Check that the function Is_Nul_Terminated produces correct results + -- whether or not the wchar_array argument contains the + -- Ada.Interfaces.C.wide_nul character. + + TC_Wide_String := "abcdefgh"; + if Is_Nul_Terminated(Item => To_C(TC_Wide_String, Append_Nul => False)) + then + Report.Failed("Incorrect result from Is_Nul_Terminated when no " & + "wide_nul wchar_t is present"); + end if; + + if not Is_Nul_Terminated(To_C(TC_Wide_String, Append_Nul => True)) then + Report.Failed("Incorrect result from Is_Nul_Terminated when the " & + "wide_nul wchar_t is present"); + end if; + + + + -- Now that we've tested the character/char versions of To_Ada and To_C, + -- use them to test the string versions. + + declare + i : size_t := 0; + j : integer := 1; + Incorrect_Conversion : Boolean := False; + + TC_No_wide_nul : constant wchar_array := To_C(TC_Wide_String, + False); + TC_wide_nul_Appended : constant wchar_array := To_C(TC_Wide_String, + True); + begin + + -- Check that the function To_C produces a wchar_array result with + -- lower bound of 0, and length dependent upon the Item and + -- Append_Nul parameters (if Append_Nul is True, length is + -- Item'Length + 1; if False, length is Item'Length). + + if TC_No_wide_nul'First /= 0 or TC_wide_nul_Appended'First /= 0 then + Report.Failed("Incorrect lower bound from Function To_C"); + end if; + + if TC_No_wide_nul'Length /= TC_Wide_String'Length then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => False"); + end if; + + if TC_wide_nul_Appended'Length /= TC_Wide_String'Length + 1 then + Report.Failed("Incorrect length returned from Function To_C " & + "when Append_Nul => True"); + end if; + + if not Is_Nul_Terminated(TC_wide_nul_Appended) then + Report.Failed("No wide_nul appended to the wide_string " & + "parameter during conversion to wchar_array " & + "by function To_C"); + end if; + + for TC_char in Report.Ident_Char('a')..Report.Ident_Char('h') loop + if TC_No_wide_nul(i) /= To_C(To_Wide_Character(TC_char)) or + TC_wide_nul_Appended(i) /= To_C(To_Wide_Character(TC_char)) then + -- Use single character To_C. + Incorrect_Conversion := True; + end if; + i := i + 1; + end loop; + + if Incorrect_Conversion then + Report.Failed("Incorrect result from To_C with wide_string input " & + "and wchar_array result"); + end if; + + + -- Check that the function To_Ada produces a wide_string result with + -- lower bound of 1, and length dependent upon the Item and + -- Trim_Nul parameters (if Trim_Nul is False, length is Item'Length; + -- if False, length will be the length of the slice of Item prior to + -- the first wide_nul). + + declare + TC_No_NUL_Wide_String : constant Wide_String := + To_Ada(Item => TC_wide_nul_Appended, Trim_Nul => True); + + TC_NUL_Appended_Wide_String : constant Wide_String := + To_Ada(TC_wide_nul_Appended, False); + + begin + + if TC_No_NUL_Wide_String'First /= 1 or + TC_NUL_Appended_Wide_String'First /= 1 + then + Report.Failed("Incorrect lower bound from Function To_Ada"); + end if; + + if TC_No_NUL_Wide_String'Length /= TC_Wide_String'Length then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => True"); + end if; + + if TC_NUL_Appended_Wide_String'Length /= + TC_Wide_String'Length + 1 + then + Report.Failed("Incorrect length returned from Function " & + "To_Ada when Trim_Nul => False"); + end if; + + for TC_Character in Wide_Character'('a') .. Wide_Character'('h') loop + if TC_No_NUL_Wide_String(j) /= TC_Character or + TC_NUL_Appended_Wide_String(j) /= TC_Character + then + Report.Failed("Incorrect result from To_Ada with " & + "char_array input, index = " & + Integer'Image(j)); + end if; + j := j + 1; + end loop; + + end; + + + -- Check that the function To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the wide_nul wchar_t. + + begin + TC_Wide_String := To_Ada(TC_No_wide_nul, Trim_Nul => True); + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "wide_nul wchar_t, but parameter Trim_Nul " & + "=> True"); + Report.Comment + (To_String(TC_Wide_String) & " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by function " & + "To_Ada when the Item parameter does not " & + "contain the wide_nul wchar_t, but " & + "parameter Trim_Nul => True"); + end; + + end; + + exception + when The_Error : others => + Report.Failed + ("The following exception was raised in the Test_Block: " & + Ada.Exceptions.Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB30061; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3007.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,408 ---- + -- CXB3007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedure To_C converts the Wide_Character elements + -- of a Wide_String parameter into wchar_t elements of the wchar_array + -- parameter Target, with wide_nul termination if parameter Append_Nul + -- is true. + -- + -- Check that the out parameter Count of procedure To_C is set to the + -- appropriate value for both the wide_nul/no wide_nul terminated cases. + -- + -- Check that Constraint_Error is propagated by procedure To_C if the + -- length of the wchar_array parameter Target is not sufficient to + -- hold the converted Wide_String value. + -- + -- Check that the Procedure To_Ada converts wchar_t elements of the + -- wchar_array parameter Item to the corresponding Wide_Character + -- elements of Wide_String out parameter Target. + -- + -- Check that Constraint_Error is propagated by Procedure To_Ada if the + -- length of Wide_String parameter Target is not long enough to hold the + -- converted wchar_array value. + -- + -- Check that Terminator_Error is propagated by Procedure To_Ada if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- contains no wide_nul wchar_t. + -- + -- TEST DESCRIPTION: + -- This test uses a variety of Wide_String, and wchar_array objects to + -- test versions of the To_C and To_Ada procedures. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.wchar_t: + -- ' ', 'a'..'z', 'A'..'Z', and '-'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C. If an implementation provides + -- package Interfaces.C, this test must compile, execute, and + -- report "PASSED". + -- + -- CHANGE HISTORY: + -- 01 Sep 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 14 Sep 99 RLB Removed incorrect and unnecessary + -- Unchecked_Conversion. + -- + --! + + with Report; + with Interfaces.C; -- N/A => ERROR + with Ada.Characters.Latin_1; + with Ada.Characters.Handling; + with Ada.Exceptions; + with Ada.Strings.Wide_Fixed; + + procedure CXB3007 is + begin + + Report.Test ("CXB3007", "Check that the procedures To_C and To_Ada " & + "for wide strings produce correct results"); + Test_Block: + declare + + use Interfaces, Interfaces.C; + use Ada.Characters, Ada.Characters.Handling; + use Ada.Exceptions; + use Ada.Strings.Wide_Fixed; + + TC_Short_Wide_String : Wide_String(1..4) := + (others => Wide_Character'First); + TC_Wide_String : Wide_String(1..8) := + (others => Wide_Character'First); + TC_wchar_array : wchar_array(0..7) := (others => wchar_t'First); + TC_size_t_Count : size_t := size_t'First; + TC_Natural_Count : Natural := Natural'First; + + + -- We can use the wide character forms of To_Ada and To_C here to check + -- the results; they were tested in CXB3006. We give them different + -- names to avoid confusion below. + + function Wide_Character_to_wchar_t (Source : in Wide_Character) + return wchar_t renames To_C; + function wchar_t_to_Wide_Character (Source : in wchar_t) + return Wide_Character renames To_Ada; + + begin + + -- Check that the procedure To_C converts the Wide_Character elements + -- of a Wide_String parameter into wchar_t elements of wchar_array out + -- parameter Target. + -- + -- Case of wide_nul termination. + + TC_Wide_String(1..6) := "abcdef"; + + To_C (Item => TC_Wide_String(1..6), -- Source slice of length 6. + Target => TC_wchar_array, + Count => TC_size_t_Count, + Append_Nul => True); + + -- Check that the out parameter Count is set to the appropriate value + -- for the wide_nul terminated case. + + if TC_size_t_Count /= 7 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => True"); + end if; + + for i in 1..TC_size_t_Count-1 loop + if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= + TC_Wide_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual wchar_t values, case of " & + "Append_Nul => True; " & + "wchar_t position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if not Is_Nul_Terminated(TC_wchar_array) then + Report.Failed("No wide_nul wchar_t appended to the wchar_array " & + "result from Procedure To_C when Append_Nul => True"); + end if; + + if TC_wchar_array(0..6) /= To_C("abcdef", True) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing wchar_array results, case " & + "of Append_Nul => True"); + end if; + + + -- Check Procedure To_C with no wide_nul termination. + + TC_wchar_array := (others => Wide_Character_to_wchar_t('M')); + TC_Wide_String(1..4) := "WXYZ"; + + To_C (Item => TC_Wide_String(1..4), -- Source slice of length 4. + Target => TC_wchar_array, + Count => TC_size_t_Count, + Append_Nul => False); + + -- Check that the out parameter Count is set to the appropriate value + -- for the non-wide_nul terminated case. + + if TC_size_t_Count /= 4 then + Report.Failed("Incorrect setting of out parameter Count by " & + "Procedure To_C when Append_Nul => False"); + end if; + + for i in 1..TC_size_t_Count loop + if wchar_t_to_Wide_Character(TC_wchar_array(i-1)) /= + TC_Wide_String(Integer(i)) + then + Report.Failed("Incorrect result from Procedure To_C when " & + "checking individual wchar_t values, case of " & + "Append_Nul => False; " & + "wchar_t position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if Is_Nul_Terminated(TC_wchar_array) then + Report.Failed + ("The wide_nul wchar_t was appended to the wchar_array " & + "result of Procedure To_C when Append_Nul => False"); + end if; + + if TC_wchar_array(0..3) /= To_C("WXYZ", False) then + Report.Failed("Incorrect result from Procedure To_C when " & + "directly comparing wchar_array results, case " & + "of Append_Nul => False"); + end if; + + + + -- Check that Constraint_Error is raised by procedure To_C if the + -- length of the target wchar_array parameter is not sufficient to + -- hold the converted Wide_String value (plus wide_nul if Append_Nul + -- is True). + + TC_wchar_array := (others => wchar_t'First); + begin + To_C("A string too long", + TC_wchar_array, + TC_size_t_Count, + Append_Nul => True); + + Report.Failed("Constraint_Error not raised when the Target " & + "parameter of Procedure To_C is not long enough " & + "to hold the converted Wide_String"); + Report.Comment + (To_Character(wchar_t_to_Wide_Character(TC_wchar_array(0))) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_C when the Target parameter is not long " & + "enough to contain the wchar_array result"); + end; + + + + -- Check that the procedure To_Ada converts wchar_t elements of the + -- wchar_array parameter Item to the corresponding Wide_Character + -- elements of Wide_String out parameter Target, with result wide + -- string length based on the Trim_Nul parameter. + -- + -- Case of appended wide_nul wchar_t on the wchar_array In parameter. + + TC_wchar_array := + To_C ("ACVC-95", Append_Nul => True); -- 8 total chars. + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => False, when a wide_nul is present " & + "in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) /= To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is not Nul, even though a " & + "wide_nul was present in the wchar_array argument, " & + "and the Trim_Nul parameter was set to False"); + end if; + + + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array(0..3) := To_C ("XYz", Append_Nul => True); -- 4 chars. + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + if TC_Natural_Count /= 3 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => True"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => True, when a wide_nul is present " & + "in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is Nul, even though the " & + "Trim_Nul parameter was set to True"); + end if; + + if TC_Wide_String(TC_Natural_Count+1) /= Wide_Character'First then + Report.Failed("Incorrect replacement from To_Ada"); + end if; + + + -- Case of no wide_nul wchar_t present in the wchar_array argument. + + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); + + To_Ada (Item => TC_wchar_array, + Target => TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => False); + + if TC_Natural_Count /= 8 then + Report.Failed("Incorrect value returned in out parameter Count " & + "by Procedure To_Ada, case of Trim_Nul => False, " & + "with no wide_nul wchar_t present in the parameter " & + "Item"); + end if; + + for i in 1..TC_Natural_Count loop + if Wide_Character_to_wchar_t(TC_Wide_String(i)) /= + TC_wchar_array(size_t(i-1)) + then + Report.Failed("Incorrect result from Procedure To_Ada when " & + "checking individual wchar_t values, case of " & + "Trim_Nul => False, when a wide_nul is not " & + "present in the wchar_array input parameter; " & + "position = " & Integer'Image(Integer(i))); + end if; + end loop; + + if TC_Wide_String(TC_Natural_Count) = To_Wide_Character(Latin_1.Nul) + then + Report.Failed("Last Wide_Character of Wide_String result of " & + "Procedure To_Ada is Nul, even though the wide_nul " & + "wchar_t was not present in the parameter Item, " & + "with the parameter Trim_Nul => False"); + end if; + + + + -- Check that the Procedure To_Ada raises Terminator_Error if the + -- parameter Trim_Nul is set to True, but the actual Item parameter + -- does not contain the wide_nul wchar_t. + + begin + TC_Wide_String := (others => Wide_Character'First); + TC_wchar_array := To_C ("ABCDWXYZ", Append_Nul => False); + + To_Ada(TC_wchar_array, + TC_Wide_String, + Count => TC_Natural_Count, + Trim_Nul => True); + + Report.Failed("Terminator_Error not raised when Item " & + "parameter of To_Ada does not contain the " & + "wide_nul wchar_t, but parameter Trim_Nul => True"); + Report.Comment(To_String(TC_Wide_String) & + " printed to defeat optimization"); + exception + when Terminator_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when the Item parameter does not " & + "contain the wide_nul wchar_t, but parameter " & + "Trim_Nul => True"); + end; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada if the + -- length of Wide_String parameter Target is not long enough to hold the + -- converted wchar_array value (plus wide_nul if Trim_Nul is False). + + begin + TC_wchar_array(0..4) := To_C ("ABCD", Append_Nul => True); + + To_Ada(TC_wchar_array(0..4), + TC_Short_Wide_String, -- Length of 4. + Count => TC_Natural_Count, + Trim_Nul => False); + + Report.Failed("Constraint_Error not raised when Wide_String " & + "parameter Target of Procedure To_Ada is not " & + "long enough to hold the converted wchar_ts"); + Report.Comment(To_String(TC_Short_Wide_String) & + " printed to defeat optimization"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Procedure " & + "To_Ada when Wide_String parameter Target is " & + "not long enough to hold the converted wchar_ts"); + end; + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3008.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,226 ---- + -- CXB3008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that functions imported from the C language and + -- libraries can be called from an Ada program. + -- + -- TEST DESCRIPTION: + -- This test checks that C language functions from the and + -- libraries can be used as completions of Ada subprograms. + -- A pragma Import with convention identifier "C" is used to complete + -- the Ada subprogram specifications. + -- The three subprogram cases tested are as follows: + -- 1) A C function that returns an int value (strcpy) is used as the + -- completion of an Ada procedure specification. The return value + -- is discarded; parameter modification is the desired effect. + -- 2) A C function that returns an int value (strlen) is used as the + -- completion of an Ada function specification. + -- 3) A C function that returns a double value (strtod) is used as the + -- completion of an Ada function specification. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', and '$'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- packages Interfaces.C and Interfaces.C.Strings. If an + -- implementation provides these packages, this test must compile, + -- execute, and report "PASSED". + -- + -- SPECIAL REQUIREMENTS: + -- The C language library functions used by this test must be + -- available for importing into the test. + -- + -- + -- CHANGE HISTORY: + -- 12 Oct 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 01 DEC 97 EDS Replaced all references of C function atof with + -- C function strtod. + -- 29 JUN 98 EDS Give Ada function corresponding to strtod a + -- second parameter. + --! + + with Report; + with Ada.Exceptions; + with Interfaces.C; -- N/A => ERROR + with Interfaces.C.Strings; -- N/A => ERROR + with Interfaces.C.Pointers; + + procedure CXB3008 is + begin + + Report.Test ("CXB3008", "Check that functions imported from the " & + "C language predefined libraries can be " & + "called from an Ada program"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + package ICP is new Interfaces.C.Pointers + ( Index => IC.size_t, + Element => IC.char, + Element_Array => IC.char_array, + Default_Terminator => IC.nul ); + use Ada.Exceptions; + + use type IC.char; + use type IC.char_array; + use type IC.size_t; + use type IC.double; + + -- The String_Copy procedure copies the string pointed to by Source, + -- including the terminating nul char, into the char_array pointed + -- to by Target. + + procedure String_Copy (Target : out IC.char_array; + Source : in IC.char_array); + + -- The String_Length function returns the length of the nul-terminated + -- string pointed to by The_String. The nul is not included in + -- the count. + + function String_Length (The_String : in IC.char_array) + return IC.size_t; + + -- The String_To_Double function converts the char_array pointed to + -- by The_String into a double value returned through the function + -- name. The_String must contain a valid floating-point number; if + -- not, the value returned is zero. + + -- type Acc_ptr is access IC.char_array; + function String_To_Double (The_String : in IC.char_array ; + End_Ptr : ICP.Pointer := null) + return IC.double; + + + -- Use the strcpy function as a completion to the procedure + -- specification. Note that the Ada interface to this C function is + -- in the form of a procedure (C function return value is not used). + + pragma Import (C, String_Copy, "strcpy"); + + -- Use the strlen function as a completion to the + -- String_Length function specification. + + pragma Import (C, String_Length, "strlen"); + + -- Use the strtod function as a completion to the + -- String_To_Double function specification. + + pragma Import (C, String_To_Double, "strtod"); + + + TC_String : constant String := "Just a Test"; + Char_Source : IC.char_array(0..30); + Char_Target : IC.char_array(0..30); + Double_Result : IC.double; + Source_Ptr, + Target_Ptr : ICS.chars_ptr; + + begin + + -- Check that the imported version of C function strcpy produces + -- the correct results. + + Char_Source(0..21) := "Test of Pragma Import" & IC.nul; + + String_Copy(Char_Target, Char_Source); + + if Char_Target(0..21) /= Char_Source(0..21) then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 1"); + end if; + + if String_Length(Char_Target) /= 21 then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 1"); + end if; + + Char_Source(0) := IC.nul; + + String_Copy(Char_Target, Char_Source); + + if Char_Target(0) /= Char_Source(0) then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 2"); + end if; + + if String_Length(Char_Target) /= 0 then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 2"); + end if; + + -- The following chars_ptr designates a char_array of 12 chars + -- (including the terminating nul char). + Source_Ptr := ICS.New_Char_Array(IC.To_C(TC_String)); + + String_Copy(Char_Target, ICS.Value(Source_Ptr)); + + Target_Ptr := ICS.New_Char_Array(Char_Target); + + if ICS.Value(Target_Ptr) /= TC_String then + Report.Failed("Incorrect result from the imported version of " & + "strcpy - 3"); + end if; + + if String_Length(ICS.Value(Target_Ptr)) /= TC_String'Length then + Report.Failed("Incorrect result from the imported version of " & + "strlen - 3"); + end if; + + + Char_Source(0..9) := "100.00only"; + + Double_Result := String_To_Double(Char_Source); + + Char_Source(0..13) := "5050.00$$$$$$$"; + + if Double_Result + String_To_Double(Char_Source) /= 5150.00 then + Report.Failed("Incorrect result returned from the imported " & + "version of function strtod - 1"); + end if; + + Char_Source(0..9) := "xxx$10.00x"; -- String doesn't contain a + -- valid floating point value. + if String_To_Double(Char_Source) /= 0.0 then + Report.Failed("Incorrect result returned from the imported " & + "version of function strtod - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3009.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,305 ---- + -- CXB3009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function To_Chars_Ptr will return a Null_Ptr value + -- when the parameter Item is null. If the parameter Item is not null, + -- and references a chars_array object that does contain the char nul, + -- and parameter Nul_Check is True, check that To_Chars_Ptr performs a + -- pointer conversion from char_array_access type to chars_ptr type. + -- Check that if parameter Item is not null, and references a + -- chars_array object that does not contain nul, and parameter Nul_Check + -- is True, the To_Chars_Ptr function will propagate Terminator_Error. + -- Check that if parameter Item is not null, and parameter Nul_Check + -- is False, check that To_Chars_Ptr performs a pointer conversion from + -- char_array_access type to chars_ptr type. + -- + -- Check that the New_Char_Array function will return a chars_ptr type + -- pointer to an allocated object that has been initialized with + -- the value of parameter Chars. + -- + -- Check that the function New_String returns a chars_ptr initialized + -- to a nul-terminated string having the value of the Str parameter. + -- + -- TEST DESCRIPTION: + -- This test uses a variety of of string, char_array, + -- char_array_access and char_ptr values in order to validate the + -- functions under test, and results are compared for both length + -- and content. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', and 'A'.. 'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C.Strings. If an implementation provides + -- package Interfaces.C.Strings, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 20 Sep 95 SAIC Initial prerelease version. + -- 09 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 01 DEC 97 EDS Remove incorrect block of code (previously + -- lines 264-287) + -- 14 Sep 99 RLB Added check for behavior of To_Chars_Ptr when + -- Nul_Check => False. (From Technical + -- Corrigendum 1). + --! + + with Report; + with Interfaces.C.Strings; -- N/A => ERROR + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Strings.Fixed; + + procedure CXB3009 is + begin + + Report.Test ("CXB3009", "Check that functions To_Chars_Ptr, " & + "New_Chars_Array, and New_String produce " & + "correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + use Ada.Exceptions; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + Test_String : constant String := "Test String"; + String_With_nul : String(1..6) := "Addnul"; + String_Without_nul : String(1..6) := "No nul"; + + Char_Array_With_nul : IC.char_array(0..6) := + IC.To_C(String_With_nul, True); + Char_Array_Without_nul : IC.char_array(0..5) := + IC.To_C(String_Without_nul, False); + Char_Array_W_nul_Ptr : ICS.char_array_access := + new IC.char_array'(Char_Array_With_nul); + Char_Array_WO_nul_Ptr : ICS.char_array_access := + new IC.char_array'(Char_Array_Without_nul); + + TC_chars_ptr : ICS.chars_ptr; + + TC_size_t : IC.size_t := IC.size_t'First; + + + begin + + -- Check that the function To_Chars_Ptr will return a Null_Ptr value + -- when the parameter Item is null. + + if ICS.To_Chars_Ptr(Item => Null_Char_Array_Access, + Nul_Check => False) /= ICS.Null_Ptr or + ICS.To_Chars_Ptr(Null_Char_Array_Access, + Nul_Check => True) /= ICS.Null_Ptr or + ICS.To_Chars_Ptr(Null_Char_Array_Access) /= ICS.Null_Ptr + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being a null value"); + end if; + + + -- Check that if the parameter Item is not null, and references a + -- chars_array object that does contain the nul char, and parameter + -- Nul_Check is True, function To_Chars_Ptr performs a pointer + -- conversion from char_array_access type to chars_ptr type. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_W_nul_Ptr, + Nul_Check => True); + + if ICS.Value(TC_chars_ptr) /= String_With_nul or + ICS.Value(TC_chars_ptr) /= Char_Array_With_nul + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being non-null and " & + "containing the nul char"); + end if; + exception + when IC.Terminator_Error => + Report.Failed("Terminator_Error raised during the validation " & + "of Function To_Chars_Ptr"); + when others => + Report.Failed("Unexpected exception raised during the " & + "validation of Function To_Chars_Ptr"); + end; + + -- Check that if parameter Item is not null, and references a + -- chars_array object that does not contain nul, and parameter + -- Nul_Check is True, the To_Chars_Ptr function will propagate + -- Terminator_Error. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Char_Array_WO_nul_Ptr, True); + Report.Failed("Terminator_Error was not raised by function " & + "To_Chars_Ptr when given a parameter Item that " & + "is non-null, and does not contain the nul " & + "char, but parameter Nul_Check is True"); + TC_size_t := ICS.Strlen(TC_chars_ptr); -- Use TC_chars_ptr to + -- defeat optimization; + exception + when IC.Terminator_Error => null; -- Expected exception. + when others => + Report.Failed("Incorrect exception raised when function " & + "To_Chars_Ptr is given a parameter Item that " & + "is non-null, and does not contain the nul " & + "char, but parameter Nul_Check is True"); + end; + + -- Check that if the parameter Item is not null, and parameter + -- Nul_Check is False, function To_Chars_Ptr performs a pointer + -- conversion from char_array_access type to chars_ptr type. + + begin + TC_chars_ptr := ICS.To_Chars_Ptr(Item => Char_Array_WO_nul_Ptr, + Nul_Check => False); + + if ICS.Value(TC_chars_ptr, 6) /= String_Without_nul or + ICS.Value(TC_chars_ptr, 6) /= Char_Array_Without_nul + then + Report.Failed("Incorrect result from function To_Chars_Ptr " & + "with parameter Item being non-null and " & + "Nul_Check False"); + end if; + exception + when IC.Terminator_Error => + Report.Failed("Terminator_Error raised during the validation " & + "of Function To_Chars_Ptr"); + when others => + Report.Failed("Unexpected exception raised during the " & + "validation of Function To_Chars_Ptr"); + end; + + + -- Check that the New_Char_Array function will return a chars_ptr type + -- pointer to an allocated object that has been initialized with + -- the value of parameter Chars. + TC_chars_ptr := ICS.New_String(""); + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_With_nul); + + if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation. + Report.Failed + ("No allocation took place in call to New_Char_Array " & + "with a non-null char_array parameter containing a " & + "terminating nul char"); + end if; + + -- Length of allocated array is determined using Strlen since array + -- is nul terminated. Contents of array are validated using Value. + + if ICS.Value (TC_chars_ptr, Length => 7) /= Char_Array_With_nul or + ICS.Strlen(Item => TC_chars_ptr) /= 6 + then + Report.Failed + ("Incorrect length of allocated char_array resulting " & + "from call of New_Char_Array with a non-null " & + "char_array parameter containing a terminating nul char"); + end if; + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(Chars => Char_Array_Without_nul); + + if TC_chars_ptr = ICS.Null_Ptr then -- Check allocation. + Report.Failed + ("No allocation took place in call to New_Char_Array " & + "with a non-null char_array parameter that did not " & + "contain a terminating nul char"); + end if; + + -- Function Value is used with the total length of the + -- Char_Array_Without_nul as a parameter to verify the allocation. + + if ICS.Value(Item => TC_chars_ptr, Length => 6) /= + Char_Array_Without_nul or + ICS.Strlen(Item => TC_chars_ptr) /= 6 + then + Report.Failed("Incorrect length of allocated char_array " & + "resulting from call of New_Char_Array with " & + "a non-null char_array parameter that did not " & + "contain a terminating nul char"); + end if; + + + -- Check that the function New_String returns a chars_ptr specifying + -- an allocated object initialized to the value of parameter Str. + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 3"); + end if; + + TC_chars_ptr := ICS.New_String(Str => Test_String); + + if ICS.Value(TC_chars_ptr) /= Test_String or + ICS.Value(ICS.New_Char_Array(IC.To_C(Test_String,True))) /= + Test_String + then + Report.Failed("Incorrect allocation resulting from function " & + "New_String with a string parameter value"); + end if; + + ICS.Free(TC_chars_ptr); -- Reset the chars_ptr to Null_Ptr; + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("Reset of TC_chars_ptr to Null not successful - 4"); + end if; + + if ICS.Value(ICS.New_String(String_Without_nul)) /= + String_Without_nul or + ICS.Value(ICS.New_Char_Array(IC.To_C(String_Without_nul,False))) /= + String_Without_nul + then + Report.Failed("Incorrect allocation resulting from function " & + "New_String with parameter value String_Without_nul"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3010.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,320 ---- + -- CXB3010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Procedure Free resets the parameter Item to + -- Null_Ptr. Check that Free has no effect if Item is Null_Ptr. + -- + -- Check that the version of Function Value with a chars_ptr parameter + -- returning a char_array result returns the prefix of an array of + -- chars. + -- + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter returning a char_array result returns + -- the shorter of: + -- 1) the first size_t number of characters, or + -- 2) the characters up to and including the first nul. + -- + -- Check that both of the above versions of Function Value propagate + -- Dereference_Error if the Item parameter is Null_Ptr. + -- + -- TEST DESCRIPTION: + -- This test validates the Procedure Free and two versions of Function + -- Value. A variety of char_array and char_ptr values are provided as + -- input, and results are compared for both length and content. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', and 'A'..'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C.Strings. If an implementation provides + -- package Interfaces.C.Strings, this test must compile, execute, + -- and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 27 Sep 95 SAIC Initial prerelease version. + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 01 DEC 97 EDS Replicate line 199 at line 256, to ensure that + -- TC_chars_ptr has a valid pointer. + -- 08 JUL 99 RLB Added a test case to check that Value raises + -- Constraint_Error when Length = 0. (From Technical + -- Corrigendum 1). + -- 25 JAN 01 RLB Repaired previous test case to avoid raising + -- Constraint_Error in test case code. + -- 26 JAN 01 RLB Added an Ident_Int to the test case to prevent + -- optimization. + + --! + + with Report; + with Interfaces.C.Strings; -- N/A => ERROR + + procedure CXB3010 is + begin + + Report.Test ("CXB3010", "Check that Procedure Free and versions of " & + "Function Value produce correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + use type IC.char; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + TC_String_1 : constant String := "Nonul"; + TC_String_2 : constant String := "AbCdE"; + TC_Blank_String : constant String(1..5) := (others => ' '); + + -- The initialization of the following char_array objects + -- includes the appending of a terminating nul char, in order to + -- prevent the erroneous execution of Function Value. + + TC_char_array : IC.char_array := + IC.To_C(TC_Blank_String, True); + TC_char_array_1 : constant IC.char_array := + IC.To_C(TC_String_1, True); + TC_char_array_2 : constant IC.char_array := + IC.To_C(TC_String_2, True); + TC_Blank_char_array : constant IC.char_array := + IC.To_C(TC_Blank_String, True); + + -- This chars_ptr is initialized via the use of New_Chars_Array to + -- avoid erroneous execution of procedure Free. + TC_chars_ptr : ICS.chars_ptr := + ICS.New_Char_Array(TC_Blank_char_array); + + begin + + -- Check that the Procedure Free resets the parameter Item + -- to Null_Ptr. + + if TC_chars_ptr = ICS.Null_Ptr then + Report.Failed("TC_chars_ptr is currently null; it should not be " & + "null since it was given default initialization"); + end if; + + ICS.Free(TC_chars_ptr); + + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("TC_chars_ptr was not set to Null_Ptr by " & + "Procedure Free"); + end if; + + -- Check that Free has no effect if Item is Null_Ptr. + + begin + TC_chars_ptr := ICS.Null_Ptr; -- Ensure pointer is null. + ICS.Free(TC_chars_ptr); + if TC_chars_ptr /= ICS.Null_Ptr then + Report.Failed("TC_chars_ptr was set to a non-Null_Ptr value " & + "by Procedure Free. It was provided as a null " & + "parameter to Free, and there should have been " & + "no effect from a call to Procedure Free"); + end if; + exception + when others => + Report.Failed("Unexpected exception raised by Procedure Free " & + "when parameter Item is Null_Ptr"); + end; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- that returns a char_array result returns an array of chars (up to + -- and including the first nul). + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_char_array := ICS.Value(Item => TC_chars_ptr); + + if TC_char_array /= TC_char_array_1 or + IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_1) + then + Report.Failed("Incorrect result from Function Value - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + TC_char_array := ICS.Value(Item => TC_chars_ptr); + + if TC_char_array /= TC_char_array_2 or + IC.To_Ada(TC_char_array, True) /= IC.To_Ada(TC_char_array_2) + then + Report.Failed("Incorrect result from Function Value - 2"); + end if; + + if ICS.Value(Item => ICS.New_String("A little longer string")) /= + IC.To_C("A little longer string") + then + Report.Failed("Incorrect result from Function Value - 3"); + end if; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter that returns a char_array result returns + -- the shorter of: + -- 1) the first size_t number of characters, or + -- 2) the characters up to and including the first nul. + + -- Case 1: the first size_t number of characters (less than the + -- total length). + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_char_array(0..2) := ICS.Value(Item => TC_chars_ptr, Length => 3); + + if TC_char_array(0..2) /= TC_char_array_1(0..2) + then + Report.Failed + ("Incorrect result from Function Value with Length " & + "parameter - 1"); + end if; + exception + when others => + Report.Failed("Exception raised during Case 1 evaluation"); + end; + + -- Case 2: the characters up to and including the first nul. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + -- The length supplied as a parameter exceeds the total length of + -- TC_char_array_2. The result should be the entire TC_char_array_2 + -- including the terminating nul. + + TC_char_array := ICS.Value(Item => TC_chars_ptr, Length => 7); + + if TC_char_array /= TC_char_array_2 or + IC.To_Ada(TC_char_array) /= IC.To_Ada(TC_char_array_2) or + not (IC.Is_Nul_Terminated(TC_char_array)) + then + Report.Failed("Incorrect result from Function Value with Length " & + "parameter - 2"); + end if; + + + -- Check that both of the above versions of Function Value propagate + -- Dereference_Error if the Item parameter is Null_Ptr. + + declare + + -- Declare a dummy function to demonstrate one way that a chars_ptr + -- variable could inadvertantly be set to Null_Ptr prior to a call + -- to Value (below). + function Freedom (Condition : Boolean := False; + Ptr : ICS.chars_ptr) return ICS.chars_ptr is + Pointer : ICS.chars_ptr := Ptr; + begin + if Condition then + ICS.Free(Pointer); + else + null; -- An activity that doesn't set the chars_ptr value to + -- Null_Ptr. + end if; + return Pointer; + end Freedom; + + begin + + begin + TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr)); + Report.Failed + ("Function Value (without Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_char_array(0) = '6' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with Item parameter, when the Item parameter " & + "is Null_Ptr"); + end; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + begin + TC_char_array := ICS.Value(Item => Freedom(True, TC_chars_ptr), + Length => 4); + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_char_array(0) = '6' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "the Item parameter is Null_Ptr"); + end; + end; + + -- Check that Function Value with two parameters propagates + -- Constraint_Error if Length is 0. + + begin + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + declare + TC : IC.char_array := ICS.Value(Item => TC_chars_ptr, Length => + IC.Size_T(Report.Ident_Int(0))); + begin + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Constraint_Error when Length = 0"); + if TC'Length <= TC_char_array'Length then + TC_char_array(1..TC'Length) := TC; -- Block optimization of TC. + end if; + end; + + Report.Failed + ("Function Value (with Length parameter) did not " & + "raise Constraint_Error when Length = 0"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "Length = 0"); + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXB3010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3011.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,282 ---- + -- CXB3011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the version of Function Value with a chars_ptr parameter + -- that returns a String result returns an Ada string containing the + -- characters pointed to by the chars_ptr parameter, up to (but not + -- including) the terminating nul. + -- + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter that returns a String result returns the + -- shorter of: + -- 1) a String of the first size_t number of characters, or + -- 2) a String of characters up to (but not including) the + -- terminating nul. + -- + -- Check that the Function Strlen returns a size_t result that + -- corresponds to the number of chars in the array pointed to by Item, + -- up to but not including the terminating nul. + -- + -- Check that both of the above versions of Function Value and + -- Function Strlen propagate Dereference_Error if the Item parameter + -- is Null_Ptr. + -- + -- TEST DESCRIPTION: + -- This test validates two versions of Function Value, and the Function + -- Strlen. A series of char_ptr values are provided as input, and + -- results are compared for length or content. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*' and '.'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C.Strings. If an implementation provides + -- package Interfaces.C.Strings, this test must compile, execute, + -- and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 28 Sep 95 SAIC Initial prerelease version. + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Characters.Latin_1; + with Interfaces.C.Strings; -- N/A => ERROR + + procedure CXB3011 is + begin + + Report.Test ("CXB3011", "Check that the two versions of Function Value " & + "returning a String result, and the Function " & + "Strlen, produce correct results"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + package ACL1 renames Ada.Characters.Latin_1; + + use type IC.char_array; + use type IC.size_t; + use type ICS.chars_ptr; + + Null_Char_Array_Access : constant ICS.char_array_access := null; + + TC_String : String(1..5) := (others => 'X'); + TC_String_1 : constant String := "*.3*0"; + TC_String_2 : constant String := "Two"; + TC_String_3 : constant String := "Five5"; + TC_Blank_String : constant String(1..5) := (others => ' '); + + TC_char_array : IC.char_array := + IC.To_C(TC_Blank_String, True); + TC_char_array_1 : constant IC.char_array := + IC.To_C(TC_String_1, True); + TC_char_array_2 : constant IC.char_array := + IC.To_C(TC_String_2, True); + TC_char_array_3 : constant IC.char_array := + IC.To_C(TC_String_3, True); + TC_Blank_char_array : constant IC.char_array := + IC.To_C(TC_Blank_String, True); + + TC_chars_ptr : ICS.chars_ptr := + ICS.New_Char_Array(TC_Blank_char_array); + + TC_size_t : IC.size_t := IC.size_t'First; + + + begin + + -- Check that the version of Function Value with a chars_ptr parameter + -- that returns a String result returns an Ada string containing the + -- characters pointed to by the chars_ptr parameter, up to (but not + -- including) the terminating nul. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_String := ICS.Value(Item => TC_chars_ptr); + + if TC_String /= TC_String_1 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + if ICS.Value(Item => TC_chars_ptr) /= + IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True) + then + Report.Failed("Incorrect result from Function Value - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3); + TC_String := ICS.Value(TC_chars_ptr); + + if TC_String /= TC_String_3 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 3"); + end if; + + + -- Check that the version of Function Value with a chars_ptr parameter + -- and a size_t parameter that returns a String result returns the + -- shorter of: + -- 1) a String of the first size_t number of characters, or + -- 2) a String of characters up to (but not including) the + -- terminating nul. + -- + + -- Case 1 : Length parameter specifies a length shorter than total + -- length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_1); + TC_String := "XXXXX"; -- Reinitialize all characters in string. + TC_String(1..5) := ICS.Value(Item => TC_chars_ptr, Length => 6); + + if TC_String(1..4) /= TC_String_1(1..4) or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 4"); + end if; + + -- Case 2 : Length parameter specifies total length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + + if ICS.Value(TC_chars_ptr, Length => 5) /= + IC.To_Ada(ICS.Value(TC_chars_ptr), Trim_Nul => True) + then + Report.Failed("Incorrect result from Function Value - 5"); + end if; + + -- Case 3 : Length parameter specifies a length longer than total + -- length. + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_3); + TC_String := "XXXXX"; -- Reinitialize all characters in string. + TC_String := ICS.Value(TC_chars_ptr, 7); + + if TC_String /= TC_String_3 or + TC_String(TC_String'Last) = ACL1.NUL + then + Report.Failed("Incorrect result from Function Value - 6"); + end if; + + + -- Check that the Function Strlen returns a size_t result that + -- corresponds to the number of chars in the array pointed to by + -- parameter Item, up to but not including the terminating nul. + + TC_chars_ptr := ICS.New_Char_Array(IC.To_C("A longer string value")); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 21 then + Report.Failed("Incorrect result from Function Strlen - 1"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(TC_char_array_2); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 3 then -- Nul not included in length. + Report.Failed("Incorrect result from Function Strlen - 2"); + end if; + + TC_chars_ptr := ICS.New_Char_Array(IC.To_C("")); + TC_size_t := ICS.Strlen(TC_chars_ptr); + + if TC_size_t /= 0 then + Report.Failed("Incorrect result from Function Strlen - 3"); + end if; + + + -- Check that both of the above versions of Function Value and + -- function Strlen propagate Dereference_Error if the Item parameter + -- is Null_Ptr. + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_String := ICS.Value(Item => TC_chars_ptr); + Report.Failed("Function Value (without Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_String(1) = '1' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with Item parameter, when the Item parameter " & + "is Null_Ptr"); + end; + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_String := ICS.Value(Item => TC_chars_ptr, Length => 4); + Report.Failed("Function Value (with Length parameter) did not " & + "raise Dereference_Error when provided a null Item " & + "parameter input value"); + if TC_String(1) = '1' then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Value " & + "with both Item and Length parameters, when " & + "the Item parameter is Null_Ptr"); + end; + + begin + TC_chars_ptr := ICS.Null_Ptr; + TC_size_t := ICS.Strlen(Item => TC_chars_ptr); + Report.Failed("Function Strlen did not raise Dereference_Error" & + "when provided a null Item parameter input value"); + if TC_size_t = 35 then -- Defeat optimization. + Report.Comment("Should never be printed"); + end if; + exception + when ICS.Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function Strlen " & + "when the Item parameter is Null_Ptr"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXB3011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3012.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,342 ---- + -- 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30130.c 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + /* + -- CXB30130.C + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FUNCTION NAME: CXB30130 ("square_it") + -- + -- FUNCTION DESCRIPTION: + -- This C function returns the square of num1 through the function + -- name, and returns the square of parameters num2, num3, and num4 + -- through the argument list (modifying the objects pointed to by + -- the parameters). + -- + -- INPUTS: + -- This function requires that four parameters be passed to it. + -- The types of these parameters are, in order: int, pointer to short, + -- pointer to float, and pointer to double. + -- + -- PROCESSING: + -- The function will calculate the square of the int parameter (num1), + -- and return this value as the function result through the function + -- name. The function will also calculate the square of the values + -- pointed to by the remaining three parameters (num2, num3, num4), + -- and will modify the referenced memory locations to contain the + -- squared values. + -- + -- OUTPUTS: + -- The square of num1 is returned through function name. + -- Parameters num2-num4 now point to values that are the squared results + -- of the originally referenced values (i.e., the original values are + -- modified as a result of this function). + -- + -- CHANGE HISTORY: + -- 12 Oct 95 SAIC Initial prerelease version. + -- + --! + */ + + int CXB30130 (int num1, short* num2, float* num3, double* num4) + + /* NOTE: The above function definition should be accepted by an ANSI-C */ + /* compiler. Older C compilers may reject it; they may, however */ + /* accept the following five lines. An implementation may comment */ + /* out the above function definition and uncomment the following */ + /* one. Otherwise, an implementation must provide the necessary */ + /* modifications to this C code to satisfy the function */ + /* requirements (see Function Description). */ + /* */ + /* int CXB30130 (num1, num2, num3, num4) */ + /* int num1; */ + /* short* num2; */ + /* float* num3; */ + /* double* num4; */ + /* */ + + { + int return_value = 0; + + return_value = num1 * num1; + *num2 = *num2 * *num2; /* Return square of these parameters through */ + *num3 = *num3 * *num3; /* the parameter list. */ + *num4 = *num4 * *num4; + + return (return_value); /* Return square of num1 through function name */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30131.c 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + /* + -- CXB30131.C + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- FUNCTION NAME: CXB30131 ("combine_two_strings") + -- + -- FUNCTION DESCRIPTION: + -- This C function returns a pointer to the combination of two + -- input strings. + -- + -- INPUTS: + -- This function requires that two parameters be passed to it. + -- The type of both of these parameters are pointer to char (which + -- is used to reference an array of chars). + -- + -- PROCESSING: + -- The function will create a char array that is equal to the combined + -- length of the char arrays referenced by the two input parameters. + -- The char elements contained in the char arrays specified by the + -- parameters will be combined (in order) into this new char array. + -- + -- OUTPUTS: + -- The newly created char array will be returned as the function + -- result through the function name. The char arrays referenced by the + -- two parameters will be unaffected. + -- + -- CHANGE HISTORY: + -- 12 Oct 95 SAIC Initial prerelease version. + -- 26 Oct 96 SAIC Modified temp array initialization. + -- 15 Feb 99 RLB Repaired to remove non-standard function strdup. + --! + */ + + #include + + char *stringdup (char *s) + { + char *result = (char *) malloc(sizeof(char)*(strlen(s)+1)); + return strcpy(result,s); + } + + char *CXB30131 (char *string1, char *string2) + + /* NOTE: The above function definition should be accepted by an ANSI-C */ + /* compiler. Older C compilers may reject it; they may, however */ + /* accept the following three lines. An implementation may comment */ + /* out the above function definition and uncomment the following */ + /* one. Otherwise, an implementation must provide the necessary */ + /* modifications to this C code to satisfy the function */ + /* requirements (see Function Description). */ + /* */ + /* char *CXB30131 (string1, string2) */ + /* char *string1; */ + /* char *string2; */ + + { + char temp[100]; /* Local array that holds the combined strings */ + int index; /* Loop counter */ + int length = 0; /* Variable that holds the length of the strings */ + + /* Initialize the local array */ + for (index = 0; index < 100; index++) + { temp[index] = 0; } + + /* Use the library function strcpy to copy the contents of string1 + into temp. */ + strcpy (temp, string1); + + /* Use the library function strlen to determine the number of + characters in the temp array (without the trailing nul). */ + length = strlen (temp); + + /* Add each character in string2 into the temp array, add nul + to the end of the array. */ + for (index = length; *string2 != '\0'; index++) + { temp[index] = *string2++; } + temp[index] = '\0'; + + /* Use the library function strdup to return a pointer to temp. */ + return (stringdup(temp)); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb30132.am 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,205 ---- + -- CXB30132.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that imported, user-defined C language functions can be + -- called from an Ada program. + -- + -- TEST DESCRIPTION: + -- This test checks that user-defined C language functions can be + -- imported and referenced from an Ada program. Two C language + -- functions are specified in files CXB30130.C and CXB30131.C. + -- These two functions are imported to this test program, using two + -- calls to Pragma Import. Each function is then called in this test, + -- and the results of the call are verified. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', and 'A'..'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- packages Interfaces.C and Interfaces.C.Strings. If an + -- implementation provides packages Interfaces.C and + -- Interfaces.C.Strings, this test must compile, execute, and + -- report "PASSED". + -- + -- SPECIAL REQUIREMENTS: + -- The files CXB30130.C and CXB30131.C must be compiled with a C + -- compiler. Implementation dialects of C may require alteration of + -- the C program syntax (see individual C files). + -- + -- Note that the compiled C code must be bound with the compiled Ada + -- code to create an executable image. An implementation must provide + -- the necessary commands to accomplish this. + -- + -- Note that the C code included in CXB30130.C and CXB30131.C conforms + -- to ANSI-C. Modifications to these files may be required for other + -- C compilers. An implementation must provide the necessary + -- modifications to satisfy the function requirements. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CXB30130.C + -- CXB30131.C + -- CXB30132.AM + -- + -- + -- CHANGE HISTORY: + -- 13 Oct 95 SAIC Initial prerelease version. + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Impdef; + with Interfaces.C; -- N/A => ERROR + with Interfaces.C.Strings; -- N/A => ERROR + + procedure CXB30132 is + begin + + Report.Test ("CXB3013", "Check that user-defined C functions can " & + "be imported into an Ada program"); + + Test_Block: + declare + + package IC renames Interfaces.C; + package ICS renames Interfaces.C.Strings; + + use type IC.char_array; + use type IC.int; + use type IC.short; + use type IC.C_float; + use type IC.double; + + type Short_Ptr is access all IC.short; + type Float_Ptr is access all IC.C_float; + type Double_Ptr is access all IC.double; + subtype Char_Array_Type is IC.char_array(0..20); + + TC_Default_int : IC.int := 49; + TC_Default_short : IC.short := 3; + TC_Default_float : IC.C_float := 50.0; + TC_Default_double : IC.double := 1209.0; + + An_Int_Value : IC.int := TC_Default_int; + A_Short_Value : aliased IC.short := TC_Default_short; + A_Float_Value : aliased IC.C_float := TC_Default_float; + A_Double_Value : aliased IC.double := TC_Default_double; + + A_Short_Int_Pointer : Short_Ptr := A_Short_Value'access; + A_Float_Pointer : Float_Ptr := A_Float_Value'access; + A_Double_Pointer : Double_Ptr := A_Double_Value'access; + + Char_Array_1 : Char_Array_Type; + Char_Array_2 : Char_Array_Type; + Char_Pointer : ICS.chars_ptr; + + TC_Char_Array : constant Char_Array_Type := + "Look before you leap" & IC.nul; + TC_Return_int : IC.int := 0; + + -- The Square_It function returns the square of the value The_Int + -- through the function name, and returns the square of the other + -- parameters through the parameter list (the last three parameters + -- are access values). + + function Square_It (The_Int : in IC.int; + The_Short : in Short_Ptr; + The_Float : in Float_Ptr; + The_Double : in Double_Ptr) return IC.int; + + -- The Combine_Strings function returns the result of the catenation + -- of the two string parameters through the function name. + + function Combine_Strings (First_Part : in IC.char_array; + Second_Part : in IC.char_array) + return ICS.chars_ptr; + + + -- Use the user-defined C function square_it as a completion to the + -- function specification above. + + pragma Import (Convention => C, + Entity => Square_It, + External_Name => Impdef.CXB30130_External_Name); + + -- Use the user-defined C function combine_two_strings as a completion + -- to the function specification above. + + pragma Import (C, Combine_Strings, Impdef.CXB30131_External_Name); + + + begin + + -- Check that the imported version of C function CXB30130 produces + -- the correct results. + + TC_Return_int := Square_It (The_Int => An_Int_Value, + The_Short => A_Short_Int_Pointer, + The_Float => A_Float_Pointer, + The_Double => A_Double_Pointer); + + -- Compare the results with the expected results. Note that in the + -- case of the three "pointer" parameters, the objects being pointed + -- to have been modified as a result of the function. + + if TC_Return_int /= An_Int_Value * An_Int_Value or + A_Short_Int_Pointer.all /= TC_Default_short * TC_Default_Short or + A_Short_Value /= TC_Default_short * TC_Default_Short or + A_Float_Pointer.all /= TC_Default_float * TC_Default_float or + A_Float_Value /= TC_Default_float * TC_Default_float or + A_Double_Pointer.all /= TC_Default_double * TC_Default_double or + A_Double_Value /= TC_Default_double * TC_Default_double + then + Report.Failed("Incorrect results returned from function square_it"); + end if; + + + -- Check that two char_array values are combined by the imported + -- C function CXB30131. + + Char_Array_1(0..12) := "Look before " & IC.nul; + Char_Array_2(0..8) := "you leap" & IC.nul; + + Char_Pointer := Combine_Strings (Char_Array_1, Char_Array_2); + + if ICS.Value(Char_Pointer) /= TC_Char_Array then + Report.Failed("Incorrect value returned from imported function " & + "combine_two_strings"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXB30132; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3014.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,254 ---- + -- CXB3014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Function Value with Pointer and Element + -- parameters will return an Element_Array result of correct size + -- and content (up to and including the first "terminator" Element). + -- + -- Check that the Function Value with Pointer and Length parameters + -- will return an Element_Array result of appropriate size and content + -- (the first Length elements pointed to by the parameter Ref). + -- + -- Check that both versions of Function Value will propagate + -- Interfaces.C.Strings.Dereference_Error when the value of + -- the Ref pointer parameter is null. + -- + -- TEST DESCRIPTION: + -- This test tests that both versions of Function Value from the + -- generic package Interfaces.C.Pointers are available and produce + -- correct results. The generic package is instantiated with size_t, + -- char, char_array, and nul as actual parameters, and subtests are + -- performed on each of the Value functions resulting from this + -- instantiation. + -- For both function versions, a test is performed where a portion of + -- a char_array is to be returned as the function result. Likewise, + -- a test is performed where each version of the function returns the + -- entire char_array referenced by the in parameter Ref. + -- Finally, both versions of Function Value are called with a null + -- pointer reference, to ensure that Dereference_Error is raised in + -- this case. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', 'a'..'z', and 'A'..'Z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- packages Interfaces.C.Strings and Interfaces.C.Pointers. If an + -- implementation provides packages Interfaces.C.Strings and + -- Interfaces.C.Pointers, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 19 Oct 95 SAIC Initial prerelease version. + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 23 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Interfaces.C.Strings; -- N/A => ERROR + with Interfaces.C.Pointers; -- N/A => ERROR + + procedure CXB3014 is + + begin + + Report.Test ("CXB3014", "Check that versions of the Value function " & + "from package Interfaces.C.Pointers produce " & + "correct results"); + + Test_Block: + declare + + use type Interfaces.C.char, Interfaces.C.size_t; + + Char_a : constant Interfaces.C.char := 'a'; + Char_j : constant Interfaces.C.char := 'j'; + Char_z : constant Interfaces.C.char := 'z'; + + subtype Lower_Case_chars is Interfaces.C.char range Char_a..Char_z; + subtype Char_Range is Interfaces.C.size_t range 0..26; + + Local_nul : aliased Interfaces.C.char := Interfaces.C.nul; + TC_Array_Size : Interfaces.C.size_t := 20; + + TC_String_1 : constant String := "abcdefghij"; + TC_String_2 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_String_3 : constant String := "abcdefghijklmnopqrst"; + TC_String_4 : constant String := "abcdefghijklmnopqrstuvwxyz"; + TC_Blank_String : constant String := " "; + + TC_Char_Array : Interfaces.C.char_array(Char_Range) := + Interfaces.C.To_C(TC_String_2, True); + + TC_Char_Array_1 : Interfaces.C.char_array(0..9); + TC_Char_Array_2 : Interfaces.C.char_array(Char_Range); + TC_Char_Array_3 : Interfaces.C.char_array(0..TC_Array_Size-1); + TC_Char_Array_4 : Interfaces.C.char_array(Char_Range); + + package Char_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + Char_Ptr : Char_Pointers.Pointer; + + use type Char_Pointers.Pointer; + + begin + + -- Check that the Function Value with Pointer and Terminator Element + -- parameters will return an Element_Array result of appropriate size + -- and content (up to and including the first "terminator" Element.) + + Char_Ptr := TC_Char_Array(0)'Access; + + -- Provide a new Terminator char in the call of Function Value. + -- This call should return only a portion (the first 10 chars) of + -- the referenced char_array, up to and including the char 'j'. + + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + + if Interfaces.C.To_Ada(TC_Char_Array_1, False) /= TC_String_1 or + Interfaces.C.Is_Nul_Terminated(TC_Char_Array_1) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when supplied with " & + "a non-default Terminator char"); + end if; + + -- Use the default Terminator char in the call of Function Value. + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_2 := Char_Pointers.Value(Char_Ptr); + + if Interfaces.C.To_Ada(TC_Char_Array_2, True) /= TC_String_2 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_2) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Terminator parameters, when using the " & + "default Terminator char"); + end if; + + + + -- Check that the Function Value with Pointer and Length parameters + -- will return an Element_Array result of appropriate size and content + -- (the first Length elements pointed to by the parameter Ref). + + -- This call should return only a portion (the first 20 chars) of + -- the referenced char_array. + + TC_Char_Array_3 := + Char_Pointers.Value(Ref => Char_Ptr, + Length => Interfaces.C.ptrdiff_t(TC_Array_Size)); + + -- Verify the individual chars of the result. + for i in 0..TC_Array_Size-1 loop + if Interfaces.C.To_Ada(TC_Char_Array_3(i)) /= + TC_String_3(Integer(i)+1) + then + Report.Failed("Incorrect result from Function Value with " & + "Ref and Length parameters, when specifying " & + "a length less than the full array size"); + exit; + end if; + end loop; + + -- This call should return the entire char_array, including the + -- terminating nul char. + + TC_Char_Array_4 := Char_Pointers.Value(Char_Ptr, 27); + + if Interfaces.C.To_Ada(TC_Char_Array_4, True) /= TC_String_4 or + not Interfaces.C.Is_Nul_Terminated(TC_Char_Array_4) + then + Report.Failed("Incorrect result from Function Value with Ref " & + "and Length parameters, when specifying the " & + "entire array size"); + end if; + + + + -- Check that both of the above versions of Function Value will + -- propagate Interfaces.C.Strings.Dereference_Error when the value of + -- the Ref Pointer parameter is null. + + Char_Ptr := null; + + begin + TC_Char_Array_1 := Char_Pointers.Value(Ref => Char_Ptr, + Terminator => Char_j); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_1 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_1, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Terminator parameter, when " & + "provided a null reference"); + end; + + + begin + TC_Char_Array_3 := + Char_Pointers.Value(Char_Ptr, + Interfaces.C.ptrdiff_t(TC_Array_Size)); + Report.Failed("Dereference_Error not raised by Function " & + "Value with Length parameter, when provided " & + "a null reference"); + -- Call Report.Comment to ensure that the assignment to + -- TC_Char_Array_3 is not "dead", and therefore can not be + -- optimized away. + Report.Comment(Interfaces.C.To_Ada(TC_Char_Array_3, False)); + exception + when Interfaces.C.Strings.Dereference_Error => + null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Function " & + "Value with Length parameter, when " & + "provided a null reference"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXB3014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3015.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,520 ---- + -- CXB3015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the "+" and "-" functions with Pointer and ptrdiff_t + -- parameters that return Pointer values produce correct results, + -- based on the size of the array elements. + -- + -- Check that the "-" function with two Pointer parameters that + -- returns a ptrdiff_t type parameter produces correct results, + -- based on the size of the array elements. + -- + -- Check that each of the "+" and "-" functions above will + -- propagate Pointer_Error if a Pointer parameter is null. + -- + -- Check that the Increment and Decrement procedures provide the + -- correct "pointer arithmetic" operations. + -- + -- TEST DESCRIPTION: + -- This test checks that the functions "+" and "-", and the procedures + -- Increment and Decrement in the generic package Interfaces.C.Pointers + -- will allow the user to perform "pointer arithmetic" operations on + -- Pointer values. + -- Package Interfaces.C.Pointers is instantiated three times, for + -- short values, chars, and arrays of arrays. Pointers from each + -- instantiated package are then used to reference different elements + -- of array objects. Pointer arithmetic operations are performed on + -- these pointers, and the results of these operations are verified + -- against expected pointer positions along the referenced arrays. + -- The propagation of Pointer_Error is checked for when the function + -- Pointer parameter is null. + -- + -- The following chart indicates the combinations of subprograms and + -- parameter types used in this test. + -- + -- + -- Short Char Array + -- -------------------------- + -- "+" Pointer, ptrdiff_t | X | | X | + -- |--------------------------| + -- "+" ptrdiff_t, Pointer | X | | X | + -- |--------------------------| + -- "-" Pointer, ptrdiff_t | | X | X | + -- |--------------------------| + -- "-" Pointer, Pointer | | X | X | + -- |--------------------------| + -- Increment (Pointer) | X | | X | + -- |--------------------------| + -- Decrement (Pointer) | X | | X | + -- -------------------------- + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', and 'a'..'z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.C.Pointers. If an implementation provides + -- package Interfaces.C.Pointers, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 26 Oct 95 SAIC Initial prerelease version. + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 06 Mar 00 RLB Repaired so that array of arrays component + -- type is statically constrained. (C does not have + -- an analog to an array of dynamically constrained + -- arrays.) + + with Report; + with Ada.Exceptions; + with Interfaces.C.Pointers; -- N/A => ERROR + + procedure CXB3015 is + begin + + Report.Test ("CXB3015", "Check that +, -, Increment, and Decrement " & + "subprograms in Package Interfaces.C.Pointers " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use type Interfaces.C.short; + use type Interfaces.C.size_t, Interfaces.C.ptrdiff_t; + use type Interfaces.C.char, Interfaces.C.char_array; + + TC_Count : Interfaces.C.size_t; + TC_Increment : Interfaces.C.ptrdiff_t; + TC_ptrdiff_t : Interfaces.C.ptrdiff_t; + TC_Short : Interfaces.C.short := 0; + TC_Verbose : Boolean := False; + Constant_Min_Array_Size : constant Interfaces.C.size_t := 0; + Constant_Max_Array_Size : constant Interfaces.C.size_t := 20; + Min_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t( + Report.Ident_Int(Integer(Constant_Min_Array_Size))); + Max_Array_Size : Interfaces.C.size_t := Interfaces.C.size_t( + Report.Ident_Int(Integer(Constant_Max_Array_Size))); + Min_size_t, + Max_size_t : Interfaces.C.size_t; + Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last; + Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz"; + + + type Short_Array_Type is + array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short; + + type Constrained_Array_Type is + array (Min_Array_Size..Max_Array_Size) of aliased Interfaces.C.short; + + type Static_Constrained_Array_Type is + array (Constant_Min_Array_Size .. Constant_Max_Array_Size) of + aliased Interfaces.C.short; + + type Array_of_Arrays_Type is + array (Interfaces.C.size_t range <>) of aliased + Static_Constrained_Array_Type; + + + Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + + Constrained_Array : Constrained_Array_Type; + + Terminator_Array : Static_Constrained_Array_Type := + (others => Short_Terminator); + + Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Alphabet'Length)) := + Interfaces.C.To_C(Alphabet, True); + + Array_of_Arrays : Array_of_Arrays_Type + (Min_Array_Size..Max_Array_Size); + + + package Short_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.short, + Element_Array => Short_Array_Type, + Default_Terminator => Short_Terminator); + + package Char_Pointers is new + Interfaces.C.Pointers (Interfaces.C.size_t, + Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + package Array_Pointers is new + Interfaces.C.Pointers (Interfaces.C.size_t, + Static_Constrained_Array_Type, + Array_of_Arrays_Type, + Terminator_Array); + + + use Short_Pointers, Char_Pointers, Array_Pointers; + + Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access; + Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access; + Start_Char_Ptr : Char_Pointers.Pointer := Ch_Array(1)'Access; + End_Char_Ptr : Char_Pointers.Pointer := Ch_Array(10)'Access; + Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(0)'Access; + Start_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(1)'Access; + End_Array_Ptr : Array_Pointers.Pointer := Array_of_Arrays(10)'Access; + + begin + + -- Provide initial values for the arrays that hold short int values. + + for i in Min_Array_Size..Max_Array_Size-1 loop + Short_Array(i) := Interfaces.C.short(i); + for j in Min_Array_Size..Max_Array_Size loop + -- Initialize this "array of arrays" so that element (i)(0) + -- is different for each value of i. + Array_of_Arrays(i)(j) := TC_Short; + TC_Short := TC_Short + 1; + end loop; + end loop; + + -- Set the final element of each array object to be the "terminator" + -- element used in the instantiations above. + + Short_Array(Max_Array_Size) := Short_Terminator; + Array_of_Arrays(Max_Array_Size) := Terminator_Array; + + -- Check starting pointer positions. + + if Short_Ptr.all /= 0 or + Char_Ptr.all /= Ch_Array(0) or + Array_Ptr.all /= Array_of_Arrays(0) + then + Report.Failed("Incorrect initial value for the first " & + "Short_Array, Ch_Array, or Array_of_Array values"); + end if; + + + -- Check that both versions of the "+" function with Pointer and + -- ptrdiff_t parameters, that return a Pointer value, produce correct + -- results, based on the size of the array elements. + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + + if Integer(i)/2*2 /= Integer(i) then -- Odd numbered loops. + -- Pointer + ptrdiff_t, increment by 1. + Short_Ptr := Short_Ptr + 1; + else -- Even numbered loops. + -- ptrdiff_t + Pointer, increment by 1. + Short_Ptr := 1 + Short_Ptr; + end if; + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the function +, incrementing by 1, " & + "array position : " & Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access; + TC_Count := Min_Array_Size; + TC_Increment := 3; + while TC_Count+Interfaces.C.size_t(TC_Increment) < Max_Array_Size loop + + if Integer(TC_Count)/2*2 /= Integer(TC_Count) then + -- Odd numbered loops. + -- Pointer + ptrdiff_t, increment by 3. + Array_Ptr := Array_Pointers."+"(Array_Ptr, TC_Increment); + else + -- Odd numbered loops. + -- ptrdiff_t + Pointer, increment by 3. + Array_Ptr := Array_Pointers."+"(Left => TC_Increment, + Right => Array_Ptr); + end if; + + if Array_Ptr.all /= + Array_of_Arrays(TC_Count+Interfaces.C.size_t(TC_Increment)) + then + Report.Failed("Incorrect value returned following use " & + "of the function +, incrementing by " & + Integer'Image(Integer(TC_Increment)) & + ", array position : " & + Integer'Image(Integer(TC_Count) + + Integer(TC_Increment))); + if not TC_Verbose then + exit; + end if; + end if; + + TC_Count := TC_Count + Interfaces.C.size_t(TC_Increment); + end loop; + + + + -- Check that the "-" function with Pointer and ptrdiff_t parameters, + -- that returns a Pointer result, produces correct results, based + -- on the size of the array elements. + + -- Set the pointer to the last element in the char_array, which is a + -- nul char. + Char_Ptr := Ch_Array(Interfaces.C.size_t(Alphabet'Length))'Access; + + if Char_Ptr.all /= Interfaces.C.nul then + Report.Failed("Incorrect initial value for the last " & + "Ch_Array value"); + end if; + + Min_size_t := 1; + Max_size_t := Interfaces.C.size_t(Alphabet'Length); + + for i in reverse Min_size_t..Max_size_t loop + + -- Subtract 1 from the pointer; it should now point to the previous + -- element in the array. + Char_Ptr := Char_Ptr - 1; + + if Char_Ptr.all /= Ch_Array(i-1) then + Report.Failed("Incorrect value returned following use " & + "of the function '-' with char element values, " & + "array position : " & Integer'Image(Integer(i-1))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + TC_Count := Max_Array_Size; + TC_Increment := 3; + while TC_Count > Min_Array_Size+Interfaces.C.size_t(TC_Increment) loop + + -- Decrement the pointer by 3. + Array_Ptr := Array_Pointers."-"(Array_Ptr, Right => 3); + + if Array_Ptr.all /= + Array_of_Arrays(TC_Count - Interfaces.C.size_t(TC_Increment)) + then + Report.Failed("Incorrect value returned following use " & + "of the function -, decrementing by " & + Integer'Image(Integer(TC_Increment)) & + ", array position : " & + Integer'Image(Integer(TC_Count-3))); + if not TC_Verbose then + exit; + end if; + end if; + + TC_Count := TC_Count - Interfaces.C.size_t(TC_Increment); + end loop; + + + + -- Check that the "-" function with two Pointer parameters, that + -- returns a ptrdiff_t type result, produces correct results, + -- based on the size of the array elements. + + TC_ptrdiff_t := 9; + if Char_Pointers."-"(Left => End_Char_Ptr, + Right => Start_Char_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 1"); + end if; + + Start_Char_Ptr := Ch_Array(1)'Access; + End_Char_Ptr := Ch_Array(25)'Access; + + TC_ptrdiff_t := 24; + if Char_Pointers."-"(End_Char_Ptr, + Right => Start_Char_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 2"); + end if; + + TC_ptrdiff_t := 9; + if Array_Pointers."-"(End_Array_Ptr, + Start_Array_Ptr) /= TC_ptrdiff_t + then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 3"); + end if; + + Start_Array_Ptr := Array_of_Arrays(Min_Array_Size)'Access; + End_Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + + TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) - + Interfaces.C.ptrdiff_t(Min_Array_Size); + if End_Array_Ptr - Start_Array_Ptr /= TC_ptrdiff_t then + Report.Failed("Incorrect result from pointer-pointer " & + "subtraction - 4"); + end if; + + + + -- Check that the Increment procedure produces correct results, + -- based upon the size of the array elements. + + Short_Ptr := Short_Array(0)'Access; + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + -- Increment the value of the Pointer; it should now point + -- to the next element in the array. + Increment(Ref => Short_Ptr); + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Increment on pointer to an " & + "array of short values, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(0)'Access; + + for i in Min_Array_Size + 1 .. Max_Array_Size loop + -- Increment the value of the Pointer; it should now point + -- to the next element in the array. + Increment(Array_Ptr); + + if Array_Ptr.all /= Array_of_Arrays(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Increment on an array of " & + "arrays, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + + -- Check that the Decrement procedure produces correct results, + -- based upon the size of the array elements. + + Short_Ptr := Short_Array(Max_Array_Size)'Access; + + for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop + -- Decrement the value of the Pointer; it should now point + -- to the previous element in the array. + Decrement(Ref => Short_Ptr); + + if Short_Ptr.all /= Short_Array(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Decrement on pointer to an " & + "array of short values, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + Array_Ptr := Array_of_Arrays(Max_Array_Size)'Access; + + for i in reverse Min_Array_Size .. Max_Array_Size - 1 loop + -- Decrement the value of the Pointer; it should now point + -- to the previous array element. + Decrement(Array_Ptr); + + if Array_Ptr.all /= Array_of_Arrays(i) then + Report.Failed("Incorrect value returned following use " & + "of the Procedure Decrement on an array of " & + "arrays, array position : " & + Integer'Image(Integer(i))); + if not TC_Verbose then + exit; + end if; + end if; + end loop; + + + + -- Check that each of the "+" and "-" functions above will + -- propagate Pointer_Error if a Pointer parameter is null. + + begin + Short_Ptr := null; + Short_Ptr := Short_Ptr + 4; + Report.Failed("Pointer_Error not raised by Function + when " & + "the Pointer parameter is null"); + if Short_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Short_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function + " & + "when the Pointer parameter is null"); + end; + + + begin + Char_Ptr := null; + Char_Ptr := Char_Ptr - 1; + Report.Failed("Pointer_Error not raised by Function - when " & + "the Pointer parameter is null"); + if Char_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Char_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Function - " & + "when the Pointer parameter is null"); + end; + + + begin + Array_Ptr := null; + Decrement(Array_Ptr); + Report.Failed("Pointer_Error not raised by Procedure Decrement " & + "when the Pointer parameter is null"); + if Array_Ptr /= null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Array_Pointers.Pointer_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Procedure " & + "Decrement when the Pointer parameter is null"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb3016.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,516 ---- + -- CXB3016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that function Virtual_Length returns the number of elements + -- in the array referenced by the Pointer parameter Ref, up to (but + -- not including) the (first) instance of the element specified in + -- the Terminator parameter. + -- + -- Check that the procedure Copy_Terminated_Array copies the array of + -- elements referenced by Pointer parameter Source, into the array + -- pointed to by parameter Target, based on which of the following + -- two scenarios occurs first: + -- 1) copying the Terminator element, or + -- 2) copying the number of elements specified in parameter Limit. + -- + -- Check that procedure Copy_Terminated_Array will propagate + -- Dereference_Error if either the Source or Target parameter is null. + -- + -- Check that procedure Copy_Array will copy an array of elements + -- of length specified in parameter Length, referenced by the + -- Pointer parameter Source, into the array pointed to by parameter + -- Target. + -- + -- Check that procedure Copy_Array will propagate Dereference_Error + -- if either the Source or Target parameter is null. + -- + -- TEST DESCRIPTION: + -- This test checks that the function Virtual_Length and the procedures + -- Copy_Terminated_Array and Copy_Array in the generic package + -- Interfaces.C.Pointers will allow the user to manipulate arrays of + -- char and short values through the pointers that reference the + -- arrays. + -- + -- Package Interfaces.C.Pointers is instantiated twice, once for + -- short values and once for chars. Pointers from each instantiated + -- package are then used to reference arrays of the appropriate + -- element type. The subprograms under test are used to determine the + -- length, and to copy, either portions or the entire content of the + -- arrays. The results of these operations are then compared against + -- expected results. + -- + -- The propagation of Dereference_Error is checked for when either + -- of the two procedures is supplied with a null Pointer parameter. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.C.char: + -- ' ', and 'a'..'z'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- packages Interfaces.C, Interfaces.C.Strings, and + -- Interfaces.C.Pointers. If an implementation provides these packages, + -- this test must compile, execute, and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 01 Feb 96 SAIC Initial release for 2.1 + -- 13 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 26 Oct 96 SAIC Incorporated reviewer comments. + -- 26 Feb 97 PWB.CTA Moved code using null pointer to avoid errors + --! + + with Report; + with Ada.Exceptions; + with Interfaces.C; -- N/A => ERROR + with Interfaces.C.Pointers; -- N/A => ERROR + with Interfaces.C.Strings; -- N/A => ERROR + + procedure CXB3016 is + begin + + Report.Test ("CXB3016", "Check that subprograms Virtual_Length, " & + "Copy_Terminated_Array, and Copy_Array " & + "produce correct results"); + + Test_Block: + declare + + use Ada.Exceptions; + use Interfaces.C.Strings; + + use type Interfaces.C.char, + Interfaces.C.char_array, + Interfaces.C.ptrdiff_t, + Interfaces.C.short, + Interfaces.C.size_t; + + TC_char : Interfaces.C.char := 'a'; + TC_ptrdiff_t : Interfaces.C.ptrdiff_t; + TC_Short : Interfaces.C.short := 0; + Min_Array_Size : Interfaces.C.size_t := 0; + Max_Array_Size : Interfaces.C.size_t := 20; + Short_Terminator : Interfaces.C.short := Interfaces.C.short'Last; + Alphabet : constant String := "abcdefghijklmnopqrstuvwxyz"; + Blank_String : constant String := " "; + + type Short_Array_Type is + array (Interfaces.C.size_t range <>) of aliased Interfaces.C.short; + + Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Alphabet'Length)) := + Interfaces.C.To_C(Alphabet, True); + + TC_Ch_Array : Interfaces.C.char_array + (0..Interfaces.C.size_t(Blank_String'Length)) := + Interfaces.C.To_C(Blank_String, True); + + Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + TC_Short_Array : Short_Array_Type(Min_Array_Size..Max_Array_Size); + + + package Char_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.char, + Element_Array => Interfaces.C.char_array, + Default_Terminator => Interfaces.C.nul); + + package Short_Pointers is new + Interfaces.C.Pointers (Index => Interfaces.C.size_t, + Element => Interfaces.C.short, + Element_Array => Short_Array_Type, + Default_Terminator => Short_Terminator); + + use Short_Pointers, Char_Pointers; + + Short_Ptr : Short_Pointers.Pointer := Short_Array(0)'Access; + TC_Short_Ptr : Short_Pointers.Pointer := TC_Short_Array(0)'Access; + Char_Ptr : Char_Pointers.Pointer := Ch_Array(0)'Access; + TC_Char_Ptr : Char_Pointers.Pointer := TC_Ch_Array(0)'Access; + + begin + + -- Provide initial values for the array that holds short int values. + + for i in Min_Array_Size..Max_Array_Size loop + Short_Array(i) := Interfaces.C.short(i); + TC_Short_Array(i) := 100; + end loop; + + -- Set the final element of the short array object to be the "terminator" + -- element used in the instantiation above. + + Short_Array(Max_Array_Size) := Short_Terminator; + + -- Check starting pointer positions. + + if Short_Ptr.all /= 0 or + Char_Ptr.all /= Ch_Array(0) + then + Report.Failed("Incorrect initial value for the first " & + "Char_Array or Short_Array values"); + end if; + + + + -- Check that function Virtual_Length returns the number of elements + -- in the array referenced by the Pointer parameter Ref, up to (but + -- not including) the (first) instance of the element specified in + -- the Terminator parameter. + + TC_char := 'j'; + + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Ref => Char_Ptr, + Terminator => TC_char); + if TC_ptrdiff_t /= 9 then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Char_ptr parameter - 1"); + end if; + + TC_char := Interfaces.C.nul; + + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr, + Terminator => TC_char); + if TC_ptrdiff_t /= Interfaces.C.ptrdiff_t(Alphabet'Length) then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Char_ptr parameter - 2"); + end if; + + TC_Short := 10; + + TC_ptrdiff_t := Short_Pointers.Virtual_Length(Short_Ptr, TC_Short); + + if TC_ptrdiff_t /= 10 then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Short_ptr parameter - 1"); + end if; + + -- Replace an element of the Short_Array with the element used as the + -- terminator of the entire array; now there are two occurrences of the + -- terminator element in the array. The call to Virtual_Length should + -- return the number of array elements prior to the first terminator. + + Short_Array(5) := Short_Terminator; + + if Short_Pointers.Virtual_Length(Short_Ptr, Short_Terminator) /= 5 + then + Report.Failed("Incorrect result from function Virtual_Length " & + "with Short_ptr parameter - 2"); + end if; + + + + -- Check that the procedure Copy_Terminated_Array copies the array of + -- elements referenced by Pointer parameter Source, into the array + -- pointed to by parameter Target, based on which of the following + -- two scenarios occurs first: + -- 1) copying the Terminator element, or + -- 2) copying the number of elements specified in parameter Limit. + -- Note: Terminator element must be copied to Target, as well as + -- all array elements prior to the terminator element. + + if TC_Ch_Array = Ch_Array then + Report.Failed("The two char arrays are equivalent prior to the " & + "call to Copy_Terminated_Array - 1"); + end if; + + + -- Case 1: Copying the Terminator Element. (Default terminator) + + Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr, + Target => TC_Char_Ptr); + + if TC_Ch_Array /= Ch_Array then + Report.Failed("The two char arrays are not equal following the " & + "call to Copy_Terminated_Array, case of copying " & + "the Terminator Element, using default terminator"); + end if; + + -- Reset the Target Pointer array. + + TC_Ch_Array := Interfaces.C.To_C(Blank_String, True); + TC_Char_Ptr := TC_Ch_Array(0)'Access; + + if TC_Ch_Array = Ch_Array then + Report.Failed("The two char arrays are equivalent prior to the " & + "call to Copy_Terminated_Array - 2"); + end if; + + + -- Case 2: Copying the Terminator Element. (Non-Default terminator) + + TC_char := 'b'; -- Second char in char_array pointed to by Char_Ptr + Char_Pointers.Copy_Terminated_Array(Source => Char_Ptr, + Target => TC_Char_Ptr, + Terminator => TC_char); + + if TC_Ch_Array(0) /= Ch_Array(0) or -- Initial value modified. + TC_Ch_Array(1) /= Ch_Array(1) or -- Initial value modified. + TC_Ch_Array(2) = Ch_Array(2) or -- Initial value not modified. + TC_Ch_Array(5) = Ch_Array(5) or -- Initial value not modified. + TC_Ch_Array(15) = Ch_Array(15) or -- Initial value not modified. + TC_Ch_Array(25) = Ch_Array(25) -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two char arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the " & + "Terminator Element, using non-default terminator"); + end if; + + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 1"); + end if; + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Terminator => 2); + + if TC_Short_Array(0) /= Short_Array(0) or + TC_Short_Array(1) /= Short_Array(1) or + TC_Short_Array(2) /= Short_Array(2) or + TC_Short_Array(3) /= 100 -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two short int " & + "arrays are not equal following the call to " & + "Copy_Terminated_Array, case of copying the " & + "Terminator Element, using non-default terminator"); + end if; + + + -- Case 3: Copying the number of elements specified in parameter Limit. + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 2"); + end if; + + TC_ptrdiff_t := 5; + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Limit => TC_ptrdiff_t, + Terminator => Short_Terminator); + + if TC_Short_Array(0) /= Short_Array(0) or + TC_Short_Array(1) /= Short_Array(1) or + TC_Short_Array(2) /= Short_Array(2) or + TC_Short_Array(3) /= Short_Array(3) or + TC_Short_Array(4) /= Short_Array(4) or + TC_Short_Array(5) /= 100 -- Initial value not modified. + then + Report.Failed("The appropriate portions of the two Short arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the number " & + "of elements specified in parameter Limit"); + end if; + + + -- Case 4: Copying the number of elements specified in parameter Limit, + -- which also happens to be the number of elements up to and + -- including the first terminator. + + -- Reset initial values for the array that holds short int values. + + for i in Min_Array_Size..Max_Array_Size loop + Short_Array(i) := Interfaces.C.short(i); + TC_Short_Array(i) := 100; + end loop; + + if TC_Short_Array = Short_Array then + Report.Failed("The two short int arrays are equivalent prior " & + "to the call to Copy_Terminated_Array - 3"); + end if; + + TC_ptrdiff_t := 3; -- Specifies three elements to be copied. + Short_Terminator := 2; -- Value held in Short_Array third element, + -- will serve as the "terminator" element. + + Short_Pointers.Copy_Terminated_Array(Source => Short_Ptr, + Target => TC_Short_Ptr, + Limit => TC_ptrdiff_t, + Terminator => Short_Terminator); + + if TC_Short_Array(0) /= Short_Array(0) or -- First element copied. + TC_Short_Array(1) /= Short_Array(1) or -- Second element copied. + TC_Short_Array(2) /= Short_Array(2) or -- Third element copied. + TC_Short_Array(3) /= 100 -- Initial value of fourth element + then -- not modified. + Report.Failed("The appropriate portions of the two Short arrays " & + "are not equal following the call to " & + "Copy_Terminated_Array, case of copying the number " & + "of elements specified in parameter " & + "Limit, which also happens to be the number of " & + "elements up to and including the first terminator"); + end if; + + + + -- Check that procedure Copy_Terminated_Array will propagate + -- Dereference_Error if either the Source or Target parameter is null. + + Char_Ptr := null; + begin + Char_Pointers.Copy_Terminated_Array(Char_Ptr, TC_Char_Ptr); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Terminated_Array with null Source parameter"); + if TC_Char_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Terminated_Array with null Source parameter"); + end; + + TC_Short_Ptr := null; + begin + Short_Pointers.Copy_Terminated_Array(Short_Ptr, TC_Short_Ptr); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Terminated_Array with null Target parameter"); + if Short_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Terminated_Array with null Target parameter"); + end; + + + + -- Check that the procedure Copy_Array will copy the array of + -- elements of length specified in parameter Length, referenced by + -- the Pointer parameter Source, into the array pointed to by + -- parameter Target. + + -- Reinitialize Target arrays prior to test cases below. + + TC_Ch_Array := Interfaces.C.To_C(Blank_String, True); + + for i in Min_Array_Size..Max_Array_Size loop + TC_Short_Array(i) := 100; + end loop; + + Char_Ptr := Ch_Array(0)'Access; + TC_Char_Ptr := TC_Ch_Array(0)'Access; + Short_Ptr := Short_Array(0)'Access; + TC_Short_Ptr := TC_Short_Array(0)'Access; + + TC_ptrdiff_t := 4; + + Char_Pointers.Copy_Array(Source => Char_Ptr, + Target => TC_Char_Ptr, + Length => TC_ptrdiff_t); + + if TC_Ch_Array(0) /= Ch_Array(0) or + TC_Ch_Array(1) /= Ch_Array(1) or + TC_Ch_Array(2) /= Ch_Array(2) or + TC_Ch_Array(3) /= Ch_Array(3) or + TC_Ch_Array(4) = Ch_Array(4) + then + Report.Failed("Incorrect result from Copy_Array when using " & + "char pointer arguments, partial array copied"); + end if; + + + TC_ptrdiff_t := Interfaces.C.ptrdiff_t(Max_Array_Size) + 1; + + Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t); + + if TC_Short_Array /= Short_Array then + Report.Failed("Incorrect result from Copy_Array when using Short " & + "pointer arguments, entire array copied"); + end if; + + + + -- Check that procedure Copy_Array will propagate Dereference_Error + -- if either the Source or Target parameter is null. + + Char_Ptr := null; + begin + Char_Pointers.Copy_Array(Char_Ptr, TC_Char_Ptr, TC_ptrdiff_t); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Array with null Source parameter"); + if TC_Char_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Array with null Source parameter"); + end; + + TC_Short_Ptr := null; + begin + Short_Pointers.Copy_Array(Short_Ptr, TC_Short_Ptr, TC_ptrdiff_t); + Report.Failed("Dereference_Error not raised by call to " & + "Copy_Array with null Target parameter"); + if Short_Ptr = null then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Copy_Array with null Target parameter"); + end; + + + -- Check that function Virtual_Length will propagate Dereference_Error + -- if the Source parameter is null. + + Char_Ptr := null; + begin + TC_ptrdiff_t := Char_Pointers.Virtual_Length(Char_Ptr, + Terminator => TC_char); + Report.Failed("Dereference_Error not raised by call to " & + "Virtual_Length with null Source parameter"); + if TC_ptrdiff_t = 100 then -- To avoid optimization. + Report.Comment("This should never be printed"); + end if; + exception + when Dereference_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by call to " & + "Virtual_Length with null Source parameter"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB3016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,230 ---- + -- CXB4001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specifications of the package Interfaces.COBOL + -- are available for use + -- + -- TEST DESCRIPTION: + -- This test verifies that the type and the subprograms specified for + -- the interface are present. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Corrected visibility errors for ACVC 2.0.1. + -- 28 Feb 96 SAIC Added applicability criteria. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- 01 DEC 97 EDS Change "To_Comp" to "To_Binary". + --! + + with Report; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4001 is + + package COBOL renames Interfaces.COBOL; + use type COBOL.Byte; + use type COBOL.Decimal_Element; + + begin + + Report.Test ("CXB4001", "Check the specification of Interfaces.COBOL"); + + + declare -- encapsulate the test + + -- Types and operations for internal data representations + + TST_Floating : COBOL.Floating; + TST_Long_Floating : COBOL.Long_Floating; + + TST_Binary : COBOL.Binary; + TST_Long_Binary : COBOL.Long_Binary; + + TST_Max_Digits_Binary : constant := COBOL.Max_Digits_Binary; + TST_Max_Digits_Long_Binary : constant := COBOL.Max_Digits_Long_Binary; + + TST_Decimal_Element : COBOL.Decimal_Element; + + TST_Packed_Decimal : COBOL.Packed_Decimal (1..5) := + (others => COBOL.Decimal_Element'First); + + -- initialize it so it can reasonably be used later + TST_COBOL_Character : COBOL.COBOL_Character := + COBOL.COBOL_Character'First; + + TST_Ada_To_COBOL : COBOL.COBOL_Character := + COBOL.Ada_To_COBOL (Character'First); + + TST_COBOL_To_Ada : Character := + COBOL.COBOL_To_Ada (COBOL.COBOL_Character'First); + + -- assignment to make sure it is an array of COBOL_Character + TST_Alphanumeric : COBOL.Alphanumeric (1..5) := + (others => TST_COBOL_Character); + + + -- assignment to make sure it is an array of COBOL_Character + TST_Numeric : COBOL.Numeric (1..5) := (others => TST_COBOL_Character); + + + procedure Collect_All_Calls is + + CAC_Alphanumeric : COBOL.Alphanumeric(1..5) := + COBOL.To_COBOL("abcde"); + CAC_String : String (1..5) := "vwxyz"; + CAC_Natural : natural := 0; + + begin + + CAC_Alphanumeric := COBOL.To_COBOL (CAC_String); + CAC_String := COBOL.To_Ada (CAC_Alphanumeric); + + COBOL.To_COBOL (CAC_String, CAC_Alphanumeric, CAC_Natural); + COBOL.To_Ada (CAC_Alphanumeric, CAC_String, CAC_Natural); + + raise COBOL.Conversion_Error; + + end Collect_All_Calls; + + + + -- Formats for COBOL data representations + + TST_Unsigned : COBOL.Display_Format := COBOL.Unsigned; + TST_Leading_Separate : COBOL.Display_Format := COBOL.Leading_Separate; + TST_Trailing_Separate : COBOL.Display_Format := COBOL.Trailing_Separate; + TST_Leading_Nonseparate : COBOL.Display_Format := + COBOL.Leading_Nonseparate; + TST_Trailing_Nonseparate : COBOL.Display_Format := + COBOL.Trailing_Nonseparate; + + + TST_High_Order_First : COBOL.Binary_Format := COBOL.High_Order_First; + TST_Low_Order_First : COBOL.Binary_Format := COBOL.Low_Order_First; + TST_Native_Binary : COBOL.Binary_Format := COBOL.Native_Binary; + + + TST_Packed_Unsigned : COBOL.Packed_Format := COBOL.Packed_Unsigned; + TST_Packed_Signed : COBOL.Packed_Format := COBOL.Packed_Signed; + + + -- Types for external representation of COBOL binary data + + TST_Byte_Array : COBOL.Byte_Array(1..5) := (others => COBOL.Byte'First); + + -- Now instantiate one version of the generic + -- + type bx4001_Decimal is delta 0.1 digits 5; + package bx4001_conv is new COBOL.Decimal_Conversions (bx4001_Decimal); + + procedure Collect_All_Generic_Calls is + CAGC_natural : natural; + CAGC_Display_Format : COBOL.Display_Format; + CAGC_Boolean : Boolean; + CAGC_Numeric : COBOL.Numeric(1..5); + CAGC_Num : bx4001_Decimal; + CAGC_Packed_Decimal : COBOL.Packed_Decimal (1..5); + CAGC_Packed_Format : COBOL.Packed_Format; + CAGC_Byte_Array : COBOL.Byte_Array (1..5); + CAGC_Binary_Format : COBOL.Binary_Format; + CAGC_Binary : COBOL.Binary; + CAGC_Long_Binary : COBOL.Long_Binary; + begin + + -- Display Formats: data values are represented as Numeric + + CAGC_Boolean := bx4001_conv.Valid (CAGC_Numeric, CAGC_Display_Format); + CAGC_Natural := bx4001_conv.Length (CAGC_Display_Format); + + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Numeric, CAGC_Display_Format); + CAGC_Numeric := bx4001_conv.To_Display + (CAGC_Num, CAGC_Display_Format); + + + -- Packed Formats: data values are represented as Packed_Decimal + + CAGC_Boolean := bx4001_conv.Valid + (CAGC_Packed_Decimal, CAGC_Packed_Format); + + CAGC_Natural := bx4001_conv.Length (CAGC_Packed_Format); + + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Packed_Decimal, CAGC_Packed_Format); + + CAGC_Packed_Decimal := bx4001_conv.To_Packed + (CAGC_Num, CAGC_Packed_Format); + + + -- Binary Formats: external data values are represented as + -- Byte_Array + + CAGC_Boolean := bx4001_conv.Valid + (CAGC_Byte_Array, CAGC_Binary_Format); + + CAGC_Natural := bx4001_conv.Length (CAGC_Binary_Format); + CAGC_Num := bx4001_conv.To_Decimal + (CAGC_Byte_Array, CAGC_Binary_Format); + + CAGC_Byte_Array := bx4001_conv.To_Binary (CAGC_Num, CAGC_Binary_Format); + + + -- Internal Binary formats: data values are of type + -- Binary/Long_Binary + + CAGC_Num := bx4001_conv.To_Decimal (CAGC_Binary); + CAGC_Num := bx4001_conv.To_Decimal (CAGC_Long_Binary); + + CAGC_Binary := bx4001_conv.To_Binary (CAGC_Num); + CAGC_Long_Binary := bx4001_conv.To_Long_Binary (CAGC_Num); + + + end Collect_All_Generic_Calls; + + + begin -- encapsulation + + if COBOL.Byte'First /= 0 or + COBOL.Byte'Last /= (2 ** COBOL.COBOL_Character'Size) - 1 then + Report.Failed ("Byte is incorrectly defined"); + end if; + + if COBOL.Decimal_Element'First /= 0 then + Report.Failed ("Decimal_Element is incorrectly defined"); + end if; + + end; -- encapsulation + + Report.Result; + + end CXB4001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,308 ---- + -- CXB4002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedure To_COBOL converts the character elements + -- of the String parameter Item into COBOL_Character elements of the + -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_COBOL. + -- + -- Check that Constraint_Error is propagated by procedure To_COBOL + -- when the length of String parameter Item exceeds the length of + -- Alphanumeric parameter Target. + -- + -- Check that the procedure To_Ada converts the COBOL_Character + -- elements of the Alphanumeric parameter Item into Character elements + -- of the String parameter Target, using the COBOL_to_Ada mapping array + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_Ada. + -- + -- Check that Constraint_Error is propagated by procedure To_Ada when + -- the length of Alphanumeric parameter Item exceeds the length of + -- String parameter Target. + -- + -- TEST DESCRIPTION: + -- This test checks that the procedures To_COBOL and To_Ada produce + -- the correct results, based on a variety of parameter input values. + -- + -- In the first series of subtests, the Out parameter results of + -- procedure To_COBOL are compared against expected results, + -- which includes (in the parameter Last) the index in Target of the + -- last element assigned. The situation where procedure To_COBOL raises + -- Constraint_Error (when Item'Length exceeds Target'Length) is also + -- verified. + -- + -- In the second series of subtests, the Out parameter results of + -- procedure To_Ada are verified, in a similar manner as is done for + -- procedure To_COBOL. The case of procedure To_Ada raising + -- Constraint_Error is also verified. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.COBOL.COBOL_Character: + -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', '$', '-', '_', and '#'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 12 Jan 96 SAIC Initial prerelease version. + -- 30 May 96 SAIC Added applicability criteria for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Strings.Bounded; + with Ada.Strings.Unbounded; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4002 is + begin + + Report.Test ("CXB4002", "Check that the procedures To_COBOL and " & + "To_Ada produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Interfaces; + use Bnd, Unb; + use type Interfaces.COBOL.Alphanumeric; + + + Alphanumeric_1 : COBOL.Alphanumeric(1..1) := " "; + Alphanumeric_5 : COBOL.Alphanumeric(1..5) := " "; + Alphanumeric_10 : COBOL.Alphanumeric(1..10) := " "; + Alphanumeric_20 : COBOL.Alphanumeric(1..20) := " "; + TC_Alphanumeric_1 : COBOL.Alphanumeric(1..1) := "A"; + TC_Alphanumeric_5 : COBOL.Alphanumeric(1..5) := "ab*de"; + TC_Alphanumeric_10 : COBOL.Alphanumeric(1..10) := "$1a2b3C4D5"; + TC_Alphanumeric_20 : COBOL.Alphanumeric(1..20) := "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + + TC_Alphanumeric : constant COBOL.Alphanumeric := ""; -- null array. + TC_String : constant String := ""; -- null string. + TC_Natural : Natural := 0; + + + begin + + -- Check that the procedure To_COBOL converts the character elements + -- of the String parameter Item into COBOL_Character elements of the + -- Alphanumeric type parameter Target, using the Ada_to_COBOL mapping + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_COBOL. + + COBOL.To_COBOL(Item => TC_String_1, + Target => Alphanumeric_1, + Last => TC_Natural); + + if Alphanumeric_1 /= TC_Alphanumeric_1 or + TC_Natural /= TC_Alphanumeric_1'Length or + TC_Natural /= 1 + then + Report.Failed("Incorrect result from procedure To_COBOL - 1"); + end if; + + COBOL.To_COBOL(To_String(TC_Unb_String), + Target => Alphanumeric_5, + Last => TC_Natural); + + if Alphanumeric_5 /= TC_Alphanumeric_5 or + TC_Natural /= TC_Alphanumeric_5'Length or + TC_Natural /= 5 + then + Report.Failed("Incorrect result from procedure To_COBOL - 2"); + end if; + + COBOL.To_COBOL(To_String(TC_Bnd_String), + Alphanumeric_10, + Last => TC_Natural); + + if Alphanumeric_10 /= TC_Alphanumeric_10 or + TC_Natural /= TC_Alphanumeric_10'Length or + TC_Natural /= 10 + then + Report.Failed("Incorrect result from procedure To_COBOL - 3"); + end if; + + COBOL.To_COBOL(TC_String_20, + Alphanumeric_20, + TC_Natural); + + if Alphanumeric_20 /= TC_Alphanumeric_20 or + TC_Natural /= TC_Alphanumeric_20'Length or + TC_Natural /= 20 + then + Report.Failed("Incorrect result from procedure To_COBOL - 4"); + end if; + + COBOL.To_COBOL(Item => TC_String, -- null string + Target => Alphanumeric_1, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_COBOL, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + + -- Check that Constraint_Error is propagated by procedure To_COBOL + -- when the length of String parameter Item exceeds the length of + -- Alphanumeric parameter Target. + + begin + + COBOL.To_COBOL(Item => TC_String_20, + Target => Alphanumeric_10, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_COBOL " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by procedure To_COBOL " & + "when Item'Length exceeds Target'Length"); + end; + + + -- Check that the procedure To_Ada converts the COBOL_Character + -- elements of the Alphanumeric parameter Item into Character elements + -- of the String parameter Target, using the COBOL_to_Ada mapping array + -- as the basis of conversion. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_Ada. + + COBOL.To_Ada(Item => TC_Alphanumeric_1, + Target => String_1, + Last => TC_Natural); + + if String_1 /= TC_String_1 or + TC_Natural /= TC_String_1'Length or + TC_Natural /= 1 + then + Report.Failed("Incorrect result from procedure To_Ada - 1"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_5, + Target => String_5, + Last => TC_Natural); + + if String_5 /= To_String(TC_Unb_String) or + TC_Natural /= Length(TC_Unb_String) or + TC_Natural /= 5 + then + Report.Failed("Incorrect result from procedure To_Ada - 2"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_10, + String_10, + Last => TC_Natural); + + if String_10 /= To_String(TC_Bnd_String) or + TC_Natural /= Length(TC_Bnd_String) or + TC_Natural /= 10 + then + Report.Failed("Incorrect result from procedure To_Ada - 3"); + end if; + + COBOL.To_Ada(TC_Alphanumeric_20, + String_20, + TC_Natural); + + if String_20 /= TC_String_20 or + TC_Natural /= TC_String_20'Length or + TC_Natural /= 20 + then + Report.Failed("Incorrect result from procedure To_Ada - 4"); + end if; + + COBOL.To_Ada(Item => TC_Alphanumeric, -- null array. + Target => String_20, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Ada, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + + -- Check that Constraint_Error is propagated by procedure To_Ada when + -- the length of Alphanumeric parameter Item exceeds the length of + -- String parameter Target. + + begin + + COBOL.To_Ada(Item => TC_Alphanumeric_10, + Target => String_5, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXB4002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,310 ---- + -- CXB4003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that function Valid, with the Display_Format parameter + -- set to Unsigned, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters; check that it + -- returns False if the parameter Item is otherwise comprised. + -- + -- Check that function Valid, with Display_Format parameter set to + -- Leading_Separate, will return True if Numeric parameter Item + -- comprises a single occurrence of a Plus_Sign or Minus_Sign + -- character, and then by one or more decimal digit characters; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + -- + -- Check that function Valid, with Display_Format parameter set to + -- Trailing_Separate, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters, and then by a + -- single occurrence of the Plus_Sign or Minus_Sign character; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + -- + -- TEST DESCRIPTION: + -- This test checks that a version of function Valid, from an instance + -- of the generic package Decimal_Conversions, will produce correct + -- results based on the particular Numeric and Display_Format + -- parameters provided. Arrays of both valid and invalid Numeric + -- data items have been created to correspond to a particular + -- value of Display_Format. The result of the function is compared + -- against the expected result for each appropriate combination of + -- Numeric and Display_Format parameter. + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.COBOL.COBOL_Character: + -- ' ', 'A'..'Z', '+', '-', '.', '$'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- + -- CHANGE HISTORY: + -- 18 Jan 96 SAIC Initial version for 2.1. + -- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Exceptions; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4003 is + begin + + Report.Test ("CXB4003", "Check that function Valid, with various " & + "Display_Format parameters, produces correct " & + "results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + + type A_Numeric_Type is delta 0.01 digits 16; + type Numeric_Access is access COBOL.Numeric; + type Numeric_Items_Type is array(Integer range <>) of Numeric_Access; + + package Display_Format is + new COBOL.Decimal_Conversions(Num => A_Numeric_Type); + + + Number_Of_Valid_Unsigned_Items : constant := 5; + Number_Of_Invalid_Unsigned_Items : constant := 21; + Number_Of_Valid_Leading_Separate_Items : constant := 5; + Number_Of_Invalid_Leading_Separate_Items : constant := 23; + Number_Of_Valid_Trailing_Separate_Items : constant := 5; + Number_Of_Invalid_Trailing_Separate_Items : constant := 22; + + Valid_Unsigned_Items : + Numeric_Items_Type(1..Number_Of_Valid_Unsigned_Items) := + (new COBOL.Numeric'("0"), + new COBOL.Numeric'("1"), + new COBOL.Numeric'("0000000001"), + new COBOL.Numeric'("1234567890123456"), + new COBOL.Numeric'("0000")); + + Invalid_Unsigned_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Unsigned_Items) := + (new COBOL.Numeric'(" 12345"), + new COBOL.Numeric'(" 12345"), + new COBOL.Numeric'("1234567890 "), + new COBOL.Numeric'("1234567890 "), + new COBOL.Numeric'("1.01"), + new COBOL.Numeric'(".0000000001"), + new COBOL.Numeric'("12345 6"), + new COBOL.Numeric'("MCXVIII"), + new COBOL.Numeric'("15F"), + new COBOL.Numeric'("+12345"), + new COBOL.Numeric'("$12.30"), + new COBOL.Numeric'("1234-"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("++99--"), + new COBOL.Numeric'("-1.01"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("123,456"), + new COBOL.Numeric'("101."), + new COBOL.Numeric'(""), + new COBOL.Numeric'("1.0000")); + + Valid_Leading_Separate_Items : + Numeric_Items_Type(1..Number_Of_Valid_Leading_Separate_Items) := + (new COBOL.Numeric'("+1000"), + new COBOL.Numeric'("-1"), + new COBOL.Numeric'("-0000000001"), + new COBOL.Numeric'("+1234567890123456"), + new COBOL.Numeric'("-0000")); + + Invalid_Leading_Separate_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Leading_Separate_Items) := + (new COBOL.Numeric'("123456"), + new COBOL.Numeric'(" +12345"), + new COBOL.Numeric'(" +12345"), + new COBOL.Numeric'("- 0000000001"), + new COBOL.Numeric'("1234567890- "), + new COBOL.Numeric'("1234567890+ "), + new COBOL.Numeric'("123-456"), + new COBOL.Numeric'("+15F"), + new COBOL.Numeric'("++123"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("+/-12"), + new COBOL.Numeric'("++99--"), + new COBOL.Numeric'("1.01"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("+123,456"), + new COBOL.Numeric'("+15FF"), + new COBOL.Numeric'("- 123"), + new COBOL.Numeric'("+$123"), + new COBOL.Numeric'(""), + new COBOL.Numeric'("-"), + new COBOL.Numeric'("-1.01"), + new COBOL.Numeric'("1.0000+")); + + Valid_Trailing_Separate_Items : + Numeric_Items_Type(1..Number_Of_Valid_Trailing_Separate_Items) := + (new COBOL.Numeric'("1001-"), + new COBOL.Numeric'("1+"), + new COBOL.Numeric'("0000000001+"), + new COBOL.Numeric'("1234567890123456-"), + new COBOL.Numeric'("0000-")); + + Invalid_Trailing_Separate_Items : + Numeric_Items_Type(1..Number_Of_Invalid_Trailing_Separate_Items) := + (new COBOL.Numeric'("123456"), + new COBOL.Numeric'("+12345"), + new COBOL.Numeric'("12345 "), + new COBOL.Numeric'("123- "), + new COBOL.Numeric'("123- "), + new COBOL.Numeric'("12345 +"), + new COBOL.Numeric'("12345+ "), + new COBOL.Numeric'("-0000000001"), + new COBOL.Numeric'("123-456"), + new COBOL.Numeric'("12--"), + new COBOL.Numeric'("+12-"), + new COBOL.Numeric'("99+-"), + new COBOL.Numeric'("12+/-"), + new COBOL.Numeric'("12.01-"), + new COBOL.Numeric'("$12.01+"), + new COBOL.Numeric'("(1.01)"), + new COBOL.Numeric'("DM12-"), + new COBOL.Numeric'("123,456+"), + new COBOL.Numeric'(""), + new COBOL.Numeric'("-"), + new COBOL.Numeric'("1.01-"), + new COBOL.Numeric'("+1.0000")); + + begin + + -- Check that function Valid, with the Display_Format parameter + -- set to Unsigned, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters; check that it + -- returns False if the parameter Item is otherwise comprised. + + for i in 1..Number_of_Valid_Unsigned_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Item => Valid_Unsigned_Items(i).all, + Format => COBOL.Unsigned) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Unsigned, for valid " & + "format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Unsigned_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Item => Invalid_Unsigned_Items(i).all, + Format => COBOL.Unsigned) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Unsigned, for invalid " & + "format item number " & Integer'Image(i)); + end if; + end loop; + + + + -- Check that function Valid, with Display_Format parameter set to + -- Leading_Separate, will return True if Numeric parameter Item + -- comprises a single occurrence of a Plus_Sign or Minus_Sign + -- character, and then by one or more decimal digit characters; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + + for i in 1..Number_of_Valid_Leading_Separate_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Valid_Leading_Separate_Items(i).all, + Format => COBOL.Leading_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Leading_Separate, " & + "for valid format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Leading_Separate_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Invalid_Leading_Separate_Items(i).all, + Format => COBOL.Leading_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Leading_Separate, " & + "for invalid format item number " & + Integer'Image(i)); + end if; + end loop; + + + + -- Check that function Valid, with Display_Format parameter set to + -- Trailing_Separate, will return True if Numeric parameter Item + -- comprises one or more decimal digit characters, and then by a + -- single occurrence of the Plus_Sign or Minus_Sign character; + -- check that it returns False if the parameter Item is otherwise + -- comprised. + + for i in 1..Number_of_Valid_Trailing_Separate_Items loop + -- Fail if the Item parameter is _NOT_ considered Valid. + if not Display_Format.Valid(Valid_Trailing_Separate_Items(i).all, + COBOL.Trailing_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Trailing_Separate, " & + "for valid format item number " & Integer'Image(i)); + end if; + end loop; + + + for i in 1..Number_of_Invalid_Trailing_Separate_Items loop + -- Fail if the Item parameter _IS_ considered Valid. + if Display_Format.Valid(Invalid_Trailing_Separate_Items(i).all, + COBOL.Trailing_Separate) + then + Report.Failed("Incorrect result from function Valid, with " & + "Format parameter set to Trailing_Separate, " & + "for invalid format item number " & + Integer'Image(i)); + end if; + end loop; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4004.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,443 ---- + -- CXB4004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that function Length, with Display_Format parameter, will + -- return the minimal length of a Numeric value that will be required + -- to hold the largest value of type Num represented as Format. + -- + -- Check that function To_Decimal will produce a decimal type Num + -- result that corresponds to parameter Item as represented by + -- parameter Format. + -- + -- Check that function To_Decimal propagates Conversion_Error when + -- the value represented by parameter Item is outside the range of + -- the Decimal_Type Num used to instantiate the package + -- Decimal_Conversions + -- + -- Check that function To_Display returns a Numeric type result that + -- represents Item under the specific Display_Format. + -- + -- Check that function To_Display propagates Conversion_Error when + -- parameter Item is negative and the specified Display_Format + -- parameter is Unsigned. + -- + -- TEST DESCRIPTION: + -- This test checks the results from instantiated versions of three + -- functions within generic package Interfaces.COBOL.Decimal_Conversions. + -- This generic package is instantiated twice, with decimal types having + -- four and ten digits representation. + -- The function Length is validated with the Unsigned, Leading_Separate, + -- and Trailing_Separate Display_Format specifiers. + -- The results of function To_Decimal are verified in cases where it + -- is given a variety of Numeric and Display_Format type parameters. + -- Function To_Decimal is also checked to propagate Conversion_Error + -- when the value represented by parameter Item is outside the range + -- of the type used to instantiate the package. + -- The results of function To_Display are verified in cases where it + -- is given a variety of Num and Display_Format parameters. It is also + -- checked to ensure that it propagates Conversion_Error if parameter + -- Num is negative and the Format parameter is Unsigned. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.COBOL.COBOL_Character: + -- ' ', '0'..'9', '+', '-', and '.'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Feb 96 SAIC Initial release for 2.1. + -- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Interfaces.COBOL; -- N/A => ERROR + with Ada.Exceptions; + + procedure CXB4004 is + begin + + Report.Test ("CXB4004", "Check that the functions Length, To_Decimal, " & + "and To_Display produce correct results"); + + Test_Block: + declare + + use Interfaces; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + Number_Of_Unsigned_Items : constant := 6; + Number_Of_Leading_Separate_Items : constant := 6; + Number_Of_Trailing_Separate_Items : constant := 6; + Number_Of_Decimal_Items : constant := 9; + + type Decimal_Type_1 is delta 0.01 digits 4; + type Decimal_Type_2 is delta 1.0 digits 10; + type Numeric_Access is access COBOL.Numeric; + type Numeric_Items_Type is array(Integer range <>) of Numeric_Access; + + Correct_Result : Boolean := False; + TC_Num_1 : Decimal_Type_1 := 0.0; + TC_Num_2 : Decimal_Type_2 := 0.0; + + package Package_1 is new COBOL.Decimal_Conversions(Decimal_Type_1); + package Package_2 is new COBOL.Decimal_Conversions(Decimal_Type_2); + + + Package_1_Numeric_Items : + Numeric_Items_Type(1..Number_Of_Decimal_Items) := + (new COBOL.Numeric'("0"), + new COBOL.Numeric'("591"), + new COBOL.Numeric'("6342"), + new COBOL.Numeric'("+0"), + new COBOL.Numeric'("-1539"), + new COBOL.Numeric'("+9199"), + new COBOL.Numeric'("0-"), + new COBOL.Numeric'("8934+"), + new COBOL.Numeric'("9949-")); + + Package_2_Numeric_Items : + Numeric_Items_Type(1..Number_Of_Decimal_Items) := + (new COBOL.Numeric'("3"), + new COBOL.Numeric'("105"), + new COBOL.Numeric'("1234567899"), + new COBOL.Numeric'("+8"), + new COBOL.Numeric'("-12345601"), + new COBOL.Numeric'("+9123459999"), + new COBOL.Numeric'("1-"), + new COBOL.Numeric'("123456781+"), + new COBOL.Numeric'("9499999999-")); + + + Decimal_Type_1_Items : array (1..Number_Of_Decimal_Items) + of Decimal_Type_1 := + (0.0, 5.91, 63.42, 0.0, -15.39, 91.99, 0.0, 89.34, -99.49); + + Decimal_Type_2_Items : array (1..Number_Of_Decimal_Items) + of Decimal_Type_2 := + ( 3.0, 105.0, 1234567899.0, + 8.0, -12345601.0, 9123459999.0, + -1.0, 123456781.0, -9499999999.0); + + begin + + -- Check that function Length with Display_Format parameter will + -- return the minimal length of a Numeric value (number of + -- COBOL_Characters) that will be required to hold the largest + -- value of type Num. + + if Package_1.Length(COBOL.Unsigned) /= 4 or + Package_2.Length(COBOL.Unsigned) /= 10 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter Unsigned"); + end if; + + if Package_1.Length(Format => COBOL.Leading_Separate) /= 5 or + Package_2.Length(Format => COBOL.Leading_Separate) /= 11 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter " & + "Leading_Separate"); + end if; + + if Package_1.Length(COBOL.Trailing_Separate) /= 5 or + Package_2.Length(COBOL.Trailing_Separate) /= 11 + then + Report.Failed("Incorrect results from function Length when " & + "used with Display_Format parameter " & + "Trailing_Separate"); + end if; + + + -- Check that function To_Decimal with Numeric and Display_Format + -- parameters will produce a decimal type Num result that corresponds + -- to parameter Item as represented by parameter Format. + + for i in 1..Number_Of_Decimal_Items loop + case i is + when 1..3 => -- Unsigned Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + Format => COBOL.Unsigned) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Unsigned, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + Format => COBOL.Unsigned) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Unsigned, subtest index: " & + Integer'Image(i)); + end if; + + when 4..6 => -- Leading_Separate Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + Format => COBOL.Leading_Separate) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Leading_Separate, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + Format => COBOL.Leading_Separate) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Leading_Separate, subtest index: " & + Integer'Image(i)); + end if; + + when 7..9 => -- Trailing_Separate Display_Format parameter. + + if Package_1.To_Decimal(Package_1_Numeric_Items(i).all, + COBOL.Trailing_Separate) /= + Decimal_Type_1_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a four-digit Decimal type, with Format " & + "parameter Trailing_Separate, subtest index: " & + Integer'Image(i)); + end if; + + if Package_2.To_Decimal(Package_2_Numeric_Items(i).all, + COBOL.Trailing_Separate) /= + Decimal_Type_2_Items(i) + then + Report.Failed + ("Incorrect result from function To_Decimal " & + "from an instantiation of Decimal_Conversions " & + "using a ten-digit Decimal type, with Format " & + "parameter Trailing_Separate, subtest index: " & + Integer'Image(i)); + end if; + + end case; + end loop; + + + -- Check that function To_Decimal propagates Conversion_Error when + -- the value represented by Numeric type parameter Item is outside + -- the range of the Decimal_Type Num used to instantiate the package + -- Decimal_Conversions. + + declare + TC_Numeric_1 : Decimal_Type_1 := Decimal_Type_1_Items(1); + begin + -- The COBOL.Numeric type used as parameter Item represents a + -- Decimal value that is outside the range of the Decimal type + -- used to instantiate Package_1. + TC_Numeric_1 := + Package_1.To_Decimal(Item => Package_2_Numeric_Items(8).all, + Format => COBOL.Trailing_Separate); + Report.Failed("Conversion_Error not raised by To_Decimal " & + "when the value represented by parameter " & + "Item is outside the range of the Decimal_Type " & + "used to instantiate the package " & + "Decimal_Conversions"); + if TC_Numeric_1 = Decimal_Type_1_Items(1) then + Report.Comment("To Guard Against Dead Assignment Elimination " & + "-- Should never be printed"); + end if; + exception + when COBOL.Conversion_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by To_Decimal " & + "when the value represented by parameter " & + "Item is outside the range of the Decimal_Type " & + "used to instantiate the package " & + "Decimal_Conversions"); + end; + + + -- Check that function To_Display with decimal type Num and + -- Display_Format parameters returns a Numeric type result that + -- represents Item under the specific Display_Format. + + -- Unsigned Display_Format parameter. + TC_Num_1 := 13.04; + Correct_Result := (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) = + "1304") AND + (Package_1.To_Display(TC_Num_1, COBOL.Unsigned) /= + "13.04"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Unsigned Display_Format parameter - 1"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Unsigned) = "1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Unsigned Display_Format parameter - 2"); + end if; + + -- Leading_Separate Display_Format parameter. + TC_Num_1 := -34.29; + Correct_Result := (Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) = + "-3429") AND + (Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) /= + "-34.29"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 1"); + end if; + + TC_Num_1 := 19.01; + Correct_Result := Package_1.To_Display(TC_Num_1, + COBOL.Leading_Separate) = + "+1901"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 2"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Leading_Separate) = + "+1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 3"); + end if; + + TC_Num_2 := -1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Leading_Separate) = + "-1234567890"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Leading_Separate Display_Format parameter - 4"); + end if; + + -- Trailing_Separate Display_Format parameter. + TC_Num_1 := -99.91; + Correct_Result := (Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) = + "9991-") AND + (Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) /= + "99.91-"); + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 1"); + end if; + + TC_Num_1 := 51.99; + Correct_Result := Package_1.To_Display(TC_Num_1, + COBOL.Trailing_Separate) = + "5199+"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 2"); + end if; + + TC_Num_2 := 1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Trailing_Separate) = + "1234567890+"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 3"); + end if; + + TC_Num_2 := -1234567890.0; + Correct_Result := Package_2.To_Display(TC_Num_2, + COBOL.Trailing_Separate) = + "1234567890-"; + if not Correct_Result then + Report.Failed("Incorrect result from function To_Display with " & + "Trailing_Separate Display_Format parameter - 4"); + end if; + + + -- Check that function To_Display propagates Conversion_Error when + -- parameter Item is negative and the specified Display_Format + -- parameter is Unsigned. + + begin + if Package_2.To_Display(Item => Decimal_Type_2_Items(9), + Format => COBOL.Unsigned) = + Package_2_Numeric_Items(2).all + then + Report.Comment("To Guard Against Dead Assignment Elimination " & + "-- Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised by To_Display " & + "when the value represented by parameter " & + "Item is negative and the Display_Format " & + "parameter is Unsigned"); + exception + when COBOL.Conversion_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by To_Display " & + "when the value represented by parameter " & + "Item is negative and the Display_Format " & + "parameter is Unsigned"); + end; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4005.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,332 ---- + -- CXB4005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function To_COBOL will convert a String + -- parameter value into a type Alphanumeric array of + -- COBOL_Characters, with lower bound of one, and length + -- equal to length of the String parameter, based on the + -- mapping Ada_to_COBOL. + -- + -- Check that the function To_Ada will convert a type + -- Alphanumeric parameter value into a String type result, + -- with lower bound of one, and length equal to the length + -- of the Alphanumeric parameter, based on the mapping + -- COBOL_to_Ada. + -- + -- Check that the Ada_to_COBOL and COBOL_to_Ada mapping + -- arrays provide a mapping capability between Ada's type + -- Character and COBOL run-time character sets. + -- + -- TEST DESCRIPTION: + -- This test checks that the functions To_COBOL and To_Ada produce + -- the correct results, based on a variety of parameter input values. + -- + -- In the first series of subtests, the results of the function + -- To_COBOL are compared against expected Alphanumeric type results, + -- and the length and lower bound of the alphanumeric result are + -- also verified. In the second series of subtests, the results of + -- the function To_Ada are compared against expected String type + -- results, and the length of the String result is also verified + -- against the Alphanumeric type parameter. + -- + -- This test also verifies that two mapping array variables defined + -- in package Interfaces.COBOL, Ada_To_COBOL and COBOL_To_Ada, are + -- available, and that they can be modified by a user at runtime. + -- Finally, the effects of user modifications on these mapping + -- variables is checked in the test. + -- + -- This test uses Fixed, Bounded, and Unbounded_Strings in combination + -- with the functions under validation. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.COBOL.COBOL_Character: + -- ' ', 'a'..'z', 'A'..'Z', '0'..'9', '*', ',', '.', and '$'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 11 Jan 96 SAIC Initial prerelease version for ACVC 2.1 + -- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Exceptions; + with Ada.Strings.Bounded; + with Ada.Strings.Unbounded; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4005 is + begin + + Report.Test ("CXB4005", "Check that the functions To_COBOL and " & + "To_Ada produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(5); + package Unb renames Ada.Strings.Unbounded; + + use Ada.Exceptions; + use Interfaces; + use Bnd; + use type Unb.Unbounded_String; + use type Interfaces.COBOL.Alphanumeric; + + TC_Alphanumeric_1 : Interfaces.COBOL.Alphanumeric(1..1); + TC_Alphanumeric_5 : Interfaces.COBOL.Alphanumeric(1..5); + TC_Alphanumeric_10 : Interfaces.COBOL.Alphanumeric(1..10); + TC_Alphanumeric_20 : Interfaces.COBOL.Alphanumeric(1..20); + + Bnd_String, + TC_Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + Unb_String, + TC_Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + + The_String, + TC_String : String(1..20) := (" "); + + begin + + -- Check that the function To_COBOL will convert a String + -- parameter value into a type Alphanumeric array of + -- COBOL_Characters, with lower bound of one, and length + -- equal to length of the String parameter, based on the + -- mapping Ada_to_COBOL. + + Unb_String := Unb.To_Unbounded_String("A"); + TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_1 /= "A" or + TC_Alphanumeric_1'Length /= Unb.Length(Unb_String) or + TC_Alphanumeric_1'Length /= 1 or + COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 1"); + end if; + + Bnd_String := Bnd.To_Bounded_String("abcde"); + TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String)); + + if TC_Alphanumeric_5 /= "abcde" or + TC_Alphanumeric_5'Length /= Bnd.Length(Bnd_String) or + TC_Alphanumeric_5'Length /= 5 or + COBOL.To_COBOL(Bnd.To_String(Bnd_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 2"); + end if; + + Unb_String := Unb.To_Unbounded_String("1A2B3c4d5F"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_10 /= "1A2B3c4d5F" or + TC_Alphanumeric_10'Length /= Unb.Length(Unb_String) or + TC_Alphanumeric_10'Length /= 10 or + COBOL.To_COBOL(Unb.To_String(Unb_String))'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 3"); + end if; + + The_String := "abcd ghij" & "1234 7890"; + TC_Alphanumeric_20 := COBOL.To_COBOL(The_String); + + if TC_Alphanumeric_20 /= "abcd ghij1234 7890" or + TC_Alphanumeric_20'Length /= The_String'Length or + TC_Alphanumeric_20'Length /= 20 or + COBOL.To_COBOL(The_String)'First /= 1 + then + Report.Failed("Incorrect result from function To_COBOL - 4"); + end if; + + + + -- Check that the function To_Ada will convert a type + -- Alphanumeric parameter value into a String type result, + -- with lower bound of one, and length equal to the length + -- of the Alphanumeric parameter, based on the mapping + -- COBOL_to_Ada. + + TC_Unb_String := Unb.To_Unbounded_String + (COBOL.To_Ada(TC_Alphanumeric_1)); + + if TC_Unb_String /= "A" or + TC_Alphanumeric_1'Length /= Unb.Length(TC_Unb_String) or + Unb.Length(TC_Unb_String) /= 1 or + COBOL.To_Ada(TC_Alphanumeric_1)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 1"); + end if; + + TC_Bnd_String := Bnd.To_Bounded_String + (COBOL.To_Ada(TC_Alphanumeric_5)); + + if TC_Bnd_String /= "abcde" or + TC_Alphanumeric_5'Length /= Bnd.Length(TC_Bnd_String) or + Bnd.Length(TC_Bnd_String) /= 5 or + COBOL.To_Ada(TC_Alphanumeric_5)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 2"); + end if; + + TC_Unb_String := Unb.To_Unbounded_String + (COBOL.To_Ada(TC_Alphanumeric_10)); + + if TC_Unb_String /= "1A2B3c4d5F" or + TC_Alphanumeric_10'Length /= Unb.Length(TC_Unb_String) or + Unb.Length(TC_Unb_String) /= 10 or + COBOL.To_Ada(TC_Alphanumeric_10)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 3"); + end if; + + TC_String := COBOL.To_Ada(TC_Alphanumeric_20); + + if TC_String /= "abcd ghij1234 7890" or + TC_Alphanumeric_20'Length /= TC_String'Length or + TC_String'Length /= 20 or + COBOL.To_Ada(TC_Alphanumeric_20)'First /= 1 + then + Report.Failed("Incorrect value returned from function To_Ada - 4"); + end if; + + + -- Check the two functions when used in combination. + + if COBOL.To_COBOL(Item => COBOL.To_Ada("This is a test")) /= + "This is a test" or + COBOL.To_COBOL(COBOL.To_Ada("1234567890abcdeFGHIJ")) /= + "1234567890abcdeFGHIJ" + then + Report.Failed("Incorrect result returned when using the " & + "functions To_Ada and To_COBOL in combination"); + end if; + + + + -- Check that the Ada_to_COBOL and COBOL_to_Ada mapping + -- arrays provide a mapping capability between Ada's type + -- Character and COBOL run-time character sets. + + Interfaces.COBOL.Ada_To_COBOL('a') := 'A'; + Interfaces.COBOL.Ada_To_COBOL('b') := 'B'; + Interfaces.COBOL.Ada_To_COBOL('c') := 'C'; + Interfaces.COBOL.Ada_To_COBOL('d') := '1'; + Interfaces.COBOL.Ada_To_COBOL('e') := '2'; + Interfaces.COBOL.Ada_To_COBOL('f') := '3'; + Interfaces.COBOL.Ada_To_COBOL(' ') := '*'; + + Unb_String := Unb.To_Unbounded_String("b"); + TC_Alphanumeric_1 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_1 /= "B" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 1"); + end if; + + Bnd_String := Bnd.To_Bounded_String("abcde"); + TC_Alphanumeric_5 := COBOL.To_COBOL(Bnd.To_String(Bnd_String)); + + if TC_Alphanumeric_5 /= "ABC12" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 2"); + end if; + + Unb_String := Unb.To_Unbounded_String("1a2B3c4d5e"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + + if TC_Alphanumeric_10 /= "1A2B3C4152" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 3"); + end if; + + The_String := "abcd ghij" & "1234 7890"; + TC_Alphanumeric_20 := COBOL.To_COBOL(The_String); + + if TC_Alphanumeric_20 /= "ABC1**ghij1234**7890" then + Report.Failed("Incorrect result from function To_COBOL after " & + "modification to Ada_To_COBOL mapping array - 4"); + end if; + + + -- Reset the Ada_To_COBOL mapping array to its original state. + + Interfaces.COBOL.Ada_To_COBOL('a') := 'a'; + Interfaces.COBOL.Ada_To_COBOL('b') := 'b'; + Interfaces.COBOL.Ada_To_COBOL('c') := 'c'; + Interfaces.COBOL.Ada_To_COBOL('d') := 'd'; + Interfaces.COBOL.Ada_To_COBOL('e') := 'e'; + Interfaces.COBOL.Ada_To_COBOL('f') := 'f'; + Interfaces.COBOL.Ada_To_COBOL(' ') := ' '; + + -- Modify the COBOL_To_Ada mapping array to check its effect on + -- the function To_Ada. + + Interfaces.COBOL.COBOL_To_Ada(' ') := '*'; + Interfaces.COBOL.COBOL_To_Ada('$') := 'F'; + Interfaces.COBOL.COBOL_To_Ada('1') := '7'; + Interfaces.COBOL.COBOL_To_Ada('.') := ','; + + Unb_String := Unb.To_Unbounded_String(" $$100.00"); + TC_Alphanumeric_10 := COBOL.To_COBOL(Unb.To_String(Unb_String)); + TC_Unb_String := Unb.To_Unbounded_String( + COBOL.To_Ada(TC_Alphanumeric_10)); + + if Unb.To_String(TC_Unb_String) /= "**FF700,00" then + Report.Failed("Incorrect result from function To_Ada after " & + "modification of COBOL_To_Ada mapping array - 1"); + end if; + + Interfaces.COBOL.COBOL_To_Ada('*') := ' '; + Interfaces.COBOL.COBOL_To_Ada('F') := '$'; + Interfaces.COBOL.COBOL_To_Ada('7') := '1'; + Interfaces.COBOL.COBOL_To_Ada(',') := '.'; + + if COBOL.To_Ada(COBOL.To_COBOL(Unb.To_String(TC_Unb_String))) /= + Unb_String + then + Report.Failed("Incorrect result from function To_Ada after " & + "modification of COBOL_To_Ada mapping array - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed ("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4006.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,322 ---- + -- CXB4006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Valid with Packed_Decimal and Packed_Format + -- parameters returns True if Item (the Packed_Decimal parameter) has + -- a value consistent with the Packed_Format parameter. + -- + -- Check that the function Length with Packed_Format parameter returns + -- the minimal length of a Packed_Decimal value sufficient to hold any + -- value of type Num when represented according to parameter Format. + -- + -- Check that the function To_Decimal with Packed_Decimal and + -- Packed_Format parameters produces a decimal type value corresponding + -- to the Packed_Decimal parameter value Item, under the conditions of + -- the Packed_Format parameter Format. + -- + -- Check that the function To_Packed with Decimal (Num) and + -- Packed_Format parameters produces a Packed_Decimal result that + -- corresponds to the decimal parameter under conditions of the + -- Packed_Format parameter. + -- + -- Check that Conversion_Error is propagated by function To_Packed if + -- the value of the decimal parameter Item is negative and the specified + -- Packed_Format parameter is Packed_Unsigned. + -- + -- + -- TEST DESCRIPTION: + -- This test checks the results from instantiated versions of + -- several functions that deal with parameters or results of type + -- Packed_Decimal. Since the rules for the formation of Packed_Decimal + -- values are implementation defined, several of the subtests cannot + -- directly check the accuracy of the results produced. Instead, they + -- verify that the result is within a range of possible values, or + -- that the result of one function can be converted back to the original + -- actual parameter using a "mirror image" conversion function. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 12 Feb 96 SAIC Initial release for 2.1. + -- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Exceptions; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4006 is + begin + + Report.Test ("CXB4006", "Check that the functions Valid, Length, " & + "To_Decimal, and To_Packed specific to " & + "Packed_Decimal parameters produce correct " & + "results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits 8; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits 12; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.6; + TC_Dec_2 : Decimal_Type_2 := 123456.78; + TC_Dec_3 : Decimal_Type_3 := 1234567.890; + TC_Dec_4 : Decimal_Type_4 := 12345678.9012; + TC_Min_Length : Natural := 1; + TC_Max_Length : Natural := 16; + + begin + + -- Check that the function Valid with Packed_Decimal and Packed_Format + -- parameters returns True if Item (the Packed_Decimal parameter) has + -- a value consistent with the Packed_Format parameter. + -- Note: Since the formation rules for Packed_Decimal values are + -- implementation defined, the parameter values here are + -- created by function To_Packed. + + TC_Dec_1 := 1434.3; + if not Pack_1.Valid(Item => Pack_1.To_Packed(TC_Dec_1, + Packed_Unsigned), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 1"); + end if; + + TC_Dec_2 := -4321.03; + if not Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Signed) or + Pack_2.Valid(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 2"); + end if; + + TC_Dec_3 := 1234567.890; + if not Pack_3.Valid(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned), + Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 3"); + end if; + + TC_Dec_4 := -234.6789; + if not Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, + Packed_Signed), + Format => Packed_Signed) or + Pack_4.Valid(Item => Pack_4.To_Packed(TC_Dec_4, Packed_Signed), + Format => Packed_Unsigned) + then + Report.Failed("Incorrect result from function Valid - 4"); + end if; + + + + -- Check that the function Length with Packed_Format parameter returns + -- the minimal length of a Packed_Decimal value sufficient to hold any + -- value of type Num when represented according to parameter Format. + + if NOT (Pack_1.Length(Packed_Signed) >= TC_Min_Length AND + Pack_1.Length(Packed_Signed) <= TC_Max_Length AND + Pack_1.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_1.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 1"); + end if; + + if NOT (Pack_2.Length(Packed_Signed) >= TC_Min_Length AND + Pack_2.Length(Packed_Signed) <= TC_Max_Length AND + Pack_2.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_2.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 2"); + end if; + + if NOT (Pack_3.Length(Packed_Signed) >= TC_Min_Length AND + Pack_3.Length(Packed_Signed) <= TC_Max_Length AND + Pack_3.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_3.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 3"); + end if; + + if NOT (Pack_4.Length(Packed_Signed) >= TC_Min_Length AND + Pack_4.Length(Packed_Signed) <= TC_Max_Length AND + Pack_4.Length(Packed_Unsigned) >= TC_Min_Length AND + Pack_4.Length(Packed_Unsigned) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length - 4"); + end if; + + + + -- Check that the function To_Decimal with Packed_Decimal and + -- Packed_Format parameters produces a decimal type value corresponding + -- to the Packed_Decimal parameter value Item, under the conditions of + -- the Packed_Format parameter Format. + + begin + TC_Dec_1 := 1234.5; + if Pack_1.To_Decimal(Item => Pack_1.To_Packed(TC_Dec_1, + Packed_Unsigned), + Format => Packed_Unsigned) /= TC_Dec_1 + then + Report.Failed("Incorrect result from function To_Decimal - 1"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 1 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_2 := -123456.50; + if Pack_2.To_Decimal(Pack_2.To_Packed(TC_Dec_2, Packed_Signed), + Format => Packed_Signed) /= TC_Dec_2 + then + Report.Failed("Incorrect result from function To_Decimal - 2"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 2 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_3 := 1234567.809; + if Pack_3.To_Decimal(Pack_3.To_Packed(TC_Dec_3, Packed_Unsigned), + Packed_Unsigned) /= TC_Dec_3 + then + Report.Failed("Incorrect result from function To_Decimal - 3"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 3 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + begin + TC_Dec_4 := -789.1234; + if Pack_4.To_Decimal(Item => Pack_4.To_Packed(TC_Dec_4, + Packed_Signed), + Format => Packed_Signed) /= TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal - 4"); + end if; + exception + when The_Error : others => + Report.Failed("The following exception was raised in " & + "subtest 4 of function To_Decimal: " & + Exception_Name(The_Error)); + end; + + + + -- Check that the function To_Packed with Decimal (Num) and + -- Packed_Format parameters produces a Packed_Decimal result that + -- corresponds to the decimal parameter under conditions of the + -- Packed_Format parameter. + + if Pack_1.To_Packed(Item => 123.4, Format => Packed_Unsigned) = + Pack_1.To_Packed(Item => -123.4, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 1"); + end if; + + if Pack_2.To_Packed( 123.45, Format => Packed_Unsigned) = + Pack_2.To_Packed(-123.45, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 2"); + end if; + + if Pack_3.To_Packed(Item => 123.456, Format => Packed_Unsigned) = + Pack_3.To_Packed(Item => -123.456, Format => Packed_Signed) + then + Report.Failed("Incorrect result from function To_Packed - 3"); + end if; + + if (Pack_4.To_Packed( 123.4567, Packed_Unsigned) = + Pack_4.To_Packed(-123.4567, Packed_Signed)) or + (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) = + Pack_4.To_Packed(12345678.9013, Packed_Unsigned)) or + (Pack_4.To_Packed(12345678.9012, Packed_Unsigned) = + Pack_4.To_Packed(22345678.9012, Packed_Unsigned)) + then + Report.Failed("Incorrect result from function To_Packed - 4"); + end if; + + + -- Check that Conversion_Error is propagated by function To_Packed if + -- the value of the decimal parameter Item is negative and the + -- specified Packed_Format parameter is Packed_Unsigned. + + begin + if Pack_1.To_Packed(Item => -12.3, Format => Packed_Unsigned) = + Pack_1.To_Packed(Item => 12.3, Format => Packed_Signed) + then + Report.Comment("Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised following call to " & + "function To_Packed with a negative parameter " & + "Item and Packed_Format parameter Packed_Unsigned"); + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Exception_Name(The_Error) & " was incorrectly " & + "raised following call to function To_Packed " & + "with a negative parameter Item and " & + "Packed_Format parameter Packed_Unsigned"); + end; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4007.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,271 ---- + -- CXB4007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Valid with Byte_Array and Binary_Format + -- parameters returns True if the Byte_Array parameter corresponds + -- to any value inside the range of type Num. + -- Check that function Valid returns False if the Byte_Array parameter + -- corresponds to a value outside the range of Num. + -- + -- Check that function Length with Binary_Format parameter will return + -- the minimum length of a Byte_Array value required to hold any value + -- of decimal type Num. + -- + -- Check that function To_Decimal with Byte_Array and Binary_Format + -- parameters will return a decimal type value that corresponds to + -- parameter Item (of type Byte_Array) under the specified Format. + -- + -- Check that Conversion_Error is propagated by function To_Decimal if + -- the Byte_Array parameter Item represents a decimal value outside the + -- range of decimal type Num. + -- + -- Check that function To_Binary will produce a Byte_Array result that + -- corresponds to the decimal type parameter Item, under the specified + -- Binary_Format. + -- + -- TEST DESCRIPTION: + -- This test uses several instantiations of generic package + -- Decimal_Conversions to provide appropriate test material. + -- This test uses the function To_Binary to create all Byte_Array + -- parameter values used in calls to functions Valid and To_Decimal. + -- The function Valid is tested with parameters to provide both + -- valid and invalid expected results. This test also checks that + -- Function To_Decimal produces expected results in cases where each + -- of the three predefined Binary_Format constants are used in the + -- function calls. In addition, the prescribed propagation of + -- Conversion_Error by function To_Decimal is verified. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 14 Feb 96 SAIC Initial release for 2.1. + -- 30 May 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- 05 JAN 98 EDS Remove incorrect subtest. + --! + + with Report; + with Ada.Exceptions; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4007 is + begin + + Report.Test ("CXB4007", "Check that functions Valid, Length, To_Decimal " & + "and To_Binary specific to Byte_Array and " & + "Binary_Format parameters produce correct results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits 8; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits 12; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.6; + TC_Dec_2 : Decimal_Type_2 := 123456.78; + TC_Dec_3 : Decimal_Type_3 := 1234567.890; + TC_Dec_4 : Decimal_Type_4 := 12345678.9012; + TC_Min_Length : Natural := 1; + TC_Max_Length : Natural := 16; + TC_Valid : Boolean := False; + + begin + + -- Check that the function Valid with Byte_Array and Binary_Format + -- parameters returns True if the Byte_Array parameter corresponds to + -- any value inside the range of type Num. + + if not Pack_1.Valid(Item => Pack_1.To_Binary(TC_Dec_1, + High_Order_First), + Format => High_Order_First) or + not Pack_1.Valid(Pack_1.To_Binary(0.0, Low_Order_First), + Format => Low_Order_First) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 1"); + end if; + + TC_Valid := (Pack_2.Valid(Pack_2.To_Binary(TC_Dec_2, High_Order_First), + Format => High_Order_First) and + Pack_2.Valid(Pack_2.To_Binary(0.01, Low_Order_First), + Format => Low_Order_First)); + if not TC_Valid then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 2"); + end if; + + if not Pack_3.Valid(Item => Pack_3.To_Binary(TC_Dec_3, + Low_Order_First), + Format => Low_Order_First) or + not Pack_3.Valid(Pack_3.To_Binary(0.001, High_Order_First), + Format => High_Order_First) or + not Pack_3.Valid(Pack_3.To_Binary(123.456, Native_Binary), + Native_Binary) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a positive result - 3"); + end if; + + + -- Check that function Valid returns False if the Byte_Array parameter + -- corresponds to a value outside the range of Num. + -- Note: use a Byte_Array value Item created by an instantiation of + -- To_Binary with a larger Num type as the generic formal. + + if Pack_1.Valid(Item => Pack_2.To_Binary(TC_Dec_2, Low_Order_First), + Format => Low_Order_First) or + Pack_2.Valid(Pack_3.To_Binary(TC_Dec_3, High_Order_First), + Format => High_Order_First) or + Pack_3.Valid(Pack_4.To_Binary(TC_Dec_4, Native_Binary), + Native_Binary) + then + Report.Failed("Incorrect result from function Valid, using " & + "parameters that should return a negative result"); + end if; + + + -- Check that function Length with Binary_Format parameter will return + -- the minimum length of a Byte_Array value required to hold any value + -- of decimal type Num. + + if not (Pack_1.Length(Native_Binary) >= TC_Min_Length and + Pack_1.Length(Low_Order_First) <= TC_Max_Length and + Pack_2.Length(High_Order_First) >= TC_Min_Length and + Pack_2.Length(Native_Binary) <= TC_Max_Length and + Pack_3.Length(Low_Order_First) >= TC_Min_Length and + Pack_3.Length(High_Order_First) <= TC_Max_Length and + Pack_4.Length(Native_Binary) >= TC_Min_Length and + Pack_4.Length(Low_Order_First) <= TC_Max_Length) + then + Report.Failed("Incorrect result from function Length"); + end if; + + + + -- Check that function To_Decimal with Byte_Array and Binary_Format + -- parameters will return a decimal type value that corresponds to + -- parameter Item (of type Byte_Array) under the specified Format. + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(Item => TC_Dec_1, + Format => Native_Binary), + Format => Native_Binary) /= + TC_Dec_1 + then + Report.Failed("Incorrect result from function To_Decimal - 1"); + end if; + + if Pack_3.To_Decimal(Pack_3.To_Binary(TC_Dec_3, High_Order_First), + Format => High_Order_First) /= + TC_Dec_3 + then + Report.Failed("Incorrect result from function To_Decimal - 2"); + end if; + + if Pack_4.To_Decimal(Pack_4.To_Binary(TC_Dec_4, Low_Order_First), + Low_Order_First) /= + TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal - 3"); + end if; + + + + -- Check that Conversion_Error is propagated by function To_Decimal + -- if the Byte_Array parameter Item represents a decimal value outside + -- the range of decimal type Num. + -- Note: use a Byte_Array value Item created by an instantiation of + -- To_Binary with a larger Num type as the generic formal. + + begin + TC_Dec_4 := 99999.9001; + TC_Dec_1 := Pack_1.To_Decimal(Pack_4.To_Binary(TC_Dec_4, + Native_Binary), + Format => Native_Binary); + if TC_Dec_1 = 99999.9 then + Report.Comment("Minimize dead assignment optimization -- " & + "Should never be printed"); + end if; + Report.Failed("Conversion_Error not raised following call to " & + "function To_Decimal if the Byte_Array parameter " & + "Item represents a decimal value outside the " & + "range of decimal type Num"); + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Exception_Name(The_Error) & " was incorrectly " & + "raised following call to function To_Decimal " & + "if the Byte_Array parameter Item represents " & + "a decimal value outside the range of decimal " & + "type Num"); + end; + + + + -- Check that function To_Binary will produce a Byte_Array result that + -- corresponds to the decimal type parameter Item, under the specified + -- Binary_Format. + + -- Different ordering. + TC_Dec_1 := 12345.6; + if Pack_1.To_Binary(TC_Dec_1, Low_Order_First) = + Pack_1.To_Binary(TC_Dec_1, High_Order_First) + then + Report.Failed("Incorrect result from function To_Binary - 1"); + end if; + + -- Variable vs. literal. + TC_Dec_2 := 12345.00; + if Pack_2.To_Binary(TC_Dec_2, Native_Binary) /= + Pack_2.To_Binary(12345.00, Native_Binary) + then + Report.Failed("Incorrect result from function To_Binary - 2"); + end if; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb4008.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,248 ---- + -- CXB4008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function To_Decimal with Binary parameter will return + -- the corresponding value of the decimal type Num. + -- + -- Check that the function To_Decimal with Long_Binary parameter will + -- return the corresponding value of the decimal type Num. + -- + -- Check that both of the To_Decimal functions described above will + -- propagate Conversion_Error if the converted value Item is outside + -- the range of type Num. + -- + -- Check that the function To_Binary converts a value of the Ada + -- decimal type Num into a Binary type value. + -- + -- Check that the function To_Long_Binary converts a value of the Ada + -- decimal type Num into a Long_Binary type value. + -- + -- TEST DESCRIPTION: + -- This test uses several instantiations of generic package + -- Decimal_Conversions to provide appropriate test material. + -- Two of the instantiations use decimal types as generic actuals + -- that include the implementation defined constants Max_Digits_Binary + -- and Max_Digits_Long_Binary in their definition. + -- + -- Subtests are included for both versions of function To_Decimal, + -- (Binary and Long_Binary parameters), and include checks that + -- Conversion_Error is propagated under the appropriate circumstances. + -- Functions To_Binary and To_Long_Binary are "sanity" checked, to + -- ensure that the functions are available, and that the results are + -- appropriate based on their parameter input. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.COBOL. If an implementation provides + -- package Interfaces.COBOL, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 21 Feb 96 SAIC Initial release for 2.1. + -- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Ada.Exceptions; + with Interfaces.COBOL; -- N/A => ERROR + + procedure CXB4008 is + begin + + Report.Test ("CXB4008", "Check that functions To_Decimal, To_Binary, and " & + "To_Long_Binary produce the correct results"); + + Test_Block: + declare + + use Interfaces.COBOL; + use Ada.Exceptions; + use type Interfaces.COBOL.Numeric; + + type Decimal_Type_1 is delta 0.1 digits 6; + type Decimal_Type_2 is delta 0.01 digits Max_Digits_Binary; + type Decimal_Type_3 is delta 0.001 digits 10; + type Decimal_Type_4 is delta 0.0001 digits Max_Digits_Long_Binary; + + package Pack_1 is new Decimal_Conversions(Decimal_Type_1); + package Pack_2 is new Decimal_Conversions(Decimal_Type_2); + package Pack_3 is new Decimal_Conversions(Decimal_Type_3); + package Pack_4 is new Decimal_Conversions(Decimal_Type_4); + + TC_Dec_1 : Decimal_Type_1 := 12345.0; + TC_Dec_2 : Decimal_Type_2 := 123456.00; + TC_Dec_3 : Decimal_Type_3 := 1234567.000; + TC_Dec_4 : Decimal_Type_4 := 12345678.0000; + TC_Binary : Interfaces.COBOL.Binary; + TC_Long_Binary : Interfaces.COBOL.Long_Binary; + + begin + + -- Check that the function To_Decimal with Binary parameter will + -- return the corresponding value of the decimal type Num. + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(TC_Dec_1)) /= TC_Dec_1 or + Pack_2.To_Decimal(Pack_2.To_Binary(TC_Dec_2)) /= TC_Dec_2 + then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 1"); + end if; + + if Pack_1.To_Decimal(Item => Pack_1.To_Binary(1234.0)) /= 1234.0 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 2"); + end if; + + TC_Binary := Pack_2.To_Binary(TC_Dec_2); + if Pack_2.To_Decimal(TC_Binary) /= TC_Dec_2 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Binary parameter - 3"); + end if; + + + + -- Check that the function To_Decimal with Long_Binary parameter + -- will return the corresponding value of the decimal type Num. + + if Pack_3.To_Decimal(Item => Pack_3.To_Long_Binary(TC_Dec_3)) /= + TC_Dec_3 or + Pack_4.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)) /= + TC_Dec_4 + then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 1"); + end if; + + if Pack_3.To_Decimal(Pack_3.To_Long_Binary(1234567.0)) /= 1234567.0 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 2"); + end if; + + TC_Long_Binary := Pack_4.To_Long_Binary(TC_Dec_4); + if Pack_4.To_Decimal(TC_Long_Binary) /= TC_Dec_4 then + Report.Failed("Incorrect result from function To_Decimal with " & + "Long_Binary parameter - 3"); + end if; + + + + -- Check that both of the To_Decimal functions described above + -- will propagate Conversion_Error if the converted value Item is + -- outside the range of type Num. + -- Note: Binary/Long_Binary parameter values are created by an + -- instantiation of To_Binary/To_Long_Binary with a larger + -- Num type as the generic formal. + + Binary_Parameter: + begin + TC_Dec_1 := Pack_1.To_Decimal(Pack_2.To_Binary(123456.78)); + Report.Failed("Conversion_Error was not raised by function " & + "To_Decimal with Binary parameter, when the " & + "converted value Item was outside the range " & + "of type Num"); + if TC_Dec_1 = 12345.6 then -- Avoid dead assignment optimization. + Report.Comment("Should never be printed"); + end if; + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " & + "was incorrectly raised by function To_Decimal " & + "with Binary parameter, when the converted " & + "value Item was outside the range of type Num"); + end Binary_Parameter; + + Long_Binary_Parameter: + begin + TC_Dec_3 := Pack_3.To_Decimal(Pack_4.To_Long_Binary(TC_Dec_4)); + Report.Failed("Conversion_Error was not raised by function " & + "To_Decimal with Long_Binary parameter, when " & + "the converted value Item was outside the range " & + "of type Num"); + if TC_Dec_3 = 123456.78 then -- Avoid dead assignment optimization. + Report.Comment("Should never be printed"); + end if; + exception + when Conversion_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed(Ada.Exceptions.Exception_Name(The_Error) & " " & + "was incorrectly raised by function To_Decimal " & + "with Long_Binary parameter, when the converted " & + "value Item was outside the range of type Num"); + end Long_Binary_Parameter; + + + + -- Check that the function To_Binary converts a value of the Ada + -- decimal type Num into a Binary type value. + + TC_Dec_1 := 123.4; + TC_Dec_2 := 9.99; + if Pack_1.To_Binary(TC_Dec_1) = Pack_1.To_Binary(-TC_Dec_1) or + Pack_2.To_Binary(TC_Dec_2) = Pack_2.To_Binary(-TC_Dec_2) + then + Report.Failed("Incorrect result from function To_Binary - 1"); + end if; + + if Pack_1.To_Binary(1.1) = Pack_1.To_Binary(-1.1) or + Pack_2.To_Binary(9999.99) = Pack_2.To_Binary(-9999.99) + then + Report.Failed("Incorrect result from function To_Binary - 2"); + end if; + + + -- Check that the function To_Long_Binary converts a value of the + -- Ada decimal type Num into a Long_Binary type value. + + TC_Dec_3 := 9.001; + TC_Dec_4 := 123.4567; + if Pack_3.To_Long_Binary(TC_Dec_3) = Pack_3.To_Long_Binary(-TC_Dec_3) or + Pack_4.To_Long_Binary(TC_Dec_4) = Pack_4.To_Long_Binary(-TC_Dec_4) + then + Report.Failed("Incorrect result from function To_Long_Binary - 1"); + end if; + + if Pack_3.To_Long_Binary(1.011) = + Pack_3.To_Long_Binary(-1.011) or + Pack_4.To_Long_Binary(2345678.9012) = + Pack_4.To_Long_Binary(-2345678.9012) + then + Report.Failed("Incorrect result from function To_Long_Binary - 2"); + end if; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB4008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- CXB5001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specification of the package Interfaces.Fortran + -- are available for use. + -- + -- TEST DESCRIPTION: + -- This test verifies that the types and subprograms specified for the + -- interface are present + -- + -- APPLICABILITY CRITERIA: + -- If an implementation provides package Interfaces.Fortran, this test + -- must compile, execute, and report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 28 Feb 96 SAIC Added applicability criteria. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Report; + with Interfaces.Fortran; -- N/A => ERROR + + procedure CXB5001 is + package Fortran renames Interfaces.FORTRAN; + + begin + + Report.Test ("CXB5001", "Check the specification of Interfaces.Fortran"); + + + declare -- encapsulate the test + + + TC_Int : integer := 1; + TC_Natural : natural; + TC_String : String := "ABCD"; + TC_Character : Character := 'a'; + + TST_Fortran_Integer : FORTRAN.Fortran_Integer; + + TST_Real : Fortran.Real; + TST_Double_Precision : Fortran.Double_Precision; + + TST_Logical : Fortran.Logical := FORTRAN.true; + -- verify it is a Boolean + TST_Complex : Fortran.Complex; + + TST_Imaginary_i : Fortran.Imaginary := FORTRAN.i; + TST_Imaginary_j : Fortran.Imaginary := FORTRAN.j; + + + -- Initialize it so we can use it below + TST_Character_Set : Fortran.Character_Set := + Fortran.Character_Set'First; + + TST_Fortran_Character : FORTRAN.Fortran_Character (1..5) := + (others => TST_Character_Set); + + + + begin -- encapsulation + + -- Arrange that the calls to the subprograms are compiled but + -- not executed + -- + if not Report.Equal ( TC_Int, TC_Int ) then + + TST_Character_Set := Fortran.To_Fortran (TC_Character); + TC_Character := Fortran.To_Ada (TST_Character_Set); + + + TST_Fortran_Character := FORTRAN.To_Fortran ("TEST STRING"); + Report.Comment ( Fortran.To_Ada (TST_Fortran_Character) ); + + Fortran.To_Fortran ( TC_String, TST_Fortran_Character, TC_Natural ); + Fortran.To_Ada ( TST_Fortran_Character, TC_String, TC_Natural ); + + end if; + + end; -- encapsulation + + Report.Result; + + end CXB5001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,334 ---- + -- CXB5002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Function To_Fortran with a Character parameter will + -- return the corresponding Fortran Character_Set value. + -- + -- Check that the Function To_Ada with a Character_Set parameter will + -- return the corresponding Ada Character value. + -- + -- Check that the Function To_Fortran with a String parameter will + -- return the corresponding Fortran_Character value. + -- + -- Check that the Function To_Ada with a Fortran_Character parameter + -- will return the corresponding Ada String value. + -- + -- TEST DESCRIPTION: + -- This test checks that the functions To_Fortran and To_Ada produce + -- the correct results, based on a variety of parameter input values. + -- + -- In the first series of subtests, the results of the function + -- To_Fortran are compared against expected Character_Set type results. + -- In the second series of subtests, the results of the function To_Ada + -- are compared against expected String type results, and the length of + -- the String result is also verified against the Fortran_Character type + -- parameter. + -- + -- This test uses Fixed, Bounded, and Unbounded_Strings in combination + -- with the functions under validation. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.Fortran.Character_Set: + -- ' ', 'a'..'z', 'A'..'Z', '1'..'9', '-', '_', '$', '#', and '*'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.Fortran. If an implementation provides + -- package Interfaces.Fortran, this test must compile, execute, and + -- report "PASSED". + -- + -- This test does not apply to an implementation in which the Fortran + -- character set ranges are not contiguous (e.g., EBCDIC). + -- + -- + -- + -- CHANGE HISTORY: + -- 11 Mar 96 SAIC Initial release for 2.1. + -- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Ada.Characters.Latin_1; + with Ada.Exceptions; + with Ada.Strings.Bounded; + with Ada.Strings.Unbounded; + with Ada.Unchecked_Conversion; + with Interfaces.Fortran; -- N/A => ERROR + with Report; + + procedure CXB5002 is + begin + + Report.Test ("CXB5002", "Check that functions To_Fortran and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + package ACL renames Ada.Characters.Latin_1; + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Bnd, Unb; + use Interfaces.Fortran; + use Ada.Exceptions; + + Null_Fortran_Character : constant Fortran_Character := ""; + Fortran_Character_1 : Fortran_Character(1..1) := " "; + Fortran_Character_5 : Fortran_Character(1..5) := " "; + Fortran_Character_10 : Fortran_Character(1..10) := " "; + Fortran_Character_20 : Fortran_Character(1..20) := + " "; + TC_Fortran_Character_1 : Fortran_Character(1..1) := "A"; + TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de"; + TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5"; + TC_Fortran_Character_20 : Fortran_Character(1..20) := + "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + Null_String : constant String := ""; + + Null_Character : constant Character := ACL.Nul; + Character_A : constant Character := Character'Val(65); + Character_Z : constant Character := Character'Val(90); + TC_Character : Character := Character'First; + + Null_Character_Set : Character_Set := To_Fortran(ACL.Nul); + TC_Character_Set, + TC_Low_Character_Set, + TC_High_Character_Set : Character_Set := Character_Set'First; + + + -- The following procedure checks the results of function To_Ada. + + procedure Check_Length (Str : in String; + Ftn : in Fortran_Character; + Num : in Natural) is + begin + if Str'Length /= Ftn'Length or + Str'Length /= Num + then + Report.Failed("Incorrect result from Function To_Ada " & + "with string length " & Integer'Image(Num)); + end if; + end Check_Length; + + -- To facilitate the conversion of Character-Character_Set data, the + -- following functions have been instantiated. + + function Character_to_Character_Set is + new Ada.Unchecked_Conversion(Character, Character_Set); + + function Character_Set_to_Character is + new Ada.Unchecked_Conversion(Character_Set, Character); + + begin + + -- Check that the Function To_Fortran with a Character parameter + -- will return the corresponding Fortran Character_Set value. + + for TC_Character in ACL.LC_A..ACL.LC_Z loop + if To_Fortran(Item => TC_Character) /= + Character_to_Character_Set(TC_Character) + then + Report.Failed("Incorrect result from To_Fortran with lower " & + "case alphabetic character input"); + end if; + end loop; + + for TC_Character in Character_A..Character_Z loop + if To_Fortran(TC_Character) /= + Character_to_Character_Set(TC_Character) + then + Report.Failed("Incorrect result from To_Fortran with upper " & + "case alphabetic character input"); + end if; + end loop; + + if To_Fortran(Null_Character) /= + Character_to_Character_Set(Null_Character) + then + Report.Failed + ("Incorrect result from To_Fortran with null character input"); + end if; + + + -- Check that the Function To_Ada with a Character_Set parameter + -- will return the corresponding Ada Character value. + + TC_Low_Character_Set := Character_to_Character_Set('a'); + TC_High_Character_Set := Character_to_Character_Set('z'); + for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop + if To_Ada(Item => TC_Character_Set) /= + Character_Set_to_Character(TC_Character_Set) + then + Report.Failed("Incorrect result from To_Ada with lower case " & + "alphabetic Character_Set input"); + end if; + end loop; + + TC_Low_Character_Set := Character_to_Character_Set('A'); + TC_High_Character_Set := Character_to_Character_Set('Z'); + for TC_Character_Set in TC_Low_Character_Set..TC_High_Character_Set loop + if To_Ada(TC_Character_Set) /= + Character_Set_to_Character(TC_Character_Set) + then + Report.Failed("Incorrect result from To_Ada with upper case " & + "alphabetic Character_Set input"); + end if; + end loop; + + if To_Ada(Character_to_Character_Set(Null_Character)) /= + Null_Character + then + Report.Failed("Incorrect result from To_Ada with a null " & + "Character_Set input"); + end if; + + + -- Check that the Function To_Fortran with a String parameter + -- will return the corresponding Fortran_Character value. + -- Note: The type Fortran_Character is a character array type that + -- corresponds to Ada type String. + + Fortran_Character_1 := To_Fortran(Item => TC_String_1); + + if Fortran_Character_1 /= TC_Fortran_Character_1 then + Report.Failed("Incorrect result from procedure To_Fortran - 1"); + end if; + + Fortran_Character_5 := To_Fortran(To_String(TC_Unb_String)); + + if Fortran_Character_5 /= TC_Fortran_Character_5 then + Report.Failed("Incorrect result from procedure To_Fortran - 2"); + end if; + + Fortran_Character_10 := To_Fortran(To_String(TC_Bnd_String)); + + if Fortran_Character_10 /= TC_Fortran_Character_10 then + Report.Failed("Incorrect result from procedure To_Fortran - 3"); + end if; + + Fortran_Character_20 := To_Fortran(Item => TC_String_20); + + if Fortran_Character_20 /= TC_Fortran_Character_20 then + Report.Failed("Incorrect result from procedure To_Fortran - 4"); + end if; + + if To_Fortran(Null_String) /= Null_Fortran_Character then + Report.Failed("Incorrect result from procedure To_Fortran - 5"); + end if; + + + -- Check that the Function To_Ada with a Fortran_Character parameter + -- will return the corresponding Ada String value. + + String_1 := To_Ada(TC_Fortran_Character_1); + + if String_1 /= TC_String_1 then + Report.Failed("Incorrect value returned from function To_Ada - 1"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_1), + TC_Fortran_Character_1, + Num => 1); + + + Unb_String := Unb.To_Unbounded_String(To_Ada(TC_Fortran_Character_5)); + + if Unb_String /= TC_Unb_String then + Report.Failed("Incorrect value returned from function To_Ada - 2"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_5), + TC_Fortran_Character_5, + Num => 5); + + + Bnd_String := Bnd.To_Bounded_String + (To_Ada(TC_Fortran_Character_10)); + + if Bnd_String /= TC_Bnd_String then + Report.Failed("Incorrect value returned from function To_Ada - 3"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_10), + TC_Fortran_Character_10, + Num => 10); + + + String_20 := To_Ada(TC_Fortran_Character_20); + + if String_20 /= TC_String_20 then + Report.Failed("Incorrect value returned from function To_Ada - 4"); + end if; + + Check_Length(To_Ada(TC_Fortran_Character_20), + TC_Fortran_Character_20, + Num => 20); + + if To_Ada(Null_Character_Set) /= Null_Character then + Report.Failed("Incorrect value returned from function To_Ada - 5"); + end if; + + + -- Check the two functions when used in combination. + + if To_Ada(Item => To_Fortran("This is a test")) /= + "This is a test" or + To_Ada(To_Fortran("1234567890abcdeFGHIJ")) /= + Report.Ident_Str("1234567890abcdeFGHIJ") + then + Report.Failed("Incorrect result returned when using the " & + "functions To_Ada and To_Fortran in combination"); + end if; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB5002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxb/cxb5003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,295 ---- + -- CXB5003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the procedure To_Fortran converts the character elements + -- of the String parameter Item into Character_Set elements of the + -- Fortran_Character type parameter Target. Check that the parameter + -- Last contains the index of the last element of parameter Target + -- that was assigned by To_Fortran. + -- + -- Check that Constraint_Error is propagated by procedure To_Fortran + -- when the length of String parameter Item exceeds the length of + -- Fortran_Character parameter Target. + -- + -- Check that the procedure To_Ada converts the Character_Set + -- elements of the Fortran_Character parameter Item into Character + -- elements of the String parameter Target. Check that the parameter + -- Last contains the index of the last element of parameter Target + -- that was assigned by To_Ada. + -- + -- Check that Constraint_Error is propagated by procedure To_Ada when + -- the length of Fortran_Character parameter Item exceeds the length of + -- String parameter Target. + -- + -- TEST DESCRIPTION: + -- This test checks that the procedures To_Fortran and To_Ada produce + -- the correct results, based on a variety of parameter input values. + -- + -- In the first series of subtests, the Out parameter results of + -- procedure To_Fortran are compared against expected results, + -- which includes (in the parameter Last) the index in Target of the + -- last element assigned. The situation where procedure To_Fortran + -- raises Constraint_Error (when Item'Length exceeds Target'Length) + -- is also verified. + -- + -- In the second series of subtests, the Out parameter results of + -- procedure To_Ada are verified, in a similar manner as is done for + -- procedure To_Fortran. The case of procedure To_Ada raising + -- Constraint_Error is also verified. + -- + -- This test assumes that the following characters are all included + -- in the implementation defined type Interfaces.Fortran.Character_Set: + -- ' ', 'a'..'j', 'A'..'D', '1'..'9', '-', '_', '$', '#', and '*'. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable to all implementations that provide + -- package Interfaces.Fortran. If an implementation provides + -- package Interfaces.Fortran, this test must compile, execute, and + -- report "PASSED". + -- + -- + -- CHANGE HISTORY: + -- 14 Mar 96 SAIC Initial release for 2.1. + -- 10 Jun 96 SAIC Incorporated reviewer comments for ACVC 2.1. + -- 27 Oct 96 SAIC Incorporated reviewer comments. + -- + --! + + with Ada.Exceptions; + with Ada.Strings.Bounded; + with Ada.Strings.Unbounded; + with Interfaces.Fortran; -- N/A => ERROR + with Report; + + procedure CXB5003 is + begin + + Report.Test ("CXB5003", "Check that procedures To_Fortran and To_Ada " & + "produce correct results"); + + Test_Block: + declare + + package Bnd is new Ada.Strings.Bounded.Generic_Bounded_Length(10); + package Unb renames Ada.Strings.Unbounded; + + use Bnd, Unb; + use Interfaces.Fortran; + use Ada.Exceptions; + + Fortran_Character_1 : Fortran_Character(1..1) := " "; + Fortran_Character_5 : Fortran_Character(1..5) := " "; + Fortran_Character_10 : Fortran_Character(1..10) := " "; + Fortran_Character_20 : Fortran_Character(1..20) := + " "; + TC_Fortran_Character_1 : Fortran_Character(1..1) := "A"; + TC_Fortran_Character_5 : Fortran_Character(1..5) := "ab*de"; + TC_Fortran_Character_10 : Fortran_Character(1..10) := "$1a2b3C4D5"; + TC_Fortran_Character_20 : Fortran_Character(1..20) := + "1234-ABCD_6789#fghij"; + + Bnd_String : Bnd.Bounded_String := + Bnd.To_Bounded_String(" "); + TC_Bnd_String : Bounded_String := + To_Bounded_String("$1a2b3C4D5"); + + Unb_String : Unb.Unbounded_String := + Unb.To_Unbounded_String(" "); + TC_Unb_String : Unbounded_String := + To_Unbounded_String("ab*de"); + + String_1 : String(1..1) := " "; + String_5 : String(1..5) := " "; + String_10 : String(1..10) := " "; + String_20 : String(1..20) := " "; + TC_String_1 : String(1..1) := "A"; + TC_String_20 : String(1..20) := "1234-ABCD_6789#fghij"; + + TC_Fortran_Character : constant Fortran_Character := ""; + TC_String : constant String := ""; + TC_Natural : Natural := 0; + + + begin + + -- Check that the procedure To_Fortran converts the character elements + -- of the String parameter Item into Character_Set elements of the + -- Fortran_Character type parameter Target. + -- Check that the parameter Last contains the index of the last element + -- of parameter Target that was assigned by To_Fortran. + + To_Fortran(Item => TC_String_1, + Target => Fortran_Character_1, + Last => TC_Natural); + + if Fortran_Character_1 /= TC_Fortran_Character_1 or + TC_Natural /= TC_Fortran_Character_1'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 1"); + end if; + + To_Fortran(To_String(TC_Unb_String), + Target => Fortran_Character_5, + Last => TC_Natural); + + if Fortran_Character_5 /= TC_Fortran_Character_5 or + TC_Natural /= TC_Fortran_Character_5'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 2"); + end if; + + To_Fortran(To_String(TC_Bnd_String), + Fortran_Character_10, + Last => TC_Natural); + + if Fortran_Character_10 /= TC_Fortran_Character_10 or + TC_Natural /= TC_Fortran_Character_10'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 3"); + end if; + + To_Fortran(TC_String_20, Fortran_Character_20, TC_Natural); + + if Fortran_Character_20 /= TC_Fortran_Character_20 or + TC_Natural /= TC_Fortran_Character_20'Length + then + Report.Failed("Incorrect result from procedure To_Fortran - 4"); + end if; + + To_Fortran(Item => TC_String, -- null string + Target => Fortran_Character_1, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Fortran, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + -- Check that Constraint_Error is propagated by procedure To_Fortran + -- when the length of String parameter Item exceeds the length of + -- Fortran_Character parameter Target. + + begin + + To_Fortran(Item => TC_String_20, + Target => Fortran_Character_10, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure " & + "To_Fortran when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed("The following exception was raised by procedure " & + "To_Fortran when Item'Length exceeds " & + "Target'Length: " & Exception_Name(The_Error)); + end; + + + -- Check that the procedure To_Ada converts the Character_Set + -- elements of the Fortran_Character parameter Item into Character + -- elements of the String parameter Target. + -- Check that the parameter Last contains the index of the last + -- element of parameter Target that was assigned by To_Ada. + + To_Ada(Item => TC_Fortran_Character_1, + Target => String_1, + Last => TC_Natural); + + if String_1 /= TC_String_1 or + TC_Natural /= TC_String_1'Length + then + Report.Failed("Incorrect result from procedure To_Ada - 1"); + end if; + + To_Ada(TC_Fortran_Character_5, + Target => String_5, + Last => TC_Natural); + + if String_5 /= To_String(TC_Unb_String) or + TC_Natural /= Length(TC_Unb_String) + then + Report.Failed("Incorrect result from procedure To_Ada - 2"); + end if; + + To_Ada(TC_Fortran_Character_10, + String_10, + Last => TC_Natural); + + if String_10 /= To_String(TC_Bnd_String) or + TC_Natural /= Length(TC_Bnd_String) + then + Report.Failed("Incorrect result from procedure To_Ada - 3"); + end if; + + To_Ada(TC_Fortran_Character_20, String_20, TC_Natural); + + if String_20 /= TC_String_20 or + TC_Natural /= TC_String_20'Length + then + Report.Failed("Incorrect result from procedure To_Ada - 4"); + end if; + + To_Ada(Item => TC_Fortran_Character, -- null array. + Target => String_20, + Last => TC_Natural); + + if TC_Natural /= 0 then + Report.Failed("Incorrect result from procedure To_Ada, value " & + "returned in parameter Last should be zero, since " & + "parameter Item is null array"); + end if; + + + -- Check that Constraint_Error is propagated by procedure To_Ada + -- when the length of Fortran_Character parameter Item exceeds the + -- length of String parameter Target. + + begin + + To_Ada(Item => TC_Fortran_Character_10, + Target => String_5, + Last => TC_Natural); + Report.Failed("Constraint_Error not raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + exception + when Constraint_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed("Incorrect exception raised by procedure To_Ada " & + "when Item'Length exceeds Target'Length"); + end; + + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXB5003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf1001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,261 ---- + -- CXF1001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that values of 2 and 10 are allowable values for Machine_Radix + -- of a decimal first subtype. + -- Check that the value of Decimal.Max_Decimal_Digits is at least 18; + -- the value of Decimal.Max_Scale is at least 18; the value of + -- Decimal.Min_Scale is at most 0. + -- + -- TEST DESCRIPTION: + -- This test examines the Machine_Radix attribute definition clause + -- and its effect on Decimal fixed point types, as well as several + -- constants from the package Ada.Decimal. + -- The first subtest checks that the Machine_Radix attribute will + -- return the value set for Machine_Radix by an attribute definition + -- clause. The second and third subtests examine differences between + -- the binary and decimal scaling of a type, based on the radix + -- representation. The final subtest examines the values + -- assigned to constants Min_Scale, Max_Scale, and Max_Decimal_Digits, + -- found in the package Ada.Decimal. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 29 Dec 94 SAIC Restructured Radix 10 and Radix 2 test blocks. + -- + --! + + with Report; + with Ada.Decimal; + + procedure CXF1001 is + begin + + Report.Test ("CXF1001", "Check that values of 2 and 10 are allowable " & + "values for Machine_Radix of a decimal first " & + "subtype. Check that the value of " & + "Decimal.Max_Decimal_Digits is at least 18; " & + "the value of Decimal.Max_Scale is at least " & + "18; the value of Decimal.Min_Scale is at " & + "most 0"); + + Attribute_Check_Block: + declare + + Del : constant := 1.0/10**2; + Const_Digits : constant := 3; + Two : constant := 2; + Ten : constant := 10; + + type Radix_2_Type_1 is delta 0.01 digits 7; + type Radix_2_Type_2 is delta Ada.Decimal.Min_Delta digits 10; + type Radix_2_Type_3 is + delta 0.000_1 digits Ada.Decimal.Max_Decimal_Digits; + + type Radix_10_Type_1 is delta 10.0**(-Ada.Decimal.Max_Scale) digits 8; + type Radix_10_Type_2 is delta 10.0**(-Ada.Decimal.Min_Scale) digits 6; + type Radix_10_Type_3 is delta Ada.Decimal.Max_Delta digits 15; + + + -- Use an attribute definition clause to set the Machine_Radix for a + -- decimal first subtype to either 2 or 10. + for Radix_2_Type_1'Machine_Radix use 2; + for Radix_2_Type_2'Machine_Radix use Two; + for Radix_2_Type_3'Machine_Radix use 10-8; + + for Radix_10_Type_1'Machine_Radix use 2*15/Const_Digits; + for Radix_10_Type_2'Machine_Radix use Ten; + for Radix_10_Type_3'Machine_Radix use Radix_10_Type_2'Machine_Radix; + + + begin + + -- Check that the attribute 'Machine_Radix returns the value assigned + -- by the attribute definition clause. + + if Radix_2_Type_1'Machine_Radix /= 2 or else + Radix_2_Type_2'Machine_Radix /= 2 or else + Radix_2_Type_3'Machine_Radix /= 2 + then + Report.Failed("Incorrect radix value returned, 2 expected"); + end if; + + if Radix_10_Type_1'Machine_Radix /= 10 or else + Radix_10_Type_2'Machine_Radix /= 10 or else + Radix_10_Type_3'Machine_Radix /= 10 + then + Report.Failed("Incorrect radix value returned, 10 expected"); + end if; + + exception + when others => Report.Failed ("Exception raised in Attr_Check_Block"); + end Attribute_Check_Block; + + + + Radix_Block: + -- Premises: + -- 1) Choose several numbers, from types using either decimal scaling or + -- binary scaling. + -- 1) Repetitively add these numbers to themselves. + -- 3) Validate that the result is the expected result, regardless of the + -- scaling used in the definition of the type. + declare + + Number_Of_Values : constant := 3; + Loop_Count : constant := 1000; + + type Radix_2_Type is delta 0.0001 digits 10; + type Radix_10_Type is delta 0.0001 digits 10; + + for Radix_2_Type'Machine_Radix use 2; + for Radix_10_Type'Machine_Radix use 10; + + type Result_Record_Type is record + Rad_2 : Radix_2_Type; + Rad_10 : Radix_10_Type; + end record; + + type Result_Array_Type is array (1..Number_Of_Values) + of Result_Record_Type; + + Result_Array : Result_Array_Type := ((50.00, 50.00), + (613.00, 613.00), + (72.70, 72.70)); + + function Repetitive_Radix_2_Add (Value : in Radix_2_Type) + return Radix_2_Type is + Result : Radix_2_Type := 0.0; + begin + for i in 1..Loop_Count loop + Result := Result + Value; + end loop; + return Result; + end Repetitive_Radix_2_Add; + + function Repetitive_Radix_10_Add (Value : in Radix_10_Type) + return Radix_10_Type is + Result : Radix_10_Type := 0.0; + begin + for i in 1..Loop_Count loop + Result := Result + Value; + end loop; + return Result; + end Repetitive_Radix_10_Add; + + begin + + -- Radix 2 Cases, three different values. + -- Compare the result of the repetitive addition with the expected + -- Radix 2 result, as well as with the Radix 10 value after type + -- conversion. + + if Repetitive_Radix_2_Add(0.05) /= Result_Array(1).Rad_2 or + Repetitive_Radix_2_Add(0.05) /= Radix_2_Type(Result_Array(1).Rad_10) + then + Report.Failed("Incorrect Radix 2 Result, Case 1"); + end if; + + if Repetitive_Radix_2_Add(0.613) /= + Result_Array(2).Rad_2 or + Repetitive_Radix_2_Add(0.613) /= + Radix_2_Type(Result_Array(2).Rad_10) + then + Report.Failed("Incorrect Radix 2 Result, Case 2"); + end if; + + if Repetitive_Radix_2_Add(0.0727) /= + Result_Array(3).Rad_2 or + Repetitive_Radix_2_Add(0.0727) /= + Radix_2_Type(Result_Array(3).Rad_10) + then + Report.Failed("Incorrect Radix 2 Result, Case 3"); + end if; + + -- Radix 10 Cases, three different values. + -- Compare the result of the repetitive addition with the expected + -- Radix 10 result, as well as with the Radix 2 value after type + -- conversion. + + if Repetitive_Radix_10_Add(0.05) /= Result_Array(1).Rad_10 or + Repetitive_Radix_10_Add(0.05) /= Radix_10_Type(Result_Array(1).Rad_2) + then + Report.Failed("Incorrect Radix 10 Result, Case 1"); + end if; + + if Repetitive_Radix_10_Add(0.613) /= + Result_Array(2).Rad_10 or + Repetitive_Radix_10_Add(0.613) /= + Radix_10_Type(Result_Array(2).Rad_2) + then + Report.Failed("Incorrect Radix 10 Result, Case 2"); + end if; + + if Repetitive_Radix_10_Add(0.0727) /= + Result_Array(3).Rad_10 or + Repetitive_Radix_10_Add(0.0727) /= + Radix_10_Type(Result_Array(3).Rad_2) + then + Report.Failed("Incorrect Radix 10 Result, Case 3"); + end if; + + exception + when others => Report.Failed ("Exception raised in Radix_Block"); + end Radix_Block; + + + + Size_Block: + -- Check the implementation max/min values of constants declared in + -- package Ada.Decimal. + declare + Minimum_Required_Size : constant := 18; + Maximum_Allowed_Size : constant := 0; + begin + + -- Check that the Max_Decimal_Digits value is at least 18. + if not (Ada.Decimal.Max_Decimal_Digits >= Minimum_Required_Size) then + Report.Failed("Insufficient size provided for Max_Decimal_Digits"); + end if; + + -- Check that the Max_Scale value is at least 18. + if not (Ada.Decimal.Max_Scale >= Minimum_Required_Size) then + Report.Failed("Insufficient size provided for Max_Scale"); + end if; + + -- Check that the Min_Scale value is at most 0. + if not (Ada.Decimal.Min_Scale <= Maximum_Allowed_Size) then + Report.Failed("Too large a value provided for Min_Scale"); + end if; + + exception + when others => Report.Failed ("Exception raised in Size_Block"); + end Size_Block; + + Report.Result; + + end CXF1001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,755 ---- + -- CXF2001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the Divide procedure provides the following results: + -- Quotient = Dividend divided by Divisor and + -- Remainder = Dividend - (Divisor * Quotient) + -- Check that the Remainder is calculated exactly. + -- + -- TEST DESCRIPTION: + -- This test is designed to test the generic procedure Divide found in + -- package Ada.Decimal. + -- + -- The table below attempts to portray the design approach used in this + -- test. There are three "dimensions" of concern: + -- 1) the delta value of the Quotient and Remainder types, shown as + -- column headers, + -- 2) specific choices for the Dividend and Divisor numerical values + -- (i.e., whether they yielded a repeating/non-terminating result, + -- or a terminating result ["exact"]), displayed on the left side + -- of the tables, and + -- 3) the delta for the Dividend and Divisor. + -- + -- Each row in the tables indicates a specific test case, showing the + -- specific quotient and remainder (under the appropriate Delta column) + -- for each combination of dividend and divisor values. Test cases + -- follow the top-to-bottom sequence shown in the tables. + -- + -- Most of the test case sets (same dividend/divisor combinations - + -- indicated by dashed horizontal lines in the tables) vary the + -- delta of the quotient and remainder types between test cases. This + -- allows for an examination of how different deltas for a quotient + -- and/or remainder type can influence the results of a division with + -- identical dividend and divisor. + -- + -- Note: Test cases are performed for both Radix 10 and Radix 2 types. + -- + -- + -- Divid Divis Delta Delta Delta Delta Delta + -- (Delta)(Delta)| .1 | .01 | .001 | .0001 | .00001 |Test + -- |---|---|-----|-----|-----|-----|-----|-----|-----|-----|Case + -- quotient | Q | R | Q | R | Q | R | Q | R | Q | R | No. + -- --------------------------------------------------------------------------- + -- .05 .3 |.1 .02 1,21 + -- (.01) (.1) |.1 0 2,22 + -- | .16 .002 3,23 + -- 0.166666.. | .16 .00 4,24 + -- | .166 .0002 5,25 + -- --------------------------------------------------------------------------- + -- .15 20 | .00 .1500 6,26 + -- (.01) (1) | .00 .150 7,27 + -- | .00 .15 8,28 + -- 0.0075 | .01 .007 9,29 + -- | .007 .010 10,30 + -- | .0075 .0000 11,31 + -- --------------------------------------------------------------------------- + -- .03125 .5 | .0625 .0000 12,32 + -- (.00001) (.1) | .062 .00025 13,33 + -- | .062 .0002 14,34 + -- 0.0625 | .062 .000 15,35 + -- | .00 .062 16,36 + -- | .06 .00125 17,37 + -- | .06 .0012 18,38 + -- | .06 .001 19,39 + -- | .06 .00 20,40 + -- --------------------------------------------------------------------------- + -- Divide by Zero| Raise Constraint_Error 41 + -- --------------------------------------------------------------------------- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 29 Dec 94 SAIC Modified Radix 2 cases to match Radix 10 cases. + -- 03 Oct 95 RBKD Modified to fix incorrect remainder results + -- 15 Nov 95 SAIC Incorporated reviewer fixes for ACVC 2.0.1. + -- + --! + + with Report; + with Ada.Decimal; + + procedure CXF2001 is + + TC_Verbose : Boolean := False; + + begin + + Report.Test ("CXF2001", "Check that the Divide procedure provides " & + "correct results. Check that the Remainder " & + "is calculated exactly"); + Radix_10_Block: + declare + + + -- Declare all types and variables used in the various blocks below + -- for all Radix 10 evaluations. + + type DT_1 is delta 1.0 digits 5; + type DT_0_1 is delta 0.1 digits 10; + type DT_0_01 is delta 0.01 digits 10; + type DT_0_001 is delta 0.001 digits 10; + type DT_0_0001 is delta 0.0001 digits 10; + type DT_0_00001 is delta 0.00001 digits 10; + + for DT_1'Machine_Radix use 10; + for DT_0_1'Machine_Radix use 10; + for DT_0_01'Machine_Radix use 10; + for DT_0_001'Machine_Radix use 10; + for DT_0_0001'Machine_Radix use 10; + for DT_0_00001'Machine_Radix use 10; + + Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0; + Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0; + Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0; + Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0; + Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0; + Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0; + + begin + + + declare + procedure Div is + new Ada.Decimal.Divide(Dividend_Type => DT_0_01, + Divisor_Type => DT_0_1, + Quotient_Type => DT_0_1, + Remainder_Type => DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 1"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_01); + if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then + Report.Failed("Incorrect values returned, Case 1"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1); + begin + if TC_Verbose then Report.Comment("Case 2"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_1); + if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then + Report.Failed("Incorrect values returned, Case 2"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 3"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then + Report.Failed("Incorrect values returned, Case 3"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 4"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then + Report.Failed("Incorrect values returned, Case 4"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 5"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001); + if Quot_0_001 /= DT_0_001(0.166) or + Rem_0_0001 /= DT_0_0001(0.0002) + then + Report.Failed("Incorrect values returned, Case 5"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 6"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then + Report.Failed("Incorrect values returned, Case 6"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 7"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then + Report.Failed("Incorrect values returned, Case 7"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 8"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then + Report.Failed("Incorrect values returned, Case 8"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 9"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001); + if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then + Report.Failed("Incorrect values returned, Case 9"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 10"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01); + if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then + Report.Failed("Incorrect values returned, Case 10"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 11"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001); + if Quot_0_0001 /= DT_0_0001(0.0075) or + Rem_0_0001 /= DT_0_0001(0.0) + then + Report.Failed("Incorrect values returned, Case 11"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 12"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001); + if Quot_0_0001 /= DT_0_0001(0.0625) or + Rem_0_0001 /= DT_0_0001(0.0) + then + Report.Failed("Incorrect values returned, Case 12"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001); + begin + if TC_Verbose then Report.Comment("Case 13"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001); + if Quot_0_001 /= DT_0_001(0.062) or + Rem_0_00001 /= DT_0_00001(0.00025) + then + Report.Failed("Incorrect values returned, Case 13"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 14"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001); + if Quot_0_001 /= DT_0_001(0.062) or + Rem_0_0001 /= DT_0_0001(0.0002) + then + Report.Failed("Incorrect values returned, Case 14"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 15"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_001); + if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000) + then + Report.Failed("Incorrect values returned, Case 15"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 16"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_01); + if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then + Report.Failed("Incorrect values returned, Case 16"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001); + begin + if TC_Verbose then Report.Comment("Case 17"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125) + then + Report.Failed("Incorrect values returned, Case 17"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 18"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012) + then + Report.Failed("Incorrect values returned, Case 18"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 19"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then + Report.Failed("Incorrect values returned, Case 19"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 20"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then + Report.Failed("Incorrect values returned, Case 20"); + end if; + end; + + + exception + when others => Report.Failed("Exception raised in Radix_10_Block"); + end Radix_10_Block; + + + + Radix_2_Block: + declare + + -- Declare all types and variables used in the various blocks below + -- for all Radix 2 evaluations. + + type DT_1 is delta 1.0 digits 5; + type DT_0_1 is delta 0.1 digits 10; + type DT_0_01 is delta 0.01 digits 10; + type DT_0_001 is delta 0.001 digits 10; + type DT_0_0001 is delta 0.0001 digits 10; + type DT_0_00001 is delta 0.00001 digits 10; + + for DT_1'Machine_Radix use 2; + for DT_0_1'Machine_Radix use 2; + for DT_0_01'Machine_Radix use 2; + for DT_0_001'Machine_Radix use 2; + for DT_0_0001'Machine_Radix use 2; + for DT_0_00001'Machine_Radix use 2; + + Dd_1, Dv_1, Quot_1, Rem_1 : DT_1 := 0.0; + Dd_0_1, Dv_0_1, Quot_0_1, Rem_0_1 : DT_0_1 := 0.0; + Dd_0_01, Dv_0_01, Quot_0_01, Rem_0_01 : DT_0_01 := 0.0; + Dd_0_001, Dv_0_001, Quot_0_001, Rem_0_001 : DT_0_001 := 0.0; + Dd_0_0001, Dv_0_0001, Quot_0_0001, Rem_0_0001 : DT_0_0001 := 0.0; + Dd_0_00001, Dv_0_00001, Quot_0_00001, Rem_0_00001 : DT_0_00001 := 0.0; + + begin + + + declare + procedure Div is + new Ada.Decimal.Divide(Dividend_Type => DT_0_01, + Divisor_Type => DT_0_1, + Quotient_Type => DT_0_1, + Remainder_Type => DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 21"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_01); + if Quot_0_1 /= DT_0_1(0.1) or Rem_0_01 /= DT_0_01(0.02) then + Report.Failed("Incorrect values returned, Case 21"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_1, DT_0_1); + begin + if TC_Verbose then Report.Comment("Case 22"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_1, Rem_0_1); + if Quot_0_1 /= DT_0_1(0.1) or Rem_0_1 /= DT_0_1(0.0) then + Report.Failed("Incorrect values returned, Case 22"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 23"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.16) or Rem_0_001 /= DT_0_001(0.002) then + Report.Failed("Incorrect values returned, Case 23"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 24"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.16) or Rem_0_01 /= DT_0_01(0.0) then + Report.Failed("Incorrect values returned, Case 24"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_0_1, DT_0_001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 25"); end if; + Dd_0_01 := DT_0_01(0.05); Dv_0_1 := DT_0_1(0.3); + Div(Dd_0_01, Dv_0_1, Quot_0_001, Rem_0_0001); + if Quot_0_001 /= DT_0_001(0.166) or + Rem_0_0001 /= DT_0_0001(0.0002) + then + Report.Failed("Incorrect values returned, Case 25"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 26"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_0001); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_0001 /= DT_0_0001(0.1500) then + Report.Failed("Incorrect values returned, Case 26"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 27"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_001 /= DT_0_001(0.150) then + Report.Failed("Incorrect values returned, Case 27"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 28"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.0) or Rem_0_01 /= DT_0_01(0.15) then + Report.Failed("Incorrect values returned, Case 28"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 29"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_001); + if Quot_0_001 /= DT_0_001(0.007) or Rem_0_001 /= DT_0_001(0.01) then + Report.Failed("Incorrect values returned, Case 29"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_001, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 30"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_001, Rem_0_01); + if Quot_0_001 /= DT_0_001(0.007) or Rem_0_01 /= DT_0_01(0.01) then + Report.Failed("Incorrect values returned, Case 30"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_01, DT_1, DT_0_0001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 31"); end if; + Dd_0_01 := DT_0_01(0.15); Dv_1 := DT_1(20); + Div(Dd_0_01, Dv_1, Quot_0_0001, Rem_0_0001); + if Quot_0_0001 /= DT_0_0001(0.0075) or + Rem_0_0001 /= DT_0_0001(0.0) + then + Report.Failed("Incorrect values returned, Case 31"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_0001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 32"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_0001, Rem_0_0001); + if Quot_0_0001 /= DT_0_0001(0.0625) or + Rem_0_0001 /= DT_0_0001(0.0) + then + Report.Failed("Incorrect values returned, Case 32"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_00001); + begin + if TC_Verbose then Report.Comment("Case 33"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_00001); + if Quot_0_001 /= DT_0_001(0.062) or + Rem_0_00001 /= DT_0_00001(0.00025) + then + Report.Failed("Incorrect values returned, Case 33"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 34"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_0001); + if Quot_0_001 /= DT_0_001(0.062) or + Rem_0_0001 /= DT_0_0001(0.0002) + then + Report.Failed("Incorrect values returned, Case 34"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 35"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_001); + if Quot_0_001 /= DT_0_001(0.062) or Rem_0_001 /= DT_0_001(0.000) + then + Report.Failed("Incorrect values returned, Case 35"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_001, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 36"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_001, Rem_0_01); + if Quot_0_001 /= DT_0_001(0.062) or Rem_0_01 /= DT_0_01(0.00) then + Report.Failed("Incorrect values returned, Case 36"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_00001); + begin + if TC_Verbose then Report.Comment("Case 37"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_00001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_00001 /= DT_0_00001(0.00125) + then + Report.Failed("Incorrect values returned, Case 37"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 38"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_0001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_0001 /= DT_0_0001(0.0012) + then + Report.Failed("Incorrect values returned, Case 38"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_001); + begin + if TC_Verbose then Report.Comment("Case 39"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_001); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_001 /= DT_0_001(0.001) then + Report.Failed("Incorrect values returned, Case 39"); + end if; + end; + + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_00001, DT_0_1, DT_0_01, DT_0_01); + begin + if TC_Verbose then Report.Comment("Case 40"); end if; + Dd_0_00001 := DT_0_00001(0.03125); Dv_0_1 := DT_0_1(0.5); + Div(Dd_0_00001, Dv_0_1, Quot_0_01, Rem_0_01); + if Quot_0_01 /= DT_0_01(0.06) or Rem_0_01 /= DT_0_01(0.0) then + Report.Failed("Incorrect values returned, Case 40"); + end if; + end; + + declare + procedure Div is + new Ada.Decimal.Divide(DT_0_0001, DT_1, DT_0_0001, DT_0_0001); + begin + if TC_Verbose then Report.Comment("Case 41"); end if; + Dd_0_0001 := (DT_0_0001(6062.0) / DT_0_0001(16384.0)); + Dv_1 := DT_1(0.0); + Div(Dd_0_0001, Dv_1, Quot_0_0001, Rem_0_0001); + Report.Failed("Divide by Zero didn't raise Constraint_Error, " & + "Case 41"); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised by Divide by Zero," & + "Case 41"); + end; + + exception + when others => Report.Failed("Exception raised in Radix_10_Block"); + end Radix_2_Block; + + + Report.Result; + + end CXF2001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,352 ---- + -- CXF2002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the multiplying operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- Check the case where the operand and result types are the same. + -- + -- Check that if the mathematical result is between multiples of the + -- small of the result type, the result is truncated toward zero. + -- Check that if the attribute 'Round is applied to the mathematical + -- result, however, the result is rounded to the nearest multiple of + -- the small (away from zero if the result is midway between two + -- multiples of the small). + -- + -- TEST DESCRIPTION: + -- Two decimal fixed point types are declared, one with a Machine_Radix + -- value of 2, and one with a value of 10. For each type, checks are + -- performed on the following operations, where the operand and result + -- types are the same: + -- + -- - Multiplication. + -- - Multiplication, where the attribute 'Round is applied to the + -- result. + -- - Division. + -- - Division, where the attribute 'Round is applied to the result. + -- + -- Each operation is performed within a loop, where one operand is + -- always the same variable. After the loop completes, the cumulative + -- total contained in this variable is compared with the expected + -- result. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 27 Mar 96 SAIC Prerelease version for ACVC 2.1. + -- + --! + + generic + type Decimal_Fixed is delta <> digits <>; + package CXF2002_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; + Factor : in Decimal_Fixed); + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; + Divisor : in Decimal_Fixed); + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed; + Factor : in Decimal_Fixed); + + procedure Divide_And_Round (Balance : in out Decimal_Fixed; + Divisor : in Decimal_Fixed); + + end CXF2002_0; + + + --==================================================================-- + + + package body CXF2002_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; + Factor : in Decimal_Fixed) is + Interest : Decimal_Fixed; + begin + Interest := Factor * Balance; -- Fixed-fixed multiplication. + Balance := Balance + Interest; + end Multiply_And_Truncate; + + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; + Divisor : in Decimal_Fixed) is + Interest : Decimal_Fixed; + begin + Interest := Balance / Divisor; -- Fixed-fixed division. + Balance := Balance + Interest; + end Divide_And_Truncate; + + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed; + Factor : in Decimal_Fixed) is + Interest : Decimal_Fixed; + begin + -- Fixed-fixed multiplication. + Interest := Decimal_Fixed'Round ( Factor * Balance ); + Balance := Balance + Interest; + end Multiply_And_Round; + + + procedure Divide_And_Round (Balance : in out Decimal_Fixed; + Divisor : in Decimal_Fixed) is + Interest : Decimal_Fixed; + begin + -- Fixed-fixed division. + Interest := Decimal_Fixed'Round ( Balance / Divisor ); + Balance := Balance + Interest; + end Divide_And_Round; + + end CXF2002_0; + + + --==================================================================-- + + + package CXF2002_1 is + + type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 + + + type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 + + end CXF2002_1; + + + --==================================================================-- + + + with CXF2002_0; + with CXF2002_1; + + with Report; + procedure CXF2002 is + + Loop_Count : constant := 300; + type Loop_Range is range 1 .. Loop_Count; + + begin + + Report.Test ("CXF2002", "Check decimal multiplication and division, and " & + "'Round, where the operand and result types are " & + "the same"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_2_SUBTESTS: + declare + package Radix_2 is new CXF2002_0 (CXF2002_1.Money_Radix2); + use type CXF2002_1.Money_Radix2; + begin + + RADIX_2_MULTIPLICATION: + declare + Rate : constant CXF2002_1.Money_Radix2 := 0.12; + Period : constant Integer := 12; + Factor : CXF2002_1.Money_Radix2 := Rate / Period; + + Initial : constant CXF2002_1.Money_Radix2 := 100_000.00; + Trunc_Expected : constant CXF2002_1.Money_Radix2 := 1_978_837.50; + Round_Expected : constant CXF2002_1.Money_Radix2 := 1_978_846.75; + + Balance : CXF2002_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Truncate (Balance, Factor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 2 multiply and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Round (Balance, Factor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 2 multiply and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_2_MULTIPLICATION; + + + RADIX_2_DIVISION: + declare + Rate : constant CXF2002_1.Money_Radix2 := 0.25; + Period : constant Integer := 12; + Factor : CXF2002_1.Money_Radix2 := Rate / Period; + Divisor : constant CXF2002_1.Money_Radix2 := 1.0 / Factor; + + Initial : constant CXF2002_1.Money_Radix2 := 5_500.36; + Trunc_Expected : constant CXF2002_1.Money_Radix2 := 2_091_332.87; + Round_Expected : constant CXF2002_1.Money_Radix2 := 2_091_436.88; + + Balance : CXF2002_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Truncate (Balance, Divisor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 2 divide and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Round (Balance, Divisor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 2 divide and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_2_DIVISION; + + end RADIX_2_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_10_SUBTESTS: + declare + package Radix_10 is new CXF2002_0 (CXF2002_1.Money_Radix10); + use type CXF2002_1.Money_Radix10; + begin + + RADIX_10_MULTIPLICATION: + declare + Rate : constant CXF2002_1.Money_Radix10 := 0.37; + Period : constant Integer := 12; + Factor : CXF2002_1.Money_Radix10 := Rate / Period; + + Initial : constant CXF2002_1.Money_Radix10 := 459.33; + Trunc_Expected : constant CXF2002_1.Money_Radix10 := 3_259_305.54; + Round_Expected : constant CXF2002_1.Money_Radix10 := 3_260_544.11; + + Balance : CXF2002_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Truncate (Balance, Factor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 10 multiply and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Round (Balance, Factor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 10 multiply and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_10_MULTIPLICATION; + + + RADIX_10_DIVISION: + declare + Rate : constant CXF2002_1.Money_Radix10 := 0.15; + Period : constant Integer := 12; + Factor : CXF2002_1.Money_Radix10 := Rate / Period; + Divisor : constant CXF2002_1.Money_Radix10 := 1.0 / Factor; + + Initial : constant CXF2002_1.Money_Radix10 := 29_842.08; + Trunc_Expected : constant CXF2002_1.Money_Radix10 := 590_519.47; + Round_Expected : constant CXF2002_1.Money_Radix10 := 590_528.98; + + Balance : CXF2002_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Truncate (Balance, Divisor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 10 divide and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Round (Balance, Divisor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 10 divide and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_10_DIVISION; + + end RADIX_10_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end CXF2002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,363 ---- + -- CXF2003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the multiplying operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- Check the case where the two operands are of different decimal + -- fixed point types. + -- + -- Check that if the mathematical result is between multiples of the + -- small of the result type, the result is truncated toward zero. + -- Check that if the attribute 'Round is applied to the mathematical + -- result, however, the result is rounded to the nearest multiple of + -- the small (away from zero if the result is midway between two + -- multiples of the small). + -- + -- TEST DESCRIPTION: + -- Two decimal fixed point types A and B are declared, one with a + -- Machine_Radix value of 2, and one with a value of 10. A third decimal + -- fixed point type C is declared with digits and delta values different + -- from those of A and B. For type A (and B), checks are performed + -- on the following operations, where one operand type is C, and the + -- other operand type and the result type is A (or B): + -- + -- - Multiplication. + -- - Multiplication, where the attribute 'Round is applied to the + -- result. + -- - Division. + -- - Division, where the attribute 'Round is applied to the result. + -- + -- Each operation is performed within a loop, where one operand is + -- always the same variable. After the loop completes, the cumulative + -- total contained in this variable is compared with the expected + -- result. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 22 Mar 96 SAIC Prerelease version for ACVC 2.1. + -- + --! + + generic + type Decimal_Fixed_1 is delta <> digits <>; + type Decimal_Fixed_2 is delta <> digits <>; + package CXF2003_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1; + Factor : in Decimal_Fixed_2); + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1; + Divisor : in Decimal_Fixed_2); + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1; + Factor : in Decimal_Fixed_2); + + procedure Divide_And_Round (Balance : in out Decimal_Fixed_1; + Divisor : in Decimal_Fixed_2); + + end CXF2003_0; + + + --==================================================================-- + + + package body CXF2003_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed_1; + Factor : in Decimal_Fixed_2) is + Interest : Decimal_Fixed_1; + begin + Interest := Factor * Balance; -- Fixed-fixed multiplication. + Balance := Balance + Interest; + end Multiply_And_Truncate; + + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed_1; + Divisor : in Decimal_Fixed_2) is + Interest : Decimal_Fixed_1; + begin + Interest := Balance / Divisor; -- Fixed-fixed division. + Balance := Balance + Interest; + end Divide_And_Truncate; + + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed_1; + Factor : in Decimal_Fixed_2) is + Interest : Decimal_Fixed_1; + begin + -- Fixed-fixed multiplication. + Interest := Decimal_Fixed_1'Round ( Factor * Balance ); + Balance := Balance + Interest; + end Multiply_And_Round; + + + procedure Divide_And_Round (Balance : in out Decimal_Fixed_1; + Divisor : in Decimal_Fixed_2) is + Interest : Decimal_Fixed_1; + begin + -- Fixed-fixed division. + Interest := Decimal_Fixed_1'Round ( Balance / Divisor ); + Balance := Balance + Interest; + end Divide_And_Round; + + end CXF2003_0; + + + --==================================================================-- + + + package CXF2003_1 is + + type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 + + + type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 + + + type Interest_Rate is delta 0.00001 digits 9; -- range -9999.99999 .. + -- +9999.99999 + + end CXF2003_1; + + + --==================================================================-- + + + with CXF2003_0; + with CXF2003_1; + + with Report; + procedure CXF2003 is + + Loop_Count : constant := 1825; + type Loop_Range is range 1 .. Loop_Count; + + begin + + Report.Test ("CXF2003", "Check decimal multiplication and division, and " & + "'Round, where the operand types are different"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_2_SUBTESTS: + declare + package Radix_2 is new CXF2003_0 (CXF2003_1.Money_Radix2, + CXF2003_1.Interest_Rate); + use type CXF2003_1.Money_Radix2; + use type CXF2003_1.Interest_Rate; + begin + + RADIX_2_MULTIPLICATION: + declare + Rate : CXF2003_1.Interest_Rate := 0.198; + Period : Integer := 365; + Factor : CXF2003_1.Interest_Rate := Rate / Period; + + Initial : constant CXF2003_1.Money_Radix2 := 1_000.00; + Trunc_Expected : constant CXF2003_1.Money_Radix2 := 2_662.94; + Round_Expected : constant CXF2003_1.Money_Radix2 := 2_678.34; + + Balance : CXF2003_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Truncate (Balance, Factor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 2 multiply and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Round (Balance, Factor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 2 multiply and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_2_MULTIPLICATION; + + + RADIX_2_DIVISION: + declare + Rate : CXF2003_1.Interest_Rate := 0.129; + Period : Integer := 365; + Factor : CXF2003_1.Interest_Rate := Rate / Period; + Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor; + + Initial : constant CXF2003_1.Money_Radix2 := 14_626.52; + Trunc_Expected : constant CXF2003_1.Money_Radix2 := 27_688.26; + Round_Expected : constant CXF2003_1.Money_Radix2 := 27_701.12; + + Balance : CXF2003_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Truncate (Balance, Divisor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 2 divide and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Round (Balance, Divisor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 2 divide and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_2_DIVISION; + + end RADIX_2_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_10_SUBTESTS: + declare + package Radix_10 is new CXF2003_0 (CXF2003_1.Money_Radix10, + CXF2003_1.Interest_Rate); + use type CXF2003_1.Money_Radix10; + use type CXF2003_1.Interest_Rate; + begin + + RADIX_10_MULTIPLICATION: + declare + Rate : CXF2003_1.Interest_Rate := 0.063; + Period : Integer := 365; + Factor : CXF2003_1.Interest_Rate := Rate / Period; + + Initial : constant CXF2003_1.Money_Radix10 := 314_036.10; + Trunc_Expected : constant CXF2003_1.Money_Radix10 := 428_249.48; + Round_Expected : constant CXF2003_1.Money_Radix10 := 428_260.52; + + Balance : CXF2003_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Truncate (Balance, Factor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 10 multiply and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Round (Balance, Factor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 10 multiply and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_10_MULTIPLICATION; + + + RADIX_10_DIVISION: + declare + Rate : CXF2003_1.Interest_Rate := 0.273; + Period : Integer := 365; + Factor : CXF2003_1.Interest_Rate := Rate / Period; + Divisor : CXF2003_1.Interest_Rate := 1.0 / Factor; + + Initial : constant CXF2003_1.Money_Radix10 := 25.72; + Trunc_Expected : constant CXF2003_1.Money_Radix10 := 79.05; + Round_Expected : constant CXF2003_1.Money_Radix10 := 97.46; + + Balance : CXF2003_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Truncate (Balance, Divisor); + end loop; + + if Balance /= Trunc_Expected then + Report.Failed ("Wrong result: Radix 10 divide and truncate"); + end if; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Round (Balance, Divisor); + end loop; + + if Balance /= Round_Expected then + Report.Failed ("Wrong result: Radix 10 divide and round"); + end if; + + ---=---=---=---=---=---=--- + end RADIX_10_DIVISION; + + end RADIX_10_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end CXF2003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2004.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,513 ---- + -- CXF2004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the multiplying operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- Check the case where one operand is of an ordinary fixed point type. + -- + -- Check that if the mathematical result is between multiples of the + -- small of the result type, the result is truncated toward zero. + -- Check that if the attribute 'Round is applied to the mathematical + -- result, however, the result is rounded to the nearest multiple of + -- the small (away from zero if the result is midway between two + -- multiples of the small). + -- + -- TEST DESCRIPTION: + -- Two decimal fixed point types A and B are declared, one with a + -- Machine_Radix value of 2, and one with a value of 10. An ordinary + -- fixed point type C is declared with a delta value different from + -- those of A and B (although still a power of 10). For type A (and B), + -- checks are performed on the following operations, where one operand + -- type is C, and the other operand type and the result type is A (or B): + -- + -- - Multiplication. + -- - Multiplication, where the attribute 'Round is applied to the + -- result. + -- - Division. + -- - Division, where the attribute 'Round is applied to the result. + -- + -- Each operation is performed within a loop, where one operand is + -- always the same variable. After the loop completes, the cumulative + -- total contained in this variable is compared with the expected + -- result. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 22 Mar 96 SAIC Prerelease version for ACVC 2.1. + -- 11 Aug 96 SAIC ACVC 2.1: In RADIX_2_MULTIPLICATION, corrected + -- value of Rate. Corrected associated commentary. + -- + --! + + generic + type Decimal_Fixed is delta <> digits <>; + type Ordinary_Fixed is delta <>; + package CXF2004_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; + Factor : in Ordinary_Fixed); + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; + Divisor : in Ordinary_Fixed); + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed; + Factor : in Ordinary_Fixed); + + procedure Divide_And_Round (Balance : in out Decimal_Fixed; + Divisor : in Ordinary_Fixed); + + end CXF2004_0; + + + --==================================================================-- + + + package body CXF2004_0 is + + procedure Multiply_And_Truncate (Balance : in out Decimal_Fixed; + Factor : in Ordinary_Fixed) is + Interest : Decimal_Fixed; + begin + Interest := Factor * Balance; -- Fixed-fixed multiplication. + Balance := Balance + Interest; + end Multiply_And_Truncate; + + + procedure Divide_And_Truncate (Balance : in out Decimal_Fixed; + Divisor : in Ordinary_Fixed) is + Interest : Decimal_Fixed; + begin + Interest := Balance / Divisor; -- Fixed-fixed division. + Balance := Balance + Interest; + end Divide_And_Truncate; + + + procedure Multiply_And_Round (Balance : in out Decimal_Fixed; + Factor : in Ordinary_Fixed) is + Interest : Decimal_Fixed; + begin + -- Fixed-fixed multiplication. + Interest := Decimal_Fixed'Round ( Factor * Balance ); + Balance := Balance + Interest; + end Multiply_And_Round; + + + procedure Divide_And_Round (Balance : in out Decimal_Fixed; + Divisor : in Ordinary_Fixed) is + Interest : Decimal_Fixed; + begin + -- Fixed-fixed division. + Interest := Decimal_Fixed'Round ( Balance / Divisor ); + Balance := Balance + Interest; + end Divide_And_Round; + + end CXF2004_0; + + + --==================================================================-- + + + package CXF2004_1 is + + type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 + + + type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 + + + type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0; + for Interest_Rate'Small use 0.001; -- Power of 10. + + end CXF2004_1; + + + --==================================================================-- + + + with CXF2004_0; + with CXF2004_1; + + with Report; + procedure CXF2004 is + + Loop_Count : constant := 180; + type Loop_Range is range 1 .. Loop_Count; + + type Rounding_Scheme is ( Rounds, Truncates ); + Machine : Rounding_Scheme; + + begin + + Report.Test ("CXF2004", "Check decimal multiplication and division, and " & + "'Round, where one operand type is ordinary fixed"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + if CXF2004_1.Interest_Rate'Machine_Rounds then -- Determine machine's + Machine := Rounds; -- rounding scheme. + else + Machine := Truncates; + end if; + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_2_SUBTESTS: + declare + package Radix_2 is new CXF2004_0 (CXF2004_1.Money_Radix2, + CXF2004_1.Interest_Rate); + use type CXF2004_1.Money_Radix2; + use type CXF2004_1.Interest_Rate; + begin + + RADIX_2_MULTIPLICATION: + declare + Rate : constant CXF2004_1.Interest_Rate := 0.154; + Period : constant Integer := 12; + Factor : CXF2004_1.Interest_Rate := Rate / Period; + + -- The exact value of Factor is: + -- + -- 0.154/12 = 0.01283333... + -- + -- The adjacent multiples of small are 0.012 and 0.013. Since + -- Factor is of an ordinary fixed point type, it may contain either + -- of these values. However, since "Rate / Period" is a static + -- expression, the value Factor contains is determined by the + -- value of CXF2004_1.Interest_Rate'Machine_Rounds: + -- + -- If Machine_Rounds = FALSE : Factor = 0.012 + -- If Machine_Rounds = TRUE : Factor = 0.013 + + Initial : constant CXF2004_1.Money_Radix2 := 1_000.00; + + Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_557.07; + Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 8_560.47; + + Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_222.65; + Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 10_225.81; + + Balance : CXF2004_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Truncate (Balance, Factor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Trunc_Expected_MachRnds then + Report.Failed ("Error (R): Radix 2 multiply and truncate"); + end if; + when Truncates => + if Balance /= Trunc_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 2 multiply and truncate"); + end if; + end case; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Multiply_And_Round (Balance, Factor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Round_Expected_MachRnds then + Report.Failed ("Error (R): Radix 2 multiply and round"); + end if; + when Truncates => + if Balance /= Round_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 2 multiply and round"); + end if; + end case; + + ---=---=---=---=---=---=--- + end RADIX_2_MULTIPLICATION; + + + RADIX_2_DIVISION: + declare + Rate : constant CXF2004_1.Interest_Rate := 0.210; + Period : constant Integer := 12; + Factor : constant CXF2004_1.Interest_Rate := Rate / Period; + Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor; + + -- The exact value of Factor is: + -- + -- 0.210/12 = 0.0175 + -- + -- The adjacent multiples of small are 0.017 and 0.018. Since + -- Factor is of an ordinary fixed point type, it may contain either + -- of these values. However, since "Rate / Period" is a static + -- expression, the value Factor contains is determined by the + -- value of CXF2004_1.Interest_Rate'Machine_Rounds: + -- + -- If Machine_Rounds = FALSE : Factor = 0.017 + -- If Machine_Rounds = TRUE : Factor = 0.018 + -- + -- The exact value of Divisor is one of the following values: + -- + -- 1.0/0.017 = 58.82352... (Adjacent smalls 58.823 and 58.824) + -- 1.0/0.018 = 55.55555... (Adjacent smalls 55.555 and 55.556) + -- + -- Again, since "1.0 / Factor" is static, the value Divisor contains + -- is determined by the value of CXF2004_1.Interest_Rate'Rounds: + -- + -- If Machine_Rounds = FALSE : Divisor = 58.823 + -- If Machine_Rounds = TRUE : Divisor = 55.556 + + Initial : constant CXF2004_1.Money_Radix2 := 260.13; + + Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_401.46; + Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix2 := 5_406.95; + + Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_446.56; + Round_Expected_MachRnds: constant CXF2004_1.Money_Radix2 := 6_453.78; + + Balance : CXF2004_1.Money_Radix2; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Truncate (Balance, Divisor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Trunc_Expected_MachRnds then + Report.Failed ("Error (R): Radix 2 divide and truncate"); + end if; + when Truncates => + if Balance /= Trunc_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 2 divide and truncate"); + end if; + end case; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_2.Divide_And_Round (Balance, Divisor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Round_Expected_MachRnds then + Report.Failed ("Error (R): Radix 2 divide and round"); + end if; + when Truncates => + if Balance /= Round_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 2 divide and round"); + end if; + end case; + + ---=---=---=---=---=---=--- + end RADIX_2_DIVISION; + + end RADIX_2_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_10_SUBTESTS: + declare + package Radix_10 is new CXF2004_0 (CXF2004_1.Money_Radix10, + CXF2004_1.Interest_Rate); + use type CXF2004_1.Money_Radix10; + use type CXF2004_1.Interest_Rate; + begin + + RADIX_10_MULTIPLICATION: + declare + Rate : constant CXF2004_1.Interest_Rate := 0.095; + Period : constant Integer := 12; + Factor : CXF2004_1.Interest_Rate := Rate / Period; + + -- The exact value of Factor is: + -- + -- 0.095/12 = 0.00791666... + -- + -- The adjacent multiples of small are 0.007 and 0.008. Since + -- Factor is of an ordinary fixed point type, it may contain either + -- of these values. However, since "Rate / Period" is a static + -- expression, the value Factor contains can be determined based + -- on the value of CXF2004_1.Interest_Rate'Machine_Rounds: + -- + -- If Machine_Rounds = FALSE : Factor = 0.007 + -- If Machine_Rounds = TRUE : Factor = 0.008 + + Initial : constant CXF2004_1.Money_Radix10 := 2_125.00; + + Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_456.90; + Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 7_458.77; + + Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_915.74; + Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 8_917.84; + + Balance : CXF2004_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Truncate (Balance, Factor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Trunc_Expected_MachRnds then + Report.Failed ("Error (R): Radix 10 multiply and truncate"); + end if; + when Truncates => + if Balance /= Trunc_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 10 multiply and truncate"); + end if; + end case; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Multiply_And_Round (Balance, Factor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Round_Expected_MachRnds then + Report.Failed ("Error (R): Radix 10 multiply and round"); + end if; + when Truncates => + if Balance /= Round_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 10 multiply and round"); + end if; + end case; + + ---=---=---=---=---=---=--- + end RADIX_10_MULTIPLICATION; + + + RADIX_10_DIVISION: + declare + Rate : constant CXF2004_1.Interest_Rate := 0.295; + Period : constant Integer := 12; + Factor : constant CXF2004_1.Interest_Rate := Rate / Period; + Divisor : CXF2004_1.Interest_Rate := 1.0 / Factor; + + -- The exact value of Factor is: + -- + -- 0.295/12 = 0.02458333... + -- + -- The adjacent multiples of small are 0.024 and 0.025. Thus, the + -- exact value of Divisor is one of the following: + -- + -- 1.0/0.024 = 41.66666... (Adjacent smalls 41.666 and 41.667) + -- 1.0/0.025 = 40.0 + -- + -- The value of CXF2004_1.Interest_Rate'Machine_Rounds determines + -- what Divisor contains: + -- + -- If Machine_Rounds = FALSE : Divisor = 41.666 + -- If Machine_Rounds = TRUE : Divisor = 40.000 + + Initial : constant CXF2004_1.Money_Radix10 := 72.19; + + Trunc_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_144.60; + Round_Expected_MachTrnc: constant CXF2004_1.Money_Radix10 := 5_157.80; + + Trunc_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_133.28; + Round_Expected_MachRnds: constant CXF2004_1.Money_Radix10 := 6_149.06; + + Balance : CXF2004_1.Money_Radix10; + begin + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Truncate (Balance, Divisor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Trunc_Expected_MachRnds then + Report.Failed ("Error (R): Radix 10 divide and truncate"); + end if; + when Truncates => + if Balance /= Trunc_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 10 divide and truncate"); + end if; + end case; + + ---=---=---=---=---=---=--- + + Balance := Initial; + + for I in Loop_Range loop + Radix_10.Divide_And_Round (Balance, Divisor); + end loop; + + case (Machine) is + when Rounds => + if Balance /= Round_Expected_MachRnds then + Report.Failed ("Error (R): Radix 10 divide and round"); + end if; + when Truncates => + if Balance /= Round_Expected_MachTrnc then + Report.Failed ("Error (T): Radix 10 divide and round"); + end if; + end case; + + ---=---=---=---=---=---=--- + end RADIX_10_DIVISION; + + end RADIX_10_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end CXF2004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2005.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,293 ---- + -- CXF2005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the multiplying operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- Check the case where one operand is of the predefined type Integer. + -- + -- TEST DESCRIPTION: + -- Two decimal fixed point types A and B are declared, one with a + -- Machine_Radix value of 2, and one with a value of 10. A variable of + -- each type is multiplied repeatedly by a series of different Integer + -- values. A cumulative result is kept and compared to an expected + -- final result. Similar checks are performed for division. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 28 Mar 96 SAIC Prerelease version for ACVC 2.1. + -- + --! + + generic + type Decimal_Fixed is delta <> digits <>; + package CXF2005_0 is + + function Multiply (Operand : Decimal_Fixed; + Interval : Integer) return Decimal_Fixed; + + function Divide (Operand : Decimal_Fixed; + Interval : Integer) return Decimal_Fixed; + + end CXF2005_0; + + + --==================================================================-- + + + package body CXF2005_0 is + + function Multiply (Operand : Decimal_Fixed; + Interval : Integer) return Decimal_Fixed is + begin + return Operand * Interval; -- Fixed-Integer multiplication. + end Multiply; + + + function Divide (Operand : Decimal_Fixed; + Interval : Integer) return Decimal_Fixed is + begin + return Operand / Interval; -- Fixed-Integer division. + end Divide; + + end CXF2005_0; + + + --==================================================================-- + + + package CXF2005_1 is + + ---=---=---=---=---=---=---=---=---=---=--- + + type Interest_Rate is delta 0.001 range 0.0 .. 1_000.0; + for Interest_Rate'Small use 0.001; -- Power of 10. + + ---=---=---=---=---=---=---=---=---=---=--- + + type Money_Radix2 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix2'Machine_Radix use 2; -- +999,999,999.99 + + function Factor (Rate : Interest_Rate; + Interval : Integer) return Money_Radix2; + + ---=---=---=---=---=---=---=---=---=---=--- + + type Money_Radix10 is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money_Radix10'Machine_Radix use 10; -- +999,999,999.99 + + function Factor (Rate : Interest_Rate; + Interval : Integer) return Money_Radix10; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2005_1; + + + --==================================================================-- + + + package body CXF2005_1 is + + ---=---=---=---=---=---=---=---=---=---=--- + + function Factor (Rate : Interest_Rate; + Interval : Integer) return Money_Radix2 is + begin + return Money_Radix2( Rate / Interval ); + end Factor; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Factor (Rate : Interest_Rate; + Interval : Integer) return Money_Radix10 is + begin + return Money_Radix10( Rate / Interval ); + end Factor; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2005_1; + + + --==================================================================-- + + + with CXF2005_0; + with CXF2005_1; + + with Report; + procedure CXF2005 is + + Loop_Count : constant := 25_000; + type Loop_Range is range 1 .. Loop_Count; + + begin + + Report.Test ("CXF2005", "Check decimal multiplication and division, " & + "where one operand type is Integer"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_2_SUBTESTS: + declare + package Radix_2 is new CXF2005_0 (CXF2005_1.Money_Radix2); + use type CXF2005_1.Money_Radix2; + begin + + RADIX_2_MULTIPLICATION: + declare + Rate : constant CXF2005_1.Interest_Rate := 0.127; + Period : constant Integer := 12; + + Expected : constant CXF2005_1.Money_Radix2 := 2_624.88; + Balance : CXF2005_1.Money_Radix2 := 1_000.00; + + Operand : CXF2005_1.Money_Radix2; + Increment : CXF2005_1.Money_Radix2; + Interval : Integer; + begin + + for I in Loop_Range loop + Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12. + Operand := CXF2005_1.Factor (Rate, Period); + Increment := Radix_2.Multiply (Operand, Interval); + Balance := Balance + Increment; + end loop; + + if Balance /= Expected then + Report.Failed ("Error: Radix 2 multiply"); + end if; + + end RADIX_2_MULTIPLICATION; + + + + RADIX_2_DIVISION: + declare + Rate : constant CXF2005_1.Interest_Rate := 0.377; + Period : constant Integer := 12; + + Expected : constant CXF2005_1.Money_Radix2 := 36_215.58; + Balance : CXF2005_1.Money_Radix2 := 456_985.01; + + Operand : CXF2005_1.Money_Radix2; + Increment : CXF2005_1.Money_Radix2; + Interval : Integer; + begin + + for I in Loop_Range loop + Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400. + Operand := CXF2005_1.Factor (Rate, Period); + Increment := Radix_2.Divide (Balance, Interval); + Balance := Balance - (Operand * Increment); + end loop; + + if Balance /= Expected then + Report.Failed ("Error: Radix 2 divide"); + end if; + + end RADIX_2_DIVISION; + + end RADIX_2_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + RADIX_10_SUBTESTS: + declare + package Radix_10 is new CXF2005_0 (CXF2005_1.Money_Radix10); + use type CXF2005_1.Money_Radix10; + begin + + RADIX_10_MULTIPLICATION: + declare + Rate : constant CXF2005_1.Interest_Rate := 0.721; + Period : constant Integer := 12; + + Expected : constant CXF2005_1.Money_Radix10 := 9_875.62; + Balance : CXF2005_1.Money_Radix10 := 126.34; + + Operand : CXF2005_1.Money_Radix10; + Increment : CXF2005_1.Money_Radix10; + Interval : Integer; + begin + + for I in Loop_Range loop + Interval := (Integer(I) mod Period) + 1; -- Range from 1 to 12. + Operand := CXF2005_1.Factor (Rate, Period); + Increment := Radix_10.Multiply (Operand, Interval); + Balance := Balance + Increment; + end loop; + + if Balance /= Expected then + Report.Failed ("Error: Radix 10 multiply"); + end if; + + end RADIX_10_MULTIPLICATION; + + + RADIX_10_DIVISION: + declare + Rate : constant CXF2005_1.Interest_Rate := 0.547; + Period : constant Integer := 12; + + Expected : constant CXF2005_1.Money_Radix10 := 26_116.37; + Balance : CXF2005_1.Money_Radix10 := 770_082.46; + + Operand : CXF2005_1.Money_Radix10; + Increment : CXF2005_1.Money_Radix10; + Interval : Integer; + begin + + for I in Loop_Range loop + Interval := (Integer(I+1000) mod (200*Period)) + 1; -- 1 .. 2400. + Operand := CXF2005_1.Factor (Rate, Period); + Increment := Radix_10.Divide (Balance, Interval); + Balance := Balance - (Operand * Increment); + end loop; + + if Balance /= Expected then + Report.Failed ("Error: Radix 10 divide"); + end if; + + end RADIX_10_DIVISION; + + end RADIX_10_SUBTESTS; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end CXF2005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2a01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,448 ---- + -- CXF2A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the binary adding operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- + -- TEST DESCRIPTION: + -- The test verifies that decimal addition and subtraction behave as + -- expected for types with various digits, delta, and Machine_Radix + -- values. Types with the minimum values for Decimal.Max_Digits and + -- Decimal.Max_Scale (18) are included. + -- + -- Two kinds of checks are performed for each type. In the first check, + -- the iteration, operation, and operand counts in the foundation and + -- the operation tables in this test are given values such that, when the + -- operations loop is complete, each operand will have been added to and + -- subtracted from the loop's cumulator variable the same number of times, + -- albeit in varying order. Thus, the result returned by the operations + -- loop should have the same value as that used to initialize the + -- cumulator (in this test, zero). + -- + -- In the second check, the same operation (addition for some types and + -- subtraction for others) is performed during each loop iteration, + -- resulting in a cumulative total which is checked against an expected + -- value. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF2A00.A + -- -> CXF2A01.A + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 08 Apr 96 SAIC Prerelease version for ACVC 2.1. + -- + --! + + package CXF2A01_0 is + + ---=---=---=---=---=---=---=---=---=---=--- + + type Micro is delta 10.0**(-18) digits 18; -- range -0.999999999999999999 .. + for Micro'Machine_Radix use 10; -- +0.999999999999999999 + + function Add (Left, Right : Micro) return Micro; + function Subtract (Left, Right : Micro) return Micro; + + + type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro; + + Micro_Add : Micro_Optr_Ptr := Add'Access; + Micro_Sub : Micro_Optr_Ptr := Subtract'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + type Money is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Money'Machine_Radix use 2; -- +999,999,999.99 + + function Add (Left, Right : Money) return Money; + function Subtract (Left, Right : Money) return Money; + + + type Money_Optr_Ptr is access function (Left, Right : Money) return Money; + + Money_Add : Money_Optr_Ptr := Add'Access; + Money_Sub : Money_Optr_Ptr := Subtract'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + -- Same as Money, but with Radix 10: + + type Cash is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Cash'Machine_Radix use 10; -- +999,999,999.99 + + function Add (Left, Right : Cash) return Cash; + function Subtract (Left, Right : Cash) return Cash; + + + type Cash_Optr_Ptr is access function (Left, Right : Cash) return Cash; + + Cash_Add : Cash_Optr_Ptr := Add'Access; + Cash_Sub : Cash_Optr_Ptr := Subtract'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + type Broad is delta 10.0**(-9) digits 18; -- range -999,999,999.999999999 .. + for Broad'Machine_Radix use 10; -- +999,999,999.999999999 + + function Add (Left, Right : Broad) return Broad; + function Subtract (Left, Right : Broad) return Broad; + + + type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad; + + Broad_Add : Broad_Optr_Ptr := Add'Access; + Broad_Sub : Broad_Optr_Ptr := Subtract'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A01_0; + + + --==================================================================-- + + + package body CXF2A01_0 is + + ---=---=---=---=---=---=---=---=---=---=--- + + function Add (Left, Right : Micro) return Micro is + begin + return (Left + Right); -- Decimal fixed addition. + end Add; + + function Subtract (Left, Right : Micro) return Micro is + begin + return (Left - Right); -- Decimal fixed subtraction. + end Subtract; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Add (Left, Right : Money) return Money is + begin + return (Left + Right); -- Decimal fixed addition. + end Add; + + function Subtract (Left, Right : Money) return Money is + begin + return (Left - Right); -- Decimal fixed subtraction. + end Subtract; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Add (Left, Right : Cash) return Cash is + begin + return (Left + Right); -- Decimal fixed addition. + end Add; + + function Subtract (Left, Right : Cash) return Cash is + begin + return (Left - Right); -- Decimal fixed subtraction. + end Subtract; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Add (Left, Right : Broad) return Broad is + begin + return (Left + Right); -- Decimal fixed addition. + end Add; + + function Subtract (Left, Right : Broad) return Broad is + begin + return (Left - Right); -- Decimal fixed subtraction. + end Subtract; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A01_0; + + + --==================================================================-- + + + with FXF2A00; + package CXF2A01_0.CXF2A01_1 is + + ---=---=---=---=---=---=---=---=---=---=--- + + type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr; + type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro; + + Micro_Optr_Table_Cancel : Micro_Ops := ( Micro_Add, Micro_Sub, + Micro_Add, Micro_Sub, + Micro_Add, Micro_Sub ); + + Micro_Optr_Table_Cumul : Micro_Ops := ( others => Micro_Add ); + + Micro_Opnd_Table_Cancel : Micro_Opnds := ( 0.001025000235111997, + 0.000000000000000003, + 0.724902903219925400, + 0.000459228020000011, + 0.049832104921096533 ); + + Micro_Opnd_Table_Cumul : Micro_Opnds := ( 0.000002309540000000, + 0.000000278060000000, + 0.000000000000070000, + 0.000010003000000000, + 0.000000023090000000 ); + + function Test_Micro_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Micro, + Operator_Ptr => Micro_Optr_Ptr, + Operator_Table => Micro_Ops, + Operand_Table => Micro_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + type Money_Ops is array (FXF2A00.Optr_Range) of Money_Optr_Ptr; + type Money_Opnds is array (FXF2A00.Opnd_Range) of Money; + + Money_Optr_Table_Cancel : Money_Ops := ( Money_Add, Money_Add, + Money_Sub, Money_Add, + Money_Sub, Money_Sub ); + + Money_Optr_Table_Cumul : Money_Ops := ( others => Money_Sub ); + + Money_Opnd_Table_Cancel : Money_Opnds := ( 127.10, + 5600.44, + 0.05, + 189662.78, + 226900402.99 ); + + Money_Opnd_Table_Cumul : Money_Opnds := ( 17.99, + 500.41, + 92.78, + 0.38, + 2942.99 ); + + function Test_Money_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Money, + Operator_Ptr => Money_Optr_Ptr, + Operator_Table => Money_Ops, + Operand_Table => Money_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + type Cash_Ops is array (FXF2A00.Optr_Range) of Cash_Optr_Ptr; + type Cash_Opnds is array (FXF2A00.Opnd_Range) of Cash; + + Cash_Optr_Table_Cancel : Cash_Ops := ( Cash_Add, Cash_Add, + Cash_Sub, Cash_Add, + Cash_Sub, Cash_Sub ); + + Cash_Optr_Table_Cumul : Cash_Ops := ( others => Cash_Add ); + + Cash_Opnd_Table_Cancel : Cash_Opnds := ( 127.10, + 5600.44, + 0.05, + 189662.78, + 226900402.99 ); + + Cash_Opnd_Table_Cumul : Cash_Opnds := ( 3.33, + 100056.14, + 22.87, + 3901.55, + 111.21 ); + + function Test_Cash_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Cash, + Operator_Ptr => Cash_Optr_Ptr, + Operator_Table => Cash_Ops, + Operand_Table => Cash_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr; + type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad; + + Broad_Optr_Table_Cancel : Broad_Ops := ( Broad_Sub, Broad_Add, + Broad_Add, Broad_Sub, + Broad_Sub, Broad_Add ); + + Broad_Optr_Table_Cumul : Broad_Ops := ( others => Broad_Sub ); + + Broad_Opnd_Table_Cancel : Broad_Opnds := ( 1.000009092, + 732919479.445022293, + 89662.787000006, + 660.101010133, + 1121127.999905594 ); + + Broad_Opnd_Table_Cumul : Broad_Opnds := ( 12.000450223, + 479.430320780, + 0.003492096, + 8.112888400, + 1002.994937800 ); + + function Test_Broad_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Broad, + Operator_Ptr => Broad_Optr_Ptr, + Operator_Table => Broad_Ops, + Operand_Table => Broad_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A01_0.CXF2A01_1; + + + --==================================================================-- + + + with CXF2A01_0.CXF2A01_1; + + with Report; + procedure CXF2A01 is + package Data renames CXF2A01_0.CXF2A01_1; + + use type CXF2A01_0.Micro; + use type CXF2A01_0.Money; + use type CXF2A01_0.Cash; + use type CXF2A01_0.Broad; + + Micro_Cancel_Expected : constant CXF2A01_0.Micro := 0.0; + Money_Cancel_Expected : constant CXF2A01_0.Money := 0.0; + Cash_Cancel_Expected : constant CXF2A01_0.Cash := 0.0; + Broad_Cancel_Expected : constant CXF2A01_0.Broad := 0.0; + + Micro_Cumul_Expected : constant CXF2A01_0.Micro := 0.075682140420000000; + Money_Cumul_Expected : constant CXF2A01_0.Money := -21327300.00; + Cash_Cumul_Expected : constant CXF2A01_0.Cash := 624570600.00; + Broad_Cumul_Expected : constant CXF2A01_0.Broad := -9015252.535794000; + + Micro_Actual : CXF2A01_0.Micro; + Money_Actual : CXF2A01_0.Money; + Cash_Actual : CXF2A01_0.Cash; + Broad_Actual : CXF2A01_0.Broad; + begin + + Report.Test ("CXF2A01", "Check decimal addition and subtraction"); + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Micro_Actual := Data.Test_Micro_Ops (0.0, + Data.Micro_Optr_Table_Cancel, + Data.Micro_Opnd_Table_Cancel); + + if Micro_Actual /= Micro_Cancel_Expected then + Report.Failed ("Wrong cancellation result for type Micro"); + end if; + + ---=---=---=---=---=---=--- + + + Micro_Actual := Data.Test_Micro_Ops (0.0, + Data.Micro_Optr_Table_Cumul, + Data.Micro_Opnd_Table_Cumul); + + if Micro_Actual /= Micro_Cumul_Expected then + Report.Failed ("Wrong cumulation result for type Micro"); + end if; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Money_Actual := Data.Test_Money_Ops (0.0, + Data.Money_Optr_Table_Cancel, + Data.Money_Opnd_Table_Cancel); + + if Money_Actual /= Money_Cancel_Expected then + Report.Failed ("Wrong cancellation result for type Money"); + end if; + + ---=---=---=---=---=---=--- + + + Money_Actual := Data.Test_Money_Ops (0.0, + Data.Money_Optr_Table_Cumul, + Data.Money_Opnd_Table_Cumul); + + if Money_Actual /= Money_Cumul_Expected then + Report.Failed ("Wrong cumulation result for type Money"); + end if; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Cash_Actual := Data.Test_Cash_Ops (0.0, + Data.Cash_Optr_Table_Cancel, + Data.Cash_Opnd_Table_Cancel); + + if Cash_Actual /= Cash_Cancel_Expected then + Report.Failed ("Wrong cancellation result for type Cash"); + end if; + + + ---=---=---=---=---=---=--- + + + Cash_Actual := Data.Test_Cash_Ops (0.0, + Data.Cash_Optr_Table_Cumul, + Data.Cash_Opnd_Table_Cumul); + + if Cash_Actual /= Cash_Cumul_Expected then + Report.Failed ("Wrong cumulation result for type Cash"); + end if; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Broad_Actual := Data.Test_Broad_Ops (0.0, + Data.Broad_Optr_Table_Cancel, + Data.Broad_Opnd_Table_Cancel); + + if Broad_Actual /= Broad_Cancel_Expected then + Report.Failed ("Wrong cancellation result for type Broad"); + end if; + + + ---=---=---=---=---=---=--- + + + Broad_Actual := Data.Test_Broad_Ops (0.0, + Data.Broad_Optr_Table_Cumul, + Data.Broad_Opnd_Table_Cumul); + + if Broad_Actual /= Broad_Cumul_Expected then + Report.Failed ("Wrong cumulation result for type Broad"); + end if; + + + ---=---=---=---=---=---=---=---=---=---=--- + + + Report.Result; + + end CXF2A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf2a02.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,354 ---- + -- CXF2A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the multiplying operators for a decimal fixed point type + -- return values that are integral multiples of the small of the type. + -- Check the case where the operand and result types are the same. + -- + -- Check that if the mathematical result is between multiples of the + -- small of the result type, the result is truncated toward zero. + -- + -- TEST DESCRIPTION: + -- The test verifies that decimal multiplication and division behave as + -- expected for types with various digits, delta, and Machine_Radix + -- values. + -- + -- The iteration, operation, and operand counts in the foundation, and + -- the operations and operand tables in the test, are given values such + -- that, when the operations loop is complete, truncation of inexact + -- results should cause the result returned by the operations loop to be + -- the same as that used to initialize the loop's cumulator variable (in + -- this test, one). + -- + -- TEST FILES: + -- This test consists of the following files: + -- + -- FXF2A00.A + -- -> CXF2A02.A + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Information Systems Annex. + -- + -- + -- CHANGE HISTORY: + -- 13 Mar 96 SAIC Prerelease version for ACVC 2.1. + -- 04 Aug 96 SAIC Updated prologue. + -- + --! + + package CXF2A02_0 is + + ---=---=---=---=---=---=---=---=---=---=--- + + type Micro is delta 10.0**(-5) digits 6; -- range -9.99999 .. + for Micro'Machine_Radix use 2; -- +9.99999 + + function Multiply (Left, Right : Micro) return Micro; + function Divide (Left, Right : Micro) return Micro; + + + type Micro_Optr_Ptr is access function (Left, Right : Micro) return Micro; + + Micro_Mult : Micro_Optr_Ptr := Multiply'Access; + Micro_Div : Micro_Optr_Ptr := Divide'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + type Basic is delta 0.01 digits 11; -- range -999,999,999.99 .. + for Basic'Machine_Radix use 10; -- +999,999,999.99 + + function Multiply (Left, Right : Basic) return Basic; + function Divide (Left, Right : Basic) return Basic; + + + type Basic_Optr_Ptr is access function (Left, Right : Basic) return Basic; + + Basic_Mult : Basic_Optr_Ptr := Multiply'Access; + Basic_Div : Basic_Optr_Ptr := Divide'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + type Broad is delta 10.0**(-3) digits 10; -- range -9,999,999.999 .. + for Broad'Machine_Radix use 2; -- +9,999,999.999 + + function Multiply (Left, Right : Broad) return Broad; + function Divide (Left, Right : Broad) return Broad; + + + type Broad_Optr_Ptr is access function (Left, Right : Broad) return Broad; + + Broad_Mult : Broad_Optr_Ptr := Multiply'Access; + Broad_Div : Broad_Optr_Ptr := Divide'Access; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A02_0; + + + --==================================================================-- + + + package body CXF2A02_0 is + + ---=---=---=---=---=---=---=---=---=---=--- + + function Multiply (Left, Right : Micro) return Micro is + begin + return (Left * Right); -- Decimal fixed multiplication. + end Multiply; + + function Divide (Left, Right : Micro) return Micro is + begin + return (Left / Right); -- Decimal fixed division. + end Divide; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Multiply (Left, Right : Basic) return Basic is + begin + return (Left * Right); -- Decimal fixed multiplication. + end Multiply; + + function Divide (Left, Right : Basic) return Basic is + begin + return (Left / Right); -- Decimal fixed division. + end Divide; + + ---=---=---=---=---=---=---=---=---=---=--- + + function Multiply (Left, Right : Broad) return Broad is + begin + return (Left * Right); -- Decimal fixed multiplication. + end Multiply; + + function Divide (Left, Right : Broad) return Broad is + begin + return (Left / Right); -- Decimal fixed division. + end Divide; + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A02_0; + + + --==================================================================-- + + + with FXF2A00; + package CXF2A02_0.CXF2A02_1 is + + ---=---=---=---=---=---=---=---=---=---=--- + + type Micro_Ops is array (FXF2A00.Optr_Range) of Micro_Optr_Ptr; + type Micro_Opnds is array (FXF2A00.Opnd_Range) of Micro; + + Micro_Mult_Operator_Table : Micro_Ops := ( Micro_Mult, Micro_Mult, + Micro_Mult, Micro_Mult, + Micro_Mult, Micro_Mult ); + + Micro_Div_Operator_Table : Micro_Ops := ( Micro_Div, Micro_Div, + Micro_Div, Micro_Div, + Micro_Div, Micro_Div ); + + Micro_Mult_Operand_Table : Micro_Opnds := ( 2.35119, + 0.05892, + 9.58122, + 0.80613, + 0.93462 ); + + Micro_Div_Operand_Table : Micro_Opnds := ( 0.58739, + 4.90012, + 0.08765, + 0.71577, + 5.53768 ); + + function Test_Micro_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Micro, + Operator_Ptr => Micro_Optr_Ptr, + Operator_Table => Micro_Ops, + Operand_Table => Micro_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + type Basic_Ops is array (FXF2A00.Optr_Range) of Basic_Optr_Ptr; + type Basic_Opnds is array (FXF2A00.Opnd_Range) of Basic; + + Basic_Mult_Operator_Table : Basic_Ops := ( Basic_Mult, Basic_Mult, + Basic_Mult, Basic_Mult, + Basic_Mult, Basic_Mult ); + + Basic_Div_Operator_Table : Basic_Ops := ( Basic_Div, Basic_Div, + Basic_Div, Basic_Div, + Basic_Div, Basic_Div ); + + Basic_Mult_Operand_Table : Basic_Opnds := ( 127.10, + 0.02, + 0.87, + 45.67, + 0.01 ); + + Basic_Div_Operand_Table : Basic_Opnds := ( 0.03, + 0.08, + 23.57, + 0.11, + 159.11 ); + + function Test_Basic_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Basic, + Operator_Ptr => Basic_Optr_Ptr, + Operator_Table => Basic_Ops, + Operand_Table => Basic_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + type Broad_Ops is array (FXF2A00.Optr_Range) of Broad_Optr_Ptr; + type Broad_Opnds is array (FXF2A00.Opnd_Range) of Broad; + + Broad_Mult_Operator_Table : Broad_Ops := ( Broad_Mult, Broad_Mult, + Broad_Mult, Broad_Mult, + Broad_Mult, Broad_Mult ); + + Broad_Div_Operator_Table : Broad_Ops := ( Broad_Div, Broad_Div, + Broad_Div, Broad_Div, + Broad_Div, Broad_Div ); + + Broad_Mult_Operand_Table : Broad_Opnds := ( 589.720, + 0.106, + 21.018, + 0.002, + 0.381 ); + + Broad_Div_Operand_Table : Broad_Opnds := ( 0.008, + 0.793, + 9.092, + 214.300, + 0.080 ); + + function Test_Broad_Ops is new FXF2A00.Operations_Loop + (Decimal_Fixed => Broad, + Operator_Ptr => Broad_Optr_Ptr, + Operator_Table => Broad_Ops, + Operand_Table => Broad_Opnds); + + ---=---=---=---=---=---=---=---=---=---=--- + + end CXF2A02_0.CXF2A02_1; + + + --==================================================================-- + + + with CXF2A02_0.CXF2A02_1; + + with Report; + procedure CXF2A02 is + package Data renames CXF2A02_0.CXF2A02_1; + + use type CXF2A02_0.Micro; + use type CXF2A02_0.Basic; + use type CXF2A02_0.Broad; + + Micro_Expected : constant CXF2A02_0.Micro := 1.0; + Basic_Expected : constant CXF2A02_0.Basic := 1.0; + Broad_Expected : constant CXF2A02_0.Broad := 1.0; + + Micro_Actual : CXF2A02_0.Micro; + Basic_Actual : CXF2A02_0.Basic; + Broad_Actual : CXF2A02_0.Broad; + begin + + Report.Test ("CXF2A02", "Check decimal multiplication and division, " & + "where the operand and result types are the same"); + + ---=---=---=---=---=---=---=---=---=---=--- + + Micro_Actual := 0.0; + Micro_Actual := Data.Test_Micro_Ops (1.0, + Data.Micro_Mult_Operator_Table, + Data.Micro_Mult_Operand_Table); + + if Micro_Actual /= Micro_Expected then + Report.Failed ("Wrong result for type Micro multiplication"); + end if; + + + Micro_Actual := 0.0; + Micro_Actual := Data.Test_Micro_Ops (1.0, + Data.Micro_Div_Operator_Table, + Data.Micro_Div_Operand_Table); + + if Micro_Actual /= Micro_Expected then + Report.Failed ("Wrong result for type Micro division"); + end if; + + ---=---=---=---=---=---=---=---=---=---=--- + + Basic_Actual := 0.0; + Basic_Actual := Data.Test_Basic_Ops (1.0, + Data.Basic_Mult_Operator_Table, + Data.Basic_Mult_Operand_Table); + + if Basic_Actual /= Basic_Expected then + Report.Failed ("Wrong result for type Basic multiplication"); + end if; + + + Basic_Actual := 0.0; + Basic_Actual := Data.Test_Basic_Ops (1.0, + Data.Basic_Div_Operator_Table, + Data.Basic_Div_Operand_Table); + + if Basic_Actual /= Basic_Expected then + Report.Failed ("Wrong result for type Basic division"); + end if; + + ---=---=---=---=---=---=---=---=---=---=--- + + Broad_Actual := 0.0; + Broad_Actual := Data.Test_Broad_Ops (1.0, + Data.Broad_Mult_Operator_Table, + Data.Broad_Mult_Operand_Table); + + if Broad_Actual /= Broad_Expected then + Report.Failed ("Wrong result for type Broad multiplication"); + end if; + + + Broad_Actual := 0.0; + Broad_Actual := Data.Test_Broad_Ops (1.0, + Data.Broad_Div_Operator_Table, + Data.Broad_Div_Operand_Table); + + if Broad_Actual /= Broad_Expected then + Report.Failed ("Wrong result for type Broad division"); + end if; + + ---=---=---=---=---=---=---=---=---=---=--- + + Report.Result; + + end CXF2A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3001.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,192 ---- + -- CXF3001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the edited output string value returned by Function Image + -- is correct. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. + -- + -- Each picture string is checked for validity, and an invalid picture + -- string will cause immediate test failure on its first pass through + -- the evaluation loop. Inside the evaluation loop, each decimal data + -- item is combined with each of the picture strings as parameters to a + -- call to Image, and the result of each call is compared to an + -- expected edited output result string. + -- + -- + -- CHANGE HISTORY: + -- 24 Feb 95 SAIC Initial prerelease version. + -- 23 Jun 95 SAIC Corrected call to functions Valid and To_Picture. + -- 22 Aug 95 SAIC Test name changed to CXF3001 (from CXF3301) to + -- conform to naming conventions. + -- 24 Feb 97 CTA.PWB Corrected picture strings and expected results. + --! + + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3001 is + begin + + Report.Test ("CXF3001", "Check that the string value returned by " & + "Function Image is correct"); + + Test_Block: + declare + + use Ada.Text_IO; + + Number_Of_Decimal_Items : constant := 5; + Number_Of_Picture_Strings : constant := 4; + Number_Of_Expected_Results : constant := Number_Of_Decimal_Items * + Number_Of_Picture_Strings; + + type String_Pointer_Type is access String; + + -- Define a decimal data type, and instantiate the Decimal_Output + -- generic package for the data type. + + type Decimal_Data_Type is delta 0.01 digits 16; + package Ed_Out is new Editing.Decimal_Output (Decimal_Data_Type); + + -- Define types for the arrays of data that will hold the decimal data + -- values, picture strings, and expected edited output results. + + type Decimal_Data_Array_Type is + array (Integer range <>) of Decimal_Data_Type; + + type Picture_String_Array_Type is + array (Integer range <>) of String_Pointer_Type; + + type Edited_Output_Results_Array_Type is + array (Integer range <>) of String_Pointer_Type; + + -- Define the data arrays for this test. + + Decimal_Data : + Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) := + ( 1 => 5678.90, + 2 => -6789.01, + 3 => 0.00, + 4 => 0.20, + 5 => 3.45 + ); + + Picture_Strings : + Picture_String_Array_Type(1..Number_Of_Picture_Strings) := + ( 1 => new String'("-$$_$$9.99"), + 2 => new String'("-$$_$$$.$$"), + 3 => new String'("-ZZZZ.ZZ"), + 4 => new String'("-$$$_999.99") + ); + + Edited_Output : + Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) := + ( 1 => new String'(" $5,678.90"), + 2 => new String'(" $5,678.90"), + 3 => new String'(" 5678.90"), + 4 => new String'(" $5,678.90"), + + 5 => new String'("-$6,789.01"), + 6 => new String'("-$6,789.01"), + 7 => new String'("-6789.01"), + 8 => new String'("- $6,789.01"), + + 9 => new String'(" $0.00"), + 10 => new String'(" "), + 11 => new String'(" "), + 12 => new String'(" $ 000.00"), + + 13 => new String'(" $0.20"), + 14 => new String'(" $.20"), + 15 => new String'(" .20"), + 16 => new String'(" $ 000.20"), + + 17 => new String'(" $3.45"), + 18 => new String'(" $3.45"), + 19 => new String'(" 3.45"), + 20 => new String'(" $ 003.45") + ); + + TC_Picture : Editing.Picture; + TC_Loop_Count : Natural := 0; + + begin + + -- Compare string result of Image with expected edited output string. + + Evaluate_Edited_Output: + for i in 1..Number_Of_Decimal_Items loop + for j in 1..Number_Of_Picture_Strings loop + + TC_Loop_Count := TC_Loop_Count + 1; + + -- Check on the validity of the picture strings prior to + -- processing. + + if Editing.Valid(Picture_Strings(j).all) then + + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(Picture_Strings(j).all); + + -- Compare actual edited output result of Function Image with + -- the expected result. + + if Ed_Out.Image(Decimal_Data(i), TC_Picture) /= + Edited_Output(TC_Loop_Count).all + then + Report.Failed("Incorrect result from Function Image, " & + "when used with decimal data item # " & + Integer'Image(i) & + " and picture string # " & + Integer'Image(j)); + end if; + + else + Report.Failed("Picture String # " & Integer'Image(j) & + "reported as being invalid"); + -- Immediate test failure if a string is invalid. + exit Evaluate_Edited_Output; + end if; + + end loop; + end loop Evaluate_Edited_Output; + + exception + when Editing.Picture_Error => + Report.Failed ("Picture_Error raised in Test_Block"); + when Layout_Error => + Report.Failed ("Layout_Error raised in Test_Block"); + when others => + Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3002.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,231 ---- + -- CXF3002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the functionality contained in package + -- Ada.Wide_Text_IO.Editing is available and produces correct results. + -- + -- TEST DESCRIPTION: + -- This test is designed to validate the procedures and functions that + -- are found in package Ada.Wide_Text_IO.Editing, the "wide" + -- complementary package to Ada.Text_IO.Editing. The test is similar + -- to CXF3301, which tested a large portion of the Ada.Text_IO.Editing + -- package. Additional testing has been added here to cover the balance + -- of the Wide_Text_IO.Editing child package. + + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. + -- + -- Each picture string is checked for validity, and an invalid picture + -- string will cause immediate test failure on its first pass through + -- the evaluation loop. Inside the evaluation loop, each decimal data + -- item is combined with each of the picture strings as parameters to a + -- call to Image, and the result of each call is compared to an + -- expected edited output result string. + -- + -- Note: Each of the functions Valid, To_Picture, and Pic_String has + -- String (rather than Wide_String) as its parameter or result + -- subtype, since a picture String is not localizable. + -- + -- + -- CHANGE HISTORY: + -- 22 Jun 95 SAIC Initial prerelease version. + -- 22 Aug 95 SAIC Test name changed to CXF3002 (from CXF3401) to + -- conform with naming conventions. + -- 24 Feb 97 PWB.CTA Corrected picture strings and expected values. + --! + + with Ada.Wide_Text_IO.Editing; + with Report; + + procedure CXF3002 is + begin + + Report.Test ("CXF3002", "Check that the functionality contained " & + "in package Ada.Wide_Text_IO.Editing is " & + "available and produces correct results"); + + Test_Block: + declare + + use Ada.Wide_Text_IO; + + Number_Of_Decimal_Items : constant := 5; + Number_Of_Picture_Strings : constant := 4; + Number_Of_Expected_Results : constant := Number_Of_Decimal_Items * + Number_Of_Picture_Strings; + + Def_Cur : constant Wide_String := "$"; + Def_Fill : constant Wide_Character := '*'; + Def_Sep : constant Wide_Character := Editing.Default_Separator; + Def_Radix : constant Wide_Character := Editing.Default_Radix_Mark; + + type String_Pointer_Type is access String; + type Wide_String_Pointer_Type is access Wide_String; + + -- Define a decimal data type, and instantiate the Decimal_Output + -- generic package for the data type. + + type Decimal_Data_Type is delta 0.01 digits 16; + + package Wide_Ed_Out is + new Editing.Decimal_Output(Num => Decimal_Data_Type, + Default_Currency => Def_Cur, + Default_Fill => Def_Fill, + Default_Separator => Def_Sep, + Default_Radix_Mark => Def_Radix); + + -- Define types for the arrays of data that will hold the decimal data + -- values, picture strings, and expected edited output results. + + type Decimal_Data_Array_Type is + array (Integer range <>) of Decimal_Data_Type; + + type Picture_String_Array_Type is + array (Integer range <>) of String_Pointer_Type; + + type Edited_Output_Results_Array_Type is + array (Integer range <>) of Wide_String_Pointer_Type; + + -- Define the data arrays for this test. + + Decimal_Data : + Decimal_Data_Array_Type(1..Number_Of_Decimal_Items) := + ( 1 => 5678.90, + 2 => -6789.01, + 3 => 0.00, + 4 => 0.20, + 5 => 3.45 + ); + + Picture_Strings : + Picture_String_Array_Type(1..Number_Of_Picture_Strings) := + ( 1 => new String'("-$$_$$9.99"), + 2 => new String'("-$$_$$$.$$"), + 3 => new String'("-ZZZZ.ZZ"), + 4 => new String'("-$$$_999.99") + ); + + + Edited_Output : + Edited_Output_Results_Array_Type(1..Number_Of_Expected_Results) := + ( 1 => new Wide_String'(" $5,678.90"), + 2 => new Wide_String'(" $5,678.90"), + 3 => new Wide_String'(" 5678.90"), + 4 => new Wide_String'(" $5,678.90"), + + 5 => new Wide_String'("-$6,789.01"), + 6 => new Wide_String'("-$6,789.01"), + 7 => new Wide_String'("-6789.01"), + 8 => new Wide_String'("- $6,789.01"), + + 9 => new Wide_String'(" $0.00"), + 10 => new Wide_String'(" "), + 11 => new Wide_String'(" "), + 12 => new Wide_String'(" $ 000.00"), + + 13 => new Wide_String'(" $0.20"), + 14 => new Wide_String'(" $.20"), + 15 => new Wide_String'(" .20"), + 16 => new Wide_String'(" $ 000.20"), + + 17 => new Wide_String'(" $3.45"), + 18 => new Wide_String'(" $3.45"), + 19 => new Wide_String'(" 3.45"), + 20 => new Wide_String'(" $ 003.45") + ); + + TC_Picture : Editing.Picture; + TC_Loop_Count : Natural := 0; + + begin + + -- Compare string result of Image with expected edited output wide + -- string. + + Evaluate_Edited_Output: + for i in 1..Number_Of_Decimal_Items loop + for j in 1..Number_Of_Picture_Strings loop + + TC_Loop_Count := TC_Loop_Count + 1; + + -- Check on the validity of the picture strings prior to + -- processing. + + if Editing.Valid(Picture_Strings(j).all) then + + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(Picture_Strings(j).all); + + -- Check results of function Decimal_Output.Valid. + if not Wide_Ed_Out.Valid(Decimal_Data(i), TC_Picture) then + Report.Failed("Incorrect result from function Valid " & + "when examining the picture string that " & + "was produced from string " & + Integer'Image(j) & " in conjunction with " & + "decimal data item # " & Integer'Image(i)); + end if; + + -- Check results of function Editing.Pic_String. + if Editing.Pic_String(TC_Picture) /= Picture_Strings(j).all then + Report.Failed("Incorrect result from To_Picture/" & + "Pic_String conversion for picture " & + "string # " & Integer'Image(j)); + end if; + + -- Compare actual edited output result of Function Image with + -- the expected result. + + if Wide_Ed_Out.Image(Decimal_Data(i), TC_Picture) /= + Edited_Output(TC_Loop_Count).all + then + Report.Failed("Incorrect result from Function Image, " & + "when used with decimal data item # " & + Integer'Image(i) & + " and picture string # " & + Integer'Image(j)); + end if; + + else + Report.Failed("Picture String # " & Integer'Image(j) & + "reported as being invalid"); + end if; + + end loop; + end loop Evaluate_Edited_Output; + + exception + when Editing.Picture_Error => + Report.Failed ("Picture_Error raised in Test_Block"); + when Layout_Error => + Report.Failed ("Layout_Error raised in Test_Block"); + when others => + Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3003.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,292 ---- + -- CXF3003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that statically identifiable picture strings can be used to + -- produce correctly formatted edited output. + -- + -- TEST DESCRIPTION: + -- This test defines several picture strings that are statically + -- identifiable, (i.e., Pic : Picture := To_Picture("..."); ). + -- These picture strings are used in conjunction with decimal data + -- as parameters in calls to functions Valid and Image. These + -- functions are created by an instantiation of the generic package + -- Ada.Text_IO.Editing.Decimal_Output. + -- + -- + -- CHANGE HISTORY: + -- 04 Apr 96 SAIC Initial release for 2.1. + -- 13 Feb 97 PWB.CTA corrected incorrect picture strings. + --! + + with Report; + with Ada.Text_IO.Editing; + with Ada.Exceptions; + + procedure CXF3003 is + begin + + Report.Test ("CXF3003", "Check that statically identifiable " & + "picture strings can be used to produce " & + "correctly formatted edited output"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Text_IO.Editing; + + Def_Cur : constant String := "$"; + Def_Fill : constant Character := '*'; + Def_Sep : constant Character := Default_Separator; + Def_Radix : constant Character := + Ada.Text_IO.Editing.Default_Radix_Mark; + + type Str_Ptr is access String; + type Edited_Output_Array_Type is array (Integer range <>) of Str_Ptr; + + -- Define a decimal data type, and instantiate the Decimal_Output + -- generic package for the data type. + + type Decimal_Data_Type is delta 0.01 digits 16; + + package Image_IO is + new Decimal_Output(Num => Decimal_Data_Type, + Default_Currency => Def_Cur, + Default_Fill => '*', + Default_Separator => Default_Separator, + Default_Radix_Mark => Def_Radix); + + + type Decimal_Data_Array_Type is + array (Integer range <>) of Decimal_Data_Type; + + Decimal_Data : Decimal_Data_Array_Type(1..5) := + (1 => 1357.99, + 2 => -9029.01, + 3 => 0.00, + 4 => 0.20, + 5 => 3.45); + + -- Statically identifiable picture strings. + + Picture_1 : Picture := To_Picture("-$$_$$9.99"); + Picture_2 : Picture := To_Picture("-$$_$$$.$$"); + Picture_3 : Picture := To_Picture("-ZZZZ.ZZ"); + Picture_5 : Picture := To_Picture("-$$$_999.99"); + Picture_6 : Picture := To_Picture("-###**_***_**9.99"); + Picture_7 : Picture := To_Picture("-$**_***_**9.99"); + Picture_8 : Picture := To_Picture("-$$$$$$.$$"); + Picture_9 : Picture := To_Picture("-$$$$$$.$$"); + Picture_10 : Picture := To_Picture("+BBBZZ_ZZZ_ZZZ.ZZ"); + Picture_11 : Picture := To_Picture("--_---_---_--9"); + Picture_12 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); + Picture_14 : Picture := To_Picture("$_$$9.99"); + Picture_15 : Picture := To_Picture("$$9.99"); + + + Picture_1_Output : Edited_Output_Array_Type(1..5) := + ( 1 => new String'(" $1,357.99"), + 2 => new String'("-$9,029.01"), + 3 => new String'(" $0.00"), + 4 => new String'(" $0.20"), + 5 => new String'(" $3.45")); + + Picture_2_Output : Edited_Output_Array_Type(1..5) := + (1 => new String'(" $1,357.99"), + 2 => new String'("-$9,029.01"), + 3 => new String'(" "), + 4 => new String'(" $.20"), + 5 => new String'(" $3.45")); + + Picture_3_Output : Edited_Output_Array_Type(1..5) := + (1 => new String'(" 1357.99"), + 2 => new String'("-9029.01"), + 3 => new String'(" "), + 4 => new String'(" .20"), + 5 => new String'(" 3.45")); + + Picture_5_Output : Edited_Output_Array_Type(1..5) := + (1 => new String'(" $1,357.99"), + 2 => new String'("- $9,029.01"), + 3 => new String'(" $ 000.00"), + 4 => new String'(" $ 000.20"), + 5 => new String'(" $ 003.45")); + + begin + + -- Check the results of function Valid, using the first five decimal + -- data items and picture strings. + + if not Image_IO.Valid(Decimal_Data(1), Picture_1) then + Report.Failed("Picture string 1 not valid"); + elsif not Image_IO.Valid(Decimal_Data(2), Picture_2) then + Report.Failed("Picture string 2 not valid"); + elsif not Image_IO.Valid(Decimal_Data(3), Picture_3) then + Report.Failed("Picture string 3 not valid"); + elsif not Image_IO.Valid(Decimal_Data(5), Picture_5) then + Report.Failed("Picture string 5 not valid"); + end if; + + + -- Check the results of function Image, using the picture strings + -- constructed above, with a variety of named vs. positional + -- parameter notation and defaulted parameters. + + for i in 1..5 loop + if Image_IO.Image(Item => Decimal_Data(i), Pic => Picture_1) /= + Picture_1_Output(i).all + then + Report.Failed("Incorrect result from function Image with " & + "decimal data item #" & Integer'Image(i) & ", " & + "combined with Picture_1 picture string." & + "Expected: " & Picture_1_Output(i).all & ", " & + "Found: " & + Image_IO.Image(Decimal_Data(i),Picture_1)); + end if; + + if Image_IO.Image(Decimal_Data(i), Pic => Picture_2) /= + Picture_2_Output(i).all + then + Report.Failed("Incorrect result from function Image with " & + "decimal data item #" & Integer'Image(i) & ", " & + "combined with Picture_2 picture string." & + "Expected: " & Picture_2_Output(i).all & ", " & + "Found: " & + Image_IO.Image(Decimal_Data(i),Picture_2)); + end if; + + if Image_IO.Image(Decimal_Data(i), Picture_3) /= + Picture_3_Output(i).all + then + Report.Failed("Incorrect result from function Image with " & + "decimal data item #" & Integer'Image(i) & ", " & + "combined with Picture_3 picture string." & + "Expected: " & Picture_3_Output(i).all & ", " & + "Found: " & + Image_IO.Image(Decimal_Data(i),Picture_3)); + end if; + + if Image_IO.Image(Decimal_Data(i), Picture_5) /= + Picture_5_Output(i).all + then + Report.Failed("Incorrect result from function Image with " & + "decimal data item #" & Integer'Image(i) & ", " & + "combined with Picture_5 picture string." & + "Expected: " & Picture_5_Output(i).all & ", " & + "Found: " & + Image_IO.Image(Decimal_Data(i),Picture_5)); + end if; + end loop; + + + if Image_IO.Image(Item => 123456.78, + Pic => Picture_6, + Currency => "$", + Fill => Def_Fill, + Separator => Def_Sep, + Radix_Mark => Def_Radix) /= " $***123,456.78" + then + Report.Failed("Incorrect result from Fn. Image using Picture_6"); + end if; + + if Image_IO.Image(123456.78, + Pic => Picture_7, + Currency => Def_Cur, + Fill => '*', + Separator => Def_Sep, + Radix_Mark => Def_Radix) /= " $***123,456.78" + then + Report.Failed("Incorrect result from Fn. Image using Picture_7"); + end if; + + if Image_IO.Image(0.0, + Picture_8, + Currency => "$", + Fill => '*', + Separator => Def_Sep, + Radix_Mark => Def_Radix) /= " " + then + Report.Failed("Incorrect result from Fn. Image using Picture_8"); + end if; + + if Image_IO.Image(0.20, + Picture_9, + Def_Cur, + Fill => Def_Fill, + Separator => Default_Separator, + Radix_Mark => Default_Radix_Mark) /= " $.20" + then + Report.Failed("Incorrect result from Fn. Image using Picture_9"); + end if; + + if Image_IO.Image(123456.00, + Picture_10, + "$", + '*', + Separator => Def_Sep, + Radix_Mark => Def_Radix) /= "+ 123,456.00" + then + Report.Failed("Incorrect result from Fn. Image using Picture_10"); + end if; + + if Image_IO.Image(-123456.78, + Picture_11, + Default_Currency, + Default_Fill, + Default_Separator, + Radix_Mark => Def_Radix) /= " -123,457" + then + Report.Failed("Incorrect result from Fn. Image using Picture_11"); + end if; + + if Image_IO.Image(123456.78, Picture_12, "$", '*', ',', '.') /= + " $123,456.78" + then + Report.Failed("Incorrect result from Fn. Image using Picture_12"); + end if; + + if Image_IO.Image(1.23, + Picture_14, + Currency => Def_Cur, + Fill => Def_Fill) /= " $1.23" + then + Report.Failed("Incorrect result from Fn. Image using Picture_14"); + end if; + + if Image_IO.Image(12.34, Pic => Picture_15) /= "$12.34" + then + Report.Failed("Incorrect result from Fn. Image using Picture_15"); + end if; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXF3003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3004.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,257 ---- + -- CXF3004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that statically identifiable picture strings can be used + -- in conjunction with function Image to produce output strings + -- appropriate to foreign currency representations. + -- + -- Check that statically identifiable picture strings will cause + -- function Image to raise Layout_Error under the appropriate + -- conditions. + -- + -- TEST DESCRIPTION: + -- This test defines several picture strings that are statically + -- identifiable, (i.e., Pic : Picture := To_Picture("..."); ). + -- These picture strings are used in conjunction with decimal data + -- as parameters in calls to function Image. + -- + -- + -- CHANGE HISTORY: + -- 11 Apr 96 SAIC Initial release for 2.1. + -- + --! + + with Report; + with Ada.Text_IO.Editing; + with Ada.Exceptions; + + procedure CXF3004 is + begin + + Report.Test ("CXF3004", "Check that statically identifiable " & + "picture strings will cause function Image " & + "to raise Layout_Error under appropriate " & + "conditions"); + + Test_Block: + declare + + use Ada.Exceptions; + use Ada.Text_IO.Editing; + + FF_Currency : constant String := "FF"; + DM_Currency : constant String := "DM"; + FF_Separator : constant Character := '.'; + DM_Separator : constant Character := ','; + FF_Radix : constant Character := ','; + DM_Radix : constant Character := '.'; + Blank_Fill : constant Character := ' '; + Star_Fill : constant Character := '*'; + + + -- Define a decimal data type, and instantiate the Decimal_Output + -- generic package for the data type. + + type Decimal_Data_Type is delta 0.01 digits 16; + + package Image_IO is + new Decimal_Output(Num => Decimal_Data_Type, + Default_Currency => "$", + Default_Fill => Star_Fill, + Default_Separator => Default_Separator, + Default_Radix_Mark => DM_Radix); + + + + -- The following decimal data items are used with picture strings + -- in evaluating use of foreign currency symbols. + + Dec_Data_1 : Decimal_Data_Type := 123456.78; + Dec_Data_2 : Decimal_Data_Type := 32.10; + Dec_Data_3 : Decimal_Data_Type := -1234.57; + Dec_Data_4 : Decimal_Data_Type := 123456.78; + Dec_Data_5 : Decimal_Data_Type := 12.34; + Dec_Data_6 : Decimal_Data_Type := 12.34; + Dec_Data_7 : Decimal_Data_Type := 12345.67; + + + -- Statically identifiable picture strings. + -- These strings are used in conjunction with non-default values + -- for Currency string, Radix mark, and Separator in calls to + -- function Image. + + Picture_1 : Picture := To_Picture("-###**_***_**9.99"); -- FF + Picture_2 : Picture := To_Picture("###z_ZZ9.99"); -- FF + Picture_3 : Picture := To_Picture("<<<<_<<<.<<###>"); -- DM + Picture_4 : Picture := To_Picture("-$_$$$_$$$_$$9.99"); -- DM + Picture_5 : Picture := To_Picture("$Zz9.99"); -- DM + Picture_6 : Picture := To_Picture("$$$9.99"); -- DM + Picture_7 : Picture := To_Picture("###_###_##9.99"); -- CHF + + + -- The following ten edited output strings correspond to the ten + -- foreign currency picture strings. + + Output_1 : constant String := " FF***123.456,78"; + Output_2 : constant String := " FF 32,10"; + Output_3 : constant String := " (1,234.57DM )"; + Output_4 : constant String := " DM123,456.78"; + Output_5 : constant String := "DM 12.34"; + Output_6 : constant String := " DM12.34"; + Output_7 : constant String := " CHF12,345.67"; + + + begin + + -- Check the results of function Image, using the picture strings + -- constructed above, in creating foreign currency edited output + -- strings. + + if Image_IO.Image(Item => Dec_Data_1, + Pic => Picture_1, + Currency => FF_Currency, + Fill => Star_Fill, + Separator => FF_Separator, + Radix_Mark => FF_Radix) /= Output_1 + then + Report.Failed("Incorrect result from Fn. Image using Picture_1"); + end if; + + if Image_IO.Image(Item => Dec_Data_2, + Pic => Picture_2, + Currency => FF_Currency, + Fill => Blank_Fill, + Separator => FF_Separator, + Radix_Mark => FF_Radix) /= Output_2 + then + Report.Failed("Incorrect result from Fn. Image using Picture_2"); + end if; + + if Image_IO.Image(Item => Dec_Data_3, + Pic => Picture_3, + Currency => DM_Currency, + Fill => Blank_Fill, + Separator => DM_Separator, + Radix_Mark => DM_Radix) /= Output_3 + then + Report.Failed("Incorrect result from Fn. Image using Picture_3"); + end if; + + if Image_IO.Image(Item => Dec_Data_4, + Pic => Picture_4, + Currency => DM_Currency, + Fill => Blank_Fill, + Separator => DM_Separator, + Radix_Mark => DM_Radix) /= Output_4 + then + Report.Failed("Incorrect result from Fn. Image using Picture_4"); + end if; + + if Image_IO.Image(Item => Dec_Data_5, + Pic => Picture_5, + Currency => DM_Currency, + Fill => Blank_Fill, + Separator => DM_Separator, + Radix_Mark => DM_Radix) /= Output_5 + then + Report.Failed("Incorrect result from Fn. Image using Picture_5"); + end if; + + if Image_IO.Image(Item => Dec_Data_6, + Pic => Picture_6, + Currency => DM_Currency, + Fill => Blank_Fill, + Separator => DM_Separator, + Radix_Mark => DM_Radix) /= Output_6 + then + Report.Failed("Incorrect result from Fn. Image using Picture_6"); + end if; + + if Image_IO.Image(Item => Dec_Data_7, + Pic => Picture_7, + Currency => "CHF", + Fill => Blank_Fill, + Separator => ',', + Radix_Mark => '.') /= Output_7 + then + Report.Failed("Incorrect result from Fn. Image using Picture_7"); + end if; + + + -- The following calls of Function Image, using the specific + -- decimal values and picture strings provided, will cause + -- a Layout_Error to be raised. + -- Note: The data and the picture strings used in the following + -- evaluations are not themselves erroneous, but when used in + -- combination will cause Layout_Error to be raised. + + Exception_Block_1 : + declare + Erroneous_Data_1 : Decimal_Data_Type := 12.34; + Erroneous_Picture_1 : Picture := To_Picture("9.99"); + N : constant Natural := Image_IO.Length(Erroneous_Picture_1); + TC_String : String(1..N); + begin + TC_String := Image_IO.Image(Erroneous_Data_1, Erroneous_Picture_1); + Report.Failed("Layout_Error not raised by combination of " & + "Erroneous_Picture_1 and Erroneous_Data_1"); + Report.Comment("Should never be printed: " & TC_String); + exception + when Ada.Text_IO.Layout_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed + ("The following exception was incorrectly raised in " & + "Exception_Block_1: " & Exception_Name(The_Error)); + end Exception_Block_1; + + Exception_Block_2 : + declare + Erroneous_Data_2 : Decimal_Data_Type := -12.34; + Erroneous_Picture_2 : Picture := To_Picture("99.99"); + N : constant Natural := Image_IO.Length(Erroneous_Picture_2); + TC_String : String(1..N); + begin + TC_String := Image_IO.Image(Erroneous_Data_2, Erroneous_Picture_2); + Report.Failed("Layout_Error not raised by combination of " & + "Erroneous_Picture_2 and Erroneous_Data_2"); + Report.Comment("Should never be printed: " & TC_String); + exception + when Ada.Text_IO.Layout_Error => null; -- OK, expected exception. + when The_Error : others => + Report.Failed + ("The following exception was incorrectly raised in " & + "Exception_Block_2: " & Exception_Name(The_Error)); + end Exception_Block_2; + + exception + when The_Error : others => + Report.Failed("The following exception was raised in the " & + "Test_Block: " & Exception_Name(The_Error)); + end Test_Block; + + Report.Result; + + end CXF3004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a01.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,167 ---- + -- CXF3A01.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Ada.Text_IO.Editing.Valid returns False if + -- a) Pic_String is not a well-formed Picture string, or + -- b) the length of Pic_String exceeds Max_Picture_Length, or + -- c) Blank_When_Zero is True and Pic_String contains '*'; + -- Check that Valid otherwise returns True. + -- + -- TEST DESCRIPTION: + -- This test validates the results of function Editing.Valid under a + -- variety of conditions. Both valid and invalid picture strings are + -- provided as input parameters to the function. The use of the + -- Blank_When_Zero parameter is evaluated with strings that contain the + -- zero suppression character '*'. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A01.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A01 is + begin + + Report.Test ("CXF3A01", "Check that the Valid function from package " & + "Ada.Text_IO.Editing returns False for strings " & + "that fail to comply with the composition " & + "constraints defined for picture strings. " & + "Check that the Valid function returns True " & + "for strings that conform to the composition " & + "constraints defined for picture strings"); + + Test_Block: + declare + use FXF3A00; + use Ada.Text_IO; + begin + + -- Use a series of picture strings that conform to the composition + -- constraints to validate the Ada.Text_IO.Editing.Valid function. + -- The result for each of these calls should be True. + -- In all the following cases, the default value of the Blank_When_Zero + -- parameter is used. + + for i in 1..FXF3A00.Number_Of_Valid_Strings loop + + if not Editing.Valid(Pic_String => FXF3A00.Valid_Strings(i).all) + then + Report.Failed("Incorrect result from Function Valid using " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end if; + + end loop; + + + for i in 1..FXF3A00.Number_Of_Foreign_Strings loop + + if not Editing.Valid(Pic_String => FXF3A00.Foreign_Strings(i).all) + then + Report.Failed("Incorrect result from Function Valid using " & + "Foreign_String = " & + FXF3A00.Foreign_Strings(i).all); + end if; + + end loop; + + + -- Use a series of picture strings that violate one or more of the + -- composition constraints to validate the Ada.Text_IO.Editing.Valid + -- function. The result for each of these calls should be False. + -- In all the following cases, the default value of the Blank_When_Zero + -- parameter is used. + + for i in 1..FXF3A00.Number_Of_Invalid_Strings loop + + if Editing.Valid(Pic_String => FXF3A00.Invalid_Strings(i).all) + then + Report.Failed("Incorrect result from Function Valid using " & + "Invalid_String = " & + FXF3A00.Invalid_Strings(i).all); + end if; + + end loop; + + + -- In all the following cases, the default value of the Blank_When_Zero + -- parameter is overridden with a True actual parameter value. Using + -- valid picture strings that contain the '*' zero suppression character + -- when this parameter value is True must result in a False result + -- from function Valid. Valid picture strings that do not contain the + -- '*' character should return a function result of True with True + -- provided as the actual parameter to Blank_When_Zero. + + -- Check entries 1, 2, 25, 36 from the Valid_Strings array, all of + -- which contain the '*' zero suppression character. + + if Editing.Valid(Valid_Strings(1).all, Blank_When_Zero => True) or + Editing.Valid(Valid_Strings(2).all, Blank_When_Zero => True) or + Editing.Valid(Valid_Strings(25).all, Blank_When_Zero => True) or + Editing.Valid(Valid_Strings(36).all, Blank_When_Zero => True) + then + Report.Failed + ("Incorrect result from Function Valid when setting " & + "the value of the Blank_When_Zero parameter to True, " & + "and using picture strings with the '*' character"); + end if; + + + -- Check entries from the Valid_Strings array, none of + -- which contain the '*' zero suppression character. + + for i in 3..24 loop + + if not Editing.Valid(Pic_String => Valid_Strings(i).all, + Blank_When_Zero => True) + then + Report.Failed("Incorrect result from Function Valid when " & + "setting the value of the Blank_When_Zero " & + "parameter to True, and using picture strings " & + "without the '*' character, Valid_String = " & + FXF3A00.Valid_Strings(i).all); + end if; + + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A01; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a02.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,267 ---- + -- CXF3A02.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the function Ada.Text_IO.Editing.To_Picture raises + -- Picture_Error if the picture string provided as input parameter does + -- not conform to the composition constraints defined for picture + -- strings. + -- Check that when Pic_String is applied to To_Picture, the result + -- is equivalent to the actual string parameter of To_Picture; + -- Check that when Blank_When_Zero is applied to To_Picture, the result + -- is the same value as the Blank_When_Zero parameter of To_Picture. + -- + -- TEST DESCRIPTION: + -- This test validates that function Editing.To_Picture returns a + -- Picture result when provided a valid picture string, and raises a + -- Picture_Error exception when provided an invalid picture string + -- input parameter. In addition, the Picture result of To_Picture is + -- converted back to a picture string value using function Pic_String, + -- and the result of function Blank_When_Zero is validated based on the + -- value of parameter Blank_When_Zero used in the formation of the Picture + -- by function To_Picture. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A02.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 11 Mar 97 PWB.CTA Corrected invalid picture string and uppercase + -- problem. + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Ada.Strings.Maps; + with Ada.Strings.Fixed; + with Report; + + procedure CXF3A02 is + + Lower_Alpha : constant String := "abcdefghijklmnopqrstuvwxyz"; + Upper_Alpha : constant String := "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; + function UpperCase ( Source : String ) return String is + begin + return + Ada.Strings.Fixed.Translate + ( Source => Source, + Mapping => Ada.Strings.Maps.To_Mapping + ( From => Lower_Alpha, + To => Upper_Alpha ) ); + end UpperCase; + + begin + + Report.Test ("CXF3A02", "Check that the function " & + "Ada.Text_IO.Editing.To_Picture raises " & + "Picture_Error if the picture string provided " & + "as input parameter does not conform to the " & + "composition constraints defined for picture " & + "strings"); + + Test_Block: + declare + + use Ada.Text_IO; + use FXF3A00; + + TC_Picture : Editing.Picture; + TC_Blank_When_Zero : Boolean; + + begin + + + -- Validate that function To_Picture does not raise Picture_Error when + -- provided a valid picture string as an input parameter. + + for i in 1..FXF3A00.Number_Of_Valid_Strings loop + begin + TC_Picture := + Editing.To_Picture(Pic_String => Valid_Strings(i).all, + Blank_When_Zero => False ); + exception + when Editing.Picture_Error => + Report.Failed + ("Picture_Error raised by function To_Picture " & + "with a valid picture string as input parameter, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + when others => + Report.Failed("Unexpected exception raised - 1, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end; + end loop; + + + + -- Validate that function To_Picture raises Picture_Error when an + -- invalid picture string is provided as an input parameter. + -- Default value used for parameter Blank_When_Zero. + + for i in 1..FXF3A00.Number_Of_Invalid_Strings loop + begin + TC_Picture := + Editing.To_Picture(Pic_String => FXF3A00.Invalid_Strings(i).all); + Report.Failed + ("Picture_Error not raised by function To_Picture " & + "with an invalid picture string as input parameter, " & + "Invalid_String = " & FXF3A00.Invalid_Strings(i).all); + exception + when Editing.Picture_Error => null; -- OK, expected exception. + when others => + Report.Failed("Unexpected exception raised, " & + "Invalid_String = " & + FXF3A00.Invalid_Strings(i).all); + end; + end loop; + + + + -- Validate that To_Picture and Pic_String/Blank_When_Zero provide + -- "inverse" results. + + -- Use the default value of the Blank_When_Zero parameter (False) for + -- these evaluations (some valid strings have the '*' zero suppression + -- character, which would result in an invalid string if used with a + -- True value for the Blank_When_Zero parameter). + + for i in 1..FXF3A00.Number_Of_Valid_Strings loop + begin + + -- Format a picture string using function To_Picture. + + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + -- Reconvert the Picture result from To_Picture to a string value + -- using function Pic_String, and compare to the original string. + + if Editing.Pic_String(Pic => TC_Picture) /= + Uppercase (FXF3A00.Valid_Strings(i).all) + then + Report.Failed + ("Inverse result incorrect from Editing.Pic_String, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end if; + + -- Ensure that function Blank_When_Zero returns the correct value + -- of the Blank_When_Zero parameter used in forming the Picture + -- (default parameter value False used in call to To_Picture + -- above). + + if Editing.Blank_When_Zero(Pic => TC_Picture) then + Report.Failed + ("Inverse result incorrect from Editing.Blank_When_Zero, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end if; + + exception + when others => + Report.Failed("Unexpected exception raised - 2, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end; + end loop; + + + -- Specifically check that any lower case letters in the original + -- picture string have been converted to upper case form following + -- the To_Picture/Pic_String conversion (as shown in previous loop). + + declare + The_Picture : Editing.Picture; + The_Picture_String : constant String := "+bBbZz_zZz_Zz9.99"; + The_Expected_Result : constant String := "+BBBZZ_ZZZ_ZZ9.99"; + begin + -- Convert Picture String to Picture. + The_Picture := Editing.To_Picture(Pic_String => The_Picture_String); + + declare + -- Reconvert the Picture to a Picture String. + The_Result : constant String := Editing.Pic_String(The_Picture); + begin + if The_Result /= The_Expected_Result then + Report.Failed("Conversion to Picture/Reconversion to String " & + "did not produce expected result when Picture " & + "String had lower case letters"); + end if; + end; + end; + + + -- Use a value of True for the Blank_When_Zero parameter for the + -- following evaluations (picture strings that do not have the '*' zero + -- suppression character, which would result in an invalid string when + -- used here with a True value for the Blank_When_Zero parameter). + + for i in 3..24 loop + begin + + -- Format a picture string using function To_Picture. + + TC_Picture := + Editing.To_Picture(Pic_String => Valid_Strings(i).all, + Blank_When_Zero => True); + + -- Reconvert the Picture result from To_Picture to a string value + -- using function Pic_String, and compare to the original string. + + if Editing.Pic_String(Pic => TC_Picture) /= + UpperCase (FXF3A00.Valid_Strings(i).all) + then + Report.Failed + ("Inverse result incorrect from Editing.Pic_String, used " & + "on Picture formed with parameter Blank_When_Zero = True, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end if; + + -- Ensure that function Blank_When_Zero returns the correct value + -- of the Blank_When_Zero parameter used in forming the Picture + -- (default parameter value False overridden in call to + -- To_Picture above). + + if not Editing.Blank_When_Zero(Pic => TC_Picture) then + Report.Failed + ("Inverse result incorrect from Editing.Blank_When_Zero, " & + "used on a Picture formed with parameter Blank_When_Zero " & + "= True, Valid_String = " & FXF3A00.Valid_Strings(i).all); + end if; + + exception + when others => + Report.Failed("Unexpected exception raised - 3, " & + "Valid_String = " & FXF3A00.Valid_Strings(i).all); + end; + end loop; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A02; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a03.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,429 ---- + -- CXF3A03.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that function Length in the generic package Decimal_Output + -- returns the number of characters in the edited output string + -- produced by function Image, for a particular decimal type, + -- currency string, and radix mark. + -- Check that function Valid in the generic package Decimal_Output + -- returns correct results based on the particular decimal value, + -- and the Picture and Currency string parameters. + -- + -- TEST DESCRIPTION: + -- This test uses two instantiations of package Decimal_Output, one + -- for decimal data with delta 0.01, the other for decimal data with + -- delta 1.0. The functions Length and Valid found in this generic + -- package are evaluated for each instantiation. + -- Function Length is examined with picture and currency string input + -- parameters of different sizes. + -- Function Valid is examined with a decimal type data item, picture + -- object, and currency string, for cases that are both valid and + -- invalid (Layout_Error would result from the particular items as + -- input parameters to function Image). + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A03.A + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A03 is + begin + + Report.Test ("CXF3A03", "Check that function Length returns the " & + "number of characters in the edited output " & + "string produced by function Image, for a " & + "particular decimal type, currency string, " & + "and radix mark. Check that function Valid " & + "returns correct results based on the " & + "particular decimal value, and the Picture " & + "and Currency string parameters"); + + Test_Block: + declare + + use Ada.Text_IO; + use FXF3A00; + + type Instantiation_Type is (NDP, TwoDP); + + -- Defaults used for all other generic parameters in these + -- instantiations. + package Pack_NDP is new Editing.Decimal_Output (Decimal_Type_NDP); + package Pack_2DP is new Editing.Decimal_Output (Decimal_Type_2DP); + + TC_Lower_Bound, + TC_Higher_Bound : Integer := 0; + + TC_Picture : Editing.Picture; + TC_US_String : constant String := "$"; + TC_FF_String : constant String := "FF"; + TC_DM_String : constant String := "DM"; + TC_CHF_String : constant String := "CHF"; + + + function Dollar_Sign_Present (Str : String) return Boolean is + begin + for i in 1..Str'Length loop + if Str(i) = '$' then + return True; + end if; + end loop; + return False; + end Dollar_Sign_Present; + + function V_Present (Str : String) return Boolean is + begin + for i in 1..Str'Length loop + if Str(i) = 'V' or Str(i) = 'v' then + return True; + end if; + end loop; + return False; + end V_Present; + + + function Accurate_Length (Pict_Str : String; + Inst : Instantiation_Type; + Currency_String : String) + return Boolean is + + TC_Length : Natural := 0; + TC_Currency_Length_Adjustment : Natural := 0; + TC_Radix_Adjustment : Natural := 0; + begin + + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(Pict_Str); + + -- Calculate the currency length adjustment. + if Dollar_Sign_Present (Editing.Pic_String(TC_Picture)) then + TC_Currency_Length_Adjustment := Currency_String'Length - 1; + end if; + + -- Calculate the Radix adjustment. + if V_Present (Editing.Pic_String(TC_Picture)) then + TC_Radix_Adjustment := 1; + end if; + + -- Calculate the length, using the version of Length that comes + -- from the appropriate instantiation of Decimal_Output, based + -- on the decimal type used in the instantiation. + if Inst = NDP then + TC_Length := Pack_NDP.Length(TC_Picture, + Currency_String); + else + TC_Length := Pack_2DP.Length(TC_Picture, + Currency_String); + end if; + + return TC_Length = Editing.Pic_String(TC_Picture)'Length + + TC_Currency_Length_Adjustment - + TC_Radix_Adjustment; + end Accurate_Length; + + + begin + + Length_Block: + begin + + -- The first 10 picture strings in the Valid_Strings array correspond + -- to data values of a decimal type with delta 0.01. + -- Note: The appropriate instantiation of the Decimal_Output package + -- (and therefore function Length) is used by function + -- Accurate_Length to calculate length. + + for i in 1..10 loop + if not Accurate_Length (FXF3A00.Valid_Strings(i).all, + TwoDP, + TC_US_String) + then + Report.Failed("Incorrect result from function Length, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_US_String & + " in evaluating picture string " & + FXF3A00.Valid_Strings(i).all ); + end if; + end loop; + + + -- Picture strings 17-20 in the Valid_Strings array correspond + -- to data values of a decimal type with delta 1.0. Again, the + -- instantiation of Decimal_Output used is based on this particular + -- decimal type. + + for i in 17..20 loop + if not Accurate_Length (FXF3A00.Valid_Strings(i).all, + NDP, + TC_US_String) + then + Report.Failed("Incorrect result from function Length, " & + "when used with a decimal type with delta 1.0 " & + "and with the currency string " & TC_US_String & + " in evaluating picture string " & + FXF3A00.Valid_Strings(i).all ); + end if; + end loop; + + + -- The first 4 picture strings in the Foreign_Strings array + -- correspond to data values of a decimal type with delta 0.01, + -- and to the currency string "FF" (two characters). + + for i in 1..FXF3A00.Number_of_FF_Strings loop + if not Accurate_Length (FXF3A00.Foreign_Strings(i).all, + TwoDP, + TC_FF_String) + then + Report.Failed("Incorrect result from function Length, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_FF_String & + " in evaluating picture string " & + FXF3A00.Foreign_Strings(i).all ); + end if; + end loop; + + + -- Picture strings 5-9 in the Foreign_Strings array correspond + -- to data values of a decimal type with delta 0.01, and to the + -- currency string "DM" (two characters). + + TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1; + TC_Higher_Bound := FXF3A00.Number_of_FF_Strings + + FXF3A00.Number_of_DM_Strings; + + for i in TC_Lower_Bound..TC_Higher_Bound loop + if not Accurate_Length (FXF3A00.Foreign_Strings(i).all, + TwoDP, + TC_DM_String) + then + Report.Failed("Incorrect result from function Length, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_DM_String & + " in evaluating picture string " & + FXF3A00.Foreign_Strings(i).all ); + end if; + end loop; + + + -- Picture string #10 in the Foreign_Strings array corresponds + -- to a data value of a decimal type with delta 0.01, and to the + -- currency string "CHF" (three characters). + + if not Accurate_Length (FXF3A00.Foreign_Strings(10).all, + TwoDP, + TC_CHF_String) + then + Report.Failed("Incorrect result from function Length, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & + TC_CHF_String); + end if; + + exception + when others => + Report.Failed("Unexpected exception raised in Length_Block"); + end Length_Block; + + + Valid_Block: + declare + + -- This offset value is used to align picture string and decimal + -- data values from package FXF3A00 for proper correspondence for + -- the evaluations below. + + TC_Offset : constant Natural := 10; + + begin + + -- The following four For Loops examine cases where the + -- decimal data/picture string/currency combinations used will + -- generate valid Edited Output strings. These combinations, when + -- provided to the Function Valid (from instantiations of + -- Decimal_Output), should result in a return result of True. + -- The particular instantiated version of Valid used in these loops + -- is that for decimal data with delta 0.01. + + -- The first 4 picture strings in the Foreign_Strings array + -- correspond to data values of a decimal type with delta 0.01, + -- and to the currency string "FF" (two characters). + + for i in 1..FXF3A00.Number_of_FF_Strings loop + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); + + if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i), + TC_Picture, + TC_FF_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_FF_String & + " in evaluating picture string " & + FXF3A00.Foreign_Strings(i).all ); + end if; + end loop; + + + -- Picture strings 5-9 in the Foreign_Strings array correspond + -- to data values of a decimal type with delta 0.01, and to the + -- currency string "DM" (two characters). + + TC_Lower_Bound := FXF3A00.Number_of_FF_Strings + 1; + TC_Higher_Bound := FXF3A00.Number_of_FF_Strings + + FXF3A00.Number_of_DM_Strings; + + for i in TC_Lower_Bound..TC_Higher_Bound loop + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); + + if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + i), + TC_Picture, + TC_DM_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_DM_String & + " in evaluating picture string " & + FXF3A00.Foreign_Strings(i).all ); + end if; + end loop; + + + -- Picture string #10 in the Foreign_Strings array corresponds + -- to a data value of a decimal type with delta 0.01, and to the + -- currency string "CHF" (three characters). + + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(FXF3A00.Foreign_Strings(10).all); + + if not Pack_2DP.Valid (FXF3A00.Data_With_2DP(TC_Offset + 10), + TC_Picture, + TC_CHF_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & + TC_CHF_String); + end if; + + + -- The following For Loop examines cases where the + -- decimal data/picture string/currency combinations used will + -- generate valid Edited Output strings. + -- The particular instantiated version of Valid used in this loop + -- is that for decimal data with delta 1.0; the others above have + -- been for decimal data with delta 0.01. + -- Note: TC_Offset is used here to align picture strings from the + -- FXF3A00.Valid_Strings table with the appropriate decimal + -- data in the FXF3A00.Data_With_NDP table. + + for i in 1..FXF3A00.Number_Of_NDP_Items loop + -- Create the picture object from the picture string. + TC_Picture := + Editing.To_Picture(FXF3A00.Valid_Strings(TC_Offset + i).all); + + if not Pack_NDP.Valid (FXF3A00.Data_With_NDP(i), + TC_Picture, + TC_US_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta .01 " & + "and with the currency string " & TC_US_String & + " in evaluating picture string " & + FXF3A00.Valid_Strings(i).all ); + end if; + end loop; + + + -- The following three evaluations of picture strings, used in + -- conjunction with the specific decimal values provided, will cause + -- Editing.Image to raise Layout_Error (to be examined in other + -- tests). Function Valid should return a False result for these + -- combinations. + -- The first two evaluations use the instantiation of Decimal_Output + -- with a decimal type with delta 0.01, while the last evaluation + -- uses the instantiation with decimal type with delta 1.0. + + for i in 1..FXF3A00.Number_of_Erroneous_Conditions loop + + -- Create the picture object from the picture string. + TC_Picture := + Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all); + + if i < 3 then -- Choose the appropriate instantiation. + if Pack_2DP.Valid(Item => FXF3A00.Erroneous_Data(i), + Pic => TC_Picture, + Currency => TC_US_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta " & + "0.01 and with the currency string " & + TC_US_String & + " in evaluating picture string " & + FXF3A00.Valid_Strings(i).all ); + end if; + else + if Pack_NDP.Valid(Item => FXF3A00.Decimal_Type_NDP( + FXF3A00.Erroneous_Data(i)), + Pic => TC_Picture, + Currency => TC_US_String) + then + Report.Failed("Incorrect result from function Valid, " & + "when used with a decimal type with delta " & + "1.0 and with the currency string " & + TC_US_String & + " in evaluating picture string " & + FXF3A00.Valid_Strings(i).all ); + end if; + end if; + end loop; + + exception + when others => + Report.Failed("Unexpected exception raised in Valid_Block"); + end Valid_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A03; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a04.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,293 ---- + -- CXF3A04.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the edited output string value returned by Function Image + -- is correct. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. These data tables are found in package FXF3A00. + -- + -- The results of the Image function are examined under a number of + -- circumstances. The generic package Decimal_Output is instantiated + -- twice, for decimal data with delta 0.01 and delta 1.0. Each version + -- of Image is called with both default parameters and user-provided + -- parameters. The results of each call to Image are compared to an + -- expected edited output result string. + -- + -- In addition, three calls to Image are designed to raise Layout_Error, + -- due to the combination of decimal value and picture string provided + -- as input parameters. If Layout_Error is not raised, or an alternate + -- exception is raised instead, test failure results. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A04.A + -- + -- + -- CHANGE HISTORY: + -- 22 JAN 95 SAIC Initial prerelease version. + -- 11 MAR 97 PWB.CTA Corrected incorrect index expression + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A04 is + begin + + Report.Test ("CXF3A04", "Check that the string value returned by " & + "Function Image is correct, based on the " & + "numerical data and picture formatting " & + "parameters provided to the function"); + + Test_Block: + declare + + use Ada.Text_IO; + + -- Instantiate the Decimal_Output generic package for the two data + -- types, using the default values for the Default_Currency, + -- Default_Fill, Default_Separator, and Default_Radix_Mark + -- parameters. + + package Pack_NDP is + new Editing.Decimal_Output (FXF3A00.Decimal_Type_NDP); + + package Pack_2DP is + new Editing.Decimal_Output (FXF3A00.Decimal_Type_2DP); + + TC_Currency : constant String := "$"; + TC_Fill : constant Character := '*'; + TC_Separator : constant Character := ','; + TC_Radix_Mark : constant Character := '.'; + + TC_Picture : Editing.Picture; + + + begin + + Two_Decimal_Place_Data: + -- Use a decimal fixed point type with delta 0.01 (two decimal places) + -- and valid picture strings. Evaluate the result of function Image + -- with the expected edited output result string. + declare + + TC_Loop_End : constant := -- 10 + FXF3A00.Number_Of_2DP_Items - FXF3A00.Number_Of_Foreign_Strings; + + begin + -- The first 10 picture strings in the Valid_Strings array + -- correspond to data values of a decimal type with delta 0.01. + + -- Compare string result of Image with expected edited output + -- string. Evaluate data using both default parameters of Image + -- and user-provided parameter values. + for i in 1..TC_Loop_End loop + + -- Create the picture object from the picture string. + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + -- Use the default parameters for this loop evaluation of Image. + if Pack_2DP.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect result from Function Image, " & + "when used with a decimal type with delta " & + "0.01, picture string " & + FXF3A00.Valid_Strings(i).all & + ", and the default parameters of Image"); + end if; + + -- Use user-provided parameters for this loop evaluation of Image. + + if Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => TC_Currency, + Fill => TC_Fill, + Separator => TC_Separator, + Radix_Mark => TC_Radix_Mark) /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect result from Function Image, " & + "when used with a decimal type with delta " & + "0.01, picture string " & + FXF3A00.Valid_Strings(i).all & + ", and user-provided parameters"); + end if; + + end loop; + + exception + when others => + Report.Failed("Exception raised in Two_Decimal_Place_Data block"); + end Two_Decimal_Place_Data; + + + + No_Decimal_Place_Data: + -- Use a decimal fixed point type with delta 1.00 (no decimal places) + -- and valid picture strings. Evaluate the result of function Image + -- with the expected result string. + declare + + use Editing, FXF3A00; + + TC_Offset : constant := 10; + TC_Loop_Start : constant := TC_Offset + 1; -- 11 + TC_Loop_End : constant := TC_Loop_Start + + Number_Of_NDP_Items - 1; -- 22 + + begin + -- The following evaluations correspond to data values of a + -- decimal type with delta 1.0. + + -- Compare string result of Image with expected edited output + -- string. Evaluate data using both default parameters of Image + -- and user-provided parameter values. + -- Note: TC_Offset is used to align corresponding data the various + -- data tables in foundation package FXF3A00. + + for i in TC_Loop_Start..TC_Loop_End loop + + -- Create the picture object from the picture string. + TC_Picture := To_Picture(Valid_Strings(i).all); + + -- Use the default parameters for this loop evaluation of Image. + if not (Pack_NDP.Image(Data_With_NDP(i-TC_Offset), TC_Picture) = + Edited_Output(TC_Offset+i).all) + then + Report.Failed("Incorrect result from Function Image, " & + "when used with a decimal type with delta " & + "1.0, picture string " & + Valid_Strings(i).all & + ", and the default parameters of Image"); + end if; + + -- Use user-provided parameters for this loop evaluation of Image. + if Pack_NDP.Image(Item => Data_With_NDP(i - TC_Offset), + Pic => TC_Picture, + Currency => TC_Currency, + Fill => TC_Fill, + Separator => TC_Separator, + Radix_Mark => TC_Radix_Mark) /= + Edited_Output(TC_Offset+i).all + then + Report.Failed("Incorrect result from Function Image, " & + "when used with a decimal type with delta " & + "1.0, picture string " & + Valid_Strings(i).all & + ", and user-provided parameters"); + end if; + + end loop; + + exception + when others => + Report.Failed("Exception raised in No_Decimal_Place_Data block"); + end No_Decimal_Place_Data; + + + + Exception_Block: + -- The following three calls of Function Image, using the specific + -- decimal values and picture strings provided, will cause + -- a Layout_Error to be raised. + -- The first two evaluations use the instantiation of Decimal_Output + -- with a decimal type with delta 0.01, while the last evaluation + -- uses the instantiation with decimal type with delta 1.0. + + -- Note: The data and the picture strings used in the following + -- evaluations are not themselves erroneous, but when used in + -- combination will cause Layout_Error to be raised. + + begin + + for i in 1..FXF3A00.Number_Of_Erroneous_Conditions loop -- 1..3 + begin + -- Create the picture object from the picture string. + TC_Picture := + Editing.To_Picture(FXF3A00.Erroneous_Strings(i).all); + + -- Layout_Error must be raised by the following calls to + -- Function Image. + + if i < 3 then -- Choose the appropriate instantiation. + declare + N : constant Natural := Pack_2DP.Length(TC_Picture); + TC_String : String(1..N); + begin + TC_String := Pack_2DP.Image(FXF3A00.Erroneous_Data(i), + TC_Picture); + end; + else + declare + use FXF3A00; + N : constant Natural := Pack_NDP.Length(TC_Picture, + TC_Currency); + TC_String : String(1..N); + begin + TC_String := + Pack_NDP.Image(Item => Decimal_Type_NDP( + Erroneous_Data(i)), + Pic => TC_Picture, + Currency => TC_Currency, + Fill => TC_Fill, + Separator => TC_Separator, + Radix_Mark => TC_Radix_Mark); + end; + end if; + + Report.Failed("Layout_Error not raised by combination " & + "# " & Integer'Image(i) & " " & + "of decimal data and picture string"); + + exception + when Layout_Error => null; -- Expected exception. + when others => + Report.Failed("Incorrect exception raised by combination " & + "# " & Integer'Image(i) & " " & + "of decimal data and picture string"); + end; + end loop; + + exception + when others => + Report.Failed("Unexpected exception raised in Exception_Block"); + end Exception_Block; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A04; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a05.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,266 ---- + -- CXF3A05.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Function Image produces correct results when provided + -- non-default parameters for Currency, Fill, Separator, and + -- Radix_Mark at either the time of package Decimal_Output instantiation, + -- or in a call to Image. Check non-default parameters that are + -- appropriate for foreign currency representations. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. These data tables are found in package FXF3A00. + -- + -- The results of the Image function, resulting from several different + -- instantiations of Decimal_Output, are compared with expected + -- edited output string results. The primary focus of this test is to + -- examine the effect of non-default parameters, provided during the + -- instantiation of package Decimal_Output, or provided as part of a + -- call to Function Image (that resulted from an instantiation of + -- Decimal_Output that used default parameters). The non-default + -- parameters provided correspond to foreign currency representations. + -- + -- For each picture string/decimal data combination examined, two + -- evaluations of Image are performed. These correspond to the two + -- methods of providing the appropriate non-default parameters described + -- above. Both forms of Function Image should produce the same expected + -- edited output string. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A05.A + -- + -- + -- CHANGE HISTORY: + -- 26 JAN 95 SAIC Initial prerelease version. + -- 17 FEB 97 PWB.CTA Correct array indices for Foreign_Strings array + -- references. + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A05 is + begin + + Report.Test ("CXF3A05", "Check that Function Image produces " & + "correct results when provided non-default " & + "parameters for Currency, Fill, Separator, " & + "and Radix_Mark, appropriate to foreign " & + "currency representations"); + + Test_Block: + declare + + use Ada.Text_IO; + + -- Instantiate the Decimal_Output generic package for the several + -- combinations of Default_Currency, Default_Fill, Default_Separator, + -- and Default_Radix_Mark. + + package Pack_Def is -- Uses default parameter values. + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); + + package Pack_FF is + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, + Default_Currency => "FF", + Default_Fill => '*', + Default_Separator => '.', + Default_Radix_Mark => ','); + + package Pack_DM is + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, + Default_Currency => "DM", + Default_Fill => '*', + Default_Separator => ',', + Default_Radix_Mark => '.'); + + package Pack_CHF is + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP, + Default_Currency => "CHF", + Default_Fill => '*', + Default_Separator => ',', + Default_Radix_Mark => '.'); + + + TC_Picture : Editing.Picture; + TC_Start_Loop : constant := 11; + TC_End_Loop : constant := TC_Start_Loop + -- 20 + FXF3A00.Number_Of_Foreign_Strings - 1; + + begin + + -- In the case of each particular type of foreign string examined, + -- two versions of Function Image are examined. First, a version of + -- the function that originated from an instantiation of Decimal_Output + -- with non-default parameters is checked. This version of Image is + -- called making use of default parameters in the actual function call. + -- In addition, a version of Function Image is checked that resulted + -- from an instantiation of Decimal_Output using default parameters, + -- but which uses non-default parameters in the function call. + + for i in TC_Start_Loop..TC_End_Loop loop + + -- Create the picture object from the picture string. + + TC_Picture := Editing.To_Picture + (FXF3A00.Foreign_Strings(i - TC_Start_Loop + 1).all); + + -- Based on the ordering of the specific foreign picture strings + -- in the FXF3A00.Foreign_Strings table, the following conditional + -- is used to determine which type of currency is being examined + -- as the loop executes. + + if i < TC_Start_Loop + FXF3A00.Number_Of_FF_Strings then -- (11-14) + -- Process the FF picture strings. + + -- Check the result of Function Image from an instantiation + -- of Decimal_Output that provided non-default actual + -- parameters at the time of package instantiation, and uses + -- default parameters in the call of Image. + + if Pack_FF.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture) /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with FF " & + "related parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all); + end if; + + -- Check the result of Function Image that originated from + -- an instantiation of Decimal_Output where default parameters + -- were used at the time of package Instantiation, but where + -- non-default parameters are provided in the call of Image. + + if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => "FF", + Fill => '*', + Separator => '.', + Radix_Mark => ',') /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with default " & + "parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all & + ", and FF related parameters in call to Image"); + end if; + + + elsif i < TC_Start_Loop + -- (15-19) + FXF3A00.Number_Of_FF_Strings + + FXF3A00.Number_Of_DM_Strings then + -- Process the DM picture strings. + + -- Non-default instantiation parameters, default function call + -- parameters. + + if Pack_DM.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture) /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with DM " & + "related parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all); + end if; + + -- Default instantiation parameters, non-default function call + -- parameters. + + if Pack_Def.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => "DM", + Fill => '*', + Separator => ',', + Radix_Mark => '.') /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with default " & + "parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all & + ", and DM related parameters in call to Image"); + end if; + + + else -- (i=20) + -- Process the CHF string. + + -- Non-default instantiation parameters, default function call + -- parameters. + + if Pack_CHF.Image(FXF3A00.Data_With_2DP(i), TC_Picture) /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with CHF " & + "related parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all); + end if; + + -- Default instantiation parameters, non-default function call + -- parameters. + + if Pack_Def.Image(FXF3A00.Data_With_2DP(i), + TC_Picture, + "CHF", + '*', + ',', + '.') /= + FXF3A00.Edited_Output(i).all + then + Report.Failed("Incorrect output from Function Image " & + "from package instantiated with default " & + "parameters, using picture string " & + FXF3A00.Foreign_Strings + (i - TC_Start_Loop + 1).all & + ", and CHF related parameters in call to Image"); + end if; + + end if; + + end loop; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A05; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a06.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,302 ---- + -- CXF3A06.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Text_IO.Editing.Put and Ada.Text_IO.Put have the same + -- effect. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. These data tables are found in package FXF3A00. + -- + -- The testing approach used in this test is that of writing edited + -- output data to a text file, using two different approaches. First, + -- Ada.Text_IO.Put is used, with a call to an instantiated version of + -- Function Image supplied as the actual for parameter Item. The + -- second approach is to use a version of Function Put from an + -- instantiation of Ada.Text_IO.Editing.Decimal_Output, with the + -- appropriate parameters for decimal data, picture, and format + -- specific parameters. A call to New_Line follows each Put, so that + -- each entry is placed on a separate line in the text file. + -- + -- Edited output for decimal data with two decimal places is in the + -- first loop, and once the data has been written to the file, the + -- text file is closed, then opened in In_File mode. The edited + -- output data is read from the file, and data on successive lines + -- is compared with the expected edited output result. The edited + -- output data produced by both of the Put procedures should be + -- identical. + -- + -- This process is repeated for decimal data with no decimal places. + -- The file is reopened in Append_File mode, and the edited output + -- data is added to the file in the same manner as described above. + -- The file is closed, and reopened to verify the data written. + -- The data written above (with two decimal places) is skipped, then + -- the data to be verified is extracted as above and verified against + -- the expected edited output string values. + -- + -- APPLICABILITY CRITERIA: + -- This test is applicable only to implementations that support + -- external text files. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A06.A + -- + -- + -- CHANGE HISTORY: + -- 26 JAN 95 SAIC Initial prerelease version. + -- 26 FEB 97 PWB.CTA Made input buffers sufficiently long + -- and removed code depending on shorter buffers + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A06 is + use Ada; + begin + + Report.Test ("CXF3A06", "Check that Ada.Text_IO.Editing.Put and " & + "Ada.Text_IO.Put have the same effect"); + + Test_for_Text_IO_Support: + declare + Text_File : Ada.Text_IO.File_Type; + Text_Filename : constant String := Report.Legal_File_Name(1); + begin + + -- Use_Error will be raised if Text_IO operations or external files + -- are not supported. + + Text_IO.Create (Text_File, Text_IO.Out_File, Text_Filename); + + Test_Block: + declare + use Ada.Text_IO; + + -- Instantiate the Decimal_Output generic package for two + -- different decimal data types. + + package Pack_2DP is -- Uses decimal type with delta 0.01. + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); + + package Pack_NDP is -- Uses decimal type with delta 1.0. + new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP, + Default_Currency => "$", + Default_Fill => '*', + Default_Separator => ',', + Default_Radix_Mark => '.'); + + TC_Picture : Editing.Picture; + TC_Start_Loop : constant := 1; + TC_End_Loop_1 : constant := FXF3A00.Number_Of_2DP_Items - -- 20-10 + FXF3A00.Number_Of_Foreign_Strings; + TC_End_Loop_2 : constant := FXF3A00.Number_Of_NDP_Items; -- 12 + TC_Offset : constant := FXF3A00.Number_Of_2DP_Items; -- 20 + + TC_String_1, TC_String_2 : String(1..255) := (others => ' '); + TC_Last_1, TC_Last_2 : Natural := 0; + + begin + + -- Use the two versions of Put, for data with two decimal points, + -- to write edited output strings to the text file. Use a separate + -- line for each string entry. + + for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10 + + -- Create the picture object from the picture string. + + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + -- Use the Text_IO version of Put to place an edited output + -- string into a text file. Use default parameters in the call + -- to Image for Currency, Fill, Separator, and Radix_Mark. + + Text_IO.Put(Text_File, + Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture)); + Text_IO.New_Line(Text_File); + + -- Use the version of Put from the instantiation of + -- Decimal_Output to place an edited output string on a separate + -- line of the Text_File. Use default parameters for Currency, + -- Fill, Separator, and Radix_Mark. + + Pack_2DP.Put(File => Text_File, + Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture); + Text_IO.New_Line(Text_File); + + end loop; + + Text_IO.Close(Text_File); + + -- Reopen the text file in In_File mode, and verify the edited + -- output found on consecutive lines of the file. + + Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename); + + for i in TC_Start_Loop..TC_End_Loop_1 loop + -- Read successive lines in the text file. + Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1); + Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2); + + -- Compare the two strings for equality with the expected edited + -- output result. Failure results if strings don't match, or if + -- a reading error occurred from the attempted Get_Line resulting + -- from an improperly formed edited output string. + + if TC_String_1(1..TC_Last_1) /= FXF3A00.Edited_Output(i).all or + TC_String_2(1..TC_Last_2) /= FXF3A00.Edited_Output(i).all + then + Report.Failed("Failed comparison of two edited output " & + "strings from data with two decimal points " & + ", loop number = " & Integer'Image(i)); + end if; + end loop; + + Text_IO.Close(Text_File); + + -- Reopen the text file in Append_File mode. + -- Use the two versions of Put, for data with no decimal points, + -- to write edited output strings to the text file. Use a separate + -- line for each string entry. + + Text_IO.Open(Text_File, Text_IO.Append_File, Text_Filename); + + for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12 + + -- Create the picture object from the picture string specific to + -- data with no decimal points. Use appropriate offset into the + -- Valid_Strings array to account for the string data used above. + + TC_Picture := + Editing.To_Picture(FXF3A00.Valid_Strings(i+TC_End_Loop_1).all); + + -- Use the Text_IO version of Put to place an edited output + -- string into a text file. Use non-default parameters in the + -- call to Image for Currency, Fill, Separator, and Radix_Mark. + + Text_IO.Put(Text_File, + Pack_NDP.Image(Item => FXF3A00.Data_With_NDP(i), + Pic => TC_Picture, + Currency => "$", + Fill => '*', + Separator => ',', + Radix_Mark => '.')); + Text_IO.New_Line(Text_File); + + -- Use the version of Put from the instantiation of + -- Decimal_Output to place an edited output string on a separate + -- line of the Text_File. Use non-default parameters for + -- Currency, Fill, Separator, and Radix_Mark. + + Pack_NDP.Put(File => Text_File, + Item => FXF3A00.Data_With_NDP(i), + Pic => TC_Picture, + Currency => "$", + Fill => '*', + Separator => ',', + Radix_Mark => '.'); + Text_IO.New_Line(Text_File); + + end loop; + + Text_IO.Close(Text_File); + + -- Reopen the text file in In_File mode, and verify the edited + -- output found on consecutive lines of the file. + + Text_IO.Open(Text_File, Text_IO.In_File, Text_Filename); + + -- Read past data that has been verified above, skipping two lines + -- of the data file for each loop. + + for i in TC_Start_Loop..TC_End_Loop_1 loop -- 1..10 + Text_IO.Skip_Line(Text_File, 2); + end loop; + + -- Verify the last data set that was written to the file. + + for i in TC_Start_Loop..TC_End_Loop_2 loop -- 1..12 + Text_IO.Get_Line(Text_File, TC_String_1, TC_Last_1); + Text_IO.Get_Line(Text_File, TC_String_2, TC_Last_2); + + -- Compare the two strings for equality with the expected edited + -- output result. Failure results if strings don't match, or if + -- a reading error occurred from the attempted Get_Line resulting + -- from an improperly formed edited output string. + + if TC_String_1(1..TC_Last_1) /= + FXF3A00.Edited_Output(i+TC_Offset).all or + TC_String_2(1..TC_Last_2) /= + FXF3A00.Edited_Output(i+TC_Offset).all + then + Report.Failed("Failed comparison of two edited output " & + "strings from data with no decimal points " & + ", loop number = " & + Integer'Image(i)); + end if; + + end loop; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + -- Delete the external file. + if Text_IO.Is_Open (Text_File) then + Text_IO.Delete (Text_File); + else + Text_IO.Open (Text_File, Text_IO.In_File, Text_Filename); + Text_IO.Delete (Text_File); + end if; + + exception + + -- Since Use_Error can be raised if, for the specified mode, + -- the environment does not support Text_IO operations, the + -- following handlers are included: + + when Text_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Text_IO Create"); + + when Text_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Text_IO Create"); + + when others => + Report.Failed ("Unexpected exception raised in Create block"); + + end Test_for_Text_IO_Support; + + Report.Result; + + end CXF3A06; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a07.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,337 ---- + -- CXF3A07.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that Ada.Text_IO.Editing.Put and Ada.Strings.Fixed.Move + -- have the same effect in putting edited output results into string + -- variables. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. These data tables are found in package FXF3A00. + -- + -- The operation of the two above subprograms are examined twice, first + -- with the output of an edited output string to a receiving string + -- object of equal size, the other to a receiving string object of + -- larger size, where justification and padding are considered. + -- The procedure Editing.Put will place an edited output string into + -- a larger receiving string with right justification and blank fill. + -- Procedure Move has parameter control of justification and fill, and + -- in this test will mirror Put by specifying right justification and + -- blank fill. + -- + -- In the cases where the edited output string is of shorter length + -- than the receiving string object, a blank-filled constant string + -- will be catenated to the front of the expected edited output string + -- for comparison with the receiving string object, enabling direct + -- string comparison for result verification. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A07.A + -- + -- + -- CHANGE HISTORY: + -- 30 JAN 95 SAIC Initial prerelease version. + -- 11 MAR 97 PWB.CTA Fixed string lengths + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Ada.Strings.Fixed; + with Report; + + procedure CXF3A07 is + begin + + Report.Test ("CXF3A07", "Check that Ada.Text_IO.Editing.Put and " & + "Ada.Strings.Fixed.Move have the same " & + "effect in putting edited output results " & + "into string variables"); + Test_Block: + declare + + use Ada.Text_IO; + + -- Instantiate the Decimal_Output generic package for two + -- different decimal data types. + + package Pack_2DP is -- Uses decimal type with delta 0.01. + new Editing.Decimal_Output(FXF3A00.Decimal_Type_2DP); + + package Pack_NDP is -- Uses decimal type with delta 1.0. + new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_NDP, + Default_Currency => "$", + Default_Fill => '*', + Default_Separator => ',', + Default_Radix_Mark => '.'); + + TC_Picture : Editing.Picture; + TC_Start_Loop : Integer := 0; + TC_End_Loop : Integer := 0; + TC_Offset : Integer := 0; + TC_Length : Natural := 0; + + TC_Put_String_20, -- Longer than the longest edited + TC_Move_String_20 : String(1..20); -- output string. + + TC_Put_String_17, -- Exact length of longest edited + TC_Move_String_17 : String(1..17); -- output string in 2DP-US data set. + + TC_Put_String_8, -- Exact length of longest edited + TC_Move_String_8 : String(1..8); -- output string in NDP-US data set. + + + begin + + -- Examine cases where the output string is longer than the length + -- of the edited output result. Use the instantiation of + -- Decimal_Output specific to data with two decimal places. + + TC_Start_Loop := 1; + TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10 + FXF3A00.Number_Of_Foreign_Strings; + + for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 + + -- Create the picture object from the picture string. + + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all, + Blank_When_Zero => False); + + -- Determine the actual length of the edited output string + -- that is expected from Put and Image. + + TC_Length := Pack_2DP.Length(Pic => TC_Picture, + Currency => "$"); + + -- Determine the difference in length between the receiving string + -- object and the expected length of the edited output string. + -- Define a blank filled string constant with length equal to this + -- length difference. + + declare + TC_Length_Diff : Integer := TC_Put_String_20'Length - + TC_Length; + TC_Buffer_String : constant String(1..TC_Length_Diff) := + (others => ' '); + begin + + -- Fill the two receiving string objects with edited output, + -- using the two different methods (Put and Move). + + Pack_2DP.Put(To => TC_Put_String_20, + Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => "$", + Fill => '*', + Separator => ',', + Radix_Mark => '.'); + + + Ada.Strings.Fixed.Move + (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => "$", + Fill => '*', + Separator => ',', + Radix_Mark => '.'), + Target => TC_Move_String_20, + Drop => Ada.Strings.Error, + Justify => Ada.Strings.Right, + Pad => Ada.Strings.Space); + + -- Each receiving string object is now filled with the edited + -- output result, right justified. + -- Compare these two string objects with the expected edited + -- output value, which is appended to the blank filled string + -- whose length is the difference between the expected edited + -- output length and the length of the receiving strings. + + if TC_Buffer_String & FXF3A00.Edited_Output(i).all /= + TC_Put_String_20 or + TC_Buffer_String & FXF3A00.Edited_Output(i).all /= + TC_Move_String_20 + then + Report.Failed("Failed case where the output string is " & + "longer than the length of the edited " & + "output result, loop #" & Integer'Image(i)); + end if; + + exception + when Layout_Error => + Report.Failed("Layout_Error raised when the output string " & + "is longer than the length of the edited " & + "output result, loop #" & Integer'Image(i)); + when others => + Report.Failed("Exception raised when the output string is " & + "longer than the length of the edited " & + "output result, loop #" & Integer'Image(i)); + end; + end loop; + + + -- Repeat the above loop, but only evaluate three cases - those where + -- the length of the expected edited output string is the exact length + -- of the receiving strings (no justification will be required within + -- the string. This series of evaluations again uses decimal data + -- with two decimal places. + + for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 + + case i is + when 1 | 5 | 7 => + + -- Create the picture object from the picture string. + TC_Picture := + Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + -- Fill the two receiving string objects with edited output, + -- using the two different methods (Put and Move). + -- Use default parameters in the various calls where possible. + + Pack_2DP.Put(To => TC_Put_String_17, + Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture); + + + Ada.Strings.Fixed.Move + (Source => Pack_2DP.Image(Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture), + Target => TC_Move_String_17); + + -- Each receiving string object is now filled with the edited + -- output result. Compare these two string objects with the + -- expected edited output value. + + if FXF3A00.Edited_Output(i).all /= TC_Put_String_17 or + FXF3A00.Edited_Output(i).all /= TC_Move_String_17 + then + Report.Failed("Failed case where the output string is " & + "the exact length of the edited output " & + "result, loop #" & Integer'Image(i)); + end if; + + when others => null; + end case; + end loop; + + + -- Evaluate a mix of cases, where the expected edited output string + -- length is either exactly as long or shorter than the receiving + -- output string parameter. This series of evaluations uses decimal + -- data with no decimal places. + + TC_Start_Loop := TC_End_Loop + 1; -- 11 + TC_End_Loop := TC_Start_Loop + -- 22 + FXF3A00.Number_of_NDP_Items - 1; + TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10 + -- This offset is required due to the arrangement of data within the + -- tables found in FXF3A00. + + for i in TC_Start_Loop..TC_End_Loop loop -- 11..22 + + -- Create the picture object from the picture string. + + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + -- Determine the actual length of the edited output string + -- that is expected from Put and Image. + + TC_Length := Pack_NDP.Length(TC_Picture); + + -- Fill the two receiving string objects with edited output, + -- using the two different methods (Put and Move). + + Pack_NDP.Put(TC_Put_String_8, + FXF3A00.Data_With_NDP(i-TC_Offset), + TC_Picture); + + Ada.Strings.Fixed.Move + (Pack_NDP.Image(FXF3A00.Data_With_NDP(i-TC_Offset), TC_Picture), + TC_Move_String_8, + Ada.Strings.Error, + Ada.Strings.Right, + Ada.Strings.Space); + + -- Determine if there is a difference in length between the + -- receiving string object and the expected length of the edited + -- output string. If so, then define a blank filled string constant + -- with length equal to this length difference. + + if TC_Length < TC_Put_String_8'Length then + declare + TC_Length_Diff : Integer := TC_Put_String_8'Length - + TC_Length; + TC_Buffer_String : constant String(1..TC_Length_Diff) := + (others => ' '); + begin + + -- Each receiving string object is now filled with the edited + -- output result, right justified. + -- Compare these two string objects with the expected edited + -- output value, which is appended to the blank filled string + -- whose length is the difference between the expected edited + -- output length and the length of the receiving strings. + + if TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /= + TC_Put_String_8 or + TC_Buffer_String & FXF3A00.Edited_Output(i+TC_Offset).all /= + TC_Move_String_8 + then + Report.Failed("Failed case where the output string is " & + "longer than the length of the edited " & + "output result, loop #" & Integer'Image(i) & + ", using data with no decimal places"); + end if; + end; + else + + -- Compare these two string objects with the expected edited + -- output value, which is appended to the blank filled string + -- whose length is the difference between the expected edited + -- output length and the length of the receiving strings. + + if FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Put_String_8 or + FXF3A00.Edited_Output(i+TC_Offset).all /= TC_Move_String_8 + then + Report.Failed("Failed case where the output string is " & + "the same length as the edited output " & + "result, loop #" & Integer'Image(i) & + ", using data with no decimal places"); + end if; + end if; + end loop; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A07; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxf/cxf3a08.a 2003-10-27 11:28:58.000000000 +0000 *************** *** 0 **** --- 1,289 ---- + -- CXF3A08.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the version of Ada.Text_IO.Editing.Put with an out + -- String parameter propagates Layout_Error if the edited output string + -- result of Put exceeds the length of the out String parameter. + -- + -- TEST DESCRIPTION: + -- This test is structured using tables of data, consisting of + -- numerical values, picture strings, and expected image + -- result strings. These data tables are found in package FXF3A00. + -- + -- This test examines the case of the out string parameter to Procedure + -- Put being insufficiently long to hold the entire edited output + -- string result of the procedure. In this case, Layout_Error is to be + -- raised. Test failure results if Layout_Error is not raised, or if an + -- exception other than Layout_Error is raised. + -- + -- A number of data combinations are examined, using instantiations + -- of Package Decimal_Output with different decimal data types and + -- both default and non-default parameters as generic actual parameters. + -- In addition, calls to Procedure Put are performed using default + -- parameters, non-default parameters, and non-default parameters that + -- override the generic actual parameters provided at the time of + -- instantiation of Decimal_Output. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- FXF3A00.A (foundation code) + -- => CXF3A08.A + -- + -- + -- CHANGE HISTORY: + -- 31 JAN 95 SAIC Initial prerelease version. + -- + --! + + with FXF3A00; + with Ada.Text_IO.Editing; + with Report; + + procedure CXF3A08 is + begin + + Report.Test ("CXF3A08", "Check that the version of " & + "Ada.Text_IO.Editing.Put with an out " & + "String parameter propagates Layout_Error " & + "if the output string exceeds the length " & + "of the out String parameter"); + + Test_Block: + declare + + use Ada.Text_IO; + + -- Instantiate the Decimal_Output generic package for two + -- different decimal data types. + -- Uses decimal type with delta 0.01 and + package Pack_2DP is -- non-default generic actual parameters. + new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP, + Default_Currency => "$", + Default_Fill => '*', + Default_Separator => ',', + Default_Radix_Mark => '.'); + + package Pack_NDP is -- Uses decimal type with delta 1.0. + new Editing.Decimal_Output(FXF3A00.Decimal_Type_NDP); + + TC_Picture : Editing.Picture; + TC_Start_Loop : Integer := 0; + TC_End_Loop : Integer := 0; + TC_Offset : Integer := 0; + + TC_Short_String : String(1..4); -- Shorter than the shortest edited + -- output string result. + + begin + + -- Examine cases where the out string parameter is shorter than + -- the length of the edited output result. Use the instantiation of + -- Decimal_Output specific to data with two decimal places. + + TC_Start_Loop := 1; + TC_End_Loop := FXF3A00.Number_of_2DP_Items - -- 10 + FXF3A00.Number_Of_Foreign_Strings; + + for i in TC_Start_Loop..TC_End_Loop loop -- 1..10 + + -- Create the picture object from the picture string. + + TC_Picture := + Editing.To_Picture(Pic_String => FXF3A00.Valid_Strings(i).all, + Blank_When_Zero => False); + + -- The out parameter string provided in the call to Put is + -- shorter than the edited output result of the procedure. + -- This will result in a Layout_Error being raised and handled. + -- Test failure results from no exception being raised, or from + -- the wrong exception being raised. + + begin + + -- Use the instantiation of Decimal_Output specific to decimal + -- data with two decimal places, as well as non-default + -- parameters and named parameter association. + + Pack_2DP.Put(To => TC_Short_String, + Item => FXF3A00.Data_With_2DP(i), + Pic => TC_Picture, + Currency => "$", + Fill => '*', + Separator => ',', + Radix_Mark => '.'); + + -- Test failure if exception not raised. + + Report.Failed + ("Layout_Error not raised, decimal data with two decimal " & + "places, loop #" & Integer'Image(i)); + + exception + when Layout_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised, Layout_Error expected, " & + "decimal data with two decimal places, loop #" & + Integer'Image(i)); + end; + end loop; + + + -- Perform similar evaluations as above, but use the instantiation + -- of Decimal_Output specific to decimal data with no decimal places. + + TC_Start_Loop := TC_End_Loop + 1; -- 11 + TC_End_Loop := TC_Start_Loop + -- 22 + FXF3A00.Number_of_NDP_Items - 1; + TC_Offset := FXF3A00.Number_of_Foreign_Strings; -- 10 + -- This offset is required due to the arrangement of data within the + -- tables found in FXF3A00. + + for i in TC_Start_Loop..TC_End_Loop loop -- 11..22 + + -- Create the picture object from the picture string. + + TC_Picture := Editing.To_Picture(FXF3A00.Valid_Strings(i).all); + + begin + + -- Use the instantiation of Decimal_Output specific to decimal + -- data with no decimal places, as well as default parameters + -- and positional parameter association. + + Pack_NDP.Put(TC_Short_String, + FXF3A00.Data_With_NDP(i-TC_Offset), + TC_Picture); + + -- Test failure if exception not raised. + + Report.Failed + ("Layout_Error not raised, decimal data with no decimal " & + "places, loop #" & Integer'Image(i)); + + exception + when Layout_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Incorrect exception raised, Layout_Error expected, " & + "decimal data with no decimal places, loop #" & + Integer'Image(i)); + end; + + end loop; + + + -- Check that Layout_Error is raised by Put resulting from an + -- instantiation of Decimal_Output specific to foreign currency + -- representations. + -- Note: Both of the following evaluation sets use decimal data with + -- two decimal places. + + declare + + package Pack_FF is + new Editing.Decimal_Output(Num => FXF3A00.Decimal_Type_2DP, + Default_Currency => "FF", + Default_Fill => '*', + Default_Separator => '.', + Default_Radix_Mark => ','); + + begin + + TC_Offset := FXF3A00.Number_Of_2DP_Items - -- 10 + FXF3A00.Number_Of_Foreign_Strings; + + for i in 1..FXF3A00.Number_Of_FF_Strings loop -- 1..4 + begin + + -- Create the picture object from the picture string. + TC_Picture := + Editing.To_Picture(FXF3A00.Foreign_Strings(i).all); + + Pack_FF.Put(To => TC_Short_String, + Item => FXF3A00.Data_With_2DP(i+TC_Offset), + Pic => TC_Picture); + + Report.Failed("Layout_Error was not raised by Put from " & + "an instantiation of Decimal_Output using " & + "non-default parameters specific to FF " & + "currency, loop #" & Integer'Image(i)); + + exception + when Layout_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Put from " & + "an instantiation of Decimal_Output using " & + "non-default parameters specific to FF " & + "currency, loop #" & Integer'Image(i)); + end; + end loop; + + + -- These evaluations use a version of Put resulting from a + -- non-default instantiation of Decimal_Output, but which has + -- specific foreign currency parameters provided in the call that + -- override the generic actual parameters provided at instantiation. + + TC_Offset := TC_Offset + FXF3A00.Number_Of_FF_Strings; -- 14 + + for i in 1..FXF3A00.Number_Of_DM_Strings loop -- 1..5 + begin + TC_Picture := + Editing.To_Picture(FXF3A00.Foreign_Strings + (i+FXF3A00.Number_Of_FF_Strings).all); + + Pack_2DP.Put(To => TC_Short_String, + Item => FXF3A00.Data_With_2DP(i+TC_Offset), + Pic => TC_Picture, + Currency => "DM", + Fill => '*', + Separator => ',', + Radix_Mark => '.'); + + Report.Failed("Layout_Error was not raised by Put using " & + "non-default parameters specific to DM " & + "currency, loop #" & Integer'Image(i)); + + exception + when Layout_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by Put using " & + "non-default parameters specific to DM " & + "currency, loop #" & Integer'Image(i)); + end; + end loop; + + end; + + exception + when others => Report.Failed("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXF3A08; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1001.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,276 ---- + -- CXG1001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in the package + -- Ada.Numerics.Generic_Complex_Types provide correct results. + -- Specifically, check the functions Re, Im (both versions), procedures + -- Set_Re, Set_Im (both versions), functions Compose_From_Cartesian (all + -- versions), Compose_From_Polar, Modulus, Argument, and "abs". + -- + -- TEST DESCRIPTION: + -- The generic package Generic_Complex_Types + -- is instantiated with a real type (new Float), and the results + -- produced by the specified subprograms are verified. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 15 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. + -- Modified subtest for Compose_From_Polar. + -- 29 Sep 96 SAIC Incorporated reviewer comments. + -- + --! + + with Ada.Numerics.Generic_Complex_Types; + with Report; + + procedure CXG1001 is + + begin + + Report.Test ("CXG1001", "Check that the subprograms defined in " & + "the package Ada.Numerics.Generic_Complex_Types " & + "provide correct results"); + + Test_Block: + declare + + type Real_Type is new Float; + + package Complex_Pack is new + Ada.Numerics.Generic_Complex_Types(Real_Type); + + use type Complex_Pack.Complex; + + -- Declare a zero valued complex number. + Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0); + + TC_Complex : Complex_Pack.Complex := Complex_Zero; + TC_Imaginary : Complex_Pack.Imaginary; + + begin + + -- Check that the procedures Set_Re and Set_Im (both versions) provide + -- correct results. + + declare + TC_Complex_Real_Field : Complex_Pack.Complex := (5.0, 0.0); + TC_Complex_Both_Fields : Complex_Pack.Complex := (5.0, 7.0); + begin + + Complex_Pack.Set_Re(X => TC_Complex, Re => 5.0); + + if TC_Complex /= TC_Complex_Real_Field then + Report.Failed("Incorrect results from Procedure Set_Re"); + end if; + + Complex_Pack.Set_Im(X => TC_Complex, Im => 7.0); + + if TC_Complex.Re /= 5.0 or + TC_Complex.Im /= 7.0 or + TC_Complex /= TC_Complex_Both_Fields + then + Report.Failed("Incorrect results from Procedure Set_Im " & + "with Complex argument"); + end if; + + Complex_Pack.Set_Im(X => TC_Imaginary, Im => 3.0); + + + if Complex_Pack.Im(TC_Imaginary) /= 3.0 then + Report.Failed("Incorrect results returned following the use " & + "of Procedure Set_Im with Imaginary argument"); + end if; + + end; + + + -- Check that the functions Re and Im (both versions) provide + -- correct results. + + declare + TC_Complex_1 : Complex_Pack.Complex := (1.0, 0.0); + TC_Complex_2 : Complex_Pack.Complex := (0.0, 2.0); + TC_Complex_3 : Complex_Pack.Complex := (4.0, 3.0); + begin + + -- Function Re. + + if Complex_Pack.Re(X => TC_Complex_1) /= 1.0 or + Complex_Pack.Re(X => TC_Complex_2) /= 0.0 or + Complex_Pack.Re(X => TC_Complex_3) /= 4.0 + then + Report.Failed("Incorrect results from Function Re"); + end if; + + -- Function Im; version with Complex argument. + + if Complex_Pack.Im(X => TC_Complex_1) /= 0.0 or + Complex_Pack.Im(X => TC_Complex_2) /= 2.0 or + Complex_Pack.Im(X => TC_Complex_3) /= 3.0 + then + Report.Failed("Incorrect results from Function Im " & + "with Complex argument"); + end if; + + + -- Function Im; version with Imaginary argument. + + if Complex_Pack.Im(Complex_Pack.i) /= 1.0 or + Complex_Pack.Im(Complex_Pack.j) /= 1.0 + then + Report.Failed("Incorrect results from use of Function Im " & + "when used with an Imaginary argument"); + end if; + + end; + + + -- Verify the results of the three versions of Function + -- Compose_From_Cartesian + + declare + + Zero : constant Real_Type := 0.0; + Six : constant Real_Type := 6.0; + + TC_Complex_1 : Complex_Pack.Complex := (3.0, 8.0); + TC_Complex_2 : Complex_Pack.Complex := (Six, Zero); + TC_Complex_3 : Complex_Pack.Complex := (Zero, 1.0); + + begin + + TC_Complex := Complex_Pack.Compose_From_Cartesian(3.0, 8.0); + + if TC_Complex /= TC_Complex_1 then + Report.Failed("Incorrect results from Function " & + "Compose_From_Cartesian - 1"); + end if; + + -- If only one component is given, the other component is + -- implicitly zero (Both components are set by the following two + -- function calls). + + TC_Complex := Complex_Pack.Compose_From_Cartesian(Re => 6.0); + + if TC_Complex /= TC_Complex_2 then + Report.Failed("Incorrect results from Function " & + "Compose_From_Cartesian - 2"); + end if; + + TC_Complex := + Complex_Pack.Compose_From_Cartesian(Im => Complex_Pack.i); + + if TC_Complex /= TC_Complex_3 then + Report.Failed("Incorrect results from Function " & + "Compose_From_Cartesian - 3"); + end if; + + end; + + + -- Verify the results of Function Compose_From_Polar, Modulus, "abs", + -- and Argument. + + declare + + use Complex_Pack; + + TC_Modulus, + TC_Argument : Real_Type := 0.0; + + + Angle_0 : constant Real_Type := 0.0; + Angle_90 : constant Real_Type := 90.0; + Angle_180 : constant Real_Type := 180.0; + Angle_270 : constant Real_Type := 270.0; + Angle_360 : constant Real_Type := 360.0; + + begin + + -- Verify the result of Function Compose_From_Polar. + -- When the value of the parameter Modulus is zero, the + -- Compose_From_Polar function yields a result of zero. + + if Compose_From_Polar(0.0, 30.0, 360.0) /= Complex_Zero + then + Report.Failed("Incorrect result from Function " & + "Compose_From_Polar - 1"); + end if; + + -- When the value of the parameter Argument is equal to a multiple + -- of the quarter cycle, the result of the Compose_From_Polar + -- function with specified cycle lies on one of the axes. + + if Compose_From_Polar( 5.0, Angle_0, Angle_360) /= (5.0, 0.0) or + Compose_From_Polar( 5.0, Angle_90, Angle_360) /= (0.0, 5.0) or + Compose_From_Polar(-5.0, Angle_180, Angle_360) /= (5.0, 0.0) or + Compose_From_Polar(-5.0, Angle_270, Angle_360) /= (0.0, 5.0) or + Compose_From_Polar(-5.0, Angle_90, Angle_360) /= (0.0, -5.0) or + Compose_From_Polar( 5.0, Angle_270, Angle_360) /= (0.0, -5.0) + then + Report.Failed("Incorrect result from Function " & + "Compose_From_Polar - 2"); + end if; + + -- When the parameter to Function Argument represents a point on + -- the non-negative real axis, the function yields a zero result. + + if Argument(Complex_Zero, Angle_360) /= 0.0 then + Report.Failed("Incorrect result from Function Argument"); + end if; + + -- Function Modulus + + if Modulus(Complex_Zero) /= 0.0 or + Modulus(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or + Modulus(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0 + then + Report.Failed("Incorrect results from Function Modulus"); + end if; + + -- Function "abs", a rename of Function Modulus. + + if "abs"(Complex_Zero) /= 0.0 or + "abs"(Compose_From_Polar( 5.0, Angle_90, Angle_360)) /= 5.0 or + "abs"(Compose_From_Polar(-5.0, Angle_180, Angle_360)) /= 5.0 + then + Report.Failed("Incorrect results from Function abs"); + end if; + + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXG1001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1002.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,198 ---- + -- CXG1002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in the package + -- Ada.Numerics.Generic_Complex_Types provide the prescribed results. + -- Specifically, check the various versions of functions "+" and "-". + -- + -- TEST DESCRIPTION: + -- This test checks that the subprograms "+" and "-" defined in the + -- Generic_Complex_Types package provide the results prescribed for the + -- evaluation of these complex arithmetic operations. The functions + -- Re and Im are used to extract the appropriate component of the + -- complex result, in order that the prescribed result component can be + -- verified. + -- The generic package is instantiated with a real type (new Float), + -- and the results produced by the specified subprograms are verified. + -- + -- SPECIAL REQUIREMENTS: + -- This test can be run in either "relaxed" or "strict" mode. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- + --! + + with Ada.Numerics.Generic_Complex_Types; + with Report; + + procedure CXG1002 is + + begin + + Report.Test ("CXG1002", "Check that the subprograms defined in " & + "the package Ada.Numerics.Generic_Complex_Types " & + "provide the prescribed results"); + + Test_Block: + declare + + type Real_Type is new Float; + + package Complex_Pack is new + Ada.Numerics.Generic_Complex_Types(Real_Type); + use Complex_Pack; + + -- Declare a zero valued complex number using the record + -- aggregate approach. + + Complex_Zero : constant Complex_Pack.Complex := (0.0, 0.0); + + TC_Complex, + TC_Complex_Right, + TC_Complex_Left : Complex_Pack.Complex := Complex_Zero; + + TC_Real : Real_Type := 0.0; + + TC_Imaginary : Complex_Pack.Imaginary; + + begin + + + -- Check that the imaginary component of the result of a binary addition + -- operator that yields a result of complex type is exact when either + -- of its operands is of pure-real type. + + TC_Complex := Compose_From_Cartesian(2.0, 3.0); + TC_Real := 3.0; + + if Im("+"(Left => TC_Complex, Right => TC_Real)) /= 3.0 or + Im("+"(TC_Complex, 6.0)) /= 3.0 or + Im(TC_Complex + TC_Real) /= 3.0 or + Im(TC_Complex + 5.0) /= 3.0 or + Im((7.0, 2.0) + 1.0) /= 2.0 or + Im((7.0, 5.0) + (-2.0)) /= 5.0 or + Im((-7.0, -2.0) + 1.0) /= -2.0 or + Im((-7.0, -3.0) + (-3.0)) /= -3.0 + then + Report.Failed("Incorrect results from Function ""+"" with " & + "one Complex and one Real argument - 1"); + end if; + + if Im("+"(Left => TC_Real, Right => TC_Complex)) /= 3.0 or + Im("+"(4.0, TC_Complex)) /= 3.0 or + Im(TC_Real + TC_Complex) /= 3.0 or + Im(9.0 + TC_Complex) /= 3.0 or + Im(1.0 + (7.0, -9.0)) /= -9.0 or + Im((-2.0) + (7.0, 2.0)) /= 2.0 or + Im(1.0 + (-7.0, -5.0)) /= -5.0 or + Im((-3.0) + (-7.0, 16.0)) /= 16.0 + then + Report.Failed("Incorrect results from Function ""+"" with " & + "one Complex and one Real argument - 2"); + end if; + + + -- Check that the imaginary component of the result of a binary + -- subtraction operator that yields a result of complex type is exact + -- when its right operand is of pure-real type. + + TC_Complex := (8.0, -4.0); + TC_Real := 2.0; + + if Im("-"(Left => TC_Complex, Right => TC_Real)) /= -4.0 or + Im("-"(TC_Complex, 5.0)) /= -4.0 or + Im(TC_Complex - TC_Real) /= -4.0 or + Im(TC_Complex - 4.0) /= -4.0 or + Im((6.0, 5.0) - 1.0) /= 5.0 or + Im((6.0, 13.0) - 7.0) /= 13.0 or + Im((-5.0, 3.0) - (2.0)) /= 3.0 or + Im((-5.0, -6.0) - (-3.0)) /= -6.0 + then + Report.Failed("Incorrect results from Function ""-"" with " & + "one Complex and one Real argument"); + end if; + + + -- Check that the real component of the result of a binary addition + -- operator that yields a result of complex type is exact when either + -- of its operands is of pure-imaginary type. + + TC_Complex := (5.0, 0.0); + + if Re("+"(Left => TC_Complex, Right => i)) /= 5.0 or + Re("+"(Complex_Pack.j, TC_Complex)) /= 5.0 or + Re((-8.0, 5.0) + ( 2.0*i)) /= -8.0 or + Re((2.0, 5.0) + (-2.0*i)) /= 2.0 or + Re((-20.0, -5.0) + ( 3.0*i)) /= -20.0 or + Re((6.0, -5.0) + (-3.0*i)) /= 6.0 + then + Report.Failed("Incorrect results from Function ""+"" with " & + "one Complex and one Imaginary argument"); + end if; + + + -- Check that the real component of the result of a binary + -- subtraction operator that yields a result of complex type is exact + -- when its right operand is of pure-imaginary type. + + TC_Complex := TC_Complex + i; -- Should produce (5.0, 1.0) + + if Re("-"(TC_Complex, i)) /= 5.0 or + Re((-4.0, 4.0) - ( 2.0*i)) /= -4.0 or + Re((9.0, 4.0) - ( 5.0*i)) /= 9.0 or + Re((16.0, -5.0) - ( 3.0*i)) /= 16.0 or + Re((-3.0, -5.0) - (-4.0*i)) /= -3.0 + then + Report.Failed("Incorrect results from Function ""-"" with " & + "one Complex and one Imaginary argument"); + end if; + + + -- Check that the result of a binary addition operation is exact when + -- one of its operands is of real type and the other is of + -- pure-imaginary type; the operator is analogous to the + -- Compose_From_Cartesian function; it performs no arithmetic. + + TC_Complex := Complex_Pack."+"(5.0, Complex_Pack.i); + + if TC_Complex /= (5.0, 1.0) or + (4.0 + i) /= (4.0, 1.0) or + "+"(Left => j, Right => 3.0) /= (3.0, 1.0) + then + Report.Failed("Incorrect results from Function ""+"" with " & + "one Real and one Imaginary argument"); + end if; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXG1002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1003.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,478 ---- + -- CXG1003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in the package Text_IO.Complex_IO + -- provide correct results. + -- + -- TEST DESCRIPTION: + -- The generic package Ada.Numerics.Generic_Complex_Types is instantiated + -- with a real type (new Float). The resulting new package is used as + -- the generic actual to package Complex_IO. + -- Two different versions of Put and Get are examined in this test, + -- those that input/output complex data values from/to Text_IO files, + -- and those that input/output complex data values from/to strings. + -- Two procedures are defined to perform the file data manipulations; + -- one to place complex data into the file, and one to retrieve the data + -- from the file and verify its correctness. + -- Complex data is also put into string variables using the Procedure + -- Put for strings, and this data is then retrieved and reconverted into + -- complex values using the Get procedure. + -- + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable to implementations that: + -- support Annex G, + -- support Text_IO and external files + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 29 Dec 94 SAIC Modified Width parameter in Get function calls. + -- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. + -- 29 Sep 96 SAIC Incorporated reviewer comments. + -- + --! + + with Ada.Text_IO.Complex_IO; + with Ada.Numerics.Generic_Complex_Types; + with Report; + + procedure CXG1003 is + begin + + Report.Test ("CXG1003", "Check that the subprograms defined in " & + "the package Text_IO.Complex_IO " & + "provide correct results"); + + Test_for_Text_IO_Support: + declare + use Ada; + + Data_File : Ada.Text_IO.File_Type; + Data_Filename : constant String := Report.Legal_File_Name; + + begin + + -- An application creates a text file in mode Out_File, with the + -- intention of entering complex data into the file as appropriate. + -- In the event that the particular environment where the application + -- is running does not support Text_IO, Use_Error or Name_Error will be + -- raised on calls to Text_IO operations. Either of these exceptions + -- will be handled to produce a Not_Applicable result. + + Text_IO.Create (File => Data_File, + Mode => Ada.Text_IO.Out_File, + Name => Data_Filename); + + Test_Block: + declare + + TC_Verbose : Boolean := False; + + type Real_Type is new Float; + + package Complex_Pack is new + Ada.Numerics.Generic_Complex_Types(Real_Type); + + package C_IO is new Ada.Text_IO.Complex_IO(Complex_Pack); + + use Ada.Text_IO, C_IO; + use type Complex_Pack.Complex; + + Number_Of_Complex_Items : constant := 6; + Number_Of_Error_Items : constant := 2; + + TC_Complex : Complex_Pack.Complex; + TC_Last_Character_Read : Positive; + + Complex_Array : array (1..Number_Of_Complex_Items) + of Complex_Pack.Complex := ( (3.0, 9.0), + (4.0, 7.0), + (5.0, 6.0), + (6.0, 3.0), + (2.0, 5.0), + (3.0, 7.0) ); + + + procedure Load_Data_File (The_File : in out Text_IO.File_Type) is + use Ada.Text_IO; + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- This procedure is designed to load complex data into a data + -- file twice, first using Text_IO, then Complex_IO. In this + -- first case, the complex data values are entered as strings, + -- assuming a variety of legal formats, as provided in the + -- reference manual. + + Put_Line(The_File, "(3.0, 9.0)"); + Put_Line(The_File, "+4. +7."); -- Relaxed real literal format. + Put_Line(The_File, "(5.0 6.)"); + Put_Line(The_File, "6., 3.0"); + Put_Line(The_File, " ( 2.0 , 5.0 ) "); + Put_Line(The_File, "("); -- Complex data separated over + Put_Line(The_File, "3.0"); -- several (5) lines. + Put_Line(The_File, " , "); + Put_Line(The_File, "7.0 "); + Put_Line(The_File, ")"); + + if TC_Verbose then + Report.Comment("Complex values entered into data file using " & + "Text_IO, Procedure Load_Data_File"); + end if; + + -- Use the Complex_IO procedure Put to enter Complex data items + -- into the data file. + -- Note: Data is being entered into the file for the *second* time + -- at this point. (Using Complex_IO here, Text_IO above) + + for i in 1..Number_Of_Complex_Items loop + C_IO.Put(File => The_File, + Item => Complex_Array(i), + Fore => 1, + Aft => 1, + Exp => 0); + end loop; + + if TC_Verbose then + Report.Comment("Complex values entered into data file using " & + "Complex_IO, Procedure Load_Data_File"); + end if; + + Put_Line(The_File, "(5A,3)"); -- data to raise Data_Error. + Put_Line(The_File, "(3.0,,8.0)"); -- data to raise Data_Error. + + end Load_Data_File; + + + + procedure Process_Data_File (The_File : in out Text_IO.File_Type) is + TC_Complex : Complex_Pack.Complex := (0.0, 0.0); + TC_Width : Integer := 0; + begin + -- This procedure does not create, open, or close the data file; + -- The_File file object must be Open at this point. + -- Use procedure Get (for Files) to extract the complex data from + -- the Text_IO file. This data was placed into the file using + -- Text_IO. + + + for i in 1..Number_Of_Complex_Items loop + + C_IO.Get(The_File, TC_Complex, TC_Width); + + if TC_Complex /= Complex_Array(i) then + Report.Failed("Incorrect complex data read from file " & + "when using Text_IO procedure Get, " & + "data item #" & Integer'Image(i)); + end if; + end loop; + + if TC_Verbose then + Report.Comment("First set of complex values extracted " & + "from data file using Complex_IO, " & + "Procedure Process_Data_File"); + end if; + + -- Use procedure Get (for Files) to extract the complex data from + -- the Text_IO file. This data was placed into the file using + -- procedure Complex_IO.Put. + -- Note: Data is being extracted from the file for the *second* + -- time at this point (Using Complex_IO here, Text_IO above) + + for i in 1..Number_Of_Complex_Items loop + + C_IO.Get(The_File, TC_Complex, TC_Width); + + if TC_Complex /= Complex_Array(i) then + Report.Failed("Incorrect complex data read from file " & + "when using Complex_IO procedure Get, " & + "data item #" & Integer'Image(i)); + end if; + end loop; + + if TC_Verbose then + Report.Comment("Second set of complex values extracted " & + "from data file using Complex_IO, " & + "Procedure Process_Data_File"); + end if; + + -- The final items in the Data_File are complex values with + -- incorrect syntax, which should raise Data_Error on an attempt + -- to read them from the file. + TC_Width := 10; + for i in 1..Number_Of_Error_Items loop + begin + C_IO.Get(The_File, TC_Complex, TC_Width); + Report.Failed + ("Exception Data_Error not raised when Complex_IO.Get " & + "was used to read complex data with incorrect " & + "syntax from the Data_File, data item #" & + Integer'Image(i)); + exception + when Ada.Text_IO.Data_Error => -- OK, expected exception. + Text_IO.Skip_Line(The_File); + when others => + Report.Failed + ("Unexpected exception raised when Complex_IO.Get " & + "was used to read complex data with incorrect " & + "syntax from the Data_File, data item #" & + Integer'Image(i)); + end; + end loop; + + if TC_Verbose then + Report.Comment("Erroneous set of complex values extracted " & + "from data file using Complex_IO, " & + "Procedure Process_Data_File"); + end if; + + + exception + when others => + Report.Failed + ("Unexpected exception raised in Process_Data_File"); + end Process_Data_File; + + + + begin -- Test_Block. + + -- Place complex values into data file. + + Load_Data_File(Data_File); + Text_IO.Close(Data_File); + + if TC_Verbose then + Report.Comment("Data file loaded with Complex values"); + end if; + + -- Read complex values from data file. + + Text_IO.Open(Data_File, Text_IO.In_File, Data_Filename); + Process_Data_File(Data_File); + + if TC_Verbose then + Report.Comment("Complex values extracted from data file"); + end if; + + + + -- Verify versions of Procedures Put and Get for Strings. + + declare + TC_String_Array : array (1..Number_Of_Complex_Items) + of String(1..15) := (others =>(others => ' ')); + begin + + -- Place complex values into strings using the Procedure Put. + + for i in 1..Number_Of_Complex_Items loop + C_IO.Put(To => TC_String_Array(i), + Item => Complex_Array(i), + Aft => 1, + Exp => 0); + end loop; + + if TC_Verbose then + Report.Comment("Complex values placed into string array"); + end if; + + -- Check the format of the strings containing a complex number. + -- The resulting strings are of 15 character length, with the + -- real component left justified within the string, followed by + -- a comma, and with the imaginary component and closing + -- parenthesis right justified in the string, with blank fill + -- for the balance of the string. + + if TC_String_Array(1) /= "(3.0, 9.0)" or + TC_String_Array(2) /= "(4.0, 7.0)" or + TC_String_Array(3) /= "(5.0, 6.0)" or + TC_String_Array(4) /= "(6.0, 3.0)" or + TC_String_Array(5) /= "(2.0, 5.0)" or + TC_String_Array(6) /= "(3.0, 7.0)" + then + Report.Failed("Incorrect format for complex values that " & + "have been placed into string variables " & + "using the Complex_IO.Put procedure for " & + "strings"); + end if; + + if TC_Verbose then + Report.Comment("String format of Complex values verified"); + end if; + + -- Get complex values from strings using the Procedure Get. + -- Compare with expected complex values. + + for i in 1..Number_Of_Complex_Items loop + + C_IO.Get(From => TC_String_Array(i), + Item => TC_Complex, + Last => TC_Last_Character_Read); + + if TC_Complex /= Complex_Array(i) then + Report.Failed("Incorrect complex data value obtained " & + "from String following use of Procedures " & + "Put and Get from Strings, Complex_Array " & + "item #" & Integer'Image(i)); + end if; + end loop; + + if TC_Verbose then + Report.Comment("Complex values removed from String array"); + end if; + + -- Verify that Layout_Error is raised if the given string is + -- too short to hold the formatted output. + Layout_Error_On_Put: + declare + Much_Too_Short : String(1..2); + Complex_Value : Complex_Pack.Complex := (5.0, 0.0); + begin + C_IO.Put(Much_Too_Short, Complex_Value); + Report.Failed("Layout_Error not raised by Procedure Put " & + "when the given string was too short to " & + "hold the formatted output"); + exception + when Layout_Error => null; -- OK, expected exception. + when others => + Report.Failed + ("Unexpected exception raised by Procedure Put when " & + "the given string was too short to hold the " & + "formatted output"); + end Layout_Error_On_Put; + + if TC_Verbose then + Report.Comment("Layout Errors verified"); + end if; + + exception + when others => + Report.Failed("Unexpected exception raised during the " & + "evaluation of Put and Get for Strings"); + end; + + + -- Place complex values into strings using a variety of legal + -- complex data formats. + declare + + type String_Ptr is access String; + + TC_Complex_String_Array : + array (1..Number_Of_Complex_Items) of String_Ptr := + (new String'( "(3.0, 9.0 )" ), + new String'( "+4.0 +7.0" ), + new String'( "(5.0 6.0)" ), + new String'( "6.0, 3.0" ), + new String'( " ( 2.0 , 5.0 ) " ), + new String'( "(3.0 7.0)" )); + + -- The following array contains Positive values that correspond + -- to the last character that will be read by Procedure Get when + -- given each of the above strings as input. + + TC_Last_Char_Array : array (1..Number_Of_Complex_Items) + of Positive := (12,10,9,8,20,22); + + begin + + -- Get complex values from strings using the Procedure Get. + -- Compare with expected complex values. + + for i in 1..Number_Of_Complex_Items loop + + C_IO.Get(TC_Complex_String_Array(i).all, + TC_Complex, + TC_Last_Character_Read); + + if TC_Complex /= Complex_Array(i) then + Report.Failed + ("Incorrect complex data value obtained from " & + "Procedure Get with complex data input of: " & + TC_Complex_String_Array(i).all); + end if; + + if TC_Last_Character_Read /= TC_Last_Char_Array(i) then + Report.Failed + ("Incorrect value returned as the last character of " & + "the input string processed by Procedure Get, " & + "string value : " & TC_Complex_String_Array(i).all & + " expected last character value read : " & + Positive'Image(TC_Last_Char_Array(i)) & + " last character value read : " & + Positive'Image(TC_Last_Character_Read)); + end if; + + end loop; + + if TC_Verbose then + Report.Comment("Complex values removed from strings and " & + "verified against expected values"); + end if; + + exception + when others => + Report.Failed("Unexpected exception raised during the " & + "evaluation of Get for Strings"); + end; + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + + -- Delete the external file. + if Ada.Text_IO.Is_Open(Data_File) then + Ada.Text_IO.Delete(Data_File); + else + Ada.Text_IO.Open(Data_File, + Ada.Text_IO.In_File, + Data_Filename); + Ada.Text_IO.Delete(Data_File); + end if; + + exception + + -- Since Use_Error can be raised if, for the specified mode, + -- the environment does not support Text_IO operations, the + -- following handlers are included: + + when Ada.Text_IO.Use_Error => + Report.Not_Applicable ("Use_Error raised on Text_IO Create"); + + when Ada.Text_IO.Name_Error => + Report.Not_Applicable ("Name_Error raised on Text_IO Create"); + + when others => + Report.Failed ("Unexpected exception raised on text file Create"); + + end Test_for_Text_IO_Support; + + Report.Result; + + end CXG1003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1004.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,360 ---- + -- CXG1004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the specified exceptions are raised by the subprograms + -- defined in package Ada.Numerics.Generic_Complex_Elementary_Functions + -- given the prescribed input parameter values. + -- + -- TEST DESCRIPTION: + -- This test checks that specific subprograms defined in the + -- package Ada.Numerics.Generic_Complex_Elementary_Functions raise the + -- exceptions Argument_Error and Constraint_Error when their input + -- parameter value are those specified as causing each exception. + -- In the case of Constraint_Error, the exception will be raised in + -- each test case, provided that the value of the attribute + -- 'Machine_Overflows (for the actual type of package + -- Generic_Complex_Type) is True. + -- + -- APPLICABILITY CRITERIA: + -- This test only applies to implementations supporting the + -- numerics annex. + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. + -- 29 Sep 96 SAIC Incorporated reviewer comments. + -- 02 Jun 98 EDS Replace "_i" with "_One". + --! + + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + with Report; + + procedure CXG1004 is + begin + + Report.Test ("CXG1004", "Check that the specified exceptions are " & + "raised by the subprograms defined in package " & + "Ada.Numerics.Generic_Complex_Elementary_" & + "Functions given the prescribed input " & + "parameter values"); + + Test_Block: + declare + + type Real_Type is new Float; + + TC_Overflows : Boolean := Real_Type'Machine_Overflows; + + package Complex_Pack is + new Ada.Numerics.Generic_Complex_Types(Real_Type); + + package CEF is + new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack); + + use Ada.Numerics, Complex_Pack, CEF; + + Complex_Zero : constant Complex := Compose_From_Cartesian(0.0, 0.0); + Plus_One : constant Complex := Compose_From_Cartesian(1.0, 0.0); + Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0); + Plus_i : constant Complex := Compose_From_Cartesian(i); + Minus_i : constant Complex := Compose_From_Cartesian(-i); + + Complex_Negative_Real : constant Complex := + Compose_From_Cartesian(-4.0, 2.0); + Complex_Negative_Imaginary : constant Complex := + Compose_From_Cartesian(3.0, -5.0); + + TC_Complex : Complex; + + + -- This procedure is used in "Exception Raising" calls below in an + -- attempt to avoid elimination of the subtest through optimization. + + procedure No_Optimize (The_Complex_Number : Complex) is + begin + Report.Comment("No Optimize: Should never be printed " & + Integer'Image(Integer(The_Complex_Number.Im))); + end No_Optimize; + + + begin + + -- Check that the exception Numerics.Argument_Error is raised by the + -- exponentiation operator when the value of the left operand is zero, + -- and the real component of the exponent (or the exponent itself) is + -- zero. + + begin + TC_Complex := "**"(Left => Complex_Zero, Right => Complex_Zero); + Report.Failed("Argument_Error not raised by exponentiation " & + "operator, left operand = complex zero, right " & + "operand = complex zero"); + No_Optimize(TC_Complex); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by exponentiation " & + "operator, left operand = complex zero, right " & + "operand = complex zero"); + end; + + begin + TC_Complex := Complex_Zero**0.0; + Report.Failed("Argument_Error not raised by exponentiation " & + "operator, left operand = complex zero, right " & + "operand = real zero"); + No_Optimize(TC_Complex); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by exponentiation " & + "operator, left operand = complex zero, right " & + "operand = real zero"); + end; + + + begin + TC_Complex := "**"(Left => 0.0, Right => Complex_Zero); + Report.Failed("Argument_Error not raised by exponentiation " & + "operator, left operand = real zero, right " & + "operand = complex zero"); + No_Optimize(TC_Complex); + exception + when Argument_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised by exponentiation " & + "operator, left operand = real zero, right " & + "operand = complex zero"); + end; + + + -- Check that the exception Constraint_Error is raised under the + -- specified circumstances, provided that + -- Complex_Types.Real'Machine_Overflows is True. + + if TC_Overflows then + + -- Raised by Log, when the value of the parameter X is zero. + begin + TC_Complex := Log (X => Complex_Zero); + Report.Failed("Constraint_Error not raised when Function " & + "Log given parameter value of complex zero"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Log given parameter value of complex zero"); + end; + + -- Raised by Cot, when the value of the parameter X is zero. + begin + TC_Complex := Cot (X => Complex_Zero); + Report.Failed("Constraint_Error not raised when Function " & + "Cot given parameter value of complex zero"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Cot given parameter value of complex zero"); + end; + + -- Raised by Coth, when the value of the parameter X is zero. + begin + TC_Complex := Coth (Complex_Zero); + Report.Failed("Constraint_Error not raised when Function " & + "Coth given parameter value of complex zero"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Coth given parameter value of complex zero"); + end; + + -- Raised by the exponentiation operator, when the value of the + -- left operand is zero and the real component of the exponent + -- is negative. + begin + TC_Complex := Complex_Zero**Complex_Negative_Real; + Report.Failed("Constraint_Error not raised when the " & + "exponentiation operator left operand is " & + "complex zero, and the real component of " & + "the exponent is negative"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when the " & + "exponentiation operator left operand is " & + "complex zero, and the real component of " & + "the exponent is negative"); + end; + + -- Raised by the exponentiation operator, when the value of the + -- left operand is zero and the exponent itself (when it is of + -- type real) is negative. + declare + Negative_Exponent : constant Real_Type := -4.0; + begin + TC_Complex := Complex_Zero**Negative_Exponent; + Report.Failed("Constraint_Error not raised when the " & + "exponentiation operator left operand is " & + "complex zero, and the real exponent is " & + "negative"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when the " & + "exponentiation operator left operand is " & + "complex zero, and the real exponent is " & + "negative"); + end; + + -- Raised by Arctan, when the value of the parameter is +i. + begin + TC_Complex := Arctan (Plus_i); + Report.Failed("Constraint_Error not raised when Function " & + "Arctan is given parameter value +i"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arctan is given parameter value +i"); + end; + + -- Raised by Arctan, when the value of the parameter is -i. + begin + TC_Complex := Arctan (Minus_i); + Report.Failed("Constraint_Error not raised when Function " & + "Arctan is given parameter value -i"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arctan is given parameter value -i"); + end; + + -- Raised by Arccot, when the value of the parameter is +i. + begin + TC_Complex := Arccot (Plus_i); + Report.Failed("Constraint_Error not raised when Function " & + "Arccot is given parameter value +i"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arccot is given parameter value +i"); + end; + + -- Raised by Arccot, when the value of the parameter is -i. + begin + TC_Complex := Arccot (Minus_i); + Report.Failed("Constraint_Error not raised when Function " & + "Arccot is given parameter value -i"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arccot is given parameter value -i"); + end; + + -- Raised by Arctanh, when the value of the parameter is +1. + begin + TC_Complex := Arctanh (Plus_One); + Report.Failed("Constraint_Error not raised when Function " & + "Arctanh is given parameter value +1"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arctanh is given parameter value +1"); + end; + + -- Raised by Arctanh, when the value of the parameter is -1. + begin + TC_Complex := Arctanh (Minus_One); + Report.Failed("Constraint_Error not raised when Function " & + "Arctanh is given parameter value -1"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arctanh is given parameter value -1"); + end; + + -- Raised by Arccoth, when the value of the parameter is +1. + begin + TC_Complex := Arccoth (Plus_One); + Report.Failed("Constraint_Error not raised when Function " & + "Arccoth is given parameter value +1"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arccoth is given parameter value +1"); + end; + + -- Raised by Arccoth, when the value of the parameter is -1. + begin + TC_Complex := Arccoth (Minus_One); + Report.Failed("Constraint_Error not raised when Function " & + "Arccoth is given parameter value -1"); + No_Optimize(TC_Complex); + exception + when Constraint_Error => null; -- OK, expected exception. + when others => + Report.Failed("Incorrect exception raised when Function " & + "Arccoth is given parameter value -1"); + end; + + else + Report.Comment + ("Attribute Complex_Pack.Real'Machine_Overflows is False; " & + "evaluation of the complex elementary functions under " & + "specified circumstances was not performed"); + end if; + + + exception + when others => + Report.Failed ("Unexpected exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXG1004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg1005.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,393 ---- + -- CXG1005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the subprograms defined in the package + -- Ada.Numerics.Generic_Complex_Elementary_Functions provide correct + -- results. + -- + -- TEST DESCRIPTION: + -- This test checks that specific subprograms defined in the generic + -- package Generic_Complex_Elementary_Functions are available, and that + -- they provide prescribed results given specific input values. + -- The generic package Ada.Numerics.Generic_Complex_Types is instantiated + -- with a real type (new Float). The resulting new package is used as + -- the generic actual to package Complex_IO. + -- + -- SPECIAL REQUIREMENTS: + -- Implementations for which Float'Signed_Zeros is True must provide + -- a body for ImpDef.Annex_G.Negative_Zero which returns a negative + -- zero. + -- + -- APPLICABILITY CRITERIA + -- This test only applies to implementations that support the + -- numerics annex. + -- + -- + -- + -- CHANGE HISTORY: + -- 06 Dec 94 SAIC ACVC 2.0 + -- 16 Nov 95 SAIC Corrected visibility problems for ACVC 2.0.1. + -- 21 Feb 96 SAIC Incorporated new structure for package Impdef. + -- 29 Sep 96 SAIC Incorporated reviewer comments. + -- + --! + + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + with ImpDef.Annex_G; + with Report; + + procedure CXG1005 is + begin + + Report.Test ("CXG1005", "Check that the subprograms defined in " & + "the package Generic_Complex_Elementary_" & + "Functions provide correct results"); + + Test_Block: + declare + + type Real_Type is new Float; + + TC_Signed_Zeros : Boolean := Real_Type'Signed_Zeros; + + package Complex_Pack is new + Ada.Numerics.Generic_Complex_Types(Real_Type); + + package CEF is + new Ada.Numerics.Generic_Complex_Elementary_Functions(Complex_Pack); + + use Ada.Numerics, Complex_Pack, CEF; + + Complex_Zero : constant Complex := Compose_From_Cartesian( 0.0, 0.0); + Plus_One : constant Complex := Compose_From_Cartesian( 1.0, 0.0); + Minus_One : constant Complex := Compose_From_Cartesian(-1.0, 0.0); + Plus_i : constant Complex := Compose_From_Cartesian(i); + Minus_i : constant Complex := Compose_From_Cartesian(-i); + + Complex_Positive_Real : constant Complex := + Compose_From_Cartesian(4.0, 2.0); + Complex_Positive_Imaginary : constant Complex := + Compose_From_Cartesian(3.0, 5.0); + Complex_Negative_Real : constant Complex := + Compose_From_Cartesian(-4.0, 2.0); + Complex_Negative_Imaginary : constant Complex := + Compose_From_Cartesian(3.0, -5.0); + + + function A_Zero_Result (Z : Complex) return Boolean is + begin + return (Re(Z) = 0.0 and Im(Z) = 0.0); + end A_Zero_Result; + + + -- In order to evaluate complex elementary functions that are + -- prescribed to return a "real" result (meaning that the imaginary + -- component is zero), the Function A_Real_Result is defined. + + function A_Real_Result (Z : Complex) return Boolean is + begin + return Im(Z) = 0.0; + end A_Real_Result; + + + -- In order to evaluate complex elementary functions that are + -- prescribed to return an "imaginary" result (meaning that the real + -- component of the complex number is zero, and the imaginary + -- component is non-zero), the Function An_Imaginary_Result is defined. + + function An_Imaginary_Result (Z : Complex) return Boolean is + begin + return (Re(Z) = 0.0 and Im(Z) /= 0.0); + end An_Imaginary_Result; + + + begin + + -- Check that when the input parameter value is zero, the following + -- functions yield a zero result. + + if not A_Zero_Result( Sqrt(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Sqrt with zero input"); + end if; + + if not A_Zero_Result( Sin(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Sin with zero input"); + end if; + + if not A_Zero_Result( Arcsin(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Arcsin with zero " & + "input"); + end if; + + if not A_Zero_Result( Tan(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Tan with zero input"); + end if; + + if not A_Zero_Result( Arctan(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Arctan with zero " & + "input"); + end if; + + if not A_Zero_Result( Sinh(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Sinh with zero input"); + end if; + + if not A_Zero_Result( Arcsinh(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Arcsinh with zero " & + "input"); + end if; + + if not A_Zero_Result( Tanh(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Tanh with zero input"); + end if; + + if not A_Zero_Result( Arctanh(Complex_Zero) ) then + Report.Failed("Non-zero result from Function Arctanh with zero " & + "input"); + end if; + + + -- Check that when the input parameter value is zero, the following + -- functions yield a result of one. + + if Exp(Complex_Zero) /= Plus_One + then + Report.Failed("Non-zero result from Function Exp with zero input"); + end if; + + if Cos(Complex_Zero) /= Plus_One + then + Report.Failed("Non-zero result from Function Cos with zero input"); + end if; + + if Cosh(Complex_Zero) /= Plus_One + then + Report.Failed("Non-zero result from Function Cosh with zero input"); + end if; + + + -- Check that when the input parameter value is zero, the following + -- functions yield a real result. + + if not A_Real_Result( Arccos(Complex_Zero) ) then + Report.Failed("Non-real result from Function Arccos with zero input"); + end if; + + if not A_Real_Result( Arccot(Complex_Zero) ) then + Report.Failed("Non-real result from Function Arccot with zero input"); + end if; + + + -- Check that when the input parameter value is zero, the following + -- functions yield an imaginary result. + + if not An_Imaginary_Result( Arccoth(Complex_Zero) ) then + Report.Failed("Non-imaginary result from Function Arccoth with " & + "zero input"); + end if; + + + -- Check that when the input parameter value is one, the Sqrt function + -- yields a result of one. + + if Sqrt(Plus_One) /= Plus_One then + Report.Failed("Incorrect result from Function Sqrt with input " & + "value of one"); + end if; + + + -- Check that when the input parameter value is one, the following + -- functions yield a result of zero. + + if not A_Zero_Result( Log(Plus_One) ) then + Report.Failed("Non-zero result from Function Log with input " & + "value of one"); + end if; + + if not A_Zero_Result( Arccos(Plus_One) ) then + Report.Failed("Non-zero result from Function Arccos with input " & + "value of one"); + end if; + + if not A_Zero_Result( Arccosh(Plus_One) ) then + Report.Failed("Non-zero result from Function Arccosh with input " & + "value of one"); + end if; + + + -- Check that when the input parameter value is one, the Arcsin + -- function yields a real result. + + if not A_Real_Result( Arcsin(Plus_One) ) then + Report.Failed("Non-real result from Function Arcsin with input " & + "value of one"); + end if; + + + -- Check that when the input parameter value is minus one, the Sqrt + -- function yields a result of "i", when the sign of the imaginary + -- component of the input parameter is positive (and yields "-i", if + -- the sign on the imaginary component is negative), and the + -- Complex_Types.Real'Signed_Zeros attribute is True. + + if TC_Signed_Zeros then + + declare + Minus_One_With_Pos_Zero_Im_Component : Complex := + Compose_From_Cartesian(-1.0, +0.0); + Minus_One_With_Neg_Zero_Im_Component : Complex := + Compose_From_Cartesian + (-1.0, Real_Type(ImpDef.Annex_G.Negative_Zero)); + begin + + if Sqrt(Minus_One_With_Pos_Zero_Im_Component) /= Plus_i then + Report.Failed("Incorrect result from Function Sqrt, when " & + "input value is minus one with a positive " & + "imaginary component, Signed_Zeros being True"); + end if; + + if Sqrt(Minus_One_With_Neg_Zero_Im_Component) /= Minus_i then + Report.Failed("Incorrect result from Function Sqrt, when " & + "input value is minus one with a negative " & + "imaginary component, Signed_Zeros being True"); + end if; + end; + + else -- Signed_Zeros is False. + + -- Check that when the input parameter value is minus one, the Sqrt + -- function yields a result of "i", when the + -- Complex_Types.Real'Signed_Zeros attribute is False. + + if Sqrt(Minus_One) /= Plus_i then + Report.Failed("Incorrect result from Function Sqrt, when " & + "input value is minus one, Signed_Zeros being " & + "False"); + end if; + + end if; + + + -- Check that when the input parameter value is minus one, the Log + -- function yields an imaginary result. + + if not An_Imaginary_Result( Log(Minus_One) ) then + Report.Failed("Non-imaginary result from Function Log with a " & + "minus one input value"); + end if; + + -- Check that when the input parameter is minus one, the following + -- functions yield a real result. + + if not A_Real_Result( Arcsin(Minus_One) ) then + Report.Failed("Non-real result from Function Arcsin with a " & + "minus one input value"); + end if; + + if not A_Real_Result( Arccos(Minus_One) ) then + Report.Failed("Non-real result from Function Arccos with a " & + "minus one input value"); + end if; + + + -- Check that when the input parameter has a value of +i or -i, the + -- Log function yields an imaginary result. + + if not An_Imaginary_Result( Log(Plus_i) ) then + Report.Failed("Non-imaginary result from Function Log with an " & + "input value of ""+i"""); + end if; + + if not An_Imaginary_Result( Log(Minus_i) ) then + Report.Failed("Non-imaginary result from Function Log with an " & + "input value of ""-i"""); + end if; + + + -- Check that exponentiation by a zero exponent yields the value one. + + if "**"(Left => Compose_From_Cartesian(5.0, 3.0), + Right => Complex_Zero) /= Plus_One or + Complex_Negative_Real**0.0 /= Plus_One or + 15.0**Complex_Zero /= Plus_One + then + Report.Failed("Incorrect result from exponentiation with a zero " & + "exponent"); + end if; + + + -- Check that exponentiation by a unit exponent yields the value of + -- the left operand (as a complex value). + -- Note: a "unit exponent" is considered the complex number (1.0, 0.0) + + if "**"(Complex_Negative_Real, Plus_One) /= + Complex_Negative_Real or + Complex_Negative_Imaginary**Plus_One /= + Complex_Negative_Imaginary or + 4.0**Plus_One /= + Compose_From_Cartesian(4.0, 0.0) + then + Report.Failed("Incorrect result from exponentiation with a unit " & + "exponent"); + end if; + + + -- Check that exponentiation of the value one yields the value one. + + if "**"(Plus_One, Complex_Negative_Imaginary) /= Plus_One or + Plus_One**9.0 /= Plus_One or + 1.0**Complex_Negative_Real /= Plus_One + then + Report.Failed("Incorrect result from exponentiation of the value " & + "One"); + end if; + + + -- Check that exponentiation of the value zero yields the value zero. + begin + if not A_Zero_Result("**"(Complex_Zero, + Complex_Positive_Imaginary)) or + not A_Zero_Result(Complex_Zero**4.0) or + not A_Zero_Result(0.0**Complex_Positive_Real) + then + Report.Failed("Incorrect result from exponentiation of the " & + "value zero"); + end if; + exception + when others => + Report.Failed("Exception raised during the exponentiation of " & + "the complex value zero"); + end; + + + exception + when others => Report.Failed ("Exception raised in Test_Block"); + end Test_Block; + + Report.Result; + + end CXG1005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2001.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,322 ---- + -- CXG2001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the floating point attributes Model_Mantissa, + -- Machine_Mantissa, Machine_Radix, and Machine_Rounds + -- are properly reported. + -- + -- TEST DESCRIPTION: + -- This test uses a generic package to compute and check the + -- values of the Machine_ attributes listed above. The + -- generic package is instantiated with the standard FLOAT + -- type and a floating point type for the maximum number + -- of digits of precision. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- + -- + -- CHANGE HISTORY: + -- 26 JAN 96 SAIC Initial Release for 2.1 + -- + --! + + -- References: + -- + -- "Algorithms To Reveal Properties of Floating-Point Arithmetic" + -- Michael A. Malcolm; CACM November 1972; pgs 949-951. + -- + -- Software Manual for Elementary Functions; W. J. Cody and W. Waite; + -- Prentice-Hall; 1980 + ----------------------------------------------------------------------- + -- + -- This test relies upon the fact that + -- (A+2.0)-A is not necessarily 2.0. If A is large enough then adding + -- a small value to A does not change the value of A. Consider the case + -- where we have a decimal based floating point representation with 4 + -- digits of precision. A floating point number would logically be + -- represented as "DDDD * 10 ** exp" where D is a value in the range 0..9. + -- The first loop of the test starts A at 2.0 and doubles it until + -- ((A+1.0)-A)-1.0 is no longer zero. For our decimal floating point + -- number this will be 1638 * 10**1 (the value 16384 rounded or truncated + -- to fit in 4 digits). + -- The second loop starts B at 2.0 and keeps doubling B until (A+B)-A is + -- no longer 0. This will keep looping until B is 8.0 because that is + -- the first value where rounding (assuming our machine rounds and addition + -- employs a guard digit) will change the upper 4 digits of the result: + -- 1638_ + -- + 8 + -- ------- + -- 1639_ + -- Without rounding the second loop will continue until + -- B is 16: + -- 1638_ + -- + 16 + -- ------- + -- 1639_ + -- + -- The radix is then determined by (A+B)-A which will give 10. + -- + -- The use of Tmp and ITmp in the test is to force values to be + -- stored into memory in the event that register precision is greater + -- than the stored precision of the floating point values. + -- + -- + -- The test for rounding is (ignoring the temporary variables used to + -- get the stored precision) is + -- Rounds := A + Radix/2.0 - A /= 0.0 ; + -- where A is the value determined in the first step that is the smallest + -- power of 2 such that A + 1.0 = A. This means that the true value of + -- A has one more digit in its value than 'Machine_Mantissa. + -- This check will detect the case where a value is always rounded. + -- There is an additional case where values are rounded to the nearest + -- even value. That is referred to as IEEE style rounding in the test. + -- + ----------------------------------------------------------------------- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2001 is + Verbose : constant Boolean := False; + + -- if one of the attribute computation loops exceeds Max_Iterations + -- it is most likely due to the compiler reordering an expression + -- that should not be reordered. + Illegal_Optimization : exception; + Max_Iterations : constant := 10_000; + + generic + type Real is digits <>; + package Chk_Attrs is + procedure Do_Test; + end Chk_Attrs; + + package body Chk_Attrs is + package EF is new Ada.Numerics.Generic_Elementary_Functions (Real); + function Log (X : Real) return Real renames EF.Log; + + + -- names used in paper + Radix : Integer; -- Beta + Mantissa_Digits : Integer; -- t + Rounds : Boolean; -- RND + + -- made global to Determine_Attributes to help thwart optimization + A, B : Real := 2.0; + Tmp, Tmpa, Tmp1 : Real; + ITmp : Integer; + Half_Radix : Real; + + -- special constants - not declared as constants so that + -- the "stored" precision will be used instead of a "register" + -- precision. + Zero : Real := 0.0; + One : Real := 1.0; + Two : Real := 2.0; + + + procedure Thwart_Optimization is + -- the purpose of this procedure is to reference the + -- global variables used by Determine_Attributes so + -- that the compiler is not likely to keep them in + -- a higher precision register for their entire lifetime. + begin + if Report.Ident_Bool (False) then + -- never executed + A := A + 5.0; + B := B + 6.0; + Tmp := Tmp + 1.0; + Tmp1 := Tmp1 + 2.0; + Tmpa := Tmpa + 2.0; + One := 12.34; Two := 56.78; Zero := 90.12; + end if; + end Thwart_Optimization; + + + -- determines values for Radix, Mantissa_Digits, and Rounds + -- This is mostly a straight translation of the C code. + -- The only significant addition is the iteration count + -- to prevent endless looping if things are really screwed up. + procedure Determine_Attributes is + Iterations : Integer; + begin + Rounds := True; + + Iterations := 0; + Tmp := Real'Machine (((A + One) - A) - One); + while Tmp = Zero loop + A := Real'Machine(A + A); + Tmp := Real'Machine(A + One); + Tmp1 := Real'Machine(Tmp - A); + Tmp := Real'Machine(Tmp1 - One); + + Iterations := Iterations + 1; + if Iterations > Max_Iterations then + raise Illegal_Optimization; + end if; + end loop; + + Iterations := 0; + Tmp := Real'Machine(A + B); + ITmp := Integer (Tmp - A); + while ITmp = 0 loop + B := Real'Machine(B + B); + Tmp := Real'Machine(A + B); + ITmp := Integer (Tmp - A); + + Iterations := Iterations + 1; + if Iterations > Max_Iterations then + raise Illegal_Optimization; + end if; + end loop; + + Radix := ITmp; + + Mantissa_Digits := 0; + B := 1.0; + Tmp := Real'Machine(((B + One) - B) - One); + Iterations := 0; + while (Tmp = Zero) loop + Mantissa_Digits := Mantissa_Digits + 1; + B := B * Real (Radix); + Tmp := Real'Machine(B + One); + Tmp1 := Real'Machine(Tmp - B); + Tmp := Real'Machine(Tmp1 - One); + + Iterations := Iterations + 1; + if Iterations > Max_Iterations then + raise Illegal_Optimization; + end if; + end loop; + + Rounds := False; + Half_Radix := Real (Radix) / Two; + Tmp := Real'Machine(A + Half_Radix); + Tmp1 := Real'Machine(Tmp - A); + if (Tmp1 /= Zero) then + Rounds := True; + end if; + Tmpa := Real'Machine(A + Real (Radix)); + Tmp := Real'Machine(Tmpa + Half_Radix); + if not Rounds and (Tmp - TmpA /= Zero) then + Rounds := True; + if Verbose then + Report.Comment ("IEEE style rounding"); + end if; + end if; + + exception + when others => + Thwart_Optimization; + raise; + end Determine_Attributes; + + + procedure Do_Test is + Show_Results : Boolean := Verbose; + Min_Mantissa_Digits : Integer; + begin + -- compute the actual Machine_* attribute values + Determine_Attributes; + + if Real'Machine_Radix /= Radix then + Report.Failed ("'Machine_Radix incorrectly reports" & + Integer'Image (Real'Machine_Radix)); + Show_Results := True; + end if; + + if Real'Machine_Mantissa /= Mantissa_Digits then + Report.Failed ("'Machine_Mantissa incorrectly reports" & + Integer'Image (Real'Machine_Mantissa)); + Show_Results := True; + end if; + + if Real'Machine_Rounds /= Rounds then + Report.Failed ("'Machine_Rounds incorrectly reports " & + Boolean'Image (Real'Machine_Rounds)); + Show_Results := True; + end if; + + if Show_Results then + Report.Comment ("computed Machine_Mantissa is" & + Integer'Image (Mantissa_Digits)); + Report.Comment ("computed Radix is" & + Integer'Image (Radix)); + Report.Comment ("computed Rounds is " & + Boolean'Image (Rounds)); + end if; + + -- check the model attributes against the machine attributes + -- G.2.2(3)/3;6.0 + if Real'Model_Mantissa > Real'Machine_Mantissa then + Report.Failed ("model mantissa > machine mantissa"); + end if; + + -- G.2.2(3)/2;6.0 + -- 'Model_Mantissa >= ceiling(d*log(10)/log(radix))+1 + Min_Mantissa_Digits := + Integer ( + Real'Ceiling ( + Real(Real'Digits) * Log(10.0) / Log(Real(Real'Machine_Radix)) + ) ) + 1; + if Real'Model_Mantissa < Min_Mantissa_Digits then + Report.Failed ("Model_Mantissa [" & + Integer'Image (Real'Model_Mantissa) & + "] < minimum mantissa digits [" & + Integer'Image (Min_Mantissa_Digits) & + "]"); + end if; + + exception + when Illegal_Optimization => + Report.Failed ("illegal optimization of" & + " floating point expression"); + end Do_Test; + end Chk_Attrs; + + package Chk_Float is new Chk_Attrs (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package Chk_A_Long_Float is new Chk_Attrs (A_Long_Float); + begin + Report.Test ("CXG2001", + "Check the attributes Model_Mantissa," & + " Machine_Mantissa, Machine_Radix," & + " and Machine_Rounds"); + + Report.Comment ("checking Standard.Float"); + Chk_Float.Do_Test; + + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + Chk_A_Long_Float.Do_Test; + + Report.Result; + end CXG2001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2002.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,468 ---- + -- CXG2002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex "abs" or modulus function returns + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test uses a generic package to compute and check the + -- values of the modulus function. In addition, a non-generic + -- copy of this package is used to check the non-generic package + -- Ada.Numerics.Complex_Types. + -- Of special interest is the case where either the real or + -- the imaginary part of the argument is very large while the + -- other part is very small or 0. + -- We want to check that the value is computed such that + -- an overflow does not occur. If computed directly from the + -- definition + -- abs (x+yi) = sqrt(x**2 + y**2) + -- then overflow or underflow is much more likely than if the + -- argument is normalized first. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 31 JAN 96 SAIC Initial release for 2.1 + -- 02 JUN 98 EDS Add parens to intermediate calculations. + --! + + -- + -- Reference: + -- Problems and Methodologies in Mathematical Software Production; + -- editors: P. C. Messina and A Murli; + -- Lecture Notes in Computer Science + -- Volume 142 + -- Springer Verlag 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Complex_Types; + procedure CXG2002 is + Verbose : constant Boolean := False; + Maximum_Relative_Error : constant := 3.0; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Types is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real := Maximum_Relative_Error) is + Rel_Error, + Abs_Error, + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Expected - Actual) & + " max_err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Do_Test is + Z : Complex; + X : Real; + T : Real; + begin + + --- test 1 --- + begin + T := Real'Safe_Last; + Z := T + 0.0*i; + X := abs Z; + Check (X, T, "test 1 -- abs(bigreal + 0i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + begin + T := Real'Safe_Last; + Z := 0.0 + T*i; + X := Modulus (Z); + Check (X, T, "test 2 -- abs(0 + bigreal*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + begin + Z := 3.0 + 4.0*i; + X := abs Z; + Check (X, 5.0 , "test 3 -- abs(3 + 4*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + S : Real; + begin + S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3); + Z := 3.0 * S + 4.0*S*i; + X := abs Z; + Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S", + 5.0*Real'Model_Epsilon); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + begin + T := Real'Model_Small; + Z := T + 0.0*i; + X := abs Z; + Check (X, T , "test 5 -- abs(small + 0*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + begin + T := Real'Model_Small; + Z := 0.0 + T*i; + X := abs Z; + Check (X, T , "test 6 -- abs(0 + small*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 --- + declare + S : Real; + begin + S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3); + Z := 3.0 * S + 4.0*S*i; + X := abs Z; + Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S", + 5.0*Real'Model_Epsilon); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 7"); + when others => + Report.Failed ("exception in test 7"); + end; + + --- test 8 --- + declare + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + begin + Z := 1.0 + 1.0*i; + X := abs Z; + Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 8"); + when others => + Report.Failed ("exception in test 8"); + end; + + --- test 9 --- + begin + T := 0.0; + Z := T + 0.0*i; + X := abs Z; + Check (X, T , "test 5 -- abs(0 + 0*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 9"); + when others => + Report.Failed ("exception in test 9"); + end; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + --- non generic copy of the above generic package + ----------------------------------------------------------------------- + + package Non_Generic_Check is + subtype Real is Float; + procedure Do_Test; + end Non_Generic_Check; + + package body Non_Generic_Check is + use Ada.Numerics.Complex_Types; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real := Maximum_Relative_Error) is + Rel_Error, + Abs_Error, + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Expected - Actual) & + " max_err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Do_Test is + Z : Complex; + X : Real; + T : Real; + begin + + --- test 1 --- + begin + T := Real'Safe_Last; + Z := T + 0.0*i; + X := abs Z; + Check (X, T, "test 1 -- abs(bigreal + 0i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + begin + T := Real'Safe_Last; + Z := 0.0 + T*i; + X := Modulus (Z); + Check (X, T, "test 2 -- abs(0 + bigreal*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + begin + Z := 3.0 + 4.0*i; + X := abs Z; + Check (X, 5.0 , "test 3 -- abs(3 + 4*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + S : Real; + begin + S := Real(Real'Machine_Radix) ** (Real'Machine_EMax - 3); + Z := 3.0 * S + 4.0*S*i; + X := abs Z; + Check (X, 5.0*S, "test 4 -- abs(3S + 4S*i) for large S", + 5.0*Real'Model_Epsilon); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + begin + T := Real'Model_Small; + Z := T + 0.0*i; + X := abs Z; + Check (X, T , "test 5 -- abs(small + 0*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + begin + T := Real'Model_Small; + Z := 0.0 + T*i; + X := abs Z; + Check (X, T , "test 6 -- abs(0 + small*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 --- + declare + S : Real; + begin + S := Real(Real'Machine_Radix) ** (Real'Model_EMin + 3); + Z := 3.0 * S + 4.0*S*i; + X := abs Z; + Check (X, 5.0*S, "test 7 -- abs(3S + 4S*i) for small S", + 5.0*Real'Model_Epsilon); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 7"); + when others => + Report.Failed ("exception in test 7"); + end; + + --- test 8 --- + declare + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + begin + Z := 1.0 + 1.0*i; + X := abs Z; + Check (X, Sqrt2 , "test 8 -- abs(1 + 1*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 8"); + when others => + Report.Failed ("exception in test 8"); + end; + + --- test 9 --- + begin + T := 0.0; + Z := T + 0.0*i; + X := abs Z; + Check (X, T , "test 5 -- abs(0 + 0*i)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 9"); + when others => + Report.Failed ("exception in test 9"); + end; + end Do_Test; + end Non_Generic_Check; + + ----------------------------------------------------------------------- + --- end of "manual instantiation" + ----------------------------------------------------------------------- + package Chk_Float is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package Chk_A_Long_Float is new Generic_Check (A_Long_Float); + begin + Report.Test ("CXG2002", + "Check the accuracy of the complex modulus" & + " function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + Chk_Float.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + Chk_A_Long_Float.Do_Test; + + if Verbose then + Report.Comment ("checking non-generic package"); + end if; + Non_Generic_Check.Do_Test; + Report.Result; + end CXG2002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2003.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,701 ---- + -- CXG2003.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sqrt function returns + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test contains three test packages that are almost + -- identical. The first two packages differ only in the + -- floating point type that is being tested. The first + -- and third package differ only in whether the generic + -- elementary functions package or the pre-instantiated + -- package is used. + -- The test package is not generic so that the arguments + -- and expected results for some of the test values + -- can be expressed as universal real instead of being + -- computed at runtime. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 2 FEB 96 SAIC Initial release for 2.1 + -- 18 AUG 96 SAIC Made Check consistent with other tests. + -- + --! + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + with Ada.Numerics.Elementary_Functions; + procedure CXG2003 is + Verbose : constant Boolean := False; + + package Float_Check is + subtype Real is Float; + procedure Do_Test; + end Float_Check; + + package body Float_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Log (X : Real) return Real renames + Elementary_Functions.Log; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + + -- The default Maximum Relative Error is the value specified + -- in the LRM. + Default_MRE : constant Real := 2.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real := Default_MRE) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Argument_Range_Check (A, B : Real; + Test : String) is + -- test a logarithmically distributed selection of + -- arguments selected from the range A to B. + X : Real; + Expected : Real; + Y : Real; + C : Real := Log(B/A); + Max_Samples : constant := 1000; + + begin + for I in 1..Max_Samples loop + Expected := A * Exp(C * Real (I) / Real (Max_Samples)); + X := Expected * Expected; + Y := Sqrt (X); + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (Y, Expected, + "test " & Test & " -" & + Integer'Image (I) & + " of argument range", + 3.0); + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check"); + when others => + Report.Failed ("exception in argument range check"); + end Argument_Range_Check; + + procedure Do_Test is + begin + + --- test 1 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Real'Machine_Radix) ** T; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := (Real'Model_EMin + 1) / 2; + X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Real'Machine_Radix) ** T; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + X : constant := 1.0; + Expected : constant := 1.0; + Y : Real; + begin + Y := Sqrt(X); + Check (Y, Expected, "test 3 -- sqrt(1.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + X : constant := 0.0; + Expected : constant := 0.0; + Y : Real; + begin + Y := Sqrt(X); + Check (Y, Expected, "test 4 -- sqrt(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + declare + X : constant := -1.0; + Y : Real; + begin + Y := Sqrt(X); + -- the following code should not be executed. + -- The call to Check is to keep the call to Sqrt from + -- appearing to be dead code. + Check (Y, -1.0, "test 5 -- sqrt(-1)" ); + Report.Failed ("test 5 - argument_error expected"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when Ada.Numerics.Argument_Error => + if Verbose then + Report.Comment ("test 5 correctly got argument_error"); + end if; + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : constant := Ada.Numerics.Pi ** 2; + Expected : constant := Ada.Numerics.Pi; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 6 -- sqrt(pi**2)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 & 8 --- + Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), + 1.0, + "7"); + Argument_Range_Check (1.0, + Sqrt(Real(Real'Machine_Radix)), + "8"); + end Do_Test; + end Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + + + package A_Long_Float_Check is + subtype Real is A_Long_Float; + procedure Do_Test; + end A_Long_Float_Check; + + package body A_Long_Float_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Log (X : Real) return Real renames + Elementary_Functions.Log; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + + -- The default Maximum Relative Error is the value specified + -- in the LRM. + Default_MRE : constant Real := 2.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real := Default_MRE) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Argument_Range_Check (A, B : Real; + Test : String) is + -- test a logarithmically distributed selection of + -- arguments selected from the range A to B. + X : Real; + Expected : Real; + Y : Real; + C : Real := Log(B/A); + Max_Samples : constant := 1000; + + begin + for I in 1..Max_Samples loop + Expected := A * Exp(C * Real (I) / Real (Max_Samples)); + X := Expected * Expected; + Y := Sqrt (X); + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (Y, Expected, + "test " & Test & " -" & + Integer'Image (I) & + " of argument range", + 3.0); + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check"); + when others => + Report.Failed ("exception in argument range check"); + end Argument_Range_Check; + + + procedure Do_Test is + begin + + --- test 1 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Real'Machine_Radix) ** T; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := (Real'Model_EMin + 1) / 2; + X : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Real'Machine_Radix) ** T; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + X : constant := 1.0; + Expected : constant := 1.0; + Y : Real; + begin + Y := Sqrt(X); + Check (Y, Expected, "test 3 -- sqrt(1.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + X : constant := 0.0; + Expected : constant := 0.0; + Y : Real; + begin + Y := Sqrt(X); + Check (Y, Expected, "test 4 -- sqrt(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + declare + X : constant := -1.0; + Y : Real; + begin + Y := Sqrt(X); + -- the following code should not be executed. + -- The call to Check is to keep the call to Sqrt from + -- appearing to be dead code. + Check (Y, -1.0, "test 5 -- sqrt(-1)" ); + Report.Failed ("test 5 - argument_error expected"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when Ada.Numerics.Argument_Error => + if Verbose then + Report.Comment ("test 5 correctly got argument_error"); + end if; + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : constant := Ada.Numerics.Pi ** 2; + Expected : constant := Ada.Numerics.Pi; + Y : Real; + begin + Y := Sqrt (X); + Check (Y, Expected, "test 6 -- sqrt(pi**2)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 & 8 --- + Argument_Range_Check (1.0/Sqrt(Real(Real'Machine_Radix)), + 1.0, + "7"); + Argument_Range_Check (1.0, + Sqrt(Real(Real'Machine_Radix)), + "8"); + end Do_Test; + end A_Long_Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + package Non_Generic_Check is + procedure Do_Test; + end Non_Generic_Check; + + package body Non_Generic_Check is + package EF renames + Ada.Numerics.Elementary_Functions; + subtype Real is Float; + + -- The default Maximum Relative Error is the value specified + -- in the LRM. + Default_MRE : constant Real := 2.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real := Default_MRE) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + + procedure Argument_Range_Check (A, B : Float; + Test : String) is + -- test a logarithmically distributed selection of + -- arguments selected from the range A to B. + X : Float; + Expected : Float; + Y : Float; + C : Float := EF.Log(B/A); + Max_Samples : constant := 1000; + + begin + for I in 1..Max_Samples loop + Expected := A * EF.Exp(C * Float (I) / Float (Max_Samples)); + X := Expected * Expected; + Y := EF.Sqrt (X); + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (Y, Expected, + "test " & Test & " -" & + Integer'Image (I) & + " of argument range", + 3.0); + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check"); + when others => + Report.Failed ("exception in argument range check"); + end Argument_Range_Check; + + + procedure Do_Test is + begin + + --- test 1 --- + declare + T : constant := (Float'Machine_EMax - 1) / 2; + X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Float'Machine_Radix) ** T; + Y : Float; + begin + Y := EF.Sqrt (X); + Check (Y, Expected, "test 1 -- sqrt(radix**((emax-1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := (Float'Model_EMin + 1) / 2; + X : constant := (1.0 * Float'Machine_Radix) ** (2 * T); + Expected : constant := (1.0 * Float'Machine_Radix) ** T; + Y : Float; + begin + Y := EF.Sqrt (X); + Check (Y, Expected, "test 2 -- sqrt(radix**((emin+1)/2))"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + X : constant := 1.0; + Expected : constant := 1.0; + Y : Float; + begin + Y := EF.Sqrt(X); + Check (Y, Expected, "test 3 -- sqrt(1.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + X : constant := 0.0; + Expected : constant := 0.0; + Y : Float; + begin + Y := EF.Sqrt(X); + Check (Y, Expected, "test 4 -- sqrt(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + declare + X : constant := -1.0; + Y : Float; + begin + Y := EF.Sqrt(X); + -- the following code should not be executed. + -- The call to Check is to keep the call to Sqrt from + -- appearing to be dead code. + Check (Y, -1.0, "test 5 -- sqrt(-1)" ); + Report.Failed ("test 5 - argument_error expected"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when Ada.Numerics.Argument_Error => + if Verbose then + Report.Comment ("test 5 correctly got argument_error"); + end if; + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : constant := Ada.Numerics.Pi ** 2; + Expected : constant := Ada.Numerics.Pi; + Y : Float; + begin + Y := EF.Sqrt (X); + Check (Y, Expected, "test 6 -- sqrt(pi**2)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 & 8 --- + Argument_Range_Check (1.0/EF.Sqrt(Float(Float'Machine_Radix)), + 1.0, + "7"); + Argument_Range_Check (1.0, + EF.Sqrt(Float(Float'Machine_Radix)), + "8"); + end Do_Test; + end Non_Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + begin + Report.Test ("CXG2003", + "Check the accuracy of the sqrt function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking non-generic package"); + end if; + + Non_Generic_Check.Do_Test; + + Report.Result; + end CXG2003; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2004.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,499 ---- + -- CXG2004.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the sin and cos functions return + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both float and a long float type. + -- The test for each floating point type is divided into + -- the following parts: + -- Special value checks where the result is a known constant. + -- Checks using an identity relationship. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 13 FEB 96 SAIC Initial release for 2.1 + -- 22 APR 96 SAIC Changed to generic implementation. + -- 18 AUG 96 SAIC Improvements to commentary. + -- 23 OCT 96 SAIC Exact results are not required unless the + -- cycle is specified. + -- 28 FEB 97 PWB.CTA Removed checks where cycle 2.0*Pi is specified + -- 02 JUN 98 EDS Revised calculations to ensure that X is exactly + -- three times Y per advice of numerics experts. + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + -- The sin and cos checks are translated directly from + -- the netlib FORTRAN code that was written by W. Cody. + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + with Ada.Numerics.Elementary_Functions; + procedure CXG2004 is + Verbose : constant Boolean := False; + Number_Samples : constant := 1000; + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + + function Sin (X : Real) return Real renames + Elementary_Functions.Sin; + function Cos (X : Real) return Real renames + Elementary_Functions.Cos; + function Sin (X, Cycle : Real) return Real renames + Elementary_Functions.Sin; + function Cos (X, Cycle : Real) return Real renames + Elementary_Functions.Cos; + + Accuracy_Error_Reported : Boolean := False; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Rel_Error, + Abs_Error, + Max_Error : Real; + begin + + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + + -- in addition to the relative error checks we apply the + -- criteria of G.2.4(16) + if abs (Actual) > 1.0 then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & " result > 1.0"); + elsif abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & + Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Sin_Check (A, B : Real; + Arg_Range : String) is + -- test a selection of + -- arguments selected from the range A to B. + -- + -- This test uses the identity + -- sin(x) = sin(x/3)*(3 - 4 * sin(x/3)**2) + -- + -- Note that in this test we must take into account the + -- error in the calculation of the expected result so + -- the maximum relative error is larger than the + -- accuracy required by the ARM. + + X, Y, ZZ : Real; + Actual, Expected : Real; + MRE : Real; + Ran : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1 .. Number_Samples loop + -- Evenly distributed selection of arguments + Ran := Real (I) / Real (Number_Samples); + + -- make sure x and x/3 are both exactly representable + -- on the machine. See "Implementation and Testing of + -- Function Software" page 44. + X := (B - A) * Ran + A; + Y := Real'Leading_Part + ( X/3.0, + Real'Machine_Mantissa - Real'Exponent (3.0) ); + X := Y * 3.0; + + Actual := Sin (X); + + ZZ := Sin(Y); + Expected := ZZ * (3.0 - 4.0 * ZZ * ZZ); + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + -- See Cody pp 139-141. + MRE := 4.0; + + Check (Actual, Expected, + "sin test of range" & Arg_Range & + Integer'Image (I), + MRE); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in sin check"); + when others => + Report.Failed ("exception in sin check"); + end Sin_Check; + + + + procedure Cos_Check (A, B : Real; + Arg_Range : String) is + -- test a selection of + -- arguments selected from the range A to B. + -- + -- This test uses the identity + -- cos(x) = cos(x/3)*(4 * cos(x/3)**2 - 3) + -- + -- Note that in this test we must take into account the + -- error in the calculation of the expected result so + -- the maximum relative error is larger than the + -- accuracy required by the ARM. + + X, Y, ZZ : Real; + Actual, Expected : Real; + MRE : Real; + Ran : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1 .. Number_Samples loop + -- Evenly distributed selection of arguments + Ran := Real (I) / Real (Number_Samples); + + -- make sure x and x/3 are both exactly representable + -- on the machine. See "Implementation and Testing of + -- Function Software" page 44. + X := (B - A) * Ran + A; + Y := Real'Leading_Part + ( X/3.0, + Real'Machine_Mantissa - Real'Exponent (3.0) ); + X := Y * 3.0; + + Actual := Cos (X); + + ZZ := Cos(Y); + Expected := ZZ * (4.0 * ZZ * ZZ - 3.0); + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + -- See Cody pp 141-143. + MRE := 6.0; + + Check (Actual, Expected, + "cos test of range" & Arg_Range & + Integer'Image (I), + MRE); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in cos check"); + when others => + Report.Failed ("exception in cos check"); + end Cos_Check; + + + procedure Special_Angle_Checks is + type Data_Point is + record + Degrees, + Radians, + Sine, + Cosine : Real; + Sin_Result_Error, + Cos_Result_Error : Boolean; + end record; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + + -- the values in the following table only involve static + -- expressions to minimize any loss of precision. However, + -- there are two sources of error that must be accounted for + -- in the following tests. + -- First, when a cycle is not specified there can be a roundoff + -- error in the value of Pi used. This error does not apply + -- when a cycle of 2.0 * Pi is explicitly provided. + -- Second, the expected results that involve sqrt values also + -- have a potential roundoff error. + -- The amount of error due to error in the argument is computed + -- as follows: + -- sin(x+err) = sin(x)*cos(err) + cos(x)*sin(err) + -- ~= sin(x) + err * cos(x) + -- similarly for cos the error due to error in the argument is + -- computed as follows: + -- cos(x+err) = cos(x)*cos(err) - sin(x)*sin(err) + -- ~= cos(x) - err * sin(x) + -- In both cases the term "err" is bounded by 0.5 * argument. + + Test_Data : constant Test_Data_Type := ( + -- degrees radians sine cosine sin_er cos_er test # + ( 0.0, 0.0, 0.0, 1.0, False, False ), -- 1 + ( 30.0, Pi/6.0, 0.5, Sqrt3/2.0, False, True ), -- 2 + ( 60.0, Pi/3.0, Sqrt3/2.0, 0.5, True, False ), -- 3 + ( 90.0, Pi/2.0, 1.0, 0.0, False, False ), -- 4 + (120.0, 2.0*Pi/3.0, Sqrt3/2.0, -0.5, True, False ), -- 5 + (150.0, 5.0*Pi/6.0, 0.5, -Sqrt3/2.0, False, True ), -- 6 + (180.0, Pi, 0.0, -1.0, False, False ), -- 7 + (210.0, 7.0*Pi/6.0, -0.5, -Sqrt3/2.0, False, True ), -- 8 + (240.0, 8.0*Pi/6.0, -Sqrt3/2.0, -0.5, True, False ), -- 9 + (270.0, 9.0*Pi/6.0, -1.0, 0.0, False, False ), -- 10 + (300.0, 10.0*Pi/6.0, -Sqrt3/2.0, 0.5, True, False ), -- 11 + (330.0, 11.0*Pi/6.0, -0.5, Sqrt3/2.0, False, True ), -- 12 + (360.0, 2.0*Pi, 0.0, 1.0, False, False ), -- 13 + ( 45.0, Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 14 + (135.0, 3.0*Pi/4.0, Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 15 + (225.0, 5.0*Pi/4.0, -Sqrt2/2.0, -Sqrt2/2.0, True, True ), -- 16 + (315.0, 7.0*Pi/4.0, -Sqrt2/2.0, Sqrt2/2.0, True, True ), -- 17 + (405.0, 9.0*Pi/4.0, Sqrt2/2.0, Sqrt2/2.0, True, True ) ); -- 18 + + + Y : Real; + Sin_Arg_Err, + Cos_Arg_Err, + Sin_Result_Err, + Cos_Result_Err : Real; + begin + for I in Test_Data'Range loop + -- compute error components + Sin_Arg_Err := abs Test_Data (I).Cosine * + abs Test_Data (I).Radians / 2.0; + Cos_Arg_Err := abs Test_Data (I).Sine * + abs Test_Data (I).Radians / 2.0; + + if Test_Data (I).Sin_Result_Error then + Sin_Result_Err := 0.5; + else + Sin_Result_Err := 0.0; + end if; + + if Test_Data (I).Cos_Result_Error then + Cos_Result_Err := 1.0; + else + Cos_Result_Err := 0.0; + end if; + + + + Y := Sin (Test_Data (I).Radians); + Check (Y, Test_Data (I).Sine, + "test" & Integer'Image (I) & " sin(r)", + 2.0 + Sin_Arg_Err + Sin_Result_Err); + Y := Cos (Test_Data (I).Radians); + Check (Y, Test_Data (I).Cosine, + "test" & Integer'Image (I) & " cos(r)", + 2.0 + Cos_Arg_Err + Cos_Result_Err); + Y := Sin (Test_Data (I).Degrees, 360.0); + Check (Y, Test_Data (I).Sine, + "test" & Integer'Image (I) & " sin(d,360)", + 2.0 + Sin_Result_Err); + Y := Cos (Test_Data (I).Degrees, 360.0); + Check (Y, Test_Data (I).Cosine, + "test" & Integer'Image (I) & " cos(d,360)", + 2.0 + Cos_Result_Err); + --pwb-math Y := Sin (Test_Data (I).Radians, 2.0*Pi); + --pwb-math Check (Y, Test_Data (I).Sine, + --pwb-math "test" & Integer'Image (I) & " sin(r,2pi)", + --pwb-math 2.0 + Sin_Result_Err); + --pwb-math Y := Cos (Test_Data (I).Radians, 2.0*Pi); + --pwb-math Check (Y, Test_Data (I).Cosine, + --pwb-math "test" & Integer'Image (I) & " cos(r,2pi)", + --pwb-math 2.0 + Cos_Result_Err); + end loop; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special angle test"); + when others => + Report.Failed ("exception in special angle test"); + end Special_Angle_Checks; + + + -- check the rule of A.5.1(41);6.0 which requires that the + -- result be exact if the mathematical result is 0.0, 1.0, + -- or -1.0 + procedure Exact_Result_Checks is + type Data_Point is + record + Degrees, + Sine, + Cosine : Real; + end record; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + Test_Data : constant Test_Data_Type := ( + -- degrees sine cosine test # + ( 0.0, 0.0, 1.0 ), -- 1 + ( 90.0, 1.0, 0.0 ), -- 2 + (180.0, 0.0, -1.0 ), -- 3 + (270.0, -1.0, 0.0 ), -- 4 + (360.0, 0.0, 1.0 ), -- 5 + ( 90.0 + 360.0, 1.0, 0.0 ), -- 6 + (180.0 + 360.0, 0.0, -1.0 ), -- 7 + (270.0 + 360.0,-1.0, 0.0 ), -- 8 + (360.0 + 360.0, 0.0, 1.0 ) ); -- 9 + + Y : Real; + begin + for I in Test_Data'Range loop + Y := Sin (Test_Data(I).Degrees, 360.0); + if Y /= Test_Data(I).Sine then + Report.Failed ("exact result for sin(" & + Real'Image (Test_Data(I).Degrees) & + ", 360.0) is not" & + Real'Image (Test_Data(I).Sine) & + " Difference is " & + Real'Image (Y - Test_Data(I).Sine) ); + end if; + + Y := Cos (Test_Data(I).Degrees, 360.0); + if Y /= Test_Data(I).Cosine then + Report.Failed ("exact result for cos(" & + Real'Image (Test_Data(I).Degrees) & + ", 360.0) is not" & + Real'Image (Test_Data(I).Cosine) & + " Difference is " & + Real'Image (Y - Test_Data(I).Cosine) ); + end if; + end loop; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in exact result check"); + when others => + Report.Failed ("exception in exact result check"); + end Exact_Result_Checks; + + + procedure Do_Test is + begin + Special_Angle_Checks; + Sin_Check (0.0, Pi/2.0, "0..pi/2"); + Sin_Check (6.0*Pi, 6.5*Pi, "6pi..6.5pi"); + Cos_Check (7.0*Pi, 7.5*Pi, "7pi..7.5pi"); + Exact_Result_Checks; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2004", + "Check the accuracy of the sin and cos functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + Report.Result; + end CXG2004; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2005.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,204 ---- + -- CXG2005.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that floating point addition and multiplication + -- have the required accuracy. + -- + -- TEST DESCRIPTION: + -- The check for the required precision is essentially a + -- check that a guard digit is used for the operations. + -- This test uses a generic package to check the addition + -- and multiplication results. The + -- generic package is instantiated with the standard FLOAT + -- type and a floating point type for the maximum number + -- of digits of precision. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- + -- + -- CHANGE HISTORY: + -- 14 FEB 96 SAIC Initial Release for 2.1 + -- 16 SEP 99 RLB Repaired to avoid printing thousands of (almost) + -- identical failure messages. + --! + + -- References: + -- + -- Basic Concepts for Computational Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Vol 142 + -- Springer Verlag, 1982 + -- + -- Software Manual for the Elementary Functions + -- William J. Cody and William Waite + -- Prentice-Hall, 1980 + -- + + with System; + with Report; + procedure CXG2005 is + Verbose : constant Boolean := False; + + generic + type Real is digits <>; + package Guard_Digit_Check is + procedure Do_Test; + end Guard_Digit_Check; + + package body Guard_Digit_Check is + -- made global so that the compiler will be more likely + -- to keep the values in memory instead of in higher + -- precision registers. + X, Y, Z : Real; + OneX : Real; + Eps, BN : Real; + + -- special constants - not declared as constants so that + -- the "stored" precision will be used instead of a "register" + -- precision. + Zero : Real := 0.0; + One : Real := 1.0; + Two : Real := 2.0; + + Failure_Count : Natural := 0; + + procedure Thwart_Optimization is + -- the purpose of this procedure is to reference the + -- global variables used by the test so + -- that the compiler is not likely to keep them in + -- a higher precision register for their entire lifetime. + begin + if Report.Ident_Bool (False) then + -- never executed + X := X + 5.0; + Y := Y + 6.0; + Z := Z + 1.0; + Eps := Eps + 2.0; + BN := BN + 2.0; + OneX := X + Y; + One := 12.34; Two := 56.78; Zero := 90.12; + end if; + end Thwart_Optimization; + + + procedure Addition_Test is + begin + for K in 1..10 loop + Eps := Real (K) * Real'Model_Epsilon; + for N in 1.. Real'Machine_EMax - 1 loop + BN := Real(Real'Machine_Radix) ** N; + X := (One + Eps) * BN; + Y := (One - Eps) * BN; + Z := X - Y; -- true value for Z is 2*Eps*BN + + if Z /= Eps*BN + Eps*BN then + Report.Failed ("addition check failed. K=" & + Integer'Image (K) & + " N=" & Integer'Image (N) & + " difference=" & Real'Image (Z - 2.0*Eps*BN) & + " Eps*BN=" & Real'Image (Eps*BN) ); + Failure_Count := Failure_Count + 1; + exit when Failure_Count > K*4; -- Avoid displaying dozens of messages. + end if; + end loop; + end loop; + exception + when others => + Thwart_Optimization; + Report.Failed ("unexpected exception in addition test"); + end Addition_Test; + + + procedure Multiplication_Test is + begin + X := Real (Real'Machine_Radix) ** (Real'Machine_EMax - 1); + OneX := One * X; + Thwart_Optimization; + if OneX /= X then + Report.Failed ("multiplication for large values"); + end if; + + X := Real (Real'Machine_Radix) ** (Real'Model_EMin + 1); + OneX := One * X; + Thwart_Optimization; + if OneX /= X then + Report.Failed ("multiplication for small values"); + end if; + + -- selection of "random" values between 1/radix and radix + Y := One / Real (Real'Machine_Radix); + Z := Real(Real'Machine_Radix) - One/Real(Real'Machine_Radix); + for I in 0..100 loop + X := Y + Real (I) / 100.0 * Z; + OneX := One * X; + Thwart_Optimization; + if OneX /= X then + Report.Failed ("multiplication for case" & Integer'Image (I)); + exit when Failure_Count > 40+8; -- Avoid displaying dozens of messages. + end if; + end loop; + exception + when others => + Thwart_Optimization; + Report.Failed ("unexpected exception in multiplication test"); + end Multiplication_Test; + + + procedure Do_Test is + begin + Addition_Test; + Multiplication_Test; + end Do_Test; + end Guard_Digit_Check; + + package Chk_Float is new Guard_Digit_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package Chk_A_Long_Float is new Guard_Digit_Check (A_Long_Float); + begin + Report.Test ("CXG2005", + "Check the accuracy of floating point" & + " addition and multiplication"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + Chk_Float.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + Chk_A_Long_Float.Do_Test; + + Report.Result; + end CXG2005; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2006.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,281 ---- + -- CXG2006.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex Argument function returns + -- results that are within the error bound allowed. + -- Check that Argument_Error is raised if the Cycle parameter + -- is less than or equal to zero. + -- + -- TEST DESCRIPTION: + -- This test uses a generic package to compute and check the + -- values of the Argument function. + -- Of special interest is the case where either the real or + -- the imaginary part of the parameter is very large while the + -- other part is very small or 0. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 15 FEB 96 SAIC Initial release for 2.1 + -- 03 MAR 97 PWB.CTA Removed checks involving explicit cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + -- + -- Reference: + -- Problems and Methodologies in Mathematical Software Production; + -- editors: P. C. Messina and A Murli; + -- Lecture Notes in Computer Science + -- Volume 142 + -- Springer Verlag 1982 + -- + + with System; + with Report; + with ImpDef.Annex_G; + with Ada.Numerics; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Complex_Types; + procedure CXG2006 is + Verbose : constant Boolean := False; + + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Types is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Cases is + type Data_Point is + record + Re, + Im, + Radians, + Degrees, + Error_Bound : Real; + end record; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + + -- the values in the following table only involve static + -- expressions to minimize errors in precision introduced by the + -- test. For cases where Pi is used in the argument we must + -- allow an extra 1.0*MRE to account for roundoff error in the + -- argument. Where the result involves a square root we allow + -- an extra 0.5*MRE to allow for roundoff error. + Test_Data : constant Test_Data_Type := ( + -- Re Im Radians Degrees Err Test # + (0.0, 0.0, 0.0, 0.0, 4.0 ), -- 1 + (1.0, 0.0, 0.0, 0.0, 4.0 ), -- 2 + (Real'Safe_Last, 0.0, 0.0, 0.0, 4.0 ), -- 3 + (Real'Model_Small, 0.0, 0.0, 0.0, 4.0 ), -- 4 + (1.0, 1.0, Pi/4.0, 45.0, 5.0 ), -- 5 + (1.0, -1.0, -Pi/4.0, -45.0, 5.0 ), -- 6 + (-1.0, -1.0, -3.0*Pi/4.0,-135.0, 5.0 ), -- 7 + (-1.0, 1.0, 3.0*Pi/4.0, 135.0, 5.0 ), -- 8 + (Sqrt3, 1.0, Pi/6.0, 30.0, 5.5 ), -- 9 + (-Sqrt3, 1.0, 5.0*Pi/6.0, 150.0, 5.5 ), -- 10 + (Sqrt3, -1.0, -Pi/6.0, -30.0, 5.5 ), -- 11 + (-Sqrt3, -1.0, -5.0*Pi/6.0,-150.0, 5.5 ), -- 12 + (Real'Model_Small, Real'Model_Small, Pi/4.0, 45.0, 5.0 ), -- 13 + (-Real'Safe_Last, 0.0, Pi, 180.0, 5.0 ), -- 14 + (-Real'Safe_Last, -Real'Model_Small, -Pi,-180.0, 5.0 ), -- 15 + (100000.0, 100000.0, Pi/4.0, 45.0, 5.0 )); -- 16 + + X : Real; + Z : Complex; + begin + for I in Test_Data'Range loop + begin + Z := (Test_Data(I).Re, Test_Data(I).Im); + X := Argument (Z); + Check (X, Test_Data(I).Radians, + "test" & Integer'Image (I) & " argument(z)", + Test_Data (I).Error_Bound); + --pwb-math X := Argument (Z, 2.0*Pi); + --pwb-math Check (X, Test_Data(I).Radians, + --pwb-math "test" & Integer'Image (I) & " argument(z, 2pi)", + --pwb-math Test_Data (I).Error_Bound); + X := Argument (Z, 360.0); + Check (X, Test_Data(I).Degrees, + "test" & Integer'Image (I) & " argument(z, 360)", + Test_Data (I).Error_Bound); + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test" & + Integer'Image (I)); + when others => + Report.Failed ("exception in test" & + Integer'Image (I)); + end; + end loop; + + if Real'Signed_Zeros then + begin + X := Argument ((-1.0, Real(ImpDef.Annex_G.Negative_Zero))); + Check (X, -Pi, "test of arg((-1,-0)", 4.0); + exception + when others => + Report.Failed ("exception in signed zero test"); + end; + end if; + end Special_Cases; + + + procedure Exception_Cases is + -- check that Argument_Error is raised if Cycle is <= 0 + Z : Complex := (1.0, 1.0); + X : Real; + Y : Real; + begin + begin + X := Argument (Z, Cycle => 0.0); + Report.Failed ("no exception for cycle = 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle = 0.0"); + end; + + begin + Y := Argument (Z, Cycle => -3.0); + Report.Failed ("no exception for cycle < 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle < 0.0"); + end; + + if Report.Ident_Int (2) = 1 then + -- optimization thwarting code - never executed + Report.Failed("2=1" & Real'Image (X+Y)); + end if; + end Exception_Cases; + + + procedure Do_Test is + begin + Special_Cases; + Exception_Cases; + end Do_Test; + end Generic_Check; + + package Chk_Float is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package Chk_A_Long_Float is new Generic_Check (A_Long_Float); + begin + Report.Test ("CXG2006", + "Check the accuracy of the complex argument" & + " function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Chk_Float.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + Chk_A_Long_Float.Do_Test; + + Report.Result; + end CXG2006; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2007.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,291 ---- + -- CXG2007.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex Compose_From_Polar function returns + -- results that are within the error bound allowed. + -- Check that Argument_Error is raised if the Cycle parameter + -- is less than or equal to zero. + -- + -- TEST DESCRIPTION: + -- This test uses a generic package to compute and check the + -- values of the Compose_From_Polar function. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 23 FEB 96 SAIC Initial release for 2.1 + -- 23 APR 96 SAIC Fixed error checking + -- 03 MAR 97 PWB.CTA Deleted checks with explicit Cycle => 2.0*Pi + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + with System; + with Report; + with Ada.Numerics; + with Ada.Numerics.Generic_Complex_Types; + procedure CXG2007 is + Verbose : constant Boolean := False; + + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Types is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + Maximum_Relative_Error : constant Real := 3.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real; + Arg_Error : Real) is + -- Arg_Error is additional absolute error that is allowed beyond + -- the MRE to account for error in the result that can be + -- attributed to error in the arguments. + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Small instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + Max_Error := Max_Error + Arg_Error; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MRE : Real; + Arg_Error : Real) is + -- Arg_Error is additional absolute error that is allowed beyond + -- the MRE to account for error in the result that can be + -- attributed to error in the arguments. + begin + Check (Actual.Re, Expected.Re, + Test_Name & " real part", + MRE, Arg_Error); + Check (Actual.Im, Expected.Im, + Test_Name & " imaginary part", + MRE, Arg_Error); + end Check; + + + procedure Special_Cases is + type Data_Point is + record + Re, + Im, + Modulus, + Radians, + Degrees, + Arg_Error : Real; + end record; + + -- shorthand names for various constants + P4 : constant := Pi/4.0; + P6 : constant := Pi/6.0; + + MER2 : constant Real := Real'Model_Epsilon * Sqrt2; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + + -- the values in the following table only involve static + -- expressions so no loss of precision occurs. + Test_Data : constant Test_Data_Type := ( + --Re Im Modulus Radians Degrees Arg_Err + ( 0.0, 0.0, 0.0, 0.0, 0.0, 0.0 ), -- 1 + ( 0.0, 0.0, 0.0, Pi, 180.0, 0.0 ), -- 2 + + ( 1.0, 0.0, 1.0, 0.0, 0.0, 0.0 ), -- 3 + (-1.0, 0.0, -1.0, 0.0, 0.0, 0.0 ), -- 4 + + ( 1.0, 1.0, Sqrt2, P4, 45.0, MER2), -- 5 + (-1.0, 1.0, -Sqrt2, -P4, -45.0, MER2), -- 6 + ( 1.0, -1.0, Sqrt2, -P4, -45.0, MER2), -- 7 + (-1.0, -1.0, -Sqrt2, P4, 45.0, MER2), -- 8 + (-1.0, -1.0, Sqrt2, -3.0*P4,-135.0, MER2), -- 9 + (-1.0, 1.0, Sqrt2, 3.0*P4, 135.0, MER2), -- 10 + ( 1.0, -1.0, -Sqrt2, 3.0*P4, 135.0, MER2), -- 11 + + (-1.0, 0.0, 1.0, Pi, 180.0, 0.0 ), -- 12 + ( 1.0, 0.0, -1.0, Pi, 180.0, 0.0 ) ); -- 13 + + + Z : Complex; + Exp : Complex; + begin + for I in Test_Data'Range loop + begin + Exp := (Test_Data (I).Re, Test_Data (I).Im); + + Z := Compose_From_Polar (Test_Data (I).Modulus, + Test_Data (I).Radians); + Check (Z, Exp, + "test" & Integer'Image (I) & " compose_from_polar(m,r)", + Maximum_Relative_Error, Test_Data (I).Arg_Error); + + --pwb-math Z := Compose_From_Polar (Test_Data (I).Modulus, + --pwb-math Test_Data (I).Radians, + --pwb-math 2.0*Pi); + --pwb-math Check (Z, Exp, + --pwb-math "test" & Integer'Image (I) & " compose_from_polar(m,r,2pi)", + --pwb-math Maximum_Relative_Error, Test_Data (I).Arg_Error); + + Z := Compose_From_Polar (Test_Data (I).Modulus, + Test_Data (I).Degrees, + 360.0); + Check (Z, Exp, + "test" & Integer'Image (I) & " compose_from_polar(m,d,360)", + Maximum_Relative_Error, Test_Data (I).Arg_Error); + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test" & + Integer'Image (I)); + when others => + Report.Failed ("exception in test" & + Integer'Image (I)); + end; + end loop; + end Special_Cases; + + + procedure Exception_Cases is + -- check that Argument_Error is raised if Cycle is <= 0 + Z : Complex; + W : Complex; + begin + begin + Z := Compose_From_Polar (3.0, 0.0, Cycle => 0.0); + Report.Failed ("no exception for cycle = 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle = 0.0"); + end; + + begin + W := Compose_From_Polar (6.0, 1.0, Cycle => -10.0); + Report.Failed ("no exception for cycle < 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle < 0.0"); + end; + + if Report.Ident_Int (1) = 2 then + -- not executed - used to make it appear that we use the + -- results of the above computation + Z := Z * W; + Report.Failed(Real'Image (Z.Re + Z.Im)); + end if; + end Exception_Cases; + + + procedure Do_Test is + begin + Special_Cases; + Exception_Cases; + end Do_Test; + end Generic_Check; + + package Chk_Float is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package Chk_A_Long_Float is new Generic_Check (A_Long_Float); + begin + Report.Test ("CXG2007", + "Check the accuracy of the Compose_From_Polar" & + " function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + Chk_Float.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + Chk_A_Long_Float.Do_Test; + + Report.Result; + end CXG2007; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2008.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,948 ---- + -- CXG2008.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex multiplication and division + -- operations return results that are within the allowed + -- error bound. + -- Check that all the required pure Numerics packages are pure. + -- + -- TEST DESCRIPTION: + -- This test contains three test packages that are almost + -- identical. The first two packages differ only in the + -- floating point type that is being tested. The first + -- and third package differ only in whether the generic + -- complex types package or the pre-instantiated + -- package is used. + -- The test package is not generic so that the arguments + -- and expected results for some of the test values + -- can be expressed as universal real instead of being + -- computed at runtime. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 24 FEB 96 SAIC Initial release for 2.1 + -- 03 JUN 98 EDS Correct the test program's incorrect assumption + -- that Constraint_Error must be raised by complex + -- division by zero, which is contrary to the + -- allowance given by the Ada 95 standard G.1.1(40). + -- 13 MAR 01 RLB Replaced commented out Pure check on non-generic + -- packages, as required by Defect Report + -- 8652/0020 and as reflected in Technical + -- Corrigendum 1. + --! + + ------------------------------------------------------------------------------ + -- Check that the required pure packages are pure by withing them from a + -- pure package. The non-generic versions of those packages are required to + -- be pure by Defect Report 8652/0020, Technical Corrigendum 1 [A.5.1(9/1) and + -- G.1.1(25/1)]. + with Ada.Numerics.Generic_Elementary_Functions; + with Ada.Numerics.Elementary_Functions; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + with Ada.Numerics.Complex_Elementary_Functions; + package CXG2008_0 is + pragma Pure; + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + end CXG2008_0; + + ------------------------------------------------------------------------------ + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Complex_Types; + with CXG2008_0; use CXG2008_0; + procedure CXG2008 is + Verbose : constant Boolean := False; + + package Float_Check is + subtype Real is Float; + procedure Do_Test; + end Float_Check; + + package body Float_Check is + package Complex_Types is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + -- keep track if an accuracy failure has occurred so the test + -- can be short-circuited to avoid thousands of error messages. + Failure_Detected : Boolean := False; + + Mult_MBE : constant Real := 5.0; + Divide_MBE : constant Real := 13.0; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MBE : Real) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; + Abs_Error := MBE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual.Re - Expected.Re) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.re: " & Real'Image (Actual.Re) & + " expected.re: " & Real'Image (Expected.Re) & + " difference.re " & + Real'Image (Actual.Re - Expected.Re) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for real part"); + else + Report.Comment (Test_Name & " passed for real part"); + end if; + end if; + + Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + if abs (Actual.Im - Expected.Im) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.im: " & Real'Image (Actual.Im) & + " expected.im: " & Real'Image (Expected.Im) & + " difference.im " & + Real'Image (Actual.Im - Expected.Im) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for imaginary part"); + else + Report.Comment (Test_Name & " passed for imaginary part"); + end if; + end if; + end Check; + + + procedure Special_Values is + begin + + --- test 1 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : Complex := (0.0, 0.0); + X : Complex := (0.0, 0.0); + Y : Complex := (Big, Big); + Z : Complex; + begin + Z := X * Y; + Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", + Mult_MBE); + Z := Y * X; + Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Expected : Complex := (0.0, 0.0); + Z : Complex; + begin + Z := U * X; + Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + B : Complex := (Big, Big); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := B / X; + Report.Failed ("test 3 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := U / X; + Report.Failed ("test 4 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 4"); + end; + + + --- test 5 --- + declare + X : Complex := (Sqrt2, Sqrt2); + Z : Complex; + Expected : constant Complex := (0.0, 4.0); + begin + Z := X * X; + Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : Complex := Sqrt3 - Sqrt3 * i; + Z : Complex; + Expected : constant Complex := (0.0, -6.0); + begin + Z := X * X; + Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 --- + declare + X : Complex := Sqrt2 + Sqrt2 * i; + Y : Complex := Sqrt2 - Sqrt2 * i; + Z : Complex; + Expected : constant Complex := 0.0 + i; + begin + Z := X / Y; + Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 7"); + when others => + Report.Failed ("exception in test 7"); + end; + end Special_Values; + + + procedure Do_Mult_Div (X, Y : Complex) is + Z : Complex; + Args : constant String := + "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & + "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; + begin + Z := (X * X) / X; + Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / X; + Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / Y; + Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); + when others => + Report.Failed ("exception in Do_Mult_Div for " & Args); + end Do_Mult_Div; + + -- select complex values X and Y where the real and imaginary + -- parts are selected from the ranges (1/radix..1) and + -- (1..radix). This translates into quite a few combinations. + procedure Mult_Div_Check is + Samples : constant := 17; + Radix : constant Real := Real(Real'Machine_Radix); + Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); + Low_Sample : Real; -- (1/radix .. 1) + High_Sample : Real; -- (1 .. radix) + Sample : array (1..2) of Real; + X, Y : Complex; + begin + for I in 1 .. Samples loop + Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + + Inv_Radix; + Sample (1) := Low_Sample; + for J in 1 .. Samples loop + High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + + Radix; + Sample (2) := High_Sample; + for K in 1 .. 2 loop + for L in 1 .. 2 loop + X := Complex'(Sample (K), Sample (L)); + Y := Complex'(Sample (L), Sample (K)); + Do_Mult_Div (X, Y); + if Failure_Detected then + return; -- minimize flood of error messages + end if; + end loop; + end loop; + end loop; -- J + end loop; -- I + end Mult_Div_Check; + + + procedure Do_Test is + begin + Special_Values; + Mult_Div_Check; + end Do_Test; + end Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + -- check the floating point type with the most digits + + package A_Long_Float_Check is + type A_Long_Float is digits System.Max_Digits; + subtype Real is A_Long_Float; + procedure Do_Test; + end A_Long_Float_Check; + + package body A_Long_Float_Check is + + package Complex_Types is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + + -- keep track if an accuracy failure has occurred so the test + -- can be short-circuited to avoid thousands of error messages. + Failure_Detected : Boolean := False; + + Mult_MBE : constant Real := 5.0; + Divide_MBE : constant Real := 13.0; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MBE : Real) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; + Abs_Error := MBE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual.Re - Expected.Re) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.re: " & Real'Image (Actual.Re) & + " expected.re: " & Real'Image (Expected.Re) & + " difference.re " & + Real'Image (Actual.Re - Expected.Re) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for real part"); + else + Report.Comment (Test_Name & " passed for real part"); + end if; + end if; + + Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + if abs (Actual.Im - Expected.Im) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.im: " & Real'Image (Actual.Im) & + " expected.im: " & Real'Image (Expected.Im) & + " difference.im " & + Real'Image (Actual.Im - Expected.Im) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for imaginary part"); + else + Report.Comment (Test_Name & " passed for imaginary part"); + end if; + end if; + end Check; + + + procedure Special_Values is + begin + + --- test 1 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : Complex := (0.0, 0.0); + X : Complex := (0.0, 0.0); + Y : Complex := (Big, Big); + Z : Complex; + begin + Z := X * Y; + Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", + Mult_MBE); + Z := Y * X; + Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Expected : Complex := (0.0, 0.0); + Z : Complex; + begin + Z := U * X; + Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + B : Complex := (Big, Big); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := B / X; + Report.Failed ("test 3 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := U / X; + Report.Failed ("test 4 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 4"); + end; + + + --- test 5 --- + declare + X : Complex := (Sqrt2, Sqrt2); + Z : Complex; + Expected : constant Complex := (0.0, 4.0); + begin + Z := X * X; + Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : Complex := Sqrt3 - Sqrt3 * i; + Z : Complex; + Expected : constant Complex := (0.0, -6.0); + begin + Z := X * X; + Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 --- + declare + X : Complex := Sqrt2 + Sqrt2 * i; + Y : Complex := Sqrt2 - Sqrt2 * i; + Z : Complex; + Expected : constant Complex := 0.0 + i; + begin + Z := X / Y; + Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 7"); + when others => + Report.Failed ("exception in test 7"); + end; + end Special_Values; + + + procedure Do_Mult_Div (X, Y : Complex) is + Z : Complex; + Args : constant String := + "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & + "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; + begin + Z := (X * X) / X; + Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / X; + Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / Y; + Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); + when others => + Report.Failed ("exception in Do_Mult_Div for " & Args); + end Do_Mult_Div; + + -- select complex values X and Y where the real and imaginary + -- parts are selected from the ranges (1/radix..1) and + -- (1..radix). This translates into quite a few combinations. + procedure Mult_Div_Check is + Samples : constant := 17; + Radix : constant Real := Real(Real'Machine_Radix); + Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); + Low_Sample : Real; -- (1/radix .. 1) + High_Sample : Real; -- (1 .. radix) + Sample : array (1..2) of Real; + X, Y : Complex; + begin + for I in 1 .. Samples loop + Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + + Inv_Radix; + Sample (1) := Low_Sample; + for J in 1 .. Samples loop + High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + + Radix; + Sample (2) := High_Sample; + for K in 1 .. 2 loop + for L in 1 .. 2 loop + X := Complex'(Sample (K), Sample (L)); + Y := Complex'(Sample (L), Sample (K)); + Do_Mult_Div (X, Y); + if Failure_Detected then + return; -- minimize flood of error messages + end if; + end loop; + end loop; + end loop; -- J + end loop; -- I + end Mult_Div_Check; + + + procedure Do_Test is + begin + Special_Values; + Mult_Div_Check; + end Do_Test; + end A_Long_Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + package Non_Generic_Check is + subtype Real is Float; + procedure Do_Test; + end Non_Generic_Check; + + package body Non_Generic_Check is + + use Ada.Numerics.Complex_Types; + + -- keep track if an accuracy failure has occurred so the test + -- can be short-circuited to avoid thousands of error messages. + Failure_Detected : Boolean := False; + + Mult_MBE : constant Real := 5.0; + Divide_MBE : constant Real := 13.0; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MBE : Real) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MBE * abs Expected.Re * Real'Model_Epsilon; + Abs_Error := MBE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual.Re - Expected.Re) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.re: " & Real'Image (Actual.Re) & + " expected.re: " & Real'Image (Expected.Re) & + " difference.re " & + Real'Image (Actual.Re - Expected.Re) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for real part"); + else + Report.Comment (Test_Name & " passed for real part"); + end if; + end if; + + Rel_Error := MBE * abs Expected.Im * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + if abs (Actual.Im - Expected.Im) > Max_Error then + Failure_Detected := True; + Report.Failed (Test_Name & + " actual.im: " & Real'Image (Actual.Im) & + " expected.im: " & Real'Image (Expected.Im) & + " difference.im " & + Real'Image (Actual.Im - Expected.Im) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result for imaginary part"); + else + Report.Comment (Test_Name & " passed for imaginary part"); + end if; + end if; + end Check; + + + procedure Special_Values is + begin + + --- test 1 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + Expected : Complex := (0.0, 0.0); + X : Complex := (0.0, 0.0); + Y : Complex := (Big, Big); + Z : Complex; + begin + Z := X * Y; + Check (Z, Expected, "test 1a -- (0+0i) * (big+big*i)", + Mult_MBE); + Z := Y * X; + Check (Z, Expected, "test 1b -- (big+big*i) * (0+0i)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Expected : Complex := (0.0, 0.0); + Z : Complex; + begin + Z := U * X; + Check (Z, Expected, "test 2 -- (tiny,tiny) * (0,0)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + T : constant := (Real'Machine_EMax - 1) / 2; + Big : constant := (1.0 * Real'Machine_Radix) ** (2 * T); + B : Complex := (Big, Big); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := B / X; + Report.Failed ("test 3 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + T : constant := Real'Model_EMin + 1; + Tiny : constant := (1.0 * Real'Machine_Radix) ** T; + U : Complex := (Tiny, Tiny); + X : Complex := (0.0, 0.0); + Z : Complex; + begin + if Real'Machine_Overflows then + Z := U / X; + Report.Failed ("test 4 - Constraint_Error not raised"); + Check (Z, Z, "not executed - optimizer thwarting", 0.0); + end if; + exception + when Constraint_Error => null; -- expected + when others => + Report.Failed ("exception in test 4"); + end; + + + --- test 5 --- + declare + X : Complex := (Sqrt2, Sqrt2); + Z : Complex; + Expected : constant Complex := (0.0, 4.0); + begin + Z := X * X; + Check (Z, Expected, "test 5 -- (sqrt2,sqrt2) * (sqrt2,sqrt2)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 5"); + when others => + Report.Failed ("exception in test 5"); + end; + + --- test 6 --- + declare + X : Complex := Sqrt3 - Sqrt3 * i; + Z : Complex; + Expected : constant Complex := (0.0, -6.0); + begin + Z := X * X; + Check (Z, Expected, "test 6 -- (sqrt3,-sqrt3) * (sqrt3,-sqrt3)", + Mult_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 6"); + when others => + Report.Failed ("exception in test 6"); + end; + + --- test 7 --- + declare + X : Complex := Sqrt2 + Sqrt2 * i; + Y : Complex := Sqrt2 - Sqrt2 * i; + Z : Complex; + Expected : constant Complex := 0.0 + i; + begin + Z := X / Y; + Check (Z, Expected, "test 7 -- (sqrt2,sqrt2) / (sqrt2,-sqrt2)", + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 7"); + when others => + Report.Failed ("exception in test 7"); + end; + end Special_Values; + + + procedure Do_Mult_Div (X, Y : Complex) is + Z : Complex; + Args : constant String := + "X=(" & Real'Image (X.Re) & "," & Real'Image (X.Im) & ") " & + "Y=(" & Real'Image (Y.Re) & "," & Real'Image (Y.Im) & ") " ; + begin + Z := (X * X) / X; + Check (Z, X, "X*X/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / X; + Check (Z, Y, "X*Y/X " & Args, Mult_MBE + Divide_MBE); + Z := (X * Y) / Y; + Check (Z, X, "X*Y/Y " & Args, Mult_MBE + Divide_MBE); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error in Do_Mult_Div for " & Args); + when others => + Report.Failed ("exception in Do_Mult_Div for " & Args); + end Do_Mult_Div; + + -- select complex values X and Y where the real and imaginary + -- parts are selected from the ranges (1/radix..1) and + -- (1..radix). This translates into quite a few combinations. + procedure Mult_Div_Check is + Samples : constant := 17; + Radix : constant Real := Real(Real'Machine_Radix); + Inv_Radix : constant Real := 1.0 / Real(Real'Machine_Radix); + Low_Sample : Real; -- (1/radix .. 1) + High_Sample : Real; -- (1 .. radix) + Sample : array (1..2) of Real; + X, Y : Complex; + begin + for I in 1 .. Samples loop + Low_Sample := (1.0 - Inv_Radix) / Real (Samples) * Real (I) + + Inv_Radix; + Sample (1) := Low_Sample; + for J in 1 .. Samples loop + High_Sample := (Radix - 1.0) / Real (Samples) * Real (I) + + Radix; + Sample (2) := High_Sample; + for K in 1 .. 2 loop + for L in 1 .. 2 loop + X := Complex'(Sample (K), Sample (L)); + Y := Complex'(Sample (L), Sample (K)); + Do_Mult_Div (X, Y); + if Failure_Detected then + return; -- minimize flood of error messages + end if; + end loop; + end loop; + end loop; -- J + end loop; -- I + end Mult_Div_Check; + + + procedure Do_Test is + begin + Special_Values; + Mult_Div_Check; + end Do_Test; + end Non_Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + begin + Report.Test ("CXG2008", + "Check the accuracy of the complex multiplication and" & + " division operators"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking non-generic package"); + end if; + + Non_Generic_Check.Do_Test; + + Report.Result; + end CXG2008; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2009.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,421 ---- + -- CXG2009.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the real sqrt and complex modulus functions + -- return results that are within the allowed + -- error bound. + -- + -- TEST DESCRIPTION: + -- This test checks the accuracy of the sqrt and modulus functions + -- by computing the norm of various vectors where the result + -- is known in advance. + -- This test uses real and complex math together as would an + -- actual application. Considerable use of generics is also + -- employed. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 26 FEB 96 SAIC Initial release for 2.1 + -- 22 AUG 96 SAIC Revised Check procedure + -- + --! + + ------------------------------------------------------------------------------ + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2009 is + Verbose : constant Boolean := False; + + --===================================================================== + + generic + type Real is digits <>; + package Generic_Real_Norm_Check is + procedure Do_Test; + end Generic_Real_Norm_Check; + + ----------------------------------------------------------------------- + + package body Generic_Real_Norm_Check is + type Vector is array (Integer range <>) of Real; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames GEF.Sqrt; + + function One_Norm (V : Vector) return Real is + -- sum of absolute values of the elements of the vector + Result : Real := 0.0; + begin + for I in V'Range loop + Result := Result + abs V(I); + end loop; + return Result; + end One_Norm; + + function Inf_Norm (V : Vector) return Real is + -- greatest absolute vector element + Result : Real := 0.0; + begin + for I in V'Range loop + if abs V(I) > Result then + Result := abs V(I); + end if; + end loop; + return Result; + end Inf_Norm; + + function Two_Norm (V : Vector) return Real is + -- if greatest absolute vector element is 0 then return 0 + -- else return greatest * sqrt (sum((element / greatest) ** 2))) + -- where greatest is Inf_Norm of the vector + Inf_N : Real; + Sum_Squares : Real; + Term : Real; + begin + Inf_N := Inf_Norm (V); + if Inf_N = 0.0 then + return 0.0; + end if; + Sum_Squares := 0.0; + for I in V'Range loop + Term := V (I) / Inf_N; + Sum_Squares := Sum_Squares + Term * Term; + end loop; + return Inf_N * Sqrt (Sum_Squares); + end Two_Norm; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real; + Vector_Length : Integer) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " VectLength:" & + Integer'Image (Vector_Length) & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + Report.Comment (Test_Name & " vector length" & + Integer'Image (Vector_Length)); + end if; + end Check; + + + procedure Do_Test is + begin + for Vector_Length in 1 .. 10 loop + declare + V : Vector (1..Vector_Length) := (1..Vector_Length => 0.0); + V1 : Vector (1..Vector_Length) := (1..Vector_Length => 1.0); + begin + Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length); + Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length); + + for J in 1..Vector_Length loop + V := (1..Vector_Length => 0.0); + V (J) := 1.0; + Check (One_Norm (V), 1.0, "one_norm (010)", + 0.0, Vector_Length); + Check (Inf_Norm (V), 1.0, "inf_norm (010)", + 0.0, Vector_Length); + Check (Two_Norm (V), 1.0, "two_norm (010)", + 0.0, Vector_Length); + end loop; + + Check (One_Norm (V1), Real (Vector_Length), "one_norm (1)", + 0.0, Vector_Length); + Check (Inf_Norm (V1), 1.0, "inf_norm (1)", + 0.0, Vector_Length); + + -- error in computing Two_Norm and expected result + -- are as follows (ME is Model_Epsilon * Expected_Value): + -- 2ME from expected Sqrt + -- 2ME from Sqrt in Two_Norm times the error in the + -- vector calculation. + -- The vector calculation contains the following error + -- based upon the length N of the vector: + -- N*1ME from squaring terms in Two_Norm + -- N*1ME from the division of each term in Two_Norm + -- (N-1)*1ME from the sum of the terms + -- This gives (2 + 2 * (N + N + (N-1)) ) * ME + -- which simplifies to (2 + 2N + 2N + 2N - 2) * ME + -- or 6*N*ME + Check (Two_Norm (V1), Sqrt (Real(Vector_Length)), + "two_norm (1)", + (Real (6 * Vector_Length)), + Vector_Length); + exception + when others => Report.Failed ("exception for vector length" & + Integer'Image (Vector_Length) ); + end; + end loop; + end Do_Test; + end Generic_Real_Norm_Check; + + --===================================================================== + + generic + type Real is digits <>; + package Generic_Complex_Norm_Check is + procedure Do_Test; + end Generic_Complex_Norm_Check; + + ----------------------------------------------------------------------- + + package body Generic_Complex_Norm_Check is + package Complex_Types is new Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Types; + type Vector is array (Integer range <>) of Complex; + + package GEF is new Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames GEF.Sqrt; + + function One_Norm (V : Vector) return Real is + Result : Real := 0.0; + begin + for I in V'Range loop + Result := Result + abs V(I); + end loop; + return Result; + end One_Norm; + + function Inf_Norm (V : Vector) return Real is + Result : Real := 0.0; + begin + for I in V'Range loop + if abs V(I) > Result then + Result := abs V(I); + end if; + end loop; + return Result; + end Inf_Norm; + + function Two_Norm (V : Vector) return Real is + Inf_N : Real; + Sum_Squares : Real; + Term : Real; + begin + Inf_N := Inf_Norm (V); + if Inf_N = 0.0 then + return 0.0; + end if; + Sum_Squares := 0.0; + for I in V'Range loop + Term := abs (V (I) / Inf_N ); + Sum_Squares := Sum_Squares + Term * Term; + end loop; + return Inf_N * Sqrt (Sum_Squares); + end Two_Norm; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real; + Vector_Length : Integer) is + Rel_Error : Real; + Abs_Error : Real; + Max_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Report.Failed (Test_Name & + " VectLength:" & + Integer'Image (Vector_Length) & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & + Real'Image (Actual - Expected) & + " mre:" & Real'Image (Max_Error) ); + elsif Verbose then + Report.Comment (Test_Name & " vector length" & + Integer'Image (Vector_Length)); + end if; + end Check; + + + procedure Do_Test is + begin + for Vector_Length in 1 .. 10 loop + declare + V : Vector (1..Vector_Length) := + (1..Vector_Length => (0.0, 0.0)); + X, Y : Vector (1..Vector_Length); + begin + Check (One_Norm (V), 0.0, "one_norm (z)", 0.0, Vector_Length); + Check (Inf_Norm (V), 0.0, "inf_norm (z)", 0.0, Vector_Length); + + for J in 1..Vector_Length loop + X := (1..Vector_Length => (0.0, 0.0) ); + Y := X; -- X and Y are now both zeroed + X (J).Re := 1.0; + Y (J).Im := 1.0; + Check (One_Norm (X), 1.0, "one_norm (0x0)", + 0.0, Vector_Length); + Check (Inf_Norm (X), 1.0, "inf_norm (0x0)", + 0.0, Vector_Length); + Check (Two_Norm (X), 1.0, "two_norm (0x0)", + 0.0, Vector_Length); + Check (One_Norm (Y), 1.0, "one_norm (0y0)", + 0.0, Vector_Length); + Check (Inf_Norm (Y), 1.0, "inf_norm (0y0)", + 0.0, Vector_Length); + Check (Two_Norm (Y), 1.0, "two_norm (0y0)", + 0.0, Vector_Length); + end loop; + + V := (1..Vector_Length => (3.0, 4.0)); + + -- error in One_Norm is 3*N*ME for abs computation + + -- (N-1)*ME for the additions + -- which gives (4N-1) * ME + Check (One_Norm (V), 5.0 * Real (Vector_Length), + "one_norm ((3,4))", + Real (4*Vector_Length - 1), + Vector_Length); + + -- error in Inf_Norm is from abs of single element (3ME) + Check (Inf_Norm (V), 5.0, + "inf_norm ((3,4))", + 3.0, + Vector_Length); + + -- error in following comes from: + -- 2ME in sqrt of expected result + -- 3ME in Inf_Norm calculation + -- 2ME in sqrt of vector calculation + -- vector calculation has following error + -- 3N*ME for abs + -- N*ME for squaring + -- N*ME for division + -- (N-1)ME for sum + -- this results in [2 + 3 + 2(6N-1) ] * ME + -- or (12N + 3)ME + Check (Two_Norm (V), 5.0 * Sqrt (Real(Vector_Length)), + "two_norm ((3,4))", + (12.0 * Real (Vector_Length) + 3.0), + Vector_Length); + exception + when others => Report.Failed ("exception for complex " & + "vector length" & + Integer'Image (Vector_Length) ); + end; + end loop; + end Do_Test; + end Generic_Complex_Norm_Check; + + --===================================================================== + + generic + type Real is digits <>; + package Generic_Norm_Check is + procedure Do_Test; + end Generic_Norm_Check; + + ----------------------------------------------------------------------- + + package body Generic_Norm_Check is + package RNC is new Generic_Real_Norm_Check (Real); + package CNC is new Generic_Complex_Norm_Check (Real); + procedure Do_Test is + begin + RNC.Do_Test; + CNC.Do_Test; + end Do_Test; + end Generic_Norm_Check; + + --===================================================================== + + package Float_Check is new Generic_Norm_Check (Float); + + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Norm_Check (A_Long_Float); + + ----------------------------------------------------------------------- + + begin + Report.Test ("CXG2009", + "Check the accuracy of the real sqrt and complex " & + " modulus functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + Report.Result; + end CXG2009; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2010.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,892 ---- + -- CXG2010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exp function returns + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test contains three test packages that are almost + -- identical. The first two packages differ only in the + -- floating point type that is being tested. The first + -- and third package differ only in whether the generic + -- elementary functions package or the pre-instantiated + -- package is used. + -- The test package is not generic so that the arguments + -- and expected results for some of the test values + -- can be expressed as universal real instead of being + -- computed at runtime. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex and where the Machine_Radix is 2, 4, 8, or 16. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 1 Mar 96 SAIC Initial release for 2.1 + -- 2 Sep 96 SAIC Improved check routine + -- + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + -- + -- Notes on derivation of error bound for exp(p)*exp(-p) + -- + -- Let a = true value of exp(p) and ac be the computed value. + -- Then a = ac(1+e1), where |e1| <= 4*Model_Epsilon. + -- Similarly, let b = true value of exp(-p) and bc be the computed value. + -- Then b = bc(1+e2), where |e2| <= 4*ME. + -- + -- The product of x and y is (x*y)(1+e3), where |e3| <= 1.0ME + -- + -- Hence, the computed ab is [ac(1+e1)*bc(1+e2)](1+e3) = + -- (ac*bc)[1 + e1 + e2 + e3 + e1e2 + e1e3 + e2e3 + e1e2e3). + -- + -- Throwing away the last four tiny terms, we have (ac*bc)(1 + eta), + -- + -- where |eta| <= (4+4+1)ME = 9.0Model_Epsilon. + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + with Ada.Numerics.Elementary_Functions; + procedure CXG2010 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + Accuracy_Error_Reported : Boolean := False; + + package Float_Check is + subtype Real is Float; + procedure Do_Test; + end Float_Check; + + package body Float_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Argument_Range_Check_1 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 1.0 / 16.0; + One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); + -- which simplifies to ZX := Exp (X-V); + ZX := ZX - ZX * One_Minus_Exp_Minus_V; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 1"); + when others => + Report.Failed ("exception in argument range check 1"); + end Argument_Range_Check_1; + + + + procedure Argument_Range_Check_2 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 45.0 / 16.0; + -- 1/16 - Exp(45/16) + Coeff : constant := 2.4453321046920570389E-3; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; + -- where Coeff is 1/16 - Exp(45/16) + -- which simplifies to ZX := Exp (X-V); + ZX := ZX * 0.0625 - ZX * Coeff; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 2"); + when others => + Report.Failed ("exception in argument range check 2"); + end Argument_Range_Check_2; + + + procedure Do_Test is + begin + + --- test 1 --- + declare + Y : Real; + begin + Y := Exp(1.0); + -- normal accuracy requirements + Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + Y : Real; + begin + Y := Exp(16.0) * Exp(-16.0); + Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + Y : Real; + begin + Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); + Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + Y : Real; + begin + Y := Exp(0.0); + Check (Y, 1.0, "test 4 -- exp(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), + 1.0, + "5"); + Error_Low_Bound := 0.0; -- reset + + --- test 6 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_2 (1.0, + Sqrt(Real(Real'Machine_Radix)), + "6"); + Error_Low_Bound := 0.0; -- reset + + end Do_Test; + end Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + + + package A_Long_Float_Check is + subtype Real is A_Long_Float; + procedure Do_Test; + end A_Long_Float_Check; + + package body A_Long_Float_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Argument_Range_Check_1 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 1.0 / 16.0; + One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); + -- which simplifies to ZX := Exp (X-V); + ZX := ZX - ZX * One_Minus_Exp_Minus_V; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 1"); + when others => + Report.Failed ("exception in argument range check 1"); + end Argument_Range_Check_1; + + + + procedure Argument_Range_Check_2 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 45.0 / 16.0; + -- 1/16 - Exp(45/16) + Coeff : constant := 2.4453321046920570389E-3; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; + -- where Coeff is 1/16 - Exp(45/16) + -- which simplifies to ZX := Exp (X-V); + ZX := ZX * 0.0625 - ZX * Coeff; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 2"); + when others => + Report.Failed ("exception in argument range check 2"); + end Argument_Range_Check_2; + + + procedure Do_Test is + begin + + --- test 1 --- + declare + Y : Real; + begin + Y := Exp(1.0); + -- normal accuracy requirements + Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + Y : Real; + begin + Y := Exp(16.0) * Exp(-16.0); + Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + Y : Real; + begin + Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); + Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + Y : Real; + begin + Y := Exp(0.0); + Check (Y, 1.0, "test 4 -- exp(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), + 1.0, + "5"); + Error_Low_Bound := 0.0; -- reset + + --- test 6 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_2 (1.0, + Sqrt(Real(Real'Machine_Radix)), + "6"); + Error_Low_Bound := 0.0; -- reset + + end Do_Test; + end A_Long_Float_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + package Non_Generic_Check is + procedure Do_Test; + subtype Real is Float; + end Non_Generic_Check; + + package body Non_Generic_Check is + + package Elementary_Functions renames + Ada.Numerics.Elementary_Functions; + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Argument_Range_Check_1 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 1.0 / 16.0; + One_Minus_Exp_Minus_V : constant := 6.058693718652421388E-2; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) - Exp(X) * (1 - Exp(-V); + -- which simplifies to ZX := Exp (X-V); + ZX := ZX - ZX * One_Minus_Exp_Minus_V; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 1"); + when others => + Report.Failed ("exception in argument range check 1"); + end Argument_Range_Check_1; + + + + procedure Argument_Range_Check_2 (A, B : Real; + Test : String) is + -- test a evenly distributed selection of + -- arguments selected from the range A to B. + -- Test using identity: EXP(X-V) = EXP(X) * EXP (-V) + -- The parameter One_Minus_Exp_Minus_V is the value + -- 1.0 - Exp (-V) + -- accurate to machine precision. + -- This procedure is a translation of part of Cody's test + X : Real; + Y : Real; + ZX, ZY : Real; + V : constant := 45.0 / 16.0; + -- 1/16 - Exp(45/16) + Coeff : constant := 2.4453321046920570389E-3; + + begin + Accuracy_Error_Reported := False; + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + Y := X - V; + if Y < 0.0 then + X := Y + V; + end if; + + ZX := Exp (X); + ZY := Exp (Y); + + -- ZX := Exp(X) * 1/16 - Exp(X) * Coeff; + -- where Coeff is 1/16 - Exp(45/16) + -- which simplifies to ZX := Exp (X-V); + ZX := ZX * 0.0625 - ZX * Coeff; + + -- note that since the expected value is computed, we + -- must take the error in that computation into account. + Check (ZY, ZX, + "test " & Test & " -" & + Integer'Image (I) & + " exp (" & Real'Image (X) & ")", + 9.0); + exit when Accuracy_Error_Reported; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in argument range check 2"); + when others => + Report.Failed ("exception in argument range check 2"); + end Argument_Range_Check_2; + + + procedure Do_Test is + begin + + --- test 1 --- + declare + Y : Real; + begin + Y := Exp(1.0); + -- normal accuracy requirements + Check (Y, Ada.Numerics.e, "test 1 -- exp(1)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + Y : Real; + begin + Y := Exp(16.0) * Exp(-16.0); + Check (Y, 1.0, "test 2 -- exp(16)*exp(-16)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + Y : Real; + begin + Y := Exp (Ada.Numerics.Pi) * Exp (-Ada.Numerics.Pi); + Check (Y, 1.0, "test 3 -- exp(pi)*exp(-pi)", 9.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + Y : Real; + begin + Y := Exp(0.0); + Check (Y, 1.0, "test 4 -- exp(0.0)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + + --- test 5 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_1 ( 1.0/Sqrt(Real(Real'Machine_Radix)), + 1.0, + "5"); + Error_Low_Bound := 0.0; -- reset + + --- test 6 --- + -- constants used here only have 19 digits of precision + if Real'Digits > 19 then + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("exp accuracy checked to 19 digits"); + end if; + + Argument_Range_Check_2 (1.0, + Sqrt(Real(Real'Machine_Radix)), + "6"); + Error_Low_Bound := 0.0; -- reset + + end Do_Test; + end Non_Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + begin + Report.Test ("CXG2010", + "Check the accuracy of the exp function"); + + -- the test only applies to machines with a radix of 2,4,8, or 16 + case Float'Machine_Radix is + when 2 | 4 | 8 | 16 => null; + when others => + Report.Not_Applicable ("only applicable to binary radix"); + Report.Result; + return; + end case; + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking non-generic package"); + end if; + + Non_Generic_Check.Do_Test; + + Report.Result; + end CXG2010; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2011.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,490 ---- + -- CXG2011.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the log function returns + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks in a range where a Taylor series can be used to compute + -- the expected result. + -- Checks that use an identity for determining the result. + -- Exception checks. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 1 Mar 96 SAIC Initial release for 2.1 + -- 22 Aug 96 SAIC Improved Check routine + -- 02 DEC 97 EDS Log (0.0) must raise Constraint_Error, + -- not Argument_Error + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2011 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + + -- CRC Handbook Page 738 + Ln10 : constant := 2.30258_50929_94045_68401_79914_54684_36420_76011_01489; + Ln2 : constant := 0.69314_71805_59945_30941_72321_21458_17656_80755_00134; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real'Base) return Real'Base renames + Elementary_Functions.Sqrt; + function Exp (X : Real'Base) return Real'Base renames + Elementary_Functions.Exp; + function Log (X : Real'Base) return Real'Base renames + Elementary_Functions.Log; + function Log (X, Base : Real'Base) return Real'Base renames + Elementary_Functions.Log; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Value_Test is + begin + + --- test 1 --- + declare + Y : Real; + begin + Y := Log(1.0); + Check (Y, 0.0, "special value test 1 -- log(1)", + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 1"); + when others => + Report.Failed ("exception in test 1"); + end; + + --- test 2 --- + declare + Y : Real; + begin + Y := Log(10.0); + Check (Y, Ln10, "special value test 2 -- log(10)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 2"); + when others => + Report.Failed ("exception in test 2"); + end; + + --- test 3 --- + declare + Y : Real; + begin + Y := Log (2.0); + Check (Y, Ln2, "special value test 3 -- log(2)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 3"); + when others => + Report.Failed ("exception in test 3"); + end; + + --- test 4 --- + declare + Y : Real; + begin + Y := Log (2.0 ** 18, 2.0); + Check (Y, 18.0, "special value test 4 -- log(2**18,2)", 4.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in test 4"); + when others => + Report.Failed ("exception in test 4"); + end; + end Special_Value_Test; + + + procedure Taylor_Series_Test is + -- Use a 4 term taylor series expansion to check a selection of + -- arguments very near 1.0. + -- The range is chosen so that the 4 term taylor series will + -- provide accuracy to machine precision. Cody pg 49-50. + Half_Range : constant Real := Real'Model_Epsilon * 50.0; + A : constant Real := 1.0 - Half_Range; + B : constant Real := 1.0 + Half_Range; + X : Real; + Xm1 : Real; + Expected : Real; + Actual : Real; + + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + + Xm1 := X - 1.0; + -- The following is the first 4 terms of the taylor series + -- that has been rearranged to minimize error in the calculation + Expected := (Xm1 * (1.0/3.0 - Xm1/4.0) - 0.5) * Xm1 * Xm1 + Xm1; + + Actual := Log (X); + Check (Actual, Expected, + "Taylor Series Test -" & + Integer'Image (I) & + " log (" & Real'Image (X) & ")", + 4.0); + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Taylor Series Test"); + when others => + Report.Failed ("exception in Taylor Series Test"); + end Taylor_Series_Test; + + + + procedure Log_Difference_Identity is + -- Check using the identity ln(x) = ln(17x/16) - ln(17/16) + -- over the range A to B. + -- The selected range assures that both X and 17x/16 will + -- have the same exponents and neither argument gets too close + -- to 1. Cody pg 50. + A : constant Real := 1.0 / Sqrt (2.0); + B : constant Real := 15.0 / 16.0; + X : Real; + Expected : Real; + Actual : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + -- magic argument purification + X := Real'Machine (Real'Machine (X+8.0) - 8.0); + + Expected := Log (X + X / 16.0) - Log (17.0/16.0); + + Actual := Log (X); + Check (Actual, Expected, + "Log Difference Identity -" & + Integer'Image (I) & + " log (" & Real'Image (X) & ")", + 4.0); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Log Difference Identity Test"); + when others => + Report.Failed ("exception in Log Difference Identity Test"); + end Log_Difference_Identity; + + + procedure Log_Product_Identity is + -- Check using the identity ln(x**2) = 2ln(x) + -- over the range A to B. + -- This large range is chosen to minimize the possibility of + -- undetected systematic errors. Cody pg 53. + A : constant Real := 16.0; + B : constant Real := 240.0; + X : Real; + Expected : Real; + Actual : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + -- magic argument purification + X := Real'Machine (Real'Machine (X+8.0) - 8.0); + + Expected := 2.0 * Log (X); + + Actual := Log (X*X); + Check (Actual, Expected, + "Log Product Identity -" & + Integer'Image (I) & + " log (" & Real'Image (X) & ")", + 4.0); + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Log Product Identity Test"); + when others => + Report.Failed ("exception in Log Product Identity Test"); + end Log_Product_Identity; + + + procedure Log10_Test is + -- Check using the identity log(x) = log(11x/10) - log(1.1) + -- over the range A to B. See Cody pg 52. + A : constant Real := 1.0 / Sqrt (10.0); + B : constant Real := 0.9; + X : Real; + Expected : Real; + Actual : Real; + begin + if Real'Digits > 17 then + -- constant used below is accuract to 17 digits + Error_Low_Bound := 0.00000_00000_00000_01; + Report.Comment ("log accuracy checked to 19 digits"); + end if; + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + + Expected := Log (X + X/10.0, 10.0) + - 3.77060_15822_50407_5E-4 - 21.0 / 512.0; + + Actual := Log (X, 10.0); + Check (Actual, Expected, + "Log 10 Test -" & + Integer'Image (I) & + " log (" & Real'Image (X) & ")", + 4.0); + + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + exit when Accuracy_Error_Reported; + end loop; + Error_Low_Bound := 0.0; -- reset + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Log 10 Test"); + when others => + Report.Failed ("exception in Log 10 Test"); + end Log10_Test; + + + procedure Exception_Test is + X1, X2, X3, X4 : Real; + begin + begin + X1 := Log (0.0); + Report.Failed ("exception not raised for LOG(0)"); + exception + -- Log (0.0) must raise Constraint_Error, not Argument_Error, + -- as per A.5.1(28,29). Was incorrect in ACVC 2.1 release. + when Ada.Numerics.Argument_Error => + Report.Failed ("Argument_Error raised instead of" & + " Constraint_Error for LOG(0)--A.5.1(28,29)"); + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for LOG(0)"); + end; + + begin + X2 := Log ( 1.0, 0.0); + Report.Failed ("exception not raised for LOG(1,0)"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for LOG(1,0)"); + when others => + Report.Failed ("wrong exception raised for LOG(1,0)"); + end; + + begin + X3 := Log (1.0, 1.0); + Report.Failed ("exception not raised for LOG(1,1)"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for LOG(1,1)"); + when others => + Report.Failed ("wrong exception raised for LOG(1,1)"); + end; + + begin + X4 := Log (1.0, -10.0); + Report.Failed ("exception not raised for LOG(1,-10)"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for LOG(1,-10)"); + when others => + Report.Failed ("wrong exception raised for LOG(1,-10)"); + end; + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1+X2+X3+X4)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Taylor_Series_Test; + Log_Difference_Identity; + Log_Product_Identity; + Log10_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2011", + "Check the accuracy of the log function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2012.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,438 ---- + -- CXG2012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the exponentiation operator returns + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- Exception checks. + -- While this test concentrates on the "**" operator + -- defined in Generic_Elementary_Functions, a check is also + -- performed on the standard "**" operator. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 7 Mar 96 SAIC Initial release for 2.1 + -- 2 Sep 96 SAIC Improvements as suggested by reviewers + -- 3 Jun 98 EDS Add parens to ensure that the expression is not + -- evaluated by multiplying its two large terms + -- together and overflowing. + -- 3 Dec 01 RLB Added 'Machine to insure that equality tests + -- are certain to work. + -- + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2012 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Exp (X : Real) return Real renames + Elementary_Functions.Exp; + function Log (X : Real) return Real renames + Elementary_Functions.Log; + function "**" (L, R : Real) return Real renames + Elementary_Functions."**"; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + -- the following version of Check computes the allowed error bound + -- using the operands + procedure Check (Actual, Expected : Real; + Left, Right : Real; + Test_Name : String; + MRE_Factor : Real := 1.0) is + MRE : Real; + begin + MRE := MRE_Factor * (4.0 + abs (Right * Log(Left)) / 32.0); + Check (Actual, Expected, Test_Name, MRE); + end Check; + + + procedure Real_To_Integer_Test is + type Int_Check is + record + Left : Real; + Right : Integer; + Expected : Real; + end record; + type Int_Checks is array (Positive range <>) of Int_Check; + + -- the following tests use only model numbers so the result + -- is expected to be exact. + IC : constant Int_Checks := + ( ( 2.0, 5, 32.0), + ( -2.0, 5, -32.0), + ( 0.5, -5, 32.0), + ( 2.0, 0, 1.0), + ( 0.0, 0, 1.0) ); + begin + for I in IC'Range loop + declare + Y : Real; + begin + Y := IC (I).Left ** IC (I).Right; + Check (Y, IC (I).Expected, + "real to integer test" & + Real'Image (IC (I).Left) & " ** " & + Integer'Image (IC (I).Right), + 0.0); -- no error allowed + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in rtoi test " & + Integer'Image (I)); + when others => + Report.Failed ("exception in rtoi test " & + Integer'Image (I)); + end; + end loop; + end Real_To_Integer_Test; + + + procedure Special_Value_Test is + No_Error : constant := 0.0; + begin + Check (0.0 ** 1.0, 0.0, "0**1", No_Error); + Check (1.0 ** 0.0, 1.0, "1**0", No_Error); + + Check ( 2.0 ** 5.0, 32.0, 2.0, 5.0, "2**5"); + Check ( 0.5**(-5.0), 32.0, 0.5, -5.0, "0.5**-5"); + + Check (Sqrt2 ** 4.0, 4.0, Sqrt2, 4.0, "Sqrt2**4"); + Check (Sqrt3 ** 6.0, 27.0, Sqrt3, 6.0, "Sqrt3**6"); + + Check (2.0 ** 0.5, Sqrt2, 2.0, 0.5, "2.0**0.5"); + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Special Value Test"); + when others => + Report.Failed ("exception in Special Value Test"); + end Special_Value_Test; + + + procedure Small_Range_Test is + -- Several checks over the range 1/radix .. 1 + A : constant Real := 1.0 / Real (Real'Machine_Radix); + B : constant Real := 1.0; + X : Real; + -- In the cases below where the expected result is + -- inexact we allow an additional error amount of + -- 1.0 * Model_Epsilon to account for that error. + -- This is accomplished by the factor of 1.25 times + -- the computed error bound (which is > 4.0) thus + -- increasing the error bound by at least + -- 1.0 * Model_Epsilon + begin + Accuracy_Error_Reported := False; -- reset + for I in 0..Max_Samples loop + X := Real'Machine((B - A) * Real (I) / Real (Max_Samples) + A); + + Check (X ** 1.0, X, -- exact result required + "Small range" & Integer'Image (I) & ": " & + Real'Image (X) & " ** 1.0", + 0.0); + + Check ((X*X) ** 1.5, X**3, X*X, 1.5, + "Small range" & Integer'Image (I) & ": " & + Real'Image (X*X) & " ** 1.5", + 1.25); + + Check (X ** 13.5, 1.0 / (X ** (-13.5)), X, 13.5, + "Small range" & Integer'Image (I) & ": " & + Real'Image (X) & " ** 13.5", + 2.0); -- 2 ** computations + + Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25, + "Small range" & Integer'Image (I) & ": " & + Real'Image (X*X) & " ** 1.25", + 2.0); -- 2 ** computations + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Small Range Test"); + when others => + Report.Failed ("exception in Small Range Test"); + end Small_Range_Test; + + + procedure Large_Range_Test is + -- Check over the range A to B where A is 1.0 and + -- B is a large value. + A : constant Real := 1.0; + B : Real; + X : Real; + Iteration : Integer := 0; + Subtest : Character := 'X'; + begin + -- upper bound of range should be as large as possible where + -- B**3 is still valid. + B := Real'Safe_Last ** 0.333; + Accuracy_Error_Reported := False; -- reset + for I in 0..Max_Samples loop + Iteration := I; + Subtest := 'X'; + X := Real'Machine((B - A) * (Real (I) / Real (Max_Samples)) + A); + + Subtest := 'A'; + Check (X ** 1.0, X, -- exact result required + "Large range" & Integer'Image (I) & ": " & + Real'Image (X) & " ** 1.0", + 0.0); + + Subtest := 'B'; + Check ((X*X) ** 1.5, X**3, X*X, 1.5, + "Large range" & Integer'Image (I) & ": " & + Real'Image (X*X) & " ** 1.5", + 1.25); -- inexact expected result + + Subtest := 'C'; + Check ((X*X) ** 1.25, X**(2.5), X*X, 1.25, + "Large range" & Integer'Image (I) & ": " & + Real'Image (X*X) & " ** 1.25", + 2.0); -- two ** operators + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Large Range Test" & + Integer'Image (Iteration) & Subtest); + when others => + Report.Failed ("exception in Large Range Test" & + Integer'Image (Iteration) & Subtest); + end Large_Range_Test; + + + procedure Exception_Test is + X1, X2, X3, X4 : Real; + begin + begin + X1 := 0.0 ** (-1.0); + Report.Failed ("exception not raised for 0**-1"); + exception + when Ada.Numerics.Argument_Error => + Report.Failed ("argument_error raised instead of" & + " constraint_error for 0**-1"); + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for 0**-1"); + end; + + begin + X2 := 0.0 ** 0.0; + Report.Failed ("exception not raised for 0**0"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for 0**0"); + when others => + Report.Failed ("wrong exception raised for 0**0"); + end; + + begin + X3 := (-1.0) ** 1.0; + Report.Failed ("exception not raised for -1**1"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for -1**1"); + when others => + Report.Failed ("wrong exception raised for -1**1"); + end; + + begin + X4 := (-2.0) ** 2.0; + Report.Failed ("exception not raised for -2**2"); + exception + when Ada.Numerics.Argument_Error => null; -- ok + when Constraint_Error => + Report.Failed ("constraint_error raised instead of" & + " argument_error for -2**2"); + when others => + Report.Failed ("wrong exception raised for -2**2"); + end; + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1+X2+X3+X4)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Real_To_Integer_Test; + Special_Value_Test; + Small_Range_Test; + Large_Range_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2012", + "Check the accuracy of the ** operator"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2012; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2013.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,367 ---- + -- CXG2013.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the TAN and COT functions return + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- Exception checks. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 11 Mar 96 SAIC Initial release for 2.1 + -- 17 Aug 96 SAIC Commentary fixes. + -- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi + -- 02 DEC 97 EDS Change Max_Samples constant to 1001. + -- 29 JUN 98 EDS Deleted Special_Angle_Test as fatally flawed. + + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2013 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1001; + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sqrt (X : Real) return Real renames + Elementary_Functions.Sqrt; + function Tan (X : Real) return Real renames + Elementary_Functions.Tan; + function Cot (X : Real) return Real renames + Elementary_Functions.Cot; + function Tan (X, Cycle : Real) return Real renames + Elementary_Functions.Tan; + function Cot (X, Cycle : Real) return Real renames + Elementary_Functions.Cot; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + -- factor to be applied in computing MRE + Maximum_Relative_Error : constant Real := 4.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- A.5.1(38);6.0 + Check (Tan (0.0), 0.0, "tan(0)", No_Error); + + -- A.5.1(41);6.0 + Check (Tan (180.0, 360.0), 0.0, "tan(180,360)", No_Error); + Check (Tan (360.0, 360.0), 0.0, "tan(360,360)", No_Error); + Check (Tan (720.0, 360.0), 0.0, "tan(720,360)", No_Error); + + -- A.5.1(41);6.0 + Check (Cot ( 90.0, 360.0), 0.0, "cot( 90,360)", No_Error); + Check (Cot (270.0, 360.0), 0.0, "cot(270,360)", No_Error); + Check (Cot (810.0, 360.0), 0.0, "cot(810,360)", No_Error); + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Tan_Test (A, B : Real) is + -- Use identity Tan(X) = [2*Tan(x/2)]/[1-Tan(x/2) ** 2] + -- checks over the range -pi/4 .. pi/4 require no argument reduction + -- checks over the range 7pi/8 .. 9pi/8 require argument reduction + X, Y : Real; + Actual1, Actual2 : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + -- argument purification to insure x and x/2 are exact + -- See Cody page 170. + Y := Real'Machine (X*0.5); + X := Real'Machine (Y + Y); + + Actual1 := Tan(X); + Actual2 := (2.0 * Tan (Y)) / (1.0 - Tan (Y) ** 2); + + if abs (X - Pi) > ( (B-A)/Real(2*Max_Samples) ) then + Check (Actual1, Actual2, + "Tan_Test " & Integer'Image (I) & ": tan(" & + Real'Image (X) & ") ", + (1.0 + Sqrt2) * Maximum_Relative_Error); + -- see Cody pg 165 for error bound info + end if; + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Tan_Test"); + when others => + Report.Failed ("exception in Tan_Test"); + end Tan_Test; + + + + procedure Cot_Test is + -- Use identity Cot(X) = [Cot(X/2)**2 - 1]/[2*Cot(X/2)] + A : constant := 6.0 * Pi; + B : constant := 25.0 / 4.0 * Pi; + X, Y : Real; + Actual1, Actual2 : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + -- argument purification to insure x and x/2 are exact. + -- See Cody page 170. + Y := Real'Machine (X*0.5); + X := Real'Machine (Y + Y); + + Actual1 := Cot(X); + Actual2 := (Cot (Y) ** 2 - 1.0) / (2.0 * Cot (Y)); + + Check (Actual1, Actual2, + "Cot_Test " & Integer'Image (I) & ": cot(" & + Real'Image (X) & ") ", + (1.0 + Sqrt2) * Maximum_Relative_Error); + -- see Cody pg 165 for error bound info + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Cot_Test"); + when others => + Report.Failed ("exception in Cot_Test"); + end Cot_Test; + + + procedure Exception_Test is + X1, X2, X3, X4, X5 : Real := 0.0; + begin + + + begin -- A.5.1(20);6.0 + X1 := Tan (0.0, Cycle => 0.0); + Report.Failed ("no exception for cycle = 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle = 0.0"); + end; + + begin -- A.5.1(20);6.0 + X2 := Cot (1.0, Cycle => -3.0); + Report.Failed ("no exception for cycle < 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle < 0.0"); + end; + + -- the remaining tests only apply to machines that overflow + if Real'Machine_Overflows then -- A.5.1(28);6.0 + + begin -- A.5.1(29);6.0 + X3 := Cot (0.0); + Report.Failed ("exception not raised for cot(0)"); + exception + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for cot(0)"); + end; + + begin -- A.5.1(31);6.0 + X4 := Tan (90.0, 360.0); + Report.Failed ("exception not raised for tan(90,360)"); + exception + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for tan(90,360)"); + end; + + begin -- A.5.1(32);6.0 + X5 := Cot (180.0, 360.0); + Report.Failed ("exception not raised for cot(180,360)"); + exception + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for cot(180,360)"); + end; + end if; + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1+X2+X3+X4+X5)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Exact_Result_Test; + Tan_Test (-Pi/4.0, Pi/4.0); + Tan_Test (7.0*Pi/8.0, 9.0*Pi/8.0); + Cot_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2013", + "Check the accuracy of the TAN and COT functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2013; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2014.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,399 ---- + -- CXG2014.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the SINH and COSH functions return + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- Exception checks. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 15 Mar 96 SAIC Initial release for 2.1 + -- 03 Jun 98 EDS In line 80, change 1000 to 1024, making it a model + -- number. Add Taylor Series terms in line 281. + -- 15 Feb 99 RLB Repaired Subtraction_Error_Test to avoid precision + -- problems. + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2014 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1024; + + E : constant := Ada.Numerics.E; + Cosh1 : constant := (E + 1.0 / E) / 2.0; -- cosh(1.0) + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + function Sinh (X : Real) return Real renames + Elementary_Functions.Sinh; + function Cosh (X : Real) return Real renames + Elementary_Functions.Cosh; + function Log (X : Real) return Real renames + Elementary_Functions.Log; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Small instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Small; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used. + Minimum_Error : constant := 8.0; + begin + Check (Sinh (1.0), + (E - 1.0 / E) / 2.0, + "sinh(1)", + Minimum_Error); + Check (Cosh (1.0), + Cosh1, + "cosh(1)", + Minimum_Error); + Check (Sinh (2.0), + (E * E - (1.0 / (E * E))) / 2.0, + "sinh(2)", + Minimum_Error); + Check (Cosh (2.0), + (E * E + (1.0 / (E * E))) / 2.0, + "cosh(2)", + Minimum_Error); + Check (Sinh (-1.0), + (1.0 / E - E) / 2.0, + "sinh(-1)", + Minimum_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- A.5.1(38);6.0 + Check (Sinh (0.0), 0.0, "sinh(0)", No_Error); + Check (Cosh (0.0), 1.0, "cosh(0)", No_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_1_Test is + -- For the Sinh test use the identity + -- 2 * Sinh(x) * Cosh(1) = Sinh(x+1) + Sinh (x-1) + -- which is transformed to + -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C + -- where C = 1/(2*Cosh(1)) + -- + -- For the Cosh test use the identity + -- 2 * Cosh(x) * Cosh(1) = Cosh(x+1) + Cosh(x-1) + -- which is transformed to + -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1)) + -- where C is the same as above + -- + -- see Cody pg 230-231 for details on the error analysis. + -- The net result is a relative error bound of 16 * Model_Epsilon. + + A : constant := 3.0; + -- large upper bound but not so large as to cause Cosh(B) + -- to overflow + B : constant Real := Log(Real'Safe_Last) - 2.0; + X_Minus_1, X, X_Plus_1 : Real; + Actual1, Actual2 : Real; + C : constant := 1.0 / (2.0 * Cosh1); + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + -- make sure there is no error in x-1, x, and x+1 + X_Plus_1 := (B - A) * Real (I) / Real (Max_Samples) + A; + X_Plus_1 := Real'Machine (X_Plus_1); + X := Real'Machine (X_Plus_1 - 1.0); + X_Minus_1 := Real'Machine (X - 1.0); + + -- Sinh(x) = ((Sinh(x+1) + Sinh(x-1)) * C + Actual1 := Sinh(X); + Actual2 := C * (Sinh(X_Plus_1) + Sinh(X_Minus_1)); + + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (I) & ": sinh(" & + Real'Image (X) & ") ", + 16.0); + + -- Cosh(x) = C * (Cosh(x+1) + Cosh(x-1)) + Actual1 := Cosh (X); + Actual2 := C * (Cosh(X_Plus_1) + Cosh (X_Minus_1)); + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (I) & ": cosh(" & + Real'Image (X) & ") ", + 16.0); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_1_Test" & + " for X=" & Real'Image (X)); + when others => + Report.Failed ("exception in Identity_1_Test" & + " for X=" & Real'Image (X)); + end Identity_1_Test; + + + + procedure Subtraction_Error_Test is + -- This test detects the error resulting from subtraction if + -- the obvious algorithm was used for computing sinh. That is, + -- it it is computed as (e**x - e**-x)/2. + -- We check the result by using a Taylor series expansion that + -- will produce a result accurate to the machine precision for + -- the range under test. + -- + -- The maximum relative error bound for this test is + -- 8 for the sinh operation and 7 for the Taylor series + -- for a total of 15 * Model_Epsilon + A : constant := 0.0; + B : constant := 0.5; + X : Real; + X_Squared : Real; + Actual, Expected : Real; + begin + if Real'digits > 15 then + return; -- The approximation below is not accurate beyond + -- 15 digits. Adding more terms makes the error + -- larger, so it makes the test worse for more normal + -- values. Thus, we skip this subtest for larger than + -- 15 digits. + end if; + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + X_Squared := X * X; + + Actual := Sinh(X); + + -- The Taylor series regrouped a bit + Expected := + X * (1.0 + (X_Squared / 6.0) * + (1.0 + (X_Squared/20.0) * + (1.0 + (X_Squared/42.0) * + (1.0 + (X_Squared/72.0) * + (1.0 + (X_Squared/110.0) * + (1.0 + (X_Squared/156.0) + )))))); + + Check (Actual, Expected, + "Subtraction_Error_Test " & Integer'Image (I) & ": sinh(" & + Real'Image (X) & ") ", + 15.0); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Subtraction_Error_Test"); + when others => + Report.Failed ("exception in Subtraction_Error_Test"); + end Subtraction_Error_Test; + + + procedure Exception_Test is + X1, X2 : Real := 0.0; + begin + -- this part of the test is only applicable if 'Machine_Overflows + -- is true. + if Real'Machine_Overflows then + + begin + X1 := Sinh (Real'Safe_Last / 2.0); + Report.Failed ("no exception for sinh overflow"); + exception + when Constraint_Error => null; + when others => + Report.Failed ("wrong exception sinh overflow"); + end; + + begin + X2 := Cosh (Real'Safe_Last / 2.0); + Report.Failed ("no exception for cosh overflow"); + exception + when Constraint_Error => null; + when others => + Report.Failed ("wrong exception cosh overflow"); + end; + + end if; + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1 + X2)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + Identity_1_Test; + Subtraction_Error_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2014", + "Check the accuracy of the SINH and COSH functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2014; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2015.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,686 ---- + -- CXG2015.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the ARCSIN and ARCCOS functions return + -- results that are within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks in a specific range where a Taylor series can be + -- used to compute an accurate result for comparison. + -- Exception checks. + -- The Taylor series tests are a direct translation of the + -- FORTRAN code found in the reference. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 18 Mar 96 SAIC Initial release for 2.1 + -- 24 Apr 96 SAIC Fixed error bounds. + -- 17 Aug 96 SAIC Added reference information and improved + -- checking for machines with more than 23 + -- digits of precision. + -- 03 Feb 97 PWB.CTA Removed checks with explicit Cycle => 2.0*Pi + -- 22 Dec 99 RLB Added model range checking to "exact" results, + -- in order to avoid too strictly requiring a specific + -- result, and too weakly checking results. + -- + -- CHANGE NOTE: + -- According to Ken Dritz, author of the Numerics Annex of the RM, + -- one should never specify the cycle 2.0*Pi for the trigonometric + -- functions. In particular, if the machine number for the first + -- argument is not an exact multiple of the machine number for the + -- explicit cycle, then the specified exact results cannot be + -- reasonably expected. The affected checks in this test have been + -- marked as comments, with the additional notation "pwb-math". + -- Phil Brashear + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + -- CELEFUNT: A Portable Test Package for Complex Elementary Functions + -- ACM Collected Algorithms number 714 + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2015 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + -- relative error bound from G.2.4(7);6.0 + Minimum_Error : constant := 4.0; + + generic + type Real is digits <>; + Half_PI_Low : in Real; -- The machine number closest to, but not greater + -- than PI/2.0. + Half_PI_High : in Real;-- The machine number closest to, but not less + -- than PI/2.0. + PI_Low : in Real; -- The machine number closest to, but not greater + -- than PI. + PI_High : in Real; -- The machine number closest to, but not less + -- than PI. + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + + function Arcsin (X : Real) return Real renames + Elementary_Functions.Arcsin; + function Arcsin (X, Cycle : Real) return Real renames + Elementary_Functions.Arcsin; + function Arccos (X : Real) return Real renames + Elementary_Functions.ArcCos; + function Arccos (X, Cycle : Real) return Real renames + Elementary_Functions.ArcCos; + + -- needed for support + function Log (X, Base : Real) return Real renames + Elementary_Functions.Log; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used. + + type Data_Point is + record + Degrees, + Radians, + Argument, + Error_Bound : Real; + end record; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + + -- the values in the following tables only involve static + -- expressions so no loss of precision occurs. However, + -- rounding can be an issue with expressions involving Pi + -- and square roots. The error bound specified in the + -- table takes the sqrt error into account but not the + -- error due to Pi. The Pi error is added in in the + -- radians test below. + + Arcsin_Test_Data : constant Test_Data_Type := ( + -- degrees radians sine error_bound test # + --( 0.0, 0.0, 0.0, 0.0 ), -- 1 - In Exact_Result_Test. + ( 30.0, Pi/6.0, 0.5, 4.0 ), -- 2 + ( 60.0, Pi/3.0, Sqrt3/2.0, 5.0 ), -- 3 + --( 90.0, Pi/2.0, 1.0, 4.0 ), -- 4 - In Exact_Result_Test. + --(-90.0, -Pi/2.0, -1.0, 4.0 ), -- 5 - In Exact_Result_Test. + (-60.0, -Pi/3.0, -Sqrt3/2.0, 5.0 ), -- 6 + (-30.0, -Pi/6.0, -0.5, 4.0 ), -- 7 + ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8 + (-45.0, -Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9 + + Arccos_Test_Data : constant Test_Data_Type := ( + -- degrees radians cosine error_bound test # + --( 0.0, 0.0, 1.0, 0.0 ), -- 1 - In Exact_Result_Test. + ( 30.0, Pi/6.0, Sqrt3/2.0, 5.0 ), -- 2 + ( 60.0, Pi/3.0, 0.5, 4.0 ), -- 3 + --( 90.0, Pi/2.0, 0.0, 4.0 ), -- 4 - In Exact_Result_Test. + (120.0, 2.0*Pi/3.0, -0.5, 4.0 ), -- 5 + (150.0, 5.0*Pi/6.0, -Sqrt3/2.0, 5.0 ), -- 6 + --(180.0, Pi, -1.0, 4.0 ), -- 7 - In Exact_Result_Test. + ( 45.0, Pi/4.0, Sqrt2/2.0, 5.0 ), -- 8 + (135.0, 3.0*Pi/4.0, -Sqrt2/2.0, 5.0 ) ); -- 9 + + Cycle_Error, + Radian_Error : Real; + begin + for I in Arcsin_Test_Data'Range loop + + -- note exact result requirements A.5.1(38);6.0 and + -- G.2.4(12);6.0 + if Arcsin_Test_Data (I).Error_Bound = 0.0 then + Cycle_Error := 0.0; + Radian_Error := 0.0; + else + Cycle_Error := Arcsin_Test_Data (I).Error_Bound; + -- allow for rounding error in the specification of Pi + Radian_Error := Cycle_Error + 1.0; + end if; + + Check (Arcsin (Arcsin_Test_Data (I).Argument), + Arcsin_Test_Data (I).Radians, + "test" & Integer'Image (I) & + " arcsin(" & + Real'Image (Arcsin_Test_Data (I).Argument) & + ")", + Radian_Error); + --pwb-math Check (Arcsin (Arcsin_Test_Data (I).Argument, 2.0 * Pi), + --pwb-math Arcsin_Test_Data (I).Radians, + --pwb-math "test" & Integer'Image (I) & + --pwb-math " arcsin(" & + --pwb-math Real'Image (Arcsin_Test_Data (I).Argument) & + --pwb-math ", 2pi)", + --pwb-math Cycle_Error); + Check (Arcsin (Arcsin_Test_Data (I).Argument, 360.0), + Arcsin_Test_Data (I).Degrees, + "test" & Integer'Image (I) & + " arcsin(" & + Real'Image (Arcsin_Test_Data (I).Argument) & + ", 360)", + Cycle_Error); + end loop; + + + for I in Arccos_Test_Data'Range loop + + -- note exact result requirements A.5.1(39);6.0 and + -- G.2.4(12);6.0 + if Arccos_Test_Data (I).Error_Bound = 0.0 then + Cycle_Error := 0.0; + Radian_Error := 0.0; + else + Cycle_Error := Arccos_Test_Data (I).Error_Bound; + -- allow for rounding error in the specification of Pi + Radian_Error := Cycle_Error + 1.0; + end if; + + Check (Arccos (Arccos_Test_Data (I).Argument), + Arccos_Test_Data (I).Radians, + "test" & Integer'Image (I) & + " arccos(" & + Real'Image (Arccos_Test_Data (I).Argument) & + ")", + Radian_Error); + --pwb-math Check (Arccos (Arccos_Test_Data (I).Argument, 2.0 * Pi), + --pwb-math Arccos_Test_Data (I).Radians, + --pwb-math "test" & Integer'Image (I) & + --pwb-math " arccos(" & + --pwb-math Real'Image (Arccos_Test_Data (I).Argument) & + --pwb-math ", 2pi)", + --pwb-math Cycle_Error); + Check (Arccos (Arccos_Test_Data (I).Argument, 360.0), + Arccos_Test_Data (I).Degrees, + "test" & Integer'Image (I) & + " arccos(" & + Real'Image (Arccos_Test_Data (I).Argument) & + ", 360)", + Cycle_Error); + end loop; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + procedure Check_Exact (Actual, Expected_Low, Expected_High : Real; + Test_Name : String) is + -- If the expected result is not a model number, then Expected_Low is + -- the first machine number less than the (exact) expected + -- result, and Expected_High is the first machine number greater than + -- the (exact) expected result. If the expected result is a model + -- number, Expected_Low = Expected_High = the result. + Model_Expected_Low : Real := Expected_Low; + Model_Expected_High : Real := Expected_High; + begin + -- Calculate the first model number nearest to, but below (or equal) + -- to the expected result: + while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop + -- Try the next machine number lower: + Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0); + end loop; + -- Calculate the first model number nearest to, but above (or equal) + -- to the expected result: + while Real'Model (Model_Expected_High) /= Model_Expected_High loop + -- Try the next machine number higher: + Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0); + end loop; + + if Actual < Model_Expected_Low or Actual > Model_Expected_High then + Accuracy_Error_Reported := True; + if Actual < Model_Expected_Low then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected low: " & Real'Image (Model_Expected_Low) & + " expected high: " & Real'Image (Model_Expected_High) & + " difference: " & Real'Image (Actual - Expected_Low)); + else + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected low: " & Real'Image (Model_Expected_Low) & + " expected high: " & Real'Image (Model_Expected_High) & + " difference: " & Real'Image (Expected_High - Actual)); + end if; + elsif Verbose then + Report.Comment (Test_Name & " passed"); + end if; + end Check_Exact; + + + procedure Exact_Result_Test is + begin + -- A.5.1(38) + Check_Exact (Arcsin (0.0), 0.0, 0.0, "arcsin(0)"); + Check_Exact (Arcsin (0.0, 45.0), 0.0, 0.0, "arcsin(0,45)"); + + -- A.5.1(39) + Check_Exact (Arccos (1.0), 0.0, 0.0, "arccos(1)"); + Check_Exact (Arccos (1.0, 75.0), 0.0, 0.0, "arccos(1,75)"); + + -- G.2.4(11-13) + Check_Exact (Arcsin (1.0), Half_PI_Low, Half_PI_High, "arcsin(1)"); + Check_Exact (Arcsin (1.0, 360.0), 90.0, 90.0, "arcsin(1,360)"); + + Check_Exact (Arcsin (-1.0), -Half_PI_High, -Half_PI_Low, "arcsin(-1)"); + Check_Exact (Arcsin (-1.0, 360.0), -90.0, -90.0, "arcsin(-1,360)"); + + Check_Exact (Arccos (0.0), Half_PI_Low, Half_PI_High, "arccos(0)"); + Check_Exact (Arccos (0.0, 360.0), 90.0, 90.0, "arccos(0,360)"); + + Check_Exact (Arccos (-1.0), PI_Low, PI_High, "arccos(-1)"); + Check_Exact (Arccos (-1.0, 360.0), 180.0, 180.0, "arccos(-1,360)"); + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("Exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Arcsin_Taylor_Series_Test is + -- the following range is chosen so that the Taylor series + -- used will produce a result accurate to machine precision. + -- + -- The following formula is used for the Taylor series: + -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) + + -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] } + -- where xsq = x * x + -- + A : constant := -0.125; + B : constant := 0.125; + X : Real; + Y, Y_Sq : Real; + Actual, Sum, Xm : Real; + -- terms in Taylor series + K : constant Integer := Integer ( + Log ( + Real (Real'Machine_Radix) ** Real'Machine_Mantissa, + 10.0)) + 1; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + -- make sure there is no error in x-1, x, and x+1 + X := (B - A) * Real (I) / Real (Max_Samples) + A; + + Y := X; + Y_Sq := Y * Y; + Sum := 0.0; + Xm := Real (K + K + 1); + for M in 1 .. K loop + Sum := Y_Sq * (Sum + 1.0/Xm); + Xm := Xm - 2.0; + Sum := Sum * (Xm /(Xm + 1.0)); + end loop; + Sum := Sum * Y; + Actual := Y + Sum; + Sum := (Y - Actual) + Sum; + if not Real'Machine_Rounds then + Actual := Actual + (Sum + Sum); + end if; + + Check (Actual, Arcsin (X), + "Taylor Series test" & Integer'Image (I) & ": arcsin(" & + Real'Image (X) & ") ", + Minimum_Error); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Arcsin_Taylor_Series_Test" & + " for X=" & Real'Image (X)); + when others => + Report.Failed ("exception in Arcsin_Taylor_Series_Test" & + " for X=" & Real'Image (X)); + end Arcsin_Taylor_Series_Test; + + + + procedure Arccos_Taylor_Series_Test is + -- the following range is chosen so that the Taylor series + -- used will produce a result accurate to machine precision. + -- + -- The following formula is used for the Taylor series: + -- TS(x) = x { 1 + (xsq/2) [ (1/3) + (3/4)xsq { (1/5) + + -- (5/6)xsq [ (1/7) + (7/8)xsq/9 ] } ] } + -- arccos(x) = pi/2 - TS(x) + A : constant := -0.125; + B : constant := 0.125; + C1, C2 : Real; + X : Real; + Y, Y_Sq : Real; + Actual, Sum, Xm, S : Real; + -- terms in Taylor series + K : constant Integer := Integer ( + Log ( + Real (Real'Machine_Radix) ** Real'Machine_Mantissa, + 10.0)) + 1; + begin + if Real'Digits > 23 then + -- constants in this section only accurate to 23 digits + Error_Low_Bound := 0.00000_00000_00000_00000_001; + Report.Comment ("arctan accuracy checked to 23 digits"); + end if; + + -- C1 + C2 equals Pi/2 accurate to 23 digits + if Real'Machine_Radix = 10 then + C1 := 1.57; + C2 := 7.9632679489661923132E-4; + else + C1 := 201.0 / 128.0; + C2 := 4.8382679489661923132E-4; + end if; + + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + -- make sure there is no error in x-1, x, and x+1 + X := (B - A) * Real (I) / Real (Max_Samples) + A; + + Y := X; + Y_Sq := Y * Y; + Sum := 0.0; + Xm := Real (K + K + 1); + for M in 1 .. K loop + Sum := Y_Sq * (Sum + 1.0/Xm); + Xm := Xm - 2.0; + Sum := Sum * (Xm /(Xm + 1.0)); + end loop; + Sum := Sum * Y; + + -- at this point we have arcsin(x). + -- We compute arccos(x) = pi/2 - arcsin(x). + -- The following code segment is translated directly from + -- the CELEFUNT FORTRAN implementation + + S := C1 + C2; + Sum := ((C1 - S) + C2) - Sum; + Actual := S + Sum; + Sum := ((S - Actual) + Sum) - Y; + S := Actual; + Actual := S + Sum; + Sum := (S - Actual) + Sum; + + if not Real'Machine_Rounds then + Actual := Actual + (Sum + Sum); + end if; + + Check (Actual, Arccos (X), + "Taylor Series test" & Integer'Image (I) & ": arccos(" & + Real'Image (X) & ") ", + Minimum_Error); + + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + exit when Accuracy_Error_Reported; + end loop; + Error_Low_Bound := 0.0; -- reset + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Arccos_Taylor_Series_Test" & + " for X=" & Real'Image (X)); + when others => + Report.Failed ("exception in Arccos_Taylor_Series_Test" & + " for X=" & Real'Image (X)); + end Arccos_Taylor_Series_Test; + + + + procedure Identity_Test is + -- test the identity arcsin(-x) = -arcsin(x) + -- range chosen to be most of the valid range of the argument. + A : constant := -0.999; + B : constant := 0.999; + X : Real; + begin + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + -- make sure there is no error in x-1, x, and x+1 + X := (B - A) * Real (I) / Real (Max_Samples) + A; + + Check (Arcsin(-X), -Arcsin (X), + "Identity test" & Integer'Image (I) & ": arcsin(" & + Real'Image (X) & ") ", + 8.0); -- 2 arcsin evaluations => twice the error bound + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + end Identity_Test; + + + procedure Exception_Test is + X1, X2 : Real := 0.0; + begin + begin + X1 := Arcsin (1.1); + Report.Failed ("no exception for Arcsin (1.1)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error instead of " & + "Argument_Error for Arcsin (1.1)"); + when Ada.Numerics.Argument_Error => + null; -- expected result + when others => + Report.Failed ("wrong exception for Arcsin(1.1)"); + end; + + begin + X2 := Arccos (-1.1); + Report.Failed ("no exception for Arccos (-1.1)"); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error instead of " & + "Argument_Error for Arccos (-1.1)"); + when Ada.Numerics.Argument_Error => + null; -- expected result + when others => + Report.Failed ("wrong exception for Arccos(-1.1)"); + end; + + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1 + X2)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + Arcsin_Taylor_Series_Test; + Arccos_Taylor_Series_Test; + Identity_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + -- These expressions must be truly static, which is why we have to do them + -- outside of the generic, and we use the named numbers. Note that we know + -- that PI is not a machine number (it is irrational), and it should be + -- represented to more digits than supported by the target machine. + Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0); + Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0); + Float_PI_Low : constant := Float'Adjacent(PI, 0.0); + Float_PI_High : constant := Float'Adjacent(PI, 10.0); + package Float_Check is new Generic_Check (Float, + Half_PI_Low => Float_Half_PI_Low, + Half_PI_High => Float_Half_PI_High, + PI_Low => Float_PI_Low, + PI_High => Float_PI_High); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0); + A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0); + A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0); + A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0); + package A_Long_Float_Check is new Generic_Check (A_Long_Float, + Half_PI_Low => A_Long_Float_Half_PI_Low, + Half_PI_High => A_Long_Float_Half_PI_High, + PI_Low => A_Long_Float_PI_Low, + PI_High => A_Long_Float_PI_High); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2015", + "Check the accuracy of the ARCSIN and ARCCOS functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2015; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2016.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,482 ---- + -- CXG2016.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the ARCTAN function returns a + -- result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Exception checks. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 19 Mar 96 SAIC Initial release for 2.1 + -- 30 APR 96 SAIC Fixed optimization issue + -- 17 AUG 96 SAIC Incorporated Reviewer's suggestions. + -- 12 OCT 96 SAIC Incorporated Reviewer's suggestions. + -- 02 DEC 97 EDS Remove procedure Identity_1_Test and calls to + -- procedure. + -- 29 JUN 98 EDS Replace -0.0 with call to ImpDef.Annex_G.Negative_Zero + -- 28 APR 99 RLB Replaced comma accidentally deleted in above change. + -- 15 DEC 99 RLB Added model range checking to "exact" results, + -- in order to avoid too strictly requiring a specific + -- result. + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + with Impdef.Annex_G; + procedure CXG2016 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + Half_PI_Low : in Real; -- The machine number closest to, but not greater + -- than PI/2.0. + Half_PI_High : in Real;-- The machine number closest to, but not less + -- than PI/2.0. + PI_Low : in Real; -- The machine number closest to, but not greater + -- than PI. + PI_High : in Real; -- The machine number closest to, but not less + -- than PI. + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + + function Arctan (Y : Real; + X : Real := 1.0) return Real renames + Elementary_Functions.Arctan; + function Arctan (Y : Real; + X : Real := 1.0; + Cycle : Real) return Real renames + Elementary_Functions.Arctan; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Value_Test is + -- If eta is very small, arctan(x + eta) ~= arctan(x) + eta/(1+x*x). + -- + -- For tests 4 and 5, there is an error of 4.0ME for arctan + an + -- additional error of 1.0ME because pi is not exact for a total of 5.0ME. + -- + -- In test 3 there is the error for pi plus an additional error + -- of (1.0ME)/4 since sqrt3 is not exact, for a total of 5.25ME. + -- + -- In test 2 there is the error for pi plus an additional error + -- of (3/4)(1.0ME) since sqrt3 is not exact, for a total of 5.75ME. + + + type Data_Point is + record + Degrees, + Radians, + Tangent, + Allowed_Error : Real; + end record; + + type Test_Data_Type is array (Positive range <>) of Data_Point; + + -- the values in the following table only involve static + -- expressions so no additional loss of precision occurs. + Test_Data : constant Test_Data_Type := ( + -- degrees radians tangent error test # + ( 0.0, 0.0, 0.0, 4.0 ), -- 1 + ( 30.0, Pi/6.0, Sqrt3/3.0, 5.75), -- 2 + ( 60.0, Pi/3.0, Sqrt3, 5.25), -- 3 + ( 45.0, Pi/4.0, 1.0, 5.0 ), -- 4 + (-45.0, -Pi/4.0, -1.0, 5.0 ) ); -- 5 + + begin + for I in Test_Data'Range loop + Check (Arctan (Test_Data (I).Tangent), + Test_Data (I).Radians, + "special value test" & Integer'Image (I) & + " arctan(" & + Real'Image (Test_Data (I).Tangent) & + ")", + Test_Data (I).Allowed_Error); + Check (Arctan (Test_Data (I).Tangent, Cycle => 360.0), + Test_Data (I).Degrees, + "special value test" & Integer'Image (I) & + " arctan(" & + Real'Image (Test_Data (I).Tangent) & + ", cycle=>360)", + Test_Data (I).Allowed_Error); + end loop; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Check_Exact (Actual, Expected_Low, Expected_High : Real; + Test_Name : String) is + -- If the expected result is not a model number, then Expected_Low is + -- the first machine number less than the (exact) expected + -- result, and Expected_High is the first machine number greater than + -- the (exact) expected result. If the expected result is a model + -- number, Expected_Low = Expected_High = the result. + Model_Expected_Low : Real := Expected_Low; + Model_Expected_High : Real := Expected_High; + begin + -- Calculate the first model number nearest to, but below (or equal) + -- to the expected result: + while Real'Model (Model_Expected_Low) /= Model_Expected_Low loop + -- Try the next machine number lower: + Model_Expected_Low := Real'Adjacent(Model_Expected_Low, 0.0); + end loop; + -- Calculate the first model number nearest to, but above (or equal) + -- to the expected result: + while Real'Model (Model_Expected_High) /= Model_Expected_High loop + -- Try the next machine number higher: + Model_Expected_High := Real'Adjacent(Model_Expected_High, 100.0); + end loop; + + if Actual < Model_Expected_Low or Actual > Model_Expected_High then + Accuracy_Error_Reported := True; + if Actual < Model_Expected_Low then + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected low: " & Real'Image (Model_Expected_Low) & + " expected high: " & Real'Image (Model_Expected_High) & + " difference: " & Real'Image (Actual - Expected_Low)); + else + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected low: " & Real'Image (Model_Expected_Low) & + " expected high: " & Real'Image (Model_Expected_High) & + " difference: " & Real'Image (Expected_High - Actual)); + end if; + elsif Verbose then + Report.Comment (Test_Name & " passed"); + end if; + end Check_Exact; + + + procedure Exact_Result_Test is + begin + -- A.5.1(40);6.0 + Check_Exact (Arctan (0.0, 1.0), 0.0, 0.0, "arctan(0,1)"); + Check_Exact (Arctan (0.0, 1.0, 27.0), 0.0, 0.0, "arctan(0,1,27)"); + + -- G.2.4(11-13);6.0 + + Check_Exact (Arctan (1.0, 0.0), Half_PI_Low, Half_PI_High, + "arctan(1,0)"); + Check_Exact (Arctan (1.0, 0.0, 360.0), 90.0, 90.0, "arctan(1,0,360)"); + + Check_Exact (Arctan (-1.0, 0.0), -Half_PI_High, -Half_PI_Low, + "arctan(-1,0)"); + Check_Exact (Arctan (-1.0, 0.0, 360.0), -90.0, -90.0, + "arctan(-1,0,360)"); + + if Real'Signed_Zeros then + Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(+0,-1)"); + Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0, + "arctan(+0,-1,360)"); + Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0), + -PI_High, -PI_Low, "arctan(-0,-1)"); + Check_Exact (Arctan ( Real ( ImpDef.Annex_G.Negative_Zero ), -1.0, + 360.0), -180.0, -180.0, "arctan(-0,-1,360)"); + else + Check_Exact (Arctan (0.0, -1.0), PI_Low, PI_High, "arctan(0,-1)"); + Check_Exact (Arctan (0.0, -1.0, 360.0), 180.0, 180.0, + "arctan(0,-1,360)"); + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("Exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Taylor_Series_Test is + -- This test checks the Arctan by using a taylor series expansion that + -- will produce a result accurate to 19 decimal digits for + -- the range under test. + -- + -- The maximum relative error bound for this test is + -- 4 for the arctan operation and 2 for the Taylor series + -- for a total of 6 * Model_Epsilon + + A : constant := -1.0/16.0; + B : constant := 1.0/16.0; + X : Real; + Actual, Expected : Real; + Sum, Em, X_Squared : Real; + begin + if Real'Digits > 19 then + -- Taylor series calculation produces result accurate to 19 + -- digits. If type being tested has more digits then set + -- the error low bound to account for this. + -- The error low bound is conservatively set to 6*10**-19 + Error_Low_Bound := 0.00000_00000_00000_0006; + Report.Comment ("arctan accuracy checked to 19 digits"); + end if; + + Accuracy_Error_Reported := False; -- reset + for I in 0..Max_Samples loop + X := (B - A) * Real (I) / Real (Max_Samples) + A; + X_Squared := X * X; + Em := 17.0; + Sum := X_Squared / Em; + + for II in 1 .. 7 loop + Em := Em - 2.0; + Sum := (1.0 / Em - Sum) * X_Squared; + end loop; + Sum := -X * Sum; + Expected := X + Sum; + Sum := (X - Expected) + Sum; + if not Real'Machine_Rounds then + Expected := Expected + (Sum + Sum); + end if; + + Actual := Arctan (X); + + Check (Actual, Expected, + "Taylor_Series_Test " & Integer'Image (I) & ": arctan(" & + Real'Image (X) & ") ", + 6.0); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + Error_Low_Bound := 0.0; -- reset + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Taylor_Series_Test"); + when others => + Report.Failed ("exception in Taylor_Series_Test"); + end Taylor_Series_Test; + + + procedure Exception_Test is + X1, X2, X3 : Real := 0.0; + begin + + begin -- A.5.1(20);6.0 + X1 := Arctan(0.0, Cycle => 0.0); + Report.Failed ("no exception for cycle = 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle = 0.0"); + end; + + begin -- A.5.1(20);6.0 + X2 := Arctan (0.0, Cycle => -1.0); + Report.Failed ("no exception for cycle < 0.0"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for cycle < 0.0"); + end; + + begin -- A.5.1(25);6.0 + X3 := Arctan (0.0, 0.0); + Report.Failed ("no exception for arctan(0,0)"); + exception + when Ada.Numerics.Argument_Error => null; + when others => + Report.Failed ("wrong exception for arctan(0,0)"); + end; + + -- optimizer thwarting + if Report.Ident_Bool (False) then + Report.Comment (Real'Image (X1 + X2 + X3)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + Taylor_Series_Test; + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + -- These expressions must be truly static, which is why we have to do them + -- outside of the generic, and we use the named numbers. Note that we know + -- that PI is not a machine number (it is irrational), and it should be + -- represented to more digits than supported by the target machine. + Float_Half_PI_Low : constant := Float'Adjacent(PI/2.0, 0.0); + Float_Half_PI_High : constant := Float'Adjacent(PI/2.0, 10.0); + Float_PI_Low : constant := Float'Adjacent(PI, 0.0); + Float_PI_High : constant := Float'Adjacent(PI, 10.0); + package Float_Check is new Generic_Check (Float, + Half_PI_Low => Float_Half_PI_Low, + Half_PI_High => Float_Half_PI_High, + PI_Low => Float_PI_Low, + PI_High => Float_PI_High); + + -- check the Floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + A_Long_Float_Half_PI_Low : constant := A_Long_Float'Adjacent(PI/2.0, 0.0); + A_Long_Float_Half_PI_High : constant := A_Long_Float'Adjacent(PI/2.0, 10.0); + A_Long_Float_PI_Low : constant := A_Long_Float'Adjacent(PI, 0.0); + A_Long_Float_PI_High : constant := A_Long_Float'Adjacent(PI, 10.0); + package A_Long_Float_Check is new Generic_Check (A_Long_Float, + Half_PI_Low => A_Long_Float_Half_PI_Low, + Half_PI_High => A_Long_Float_Half_PI_High, + PI_Low => A_Long_Float_PI_Low, + PI_High => A_Long_Float_PI_High); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2016", + "Check the accuracy of the ARCTAN function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2016; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2017.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,296 ---- + -- CXG2017.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the TANH function returns + -- a result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 20 Mar 96 SAIC Initial release for 2.1 + -- 17 Aug 96 SAIC Incorporated reviewer comments. + -- 03 Jun 98 EDS Add parens to remove the potential for overflow. + -- Remove the invocation of Identity_Test that checks + -- Tanh values that are too close to zero for the + -- test's error bounds. + --! + + -- + -- References: + -- + -- Software Manual for the Elementary Functions + -- William J. Cody, Jr. and William Waite + -- Prentice-Hall, 1980 + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + -- Implementation and Testing of Function Software + -- W. J. Cody + -- Problems and Methodologies in Mathematical Software Production + -- editors P. C. Messina and A. Murli + -- Lecture Notes in Computer Science Volume 142 + -- Springer Verlag, 1982 + -- + + with System; + with Report; + with Ada.Numerics.Generic_Elementary_Functions; + procedure CXG2017 is + Verbose : constant Boolean := False; + Max_Samples : constant := 1000; + + E : constant := Ada.Numerics.E; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Elementary_Functions is new + Ada.Numerics.Generic_Elementary_Functions (Real); + + function Tanh (X : Real) return Real renames + Elementary_Functions.Tanh; + + function Log (X : Real) return Real renames + Elementary_Functions.Log; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Small instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Small; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used. + Minimum_Error : constant := 8.0; + E2 : constant := E * E; + begin + Check (Tanh (1.0), + (E - 1.0 / E) / (E + 1.0 / E), + "tanh(1)", + Minimum_Error); + Check (Tanh (2.0), + (E2 - 1.0 / E2) / (E2 + 1.0 / E2), + "tanh(2)", + Minimum_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- A.5.1(38);6.0 + Check (Tanh (0.0), 0.0, "tanh(0)", No_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_Test (A, B : Real) is + -- For this test we use the identity + -- TANH(u+v) = [TANH(u) + TANH(v)] / [1 + TANH(u)*TANH(v)] + -- which is transformed to + -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C] + -- where C = TANH(1/8) and y = x - 1/8 + -- + -- see Cody pg 248-249 for details on the error analysis. + -- The net result is a relative error bound of 16 * Model_Epsilon. + -- + -- The second part of this test checks the identity + -- TANH(-x) = -TANH(X) + + X, Y : Real; + Actual1, Actual2 : Real; + C : constant := 1.2435300177159620805e-1; + begin + if Real'Digits > 20 then + -- constant C is accurate to 20 digits. Set the low bound + -- on the error to 16*10**-20 + Error_Low_Bound := 0.00000_00000_00000_00016; + Report.Comment ("tanh accuracy checked to 20 digits"); + end if; + + Accuracy_Error_Reported := False; -- reset + for I in 1..Max_Samples loop + X := (B - A) * (Real (I) / Real (Max_Samples)) + A; + Actual1 := Tanh(X); + + -- TANH(x) = [TANH(y)+C] / [1 + TANH(y) * C] + Y := X - (1.0 / 8.0); + Actual2 := (Tanh (Y) + C) / (1.0 + Tanh(Y) * C); + + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (I) & ": tanh(" & + Real'Image (X) & ") ", + 16.0); + + -- TANH(-x) = -TANH(X) + Actual2 := Tanh(-X); + Check (-Actual1, Actual2, + "Identity_2_Test " & Integer'Image (I) & ": tanh(" & + Real'Image (X) & ") ", + 16.0); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + + end loop; + Error_Low_Bound := 0.0; -- reset + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_Test" & + " for X=" & Real'Image (X)); + when others => + Report.Failed ("exception in Identity_Test" & + " for X=" & Real'Image (X)); + end Identity_Test; + + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + -- cover a large range + Identity_Test (1.0, Real'Safe_Last); + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2017", + "Check the accuracy of the TANH function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2017; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2018.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,355 ---- + -- CXG2018.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex EXP function returns + -- a result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check complex numbers based upon + -- both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 21 Mar 96 SAIC Initial release for 2.1 + -- 17 Aug 96 SAIC Incorporated reviewer comments. + -- 27 Aug 99 RLB Repair on the error result of checks. + -- 02 Apr 03 RLB Added code to discard excess precision in the + -- construction of the test value for the + -- Identity_Test. + -- + --! + + -- + -- References: + -- + -- W. J. Cody + -- CELEFUNT: A Portable Test Package for Complex Elementary Functions + -- Algorithm 714, Collected Algorithms from ACM. + -- Published in Transactions On Mathematical Software, + -- Vol. 19, No. 1, March, 1993, pp. 1-21. + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + procedure CXG2018 is + Verbose : constant Boolean := False; + -- Note that Max_Samples is the number of samples taken in + -- both the real and imaginary directions. Thus, for Max_Samples + -- of 100 the number of values checked is 10000. + Max_Samples : constant := 100; + + E : constant := Ada.Numerics.E; + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Type is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Type; + + package CEF is new + Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); + + function Exp (X : Complex) return Complex renames CEF.Exp; + function Exp (X : Imaginary) return Complex renames CEF.Exp; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Small instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Small; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MRE : Real) is + begin + Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); + Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used. + -- + -- The error bounds given assumed z is exact. When using + -- pi there is an extra error of 1.0ME. + -- The pi inside the exp call requires that the complex + -- component have an extra error allowance of 1.0*angle*ME. + -- Thus for pi/2,the Minimum_Error_I is + -- (2.0 + 1.0(pi/2))ME <= 3.6ME. + -- For pi, it is (2.0 + 1.0*pi)ME <= 5.2ME, + -- and for 2pi, it is (2.0 + 1.0(2pi))ME <= 8.3ME. + + -- The addition of 1 or i to a result is so that neither of + -- the components of an expected result is 0. This is so + -- that a reasonable relative error is allowed. + Minimum_Error_C : constant := 7.0; -- for exp(Complex) + Minimum_Error_I : constant := 2.0; -- for exp(Imaginary) + begin + Check (Exp (1.0 + 0.0*i) + i, + E + i, + "exp(1+0i)", + Minimum_Error_C); + Check (Exp ((Pi / 2.0) * i) + 1.0, + 1.0 + 1.0*i, + "exp(pi/2*i)", + 3.6); + Check (Exp (Pi * i) + i, + -1.0 + 1.0*i, + "exp(pi*i)", + 5.2); + Check (Exp (Pi * 2.0 * i) + i, + 1.0 + i, + "exp(2pi*i)", + 8.3); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- G.1.2(36);6.0 + Check (Exp(0.0 + 0.0*i), 1.0 + 0.0 * i, "exp(0+0i)", No_Error); + Check (Exp( 0.0*i), 1.0 + 0.0 * i, "exp(0i)", No_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_Test (A, B : Real) is + -- For this test we use the identity + -- Exp(Z) = Exp(Z-W) * Exp (W) + -- where W = (1+i)/16 + -- + -- The second part of this test checks the identity + -- Exp(Z) * Exp(-Z) = 1 + -- + + X, Y : Complex; + Actual1, Actual2 : Complex; + W : constant Complex := (0.0625, 0.0625); + -- the following constant was taken from the CELEFUNC EXP test. + -- This is the value EXP(W) - 1 + C : constant Complex := (6.2416044877018563681e-2, + 6.6487597751003112768e-2); + begin + if Real'Digits > 20 then + -- constant ExpW is accurate to 20 digits. + -- The low bound is 19 * 10**-20 + Error_Low_Bound := 0.00000_00000_00019; + Report.Comment ("complex exp accuracy checked to 20 digits"); + end if; + + Accuracy_Error_Reported := False; -- reset + for II in 1..Max_Samples loop + X.Re := Real'Machine ((B - A) * Real (II) / Real (Max_Samples) + + A); + for J in 1..Max_Samples loop + X.Im := Real'Machine ((B - A) * Real (J) / Real (Max_Samples) + + A); + + Actual1 := Exp(X); + + -- Exp(X) = Exp(X-W) * Exp (W) + -- = Exp(X-W) * (1 - (1-Exp(W)) + -- = Exp(X-W) * (1 + (Exp(W) - 1)) + -- = Exp(X-W) * (1 + C) + Y := X - W; + Actual2 := Exp(Y); + Actual2 := Actual2 + Actual2 * C; + + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (II) & + Integer'Image (J) & ": Exp((" & + Real'Image (X.Re) & ", " & + Real'Image (X.Im) & ")) ", + 20.0); -- 2 exp and 1 multiply and 1 add = 2*7+1*5+1 + -- Note: The above is not strictly correct, as multiply + -- has a box error, rather than a relative error. + -- Supposedly, the interval is chosen to avoid the need + -- to worry about this. + + -- Exp(X) * Exp(-X) + i = 1 + i + -- The addition of i is to allow a reasonable relative + -- error in the imaginary part + Actual2 := (Actual1 * Exp(-X)) + i; + Check (Actual2, (1.0, 1.0), + "Identity_2_Test " & Integer'Image (II) & + Integer'Image (J) & ": Exp((" & + Real'Image (X.Re) & ", " & + Real'Image (X.Im) & ")) ", + 20.0); -- 2 exp and 1 multiply and one add = 2*7+1*5+1 + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + end loop; + Error_Low_Bound := 0.0; + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_Test" & + " for X=(" & Real'Image (X.Re) & + ", " & Real'Image (X.Im) & ")"); + when others => + Report.Failed ("exception in Identity_Test" & + " for X=(" & Real'Image (X.Re) & + ", " & Real'Image (X.Im) & ")"); + end Identity_Test; + + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + -- test regions where we can avoid cancellation error problems + -- See Cody page 10. + Identity_Test (0.0625, 1.0); + Identity_Test (15.0, 17.0); + Identity_Test (1.625, 3.0); + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2018", + "Check the accuracy of the complex EXP function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2018; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2019.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,338 ---- + -- CXG2019.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex LOG function returns + -- a result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check complex numbers based upon + -- both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- Exception conditions. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 22 Mar 96 SAIC Initial release for 2.1 + -- + --! + + -- + -- References: + -- + -- W. J. Cody + -- CELEFUNT: A Portable Test Package for Complex Elementary Functions + -- Algorithm 714, Collected Algorithms from ACM. + -- Published in Transactions On Mathematical Software, + -- Vol. 19, No. 1, March, 1993, pp. 1-21. + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + procedure CXG2019 is + Verbose : constant Boolean := False; + -- Note that Max_Samples is the number of samples taken in + -- both the real and imaginary directions. Thus, for Max_Samples + -- of 100 the number of values checked is 10000. + Max_Samples : constant := 100; + + E : constant := Ada.Numerics.E; + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Type is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Type; + + package CEF is new + Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); + + function Log (X : Complex) return Complex renames CEF.Log; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Small instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * abs Expected * Real'Model_Epsilon; + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MRE : Real) is + begin + Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); + Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used if the argument is exact. + -- + -- When using pi there is an extra error of 1.0ME. + -- Although the real component has an error bound of 13.0, + -- the complex component must take into account this error + -- in the value for Pi. + -- + -- One or i is added to the actual and expected results in + -- order to prevent the expected result from having a + -- real or imaginary part of 0. This is to allow a reasonable + -- relative error for that component. + Minimum_Error : constant := 13.0; + begin + Check (1.0 + Log (0.0 + i), + 1.0 + Pi / 2.0 * i, + "1+log(0+i)", + Minimum_Error + 1.0); + Check (1.0 + Log ((-1.0, 0.0)), + 1.0 + (Pi * i), + "log(-1+0i)+1 ", + Minimum_Error + 1.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- G.1.2(37);6.0 + Check (Log(1.0 + 0.0*i), 0.0 + 0.0 * i, "log(1+0i)", No_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_Test (RA, RB, IA, IB : Real) is + -- Tests an identity over a range of values specified + -- by the 4 parameters. RA and RB denote the range for the + -- real part while IA and IB denote the range for the + -- imaginary part. + -- + -- For this test we use the identity + -- Log(Z*Z) = 2 * Log(Z) + -- + + Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4); + W, X, Y, Z : Real; + CX, CY : Complex; + Actual1, Actual2 : Complex; + begin + Accuracy_Error_Reported := False; -- reset + for II in 1..Max_Samples loop + X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; + for J in 1..Max_Samples loop + Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; + + -- purify the arguments to minimize roundoff error. + -- We construct the values so that the products X*X, + -- Y*Y, and X*Y are all exact machine numbers. + -- See Cody page 7 and CELEFUNT code. + Z := X * Scale; + W := Z + X; + X := W - Z; + Z := Y * Scale; + W := Z + Y; + Y := W - Z; + CX := Compose_From_Cartesian(X,Y); + Z := X*X - Y*Y; + W := X*Y; + CY := Compose_From_Cartesian(Z,W+W); + + -- The arguments are now ready so on with the + -- identity computation. + Actual1 := Log(CX); + + Actual2 := Log(CY) * 0.5; + + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (II) & + Integer'Image (J) & ": Log((" & + Real'Image (CX.Re) & ", " & + Real'Image (CX.Im) & ")) ", + 26.0); -- 2 logs = 2*13. no error from this multiply + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_Test" & + " for X=(" & Real'Image (X) & + ", " & Real'Image (X) & ")"); + when others => + Report.Failed ("exception in Identity_Test" & + " for X=(" & Real'Image (X) & + ", " & Real'Image (X) & ")"); + end Identity_Test; + + + procedure Exception_Test is + -- Check that log((0,0)) causes constraint_error. + -- G.1.2(29); + + X : Complex := (0.0, 0.0); + begin + if not Real'Machine_Overflows then + -- not applicable: G.1.2(28);6.0 + return; + end if; + + begin + X := Log ((0.0, 0.0)); + Report.Failed ("exception not raised for log(0,0)"); + exception + when Constraint_Error => null; -- ok + when others => + Report.Failed ("wrong exception raised for log(0,0)"); + end; + + -- optimizer thwarting + if Report.Ident_Bool(False) then + Report.Comment (Real'Image (X.Re + X.Im)); + end if; + end Exception_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + -- test regions that do not include the unit circle so that + -- the real part of LOG(Z) does not vanish + -- See Cody page 9. + Identity_Test ( 2.0, 10.0, 0.0, 10.0); + Identity_Test (1000.0, 2000.0, -4000.0, -1000.0); + Identity_Test (Real'Model_Epsilon, 0.25, + -0.25, -Real'Model_Epsilon); + Exception_Test; + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2019", + "Check the accuracy of the complex LOG function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2019; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2020.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,351 ---- + -- CXG2020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex SQRT function returns + -- a result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check complex numbers based upon + -- both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 24 Mar 96 SAIC Initial release for 2.1 + -- 17 Aug 96 SAIC Incorporated reviewer comments. + -- 03 Jun 98 EDS Added parens to ensure that the expression is not + -- evaluated by multiplying its two large terms + -- together and overflowing. + --! + + -- + -- References: + -- + -- W. J. Cody + -- CELEFUNT: A Portable Test Package for Complex Elementary Functions + -- Algorithm 714, Collected Algorithms from ACM. + -- Published in Transactions On Mathematical Software, + -- Vol. 19, No. 1, March, 1993, pp. 1-21. + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + procedure CXG2020 is + Verbose : constant Boolean := False; + -- Note that Max_Samples is the number of samples taken in + -- both the real and imaginary directions. Thus, for Max_Samples + -- of 100 the number of values checked is 10000. + Max_Samples : constant := 100; + + E : constant := Ada.Numerics.E; + Pi : constant := Ada.Numerics.Pi; + + -- CRC Standard Mathematical Tables; 23rd Edition; pg 738 + Sqrt2 : constant := + 1.41421_35623_73095_04880_16887_24209_69807_85696_71875_37695; + Sqrt3 : constant := + 1.73205_08075_68877_29352_74463_41505_87236_69428_05253_81039; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Type is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Type; + + package CEF is new + Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); + + function Sqrt (X : Complex) return Complex renames CEF.Sqrt; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon + -- instead of Model_Epsilon and Expected. + Rel_Error := MRE * (abs Expected * Real'Model_Epsilon); + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed"); + end if; + end if; + end Check; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MRE : Real) is + begin + Check (Actual.Re, Expected.Re, Test_Name & " real part", MRE); + Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", MRE); + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used if the argument is exact. + -- + -- One or i is added to the actual and expected results in + -- order to prevent the expected result from having a + -- real or imaginary part of 0. This is to allow a reasonable + -- relative error for that component. + Minimum_Error : constant := 6.0; + Z1, Z2 : Complex; + begin + Check (Sqrt(9.0+0.0*i) + i, + 3.0+1.0*i, + "sqrt(9+0i)+i", + Minimum_Error); + Check (Sqrt (-2.0 + 0.0 * i) + 1.0, + 1.0 + Sqrt2 * i, + "sqrt(-2)+1 ", + Minimum_Error); + + -- make sure no exception occurs when taking the sqrt of + -- very large and very small values. + + Z1 := (Real'Safe_Last * 0.9, Real'Safe_Last * 0.9); + Z2 := Sqrt (Z1); + begin + Check (Z2 * Z2, + Z1, + "sqrt((big,big))", + Minimum_Error + 5.0); -- +5 for multiply + exception + when others => + Report.Failed ("unexpected exception in sqrt((big,big))"); + end; + + Z1 := (Real'Model_Epsilon * 10.0, Real'Model_Epsilon * 10.0); + Z2 := Sqrt (Z1); + begin + Check (Z2 * Z2, + Z1, + "sqrt((little,little))", + Minimum_Error + 5.0); -- +5 for multiply + exception + when others => + Report.Failed ("unexpected exception in " & + "sqrt((little,little))"); + end; + + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- G.1.2(36);6.0 + Check (Sqrt(0.0 + 0.0*i), 0.0 + 0.0 * i, "sqrt(0+0i)", No_Error); + + -- G.1.2(37);6.0 + Check (Sqrt(1.0 + 0.0*i), 1.0 + 0.0 * i, "sqrt(1+0i)", No_Error); + + -- G.1.2(38-39);6.0 + Check (Sqrt(-1.0 + 0.0*i), 0.0 + 1.0 * i, "sqrt(-1+0i)", No_Error); + + -- G.1.2(40);6.0 + if Real'Signed_Zeros then + Check (Sqrt(-1.0-0.0*i), 0.0 - 1.0 * i, "sqrt(-1-0i)", No_Error); + end if; + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_Test (RA, RB, IA, IB : Real) is + -- Tests an identity over a range of values specified + -- by the 4 parameters. RA and RB denote the range for the + -- real part while IA and IB denote the range for the + -- imaginary part of the result. + -- + -- For this test we use the identity + -- Sqrt(Z*Z) = Z + -- + + Scale : Real := Real (Real'Machine_Radix) ** (Real'Mantissa / 2 + 4); + W, X, Y, Z : Real; + CX : Complex; + Actual, Expected : Complex; + begin + Accuracy_Error_Reported := False; -- reset + for II in 1..Max_Samples loop + X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; + for J in 1..Max_Samples loop + Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; + + -- purify the arguments to minimize roundoff error. + -- We construct the values so that the products X*X, + -- Y*Y, and X*Y are all exact machine numbers. + -- See Cody page 7 and CELEFUNT code. + Z := X * Scale; + W := Z + X; + X := W - Z; + Z := Y * Scale; + W := Z + Y; + Y := W - Z; + -- G.1.2(21);6.0 - real part of result is non-negative + Expected := Compose_From_Cartesian( abs X,Y); + Z := X*X - Y*Y; + W := X*Y; + CX := Compose_From_Cartesian(Z,W+W); + + -- The arguments are now ready so on with the + -- identity computation. + Actual := Sqrt(CX); + + Check (Actual, Expected, + "Identity_1_Test " & Integer'Image (II) & + Integer'Image (J) & ": Sqrt((" & + Real'Image (CX.Re) & ", " & + Real'Image (CX.Im) & ")) ", + 8.5); -- 6.0 from sqrt, 2.5 from argument. + -- See Cody pg 7-8 for analysis of additional error amount. + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + return; + end if; + end loop; + end loop; + + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_Test" & + " for X=(" & Real'Image (X) & + ", " & Real'Image (X) & ")"); + when others => + Report.Failed ("exception in Identity_Test" & + " for X=(" & Real'Image (X) & + ", " & Real'Image (X) & ")"); + end Identity_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + -- ranges where the sign is the same and where it + -- differs. + Identity_Test ( 0.0, 10.0, 0.0, 10.0); + Identity_Test ( 0.0, 100.0, -100.0, 0.0); + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2020", + "Check the accuracy of the complex SQRT function"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2020; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2021.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,386 ---- + -- CXG2021.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that the complex SIN and COS functions return + -- a result that is within the error bound allowed. + -- + -- TEST DESCRIPTION: + -- This test consists of a generic package that is + -- instantiated to check complex numbers based upon + -- both Float and a long float type. + -- The test for each floating point type is divided into + -- several parts: + -- Special value checks where the result is a known constant. + -- Checks that use an identity for determining the result. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 27 Mar 96 SAIC Initial release for 2.1 + -- 22 Aug 96 SAIC No longer skips test for systems with + -- more than 20 digits of precision. + -- + --! + + -- + -- References: + -- + -- W. J. Cody + -- CELEFUNT: A Portable Test Package for Complex Elementary Functions + -- Algorithm 714, Collected Algorithms from ACM. + -- Published in Transactions On Mathematical Software, + -- Vol. 19, No. 1, March, 1993, pp. 1-21. + -- + -- CRC Standard Mathematical Tables + -- 23rd Edition + -- + + with System; + with Report; + with Ada.Numerics.Generic_Complex_Types; + with Ada.Numerics.Generic_Complex_Elementary_Functions; + procedure CXG2021 is + Verbose : constant Boolean := False; + -- Note that Max_Samples is the number of samples taken in + -- both the real and imaginary directions. Thus, for Max_Samples + -- of 100 the number of values checked is 10000. + Max_Samples : constant := 100; + + E : constant := Ada.Numerics.E; + Pi : constant := Ada.Numerics.Pi; + + generic + type Real is digits <>; + package Generic_Check is + procedure Do_Test; + end Generic_Check; + + package body Generic_Check is + package Complex_Type is new + Ada.Numerics.Generic_Complex_Types (Real); + use Complex_Type; + + package CEF is new + Ada.Numerics.Generic_Complex_Elementary_Functions (Complex_Type); + + function Sin (X : Complex) return Complex renames CEF.Sin; + function Cos (X : Complex) return Complex renames CEF.Cos; + + -- flag used to terminate some tests early + Accuracy_Error_Reported : Boolean := False; + + -- The following value is a lower bound on the accuracy + -- required. It is normally 0.0 so that the lower bound + -- is computed from Model_Epsilon. However, for tests + -- where the expected result is only known to a certain + -- amount of precision this bound takes on a non-zero + -- value to account for that level of precision. + Error_Low_Bound : Real := 0.0; + + -- the E_Factor is an additional amount added to the Expected + -- value prior to computing the maximum relative error. + -- This is needed because the error analysis (Cody pg 17-20) + -- requires this additional allowance. + procedure Check (Actual, Expected : Real; + Test_Name : String; + MRE : Real; + E_Factor : Real := 0.0) is + Max_Error : Real; + Rel_Error : Real; + Abs_Error : Real; + begin + -- In the case where the expected result is very small or 0 + -- we compute the maximum error as a multiple of Model_Epsilon instead + -- of Model_Epsilon and Expected. + Rel_Error := MRE * Real'Model_Epsilon * (abs Expected + E_Factor); + Abs_Error := MRE * Real'Model_Epsilon; + if Rel_Error > Abs_Error then + Max_Error := Rel_Error; + else + Max_Error := Abs_Error; + end if; + + -- take into account the low bound on the error + if Max_Error < Error_Low_Bound then + Max_Error := Error_Low_Bound; + end if; + + if abs (Actual - Expected) > Max_Error then + Accuracy_Error_Reported := True; + Report.Failed (Test_Name & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) & + " efactor:" & Real'Image (E_Factor) ); + elsif Verbose then + if Actual = Expected then + Report.Comment (Test_Name & " exact result"); + else + Report.Comment (Test_Name & " passed" & + " actual: " & Real'Image (Actual) & + " expected: " & Real'Image (Expected) & + " difference: " & Real'Image (Actual - Expected) & + " max err:" & Real'Image (Max_Error) & + " efactor:" & Real'Image (E_Factor) ); + end if; + end if; + end Check; + + + procedure Check (Actual, Expected : Complex; + Test_Name : String; + MRE : Real; + R_Factor, I_Factor : Real := 0.0) is + begin + Check (Actual.Re, Expected.Re, Test_Name & " real part", + MRE, R_Factor); + Check (Actual.Im, Expected.Im, Test_Name & " imaginary part", + MRE, I_Factor); + end Check; + + + procedure Special_Value_Test is + -- In the following tests the expected result is accurate + -- to the machine precision so the minimum guaranteed error + -- bound can be used if the argument is exact. + -- Since the argument involves Pi, we must allow for this + -- inexact argument. + Minimum_Error : constant := 11.0; + begin + Check (Sin (Pi/2.0 + 0.0*i), + 1.0 + 0.0*i, + "sin(pi/2+0i)", + Minimum_Error + 1.0); + Check (Cos (Pi/2.0 + 0.0*i), + 0.0 + 0.0*i, + "cos(pi/2+0i)", + Minimum_Error + 1.0); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in special value test"); + when others => + Report.Failed ("exception in special value test"); + end Special_Value_Test; + + + + procedure Exact_Result_Test is + No_Error : constant := 0.0; + begin + -- G.1.2(36);6.0 + Check (Sin(0.0 + 0.0*i), 0.0 + 0.0 * i, "sin(0+0i)", No_Error); + Check (Cos(0.0 + 0.0*i), 1.0 + 0.0 * i, "cos(0+0i)", No_Error); + exception + when Constraint_Error => + Report.Failed ("Constraint_Error raised in Exact_Result Test"); + when others => + Report.Failed ("exception in Exact_Result Test"); + end Exact_Result_Test; + + + procedure Identity_Test (RA, RB, IA, IB : Real) is + -- Tests an identity over a range of values specified + -- by the 4 parameters. RA and RB denote the range for the + -- real part while IA and IB denote the range for the + -- imaginary part. + -- + -- For this test we use the identity + -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W) + -- and + -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W) + -- + + X, Y : Real; + Z : Complex; + W : constant Complex := Compose_From_Cartesian(0.0625, 0.0625); + ZmW : Complex; -- Z - W + Sin_ZmW, + Cos_ZmW : Complex; + Actual1, Actual2 : Complex; + R_Factor : Real; -- additional real error factor + I_Factor : Real; -- additional imaginary error factor + Sin_W : constant Complex := (6.2581348413276935585E-2, + 6.2418588008436587236E-2); + -- numeric stability is enhanced by using Cos(W) - 1.0 instead of + -- Cos(W) in the computation. + Cos_W_m_1 : constant Complex := (-2.5431314180235545803E-6, + -3.9062493377261771826E-3); + + + begin + if Real'Digits > 20 then + -- constants used here accurate to 20 digits. Allow 1 + -- additional digit of error for computation. + Error_Low_Bound := 0.00000_00000_00000_0001; + Report.Comment ("accuracy checked to 19 digits"); + end if; + + Accuracy_Error_Reported := False; -- reset + for II in 0..Max_Samples loop + X := (RB - RA) * Real (II) / Real (Max_Samples) + RA; + for J in 0..Max_Samples loop + Y := (IB - IA) * Real (J) / Real (Max_Samples) + IA; + + Z := Compose_From_Cartesian(X,Y); + ZmW := Z - W; + Sin_ZmW := Sin (ZmW); + Cos_ZmW := Cos (ZmW); + + -- now for the first identity + -- Sin(Z) = Sin(Z-W) * Cos(W) + Cos(Z-W) * Sin(W) + -- = Sin(Z-W) * (1+(Cos(W)-1)) + Cos(Z-W) * Sin(W) + -- = Sin(Z-W) + Sin(Z-W)*(Cos(W)-1) + Cos(Z-W)*Sin(W) + + + Actual1 := Sin (Z); + Actual2 := Sin_ZmW + (Sin_ZmW * Cos_W_m_1 + Cos_ZmW * Sin_W); + + -- The computation of the additional error factors are taken + -- from Cody pages 17-20. + + R_Factor := abs (Re (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) + + abs (Im (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) + + abs (Re (Cos_ZmW) * Re (Sin_W)) + + abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); + + I_Factor := abs (Re (Sin_ZmW) * Im (1.0 - Cos_W_m_1)) + + abs (Im (Sin_ZmW) * Re (1.0 - Cos_W_m_1)) + + abs (Re (Cos_ZmW) * Im (Sin_W)) + + abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); + + Check (Actual1, Actual2, + "Identity_1_Test " & Integer'Image (II) & + Integer'Image (J) & ": Sin((" & + Real'Image (Z.Re) & ", " & + Real'Image (Z.Im) & ")) ", + 11.0, R_Factor, I_Factor); + + -- now for the second identity + -- Cos(Z) = Cos(Z-W) * Cos(W) - Sin(Z-W) * Sin(W) + -- = Cos(Z-W) * (1+(Cos(W)-1) - Sin(Z-W) * Sin(W) + Actual1 := Cos (Z); + Actual2 := Cos_ZmW + (Cos_ZmW * Cos_W_m_1 - Sin_ZmW * Sin_W); + + -- The computation of the additional error factors are taken + -- from Cody pages 17-20. + + R_Factor := abs (Re (Sin_ZmW) * Re (Sin_W)) + + abs (Im (Sin_ZmW) * Im (Sin_W)) + + abs (Re (Cos_ZmW) * Re (1.0 - Cos_W_m_1)) + + abs (Im (Cos_ZmW) * Im (1.0 - Cos_W_m_1)); + + I_Factor := abs (Re (Sin_ZmW) * Im (Sin_W)) + + abs (Im (Sin_ZmW) * Re (Sin_W)) + + abs (Re (Cos_ZmW) * Im (1.0 - Cos_W_m_1)) + + abs (Im (Cos_ZmW) * Re (1.0 - Cos_W_m_1)); + + Check (Actual1, Actual2, + "Identity_2_Test " & Integer'Image (II) & + Integer'Image (J) & ": Cos((" & + Real'Image (Z.Re) & ", " & + Real'Image (Z.Im) & ")) ", + 11.0, R_Factor, I_Factor); + + if Accuracy_Error_Reported then + -- only report the first error in this test in order to keep + -- lots of failures from producing a huge error log + Error_Low_Bound := 0.0; -- reset + return; + end if; + end loop; + end loop; + + Error_Low_Bound := 0.0; -- reset + exception + when Constraint_Error => + Report.Failed + ("Constraint_Error raised in Identity_Test" & + " for Z=(" & Real'Image (X) & + ", " & Real'Image (Y) & ")"); + when others => + Report.Failed ("exception in Identity_Test" & + " for Z=(" & Real'Image (X) & + ", " & Real'Image (Y) & ")"); + end Identity_Test; + + + procedure Do_Test is + begin + Special_Value_Test; + Exact_Result_Test; + -- test regions where sin and cos have the same sign and + -- about the same magnitude. This will minimize subtraction + -- errors in the identities. + -- See Cody page 17. + Identity_Test (0.0625, 10.0, 0.0625, 10.0); + Identity_Test ( 16.0, 17.0, 16.0, 17.0); + end Do_Test; + end Generic_Check; + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + package Float_Check is new Generic_Check (Float); + + -- check the floating point type with the most digits + type A_Long_Float is digits System.Max_Digits; + package A_Long_Float_Check is new Generic_Check (A_Long_Float); + + ----------------------------------------------------------------------- + ----------------------------------------------------------------------- + + + begin + Report.Test ("CXG2021", + "Check the accuracy of the complex SIN and COS functions"); + + if Verbose then + Report.Comment ("checking Standard.Float"); + end if; + + Float_Check.Do_Test; + + if Verbose then + Report.Comment ("checking a digits" & + Integer'Image (System.Max_Digits) & + " floating point type"); + end if; + + A_Long_Float_Check.Do_Test; + + + Report.Result; + end CXG2021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2022.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,309 ---- + -- CXG2022.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that multiplication and division of binary fixed point + -- numbers with compatible 'small values produce exact results. + -- + -- TEST DESCRIPTION: + -- Signed, unsigned, and a mixture of signed and unsigned + -- binary fixed point values are multiplied and divided. + -- The result is checked against the expected "perfect result set" + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- + -- + -- CHANGE HISTORY: + -- 1 Apr 96 SAIC Initial release for 2.1 + -- 29 Jan 1998 EDS Repaired fixed point errors ("**" and + -- assumptions about 'Small) + --! + + with System; + with Report; + procedure CXG2022 is + Verbose : constant Boolean := False; + + procedure Check_Signed is + type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) .. + 2.0 ** (System.Max_Mantissa) - 1.0; + type Halves is delta 0.5 range -2.0 ** (System.Max_Mantissa-2) .. + 2.0 ** (System.Max_Mantissa-2) - 1.0; + P1, P2, P3, P4 : Pairs; + H1, H2, H3, H4 : Halves; + + procedure Dont_Opt is + -- keep optimizer from knowing the constant value of expressions + begin + if Report.Ident_Bool (False) then + P1 := 2.0; P2 := 4.0; P3 := 6.0; + H1 := -2.0; H2 := 9.0; H3 := 3.0; + end if; + end Dont_Opt; + + begin + H1 := -0.5; + H2 := Halves'First; + H3 := 1.0; + P1 := 12.0; + P2 := Pairs'First; + P3 := Pairs'Last; + Dont_Opt; + + P4 := Pairs (P1 * H1); -- 12.0 * -0.5 + if P4 /= -6.0 then + Report.Failed ("12.0 * -0.5 = " & Pairs'Image (P4)); + end if; + + H4 := Halves (P1 / H1); -- 12.0 / -0.5 + if H4 /= -24.0 then + Report.Failed ("12.0 / -0.5 = " & Halves'Image (H4)); + end if; + + P4 := P3 * H3; -- Pairs'Last * 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P3 / H3; -- Pairs'Last / 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P2 * 0.25; -- Pairs'First * 0.25 + if P4 /= Pairs (-2.0 ** (System.Max_Mantissa - 2)) then + Report.Failed ("Pairs'First * 0.25 = " & Pairs'Image (P4)); + end if; + + P4 := 100.5 / H1; -- 100.5 / -0.5 + if P4 = -201.0 then + null; -- Perfect result + elsif Pairs'Small = 2.0 and ( P4 = -200.0 or P4 = -202.0 ) then + null; -- Allowed variation + else + Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & + " and 100.5/-0.5 = " & Pairs'Image (P4) ); + end if; + + H4 := H1 * H2; -- -0.5 * Halves'First + if H4 /= Halves (2.0 ** (System.Max_Mantissa-3)) then + Report.Failed ("-0.5 * Halves'First =" & Halves'Image (H4) & + " instead of " & + Halves'Image( Halves(2.0 ** (System.Max_Mantissa-3)))); + end if; + + exception + when others => + Report.Failed ("unexpected exception in Check_Signed"); + end Check_Signed; + + + + procedure Check_Unsigned is + type Pairs is delta 2.0 range 0.0 .. 2.0 ** (System.Max_Mantissa+1) - 1.0; + type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0; + P1, P2, P3, P4 : Pairs; + H1, H2, H3, H4 : Halves; + + procedure Dont_Opt is + -- keep optimizer from knowing the constant value of expressions + begin + if Report.Ident_Bool (False) then + P1 := 2.0; P2 := 4.0; P3 := 6.0; + H1 := 2.0; H2 := 9.0; H3 := 3.0; + end if; + end Dont_Opt; + + begin + H1 := 10.5; + H2 := Halves(2.0 ** (System.Max_Mantissa - 6)); + H3 := 1.0; + P1 := 12.0; + P2 := Pairs'Last / 2; + P3 := Pairs'Last; + Dont_Opt; + + P4 := Pairs (P1 * H1); -- 12.0 * 10.5 + if P4 /= 126.0 then + Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4)); + end if; + + H4 := Halves (P1 / H1); -- 12.0 / 10.5 + if H4 /= 1.0 and H4 /= 1.5 then + Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4)); + end if; + + P4 := P3 * H3; -- Pairs'Last * 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P3 / H3; -- Pairs'Last / 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P1 * 0.25; -- 12.0 * 0.25 + if P4 /= 2.0 and P4 /= 4.0 then + Report.Failed ("12.0 * 0.25 = " & Pairs'Image (P4)); + end if; + + P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571... + if P4 /= 8.0 and P4 /= 10.0 then + Report.Failed ("100.5/10.5 = " & Pairs'Image (P4)); + end if; + + H4 := H2 * 2; -- 2**(max_mantissa-6) * 2 + if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then + Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) & + " instead of " & + Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5)))); + end if; + + exception + when others => + Report.Failed ("unexpected exception in Check_Unsigned"); + end Check_Unsigned; + + + + procedure Check_Mixed is + type Pairs is delta 2.0 range -2.0 ** (System.Max_Mantissa) .. + 2.0 ** (System.Max_Mantissa) - 1.0; + type Halves is delta 0.5 range 0.0 .. 2.0 ** (System.Max_Mantissa-1) - 1.0; + P1, P2, P3, P4 : Pairs; + H1, H2, H3, H4 : Halves; + + procedure Dont_Opt is + -- keep optimizer from knowing the constant value of expressions + begin + if Report.Ident_Bool (False) then + P1 := 2.0; P2 := 4.0; P3 := 6.0; + H1 := 2.0; H2 := 9.0; H3 := 3.0; + end if; + end Dont_Opt; + + begin + H1 := 10.5; + H2 := Halves(2.0 ** (System.Max_Mantissa - 6)); + H3 := 1.0; + P1 := 12.0; + P2 := -4.0; + P3 := Pairs'Last; + Dont_Opt; + + P4 := Pairs (P1 * H1); -- 12.0 * 10.5 + if P4 /= 126.0 then + Report.Failed ("12.0 * 10.5 = " & Pairs'Image (P4)); + end if; + + H4 := Halves (P1 / H1); -- 12.0 / 10.5 + if H4 /= 1.0 and H4 /= 1.5 then + Report.Failed ("12.0 / 10.5 = " & Halves'Image (H4)); + end if; + + P4 := P3 * H3; -- Pairs'Last * 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last * 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P3 / H3; -- Pairs'Last / 1.0 + if P4 /= Pairs'Last then + Report.Failed ("Pairs'Last / 1.0 = " & Pairs'Image (P4)); + end if; + + P4 := P1 * 0.25; -- 12.0 * 0.25 + if P4 = 3.0 then + null; -- Perfect result + elsif Pairs'Small = 2.0 and then ( P4 = 2.0 or P4 = 4.0 ) then + null; -- Allowed deviation + else + Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & + "and 12.0 * 0.25 = " & Pairs'Image (P4) ); + end if; + + P4 := 100.5 / H1; -- 100.5 / 10.5 = 9.571... + if P4 = 9.0 then + null; -- Perfect result + elsif Pairs'Small = 2.0 and then ( P4 = 8.0 or P4 = 10.0 ) then + null; -- Allowed values + else + Report.Failed ("Pairs'Small =" & Pairs'Image (Pairs'Small) & + "and 100.5/10.5 = " & Pairs'Image (P4) ); + end if; + + H4 := H2 * 2; -- 2**(max_mantissa-6) * 2 + if H4 /= Halves(2.0 ** (System.Max_Mantissa-5)) then + Report.Failed ("2**(System.Max_Mantissa-6) * 2=" & Halves'Image (H4) & + " instead of " & + Halves'Image( Halves(2.0 ** (System.Max_Mantissa-5)))); + end if; + + P4 := Pairs(P1 * 6) / P2; -- 12 * 6 / -4 + if (P4 /= -18.0) then + Report.Failed ("12*6/-4 = " & Pairs'Image(P4)); + end if; + + P4 := Halves(P1 * 6.0) / P2; -- 12 * 6 / -4 + if (P4 /= -18.0) then + Report.Failed ("Halves(12*6)/-4 = " & Pairs'Image(P4)); + end if; + + exception + when others => + Report.Failed ("unexpected exception in Check_Mixed"); + end Check_Mixed; + + + begin -- main + Report.Test ("CXG2022", + "Check the accuracy of multiplication and division" & + " of binary fixed point numbers"); + if Verbose then + Report.Comment ("starting signed test"); + end if; + Check_Signed; + + if Verbose then + Report.Comment ("starting unsigned test"); + end if; + Check_Unsigned; + + if Verbose then + Report.Comment ("starting mixed sign test"); + end if; + Check_Mixed; + + Report.Result; + end CXG2022; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2023.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,351 ---- + -- CXG2023.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that multiplication and division of decimal fixed point + -- numbers produce exact results. + -- + -- TEST DESCRIPTION: + -- Check that multiplication and division of decimal fixed point + -- numbers produce exact results. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- This test applies only to implementations supporting + -- decimal fixed point types of at least 9 digits. + -- + -- + -- CHANGE HISTORY: + -- 3 Apr 96 SAIC Initial release for 2.1 + -- + --! + + with System; + with Report; + procedure CXG2023 is + Verbose : constant Boolean := False; + + procedure Check_1 is + Num_Digits : constant := 6; + type Pennies is delta 0.01 digits Num_Digits; + type Franklins is delta 100.0 digits Num_Digits; + type Dollars is delta 1.0 digits Num_Digits; + + P1 : Pennies; + F1 : Franklins; + D1 : Dollars; + + -- optimization thwarting functions + + function P (X : Pennies) return Pennies is + begin + if Report.Ident_Bool (True) then + return X; + else + return 3.21; -- never executed + end if; + end P; + + + function F (X : Franklins) return Franklins is + begin + if Report.Ident_Bool (True) then + return X; + else + return 32100.0; -- never executed + end if; + end F; + + + function D (X : Dollars) return Dollars is + begin + if Report.Ident_Bool (True) then + return X; + else + return 321.0; -- never executed + end if; + end D; + + + begin + -- multiplication where one operand is universal real + + P1 := P(0.05) * 200.0; + if P1 /= 10.00 then + Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(0.05) * 100.0; + if D1 /= 5.00 then + Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(0.05) * 50_000.0; + if F1 /= 2500.00 then + Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1)); + end if; + + -- multiplication where both operands are decimal fixed + + P1 := P(0.05) * D(-200.0); + if P1 /= -10.00 then + Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(0.05) * P(-100.0); + if D1 /= -5.00 then + Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(-0.05) * F(50_000.0); + if F1 /= -2500.00 then + Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1)); + end if; + + -- division where one operand is universal real + + P1 := P(0.05) / 0.001; + if P1 /= 50.00 then + Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1)); + end if; + + D1 := D(1000.0) / 3.0; + if D1 /= 333.00 then + Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(1234.56) / 0.0001; + if F1 /= 12345600.00 then + Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1)); + end if; + + + -- division where both operands are decimal fixed + + P1 := P(0.05) / D(1.0); + if P1 /= 0.05 then + Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1)); + end if; + + -- check for truncation toward 0 + D1 := P(-101.00) / P(2.0); + if D1 /= -50.00 then + Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1)); + end if; + + P1 := P(-102.03) / P(-0.5); + if P1 /= 204.06 then + Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1)); + end if; + + F1 := P(876.54) / P(0.03); + if F1 /= 29200.00 then + Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1)); + end if; + + exception + when others => + Report.Failed ("unexpected exception in Check_1"); + end Check_1; + + generic + type Pennies is delta<> digits<>; + type Dollars is delta<> digits<>; + type Franklins is delta<> digits<>; + procedure Generic_Check; + procedure Generic_Check is + + -- the following code is copied directly from the + -- above procedure Check_1 + + P1 : Pennies; + F1 : Franklins; + D1 : Dollars; + + -- optimization thwarting functions + + function P (X : Pennies) return Pennies is + begin + if Report.Ident_Bool (True) then + return X; + else + return 3.21; -- never executed + end if; + end P; + + + function F (X : Franklins) return Franklins is + begin + if Report.Ident_Bool (True) then + return X; + else + return 32100.0; -- never executed + end if; + end F; + + + function D (X : Dollars) return Dollars is + begin + if Report.Ident_Bool (True) then + return X; + else + return 321.0; -- never executed + end if; + end D; + + + begin + -- multiplication where one operand is universal real + + P1 := P(0.05) * 200.0; + if P1 /= 10.00 then + Report.Failed ("1 - expected 10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(0.05) * 100.0; + if D1 /= 5.00 then + Report.Failed ("2 - expected 5.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(0.05) * 50_000.0; + if F1 /= 2500.00 then + Report.Failed ("3 - expected 2500.0 got " & Franklins'Image (F1)); + end if; + + -- multiplication where both operands are decimal fixed + + P1 := P(0.05) * D(-200.0); + if P1 /= -10.00 then + Report.Failed ("4 - expected -10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(0.05) * P(-100.0); + if D1 /= -5.00 then + Report.Failed ("5 - expected -5.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(-0.05) * F(50_000.0); + if F1 /= -2500.00 then + Report.Failed ("6 - expected -2500.0 got " & Franklins'Image (F1)); + end if; + + -- division where one operand is universal real + + P1 := P(0.05) / 0.001; + if P1 /= 50.00 then + Report.Failed ("7 - expected 50.00 got " & Pennies'Image (P1)); + end if; + + D1 := D(1000.0) / 3.0; + if D1 /= 333.00 then + Report.Failed ("8 - expected 333.00 got " & Dollars'Image (D1)); + end if; + + F1 := P(1234.56) / 0.0001; + if F1 /= 12345600.00 then + Report.Failed ("9 - expected 12345600.0 got " & Franklins'Image (F1)); + end if; + + + -- division where both operands are decimal fixed + + P1 := P(0.05) / D(1.0); + if P1 /= 0.05 then + Report.Failed ("10 - expected 0.05 got " & Pennies'Image (P1)); + end if; + + -- check for truncation toward 0 + D1 := P(-101.00) / P(2.0); + if D1 /= -50.00 then + Report.Failed ("11 - expected -50.00 got " & Dollars'Image (D1)); + end if; + + P1 := P(-102.03) / P(-0.5); + if P1 /= 204.06 then + Report.Failed ("12 - expected 204.06 got " & Pennies'Image (P1)); + end if; + + F1 := P(876.54) / P(0.03); + if F1 /= 29200.00 then + Report.Failed ("13 - expected 29200.0 got " & Franklins'Image (F1)); + end if; + + end Generic_Check; + + + procedure Check_G6 is + Num_Digits : constant := 6; + type Pennies is delta 0.01 digits Num_Digits; + type Franklins is delta 100.0 digits Num_Digits; + type Dollars is delta 1.0 digits Num_Digits; + + procedure G is new Generic_Check (Pennies, Dollars, Franklins); + begin + G; + end Check_G6; + + + procedure Check_G9 is + Num_Digits : constant := 9; + type Pennies is delta 0.01 digits Num_Digits; + type Franklins is delta 100.0 digits Num_Digits; + type Dollars is delta 1.0 digits Num_Digits; + + procedure G is new Generic_Check (Pennies, Dollars, Franklins); + begin + G; + end Check_G9; + + + begin -- main + Report.Test ("CXG2023", + "Check the accuracy of multiplication and division" & + " of decimal fixed point numbers"); + + if Verbose then + Report.Comment ("starting Check_1"); + end if; + Check_1; + + if Verbose then + Report.Comment ("starting Check_G6"); + end if; + Check_G6; + + if Verbose then + Report.Comment ("starting Check_G9"); + end if; + Check_G9; + + Report.Result; + end CXG2023; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxg/cxg2024.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,191 ---- + -- CXG2024.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that multiplication and division of decimal + -- and binary fixed point numbers that result in a + -- decimal fixed point type produce acceptable results. + -- + -- TEST DESCRIPTION: + -- Multiplication and division of mixed binary and decimal + -- values are performed. Identity functions are used so + -- that the operands of the expressions will not be seen + -- as static by the compiler. + -- + -- SPECIAL REQUIREMENTS + -- The Strict Mode for the numerical accuracy must be + -- selected. The method by which this mode is selected + -- is implementation dependent. + -- + -- APPLICABILITY CRITERIA: + -- This test applies only to implementations supporting the + -- Numerics Annex. + -- This test only applies to the Strict Mode for numerical + -- accuracy. + -- This test applies only to implementations supporting + -- decimal fixed point types of at least 9 digits. + -- + -- + -- CHANGE HISTORY: + -- 4 Apr 96 SAIC Initial release for 2.1 + -- 17 Aug 96 SAIC Removed checks for close results + -- + --! + + with System; + with Report; + procedure CXG2024 is + + procedure Do_Check is + Num_Digits : constant := 9; + type Pennies is delta 0.01 digits Num_Digits; + type Dollars is delta 1.0 digits Num_Digits; + + type Signed_Sixteenths is delta 0.0625 + range -2.0 ** (System.Max_Mantissa-5) .. + 2.0 ** (System.Max_Mantissa-5) - 1.0; + type Unsigned_Sixteenths is delta 0.0625 + range 0.0 .. 2.0 ** (System.Max_Mantissa-4) - 1.0; + + P1 : Pennies; + D1 : Dollars; + + -- optimization thwarting functions + + function P (X : Pennies) return Pennies is + begin + if Report.Ident_Bool (True) then + return X; + else + return 3.21; -- never executed + end if; + end P; + + + function D (X : Dollars) return Dollars is + begin + if Report.Ident_Bool (True) then + return X; + else + return 321.0; -- never executed + end if; + end D; + + + function US (X : Unsigned_Sixteenths) return Unsigned_Sixteenths is + begin + if Report.Ident_Bool (True) then + return X; + else + return 321.0; -- never executed + end if; + end US; + + + function SS (X : Signed_Sixteenths) return Signed_Sixteenths is + begin + if Report.Ident_Bool (True) then + return X; + else + return 321.0; -- never executed + end if; + end SS; + + + begin + + P1 := P(0.05) * SS(-200.0); + if P1 /= -10.00 then + Report.Failed ("1 - expected -10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(0.05) * SS(-100.0); + if D1 /= -5.00 then + Report.Failed ("2 - expected -5.00 got " & Dollars'Image (D1)); + end if; + + P1 := P(0.05) * US(200.0); + if P1 /= 10.00 then + Report.Failed ("3 - expected 10.00 got " & Pennies'Image (P1)); + end if; + + D1 := P(-0.05) * US(100.0); + if D1 /= -5.00 then + Report.Failed ("4 - expected -5.00 got " & Dollars'Image (D1)); + end if; + + + + P1 := P(0.05) / US(1.0); + if P1 /= 0.05 then + Report.Failed ("6 - expected 0.05 got " & Pennies'Image (P1)); + end if; + + + -- check rounding + + D1 := Dollars'Round (Pennies (P(-101.00) / US(2.0))); + if D1 /= -51.00 then + Report.Failed ("11 - expected -51.00 got " & Dollars'Image (D1)); + end if; + + D1 := Dollars'Round (Pennies (P(101.00) / US(2.0))); + if D1 /= 51.00 then + Report.Failed ("12 - expected 51.00 got " & Dollars'Image (D1)); + end if; + + D1 := Dollars'Round (Pennies (SS(-101.00) / P(2.0))); + if D1 /= -51.00 then + Report.Failed ("13 - expected -51.00 got " & Dollars'Image (D1)); + end if; + + D1 := Dollars'Round (Pennies (US(101.00) / P(2.0))); + if D1 /= 51.00 then + Report.Failed ("14 - expected 51.00 got " & Dollars'Image (D1)); + end if; + + + + P1 := P(-102.03) / SS(-0.5); + if P1 /= 204.06 then + Report.Failed ("15 - expected 204.06 got " & Pennies'Image (P1)); + end if; + + + exception + when others => + Report.Failed ("unexpected exception in Do_Check"); + end Do_Check; + + + begin -- main + Report.Test ("CXG2024", + "Check the accuracy of multiplication and division" & + " of mixed decimal and binary fixed point numbers"); + + Do_Check; + + Report.Result; + end CXG2024; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh1001.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,349 ---- + -- CXH1001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check pragma Normalize_Scalars. + -- Check that this configuration pragma causes uninitialized scalar + -- objects to be set to a predictable value. Check that multiple + -- compilation units are affected. Check for uninitialized scalar + -- objects that are subcomponents of composite objects, unassigned + -- out parameters, objects that have been allocated without an initial + -- value, and objects that are stand alone. + -- + -- TEST DESCRIPTION + -- The test requires that the configuration pragma Normalize_Scalars + -- be processed. It then defines a few scalar types (some enumeration, + -- some integer) in a few packages. The scalar types are designed such + -- that the representation will easily allow for an out of range value. + -- Unchecked_Conversion and the 'Valid attribute are both used to verify + -- that the default values of the various kinds of objects are indeed + -- invalid for the type. + -- + -- Note that this test relies on having uninitialized objects, compilers + -- may generate several warnings to this effect. + -- + -- SPECIAL REQUIREMENTS + -- The implementation must process configuration pragmas which + -- are not part of any Compilation Unit; the method employed + -- is implementation defined. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Safety and Security Annex. + -- + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial version + -- 04 NOV 96 SAIC Added cases, upgraded commentary + -- + --! + + ---------------------------- CONFIGURATION PRAGMAS ----------------------- + + pragma Normalize_Scalars; -- OK + -- configuration pragma + + ------------------------ END OF CONFIGURATION PRAGMAS -------------------- + + + ----------------------------------------------------------------- CXH1001_0 + + with Impdef.Annex_H; + with Unchecked_Conversion; + package CXH1001_0 is + + package Imp_H renames Impdef.Annex_H; + use type Imp_H.Small_Number; + use type Imp_H.Scalar_To_Normalize; + + Global_Object : Imp_H.Scalar_To_Normalize; + -- if the pragma is in effect, this should come up with the predictable + -- value + + Global_Number : Imp_H.Small_Number; + -- if the pragma is in effect, this should come up with the predictable + -- value + + procedure Package_Check; + + type Num is range 0..2**Imp_H.Scalar_To_Normalize'Size-1; + for Num'Size use Imp_H.Scalar_To_Normalize'Size; + + function STN_2_Num is + new Unchecked_Conversion( Imp_H.Scalar_To_Normalize, Num ); + + Small_Last : constant Integer := Integer(Imp_H.Small_Number'Last); + + end CXH1001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CXH1001_0 is + + procedure Heap_Check( A_Value : access Imp_H.Scalar_To_Normalize; + A_Number : access Imp_H.Small_Number ) is + Value : Num; + Number : Integer; + begin + + if A_Value.all'Valid then + Value := STN_2_Num ( A_Value.all ); + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Imp_H.Scalar_To_Normalize'Val(Value) + /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for local variable is not " + & "the predicted value"); + end if; + else + if Value in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for local variable is a " + & "value of the type"); + end if; + end if; + end if; + + if A_Number.all'Valid then + Number := Integer( A_Number.all ); + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Global_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for number is not " + & "the predicted value"); + end if; + else + if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then + Report.Failed("Implicit initial value for number is a " + & "value of the type"); + end if; + end if; + end if; + + end Heap_Check; + + procedure Package_Check is + Value : Num; + Number : Integer; + begin + + if Global_Object'Valid then + Value := STN_2_Num ( Global_Object ); + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Imp_H.Scalar_To_Normalize'Val(Value) + /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for local variable is not " + & "the predicted value"); + end if; + else + if Value in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for local variable is a " + & "value of the type"); + end if; + end if; + end if; + + if Global_Number'Valid then + Number := Integer( Global_Number ); + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Global_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for number is not " + & "the predicted value"); + end if; + else + if Integer( Global_Number ) in 0 .. Report.Ident_Int(Small_Last) then + Report.Failed("Implicit initial value for number is a " + & "value of the type"); + end if; + end if; + end if; + + Heap_Check( new Imp_H.Scalar_To_Normalize, new Imp_H.Small_Number ); + + end Package_Check; + + end CXH1001_0; + + ----------------------------------------------------------------- CXH1001_1 + + with Unchecked_Conversion; + package CXH1001_0.CXH1001_1 is + + -- kill as many birds as possible with a single stone: + -- embed a protected object in the body of a child package, + -- checks the multiple compilation unit case, + -- and part of the subcomponent case. + + protected Thingy is + procedure Check_Embedded_Values; + private + Hidden_Object : Imp_H.Scalar_To_Normalize; -- not initialized + Hidden_Number : Imp_H.Small_Number; -- not initialized + end Thingy; + + end CXH1001_0.CXH1001_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CXH1001_0.CXH1001_1 is + + Childs_Object : Imp_H.Scalar_To_Normalize; -- not initialized + + protected body Thingy is + + procedure Check_Embedded_Values is + begin + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Childs_Object /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for child object is not " + & "the predicted value"); + end if; + elsif Childs_Object'Valid and then STN_2_Num( Childs_Object ) in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for child object is a " + & "value of the type"); + end if; + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if Hidden_Object /= Imp_H.Default_For_Scalar_To_Normalize then + Report.Failed("Implicit initial value for protected package object " + & "is not the predicted value"); + end if; + elsif Hidden_Object'Valid and then STN_2_Num( Hidden_Object ) in 0 .. + Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed("Implicit initial value for protected component " + & "is a value of the type"); + end if; + + if Imp_H.Default_For_Small_Number_Is_In_Range then + if Hidden_Number /= Imp_H.Default_For_Small_Number then + Report.Failed("Implicit initial value for protected number " + & "is not the predicted value"); + end if; + elsif Hidden_Number'Valid and then Hidden_Number in + 0 .. Imp_H.Small_Number(Report.Ident_Int(Small_Last)) then + Report.Failed("Implicit initial value for protected number " + & "is a value of the type"); + end if; + + end Check_Embedded_Values; + + end Thingy; + + end CXH1001_0.CXH1001_1; + + ------------------------------------------------------------------- CXH1001 + + with Impdef.Annex_H; + with Report; + with CXH1001_0.CXH1001_1; + procedure CXH1001 is + + package Imp_H renames Impdef.Annex_H; + use type CXH1001_0.Num; + + My_Object : Imp_H.Scalar_To_Normalize; -- not initialized + + Value : CXH1001_0.Num := CXH1001_0.STN_2_Num ( My_Object ); + -- My_Object is not initialized + + Parameter_Value : Imp_H.Scalar_To_Normalize + := Imp_H.Scalar_To_Normalize'Last; + + type Structure is record -- not initialized + Std_Int : Integer; + Scalar : Imp_H.Scalar_To_Normalize; + Num : CXH1001_0.Num; + end record; + + S : Structure; -- not initialized + + procedure Bad_Code( Unassigned : out Imp_H.Scalar_To_Normalize ) is + -- returns uninitialized OUT parameter + begin + + if Report.Ident_Int( 0 ) = 1 then + Report.Failed( "Nothing is something" ); + Unassigned := Imp_H.Scalar_To_Normalize'First; + end if; + + end Bad_Code; + + procedure Check( V : CXH1001_0.Num; Message : String ) is + begin + + + if Imp_H.Default_For_Scalar_To_Normalize_Is_In_Range then + if V /= Imp_H.Scalar_To_Normalize'Pos( + Imp_H.Default_For_Scalar_To_Normalize) then + Report.Failed(Message & ": Implicit initial value for object " + & "is not the predicted value"); + end if; + elsif V'Valid and then V in + 0 .. Imp_H.Scalar_To_Normalize'Pos(Imp_H.Scalar_To_Normalize'Last) then + Report.Failed(Message & ": Implicit initial value for object " + & "is a value of the type"); + end if; + + end Check; + + begin -- Main test procedure. + + Report.Test ("CXH1001", "Check that the configuration pragma " & + "Normalize_Scalars causes uninitialized scalar " & + "objects to be set to a predictable value. " & + "Check that multiple compilation units are " & + "affected. Check for uninitialized scalar " & + "objects that are subcomponents of composite " & + "objects, unassigned out parameters, have been " & + "allocated without an initial value, and are " & + "stand alone." ); + + CXH1001_0.Package_Check; + + if My_Object'Valid then + Value := CXH1001_0.STN_2_Num ( My_Object ); -- My_Object not initialized + end if; + -- otherwise, we just leave Value uninitialized + + Check( Value, "main procedure variable" ); + + Bad_Code( Parameter_Value ); + + if Parameter_Value'Valid then + Check( CXH1001_0.STN_2_Num ( Parameter_Value ), "Out parameter return" ); + end if; + + if S.Scalar'Valid then + Check( CXH1001_0.STN_2_Num ( S.Scalar ), "Record component" ); + end if; + + CXH1001_0.CXH1001_1.Thingy.Check_Embedded_Values; + + Report.Result; + + end CXH1001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh3001.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,243 ---- + -- CXH3001.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check pragma Reviewable. + -- Check that pragma Reviewable is accepted as a configuration pragma. + -- + -- TEST DESCRIPTION + -- The test requires that the configuration pragma Reviewable + -- be processed. The following package contains a simple "one of each + -- construct in the language" to check that the configuration pragma has + -- not disallowed some feature of the language. This test should generate + -- no errors. + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Safety and Security Annex. + -- + -- PASS/FAIL CRITERIA: + -- This test passes if it correctly compiles, executes, and reports PASS. + -- It fails if the pragma is rejected. The effect of the pragma should + -- be to produce a listing with information, including warnings, as + -- required in H.3.1. Specific form and contents of this listing are not + -- required by this test and are not part of the PASS/FAIL criteria. + -- + -- SPECIAL REQUIREMENTS + -- The implementation must process a configuration pragma which is not + -- part of any Compilation Unit; the method employed is implementation + -- defined. + -- + -- Pragma Reviewable requires that the implementation provide the + -- following information for the compilation units in this test: + -- + -- o Where compiler-generated run-time checks remain (6) + -- + -- o Identification of any construct with a language-defined check + -- that is recognized prior to runtime as certain to fail if + -- executed (7) + -- + -- o For each reference to a scalar object, an identification of + -- the reference as either "known to be initialized," + -- or "possibly uninitialized" (8) + -- + -- o Where run-time support routines are implicitly invoked (9) + -- + -- o An object code listing including: (10) + -- + -- o Machine instructions with relative offsets (11) + -- + -- o Where each data object is stored during its lifetime (12) + -- + -- o Correspondence with the source program (13) + -- + -- o Identification of each construct for which the implementation + -- detects the possibility of erroneous execution (14) + -- + -- o For each subprogram, block, task or other construct implemented by + -- reserving and subsequently freezing an area of the run-time stack, + -- an identification of the length of the fixed-size portion of + -- the area and an indication of whether the non-fixed size portion + -- is reserved on the stack or in a dynamically managed storage + -- region (15) + -- + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial version + -- 12 NOV 96 SAIC Revised for 2.1 + -- 27 AUG 99 RLB Removed result dependence on uninitialized object. + -- 30 AUG 99 RLB Repaired the above. + -- + --! + + ---------------------------- CONFIGURATION PRAGMAS ----------------------- + + pragma Reviewable; -- OK + -- configuration pragma + + ------------------------ END OF CONFIGURATION PRAGMAS -------------------- + + + ----------------------------------------------------------------- CXH3001_0 + + package CXH3001_0 is + + type Enum is (Item,Stuff,Things); + + type Int is range 0..256; + + type Unt is mod 256; + + type Flt is digits 5; + + type Fix is delta 0.5 range -1.0..1.0; + + type Root(Disc: Enum) is tagged record + I: Int; U:Unt; + end record; + + type List is array(Unt) of Root(Stuff); + + type A_List is access List; + type A_Proc is access procedure(R:Root); + + procedure P(R:Root); + + function F return A_Proc; + + protected PT is + entry Set(Switch: Boolean); + function Enquire return Boolean; + private + Toggle : Boolean; + end PT; + + task TT is + entry Release; + end TT; + + Global_Variable : Boolean := False; + + end CXH3001_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + with Report; + package body CXH3001_0 is + + procedure P(R:Root) is + Warnable : Positive := 0; -- (7) -- OPTIONAL WARNING + -- this would raise Constraint_Error if P were ever called, however + -- this test never calls P. + begin + case R.Disc is + when Item => Report.Comment("Got Item"); + when Stuff => Report.Comment("Got Stuff"); + when Things => Report.Comment("Got Things"); + end case; + if Report.Ident_Int( Warnable ) = 0 then + Global_Variable := not Global_Variable; -- (8) known to be initialized + end if; + end P; + + function F return A_Proc is + begin + return P'Access; + end F; + + protected body PT is + + entry Set(Switch: Boolean) when True is + begin + Toggle := Switch; + end Set; + + function Enquire return Boolean is + begin + return Toggle; + end Enquire; + + end PT; + + task body TT is + begin + loop + accept Release; + exit when Global_Variable; + end loop; + end TT; + + -- (9) TT activation + end CXH3001_0; + + ------------------------------------------------------------------- CXH3001 + + with Report; + with CXH3001_0; + procedure CXH3001 is + begin + Report.Test("CXH3001", "Check pragma Reviewable as a configuration pragma"); + + Block: declare + A_Truth : Boolean; + Message : String := Report.Ident_Str( "Bad value encountered" ); + begin + begin + A_Truth := Report.Ident_Bool( True ) or A_Truth; -- (8) not initialized + if not A_Truth then + Report.Comment ("True or Uninit = False"); + A_Truth := Report.Ident_Bool (True); + else + A_Truth := Report.Ident_Bool (True); + -- We do this separately on each branch in order to insure that a + -- clever optimizer can find out little about this value. Ident_Bool + -- is supposed to be opaque to any optimizer. + end if; + exception + when Constraint_Error | Program_Error => + -- Possible results of accessing an uninitialized object. + A_Truth := Report.Ident_Bool (True); + end; + + CXH3001_0.PT.Set( A_Truth ); + + CXH3001_0.Global_Variable := A_Truth; + + CXH3001_0.TT.Release; -- (9) rendezvous with TT + + while CXH3001_0.TT'Callable loop + delay 1.0; -- wait for TT to become non-callable + end loop; + + if not CXH3001_0.PT.Enquire + or not CXH3001_0.Global_Variable + or CXH3001_0.TT'Callable then + Report.Failed(Message); + end if; + + end Block; + + Report.Result; + end CXH3001; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh3002.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,343 ---- + -- CXH3002.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check that pragma Inspection_Point is allowed whereever a declarative + -- item or statement is allowed. Check that pragma Inspection_Point may + -- have zero or more arguments. Check that the execution of pragma + -- Inspection_Point has no effect. + -- + -- TEST DESCRIPTION + -- Check pragma Inspection_Point applied to: + -- A no objects, + -- B one object, + -- C multiple objects. + -- Check pragma Inspection_Point applied to: + -- D Enumeration type objects, + -- E Integer type objects (signed and unsigned), + -- F access type objects, + -- G Floating Point type objects, + -- H Fixed point type objects, + -- I array type objects, + -- J record type objects, + -- K tagged type objects, + -- L protected type objects, + -- M controlled type objects, + -- N task type objects. + -- Check pragma Inspection_Point applied in: + -- O declarations (package, procedure) + -- P statements (incl package elaboration) + -- Q subprogram (procedure, function, finalization) + -- R package + -- S specification + -- T body (PO entry, task body, loop body, accept body, select body) + -- U task + -- V protected object + -- + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Safety and Security Annex. + -- + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial version + -- 12 NOV 96 SAIC Revised for 2.1 + -- + --! + + ----------------------------------------------------------------- CXH3002_0 + + package CXH3002_0 is + + type Enum is (Item,Stuff,Things); + + type Int is range 0..256; + + type Unt is mod 256; + + type Flt is digits 5; + + type Fix is delta 0.5 range -1.0..1.0; + + type Root(Disc: Enum) is record + I: Int; + U: Unt; + end record; + + type List is array(Unt) of Root(Stuff); + + type A_List is access all List; + type A_Proc is access procedure(R:Root); + + procedure Proc(R:Root); + function Func return A_Proc; + + protected type PT is + entry Prot_Entry(Switch: Boolean); + private + Toggle : Boolean := False; + end PT; + + task type TT is + entry Task_Entry(Items: in A_List); + end TT; + + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- AORS + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + + end CXH3002_0; + + ----------------------------------------------------------------- CXH3002_1 + + with Ada.Finalization; + package CXH3002_0.CXH3002_1 is + + type Final is new Ada.Finalization.Controlled with + record + Value : Natural; + end record; + + procedure Initialize( F: in out Final ); + procedure Adjust( F: in out Final ); + procedure Finalize( F: in out Final ); + + end CXH3002_0.CXH3002_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_0 + + package body CXH3002_0 is + + Global_Variable : Character := 'A'; + + procedure Proc(R:Root) is + begin + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point( Global_Variable ); -- BDPQT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + case R.Disc is + when Item => Global_Variable := 'I'; + when Stuff => Global_Variable := 'S'; + when Things => Global_Variable := 'T'; + end case; + end Proc; + + function Func return A_Proc is + begin + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- APQT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + return Proc'Access; + end Func; + + protected body PT is + entry Prot_Entry(Switch: Boolean) when True is + begin + Toggle := Switch; + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- APVT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + end Prot_Entry; + end PT; + + task body TT is + List_Copy : A_List; + begin + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- APUT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + loop + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- APUT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + select + accept Task_Entry(Items: in A_List) do + List_Copy := Items; + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point( List_Copy ); -- BFPUT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + end Task_Entry; + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- APUT + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + or terminate; + end select; + end loop; + end TT; + + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point; -- ARTO + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + + end CXH3002_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- CXH3002_1 + + with Report; + package body CXH3002_0.CXH3002_1 is + + Embedded_Final_Object : Final + := (Ada.Finalization.Controlled with Value => 1); + -- attempt to call Initialize here would P_E! + + procedure Initialize( F: in out Final ) is + begin + F.Value := 1; + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point( Embedded_Final_Object ); -- BKQP + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + end Initialize; + + procedure Adjust( F: in out Final ) is + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point; -- AQO + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + begin + F.Value := 2; + end Adjust; + + procedure Finalize( F: in out Final ) is + begin + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- AQP + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + if F.Value not in 1..10 then + Report.Failed("Bad value in controlled object at finalization"); + end if; + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + pragma Inspection_Point; -- AQP + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---==== + end Finalize; + + begin + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====== + pragma Inspection_Point( Embedded_Final_Object ); -- BKRTP + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---====== + null; + end CXH3002_0.CXH3002_1; + + ------------------------------------------------------------------- CXH3002 + + with Report; + with CXH3002_0.CXH3002_1; + procedure CXH3002 is + + use type CXH3002_0.Enum, CXH3002_0.Int, CXH3002_0.Unt, CXH3002_0.Flt, + CXH3002_0.Fix, CXH3002_0.Root; + + Main_Enum : CXH3002_0.Enum := CXH3002_0.Item; + Main_Int : CXH3002_0.Int; + Main_Unt : CXH3002_0.Unt; + Main_Flt : CXH3002_0.Flt; + Main_Fix : CXH3002_0.Fix; + Main_Rec : CXH3002_0.Root(CXH3002_0.Stuff) + := (CXH3002_0.Stuff, I => 1, U => 2); + + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + pragma Inspection_Point( Main_Rec ); -- BJQO + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---===== + + Main_List : CXH3002_0.List := ( others => Main_Rec ); + + Main_A_List : CXH3002_0.A_List := new CXH3002_0.List'( others => Main_Rec ); + Main_A_Proc : CXH3002_0.A_Proc := CXH3002_0.Func; + -- CXH3002_0.Proc'Access + Main_PT : CXH3002_0.PT; + Main_TT : CXH3002_0.TT; + + type Test_Range is (First, Second); + + procedure Assert( Truth : Boolean; Message : String ) is + begin + if not Truth then + Report.Failed( "Unexpected value found in " & Message ); + end if; + end Assert; + + begin -- Main test procedure. + + Report.Test ("CXH3002", "Check pragma Inspection_Point" ); + + Enclosure:declare + Main_Final : CXH3002_0.CXH3002_1.Final; + Xtra_Final : CXH3002_0.CXH3002_1.Final; + begin + for Test_Case in Test_Range loop + + + case Test_Case is + when First => + Main_Final.Value := 5; + Xtra_Final := Main_Final; -- call Adjust + Main_Enum := CXH3002_0.Things; + Main_Int := CXH3002_0.Int'First; + Main_Unt := CXH3002_0.Unt'Last; + Main_Flt := 3.14; + Main_Fix := 0.5; + Main_Rec := (CXH3002_0.Stuff, I => 3, U => 4); + Main_List(Main_Unt) := Main_Rec; + Main_A_List(CXH3002_0.Unt'First) := (CXH3002_0.Stuff, I => 5, U => 6); + Main_A_Proc( Main_A_List(2) ); + Main_PT.Prot_Entry(True); + Main_TT.Task_Entry( null ); + + when Second => + Assert( Main_Final.Value = 5, "Main_Final" ); + Assert( Xtra_Final.Value = 2, "Xtra_Final" ); + Assert( Main_Enum = CXH3002_0.Things, "Main_Enum" ); + Assert( Main_Int = CXH3002_0.Int'First, "Main_Int" ); + Assert( Main_Unt = CXH3002_0.Unt'Last, "Main_Unt" ); + Assert( Main_Flt in 3.0..3.5, "Main_Flt" ); + Assert( Main_Fix = 0.5, "Main_Fix" ); + Assert( Main_Rec = (CXH3002_0.Stuff, I => 3, U => 4), "Main_Rec" ); + Assert( Main_List(Main_Unt) = Main_Rec, "Main_List" ); + Assert( Main_A_List(CXH3002_0.Unt'First) + = (CXH3002_0.Stuff, I => 5, U => 6), "Main_A_List" ); + + end case; + + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---== + pragma Inspection_Point( -- CQP + Main_Final, -- M + Main_Enum, -- D + Main_Int, -- E + Main_Unt, -- E + Main_Flt, -- G + Main_Fix, -- H + Main_Rec, -- J + Main_List, -- I + Main_A_List, -- F + Main_A_Proc, -- F + Main_PT, -- L + Main_TT ); -- N + -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- --- -- ---== + + end loop; + end Enclosure; + + Report.Result; + + end CXH3002; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh30030.a 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- CXH30030.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- See CHX30031.AM + -- + -- TEST DESCRIPTION + -- See CHX30031.AM + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- => CXH30030.A + -- CXH30031.AM + -- + -- APPLICABILITY CRITERIA: + -- See CHX30031.AM + -- + -- SPECIAL REQUIREMENTS + -- See CHX30031.AM + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial version for 2.1 + -- 07 JUN 96 SAIC Revised by reviewer request, split to multifile + -- + --! + + pragma Reviewable; + + -- This test requires that this configuration pragma be applied to all + -- following compilation units in the environment; specifically the ones + -- in file CXH30031.AM diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cxh/cxh30031.am 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,215 ---- + -- CXH30031.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE + -- Check pragma Reviewable. + -- Check that pragma Reviewable is accepted as a configuration pragma. + -- + -- TEST DESCRIPTION + -- This test checks that pragma Reviewable is processed as a + -- configuration pragma. See CXH3001 for testing pragma Reviewable as + -- other than a configuration pragma. + -- + -- TEST FILES: + -- The following files comprise this test: + -- + -- CXH30030.A + -- => CXH30031.AM + -- + -- APPLICABILITY CRITERIA: + -- This test is only applicable for a compiler attempting validation + -- for the Safety and Security Annex. + -- + -- SPECIAL REQUIREMENTS + -- The implementation must process a configuration pragma which is not + -- part of any Compilation Unit; the method employed is implementation + -- defined. + -- + -- + -- CHANGE HISTORY: + -- 26 OCT 95 SAIC Initial version for 2.1 + -- 07 JUN 96 SAIC Revised by reviewer request + -- 03 NOV 96 SAIC Documentation revision + -- + -- 03 NOV 96 Keith Documentation revision + -- 27 AUG 99 RLB Removed result dependence on uninitialized object. + -- 30 AUG 99 RLB Repaired the above. + -- + --! + + pragma Reviewable; + + ----------------------------------------------------------------- CXH3003_0 + + package CXH3003_0 is + + type Enum is (Item,Stuff,Things); + + type Int is range 0..256; + + type Unt is mod 256; + + type Flt is digits 5; + + type Fix is delta 0.5 range -1.0..1.0; + + type Root(Disc: Enum) is tagged record + I: Int; U:Unt; + end record; + + type List is array(Unt) of Root(Stuff); + + type A_List is access List; + type A_Proc is access procedure(R:Root); + + procedure P(R:Root); + + function F return A_Proc; + + Global_Variable : Boolean := False; + + end CXH3003_0; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + with Report; + package body CXH3003_0 is + + procedure P(R:Root) is + Warnable : Positive := 0; -- OPTIONAL WARNING + begin + case R.Disc is + when Item => Report.Comment("Got Item"); + when Stuff => Report.Comment("Got Stuff"); + when Things => Report.Comment("Got Things"); + end case; + if Report.Ident_Int( Warnable ) = 0 then + Global_Variable := not Global_Variable; -- known to be initialized + end if; + end P; + + function F return A_Proc is + begin + return P'Access; + end F; + + end CXH3003_0; + + ----------------------------------------------------------------- CXH3003_1 + + package CXH3003_0.CXH3003_1 is + + protected PT is + entry Set(Switch: Boolean); + function Enquire return Boolean; + private + Toggle : Boolean; + end PT; + + task TT is + entry Release; + end TT; + + end CXH3003_0.CXH3003_1; + + -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- + + package body CXH3003_0.CXH3003_1 is + + protected body PT is + + entry Set(Switch: Boolean) when True is + begin + Toggle := Switch; + end Set; + + function Enquire return Boolean is + begin + return Toggle; + end Enquire; + + end PT; + + task body TT is + begin + loop + accept Release; + exit when Global_Variable; + end loop; + end TT; + + -- TT activation + + end CXH3003_0.CXH3003_1; + + ------------------------------------------------------------------- CXH3003 + + with Report; + with CXH3003_0.CXH3003_1; + procedure CXH30031 is + begin + + Report.Test("CXH3003", "Check pragma Reviewable as a configuration pragma"); + + Block: declare + A_Truth : Boolean; + Message : String := Report.Ident_Str( "Bad value encountered" ); + begin + begin + A_Truth := Report.Ident_Bool( True ) or A_Truth; -- not initialized + if not A_Truth then + Report.Comment ("True or Uninit = False"); + A_Truth := Report.Ident_Bool (True); + else + A_Truth := Report.Ident_Bool (True); + -- We do this separately on each branch in order to insure that a + -- clever optimizer can find out little about this value. Ident_Bool + -- is supposed to be opaque to any optimizer. + end if; + exception + when Constraint_Error | Program_Error => + -- Possible results of accessing an uninitialized object. + A_Truth := Report.Ident_Bool (True); + end; + + CXH3003_0.CXH3003_1.PT.Set( A_Truth ); + + CXH3003_0.Global_Variable := A_Truth; + + CXH3003_0.CXH3003_1.TT.Release; -- rendezvous with TT + + while CXH3003_0.CXH3003_1.TT'Callable loop -- wait for TT to complete + delay 1.0; + end loop; + + if not CXH3003_0.CXH3003_1.PT.Enquire + or not CXH3003_0.Global_Variable then + Report.Failed(Message); + end if; + + end Block; + + Report.Result; + + end CXH30031; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1101a.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- CZ1101A.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- CHECK THAT THE REPORT ROUTINES OF THE REPORT PACKAGE WORK + -- CORRECTLY. + -- + -- PASS/FAIL CRITERIA: + -- THIS TEST PASSES IF THE OUTPUT MATCHES THAT SUPPLIED IN THE + -- APPLICABLE VERSION OF THE ACVC USERS' GUIDE. THE EXPECTED + -- TEST RESULT IS "TENTATIVELY PASSED." + + -- HISTORY: + -- JRK 08/07/81 CREATED ORIGINAL TEST. + -- JRK 10/27/82 + -- JRK 06/01/84 + -- JET 01/13/88 ADDED TESTS OF SPECIAL_ACTION AND UPDATED HEADER. + -- PWB 06/24/88 CORRECTED LENGTH OF ONE OUTPUT STRING AND ADDED + -- PASS/FAIL CRITERIA. + -- BCB 05/17/90 CORRECTED LENGTH OF 'MAX_LEN LONG' OUTPUT STRING. + -- ADDED CODE TO CREATE REPFILE. + -- LDC 05/17/90 REMOVED DIRECT_IO REFERENCES. + -- PWN 12/03/94 REMOVED ADA 9X INCOMPATIBILITIES. + + WITH REPORT; + USE REPORT; + + PROCEDURE CZ1101A IS + + + DATE_AND_TIME : STRING(1..17); + + DATE, TIME : STRING(1..7); + + BEGIN + + COMMENT ("(CZ1101A) CHECK REPORT ROUTINES"); + COMMENT (" INITIAL VALUES SHOULD BE 'NO_NAME' AND 'FAILED'"); + RESULT; + + TEST ("PASS_TEST", "CHECKING 'TEST' AND 'RESULT' FOR 'PASSED'"); + COMMENT ("THIS LINE IS EXACTLY 'MAX_LEN' LONG. " & + "...5...60....5...70"); + COMMENT ("THIS COMMENT HAS A WORD THAT SPANS THE FOLD " & + "POINT. THIS COMMENT FITS EXACTLY ON TWO LINES. " & + "..5...60....5...70"); + COMMENT ("THIS_COMMENT_IS_ONE_VERY_LONG_WORD_AND_SO_" & + "IT_SHOULD_BE_SPLIT_AT_THE_FOLD_POINT"); + RESULT; + + COMMENT ("CHECK THAT 'RESULT' RESETS VALUES TO 'NO_NAME' " & + "AND 'FAILED'"); + RESULT; + + TEST ("FAIL_TEST", "CHECKING 'FAILED' AND 'RESULT' FOR 'FAILED'"); + FAILED ("'RESULT' SHOULD NOW BE 'FAILED'"); + RESULT; + + TEST ("NA_TEST", "CHECKING 'NOT-APPLICABLE'"); + NOT_APPLICABLE ("'RESULT' SHOULD NOW BE 'NOT-APPLICABLE'"); + RESULT; + + TEST ("FAIL_NA_TEST", "CHECKING 'NOT_APPLICABLE', 'FAILED', " & + "'NOT_APPLICABLE'"); + NOT_APPLICABLE ("'RESULT' BECOMES 'NOT-APPLICABLE'"); + FAILED ("'RESULT' BECOMES 'FAILED'"); + NOT_APPLICABLE ("CALLING 'NOT_APPLICABLE' DOESN'T CHANGE " & + "'RESULT'"); + RESULT; + + TEST ("SPEC_NA_TEST", "CHECKING 'SPEC_ACT', 'NOT_APPLICABLE', " & + "'SPEC_ACT'"); + SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'"); + NOT_APPLICABLE ("'RESULT' BECOMES 'NOT APPLICABLE'"); + SPECIAL_ACTION("CALLING 'SPECIAL_ACTION' DOESN'T CHANGE 'RESULT'"); + RESULT; + + TEST ("SPEC_FAIL_TEST", "CHECKING 'SPEC_ACT', 'FAILED', " & + "'SPEC_ACT'"); + SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'"); + FAILED ("'RESULT' BECOMES 'FAILED'"); + SPECIAL_ACTION("CALLING 'SPECIAL_ACTION' DOESN'T CHANGE 'RESULT'"); + RESULT; + + TEST ("CZ1101A", "CHECKING 'SPECIAL_ACTION' ALONE"); + SPECIAL_ACTION("'RESULT' BECOMES 'TENTATIVELY PASSED'"); + RESULT; + + END CZ1101A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1102a.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- CZ1102A.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- CHECK THAT THE DYNAMIC VALUE ROUTINES OF THE REPORT PACKAGE WORK + -- CORRECTLY. + + -- JRK 8/7/81 + -- JRK 10/27/82 + -- RLB 03/20/00 - Added checks for Integer'First and Integer'Last. + + WITH REPORT; + USE REPORT; + + PROCEDURE CZ1102A IS + + BEGIN + + TEST ("CZ1102A", "CHECK THAT THE DYNAMIC VALUE ROUTINES OF " & + "THE REPORT PACKAGE WORK CORRECTLY"); + + IF NOT EQUAL (0, 0) OR + EQUAL (0, 1) OR + NOT EQUAL (1, 1) OR + NOT EQUAL (3, 3) OR + NOT EQUAL (4, 4) OR + NOT EQUAL (-1, -1) OR + NOT EQUAL (INTEGER'FIRST, INTEGER'FIRST) OR + NOT EQUAL (INTEGER'LAST, INTEGER'LAST) OR + EQUAL (-1, 0) THEN + FAILED ("'EQUAL' NOT WORKING"); + END IF; + + IF IDENT_INT (5) /= 5 THEN + FAILED ("'IDENT_INT' NOT WORKING"); + END IF; + + IF IDENT_CHAR ('E') /= 'E' THEN + FAILED ("'IDENT_CHAR' NOT WORKING"); + END IF; + + IF IDENT_BOOL (TRUE) /= TRUE THEN + FAILED ("'IDENT_BOOL' NOT WORKING"); + END IF; + + IF IDENT_STR ("") /= "" OR + IDENT_STR ("K") /= "K" OR + IDENT_STR ("PQRS") /= "PQRS" THEN + FAILED ("'IDENT_STR' NOT WORKING"); + END IF; + + RESULT; + + END CZ1102A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/cz/cz1103a.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,232 ---- + -- CZ1103A.ADA + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- CHECK THAT THE PROCEDURE CHECK_FILE WORKS CORRECTLY, IN + -- PARTICULAR, THAT IT WILL REPORT INCORRECT FILE CONTENTS + -- AS TEST FAILURES. + + -- THIS TEST INTENTIONALLY CONTAINS MISMATCHES BETWEEN FILE + -- CONTENTS AND THE 'CONTENTS' STRING PARAMETER OF PROCEDURE + -- CHECK_FILE. + + -- PASS/FAIL CRITERIA: + -- IF AN IMPLEMENTATION SUPPORTS EXTERNAL FILES, IT PASSES THIS TEST + -- IF TEST EXECUTION REPORTS THE FOLLOWING FOUR FAILURES, REPORTS AN + -- INTERMEDIATE "FAILED" RESULT, REPORTS A FINAL "TENTATIVELY PASSED" + -- RESULT, AND REPORTS NO OTHER FAILURES. + -- * CZ1103A FROM CHECK_FILE: END OF LINE EXPECTED - E + -- ENCOUNTERED. + -- * CZ1103A FROM CHECK_FILE: END_OF_PAGE NOT WHERE EXPECTED. + -- * CZ1103A FROM CHECK_FILE: END_OF_FILE NOT WHERE EXPECTED. + -- * CZ1103A FROM CHECK_FILE: FILE DOES NOT CONTAIN CORRECT + -- OUTPUT - EXPECTED C - GOT I. + -- + -- IF AN IMPLEMENTATION DOES NOT SUPPORT EXTERNAL FILES, IT PASSES THIS + -- TEST IF TEST EXECUTION REPORTS NINE FAILURES FOR INCOMPLETE SUBTESTS + -- SIMILAR TO THE SAMPLE BELOW, REPORTS AN INTERMEDIATE "FAILED" RESULT, + -- REPORTS A FINAL "TENTATIVELY PASSED" RESULT, AND REPORTS NO OTHER + -- FAILURES. + -- * CZ1103A TEST WITH EMPTY FILE INCOMPLETE. + + -- HISTORY: + -- SPS 12/09/82 CREATED ORIGINAL TEST. + -- JRK 11/18/85 ADDED COMMENTS ABOUT PASS/FAIL CRITERIA. + -- JET 01/13/88 UPDATED HEADER FORMAT, ADDED FINAL CALL TO + -- SPECIAL_ACTION. + -- PWB 06/24/88 CORRECTED PASS/FAIL CRITERIA TO INDICATE THE + -- EXPECTED RESULT (TENTATIVELY PASSED). + -- RLB 03/20/00 CORRECTED PASS/FAIL CRITERIA TO REFLECT PROPER RESULT + -- FOR AN IMPLEMENTATION THAT DOES NOT SUPPORT EXTERNAL FILES. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE CZ1103A IS + + NULL_FILE : FILE_TYPE; + FILE_WITH_BLANK_LINES : FILE_TYPE; + FILE_WITH_BLANK_PAGES : FILE_TYPE; + FILE_WITH_TRAILING_BLANKS : FILE_TYPE; + FILE_WITHOUT_TRAILING_BLANKS : FILE_TYPE; + FILE_WITH_END_OF_LINE_ERROR : FILE_TYPE; + FILE_WITH_END_OF_PAGE_ERROR : FILE_TYPE; + FILE_WITH_END_OF_FILE_ERROR : FILE_TYPE; + FILE_WITH_DATA_ERROR : FILE_TYPE; + + BEGIN + + TEST ("CZ1103A", "CHECK THAT PROCEDURE CHECK_FILE WORKS"); + + -- THIS SECTION TESTS CHECK_FILE WITH AN EMPTY FILE. + + BEGIN + COMMENT ("BEGIN TEST WITH AN EMPTY FILE"); + CREATE (NULL_FILE, OUT_FILE); + CHECK_FILE (NULL_FILE, "#@%"); + CLOSE (NULL_FILE); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH EMPTY FILE INCOMPLETE"); + + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH BLANK LINES. + + BEGIN + COMMENT ("BEGIN TEST WITH A FILE WITH BLANK LINES"); + CREATE (FILE_WITH_BLANK_LINES, OUT_FILE); + NEW_LINE (FILE_WITH_BLANK_LINES, 20); + CHECK_FILE (FILE_WITH_BLANK_LINES, "####################@%"); + CLOSE (FILE_WITH_BLANK_LINES); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH FILE WITH BLANK LINES INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH BLANK LINES AND PAGES. + + BEGIN + COMMENT ("BEGIN TEST WITH A FILE WITH BLANK LINES " & + "AND PAGES"); + CREATE (FILE_WITH_BLANK_PAGES, OUT_FILE); + NEW_LINE (FILE_WITH_BLANK_PAGES, 3); + NEW_PAGE (FILE_WITH_BLANK_PAGES); + NEW_LINE (FILE_WITH_BLANK_PAGES, 2); + NEW_PAGE (FILE_WITH_BLANK_PAGES); + NEW_PAGE (FILE_WITH_BLANK_PAGES); + CHECK_FILE (FILE_WITH_BLANK_PAGES, "###@##@#@%"); + CLOSE (FILE_WITH_BLANK_PAGES); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH FILE WITH BLANK PAGES INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH TRAILING BLANKS. + + BEGIN + COMMENT ("BEGIN TEST WITH A FILE WITH TRAILING BLANKS"); + CREATE (FILE_WITH_TRAILING_BLANKS, OUT_FILE); + FOR I IN 1 .. 3 LOOP + PUT_LINE (FILE_WITH_TRAILING_BLANKS, + "LINE WITH TRAILING BLANKS "); + END LOOP; + CHECK_FILE(FILE_WITH_TRAILING_BLANKS, "LINE WITH TRAILING" & + " BLANKS#LINE WITH TRAILING BLANKS#LINE" & + " WITH TRAILING BLANKS#@%"); + CLOSE (FILE_WITH_TRAILING_BLANKS); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH FILE WITH TRAILING BLANKS " & + "INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITHOUT TRAILING BLANKS. + + BEGIN + COMMENT ("BEGIN TEST WITH A FILE WITHOUT TRAILING BLANKS"); + CREATE (FILE_WITHOUT_TRAILING_BLANKS, OUT_FILE); + FOR I IN 1 .. 3 LOOP + PUT_LINE (FILE_WITHOUT_TRAILING_BLANKS, + "LINE WITHOUT TRAILING BLANKS"); + END LOOP; + CHECK_FILE(FILE_WITHOUT_TRAILING_BLANKS, "LINE WITHOUT " & + "TRAILING BLANKS#LINE WITHOUT TRAILING BLANKS#" & + "LINE WITHOUT TRAILING BLANKS#@%"); + CLOSE (FILE_WITHOUT_TRAILING_BLANKS); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH FILE WITHOUT TRAILING BLANKS " & + "INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF LINE ERROR. + + BEGIN + COMMENT ("BEGIN TEST WITH A FILE WITH AN END OF LINE ERROR"); + CREATE (FILE_WITH_END_OF_LINE_ERROR, OUT_FILE); + PUT_LINE (FILE_WITH_END_OF_LINE_ERROR, "THIS LINE WILL " & + "CONTAIN AN END OF LINE IN THE WRONG PLACE"); + CHECK_FILE (FILE_WITH_END_OF_LINE_ERROR, "THIS LINE WILL " & + "CONTAIN AN # IN THE WRONG PLACE#@%"); + CLOSE (FILE_WITH_END_OF_LINE_ERROR); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH END_OF_LINE ERROR INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF PAGE ERROR. + + BEGIN + COMMENT ("BEGIN TEST WITH FILE WITH END OF PAGE ERROR"); + CREATE (FILE_WITH_END_OF_PAGE_ERROR, OUT_FILE); + PUT_LINE (FILE_WITH_END_OF_PAGE_ERROR, "THIS LINE WILL " & + "CONTAIN AN END OF PAGE IN THE WRONG PLACE"); + CHECK_FILE (FILE_WITH_END_OF_PAGE_ERROR, "THIS LINE WILL " & + "CONTAIN AN @ IN THE WRONG PLACE#@%"); + CLOSE (FILE_WITH_END_OF_PAGE_ERROR); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH END_OF_PAGE ERROR INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH AN END OF FILE ERROR. + + BEGIN + COMMENT ("BEGIN TEST WITH FILE WITH END OF FILE ERROR"); + CREATE (FILE_WITH_END_OF_FILE_ERROR, OUT_FILE); + PUT_LINE (FILE_WITH_END_OF_FILE_ERROR, "THIS LINE WILL " & + "CONTAIN AN END OF FILE IN THE WRONG PLACE"); + CHECK_FILE (FILE_WITH_END_OF_FILE_ERROR, "THIS LINE WILL " & + "CONTAIN AN % IN THE WRONG PLACE#@%"); + CLOSE (FILE_WITH_END_OF_FILE_ERROR); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH END_OF_FILE ERROR INCOMPLETE"); + END; + + -- THIS SECTION TESTS CHECK_FILE WITH A FILE WITH INCORRECT DATA. + + BEGIN + COMMENT ("BEGIN TEST WITH FILE WITH INCORRECT DATA"); + CREATE (FILE_WITH_DATA_ERROR, OUT_FILE); + PUT_LINE (FILE_WITH_DATA_ERROR, "LINE WITH INCORRECT " & + "DATA"); + CHECK_FILE (FILE_WITH_DATA_ERROR, "LINE WITH CORRECT " & + "DATA#@%"); + CLOSE (FILE_WITH_DATA_ERROR); + EXCEPTION + WHEN OTHERS => + FAILED ("TEST WITH INCORRECT DATA INCOMPLETE"); + END; + + RESULT; + + TEST ("CZ1103A", "THE LINE ABOVE SHOULD REPORT FAILURE"); + SPECIAL_ACTION ("COMPARE THIS OUTPUT TO THE EXPECTED RESULT"); + RESULT; + + END CZ1103A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a002a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a002a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a002a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a002a.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- D4A002A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- LARGE LITERALS IN NUMBER DECLARATIONS, BUT WITH RESULTING + -- SMALLER VALUE OBTAINED BY SUBTRACTION. THIS TEST LIMITS VALUES + -- TO 32 BINARY PLACES. + + -- BAW 29 SEPT 80 + -- JBG 12/6/84 + + WITH REPORT; + PROCEDURE D4A002A IS + + USE REPORT; + + X : CONSTANT := 1_034_567_890 - 1_034_567_891; + Y : CONSTANT := 107 * (10 ** 7) - 1_069_999_999; + Z : CONSTANT := (1024 ** 3) - (2 ** 30); + D : CONSTANT := 1_073_741_823 / 32_769; + E : CONSTANT := 536_870_912 REM 2_304_167; + F : CONSTANT := (-134_217_728) MOD (-262_657); + + BEGIN TEST("D4A002A","LARGE INTEGER RANGE (WITH CANCELLATION) IN " & + "NUMBER DECLARATIONS; LONGEST INTEGER IS 32 BITS"); + + IF X /= -1 OR Y /= 1 OR Z /= 0 OR D /= 32_767 OR E /= 1 OR F /= -1 + THEN FAILED("EXPRESSIONS WITH A LARGE INTEGER RANGE (WITH " & + "CANCELLATION) ARE NOT EXACT "); + END IF; + + RESULT; + + END D4A002A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a002b.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- D4A002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- LARGER LITERALS IN NUMBER DECLARATIONS, BUT WITH RESULTING + -- SMALLER VALUE OBTAINED BY SUBTRACTION. THIS TEST LIMITS VALUES + -- TO 64 BINARY PLACES. + + -- BAW 29 SEPT 80 + -- JBG 05/02/85 RENAMED TO -B. REVISED SO THAT ALL RESULTS FIT IN + -- 16 BITS. + + WITH REPORT; + PROCEDURE D4A002B IS + + USE REPORT; + + X : CONSTANT := 4123456789012345678 - 4123456789012345679; + Y : CONSTANT := 4 * (10 ** 18) - 3999999999999999999; + Z : CONSTANT := (1024 ** 6) - (2 ** 60); + D : CONSTANT := 9_223_372_036_854_775_807 / 994_862_694_084_217; + E : CONSTANT := 36_028_790_976_242_271 REM 17_600_175_361; + F : CONSTANT := ( - 2 ** 51 ) MOD ( - 131_071 ); + + BEGIN TEST("D4A002B","LARGE INTEGER RANGE (WITH CANCELLATION) IN " & + "NUMBER DECLARATIONS; LONGEST INTEGER IS 64 BITS "); + + IF X /= -1 OR Y /= 1 OR Z /= 0 + OR D /= 9271 OR E /= 1 OR F /= -1 + THEN FAILED("EXPRESSIONS WITH A LARGE INTEGER RANGE (WITH " & + "CANCELLATION) ARE NOT EXACT "); + END IF; + + RESULT; + + END D4A002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a004a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a004a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a004a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a004a.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- D4A004A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- 32 BIT INTEGERS IN NUMBER DECLARATIONS. UNLIKE TEST D4A002A, + -- NO CANCELLATION IS INVOLVED. + + -- A COMPILER MAY REFUSE TO COMPILE THIS TEST BECAUSE THE NUMBERS + -- INVOLVED ARE TOO BIG. + + -- BAW 29 SEPT 80 + -- JBG 12/6/84 + + WITH REPORT; + PROCEDURE D4A004A IS + + USE REPORT; + + X : CONSTANT := 511_111_111 + 501_111_111; + Y : CONSTANT := -599_999_999 - 411_111_112; + Z : CONSTANT := 10 * (10 ** 8); + D : CONSTANT := 2 ** 30 / 1; + E : CONSTANT := ( 2 ** 29 - 1) REM 233; + F : CONSTANT := ABS(( - 2 ** 27 + 1) MOD 511); + + BEGIN TEST("D4A004A","LARGE INTEGER VALUES IN NUMBER DECLARATIONS; " & + "LONGEST INTEGER IS 32 BITS "); + + IF X /= 1_012_222_222 OR Y /= -1_011_111_111 + THEN FAILED("ADDITION OR SUBTRACTION NOT EXACT"); + END IF; + + IF Z /= 1_000_000_000 OR D /= 1_073_741_824 OR E /= 0 OR F /= 0 + THEN FAILED("INTEGER ** IS NOT EXACT"); + END IF; + + RESULT; + + END D4A004A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a004b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a004b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/d/d4a004b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/d/d4a004b.ada 2003-10-27 11:28:59.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- D4A004B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- INTEGERS TO 64 BITS IN NUMBER DECLARATIONS. UNLIKE TEST C4A002B, + -- NO CANCELLATION IS INVOLVED. + + -- BAW 29 SEPT 80 + -- JWC 7/8/85 RENAMED TO -AB + + WITH REPORT; + PROCEDURE D4A004B IS + + USE REPORT; + + X : CONSTANT := 2200000000000000000 + 2199999999999999999; + Y : CONSTANT := -2200000000000000001 - 2199999999999999998; + Z : CONSTANT := 4 * (10 ** 18); + D : CONSTANT := 2 ** 63 / 1; + E : CONSTANT := ( 2 ** 63 - 1 ) REM 454_279; + F : CONSTANT := ABS(( -2 ** 55 + 1 ) MOD 2047 ); + + BEGIN TEST("D4A004B","LARGE INTEGER VALUES IN NUMBER DECLARATIONS; " & + "LONGEST INTEGER IS 64 BITS "); + + IF X /= 4399999999999999999 THEN + FAILED ("ERROR X"); + END IF; + + IF Y /= -4399999999999999999 THEN + FAILED ("ERROR Y"); + END IF; + + IF Z /= 4000000000000000000 THEN + FAILED ("ERROR Z"); + END IF; + + IF E /= 0 THEN + FAILED ("ERROR E"); + END IF; + + IF F /= 0 THEN + FAILED ("ERROR F"); + END IF; + + IF D /= 9_223_372_036_854_775_808 THEN + FAILED ("ERROR D"); + END IF; + + RESULT; + + END D4A004B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e28002b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e28002b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e28002b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e28002b.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + -- E28002B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT A PREDEFINED OR AN UNRECOGNIZED PRAGMA MAY HAVE + -- ARGUMENTS INVOLVING OVERLOADED IDENTIFIERS WITHOUT ENOUGH + -- CONTEXTUAL INFORMATION TO RESOLVE THE OVERLOADING. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT REPORTS "TENTATIVELY PASSED" AND + -- THE STARRED COMMENT DOES NOT APPEAR IN THE LISTING. + + -- AN IMPLEMENTATION FAILS THIS TEST IF THE STARRED COMMENT + -- LINE APPEARS IN THE COMPILATION LISTING. + + -- HISTORY: + -- TBN 02/24/86 CREATED ORIGINAL TEST. + -- JET 01/13/88 ADDED CALLS TO SPECIAL_ACTION AND UPDATED HEADER. + -- EDS 10/28/97 ADDED DECLARATIONS FOR PROCEDURES XYZ. + + WITH REPORT, SYSTEM; USE REPORT, SYSTEM; + PROCEDURE E28002B IS + + FUNCTION OFF RETURN INTEGER IS + BEGIN + RETURN 1; + END OFF; + + FUNCTION OFF RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END OFF; + + PRAGMA LIST (OFF); + --***** THIS LINE MUST NOT APPEAR IN COMPILATION LISTING. + PRAGMA LIST (ON); + + FUNCTION ELABORATION_CHECK RETURN INTEGER IS + BEGIN + RETURN 1; + END ELABORATION_CHECK; + + FUNCTION ELABORATION_CHECK RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END ELABORATION_CHECK; + + PRAGMA SUPPRESS (ELABORATION_CHECK, ELABORATION_CHECK); + + FUNCTION TIME RETURN INTEGER IS + BEGIN + RETURN 1; + END TIME; + + FUNCTION TIME RETURN BOOLEAN IS + BEGIN + RETURN TRUE; + END TIME; + + PRAGMA OPTIMIZE (TIME); + + PROCEDURE XYZ; + PROCEDURE XYZ (COUNT : INTEGER); + + PRAGMA INLINE (XYZ); + PRAGMA PHIL_BRASHEAR (XYZ); + + PROCEDURE XYZ IS + BEGIN + NULL; + END XYZ; + + PROCEDURE XYZ (COUNT : INTEGER) IS + BEGIN + NULL; + END XYZ; + + BEGIN + TEST ("E28002B", "CHECK THAT A PREDEFINED OR AN UNRECOGNIZED " & + "PRAGMA MAY HAVE ARGUMENTS INVOLVING " & + "OVERLOADED IDENTIFIERS WITHOUT ENOUGH " & + "CONTEXTUAL INFORMATION TO RESOLVE THE " & + "OVERLOADING"); + + SPECIAL_ACTION ("CHECK THAT THE COMPILATION LISTING DOES NOT " & + "SHOW THE STARRED COMMENT LINE"); + + RESULT; + + END E28002B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e28005d.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e28005d.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e28005d.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e28005d.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + PRAGMA PAGE; + -- E28005D.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN PRAGMA PAGE IS USED AT THE BEGINNING OR END OF A + -- COMPILATION, THERE IS NO PROBLEM. + + -- PASS/FAIL CRITERIA: + -- THE TEST MUST COMPILE TO EXECUTE WITH A 'TENTATIVELY PASSED' + -- RESULT. THERE IS A PAGE BREAK BEFORE THE TEST NAME AND A + -- PAGE BREAK AFTER THE END OF THE TEST. + + -- HISTORY: + -- RJW 04/16/86 CREATED ORIGINAL TEST. + -- JET 01/13/88 ADDED CALLS TO SPECIAL_ACTION AND UPDATED HEADER. + + WITH REPORT; USE REPORT; + + PROCEDURE E28005D IS + BEGIN + TEST ( "E28005D", "CHECK THAT WHEN PRAGMA PAGE IS USED AT THE " & + "BEGINNING OR END OF A COMPILATION, THERE " & + "IS NO PROBLEM"); + + SPECIAL_ACTION ("CHECK THAT THE PAGE PRAGMAS AT THE BEGINNING " & + "AND END OF THE PROGRAM CAUSE THE TEXT " & + "FOLLOWING THE PRAGMAS TO APPEAR AT THE START " & + "OF A NEW PAGE OF THE COMPILATION LISTING"); + RESULT; + + END E28005D; + + PRAGMA PAGE; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e52103y.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e52103y.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/e52103y.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/e52103y.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,132 ---- + -- E52103Y.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- CHECK WHETHER A NULL ARRAY WITH ONE DIMENSION OF LENGTH GREATER THAN + -- INTEGER'LAST RAISES CONSTRAINT_ERROR OR NO EXCEPTION, + -- EITHER WHEN DECLARED OR ASSIGNED. + + -- CHECK THAT LENGTHS MUST MATCH IN ARRAY AND SLICE ASSIGNMENTS. + -- MORE SPECIFICALLY, TEST THAT ARRAY ASSIGNMENTS WITH MATCHING + -- LENGTHS DO NOT CAUSE CONSTRAINT_ERROR TO BE RAISED AND + -- ARE PERFORMED CORRECTLY. + -- (OVERLAPS BETWEEN THE OPERANDS OF THE ASSIGNMENT STATEMENT + -- ARE TREATED ELSEWHERE.) + + + -- THIS IS A SPECIAL CASE IN + + -- DIVISION D : NULL ARRAYS WHOSE LENGTHS ARE NOT DETERMINABLE + -- STATICALLY + + -- WHICH (THE SPECIAL CASE) TREATS TWO-DIMENSIONAL ARRAYS WHOSE LENGTH + -- ALONG ONE DIMENSION IS GREATER THAN INTEGER'LAST AND WHOSE + -- LENGTH ALONG THE OTHER DIMENSION IS 0 . + + + -- *** NOTE: This test has been modified since ACVC version 1.11 to -- 9X + -- *** remove incompatibilities associated with the transition -- 9X + -- *** to Ada 9X. -- 9X + -- *** -- 9X + + -- RM 07/31/81 + -- SPS 03/22/83 + -- JBG 05/02/83 + -- JBG 06/01/85 + -- EG 10/28/85 FIX NUMERIC_ERROR/CONSTRAINT_ERROR ACCORDING TO + -- AI-00387. + -- LDC 06/01/88 CHANGED HEADER COMMENT TO INDICATE CONSTRAINT_ERROR + -- IS ALLOWED. ADDED CODE TO PREVENT DEAD VARIABLE + -- OPTIMIZATION. + -- MRM 03/30/93 REMOVED NUMERIC_ERROR FOR 9X COMPATIBILITY + + WITH REPORT; + PROCEDURE E52103Y IS + + USE REPORT ; + + BEGIN + + TEST( "E52103Y","CHECK WHETHER CONSTRAINT_ERROR " & + "OR NO EXCEPTION IS RAISED WHEN DIMENSION OF " & + "AN ARRAY HAS LENGTH > INTEGER'LAST"); + BEGIN + + DECLARE + + TYPE TA42 IS ARRAY( + INTEGER RANGE IDENT_INT( 13 )..IDENT_INT( 12 ), + INTEGER RANGE IDENT_INT(-2)..IDENT_INT(INTEGER'LAST) + ) OF BOOLEAN ; + + SUBTYPE TA41 IS TA42 ; + + ARR41 : TA41 ; + ARR42 : TA42 ; + + BEGIN + + COMMENT ("NO EXCEPTION FOR ARRAY DECLARATION"); + + -- NULL ARRAY ASSIGNMENT: + + ARR42 := ARR41 ; + IF ARR42'LENGTH(1) /= 0 THEN + FOR I IN TA42'RANGE(2) LOOP + ARR41(13,I) := IDENT_BOOL(ARR42(13,I)); + END LOOP; + END IF; + + COMMENT ("NO EXCEPTION RAISED FOR NULL ARRAY " & + "ASSIGNMENT"); + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED IN LENGTH " & + "COMPARISON"); + + WHEN OTHERS => + FAILED( "OTHER EXCEPTION RAISED - SUBTEST 2" ); + + END ; + + EXCEPTION + + WHEN CONSTRAINT_ERROR => + COMMENT ("CONSTRAINT_ERROR RAISED BY DECLARATION OF " & + "NULL ARRAY TYPE WITH ONE DIMENSION > " & + "INTEGER'LAST"); + + WHEN OTHERS => + FAILED ("SOME OTHER EXCEPTION RAISED"); + + END; + + ------------------------------------------------------------------- + + + RESULT ; + + + END E52103Y; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4011a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4011a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4011a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4011a.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + -- EB4011A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT UNHANDLED EXCEPTIONS RAISED IN PACKAGE SUBUNITS ARE + -- PROPAGATED TO THE ENVIRONMENT STATICALLY ENCLOSING THE + -- CORRESPONDING BODY STUB (DECLARER OF THE PARENT UNIT). + + -- PASS/FAIL CRITERIA: + -- THIS TEST MUST EXECUTE AND REPORT "TENTATIVELY PASSED". IN + -- ADDITION, THE OUTPUT/LOG FILE MUST INDICATE THAT THE PROGRAM + -- TERMINATED WITH AN UNHANDLED EXCEPTION. + + -- HISTORY: + -- DHH 03/29/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE EB4011A IS + + PACKAGE EB4011A_OUTSIDE IS + END EB4011A_OUTSIDE; + + PACKAGE EB4011A1 IS + END EB4011A1; + + PACKAGE BODY EB4011A1 IS + BEGIN + + TEST("EB4011A", "CHECK THAT UNHANDLED EXCEPTIONS RAISED IN " & + "PACKAGE SUBUNITS ARE PROPAGATED TO THE " & + "ENVIRONMENT STATICALLY ENCLOSING THE" & + "CORRESPONDING BODY STUB (DECLARER OF THE " & + "PARENT UNIT)"); + + SPECIAL_ACTION("CHECK THE OUTPUT FILE TO SEE IF THIS " & + "PROGRAM TERMINATED WITH AN UNHANDLED " & + "EXCEPTION"); + + RESULT; + + END EB4011A1; + + PACKAGE BODY EB4011A_OUTSIDE IS SEPARATE; + + BEGIN + + TEST("EB4011A", "THIS LINE SHOULD NOT PRINT OUT"); + + FAILED("EXCEPTION DID NOT CAUSE MAIN PROGRAM TERMINATION"); + RESULT; + + END EB4011A; + + SEPARATE (EB4011A) + PACKAGE BODY EB4011A_OUTSIDE IS + BEGIN + RAISE CONSTRAINT_ERROR; + END EB4011A_OUTSIDE; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4012a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4012a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4012a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4012a.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- EB4012A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN AN UNHANDLED EXCEPTION IS RAISED IN THE MAIN + -- PROGRAM, THE MAIN PROGRAM IS ABANDONED. + + -- PASS/FAIL CRITERIA: + -- THIS TEST MUST EXECUTE AND PRINT "TENTATIVELY PASSED". IN + -- ADDITION, THE OUTPUT/LOG FILE MUST SHOW THAT THE PROGRAM + -- WAS ABANDONED DUE TO AN UNHANDLED EXCEPTION. + + -- HISTORY: + -- DHH 03/29/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + PROCEDURE EB4012A IS + + BEGIN + TEST("EB4012A", "CHECK THAT WHEN AN UNHANDLED EXCEPTION IS " & + "RAISED IN THE MAIN PROGRAM, THE MAIN PROGRAM " & + "IS ABANDONED"); + SPECIAL_ACTION("CHECK THE OUTPUT/LOG FILE TO SEE THAT THIS " & + "PROGRAM WAS ABANDONED BECAUSE OF AN UNHANDLED " & + "EXCEPTION"); + + RESULT; + + IF EQUAL(3,3) THEN + RAISE CONSTRAINT_ERROR; + END IF; + + TEST("EB4012A", "SHOULD NOT PRINT OUT"); + FAILED("CONSTRAINT_ERROR NOT RAISED"); + + RESULT; + + END EB4012A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4014a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4014a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/eb4014a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/eb4014a.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + -- EB4014A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT WHEN EXCEPTIONS ARE RAISED DURING THE ELABORATION OF + -- A LIBRARY UNIT, EXECUTION OF THE MAIN PROGRAM IS ABANDONED. + + -- PASS/FAIL CRITERIA: + -- THIS TEST MUST EXECUTE AND REPORT "TENTATIVELY PASSED". IN + -- ADDITION, THE OUTPUT/LOG FILE MUST INDICATE THAT THE PROGRAM + -- TERMINATED WITH AN UNHANDLED EXCEPTION. + + -- HISTORY: + -- DHH 03/29/88 CREATED ORIGINAL TEST. + -- PWN 05/25/94 ADDED A PROCEDURE TO KEEP PACKAGE BODIES LEGAL. + + WITH REPORT; USE REPORT; + FUNCTION EB4014A1 RETURN INTEGER IS + BEGIN + + TEST("EB4014A", "THIS LINE SHOULD NOT BE PRINTED"); + + FAILED("THE MAIN PROGRAM BODY WAS ENTERED"); + RESULT; + + RETURN IDENT_INT(1); + + END EB4014A1; + + WITH REPORT; USE REPORT; + PRAGMA ELABORATE (REPORT); + PACKAGE EB4014A_OUTSIDE IS + PROCEDURE REQUIRE_BODY; + END EB4014A_OUTSIDE; + + PACKAGE BODY EB4014A_OUTSIDE IS + PROCEDURE REQUIRE_BODY IS + BEGIN + NULL; + END; + BEGIN + TEST("EB4014A", "CHECK THAT WHEN EXCEPTIONS ARE RAISED DURING " & + "THE ELABORATION OF A LIBRARY UNIT, EXECUTION " & + "OF THE MAIN PROGRAM IS ABANDONED"); + + SPECIAL_ACTION("CHECK THE OUTPUT/LOG FILE TO SEE IF THIS " & + "PROGRAM TERMINATED WITH AN UNHANDLED " & + "EXCEPTION"); + + RESULT; + + RAISE CONSTRAINT_ERROR; + END EB4014A_OUTSIDE; + + WITH EB4014A1; WITH EB4014A_OUTSIDE; + WITH REPORT; USE REPORT; + PROCEDURE EB4014A IS + X : INTEGER := EB4014A1; + BEGIN + + TEST("EB4014A", "THIS LINE SHOULD NOT PRINT OUT"); + + FAILED("EXCEPTION DID NOT CAUSE MAIN PROGRAM TERMINATION"); + RESULT; + X := IDENT_INT(X); + END EB4014A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3203a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3203a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3203a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3203a.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,168 ---- + -- EE3203A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT SET_INPUT AND SET_OUTPUT CAN BE USED, AND THAT THEY + -- DO NOT REDEFINE OR CLOSE THE CORRESPONDING STANDARD FILES. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT EXECUTES AND THE STANDARD OUTPUT FILE + -- CONTAINS THE LINE "INITIAL TEXT OF STANDARD_OUTPUT". + + -- HISTORY: + -- ABW 08/25/82 + -- SPS 11/19/82 + -- VKG 02/15/83 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/19/87 CORRECTED EXCEPTION HANDLING, REMOVED DEPENDENCE + -- ON RESET, AND ADDED CHECKS FOR USE_ERROR ON DELETE. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE EE3203A IS + + INCOMPLETE : EXCEPTION; + FILE_IN, FILE_OUT : FILE_TYPE; + LST : NATURAL; + IN_STR : STRING (1 .. 50); + + BEGIN + + TEST ("EE3203A", "CHECK THAT SET_INPUT AND SET_OUTPUT " & + "CAN BE USED, AND THAT CORRESPONDING " & + "STANDARD FILES ARE UNCHANGED"); + + BEGIN + CREATE (FILE_IN, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE - 1"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + BEGIN + CREATE (FILE_OUT, OUT_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE WITH " & + "OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE - 2"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + PUT (FILE_IN, "INITIAL TEXT OF FILE_IN"); + PUT (FILE_OUT, "INITIAL TEXT OF FILE_OUT"); + PUT ("INITIAL TEXT OF STANDARD_OUTPUT"); + + CLOSE (FILE_IN); + + BEGIN + OPEN (FILE_IN, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN WITH " & + "IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE_IN); + SET_OUTPUT (FILE_OUT); + + IF NOT IS_OPEN (STANDARD_INPUT) THEN + FAILED ("STANDARD_INPUT NOT OPEN"); + END IF; + + IF NOT IS_OPEN (FILE_IN) THEN + FAILED ("FILE_IN NOT OPEN"); + END IF; + + IF NOT IS_OPEN (STANDARD_OUTPUT) THEN + FAILED ("STANDARD_OUTPUT NOT OPEN"); + END IF; + + IF NOT IS_OPEN (FILE_OUT) THEN + FAILED ("FILE_OUT NOT OPEN"); + END IF; + + NEW_LINE; + PUT ("SECOND LINE OF OUTPUT"); + + GET_LINE (IN_STR, LST); + IF IN_STR (1 .. LST) /= "INITIAL TEXT OF FILE_IN" THEN + FAILED ("DEFAULT INPUT INCORRECT"); + END IF; + + CHECK_FILE (FILE_IN, "INITIAL TEXT OF FILE_IN#@%"); + SET_OUTPUT (FILE => STANDARD_OUTPUT); + SET_INPUT (FILE => STANDARD_INPUT); + CHECK_FILE (FILE_OUT, "INITIAL TEXT OF FILE_OUT#" & + "SECOND LINE OF OUTPUT#@%"); + + SPECIAL_ACTION ("THE STANDARD OUTPUT FILE SHOULD CONTAIN " & + "THE LINE : INITIAL TEXT OF STANDARD_OUTPUT"); + + BEGIN + DELETE (FILE_IN); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + BEGIN + DELETE (FILE_OUT); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END EE3203A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3204a.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3204a.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3204a.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3204a.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- EE3204A.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT AFTER THE DEFAULT FILES HAVE BEEN REDEFINED, + -- OUTPUT ON THE STANDARD FILES IS STILL PROPERLY HANDLED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS ONLY APPLICABLE TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED, + -- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT. + + -- HISTORY: + -- JLH 07/08/88 CREATED ORIGINAL TEST. + + WITH REPORT; USE REPORT; + WITH TEXT_IO; USE TEXT_IO; + + PROCEDURE EE3204A IS + + FILE1, FILE2 : FILE_TYPE; + ITEM : CHARACTER := 'B'; + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("EE3204A", "CHECK THAT AFTER THE DEFAULT FILES HAVE BEEN " & + "REDEFINED, OUTPUT ON THE STANDARD " & + "FILES IS STILL PROPERLY HANDLED"); + + BEGIN + + BEGIN + CREATE (FILE1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON CREATE " & + "WITH MODE OUT_FILE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON CREATE"); + RAISE INCOMPLETE; + END; + + CREATE (FILE2, OUT_FILE, LEGAL_FILE_NAME(2)); + PUT (FILE2, 'A'); + NEW_LINE (FILE2); + PUT (FILE2, 'B'); + + CLOSE (FILE2); + + BEGIN + OPEN (FILE2, IN_FILE, LEGAL_FILE_NAME(2)); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON OPEN WITH " & + "WITH MODE IN_FILE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (FILE2); + + GET (ITEM); + IF ITEM /= 'A' THEN + FAILED ("INCORRECT VALUE READ FROM DEFAULT FILE"); + END IF; + + SET_OUTPUT (FILE1); + + PUT ("THIS TEST FAILS IF THIS APPEARS IN STANDARD OUTPUT"); + NEW_LINE; + PUT ("THIS TEST FAILS IF THIS APPEARS IN STANDARD OUTPUT"); + + PUT (STANDARD_OUTPUT, "FIRST LINE OF INPUT"); + NEW_LINE (STANDARD_OUTPUT); + PUT (STANDARD_OUTPUT, "SECOND LINE OF INPUT"); + + SPECIAL_ACTION ("CHECK THAT THE CONTENTS OF THE STANDARD " & + "OUTPUT FILE ARE CORRECT"); + SPECIAL_ACTION ("IT SHOULD CONTAIN:"); + SPECIAL_ACTION ("TEST HEADER LINES"); + SPECIAL_ACTION ("FIRST LINE OF INPUT"); + SPECIAL_ACTION ("SECOND LINE OF INPUT"); + + BEGIN + DELETE (FILE1); + DELETE (FILE2); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END EE3204A; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3402b.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3402b.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3402b.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3402b.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- EE3402B.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT NEW_LINE HAS AN OPTIONAL SPACING PARAMETER WITH + -- DEFAULT VALUE ONE, AND CHECK THAT NEW_LINE OPERATES ON THE + -- CURRENT DEFAULT OUTPUT FILE IF NO FILE IS SPECIFIED. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED, + -- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/16/82 + -- TBN 11/04/86 REVISED TEST TO OUTPUT A NON_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- DWC 08/19/87 ADDED SPECIAL ACTION FUNCTION AND REMOVED + -- EXCEPTION HANDLERS. CHANGED TO AN E TEST. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + WITH CHECK_FILE; + + PROCEDURE EE3402B IS + + INCOMPLETE : EXCEPTION; + FILE, FILE_OUT : FILE_TYPE; + SPAC : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + TWO : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(2)); + FOUR : CONSTANT POSITIVE_COUNT := POSITIVE_COUNT (IDENT_INT(4)); + CUR_LINE : COUNT; + + BEGIN + + TEST ("EE3402B", "CHECK THAT NEW_LINE HAS AN OPTIONAL " & + "SPACING PARAMETER WITH DEFAULT VALUE ONE, " & + "AND CHECK THAT NEW_LINE OPERATES ON THE " & + "CURRENT DEFAULT OUTPUT FILE IF NO FILE IS " & + "SPECIFIED."); + + BEGIN + CREATE (FILE); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED; TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED; TEXT CREATE - 1"); + RAISE INCOMPLETE; + END; + + CREATE (FILE_OUT); + + SPECIAL_ACTION ("CHECK OUTPUT FOR FOUR BLANK LINES"); + + NEW_LINE (FILE); + IF LINE (FILE) /= TWO THEN + FAILED ("SPACING DEFAULT NOT ONE"); + END IF; + + SPECIAL_ACTION ("FOUR BLANK LINES SHOULD FOLLOW THIS COMMENT"); + CUR_LINE := LINE (STANDARD_OUTPUT); + NEW_LINE (SPAC); + IF LINE (STANDARD_OUTPUT) /= CUR_LINE + 4 THEN + FAILED ("FILE DEFAULT NOT CORRECT FOR STANDARD_OUTPUT"); + END IF; + + SET_OUTPUT (FILE_OUT); + NEW_LINE (SPAC); + IF LINE (CURRENT_OUTPUT) /= FOUR + 1 THEN + FAILED ("FILE DEFAULT NOT CORRECT FOR CURRENT_OUTPUT"); + END IF; + + SET_OUTPUT (STANDARD_OUTPUT); -- RESET STANDARD OUTPUT + COMMENT ("CHECKING FILE"); + CHECK_FILE (FILE, "#@%"); + COMMENT ("CHECKING FILE_OUT"); + CHECK_FILE (FILE_OUT, "####@%"); + + CLOSE (FILE); + CLOSE (FILE_OUT); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END EE3402B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3409f.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3409f.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3409f.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3409f.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- EE3409F.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT THE FILE PARAMETER FOR SET_COL IS OPTIONAL, AND + -- THAT THE FUNCTION IS THEN APPLIED TO THE CURRENT DEFAULT + -- OUTPUT FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- CREATION OF TEMPORARY TEXT FILES WITH OUT_FILE MODE. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED, + -- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT. + + -- HISTORY: + -- ABW 08/26/82 + -- SPS 09/20/82 + -- TBN 11/10/86 REVISED TEST TO OUTPUT A NOT_APPLICABLE + -- RESULT WHEN FILES ARE NOT SUPPORTED. + -- JLH 08/31/87 CORRECTED EXCEPTION HANDLING, CHECKED FOR + -- USE_ERROR ON DELETE, AND RENAMED FROM + -- CE3409F.ADA. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE EE3409F IS + + INCOMPLETE : EXCEPTION; + FILE_OUT : FILE_TYPE; + TWO : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(2)); + THREE : POSITIVE_COUNT := POSITIVE_COUNT(IDENT_INT(3)); + + BEGIN + + TEST ("EE3409F", "CHECK DEFAULT FILE FOR SET_COL"); + + BEGIN + CREATE (FILE_OUT); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "FOR TEMPORARY FILES WITH " & + "OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN OTHERS => + FAILED ("UNEXPECTED EXCEPTION RAISED ON TEXT CREATE"); + RAISE INCOMPLETE; + END; + + SPECIAL_ACTION ("THE NEXT LINE SHOULD BEGIN IN COLUMN TWO"); + + SET_COL (TWO); + PUT ("SHOULD BEGIN IN COLUMN TWO"); + + IF COL (STANDARD_OUTPUT) /= 28 THEN + FAILED ("SET_COL DOES NOT OPERATE ON THE DEFAULT " & + "STANDARD_OUTPUT"); + END IF; + + NEW_LINE; + + SET_OUTPUT (FILE_OUT); + SET_COL (THREE); + IF COL (CURRENT_OUTPUT) /= THREE THEN + FAILED ("SET_COL DOES NOT OPERATE ON THE DEFAULT " & + "CURRENT_OUTPUT"); + END IF; + + CLOSE (FILE_OUT); + + RESULT; + + EXCEPTION + WHEN INCOMPLETE => + RESULT; + + END EE3409F; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3412c.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3412c.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/e/ee3412c.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/e/ee3412c.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- EE3412C.ADA + + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- OBJECTIVE: + -- CHECK THAT LINE OPERATES ON THE CURRENT DEFAULT OUTPUT FILE WHEN + -- NO FILE IS SPECIFIED. CHECK THAT LINE CAN OPERATE ON FILES OF + -- MODE IN_FILE AND OUT_FILE, INCLUDING THE CURRENT DEFAULT + -- INPUT_FILE. + + -- APPLICABILITY CRITERIA: + -- THIS TEST IS APPLICABLE ONLY TO IMPLEMENTATIONS WHICH SUPPORT + -- TEXT FILES. + + -- PASS/FAIL CRITERIA: + -- THIS TEST IS PASSED IF IT EXECUTES, PRINTS TENTATIVELY PASSED, + -- AND THE CONTENTS OF THE STANDARD OUTPUT FILE ARE CORRECT. + + -- HISTORY: + -- SPS 09/29/82 + -- JBG 08/30/83 + -- JLH 09/02/87 REMOVED DEPENDENCE ON RESET, REMOVED UNNECESSARY + -- CODE, CHECKED FOR USE_ERROR ON DELETE, AND RENAMED + -- FROM CE3412C.ADA. + + WITH REPORT; + USE REPORT; + WITH TEXT_IO; + USE TEXT_IO; + + PROCEDURE EE3412C IS + INCOMPLETE : EXCEPTION; + + BEGIN + + TEST ("EE3412C", "CHECK THAT LINE OPERATES ON DEFAULT IN_FILE " & + "AND OUT_FILE FILES"); + + DECLARE + F1, F2 : FILE_TYPE; + C : POSITIVE_COUNT; + X : CHARACTER; + ITEM : STRING (1..6); + BEGIN + C := LINE (STANDARD_OUTPUT); + NEW_LINE (STANDARD_OUTPUT); + SPECIAL_ACTION ("ONE BLANK LINE SHOULD PRECEDE THIS COMMENT"); + IF LINE /= C+2 THEN + FAILED ("DEFAULT FOR LINE NOT STANDARD_OUTPUT"); + END IF; + + BEGIN + CREATE (F1, OUT_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT CREATE " & + "WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + WHEN NAME_ERROR => + NOT_APPLICABLE ("NAME_ERROR RAISED ON TEXT " & + "CREATE WITH OUT_FILE MODE"); + RAISE INCOMPLETE; + END; + + CREATE (F2, OUT_FILE); + + SET_OUTPUT (F2); + + FOR I IN 1 .. 6 LOOP + PUT (F1, "STRING"); + NEW_LINE (F1); + END LOOP; + IF LINE (F1) /= 7 THEN + FAILED ("LINE INCORRECT SUBTEST 1"); + END IF; + + SET_LINE_LENGTH (3); + PUT ("OUTPUT STRING"); + IF LINE /= LINE(F2) THEN + FAILED ("LINE INCORRECT SUBTEST 2"); + END IF; + + CLOSE (F1); + + BEGIN + OPEN (F1, IN_FILE, LEGAL_FILE_NAME); + EXCEPTION + WHEN USE_ERROR => + NOT_APPLICABLE ("USE_ERROR RAISED ON TEXT OPEN " & + "WITH IN_FILE MODE"); + RAISE INCOMPLETE; + END; + + SET_INPUT (F1); + + GET (F1, ITEM); + IF ITEM /= "STRING" THEN + FAILED ("INCORRECT VALUE READ"); + END IF; + + SKIP_LINE(F1); + SKIP_LINE(F1); + SKIP_LINE(F1); + IF LINE (CURRENT_INPUT) /= 4 AND LINE (F1) /= 4 THEN + FAILED ("LINE INCORRECT SUBTEST 3"); + END IF; + + BEGIN + DELETE (F1); + EXCEPTION + WHEN USE_ERROR => + NULL; + END; + + CLOSE (F2); + + EXCEPTION + WHEN INCOMPLETE => + NULL; + END; + + RESULT; + + END EE3412C; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/gcc/template.ada gcc-3.4.0/gcc/testsuite/ada/acats/tests/gcc/template.ada *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/gcc/template.ada 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/gcc/template.ada 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + with Report; use Report; + + procedure Template is + begin + -- Test header + Test ("TEMPLATE", "Template test for GNU Ada test suite"); + + begin + -- Body of test + -- Call procedure Failed when detecting a failure + Failed ("Pretend this test failed"); + end; + + -- Display result + Result; + end Template; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140010.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140010.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140010.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140010.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + -- LA140010.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140011.AM. + -- + -- TEST DESCRIPTION: + -- See LA140011.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140011.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140010.A + -- LA140011.AM + -- LA140012.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140011.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA140010_0 is + TC_Var : integer := 100; + end LA140010_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140011.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140011.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140011.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140011.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- LA140011.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level function body depends + -- on a unit that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package, a function that withs the + -- package, and a procedure that withs the function. Then, + -- a new version of the package is compiled (in a separate + -- file, simulating an editing modification to the package). + -- Unless automatic recompilation is supported, this + -- test should fail to link. Otherwise, the test should + -- recompile and link the correct version of the withed package + -- and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140010 (and include the results in the + -- program library). + -- 2) Compile the file LA140011 (and include the results in the + -- program library). + -- 3) Compile the file LA140012 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140010.A + -- -> LA140011.AM + -- LA140012.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140011_0 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007I baseline version + -- 08 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Changed unit and file names to conform to + -- coding standards. Modified prologue. + -- 07 DEC 96 SAIC Moved LA140010_0 to a separate file. + -- + --! + + function LA140011_0 return integer; + + with LA140010_0; + function LA140011_0 return integer is + begin + return LA140010_0.TC_Var; + end LA140011_0; + + with Report; use Report; + with LA140011_0; + procedure LA140011 is + TC_Val : integer := 0; + begin + Test ("LA14001", "Check that a compilation unit " & + "may not depend semantically on " & + "two different versions of the same " & + "compilation unit. Check the case " & + "where a library level function body " & + "depends on a unit that is changed"); + + TC_Val := LA140011_0; + if TC_Val = 100 then + Failed ("Revised package not used"); + elsif TC_Val /= -10 then + Failed ("Incorrect test value returned"); + end if; + + Result; + end LA140011; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140012.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140012.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140012.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140012.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- LA140012.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140011.AM. + -- + -- TEST DESCRIPTION: + -- See LA140011.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140011.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140010.A + -- LA140011.AM + -- -> LA140012.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140011.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007I baseline version + -- 08 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Modified prologue to conform to standards. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + package LA140010_0 is + TC_Var : integer := -10; + end LA140010_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140020.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140020.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140020.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140020.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140020.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140021.AM. + -- + -- TEST DESCRIPTION: + -- See LA140021.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140021.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140020.A + -- LA140021.AM + -- LA140022.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140021.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA140020_0 is + procedure P (TC_change : out integer); + + TC_Var : integer := 100; + end LA140020_0; + + package body LA140020_0 is + procedure P (TC_change : out integer) is + begin + TC_change := TC_Var; + end P; + end LA140020_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140021.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140021.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140021.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140021.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- LA140021.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a unit depends on a package whose + -- declaration is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles the specification of a package containing + -- the specification of a procedure. Then it compiles the body + -- of the package containing the body of the procedure and the + -- main test procedure. The main procedure withs the first + -- package and calls the procedure in the first package. Then, + -- the withed package specification is changed and recompiled. + -- Unless automatic recompilation is supported, this test should + -- fail to link. Otherwise, the test should recompile the package + -- body and main procedure, link the correct versions of the unit, + -- and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140020 (and include the results in the + -- program library). + -- 2) Compile the file LA140021 (and include the results in the + -- program library). + -- 3) Compile the file LA140022 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140020.A + -- -> LA140021.AM + -- LA140022.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140020_0 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007J baseline version + -- 08 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Changed unit and file names to conform to + -- coding conventions. + -- 07 DEC 96 SAIC Moved LA140020_0 to a separate file. + -- + --! + + with Report; use Report; + with LA140020_0; + + procedure LA140021 is + TC_Val : integer := 0; + begin + Test ("LA14002", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a unit depends on a package whose " & + "declaration is changed"); + + LA140020_0.P (TC_Val); + if TC_Val = 100 then + Failed ("Changed unit not used"); + elsif TC_Val /= -10 then + Failed ("Incorrect test value"); + end if; + + Result; + end LA140021; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140022.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140022.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140022.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140022.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- LA140022.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140021.AM. + -- + -- TEST DESCRIPTION: + -- See LA140021.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140021.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140020.A + -- LA140021.AM + -- -> LA140022.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140021.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007J baseline version + -- 08 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. Added body for unit to + -- allow automatic recompilation. + -- + --! + + package LA140020_0 is + procedure P (TC_change : out integer); + + TC_Var : integer := -10; + end LA140020_0; + + package body LA140020_0 is + procedure P (TC_change : out integer) is + begin + TC_change := TC_Var; + end P; + end LA140020_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140030.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140030.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140030.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140030.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- LA140030.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140032.AM. + -- + -- TEST DESCRIPTION: + -- See LA140032.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140032.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- => LA140030.A + -- LA140031.A + -- LA140032.AM + -- LA140033.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140032.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007K baseline version + -- 09 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. + -- + --! + + package LA140030 is + TC_named_number : constant := 100; + TC_Var : integer := 100; + end LA140030; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140031.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140031.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140031.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140031.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- LA140031.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140032.AM. + -- + -- TEST DESCRIPTION: + -- See LA140032.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140032.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140030.A + -- => LA140031.A + -- LA140032.AM + -- LA140033.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140032.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007K baseline version + -- 09 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. + -- + --! + + package LA140031 is + procedure P (TC_Change : out integer); + end LA140031; + + with LA140030; -- when LA140030 is revised and recompiled, + -- this semantic dependency has to be handled + + package body LA140031 is + procedure P (TC_Change : out integer) is + begin + TC_Change := LA140030.TC_Var; + end P; + end LA140031; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140032.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140032.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140032.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140032.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- LA140032.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a package body depends on a package + -- specification that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package specification, then a second + -- package specification and body that withs the first package, + -- followed by a procedure that makes a call to a procedure + -- contained inside the second package. Then, the first + -- package specification is recompiled, making the body of + -- package LA140031 obsolete. Unless automatic recompilation + -- is supported this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140030 (and include the results in the + -- program library). + -- 2) Compile the file LA140031 (and include the results in the + -- program library). + -- 3) Compile the file LA140032 (and include the results in the + -- program library). + -- 4) Compile the file LA140033 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140030.A + -- LA140031.A + -- => LA140032.AM + -- LA140033.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140031 is missing or obsolete, and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007K baseline version + -- 09 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Changed main program name and prologue + -- to conform to coding conventions. + -- + --! + + + with Report; use Report; + with LA140031; + procedure LA140032 is + TC_Val : integer := 0; + begin + Test ("LA14003", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a package body " & + "depends on a package specification that " & + "is changed"); + + LA140031.P (TC_Val); + + if TC_Val = 100 then + Failed ("Obsolete unit elaborated"); + elsif TC_Val /= -10 then + Failed ("Incorrect test value"); + end if; + + Result; + end LA140032; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140033.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140033.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140033.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140033.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140033.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140032.AM. + -- + -- TEST DESCRIPTION: + -- See LA140032.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140032.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140030.A + -- LA140031.A + -- LA140032.AM + -- => LA140033.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140032.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007K baseline version + -- 09 MAY 95 SAIC Initial version + -- 16 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. + -- + --! + + package LA140030 is + TC_Var : integer := -10; + end LA140030; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140040.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140040.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140040.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140040.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- LA140040.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140041.AM. + -- + -- TEST DESCRIPTION: + -- See LA140041.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140041.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140040.A + -- LA140041.AM + -- LA140042.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140041.AM. + -- + -- CHANGE HISTORY: + -- 09 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + package LA14004_0 is + TC_Var : integer := 100; + end LA14004_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140041.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140041.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140041.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140041.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,108 ---- + -- LA140041.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic function depends on a + -- library level package. + -- + -- TEST DESCRIPTION: + -- This test compiles a package specification, then a generic + -- function specification and body that withs the package, + -- followed by a procedure that makes a call to an instance of + -- the generic function. Then, the package specification is + -- recompiled, making the body of function LA14004_1 obsolete. + -- Unless automatic recompilation is supported this test should fail + -- to link. Otherwise, the test should recompile and link + -- the correct version of the withed package and report + -- "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140040 (and include the results in the + -- program library). + -- 2) Compile the file LA140041 (and include the results in the + -- program library). + -- 3) Compile the file LA140042 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140040.A + -- -> LA140041.AM + -- LA140042.A + -- + -- PASS/FAIL CRITERIA: + -- Expect a link-time error message that the body of generic + -- function LA14004_1 is missing or obsolete. If automatic + -- recompilation is supported, and an executable image is + -- built, expect a "PASSED" message from execution. + -- + -- CHANGE HISTORY: + -- 09 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + generic + function LA14004_1 return integer; + + with LA14004_0; -- Revision and recompilation of LA14004_0 + -- will require resolution of this semantic + -- dependency + function LA14004_1 return integer is + begin + return LA14004_0.TC_Var; + end LA14004_1; + + + + with Report; use Report; + with LA14004_1; + procedure LA140041 is + TC_Val : integer := 0; + + function F_LA14004_1 is new LA14004_1; + begin + Test ("LA14004", "Check that a compilation unit may " & + "not depend semantically on two " & + "different versions of the same " & + "compilation unit. Check the case " & + "where a generic function depends on a "& + "library level package"); + + TC_Val := F_LA14004_1; + + if TC_Val = 100 then + Failed ("Obsolete unit used in elaboration"); + elsif TC_Val /= -10 then + Failed ("Incorrect test value returned"); + end if; + + Result; + end LA140041; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140042.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140042.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140042.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140042.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,53 ---- + -- LA140042.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140041.AM. + -- + -- TEST DESCRIPTION: + -- See LA140041.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140041.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140040.A + -- LA140041.AM + -- -> LA140042.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140041.AM. + -- + -- CHANGE HISTORY: + -- 09 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + package LA14004_0 is + Small_array : array (1..15) of integer; + TC_Var : integer := -10; + end LA14004_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140050.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140050.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140050.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140050.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140050.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140052.AM. + -- + -- TEST DESCRIPTION: + -- See LA140052.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140052.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140050.A + -- LA140051.A + -- LA140052.AM + -- LA140053.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140052.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + generic + hi : integer; + lo : integer; + type flt is digits <>; + package LA14005_0 is + TC_var : flt := flt(lo); + type gen_flt is new flt range flt(lo)..flt(hi); + max : integer := hi; + min : integer := lo; + avg : integer := (hi + lo)/ (integer(2.0)); + end LA14005_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140051.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140051.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140051.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140051.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140051.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140052.AM. + -- + -- TEST DESCRIPTION: + -- See LA140052.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140052.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140050.A + -- -> LA140051.A + -- LA140052.AM + -- LA140053.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140052.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + with LA14005_0; + generic + with package types is new LA14005_0 (<>); + package LA14005_1 is + TC_constant_flt : constant types.gen_flt := types.gen_flt(types.avg); + function return_flt return types.gen_flt; + end LA14005_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140052.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140052.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140052.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140052.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- LA140052.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically on two + -- different versions of the same compilation unit. Check the case + -- where a generic package body depends on a generic package + -- specification. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package specification and body, + -- followed by a procedure that makes a call to a procedure + -- contained inside the generic package. Then, the generic package + -- specification is recompiled, making the body of the generic + -- package obsolete. Unless automatic recompilation is + -- supported this test should fail to link. Otherwise, the test should + -- recompile and link the correct version of the units and report + -- "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140050 (and include the results in the + -- program library). + -- 2) Compile the file LA140051 (and include the results in the + -- program library). + -- 3) Compile the file LA140052 (and include the results in the + -- program library). + -- 4) Compile the file LA140053 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140050.A + -- LA140051.A + -- -> LA140052.AM + -- LA140053.A + -- + -- PASS/FAIL CRITERIA: + -- Expect a link-time error message that the body of generic + -- package LA14005_1 is missing or obsolete. If automatic + -- recompilation is supported, and an executable image is + -- built, expect a "PASSED" message from execution. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008I baseline version + -- 09 MAY 95 SAIC Initial version + -- 08 NOV 96 SAIC Unit naming correction + -- 07 DEC 96 SAIC Moved spec of LA14005_1 to a separate file. + -- + --! + + package body LA14005_1 is + function return_flt return types.gen_flt is + begin + return types.gen_flt(types.TC_var); + end return_flt; + begin + types.TC_var := types.flt(TC_constant_flt); + end LA14005_1; + + --------------------------------------------------------- + + with Report; use Report; + with LA14005_0; + with LA14005_1; + procedure LA140052 is + subtype TC_flt is float digits 5; + + package Y is new LA14005_0 (integer(100.0), integer(0.0), TC_flt); + package inst is new LA14005_1 (Y); + TC_var : TC_flt; + begin + Test ("LA14005", "Check that a compilation unit may not depend " & + "semantically on two different versions of the same " & + "compilation unit. Check the case where a generic package " & + "body depends on a generic package specification"); + + TC_var := TC_flt(inst.return_flt); + + if TC_Var /= TC_flt(Y.min) then + Failed ("Obsolete unit used in elaboration"); + end if; + + Result; + end LA140052; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140053.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140053.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140053.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140053.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140053.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140052.AM. + -- + -- TEST DESCRIPTION: + -- See LA140052.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140052.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140050.A + -- LA140051.A + -- LA140052.AM + -- -> LA140053.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140052.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008I baseline version + -- 09 MAY 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + with LA14005_0; + generic + with package types is new LA14005_0 (<>); + package LA14005_1 is + TC_constant_flt : constant + types.gen_flt := types.gen_flt(types.min); --changed line + function return_flt return types.gen_flt; + end LA14005_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140060.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140060.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140060.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140060.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- LA140060.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140062.AM. + -- + -- TEST DESCRIPTION: + -- See LA140062.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140062.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140060.A + -- LA140061.A + -- LA140062.AM + -- LA140063.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140062.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA14006_types is + type t_type is tagged record + f : integer := 87; + end record; + end LA14006_types; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140061.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140061.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140061.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140061.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + -- LA140061.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140062.AM. + -- + -- TEST DESCRIPTION: + -- See LA140062.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140062.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140060.A + -- -> LA140061.A + -- LA140062.AM + -- LA140063.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140062.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + with LA14006_types; + use LA14006_types; + generic + type t is new t_type with private; + package LA14006_0 is + + type T2 is new t with record + g : integer := 100; + end record; + + TC_var : T2; + + private + type type_t is new t with record + g2 : integer := 99; + end record; + end LA14006_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140062.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140062.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140062.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140062.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + -- LA140062.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic package depends on another + -- generic package specification. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package specification, then + -- compiles a generic package specification and body, + -- followed by a procedure that makes a call to a procedure + -- contained inside the second generic package. Then, the + -- first generic package specification is recompiled, + -- making the body of the generic package LA140060 obsolete. + -- Unless automatic recompilation is supported this test should + -- fail to link. Otherwise, the test should recompile and link + -- the correct version of the units and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140060 (and include the results in the + -- program library). + -- 2) Compile the file LA140061 (and include the results in the + -- program library). + -- 3) Compile the file LA140062 (and include the results in the + -- program library). + -- 4) Compile the file LA140063 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140060.A + -- LA140061.A + -- -> LA140062.AM + -- LA140063.A + -- + -- PASS/FAIL CRITERIA: + -- Expect a link-time error message that the body of generic + -- package LA14006_1 is missing or obsolete. If automatic + -- recompilation is supported, and an executable image is + -- built, expect a "PASSED" message from execution. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008K baseline version + -- 09 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved LA14006_0 to a separate file. Added + -- pragma Elaborate to context clause of LA14006_2. + -- + --! + + with LA14006_0; + with LA14006_types; + use LA14006_types; + generic + type additional is (<>); + add_val : additional; + package LA14006_1 is + type T3 is new t_type with record + h: additional := add_val; + end record; + + procedure P (TC_Change : out integer); + + package inst is new LA14006_0 (T3); + end LA14006_1; + + ---------------------------------------------------------------- + + package body LA14006_1 is + procedure P (TC_Change : out integer) is + begin + TC_Change := inst.TC_Var.g; + end P; + end LA14006_1; + + ---------------------------------------------------------------- + + with LA14006_1; + pragma Elaborate (LA14006_1); + package LA14006_2 is new LA14006_1 (integer, 300); + + ---------------------------------------------------------------- + + with Report; use Report; + with LA14006_2; + procedure LA140062 is + TC_Val : integer := 0; + begin + Test ("LA14006", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic package " & + "depends on another generic package " & + "specification"); + + LA14006_2.P (TC_Val); + + if TC_Val = 100 then + Failed ("Obsolete unit used in elaboration"); + elsif TC_Val /= -10 then + Failed ("Incorrect test value received"); + end if; + + Result; + end LA140062; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140063.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140063.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140063.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140063.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + -- LA140063.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140062.AM. + -- + -- TEST DESCRIPTION: + -- See LA140062.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140062.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140060.A + -- LA140061.A + -- LA140062.AM + -- -> LA140063.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140062.AM. + -- + -- CHANGE HISTORY: + -- 09 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + with LA14006_types; + use LA14006_types; + generic + type t is new t_type with private; + package LA14006_0 is + type T2 is new t with record + g : integer := -10; + end record; + + TC_var : T2; + Other_var : integer := 12; + + private + type type_t is new t with record + g2 : integer := 88; + end record; + end LA14006_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140070.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140070.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140070.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140070.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- LA140070.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140072.AM. + -- + -- TEST DESCRIPTION: + -- See LA140072.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140072.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140070.A + -- LA140071.A + -- LA140072.AM + -- LA140073.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140072.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007L baseline version + -- 12 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14007_0 is -- this will be modified and recompiled + type mod_16 is new integer; + type rec is tagged record + f: mod_16 := 12; + end record; + type t_rec is new rec with record + g : mod_16 := -2; + end record; + TC_Var : t_rec; + end LA14007_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140071.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140071.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140071.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140071.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + -- LA140071.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140072.AM. + -- + -- TEST DESCRIPTION: + -- See LA140072.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140072.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140070.A + -- -> LA140071.A + -- LA140072.AM + -- LA140073.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140072.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007L baseline version + -- 12 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. Deleted extraneous procedure + -- specification. + -- + --! + + procedure LA14007_1 (TC_Parent : in out integer); + + --================================================================-- + + procedure LA14007_1 (TC_Parent : in out integer) is + procedure LA14007_2 (TC_Local : in out integer) is separate; + begin + LA14007_2 (TC_Parent); + end LA14007_1; + + --================================================================-- + + with LA14007_0; + + separate (LA14007_1) + procedure LA14007_2 (TC_Local : in out integer) is + begin + TC_Local := integer (LA14007_0.TC_Var.f); + end LA14007_2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140072.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140072.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140072.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140072.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- LA140072.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a separate procedure body depends on + -- a non-generic package specification that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package specification, a procedure, + -- the separate procedure body and a main procedure that + -- withs the first package. Then, a new version of the + -- first package specification is compiled (in a separate + -- file, simulating editing and modification of the unit). + -- Unless automatic recompilation is supported, this test + -- should fail to link. Otherwise, the test should + -- recompile and link the correct version of the withed + -- package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140070 (and include the results in the + -- program library). + -- 2) Compile the file LA140071 (and include the results in the + -- program library). + -- 3) Compile the file LA140072 (and include the results in the + -- program library). + -- 4) Compile the file LA140073 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140070.A + -- LA140071.A + -- -> LA140072.AM + -- LA140073.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14007_1.LA14007_2 is missing or obsolete and no executable + -- image results. The test also passes if an executable image is + -- produced and reports "PASSED" (in the case where the implementation + -- supports automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007L baseline version + -- 12 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + + with Report; use Report; + with LA14007_1; + + procedure LA140072 is + TC_Val : integer := 0; + begin + Test ("LA14007", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a separate procedure " & + "body depends on a non-generic package " & + "specification that is changed"); + + LA14007_1 (TC_Val); + + if TC_Val = 12 then + Failed ("Obsolete unit used in elaboration"); + elsif TC_Val /= 3 then + Failed ("Incorrect test value returned"); + end if; + + Result; + end LA140072; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140073.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140073.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140073.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140073.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- LA140073.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140072.AM. + -- + -- TEST DESCRIPTION: + -- See LA140072.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140072.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140070.A + -- LA140071.A + -- LA140072.AM + -- -> LA140073.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140072.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007L baseline version + -- 12 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14007_0 is -- this is the corrected version + extra_integer : integer; + type mod_16 is new integer; + type rec is tagged record + f: mod_16 := 3; + end record; + type t_rec is new rec with record + null; + end record; + TC_Var : t_rec; + end LA14007_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140080.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140080.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140080.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140080.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- LA140080.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140082.AM. + -- + -- TEST DESCRIPTION: + -- See LA140082.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140082.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140080.A + -- LA140081.A + -- LA140082.AM + -- LA140083.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140082.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007M baseline version + -- 25 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + function LA14008_0 return integer; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140081.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140081.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140081.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140081.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- LA140081.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140082.AM. + -- + -- TEST DESCRIPTION: + -- See LA140082.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140082.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140080.A + -- -> LA140081.A + -- LA140082.AM + -- LA140083.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140082.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007M baseline version + -- 25 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + function LA14008_0 return integer is + TC_local : integer := 0; + TC_var : integer := 100; + + function LA14008_1 return integer is separate; + -- when LA14008_0 is revised and recompiled, + -- this semantic dependency has to be + -- handled + begin + TC_local := LA14008_1; + return TC_local; + end LA14008_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140082.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140082.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140082.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140082.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,106 ---- + -- LA140082.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a subunit function body depends + -- on a unit that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a function, separate subunit function + -- body, and a procedure that withs the function. Then, + -- a new version of the parent function is compiled (in a separate + -- file, simulating and editing modification to the package). + -- Unless automatic recompilation is supported, this + -- test should fail to link. Otherwise, the test should + -- recompile and link the correct version of the withed package + -- and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140080 (and include the results in the + -- program library). + -- 2) Compile the file LA140081 (and include the results in the + -- program library). + -- 3) Compile the file LA140082 (and include the results in the + -- program library). + -- 4) Compile the file LA140083 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140080.A + -- LA140081.A + -- -> LA140082.AM + -- LA140083.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14008_0.LA14008_1 is missing or obsolete and no executable image + -- results. The test passes if an executable image is produced + -- and reports "PASSED" (in case the implementation supports + -- automatic recompilation). + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007M baseline version + -- 25 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + separate (LA14008_0) + + function LA14008_1 return integer is + begin + return LA14008_0.TC_var; + end LA14008_1; + + --==================================================================-- + + with Report; use Report; + with LA14008_0; + + procedure LA140082 is + TC_val : integer := 0; + begin + Test ("LA14008", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a subunit function body depends on a " & + "unit that is changed"); + + TC_val := LA14008_0; + + if TC_val = 100 then + Failed ("Revised unit not used"); + elsif TC_val /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140082; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140083.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140083.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140083.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140083.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- LA140083.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140082.AM. + -- + -- TEST DESCRIPTION: + -- See LA140082.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140082.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140080.A + -- LA140081.A + -- LA140082.AM + -- -> LA140083.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140082.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007M baseline version + -- 25 MAY 95 SAIC Initial version + -- 10 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + + function LA14008_0 return integer is + Another_var : integer := 1000; + TC_local : integer := 0; + TC_var : integer := -10; + + function LA14008_1 return integer is separate; + + begin + TC_local := LA14008_1; + return TC_local; + end LA14008_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140090.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140090.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140090.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140090.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140090.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140092.AM. + -- + -- TEST DESCRIPTION: + -- See LA140092.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140092.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140090.A + -- LA140091.A + -- LA140092.AM + -- LA140093.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140092.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007N baseline version + -- 25 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + package LA14009_0 is + + package LA14009_1 is + + procedure P (TC_local : in out integer); + + end LA14009_1; + + end LA14009_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140091.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140091.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140091.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140091.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140091.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140092.AM. + -- + -- TEST DESCRIPTION: + -- See LA140092.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140092.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140090.A + -- -> LA140091.A + -- LA140092.AM + -- LA140093.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140092.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007N baseline version + -- 25 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + package body LA14009_0 is + TC_var : integer := 100; + + package body LA14009_1 is separate; + -- when LA14009_0 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + end LA14009_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140092.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140092.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140092.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140092.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,110 ---- + -- LA140092.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a subunit package body depends + -- on a unit that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package, separate subunit package + -- body, and a procedure that withs the package. Then, + -- a new version of the package is compiled (in a separate + -- file, simulating and editing modification to the package). + -- Unless automatic recompilation is supported, this + -- test should fail to link. Otherwise, the test should + -- recompile and link the correct version of the withed package + -- and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140090 (and include the results in the + -- program library). + -- 2) Compile the file LA140091 (and include the results in the + -- program library). + -- 3) Compile the file LA140092 (and include the results in the + -- program library). + -- 4) Compile the file LA140093 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140090.A + -- LA140091.A + -- -> LA140092.AM + -- LA140093.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14009_0.LA14009_1 is missing or obsolete and no executable image + -- results. The test passes if an executable image is produced + -- and reports "PASSED" (in case the implementation supports + -- automatic recompilation). + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007N baseline version + -- 25 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + separate (LA14009_0) + + package body LA14009_1 is + + procedure P (TC_local : in out integer) is + begin + TC_local := LA14009_0.TC_var; + end P; + + end LA14009_1; + + + + with Report; use Report; + with LA14009_0; + + procedure LA140092 is + TC_val : integer := 0; + begin + Test ("LA14009", "Check that a compilation unit may not depend " & + "semantically on two different versions of the " & + "same compilation unit. Check the case where " & + "a subunit package body depends on a unit that " & + "is changed"); + + LA14009_0.LA14009_1.P(TC_Val); + + if TC_val = 100 then + Failed ("Revised package body not used"); + elsif TC_val /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140092; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140093.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140093.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140093.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140093.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- LA140093.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140092.AM. + -- + -- TEST DESCRIPTION: + -- See LA140092.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140092.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140090.A + -- LA140091.A + -- LA140092.AM + -- -> LA140093.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140092.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007N baseline version + -- 25 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + package body LA14009_0 is + New_TC_var : integer := 50; + Dummy_array : array (1..100) of boolean := (others => False); + TC_var : constant integer := -10; + + package body LA14009_1 is separate; + + end LA14009_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140100.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140100.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140100.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140100.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140100.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140102.AM. + -- + -- TEST DESCRIPTION: + -- See LA140102.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140102.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140100.A + -- LA140101.A + -- LA140102.AM + -- LA140103.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140102.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008O baseline version + -- 29 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14010_0 is + delta_v : integer := 1; + end LA14010_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140101.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140101.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140101.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140101.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,89 ---- + -- LA140101.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140102.AM. + -- + -- TEST DESCRIPTION: + -- See LA140102.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140102.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140100.A + -- -> LA140101.A + -- LA140102.AM + -- LA140103.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140102.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008O baseline version + -- 29 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified prologue to conform to coding + -- conventions. Changed task to task type. + -- + --! + + generic + type scalar is range <>; + package LA14010_1 is + procedure inc (param : in out scalar); + end LA14010_1; + + with LA14010_0; + use LA14010_0; + + package body LA14010_1 is + procedure inc (param : in out scalar) is + begin + for i in 1..delta_v loop + param := param + 1; + end loop; + end inc; + + task type inc_task is + entry increment (param : in out scalar); + end inc_task; + + task body inc_task is separate; + end LA14010_1; + + + separate (LA14010_1) + + task body inc_task is + static_zero : integer := 0; + begin + accept increment (param : in out scalar) do + static_zero := LA14010_0.delta_v + static_zero; + static_zero := static_zero - LA14010_0.delta_v; + inc (param); + end increment; + end inc_task; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140102.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140102.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140102.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140102.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- LA140102.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a task body depends on a package + -- specification. + -- + -- TEST DESCRIPTION: + -- This test compiles a package spec, a generic package + -- with a body containing a task with a body that withs the + -- first package spec, and a main procedure that withs the + -- generic package and calls the task. Then, a new version + -- of the package spec is compiled (in a separate file, simulating + -- editing and modification of the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the package spec and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140100 (and include the results in the + -- program library). + -- 2) Compile the file LA140101 (and include the results in the + -- program library). + -- 3) Compile the file LA140102 (and include the results in the + -- program library). + -- 4) Compile the file LA140103 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140100.A + -- LA140101.A + -- -> LA140102.AM + -- LA140103.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14010_1.INC_TASK is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008O baseline version + -- 29 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14010_1; + + procedure LA140102 is + subtype scalar_type is integer range 0..100; + TC_val : scalar_type := 0; + package Gen_pack is new LA14010_1(scalar_type); + begin + Test ("LA14010", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a task body depends " & + "on a package specification"); + + Gen_pack.inc(TC_val); + + if TC_val = 1 then + Failed ("Old package specification used"); + elsif TC_val /= 10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140102; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140103.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140103.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140103.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140103.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- LA140103.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140102.AM. + -- + -- TEST DESCRIPTION: + -- See LA140102.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140102.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140100.A + -- LA140101.A + -- LA140102.AM + -- -> LA140103.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140102.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008O baseline version + -- 29 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14010_0 is + New_var : integer := 100; + Local_array : array (1..51) of integer; + delta_v : constant integer := 10; + end LA14010_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140110.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140110.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140110.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140110.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140110.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140112.AM. + -- + -- TEST DESCRIPTION: + -- See LA140112.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140112.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140110.A + -- LA140111.A + -- LA140112.AM + -- LA140113.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140112.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007P baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + + procedure LA14011_0 (Change_this : in out integer); + + + procedure LA14011_0 (Change_this : in out integer) is + begin + if Change_this = 10 then + Change_this := 100; + else + Change_this := 50; + end if; + end LA14011_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140111.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140111.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140111.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140111.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + -- LA140111.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140112.AM. + -- + -- TEST DESCRIPTION: + -- See LA140112.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140112.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140110.A + -- -> LA140111.A + -- LA140112.AM + -- LA140113.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140112.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007P baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + + with LA14011_0; + + procedure LA14011_1 (Change_this1 : in out integer); + + + procedure LA14011_1 (Change_this1 : in out integer) is + begin + LA14011_0(Change_this1); + end LA14011_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140112.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140112.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140112.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140112.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + -- LA140112.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library procedure depends + -- on a unit that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a procedure, a procedure that withs + -- the first procedure, and a procedure that withs the second + -- procedure. Then, a new version of the first procedure is + -- compiled (in a separate file, simulating an editing + -- modification to the package). Unless automatic recompilation + -- is supported, this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140110 (and include the results in the + -- program library). + -- 2) Compile the file LA140111 (and include the results in the + -- program library). + -- 3) Compile the file LA140112 (and include the results in the + -- program library). + -- 4) Compile the file LA140113 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140110.A + -- LA140111.A + -- -> LA140112.AM + -- LA140113.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14011_1 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007P baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + + with Report; use Report; + with LA14011_1; -- when LA14011_0 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + + procedure LA140112 is + TC_val : integer := 10; + begin + Test ("LA14011", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a library procedure depends on a unit " & + "that is changed"); + + LA14011_1(TC_val); + + if TC_val = 100 then + Failed ("Revised procedure not used"); + elsif TC_val /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140112; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140113.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140113.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140113.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140113.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- LA140113.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140112.AM. + -- + -- TEST DESCRIPTION: + -- See LA140112.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140112.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140110.A + -- LA140111.A + -- LA140112.AM + -- -> LA140113.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140112.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007P baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + procedure LA14011_0 (Change_this : in out integer); + + + procedure LA14011_0 (Change_this : in out integer) is + begin + Change_this := -Change_this; + end LA14011_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140120.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140120.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140120.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140120.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- LA140120.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140122.AM. + -- + -- TEST DESCRIPTION: + -- See LA140122.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140122.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140120.A + -- LA140121.A + -- LA140122.AM + -- LA140123.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140122.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007Q baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + function LA14012_0 (Parm_1 : integer) return integer; + + + function LA14012_0 (Parm_1 : integer) return integer is + begin + if Parm_1 >= 0 then + return 100; + else + return 200; + end if; + end LA14012_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140121.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140121.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140121.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140121.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140121.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140122.AM. + -- + -- TEST DESCRIPTION: + -- See LA140122.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140122.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140120.A + -- -> LA140121.A + -- LA140122.AM + -- LA140123.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140122.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007Q baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + + with LA14012_0; + + function LA14012_1 return integer; + + + function LA14012_1 return integer is + Local_val : integer := 5; + begin + Local_val := LA14012_0 (Parm_1 => Local_val); + return Local_val; + end LA14012_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140122.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140122.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140122.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140122.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- LA140122.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level function depends + -- on a unit that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a function, a function that withs + -- the first function, and a procedure that withs the second + -- function. Then, a new version of the first function is + -- compiled (in a separate file, simulating an editing + -- modification to the package). Unless automatic recompilation + -- is supported, this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140120 (and include the results in the + -- program library). + -- 2) Compile the file LA140121 (and include the results in the + -- program library). + -- 3) Compile the file LA140122 (and include the results in the + -- program library). + -- 4) Compile the file LA140123 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140120.A + -- LA140121.A + -- -> LA140122.AM + -- LA140123.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14012_1 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007Q baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14012_1; -- when LA14012_0 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + + procedure LA140122 is + TC_local : integer := 5; + begin + Test ("LA14012", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a library level function depends on a " & + "unit that is changed"); + + TC_local := LA14012_1; + + if TC_local = 100 then + Failed ("Revised function not used"); + elsif TC_local /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140122; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140123.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140123.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140123.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140123.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- LA140123.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140122.AM. + -- + -- TEST DESCRIPTION: + -- See LA140122.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140122.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140120.A + -- LA140121.A + -- LA140122.AM + -- -> LA140123.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140122.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007Q baseline version + -- 25 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + function LA14012_0 (Parm_1 : integer) return integer; + + + function LA14012_0 (Parm_1 : integer) return integer is + begin + return -(2 * Parm_1); + end LA14012_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140130.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140130.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140130.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140130.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- LA140130.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140132.AM. + -- + -- TEST DESCRIPTION: + -- See LA140132.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140132.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140130.A + -- LA140131.A + -- LA140132.AM + -- LA140133.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140132.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007R baseline version + -- 26 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA140130 is + subtype TC_type is integer range 0..100; + TC_var : TC_type := TC_type'last; + end LA140130; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140131.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140131.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140131.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140131.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- LA140131.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140132.AM. + -- + -- TEST DESCRIPTION: + -- See LA140132.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140132.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140130.A + -- -> LA140131.A + -- LA140132.AM + -- LA140133.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140132.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007R baseline version + -- 26 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + with LA140130; + + package LA140131 is + TC_local : LA140130.TC_type := LA140130.TC_var; + end LA140131; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140132.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140132.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140132.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140132.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- LA140132.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level package depends + -- on a package specification that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package spec., a package that withs + -- the first package, and a procedure that withs the second + -- package. Then, a new version of the first package spec. is + -- compiled (in a separate file, simulating an editing + -- modification to the package). Unless automatic recompilation + -- is supported, this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140130 (and include the results in the + -- program library). + -- 2) Compile the file LA140131 (and include the results in the + -- program library). + -- 3) Compile the file LA140132 (and include the results in the + -- program library). + -- 4) Compile the file LA140133 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140130.A + -- LA140131.A + -- -> LA140132.AM + -- LA140133.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140131 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007R baseline version + -- 26 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA140131; -- when LA140130 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + + procedure LA140132 is + TC_val : integer := 0; + begin + Test ("LA14013", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a library level package depends on a " & + "package specification that is changed"); + + TC_val := LA140131.TC_local; + + if TC_val = 100 then + Failed ("Revised package specification not used"); + elsif TC_val /= -49 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140132; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140133.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140133.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140133.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140133.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- LA140133.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140132.AM. + -- + -- TEST DESCRIPTION: + -- See LA140132.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140132.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140130.A + -- LA140131.A + -- LA140132.AM + -- -> LA140133.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140132.AM. + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007R baseline version + -- 26 MAY 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA140130 is + subtype TC_type is integer range -49..50; + TC_const : constant TC_type := TC_type'first; + TC_var : TC_type := TC_const; + end LA140130; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140140.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140140.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140140.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140140.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- LA140140.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140142.AM. + -- + -- TEST DESCRIPTION: + -- See LA140142.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140142.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140140.A + -- LA140141.A + -- LA140142.AM + -- LA140143.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140142.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007S baseline version + -- 26 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + procedure LA14014_0 (Change_one : in out integer) is + begin + Change_one := Change_one * 5; + end LA14014_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140141.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140141.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140141.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140141.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- LA140141.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140142.AM. + -- + -- TEST DESCRIPTION: + -- See LA140142.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140142.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140140.A + -- -> LA140141.A + -- LA140142.AM + -- LA140143.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140142.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007S baseline version + -- 26 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + with LA14014_0; + procedure LA14014_1 (Change_this : out integer) is + begin + Change_this := 10; + LA14014_0(Change_one => Change_this); + end LA14014_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140142.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140142.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140142.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140142.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- LA140142.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level procedure depends + -- on another library level procedure that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a procedure, a procedure that withs + -- the first procedure, and a procedure that withs the second + -- procedure. Then, a new version of the first procedure is + -- compiled (in a separate file, simulating and editing + -- modification to the procedure). Unless automatic recompilation + -- is supported, this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140140 (and include the results in the + -- program library). + -- 2) Compile the file LA140141 (and include the results in the + -- program library). + -- 3) Compile the file LA140142 (and include the results in the + -- program library). + -- 4) Compile the file LA140143 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140140.A + -- LA140141.A + -- -> LA140142.AM + -- LA140143.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14014_1 is missing or obsolete and no executable image + -- results. The test passes if an executable image is produced + -- and reports "PASSED" (in case the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007S baseline version + -- 26 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + with Report; use Report; + with LA14014_1; -- when LA14014_0 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + procedure LA140142 is + TC_val : integer := 0; + begin + Test ("LA14014", "Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a library level procedure depends on " & + "another library level procedure that is changed"); + + LA14014_1(TC_val); + + if TC_val = 50 then + Failed ("Revised procedure not used"); + elsif TC_val = 70 then + Failed ("Revised procedure not used"); + elsif TC_val /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140142; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140143.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140143.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140143.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140143.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140143.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140142.AM. + -- + -- TEST DESCRIPTION: + -- See LA140142.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140142.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140140.A + -- LA140141.A + -- LA140142.AM + -- -> LA140143.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140142.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007S baseline version + -- 26 MAY 95 SAIC Initial version + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- + --! + + procedure LA14014_0 (Change_two : in integer := 0; + Change_one : out integer) is + begin + + if Change_two = 10 then + Change_one := 70; + elsif Change_two = 0 then + Change_one := -10; + else + Change_one := 30; + end if; + + end LA14014_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140150.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140150.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140150.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140150.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140150.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140152.AM. + -- + -- TEST DESCRIPTION: + -- See LA140152.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140152.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140150.A + -- LA140151.A + -- LA140152.AM + -- LA140153.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140152.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007T baseline version + -- 06 JUN 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + function LA14015_0 (Param_1 : integer) return boolean is + begin + return Param_1 = 5; + end LA14015_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140151.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140151.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140151.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140151.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- LA140151.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140152.AM. + -- + -- TEST DESCRIPTION: + -- See LA140152.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140152.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140150.A + -- -> LA140151.A + -- LA140152.AM + -- LA140153.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140152.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007T baseline version + -- 06 JUN 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + with LA14015_0; -- when LA140150 is revised and recompiled, + -- this semantic dependency has to be + -- handled + + + function LA14015_1 (P : integer) return integer is + begin + if LA14015_0 (Param_1 => P) then + return 100; + else + return -10; + end if; + end LA14015_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140152.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140152.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140152.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140152.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + -- LA140152.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level function depends + -- on another library level function that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a function, a function that withs and + -- calls the first, and a procedure that withs the second + -- function. Then, a new version of the first function is + -- compiled (in a separate file, simulating an editing + -- modification to the function). Unless automatic recompilation + -- is supported, this test should fail to link. Otherwise, the + -- test should recompile and link the correct version of the + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140150 (and include the results in the + -- program library). + -- 2) Compile the file LA140151 (and include the results in the + -- program library). + -- 3) Compile the file LA140152 (and include the results in the + -- program library). + -- 4) Compile the file LA140153 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140150.A + -- LA140151.A + -- -> LA140152.AM + -- LA140153.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14015_1 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007T baseline version + -- 06 JUN 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14015_1; + + procedure LA140152 is + TC_local : integer := 5; + begin + Test ("LA14015", "Check that a compilation unit may " & + "not depend semantically on two " & + "different versions of the same " & + "compilation unit. Check the case " & + "where a library level function " & + "depends on another library level " & + "function that is changed"); + + TC_local := LA14015_1 (5); + + if TC_local = 100 then + Failed ("Revised unit not used"); + elsif TC_local /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140152; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140153.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140153.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140153.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140153.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- LA140153.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140152.AM. + -- + -- TEST DESCRIPTION: + -- See LA140152.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140152.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140150.A + -- LA140151.A + -- LA140152.AM + -- -> LA140153.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140152.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007T baseline version + -- 06 JUN 95 SAIC Initial version + -- 17 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + function LA14015_0 (Param_2 : boolean := false; + Param_1 : integer := 10) return boolean is + begin + if Param_2 then + return true; + else + return Param_1 = 10; + end if; + end LA14015_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140160.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140160.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140160.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140160.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- LA140160.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140162.AM. + -- + -- TEST DESCRIPTION: + -- See LA140162.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140162.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140160.A + -- LA140161.A + -- LA140162.AM + -- LA140163.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140162.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA14016_0 is + subtype status_code is integer range 0..10; + type tagged_type is abstract tagged null record; + function status (param : tagged_type) return status_code is abstract; + end LA14016_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140161.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140161.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140161.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140161.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + -- LA140161.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140162.AM. + -- + -- TEST DESCRIPTION: + -- See LA140162.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140162.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140160.A + -- -> LA140161.A + -- LA140162.AM + -- LA140162.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140162.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + with LA14016_0; + generic + type T is new LA14016_0.tagged_type with private; + type count_type is range <>; + package LA14016_1 is + default_status : constant LA14016_0.status_code := 0; + type new_t is new T with + record + count : count_type; + end record; + function status (param : new_t) return LA14016_0.status_code; + + procedure inc (param : in out new_t); + end LA14016_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140162.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140162.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140162.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140162.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,196 ---- + -- LA140162.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a separate procedure depends + -- on a withed generic package that is changed. + -- + -- TEST DESCRIPTION: + -- This test declares a package which contains a generic procedure GP, + -- the body of which is a subunit. The package also contains a procedure + -- P which instantiates GP and calls the instance. The instance itself + -- calls a procedure which is declared within the instance of a generic + -- package X. The test compiles each of these compilation units and the + -- main procedure, then compiles a new version of the generic package X + -- (in a separate file, simulating an editing modification to the unit). + -- Unless automatic recompilation is supported, this test should fail to + -- link. Otherwise, the test should recompile and link the correct + -- version of the generic package X and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140160 (and include the results in the + -- program library). + -- 2) Compile the file LA140161 (and include the results in the + -- program library). + -- 3) Compile the file LA140162 (and include the results in the + -- program library). + -- 4) Compile the file LA140163 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140160.A + -- LA140161.A + -- -> LA140162.AM + -- LA140163.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14016_4.gen_def is missing or obsolete and no executable + -- image results. The test also passes if an executable image is + -- produced and reports "PASSED" (in the case where the implementation + -- supports automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008L baseline version + -- 16 JUN 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. Restructured subunits + -- to prevent potential Program_Error due to + -- premature instantiation of gen_def. Moved + -- LA14016_1 to a separate file. Added pragma + -- Elaborate to context clause of LA14016_3. + -- + -- + --! + + package body LA14016_1 is + procedure inc (param : in out new_t) is + begin + param.count := param.count + 1; + end inc; + function status (param : new_t) return LA14016_0.status_code is + begin + return LA14016_0.status_code(param.count); + end status; + end LA14016_1; + + --------------------------------------------------------- + + with LA14016_0; + package LA14016_2 is + type extended is new LA14016_0.tagged_type with + record + status : LA14016_0.status_code := 10; + end record; + function status (param : extended) return LA14016_0.status_code; + end LA14016_2; + + --------------------------------------------------------- + + package body LA14016_2 is + function status (param : extended) return LA14016_0.status_code is + begin + return param.status; + end status; + end LA14016_2; + + --------------------------------------------------------- + + with LA14016_0; + with LA14016_1; + with LA14016_2; + pragma Elaborate (LA14016_1); + package LA14016_3 is new LA14016_1 (LA14016_2.extended, + LA14016_0.status_code); + + --------------------------------------------------------- + + with LA14016_3; + package LA14016_4 is + + procedure gen_caller (p1 : in out LA14016_3.new_t); + + generic + new_max : integer; + procedure gen_def (param : in out LA14016_3.new_t); + + end LA14016_4; + + --------------------------------------------------------- + + package body LA14016_4 is + procedure gen_def (param : in out LA14016_3.new_t) is separate; + procedure gen_caller (p1 : in out LA14016_3.new_t) is separate; + end LA14016_4; + + --------------------------------------------------------- + + separate (LA14016_4) + procedure gen_def (param : in out LA14016_3.new_t) is + begin + param.status := LA14016_3.default_status; --originally 0 + --later change to 5 + param.count := param.status; + LA14016_3.inc (param); + end gen_def; + + --------------------------------------------------------- + + separate (LA14016_4) + procedure gen_caller (p1 : in out LA14016_3.new_t) is + procedure default is new gen_def (101); + begin + default (p1); + end gen_caller; + + --------------------------------------------------------- + + with Report; use Report; + with LA14016_3; + with LA14016_4; + with LA14016_2; + + procedure LA140162 is + E : LA14016_3.new_t; --status defaults to 10 + begin + Test ("LA14016","Check that a compilation unit may not depend " & + "semantically on two different versions of the " & + "same compilation unit. Check the case where a " & + "separate procedure depends on a withed generic " & + "package that is changed"); + + LA14016_4.gen_caller (E); + + if E.status = 0 then + Failed ("Old generic used"); + elsif E.status = 10 then + Failed ("Status not updated"); + elsif E.status /= 5 then + Failed ("Wrong status value used"); + end if; + + if E.count /= 6 then + Failed ("Count not properly handled"); + end if; + + Result; + end LA140162; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140163.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140163.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140163.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140163.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,67 ---- + -- LA140163.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140162.AM. + -- + -- TEST DESCRIPTION: + -- See LA140162.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140162.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140160.A + -- LA140161.A + -- LA140162.AM + -- -> LA140163.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140162.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008L baseline version + -- 16 JUN 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified unit names and prologue to conform + -- to coding conventions and to reflect new + -- test file organization. + -- + --! + + with LA14016_0; + generic + type T is new LA14016_0.tagged_type with private; + type count_type is range <>; + package LA14016_1 is + default_status : constant LA14016_0.status_code := 5; + type new_t is new T with + record + count : count_type; + end record; + function status (param : new_t) return LA14016_0.status_code; + + procedure inc (param : in out new_t); + end LA14016_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140170.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140170.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140170.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140170.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140170.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140172.AM. + -- + -- TEST DESCRIPTION: + -- See LA140172.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140172.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140170.A + -- LA140171.A + -- LA140172.AM + -- LA140173.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140172.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA14017_0 is + type swap_type_ptr is record + p_all : integer; + end record; + subtype count_type is integer; + end LA14017_0; + + ----------------------------------------------------- + + with LA14017_0; + use LA14017_0; + generic + type swap_type is private; + function LA14017_1 (P1, P2 : swap_type_ptr; + count : count_type) return count_type; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140171.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140171.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140171.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140171.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- LA140171.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140172.AM. + -- + -- TEST DESCRIPTION: + -- See LA140172.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140172.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140170.A + -- -> LA140171.A + -- LA140172.AM + -- LA140173.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140172.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + function LA14017_1 (P1, P2 : swap_type_ptr; + count : count_type) return count_type is + temp : integer := 0; + count_factor : count_type := 10; + + function Inc (Param : integer) return integer; + + function Inc (Param : integer) return integer is separate; + + procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is + temp : integer := 0; + begin + temp := P1.p_all; + P1.p_all := P2.p_all; + P2.p_all := temp; + end Swap_Ptrs; + + begin + return count_type (Inc (integer(count))); + end LA14017_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140172.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140172.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140172.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140172.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,121 ---- + -- LA140172.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a separate function semantically + -- depends on a library level generic function that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic function, and a procedure that + -- withs the function. Then, a new version of the generic + -- function body is compiled (in a separate file, simulating + -- and editing modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed function and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140170 (and include the results in the + -- program library). + -- 2) Compile the file LA140171 (and include the results in the + -- program library). + -- 3) Compile the file LA140172 (and include the results in the + -- program library). + -- 4) Compile the file LA140173 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140170.A + -- LA140171.A + -- -> LA140172.AM + -- LA140173.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14017_1.Inc is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008M baseline version + -- 16 JUN 95 SAIC Initial version + -- 03 MAR 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved LA14017_1 to a separate file. + -- + --! + + separate (LA14017_1) -- This dependency must be resolved + -- after LA140171.A is compiled. + + function Inc (Param : integer) return integer is + begin + return Param + integer (count_factor); + end Inc; + + ----------------------------------------------------- + + + with Report; use Report; + with LA14017_1; + with LA14017_0; + + procedure LA140172 is + type Access_integer is access integer; + TC_local : integer := 0; + P1, P2 : LA14017_0.swap_type_ptr; + + function New_swap is new LA14017_1(swap_type => integer); + begin + Test ("LA14017", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a separate " & + "function semantically depends on a " & + "library level generic function that is " & + "changed"); + + P1.p_all := 0; + P2 := P1; + TC_local := integer (New_swap(P1,P2,0)); + + if TC_local = 10 then + Failed ("Revised library level function not used"); + elsif TC_local /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140172; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140173.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140173.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140173.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140173.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + -- LA140173.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140172.AM. + -- + -- TEST DESCRIPTION: + -- See LA140172.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140172.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140170.A + -- LA140171.A + -- LA140172.AM + -- -> LA140173.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140172.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008M baseline version + -- 16 JUN 95 SAIC Initial version + -- 03 MAR 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + function LA14017_1 (P1, P2 : swap_type_ptr; + count : count_type) return count_type is + count_factor : count_type := -10; + + procedure Swap_Ptrs (P1, P2 : in out swap_type_ptr) is + temp : integer := 0; + begin + temp := P1.p_all; + P1.p_all := P2.p_all; + P2.p_all := temp; + end Swap_Ptrs; + + function Inc (Param : integer) return integer; + + function Inc (Param : integer) return integer is separate; + + temp : integer := 0; + begin + return count_type (Inc (integer(count))); + end LA14017_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140180.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140180.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140180.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140180.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,65 ---- + -- LA140180.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140182.AM. + -- + -- TEST DESCRIPTION: + -- See LA140182.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140182.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140180.A + -- LA140181.A + -- LA140182.AM + -- LA140183.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140182.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + generic + type unsigned is mod <>; + mod_value : unsigned := 1; + package LA14018_0 is + --types declared locally + + generic + type discrete is (<>); + package utils_18 is + procedure Dec (Param : in out unsigned); + + -- other utilities + end utils_18; + + --routines that make this generic useful + end LA14018_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140181.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140181.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140181.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140181.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + -- LA140181.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140182.AM. + -- + -- TEST DESCRIPTION: + -- See LA140182.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140182.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140180.A + -- -> LA140181.A + -- LA140182.AM + -- LA140183.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140182.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package body LA14018_0 is + offset : constant unsigned := mod_value; + + package body utils_18 is separate; + end LA14018_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140182.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140182.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140182.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140182.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,118 ---- + -- LA140182.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a separate generic package body depends + -- on a library level generic package body that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package and its body, and a + -- procedure that withs the generic package. Then a new + -- version of the generic package body is compiled (in a + -- separate file, simulating and editing modification to the + -- unit). Unless automatic recompilation is supported, this + -- test should fail to link. Otherwise, the test should + -- recompile and link the correct version of the with package + -- withed package and report "PASSED" at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140180 (and include the results in the + -- program library). + -- 2) Compile the file LA140181 (and include the results in the + -- program library). + -- 3) Compile the file LA140182 (and include the results in the + -- program library). + -- 4) Compile the file LA140183 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140180.A + -- LA140181.A + -- -> LA140182.AM + -- LA140183.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14018_0.utils_18 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008N baseline version + -- 16 JUN 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. Moved instantiation + -- of utils_18 to avoid potential Program_Error. + -- Moved LA14018_0 to a separate file. + -- + --! + + separate (LA14018_0) -- This dependency must be resolved + -- after LA140181.A is compiled. + package body utils_18 is + procedure Dec (Param : in out unsigned) is + begin + Param := Param - offset; + end Dec; + end utils_18; + + -------------------------------------------------------- + + with Report; use Report; + with LA14018_0; + procedure LA140182 is + type mod_4 is mod 4; -- 0, 1, 2, 3, 0, 1,... + TC_var : mod_4 := 2; + + package Mod_stuff is new LA14018_0 (mod_4); + package unsigned_utils is new Mod_stuff.utils_18 (mod_4); + begin + Test ("LA14018", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. "& + "Check the case where a separate package " & + "body depends on a library level generic " & + "package body that is changed"); + + unsigned_utils.Dec (TC_var); + + if TC_var = 2 then + Failed ("Dec routine did not work"); + elsif TC_var = 1 then + Failed ("New body for LA14018_0 not used"); + elsif TC_var /= 3 then + Failed ("Unexpected result produced"); + end if; + + Result; + end LA140182; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140183.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140183.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140183.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140183.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + -- LA140183.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140182.AM. + -- + -- TEST DESCRIPTION: + -- See LA140182.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140182.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140180.A + -- LA140181.A + -- LA140182.AM + -- -> LA140183.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140182.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008N baseline version + -- 16 JUN 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified unit names and prologue to conform + -- to coding conventions, and to reflect new test + -- file organization. + -- + --! + + package body LA14018_0 is + New_TC_var : integer := 101; + New_array : array (1..101) of integer := (others => 0); + offset : constant unsigned := mod_value + 2; + + package body utils_18 is separate; + end LA14018_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140190.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140190.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140190.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140190.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- LA140190.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140192.AM. + -- + -- TEST DESCRIPTION: + -- See LA140192.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140192.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140190.A + -- LA140191.A + -- LA140192.AM + -- LA140193.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140192.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008P baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + procedure LA14019_0 (Param : in out integer); + + + procedure LA14019_0 (Param : in out integer) is + TC_offset : constant integer := 1; + begin + Param := Param + TC_offset; + end LA14019_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140191.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140191.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140191.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140191.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- LA140191.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140192.AM. + -- + -- TEST DESCRIPTION: + -- See LA140192.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140192.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140190.A + -- -> LA140191.A + -- LA140192.AM + -- LA140193.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140192.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008P baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + generic + type integer_type is range <>; + procedure LA14019_1 (Test_val : in out integer); + + with LA14019_0; + procedure LA14019_1 (Test_val : in out integer) is + arr : array (1..5) of integer; + sum : integer := 0; + temp_val : integer := 0; + begin + arr(1) := Test_val; + for i in 2..arr'last loop + temp_val := arr(i-1); + LA14019_0 (temp_val); + arr(i) := temp_val; + end loop; + for i in 1..arr'last loop + sum := sum + arr(i); + end loop; + Test_val := sum; + end LA14019_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140192.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140192.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140192.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140192.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,107 ---- + -- LA140192.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level generic procedure + -- depends on library level procedure that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a procedure, a generic procedure that + -- withs the first procedure and a main procedure that withs + -- the generic procedure. Then, a new version of the + -- procedure is compiled (in a separate file, simulating + -- and editing modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed function and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140190 (and include the results in the + -- program library). + -- 2) Compile the file LA140191 (and include the results in the + -- program library). + -- 3) Compile the file LA140192 (and include the results in the + -- program library). + -- 4) Compile the file LA140193 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140190.A + -- LA140191.A + -- -> LA140192.AM + -- LA140193.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140192 is missing or obsolete, or that LA14019_1 is + -- missing or obsolete (optional) and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008P baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14019_1; -- This dependency must be resolved + -- after LA140193 is compiled. + + procedure LA140192 is + subtype count is integer range 0..100; + procedure Gen_proc is new LA14019_1 (count); + TC_local : count := 0; + begin + Test ("LA14019", "Check that a compilation unit may " & + "not depend semantically on two " & + "different versions of the same " & + "compilation unit. Check the case " & + "where a library level generic " & + "procedure depends on library level " & + "procedure that is changed."); + + Gen_proc (TC_local); + + if TC_local = 10 then + Failed ("Revised library level procedure not used"); + elsif TC_local /= 52 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140192; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140193.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140193.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140193.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140193.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140193.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140192.AM. + -- + -- TEST DESCRIPTION: + -- See LA140192.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140192.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140190.A + -- LA140191.A + -- LA140192.AM + -- -> LA140193.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140192.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008P baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 17 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + procedure LA14019_0 (Param : in out integer); + + + procedure LA14019_0 (Param : in out integer) is + Local_array : array (1..10) of float := (others => 0.0); + Local_var : integer := 0; + TC_var : constant integer := -9; + + begin + Param := (1 + Param) * 2; + end LA14019_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140200.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140200.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140200.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140200.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + -- LA140200.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140202.AM. + -- + -- TEST DESCRIPTION: + -- See LA140202.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140202.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140200.A + -- LA140201.A + -- LA140202.AM + -- LA140203.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140202.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008Q baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- Reworded objective. Moved instance to + -- library-level and redesigned to use generic + -- formal function. Fixed arithmetic errors. + -- + --! + + package LA14020_0 is + + subtype apples is integer range 0..100; + subtype oranges is integer range 0..200; + + type Fruit_Basket is tagged record + App : apples; + Ora : oranges; + end record; + + end LA14020_0; + + --==================================================================-- + + package LA14020_0.LA14020_1 is + + type Bigger_Basket is new Fruit_Basket with record + Total : integer; + end record; + + end LA14020_0.LA14020_1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140201.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140201.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140201.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140201.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- LA140201.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140202.AM. + -- + -- TEST DESCRIPTION: + -- See LA140202.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140202.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140200.A + -- -> LA140201.A + -- LA140202.AM + -- LA140203.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140202.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008Q baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- Reworded objective. Moved instance to + -- library-level and redesigned to use generic + -- formal function. Fixed arithmetic errors. + -- + --! + + with LA14020_0; + generic + type Basket is new LA14020_0.Fruit_Basket with private; + function LA14020_2 (Left, Right : Basket) return Basket; + + --==================================================================-- + + function LA14020_2 (Left, Right : Basket) return Basket is + Result : Basket; + begin + Result.App := Left.App + Left.App; + Result.Ora := Right.Ora + Right.Ora; + -- wrong algorithm, to be corrected later + + return Result; + end LA14020_2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140202.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140202.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140202.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140202.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,144 ---- + -- LA140202.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a library level instance depends on + -- a library level generic function whose body is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic function, an instance of a generic + -- function that withs the first function and a main procedure that + -- withs the instance. Then a new version of the first generic function + -- is compiled (in a separate file, simulating editing and modification + -- of the unit). Unless automatic recompilation is supported, this + -- test should fail to link. Otherwise, the test should recompile and + -- link the correct version of the withed function and report "PASSED" + -- at execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140200 (and include the results in the + -- program library). + -- 2) Compile the file LA140201 (and include the results in the + -- program library). + -- 3) Compile the file LA140202 (and include the results in the + -- program library). + -- 4) Compile the file LA140203 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140200.A + -- LA140201.A + -- -> LA140202.AM + -- LA140203.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140202 is missing or obsolete, or that LA14020_3 or LA14020_4 + -- is missing or obsolete (optional) and no executable image + -- results. The test passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation + -- supports automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008Q baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- Reworded objective. Moved instance to + -- library-level and redesigned to use generic + -- formal function. Fixed arithmetic errors. + -- + --! + + with LA14020_0.LA14020_1; + with LA14020_2; + pragma Elaborate (LA14020_2); + function LA14020_3 is new LA14020_2 (LA14020_0.LA14020_1.Bigger_Basket); + + --==================================================================-- + + with LA14020_0.LA14020_1; + generic + type Market_Basket is new LA14020_0.LA14020_1.Bigger_Basket with private; + with function "+" (L,R: Market_Basket) return Market_Basket is <>; + function LA14020_4 (B1, B2 : Market_Basket) return Market_Basket; + + --==================================================================-- + + with LA14020_3; + function LA14020_4 (B1, B2 : Market_Basket) return Market_Basket is + Result : Market_Basket; + begin + Result := B1 + B2; + Result.Total := integer (Result.App) + integer (Result.Ora); + return Result; + end LA14020_4; + + --==================================================================-- + + with Report; + + with LA14020_0.LA14020_1; + with LA14020_3; + with LA14020_4; + + procedure LA140202 is + package Child renames LA14020_0.LA14020_1; + + Basket_1 : Child.Bigger_Basket := (App => 5, Ora => 20, Total => 0); + Basket_2 : Child.Bigger_Basket := (App => 7, Ora => 3, Total => 0); + + function Total is new LA14020_4 (Child.Bigger_Basket, LA14020_3); + begin + Report.Test ("LA14020", "Check that a compilation unit may " & + "not depend semantically on two " & + "different versions of the same " & + "compilation unit. Check the case " & + "where a library level instance " & + "depends on a library level generic " & + "function whose body is changed"); + + Basket_1 := Total (Basket_1, Basket_2); + + if Basket_1.App = 10 or + Basket_1.Ora = 6 or + Basket_1.Total = 16 + then + Report.Failed ("Revised generic function not used"); + elsif Basket_1.App /= 12 or + Basket_1.Ora /= 23 or + Basket_1.Total /= 35 then + Report.Failed ("Incorrect result returned"); + end if; + + Report.Result; + end LA140202; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140203.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140203.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140203.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140203.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + -- LA140203.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140202.AM. + -- + -- TEST DESCRIPTION: + -- See LA140202.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140202.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140200.A + -- LA140201.A + -- LA140202.AM + -- -> LA140203.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140202.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008Q baseline version + -- 23 JUN 95 SAIC Initial version + -- 29 FEB 96 SAIC First revision after review + -- 12 DEC 96 SAIC Reorganized to permit automatic recompilation. + -- Reworded objective. Moved instance to + -- library-level and redesigned to use generic + -- formal function. Fixed arithmetic errors. + -- + --! + + with LA14020_0; + generic + type Basket is new LA14020_0.Fruit_Basket with private; + function LA14020_2 (Left, Right : Basket) return Basket; + + --==================================================================-- + + function LA14020_2 (Left, Right : Basket) return Basket is + Result : Basket; + begin + Result.App := Left.App + Right.App; + Result.Ora := Left.Ora + Right.Ora; + -- correct algorithm + + return Result; + end LA14020_2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140210.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140210.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140210.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140210.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- LA140210.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140211.AM. + -- + -- TEST DESCRIPTION: + -- See LA140211.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140211.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140210.A + -- LA140211.AM + -- LA140212.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140211.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + generic + type swap_type is private; + type int_type is range <>; + times : int_type :=1; + package LA14021_0 is + procedure swap (this, for_that : in out swap_type); + end LA14021_0; + + --------------------------------------------------------- + + package body LA14021_0 is + procedure swap (this, for_that : in out swap_type) is + temp : swap_type; + begin + for i in int_type'first..times loop + temp := this; + this := for_that; + for_that := temp; + end loop; + end swap; + end LA14021_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140211.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140211.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140211.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140211.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,134 ---- + -- LA140211.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic package depends on another + -- generic package that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package, a second generic + -- package that withs the first and a main procedure that + -- withs the second package. Then, a new version of the + -- first package is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed function and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140210 (and include the results in the + -- program library). + -- 2) Compile the file LA140211 (and include the results in the + -- program library). + -- 3) Compile the file LA140212 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140210.A + -- -> LA140211.AM + -- LA140212.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14021_1 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008R baseline version + -- 23 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved LA14021_0 to a separate file. + -- + --! + + package LA14021_1 is + type data_record is tagged + record + info : character; + end record; + subtype loop_count is integer range 1..100; + type data_type is new data_record with + record + serial : integer := 0; + end record; + end LA14021_1; + + --------------------------------------------------------- + + with LA14021_1; + with LA14021_0; + generic + type data_rec is new LA14021_1.data_record with private; + package LA14021_2 is + package util is new LA14021_0 (character, LA14021_1.loop_count); + procedure flip_flop (rec1, rec2 : in out data_rec); + end LA14021_2; + + --------------------------------------------------------- + + package body LA14021_2 is + procedure flip_flop (rec1, rec2 : in out data_rec) is + begin + util.swap (rec1.info, rec2.info); + end flip_flop; + end LA14021_2; + + --------------------------------------------------------- + + with Report; use Report; + with LA14021_1; + with LA14021_2; + + procedure LA140211 is + package util is new LA14021_2 (LA14021_1.data_type); + datum_1 : LA14021_1.data_type := LA14021_1.data_type'('a', 1); + datum_2 : LA14021_1.data_type := LA14021_1.data_type'('b', 2); + begin + Test ("LA14021", "Check that a compilation unit may " & + "not depend semantically on two " & + "different versions of the same " & + "compilation unit. Check the case " & + "where a generic package depends on " & + "another generic package that is changed"); + + util.flip_flop (datum_1, datum_2); + if datum_1.info = 'b' then + Failed ("Revised unit not used"); + elsif datum_1.info /= 'a' then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140211; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140212.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140212.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140212.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140212.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + -- LA140212.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140211.AM. + -- + -- TEST DESCRIPTION: + -- See LA140211.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140211.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140210.A + -- LA140211.AM + -- -> LA140212.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140211.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008R baseline version + -- 23 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + generic + type swap_type is private; + type int_type is range <>; + times : int_type :=2; --this line contains the change + package LA14021_0 is + procedure swap (this, for_that : in out swap_type); + end LA14021_0; + + --------------------------------------------------------- + + package body LA14021_0 is + procedure swap (this, for_that : in out swap_type) is + temp : swap_type; + begin + for i in int_type'first..times loop + temp := this; + this := for_that; + for_that := temp; + end loop; + end swap; + end LA14021_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140220.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140220.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140220.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140220.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + -- LA140220.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140221.AM. + -- + -- TEST DESCRIPTION: + -- See LA140221.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140221.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140220.A + -- LA140221.AM + -- LA140222.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140221.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + generic + type stuff is private; + type ptr is access stuff; + type return_result is range <>; + delta_val : return_result := 1; + procedure LA14022_0 (pointer : in out ptr; + result : in out return_result); + + ------------------------------------------------------- + + procedure LA14022_0 (pointer : in out ptr; + result : in out return_result) is + begin + pointer := new stuff; + result := result + delta_val; + end LA14022_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140221.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140221.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140221.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140221.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,128 ---- + -- LA140221.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic instantiation depends on + -- a generic procedure that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic procedure, a second generic + -- procedure, a generic instantiation of the second procedure + -- that depends on both the first and second generic + -- procedures, and a main procedure that withs the instantiated + -- procedure. Then, a new version of the first generic + -- procedure is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed function and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140220 (and include the results in the + -- program library). + -- 2) Compile the file LA140221 (and include the results in the + -- program library). + -- 3) Compile the file LA140222 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140220.A + -- -> LA140221.AM + -- LA140222.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14022_2 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008S baseline version + -- 23 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved LA14022_0 to a separate file. Added + -- pragma Elaborate to context clause of + -- LA14022_2. + -- + --! + + package LA14022_1 is + type rec_ptr; + type rec is record + data : integer; + end record; + type rec_ptr is access rec; + subtype data_int is integer range 0..100; + end LA14022_1; + + + with LA14022_0; + with LA14022_1; + pragma Elaborate (LA14022_0); + procedure LA14022_2 is new + LA14022_0 (stuff => LA14022_1.rec, + ptr => LA14022_1.rec_ptr, + return_result => LA14022_1.data_int, + delta_val => 50); + + with Report; + use Report; + with LA14022_2; + with LA14022_1; + use LA14022_1; + procedure LA140221 is + TC_val : LA14022_1.data_int := 10; + P, Q : LA14022_1.rec_ptr; + begin + Test ("LA14022", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic " & + "instantiation depends on a generic " & + "procedure that is changed"); + + Q := P; + LA14022_2 (Q, TC_val); + + if Q /= P then + Failed ("Wrong procedure result"); + end if; + if TC_val = 60 then + Failed ("Old instantiation used"); + elsif TC_val /= 10 then + Failed ("Wrong result"); + end if; + + Result; + end LA140221; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140222.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140222.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140222.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140222.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + -- LA140222.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140221.AM. + -- + -- TEST DESCRIPTION: + -- See LA140221.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140221.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140220.A + -- LA140221.AM + -- -> LA140222.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140221.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008S baseline version + -- 23 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + generic + type stuff is private; + type ptr is access stuff; + type return_result is range <>; + delta_val : return_result := 1; + procedure LA14022_0 (pointer : in out ptr; + result : in out return_result); + + ------------------------------------------------------- + + procedure LA14022_0 (pointer : in out ptr; + result : in out return_result) is + begin + pointer := null; + result := result + return_result'first; + end LA14022_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140240.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140240.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140240.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140240.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- LA140240.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140242.AM. + -- + -- TEST DESCRIPTION: + -- See LA140242.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140242.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140240.A + -- LA140241.A + -- LA140242.AM + -- LA140243.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140242.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008U baseline version + -- 29 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + generic + Local_max : positive; + type Thing is private; + package LA14024_0 is + type Goodies is tagged + record + X, Y : integer := 100; + end record; + end LA14024_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140241.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140241.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140241.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140241.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + -- LA140241.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140242.AM. + -- + -- TEST DESCRIPTION: + -- See LA140242.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140242.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140240.A + -- -> LA140241.A + -- LA140242.AM + -- LA140243.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140242.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008U baseline version + -- 29 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + with LA14024_0; + + package LA14024_1 is new LA14024_0 (100, integer); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140242.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140242.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140242.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140242.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,104 ---- + -- LA140242.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic instantiation depends on + -- a generic package that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package, a generic + -- instantiation of the generic package, and a main + -- procedure that withs the instantiated generic + -- package. Then, a new version of the first generic + -- package is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed package and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140240 (and include the results in the + -- program library). + -- 2) Compile the file LA140241 (and include the results in the + -- program library). + -- 3) Compile the file LA140242 (and include the results in the + -- program library). + -- 4) Compile the file LA140243 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140240.A + -- LA140241.A + -- -> LA140242.AM + -- LA140243.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140242 is missing or obsolete, or that LA14024_1 is + -- missing or obsolete (optional) and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008U baseline version + -- 29 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14024_1; + + procedure LA140242 is + TC_val : integer := 0; + Local_goodies : LA14024_1.Goodies; + begin + Test ("LA14024", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic " & + "instantiation depends on a generic " & + "package that is changed"); + + TC_val := Local_goodies.X; + + if TC_val = 100 then + Failed ("Revised generic package not used"); + elsif TC_val /= -10 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140242; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140243.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140243.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140243.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140243.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + -- LA140243.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140242.AM. + -- + -- TEST DESCRIPTION: + -- See LA140242.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140242.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140240.A + -- LA140241.A + -- LA140242.AM + -- -> LA140243.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140242.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008U baseline version + -- 29 JUN 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + generic + Local_max : positive; + type Thing is private; + package LA14024_0 is + type Goodies is tagged + record + Y, X : integer := -10; + end record; + end LA14024_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140250.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140250.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140250.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140250.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140250.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140251.AM. + -- + -- TEST DESCRIPTION: + -- See LA140251.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140251.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140050.A + -- LA140051.AM + -- LA140052.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140251.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA14025_0 is + subtype byte is integer range 0..511; + byte_val : constant byte := 128; + type Data_rec is tagged record + Id : integer := 1; + Val: byte := byte_val; + end record; + end LA14025_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140251.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140251.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140251.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140251.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + -- LA140251.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic instantiation depends on + -- a non-generic package that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a package, a generic package, a + -- generic instantiation that withs both of the first two + -- packages, and a main procedure that withs the instantiated + -- generic package. Then, a new version of the first + -- package is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the withed package and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140250 (and include the results in the + -- program library). + -- 2) Compile the file LA140251 (and include the results in the + -- program library). + -- 3) Compile the file LA140252 (and include the results in the + -- program library). + -- 4) Attempt to build an executable image. + -- 5) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140250.A + -- -> LA140251.AM + -- LA140252.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14025 is missing or obsolete, or that LA14025_2 is + -- missing or obsolete (optional) and no executable image + -- results. The test passes if an executable image is produced + -- and reports "PASSED" (in case the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008V baseline version + -- 06 JUL 95 SAIC Initial version + -- 08 NOV 96 SAIC Unit naming correction + -- 07 DEC 96 SAIC Moved LA14025_0 to a separate file. Added + -- pragma Elaborate to context clause of + -- LA14025_2. + -- + --! + + with LA14025_0; + generic + type your_addition is (<>); + package LA14025_1 is --extensions, utilities + type extended_record is new LA14025_0.data_rec with record + new_data : your_addition; + end record; + procedure stuff (param : your_addition); + function fetch (param : LA14025_0.byte) return LA14025_0.byte; + private + obj : extended_record; + end LA14025_1; + + --------------------------------------------- + + package body LA14025_1 is + procedure stuff (param : your_addition) is + begin + obj.new_data := param; + end stuff; + + function fetch (param : LA14025_0.byte) return LA14025_0.byte is + begin + return (param + obj.val); + end fetch; + end LA14025_1; + + --------------------------------------------- + + with LA14025_0; + with LA14025_1; + pragma Elaborate (LA14025_1); + package LA14025_2 is new LA14025_1 (LA14025_0.byte); + + --------------------------------------------- + + with Report; use Report; + with LA14025_2; + with LA14025_0; + procedure LA140251 is + TC_val : LA14025_0.byte := 0; + Temp_var : LA14025_2.extended_record; + begin + Test ("LA14025", "Check that a compilation unit may not " & + "depend semantically on two different " & + "versions of the same compilation unit. " & + "Check the case where a generic " & + "instantiation depends on a non-generic " & + "package that is changed"); + + LA14025_2.stuff(10); + + TC_val := LA14025_2.fetch (Temp_var.val); + + if TC_val = 256 then + Failed ("Old version of package used"); + elsif TC_val /= 128 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140251; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140252.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140252.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140252.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140252.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + -- LA140252.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140251.AM. + -- + -- TEST DESCRIPTION: + -- See LA140251.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140251.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140050.A + -- LA140051.AM + -- -> LA140052.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140251.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008V baseline version + -- 06 JUL 95 SAIC Initial version + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + package LA14025_0 is + subtype byte is integer range 0..511; + byte_val : constant byte := 64; + type Data_rec is tagged record + Id : integer := 1; + Val: byte := byte_val; + end record; + end LA14025_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140260.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140260.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140260.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140260.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,98 ---- + -- LA140260.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140262.AM. + -- + -- TEST DESCRIPTION: + -- See LA140262.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140262.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140260.A + -- LA140261.A + -- LA140262.AM + -- LA140263.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140262.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + package LA14026_0 is + type basic_rec is tagged + record + null; + end record; + end LA14026_0; + + --------------------------------------------------------- + + with LA14026_0; + generic + type data_type is private; + type serial_type is range <>; + serial_init : serial_type; + package LA14026_1 is + + pragma Elaborate_Body; + + function get_serial_num return serial_type; + + type node_type is new LA14026_0.basic_rec with + record + data_field : data_type; + serial_no : serial_type := get_serial_num; + end record; + end LA14026_1; + + --------------------------------------------------------- + + package body LA14026_1 is + serial : serial_type := serial_init; + function get_serial_num return serial_type is + begin + serial := serial + 1; + return serial; + end; + end LA14026_1; + + --------------------------------------------------------- + + package LA14026_2 is + subtype serial_type is integer range 0..5; + subtype data_type is integer range 0..100; + + type data_rec is record + F1 : data_type := data_type'first; + F2 : data_type := data_type'last; + end record; + end LA14026_2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140261.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140261.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140261.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140261.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,52 ---- + -- LA140261.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140262.AM. + -- + -- TEST DESCRIPTION: + -- See LA140262.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140262.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140260.A + -- -> LA140261.A + -- LA140262.AM + -- LA140263.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140262.AM. + -- + -- CHANGE HISTORY: + -- 07 DEC 96 SAIC ACVC 2.1: Initial version. + -- + --! + + with LA14026_2, LA14026_1; + package LA14026_3 is new LA14026_1 (LA14026_2.data_rec, + LA14026_2.serial_type, 0); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140262.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140262.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140262.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140262.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,140 ---- + -- LA140262.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a generic instantiation depends on + -- a generic package instantiation that is changed. + -- + -- TEST DESCRIPTION: + -- This test compiles a generic package, a generic + -- instantiation of the generic package, another generic + -- package, a generic instantiation of the second generic + -- package that withs the first generic instantiation + -- packages, and a main procedure that withs the instantiated + -- generic package. Then, a new version of the first generic + -- package is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the instantiation and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140260 (and include the results in the + -- program library). + -- 2) Compile the file LA140261 (and include the results in the + -- program library). + -- 3) Compile the file LA140262 (and include the results in the + -- program library). + -- 4) Compile the file LA140263 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140260.A + -- LA140261.A + -- -> LA140262.AM + -- LA140263.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA140260 is missing or obsolete, or that LA14026_5 is + -- missing or obsolete (optional) and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008W baseline version + -- 06 JUL 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Moved LA14026_3 to a separate file. Added + -- pragma Elaborate to context clause of LA14026_5. + -- + --! + + with LA14026_0; + generic + type rec is new LA14026_0.basic_rec with private; + package LA14026_4 is + type extended_node; + type extended_node_ptr is access extended_node; + type extended_node is new rec with + record + next : extended_node_ptr := null; + end record; + procedure add_next (node : in out extended_node; ptr : extended_node_ptr); + end LA14026_4; + + --------------------------------------------------------- + + package body LA14026_4 is + procedure add_next (node : in out extended_node; + ptr : extended_node_ptr) is + begin + node.next := ptr; + end add_next; + end LA14026_4; + + --------------------------------------------------------- + + with LA14026_3, LA14026_4; + pragma Elaborate (LA14026_4); + package LA14026_5 is new LA14026_4 (LA14026_3.node_type); + + --------------------------------------------------------- + + with Report; + use Report; + with LA14026_5; + + procedure LA140262 is + root : LA14026_5.extended_node_ptr := new LA14026_5.extended_node; + next : LA14026_5.extended_node_ptr := new LA14026_5.extended_node; + begin + Test ("LA14026","Check that a compilation unit may not depend " & + "semantically on two different versions of " & + "the same compilation unit. Check the case " & + "where a generic instantiation depends on " & + "a generic package instantiation that is " & + "changed"); + + + LA14026_5.add_next (root.all, next); + + if root.all.next.serial_no = 2 then + Failed ("Old version of unit used"); + elsif root.all.next.serial_no /= 5 then + Failed ("Wrong value returned"); + end if; + + Result; + end LA140262; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140263.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140263.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140263.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140263.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + -- LA140263.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140262.AM. + -- + -- TEST DESCRIPTION: + -- See LA140262.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140262.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140260.A + -- LA140261.A + -- LA140262.AM + -- -> LA140263.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140262.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5008W baseline version + -- 06 JUL 95 SAIC Initial version + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- 07 DEC 96 SAIC Modified prologue to reflect new test + -- file organization. + -- + --! + + with LA14026_2, LA14026_1; + package LA14026_3 is new LA14026_1 (LA14026_2.data_rec, + LA14026_2.serial_type, 3); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140270.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140270.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140270.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140270.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + -- LA140270.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140272.AM. + -- + -- TEST DESCRIPTION: + -- See LA140272.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140272.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- -> LA140270.A + -- LA140271.A + -- LA140272.AM + -- LA140273.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140272.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007O baseline version + -- 28 JUL 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14027_0 is + Sample_value : integer := 100; + end LA14027_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140271.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140271.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140271.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140271.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,93 ---- + -- LA140271.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140272.AM. + -- + -- TEST DESCRIPTION: + -- See LA140272.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140272.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140270.A + -- -> LA140271.A + -- LA140272.AM + -- LA140273.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140272.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007O baseline version + -- 28 JUL 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. Removed loop from + -- task body to prevent hang. + -- + --! + + package LA14027_1 is + procedure Random (Number : out integer); + end LA14027_1; + + -------------------------------------------- + + package body LA14027_1 is + task LA14027_2 is + entry Get (Value : out integer); + end LA14027_2; + + task body LA14027_2 is separate; + + procedure Random (Number : out integer) is + begin + -- get a random number from sampling task + LA14027_2.Get (Number); + -- massage it + Number := Number + 10; + -- and return it + end; + end LA14027_1; + + -------------------------------------------- + + with LA14027_0; -- must resolve this + + separate (LA14027_1) + + task body LA14027_2 is + begin + select + accept Get (Value : out integer) do + -- sample some random physical process + Value := LA14027_0.Sample_value; + -- and return it + end Get; + end select; + end LA14027_2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140272.am gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140272.am *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140272.am 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140272.am 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,102 ---- + -- LA140272.AM + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- Check that a compilation unit may not depend semantically + -- on two different versions of the same compilation unit. + -- Check the case where a task body depends on non-generic + -- package specification. + -- + -- TEST DESCRIPTION: + -- This test compiles a package spec, another package + -- with a body containing a task with a body that withs the + -- first package spec, and a main procedure that withs the + -- second package. Then, a new version of the first package + -- spec is compiled (in a separate file, simulating + -- editing and modification to the unit). Unless automatic + -- recompilation is supported, this test should fail to link. + -- Otherwise, the test should recompile and link the correct + -- version of the package spec and report "PASSED" at + -- execution time. + -- + -- SPECIAL REQUIREMENTS: + -- To build this test: + -- 1) Compile the file LA140270 (and include the results in the + -- program library). + -- 2) Compile the file LA140271 (and include the results in the + -- program library). + -- 3) Compile the file LA140272 (and include the results in the + -- program library). + -- 4) Compile the file LA140273 (and include the results in the + -- program library). + -- 5) Attempt to build an executable image. + -- 6) If an executable image results, run it. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140270.A + -- LA140271.A + -- -> LA140272.AM + -- LA140273.A + -- + -- PASS/FAIL CRITERIA: + -- The test passes if a link time error message reports that + -- LA14027_1.LA14027_2 is missing or obsolete and no executable image + -- results. The test also passes if an executable image is produced + -- and reports "PASSED" (in the case where the implementation supports + -- automatic recompilation). + -- + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007O baseline version + -- 28 JUL 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified unit names and prologue to conform + -- to coding conventions. + -- + --! + + with Report; use Report; + with LA14027_1; + + procedure LA140272 is + TC_val : integer := 0; + begin + Test ("LA14027", "Check that a compilation unit may not depend " & + "semantically on two different versions of the " & + "same compilation unit. Check the case where " & + "a task body depends on non-generic package " & + "specification"); + + LA14027_1.Random (TC_val); + + if TC_val = 110 then + Failed ("Old version used"); + elsif TC_val /= 0 then + Failed ("Incorrect value returned"); + end if; + + Result; + end LA140272; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140273.a gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140273.a *** gcc-3.3.3/gcc/testsuite/ada/acats/tests/l/la140273.a 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ada/acats/tests/l/la140273.a 2003-10-27 11:29:00.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + -- LA140273.A + -- + -- Grant of Unlimited Rights + -- + -- Under contracts F33600-87-D-0337, F33600-84-D-0280, MDA903-79-C-0687, + -- F08630-91-C-0015, and DCA100-97-D-0025, the U.S. Government obtained + -- unlimited rights in the software and documentation contained herein. + -- Unlimited rights are defined in DFAR 252.227-7013(a)(19). By making + -- this public release, the Government intends to confer upon all + -- recipients unlimited rights equal to those held by the Government. + -- These rights include rights to use, duplicate, release or disclose the + -- released technical data and computer software in whole or in part, in + -- any manner and for any purpose whatsoever, and to have or permit others + -- to do so. + -- + -- DISCLAIMER + -- + -- ALL MATERIALS OR INFORMATION HEREIN RELEASED, MADE AVAILABLE OR + -- DISCLOSED ARE AS IS. THE GOVERNMENT MAKES NO EXPRESS OR IMPLIED + -- WARRANTY AS TO ANY MATTER WHATSOEVER, INCLUDING THE CONDITIONS OF THE + -- SOFTWARE, DOCUMENTATION OR OTHER INFORMATION RELEASED, MADE AVAILABLE + -- OR DISCLOSED, OR THE OWNERSHIP, MERCHANTABILITY, OR FITNESS FOR A + -- PARTICULAR PURPOSE OF SAID MATERIAL. + --* + -- + -- OBJECTIVE: + -- See LA140272.AM. + -- + -- TEST DESCRIPTION: + -- See LA140272.AM. + -- + -- SPECIAL REQUIREMENTS: + -- See LA140272.AM. + -- + -- TEST FILES: + -- This test consists of the following files: + -- LA140270.A + -- LA140271.A + -- LA140272.AM + -- -> LA140273.A + -- + -- PASS/FAIL CRITERIA: + -- See LA140272.AM. + -- + -- CHANGE HISTORY: + -- 01 MAY 95 ACVC 1.12 LA5007O baseline version + -- 28 JUL 95 SAIC Initial version + -- 29 JAN 96 SAIC First revision after review + -- 18 NOV 96 SAIC Modified prologue to conform + -- to coding conventions. + -- + --! + + package LA14027_0 is + New_var : integer := 100; + Local_array : array (1..51) of integer; + Sample_value : constant integer := -10; + end LA14027_0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/ChangeLog gcc-3.4.0/gcc/testsuite/ChangeLog *** gcc-3.3.3/gcc/testsuite/ChangeLog 2004-02-14 20:19:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/ChangeLog 2004-04-19 01:58:58.000000000 +0000 *************** *** 1,73 **** ! 2004-02-14 Release Manager ! * GCC 3.3.3 Released. ! 2004-02-05 Giovanni Bajo PR c++/13086 * g++.dg/warn/incomplete1.C: Remove xfail. ! 2004-02-03 Zack Weinberg * g++.dg/eh/forced1.C, g++.dg/eh/forced2.C, g++.dg/eh/forced3.C * g++.dg/eh/forced4.C: XFAIL ia64-hp-hpux11.*. * g++.dg/eh/ia64-1.C: Test branch regs only #ifdef __LP64__. * gcc.dg/cleanup-5.c: Run only on Linux targets. 2004-01-30 Giovanni Bajo PR c++/13683 * g++.dg/template/sizeof6.C: New test. 2004-01-25 Kriang Lerdsuwanakij PR c++/13797 * g++.dg/template/nontype4.C: New test. * g++.dg/template/nontype5.C: Likewise. ! PR c++/10555, c++/10576 ! * g++.dg/template/memclass1.C: New test. 2004-01-11 Jakub Jelinek PR middle-end/13392 * g++.dg/opt/expect2.C: New test. ! 2004-01-02 Matthias Klose ! Backport from mainline: ! 2003-12-28 Mark Mitchell ! PR c++/13081 ! * g++.dg/opt/inline6.C: New test. 2004-01-01 Jakub Jelinek PR optimization/13521 * gcc.c-torture/compile/20031231-1.c: New test. ! 2003-12-31 Roger Sayle PR fortran/12632 * g77.dg/12632.f: New test case. ! 2003-12-29 Nathan Sidwell ! PR c++/13445 ! * g++.dg/template/scope2.C: New test. 2003-12-28 Roger Sayle PR c++/13070 * g++.dg/warn/format3.C: New test case. ! 2003-12-27 Giovanni Bajo ! Backport from mainline: ! 2003-11-14 Giovanni Bajo ! PR c++/2294 ! * g++.dg/lookup/using9.C: New test. 2003-12-23 Eric Botcazou --- 1,1433 ---- ! 2004-04-18 Release Manager ! * GCC 3.4.0 released. ! 2004-04-18 John David Anglin ! ! * gcc.dg/funcorder.c: xfail hppa*64*-*-*. ! ! 2004-04-17 John David Anglin ! ! * gcc.dg/const-elim-1.c: XFAIL hppa-*-*. ! ! 2004-04-14 Zack Weinberg ! ! * gcc.dg/const-elim-1.c: XFAIL hppa*.*-*-* (PA32). Merge further ! XFAILs from mainline: strongarm-*-*, xscale-*-*, powerpc*-*-aix*. ! Update commentary. ! ! 2004-04-12 Kaveh R. Ghazi ! ! * gcc.dg/compat/struct-by-value-5a_main.c, ! gcc.dg/compat/struct-by-value-5b_main.c: New files. ! * gcc.dg/compat/struct-by-value-5_main.c: Delete. ! * gcc.dg/compat/struct-by-value-5a_x.c, ! gcc.dg/compat/struct-by-value-5b_x.c: New, split out from ! gcc.dg/compat/struct-by-value-5_x.c. ! * gcc.dg/compat/struct-by-value-5a_y.c, ! gcc.dg/compat/struct-by-value-5b_y.c: New, split out from ! gcc.dg/compat/struct-by-value-5_y.c. ! ! * gcc.dg/compat/struct-by-value-6a_main.c, ! gcc.dg/compat/struct-by-value-6b_main.c: New files. ! * gcc.dg/compat/struct-by-value-6_main.c: Delete. ! * gcc.dg/compat/struct-by-value-6a_x.c, ! gcc.dg/compat/struct-by-value-6b_x.c: New, split out from ! gcc.dg/compat/struct-by-value-6_x.c. ! * gcc.dg/compat/struct-by-value-6a_y.c, ! gcc.dg/compat/struct-by-value-6b_y.c: New, split out from ! gcc.dg/compat/struct-by-value-6_y.c. ! ! * gcc.dg/compat/struct-by-value-7a_main.c, ! gcc.dg/compat/struct-by-value-7b_main.c: New files. ! * gcc.dg/compat/struct-by-value-7_main.c: Delete. ! * gcc.dg/compat/struct-by-value-7a_x.c, ! gcc.dg/compat/struct-by-value-7b_x.c: New, split out from ! gcc.dg/compat/struct-by-value-7_x.c. ! * gcc.dg/compat/struct-by-value-7a_y.c, ! gcc.dg/compat/struct-by-value-7b_y.c: New, split out from ! gcc.dg/compat/struct-by-value-7_y.c. ! ! 2004-04-05 Paul Brook ! ! PR 2123 ! * g++.dg/expr/anew1.C: XFAIL and make reproducible. Call abort on ! failure and exit(0) on success. ! * g++.dg/expr/anew2.C: Ditto. ! * g++.dg/expr/anew3.C: Ditto. ! * g++.dg/expr/anew4.C: Ditto. ! ! 2004-04-09 Zack Weinberg ! ! * lib/target-supports.exp (check_named_sections_available): New. ! * lib/gcc-dg.exp (dg-require-named-sections): New. ! * lib/prune.exp (prune_gcc_output): Incorporate prunes from ! old-deja.exp. Also prune error-count message from HP linker. ! * g++.old-deja/old-deja.exp (g++-dg-prune): Delete. ! ! * g++.dg/init/init-ref4.C: Use dg-require-weak. ! * g++.old-deja/g++.pt/static3.C: Likewise. ! * g++.dg/parse/attr-ctor1.C: Use dg-require-named-sections. ! ! 2004-04-09 Andreas Schwab ! ! * lib/prune.exp (prune_gcc_output): Ignore errata warning from ! IA64 assembler. ! ! 2004-04-05 Eric Botcazou ! ! Backport from mainline: ! ! 2004-03-26 James A. Morrison ! ! * gcc.dg/20001013-1.c: Run on 32-bit and 64-bit SPARC. ! * gcc.dg/20001101-1.c: Likewise. ! * gcc.dg/20001102-1.c: Likewise. ! ! 2004-03-22 Eric Botcazou ! ! * gcc.dg/ultrasp2.c: Do not pass -m64. Remove redundant lines. ! * gcc.dg/ultrasp4.c: Likewise. ! * gcc.dg/ultrasp8.c: Do not pass -m64. Add sparcv9-*-*. ! ! 2004-04-02 Jakub Jelinek ! ! PR optimization/13424, optimization/12419 ! * gcc.dg/20040302-1.c: New test. ! * gcc.c-torture/execute/20040401-1.c: New test. ! ! 2004-04-01 Mark Mitchell ! ! PR c++/14803 ! * g++.dg/inherit/ptrmem1.C: New test. ! ! 2004-04-01 Jakub Jelinek ! ! PR c++/14755 ! * gcc.c-torture/execute/20040331-1.c: New test. ! * gcc.dg/20040331-1.c: New test. ! ! 2004-03-30 Mark Mitchell ! ! PR c++/14724 ! * g++.dg/init/goto1.C: New test. ! ! PR c++/14763 ! * g++.dg/template/defarg4.C: New test. ! ! 2004-03-23 Roger Sayle ! ! PR optimization/14669 ! * g++.dg/opt/fold2.C: New test case. ! ! 2004-03-22 Mark Mitchell ! ! PR c/13129 ! * gcc.dg/Wshadow-2.c: New test. ! ! 2004-03-22 Jakub Jelinek ! ! PR c/14069 ! * gcc.dg/20040322-1.c: New test. ! ! 2004-03-21 Roger Sayle ! ! PR target/13889 ! * gcc.c-torture/compile/pr13889.c: New test case. ! ! 2004-03-21 Mark Mitchell ! ! PR c++/14616 ! * g++.dg/init/array13.C: New test. ! ! 2004-03-20 Joseph S. Myers ! ! PR c/14635 ! * builtins-1.c (nan, nans): Don't test. ! * builtins-30.c: Don't use nan, nanf, nanl. ! * builtins-35.c: New test. ! ! 2004-03-19 Mark Mitchell ! ! * g++.dg/init/placement3.C: New test. ! ! * g++.dg/template/spec13.C: New test. ! ! * g++.dg/lookup/using11.C: New test. ! ! * g++.dg/lookup/koenig3.C: New test. ! ! * g++.dg/template/operator2.C: New test. ! ! * g++.dg/expr/dtor3.C: New test. ! * g++.old-deja/g++.brendan/crash15.C: Remove incorrect dg-error ! marker. ! * g++.old-deja/g++.law/visibility28.C: Likewise. ! ! 2004-03-19 Giovanni Bajo ! ! PR c++/14545 ! * g++.dg/parse/template15.C: New test. ! ! 2004-03-18 Mark Mitchell ! ! * g++.dg/expr/dtor2.C: New test. ! ! * g++.dg/lookup/anon4.C: New test. ! ! * g++.dg/overload/using1.C: New test. ! ! * g++.dg/template/lookup7.C: New test. ! ! * g++.dg/template/typename6.C: New test. ! ! * g++.dg/expr/cond6.C: New test. ! ! * g++.dg/expr/cond5.C: New test. ! * g++.dg/expr/constcast1.C: Likewise. ! * g++.dg/expr/ptrmem2.C: Likewise. ! * g++.dg/expr/ptrmem3.C: Likewise. ! * g++.dg/lookup/main1.C: Likewise. ! * g++.dg/template/lookup6.C: Likewise. ! ! * gcc.dg/local1.c: New test. ! ! * gcc.dg/debug/dwarf2/c99-typedef1.c: New test. ! ! 2004-03-16 Mark Mitchell ! ! PR c++/14481 ! * g++.dg/warn/Wunused-7.C: New test. ! ! PR c++/14586 ! * g++.dg/parse/non-dependent3.C: New test. ! ! 2004-03-13 Kazu Hirata ! ! PR other/14544 ! * gcc.c-torture/execute/20040307-1.c: Remove the 24-bit ! bit-field. ! ! 2004-03-13 Eric Botcazou ! ! * gcc.dg/decl-5.c: Remove XFAIL. ! ! 2004-03-13 Eric Botcazou ! ! * gcc.c-torture/execute/20040313-1.c: New test. ! ! 2004-03-13 Mark Mitchell ! ! PR c++/14550 ! * g++.dg/parse/template14.C: New test. ! ! 2004-03-13 Jakub Jelinek ! ! PR target/14533 ! * gcc.dg/20040311-2.c: New test. ! ! 2004-03-12 Ian Lance Taylor ! ! * gcc.dg/arm-mmx-1.c: Don't look for ldmfd if -mthumb. ! ! 2004-03-11 Mark Mitchell ! ! PR c++/14476 ! * g++.dg/lookup/enum1.C: New test. ! ! 2004-03-10 Mark Mitchell ! ! PR c++/14510 ! * g++.dg/lookup/struct2.C: New test. ! ! 2004-03-09 Nathan Sidwell ! ! PR c++/14397 ! * g++.dg/overload/ref1.C: New. ! ! 2004-03-09 Roger Sayle ! ! PR middle-end/14289 ! * gcc.dg/pr14289-1.c: New test case. ! * gcc.dg/pr14289-2.c: Likewise. ! * gcc.dg/pr14289-3.c: Likewise. ! ! 2004-03-09 Giovanni Bajo ! ! PR c++/14409 ! * g++.dg/template/spec12.C: New test. ! ! PR c++/14448 ! * g++.dg/parse/crash14.C: New test. ! ! 2004-03-09 Mark Mitchell ! ! PR c++/14230 ! * g++.dg/init/ref11.C: New test. ! ! PR c++/14432 ! * g++.dg/parse/builtin2.C: New test. ! ! 2004-03-08 Mark Mitchell ! ! PR c++/14401 ! * g++.dg/init/ctor3.C: New test. ! * g++.dg/init/union1.C: New test. ! * g++.dg/ext/anon-struct4.C: New test. ! ! 2004-03-08 Roger Sayle ! ! * gcc.c-torture/execute/20040307-1.c: New test case. ! ! 2004-03-08 Eric Botcazou ! ! * gcc.c-torture/execute/20040308-1.c: New test. ! ! 2004-03-07 Richard Sandiford ! ! * gcc.dg/torture/mips-sdata-1.c: Restrict to mips*-*-elf*. ! ! 2004-03-06 Ulrich Weigand ! ! * gcc.dg/20040306-1.c: New test. ! ! 2004-03-06 Eric Botcazou ! ! * gcc.dg/decl-5.c: XFAIL. ! ! 2004-03-06 Eric Botcazou ! ! PR c/14465 ! * gcc.dg/decl-6.c: New test. ! ! 2004-03-06 Eric Botcazou ! ! * gcc.dg/i386-sse-8.c: New test. ! ! 2004-03-06 Eric Botcazou ! ! * gcc.dg/decl-5.c: New test. ! ! 2004-03-05 Roger Sayle ! ! PR middle-end/14203 ! * g++.dg/warn/Wunused-6.C: New test case. ! ! 2004-03-05 Andreas Krebbel ! ! * gcc.dg/20040305-1.c: New test. ! ! 2004-03-03 Zack Weinberg ! ! PR 13728 ! * gcc.dg/decl-4.c: New testcase. ! ! 2004-03-03 Kaveh R. Ghazi ! ! * gcc.dg/builtins-config.h: Use underscore macro style for __sun ! system type. Add check for irix6 which doesn't have c99 runtime. ! ! 2004-03-03 Bob Wilson ! ! * gcc.dg/const-elim-1.c: xfail for xtensa. ! ! 2004-03-01 Mark Mitchell ! ! PR c++/14369 ! * g++.dg/template/cond4.C: New test. ! ! PR c++/14360 ! * g++.old-deja/g++.ns/koenig5.C: Remove some error markers. ! ! PR c++/14361 ! * g++.dg/parse/defarg7.C: New test. ! ! PR c++/14359 ! * g++.dg/template/friend26.C: New test. ! ! PR c++/14324 ! * g++.dg/abi/mangle21.C: New test. ! ! PR c++/14260 ! * g++.dg/parse/constructor2.C: New test. ! ! PR c++/14337 ! * g++.dg/template/sfinae1.C: New test. ! ! 2004-02-29 Mark Mitchell ! ! PR middle-end/13448 ! * gcc.dg/inline-5.c: New test. ! * gcc.dg/always-inline.c: Split out tests into ... ! * gcc.dg/always-inline2.c: ... this and ... ! * gcc.dg/always-inline3.c: ... this. ! ! PR debug/12103 ! * g++.dg/debug/crash1.C: New test. ! ! 2004-02-27 Giovanni Bajo ! ! PR c++/14284 ! * g++.dg/template/ttp8.C: New test. ! ! 2004-02-26 Mark Mitchell ! ! PR c++/14278 ! * g++.dg/parse/comma1.C: New test. ! ! 2004-02-26 John David Anglin ! ! * gcc.dg/builtins-config.h: Use #elif. ! ! 2004-02-26 Michael Matz ! ! * gcc.dg/20000724-1.c: Add regparm attribute to decl and def. ! * gcc.dg/991214-1.c: Likewise. ! * gcc.dg/i386-asm-1.c: Likewise. ! ! 2004-02-26 Giovanni Bajo ! ! PR c++/14246 ! * g++.dg/other/crash-3.C: New test. ! ! 2004-02-25 John David Anglin ! ! * g++.dg/opt/inline4.C (dg-final): Robustify regexp. ! * g++.dg/opt/inline6.C (dg-final): Robustify regexp. ! ! * gcc.dg/builtins-config.h (HAVE_C99_RUNTIME): Don't define for PA ! HP-UX. ! ! 2004-02-25 Eric Botcazou ! ! * g++.dg/eh/simd-1.C: Tweak again for SPARC. ! * g++.dg/eh/simd-2.C: Likewise. ! ! 2004-02-24 Michael Matz ! ! * gcc.dg/i386-regparm.c: New test. ! ! 2004-02-23 Kriang Lerdsuwanakij ! ! PR c++/14106 ! * g++.dg/ext/typeof9.C: New test. ! ! 2004-02-23 Giovanni Bajo ! ! PR c++/14250 ! * g++.dg/other/switch1.C: New test. ! ! 2004-02-23 Eric Botcazou ! ! * gcc.dg/cast-function-1.c: Adjust for new informative message. ! * gcc.dg/va-arg-1.c: Likewise. ! ! 2004-02-22 Hans-Peter Nilsson ! ! PR target/14209 ! * gcc.c-torture/execute/20040218-1.c: New test. ! ! 2004-02-20 Kaveh R. Ghazi ! ! * lib/target-supports.exp (check_alias_available): Don't mangle ! function `g' in test program. ! ! 2004-02-20 Kaveh R. Ghazi ! ! * lib/target-supports.exp (check_profiling_available): Check ! argument to determine whether we support a profiling type. ! * lib/gcc-dg.exp (dg-require-profiling): Pass argument to ! check_profiling_available. ! * g++.dg/bprob/bprob.exp: Likewise ! * g77.dg/bprob/bprob.exp: Likewise. ! * gcc.misc-tests/bprob.exp: Likewise. ! * g++.old-deja/g++.law/profile1.C: Pass profiling type to ! dg-require-profiling and delete expected error handling. ! * gcc.dg/20021014-1.c: Likewise. ! * gcc.dg/nest.c: Likewise. ! ! 2004-02-20 Falk Hueffner ! ! PR target/14201 ! * gcc.c-torture/compile/fix-trunc-mem-1.c: New test. ! ! 2004-02-20 Mark Mitchell ! ! PR c++/14173 ! * g++.dg/ext/packed5.C: New test. ! ! PR c++/14199 ! * g++.dg/warn/Wunused-5.C: New test. ! ! 2004-02-20 Josef Zlomek ! ! Backport from mainline: ! 2004-02-14 Josef Zlomek ! ! * gcc.c-torture/compile/20040214-2.c: New test. ! ! 2004-02-19 Mark Mitchell ! ! PR c++/14186 ! * g++.dg/lookup/member1.C: New test. ! ! 2004-02-19 Nathan Sidwell ! ! * g++.dg/parse/attr-ctor1.C: XFAIL on hppa. ! * g++.dg/opt/template1.C: Robustify assembler regexp ! ! 2004-02-19 Alan Modra ! ! * gcc.c-torture/compile/complex-1.c: New. ! ! 2004-02-19 Giovanni Bajo ! ! PR c++/14181 ! * g++.dg/parse/new2.C: New test. ! ! 2004-02-18 Paul Brook ! ! * gcc.c-torture/compile/libcall-1.c: New test. ! ! 2004-02-18 Paul Brook ! ! PR debug/12934 ! * gcc.dg/debug/debug-7.c: New test. ! ! 2004-02-17 Mark Mitchell ! ! PR c++/11326 ! * g++.dg/abi/structret1.C: New test. ! ! 2004-02-17 Ulrich Weigand ! ! * gcc.dg/20040217-1.c: New test. ! ! 2004-02-17 Zack Weinberg ! ! * gcc.c-torture/execute/990208-1.x: Delete. ! ! 2004-02-17 Richard Sandiford ! ! * gcc.c-torture/execute/20040208-2.x: New file. ! ! 2004-02-17 Jakub Jelinek ! ! * gcc.dg/i386-cpuid.h (bit_CMOV): Define. ! (i386_cpuid): No need to test if cpuid is available on AMD64. ! Fix assembly, so that it works onboth i386 and AMD64. ! * gcc.dg/i386-sse-6.c: Include stdio.h, stdlib.h and string.h. ! (vecInLong): Fix s[] member type to unsigned int. ! (vecInWord): Remove type. ! (mmx_tests, sse_tests, dump64_16, dump64_32, dump64_64): Remove. ! (a64, b64, c64, d64, e64): Remove. ! (main): Pass if CPU has no MMX, SSE, SSE2 or CMOV support. ! Remove unused variable. Remove initialization of removed variables. ! Don't call mmx_tests nor sse_tests. ! (reference_mmx, reference_sse): Remove. ! (check): Add return stmt. ! * gcc.dg/i386-sse-7.c: New test. ! * gcc.dg/i386-mmx-4.c: New test. ! ! 2004-02-16 Eric Botcazou ! ! * gcc.c-torture/execute/20020720-1.x: XFAIL on SPARC with -fPIC. ! ! 2004-02-15 Roger Sayle ! ! Backport from mainline: ! ! 2004-02-07 Roger Sayle ! PR middle-end/13696 ! * g++.dg/opt/fold1.C: New test case. ! ! 2004-02-09 Roger Sayle ! * gcc.c-torture/compile/20040209-1.c: New test case. ! ! 2004-02-10 Paolo Bonzini ! PR c/14092 ! * gcc.dg/pr14092-1.c: New testcase. ! ! 2004-02-15 Mark Mitchell ! ! PR c++/13971 ! * g++.dg/expr/cond4.C: New test. ! ! PR c++/14086 ! * g++.dg/lookup/crash2.C: New test. ! ! 2004-02-14 Andrew Pinski ! ! PR c++/14116 ! * g++.dg/ext/typeof8.C: New test. ! ! 2004-02-14 Richard Sandiford ! ! Backport from mainline: ! ! 2004-02-08 Richard Sandiford ! * gcc.c-torture/execute/20040208-[12].c: New tests. ! ! 2004-02-14 Eric Botcazou ! ! * gcc.c-torture/compile/20040214-1.c: New test. ! ! 2004-02-14 Kriang Lerdsuwanakij ! ! PR c++/13635 ! * g++.dg/template/spec11.C: New test. ! ! 2004-02-13 Mark Mitchell ! ! PR c++/14122 ! * g++.dg/template/array4.C: New test. ! ! PR c++/14108 ! * g++.dg/inherit/thunk2.C: New test. ! ! 2004-02-13 Giovanni Bajo ! ! PR c++/13927 ! * g++.dg/other/error8.C: New test. ! ! 2004-02-13 Mark Mitchell ! ! PR c++/14083 ! * call.c (build_conditional_expr): Call force_rvalue on the ! non-void operand in the case that one result is a throw-expression ! and the other is not. ! ! 2004-02-12 Alan Modra ! ! * gcc.dg/debug/20020327-1.c: Disable for powerpc64. ! ! 2004-02-12 Nathaniel Smith ! ! * lib/scanasm.exp (dg-scan): Quote pattern before display. ! ! 2004-02-12 Hartmut Penner ! ! * gcc.dg/ppc64-abi-3.c: New. ! ! 2004-02-12 Hartmut Penner ! ! * g++.dg/simd-2.C: xfail on ppc64-linux. ! ! 2004-02-11 Joseph S. Myers ! ! PR c/456 ! * gcc.dg/cpp/c90-if-comma-1.c, gcc.dg/cpp/c99-if-comma-1.c: New ! tests. ! ! 2004-02-10 Alan Modra ! ! * gcc.dg/cpp/assert4.c: Fix typo last change. ! ! * gcc.dg/cpp/assert4.c: Handle powerpc64. ! ! * gcc.dg/debug/20020327-1.c: xfail for powerpc64. ! ! 2004-02-08 Joseph S. Myers ! ! * gcc.dg/c90-init-1.c: Adjust expected error messages. ! ! 2004-02-08 Eric Botcazou ! ! * g++.dg/eh/simd-2.C: Adjust line numbers for SPARC. ! ! 2004-02-08 Eric Botcazou ! ! * gcc.c-torture/execute/va-arg-25.x: XFAIL only on SPARC 64-bit. ! ! 2004-02-07 Zack Weinberg ! ! Bug 13856 ! * gcc.dg/visibility-8.c: New testcase. ! ! 2004-02-07 Geoffrey Keating ! Andrew Pinski ! ! * objc.dg/call-super-2.m: Include stddef.h for size_t. ! Update line numbers for the including of stddef.h. ! ! 2004-02-07 Zack Weinberg ! ! * gcc.c-torture/execute/string-opt-15.c: Define memcmp with void * ! arguments. ! * gcc.dg/fwritable-strings-1.c: Expect the deprecation notice. ! ! 2003-02-06 Giovanni Bajo ! ! PR c++/14033 ! * g++.dg/other/crash-2.C: New test. ! ! 2004-02-06 Falk Hueffner ! ! PR target/12898 ! * gcc.c-torture/compile/20040121-1.c: New test. ! ! 2003-02-06 Giovanni Bajo ! ! PR c++/14028 ! * g++.dg/parse/angle-bracket2.C: New test. ! ! 2004-02-05 Rainer Orth ! ! PR middle-end/13750 ! Revert: ! 2004-01-15 Geoffrey Keating ! PR pch/13361 ! * testsuite/g++.dg/pch/wchar-1.C: New. ! * testsuite/g++.dg/pch/wchar-1.Hs: New. ! ! 2004-02-04 Mark Mitchell ! ! PR c++/13932 ! * g++.dg/warn/conv2.C: New test. ! ! * lib/file-format.exp (gcc_target_object_format): Use ! ${tool}_target_compile, not gcc_target_compile. ! * lib/target-supports.exp (check_alias_available): Likewise. ! (check_gc_sections_available): Likewise. ! * g++.dg/ext/attrib10.C: Use dg-require-alias. ! * g++.old-deja/g++.ext/attrib5.C: Use dg-require-weak and ! dg-require-alias. ! ! 2004-02-04 Giovanni Bajo PR c++/13086 * g++.dg/warn/incomplete1.C: Remove xfail. ! 2004-02-04 Mark Mitchell ! ! PR c++/13969 ! * g++.dg/template/static6.C: New test. ! ! 2004-02-04 Kaveh R. Ghazi ! ! * objc.dg/encode-2.m, objc.dg/encode-3.m, objc.dg/encode-4.m: Fix ! tests for systems where `char' is unsigned by default. ! ! 2003-02-04 Giovanni Bajo ! ! PR c++/13997 ! * g++.dg/template/partial3.C: New test. ! ! 2004-02-03 Mark Mitchell ! ! PR c++/13950 ! * g++.dg/template/lookup4.C: New test. ! ! PR c++/13970 ! * g++.dg/parse/error14.C: New test. ! ! 2004-02-03 Mark Mitchell ! ! PR c++/13925 ! * g++.dg/template/lookup5.C: New test. ! ! PR c++/14002 ! * g++.dg/parse/template13.C: New test. ! ! PR c++/13978 ! * g++.dg/template/koenig4.C: New test. ! ! PR c++/13968 ! * g++.dg/template/crash17.C: New test. ! ! PR c++/13975 ! * g++.dg/parse/error13.C: New test. ! * g++.old-deja/g++.robertl/eb125.C: Tweak error messages. ! ! 2004-02-02 Andrew Pinski ! ! PR c++/10858 ! * g++.dg/template/sizeof7.C: New test. ! ! 2004-02-02 Eric Christopher ! Zack Weinberg ! ! * gcc.c-torture/execute/wchar_t-1.c: Add -finput-charset. ! ! 2004-02-02 Zack Weinberg * g++.dg/eh/forced1.C, g++.dg/eh/forced2.C, g++.dg/eh/forced3.C * g++.dg/eh/forced4.C: XFAIL ia64-hp-hpux11.*. * g++.dg/eh/ia64-1.C: Test branch regs only #ifdef __LP64__. * gcc.dg/cleanup-5.c: Run only on Linux targets. + 2004-02-02 Giovanni Bajo + + DR206 + PR c++/13813 + * g++.dg/template/member4.C: New test. + + 2004-02-02 Mark Mitchell + + PR c++/13113 + * g++.old-deja/g++.mike/net36.C: Adjust error messages. + + PR c++/13854 + * g++.dg/ext/attrib13.C: New test. + + PR c++/13907 + * g++.dg/conversion/op2.C: New test. + + 2004-02-02 Eric Botcazou + + * gcc.dg/titype-1.c: Fix pasto. + + 2004-02-02 Giovanni Bajo + + PR c++/13957 + * g++.dg/template/non-type-template-argument-1.C, + g++.dg/template/qualified-id1.C: Update dg-error marks. + * g++.dg/template/nontype6.C: New test. + + 2004-02-02 Eric Botcazou + + * gcc.dg/titype-1.c: New test. + + 2004-01-30 Michael Matz + + * g++.dg/ext/case-range1.C, g++.dg/ext/case-range2.C, + g++.dg/ext/case-range3.C: New tests. + + 2004-01-31 Bud Davis + + PR fortran/12884 + * g77.f-torture/execute/12884.f: New test + 2004-01-30 Giovanni Bajo PR c++/13683 * g++.dg/template/sizeof6.C: New test. + 2004-01-30 Eric Botcazou + + * gcc.dg/fwritable-strings-1.c: New test. + + 2004-01-30 Eric Botcazou + + * gcc.c-torture/compile/20040130-1.c: New test. + + 2004-01-29 Giovanni Bajo + + * g++.dg/parse/error11.C: New test. + * g++.dg/parse/error12.C: Likewise. + + 2004-01-29 Mark Mitchell + + PR c++/13883 + * g++.dg/template/ctor3.C: New test. + + 2004-01-28 Ziemowit Laski + + * objc.dg/proto-qual-1.m (ROUND, aligned_sizeof): New. + (scan_initial, main): Use aligned_sizeof instead of sizeof. + + 2004-01-28 Mark Mitchell + + PR c++/13791 + * g++.dg/ext/attrib12.C: New test. + + 2004-01-28 Mark Mitchell + + PR c++/13736 + * g++.dg/parse/cast2.C: New test. + + 2004-01-27 James E Wilson + + * objc.dg/encode-2.m (main): New local string. Set depending on + sizeof long. Use in sscanf call. + * objc.dg/encode-3.m (main): New local string. Set depending on + sizeof long. Use in scan_initial call. + + 2004-01-27 Kaveh R. Ghazi + + * objc.dg/call-super-2.m: Make LP64-safe. + * objc.dg/desig-init-1.m: Likewise. + + 2004-01-27 Ian Lance Taylor + + * gcc.dg/arm-mmx-1.c: New test. + + 2004-01-27 Eric Botcazou + + * gcc.dg/20040127-1.c: New test. + * gcc.dg/20040127-2.c: New test. + + 2004-01-26 Rainer Orth + + * objc.dg/stret-1.m (glob): Renamed to globa. + + 2004-01-26 Mark Mitchell + + PR c++/13363 + * g++.dg/expr/for1.C: New test. + + 2004-01-26 Eric Botcazou + + * gcc.dg/sparc-ret.c: Run only in 32-bit mode. Don't scan + the assembly output if -m64 is passed. + + 2004-01-25 Mark Mitchell + + PR c++/13833 + * g++.dg/template/cond3.C: New test. + + 2004-01-25 Giovanni Bajo + + PR c++/13810 + * g++.dg/template/ttp7.C: New test. + 2004-01-25 Kriang Lerdsuwanakij PR c++/13797 * g++.dg/template/nontype4.C: New test. * g++.dg/template/nontype5.C: Likewise. ! 2004-01-25 Richard Sandiford ! ! * gcc.dg/torture/mips-clobber-at.c: New test. ! ! 2004-01-24 Jakub Jelinek ! ! * gcc.dg/20040123-1.c: New test. ! ! 2004-01-23 Zack Weinberg ! ! PR 18314 ! * gcc.dg/builtins-30.c: New testcase. ! ! 2004-01-22 Hartmut Penner ! ! * gcc.dg/ppc64-abi-2.c: New test. ! ! 2004-01-22 Eric Botcazou ! ! * gcc.dg/struct-by-value-2.c: New test. ! ! 2004-01-21 Andrew Pinski ! ! PR target/13785 ! * gcc.dg/20030121-1.c: New test. ! ! 2004-01-22 Ulrich Weigand ! ! * gcc.dg/20030123-1.c: Add -fno-omit-frame-pointer option. Do not ! clobber frame pointer register in asm statement. ! ! 2004-01-21 Zack Weinberg ! ! * gcc.dg/noncompile/20020213-1.c: Add another dg-warning line. ! ! 2004-01-19 Mark Mitchell ! ! PR c++/13592 ! * g++.dg/other/error1.C (class foo): Tweak error message. ! ! 2004-01-19 Mark Mitchell ! ! PR c++/13592 ! * g++.dg/template/call2.C: New test. ! ! 2004-01-19 Eric Botcazou ! ! * gcc.dg/tls/alias-1.c: Add dg-warning for unsupported visibility ! attribute on sparc*-sun-solaris2.*. ! ! 2004-01-18 Mark Mitchell ! ! PR c++/13710 ! * g++.dg/ext/typeof7.C: New test. ! ! 2004-01-17 Ziemowit Laski ! ! * objc.dg/stret-1.m: New. ! * objc.dg/stret-2.m: New. ! ! 2004-01-17 Andrew Pinski ! ! PR c++/11895 ! * g++.dg/ext/vector1.C: New test. ! ! 2004-01-16 Mark Mitchell ! ! PR c++/13574 ! * g++.dg/ext/array1.C: New test. ! ! PR c++/13178 ! * g++.dg/conversion/op1.C: New test. ! ! 2004-01-16 J"orn Rennecke ! ! PR 11864 ! From Kazumoto Kojima / Dan Kegel: ! * gcc.dg/pr11864-1.c: New test. ! ! PR 10392 ! From Marcus Comstedt / Dan Kegel: ! * gcc.dg/pr10392-1.c: New test. ! ! 2004-01-16 Mark Mitchell ! ! PR c++/13478 ! * g++.dg/init/ref10.C: New test. ! ! 2004-01-15 Giovanni Bajo ! ! PR c++/13407 ! * g++.dg/parse/typename6.C: New test. ! ! 2004-01-15 Geoffrey Keating ! ! PR pch/13361 ! * testsuite/g++.dg/pch/wchar-1.C: New. ! * testsuite/g++.dg/pch/wchar-1.Hs: New. ! ! 2004-01-15 Giovanni Bajo ! ! PR c++/9259 ! * g++.dg/expr/sizeof2.C: New test. ! ! 2004-01-15 Kazu Hirata ! ! * gcc.dg/sibcall-3.c: Replace mn10?00 with mn10300. ! ! 2004-01-15 Alexandre Oliva ! ! PR c++/13659 ! * g++.dg/lookup/strong-using-3.C: New. ! * g++.dg/lookup/using-10.C: New. ! ! 2004-01-15 Alexandre Oliva ! ! PR c++/13594 ! * g++.dg/lookup/strong-using-2.C: New. ! ! 2004-01-15 Marcus Comstedt ! Dan Kegel ! J"orn Rennecke ! ! PR target/9365 ! * gcc.dg/pr9365-1.c: New test. ! ! 2004-01-15 Giovanni Bajo ! ! PR c++/8856 ! * g++.dg/parse/casting-operator2.C: New test. ! * g++.old-deja/g++.pt/explicit83.C: Remove. ! ! 2004-01-14 Joseph S. Myers ! ! * gcc.dg/label-compound-stmt-1.c: New test. ! * gcc.c-torture/compile/950922-1.c, ! gcc.c-torture/compile/20000211-3.c, ! gcc.c-torture/compile/20000518-1.c, ! gcc.c-torture/compile/20021108-1.c: Avoid labels at and of ! compound statements. ! ! 2004-01-14 Hartmut Penner ! ! * gcc.dg/ppc64-abi-1.c: New test. ! ! 2004-01-14 Danny Smith ! ! * g++.dg/ext/attrib9.C: Add dg-warnings. ! ! 2004-01-14 Giovanni Bajo ! ! PR c++/12335 ! * g++.dg/parse/dtor3.C: New test. ! ! 2004-01-13 Andrew Pinski ! ! PR c++/12709 ! * g++.dg/parse/try-catch-1.C: New test. ! ! 2004-01-13 Arnaud Charlet ! ! * ada/acats/run_all.sh: Add more verbose output in acats.log ! when compiling tests. ! ! 2004-01-12 Zack Weinberg ! ! PR 13656 ! * gcc.dg/typedef-redecl.c: New test case. ! * gcc.dg/typedef-redecl.h: New support file. ! ! 2004-01-13 Jan Hubicka ! ! * gcc.dg/always_inline.c: New test. ! * gcc.dg/debug/20031231-1.c: Fix. ! ! 2004-01-13 Giovanni Bajo ! ! PR c++/13474 ! * g++.dg/template/array3.C: New test. ! ! 2004-01-12 Zack Weinberg ! ! * g++.dg/ext/lvalue1.C: No longer expected to fail. ! * g++.dg/warn/Wunused-2.C: Likewise. ! ! 2004-01-12 Kriang Lerdsuwanakij ! ! PR c++/13289 ! * g++.dg/template/instantiate6.C: New test. ! ! 2004-01-12 Roger Sayle ! ! PR middle-end/11397 ! * gcc.dg/special/wkali-2.c: Add dg-require-alias. ! ! 2004-01-12 Jan Hubicka ! ! PR opt/12826 ! * gcc.dg/20040112-1.c: New. ! ! * gcc.dg/dwarf-die[1-7].c: Move to... ! * gcc.dg/debug/dwarf2/dwarf-die[1-7].c: ... here. ! * gcc.dg/debug/dwarf2/dwarf2.exp: New. ! ! 2004-01-12 Ian Lance Taylor ! ! PR c++/4100 ! * g++.dg/parse/friend4.C: New test. ! ! 2004-01-12 Scott Brumbaugh ! ! PR c++/4100 ! * g++.old-deja/g++.pt/niklas01a.C: Mark an error where a class ! definition is called a friend. ! ! 2004-01-11 Zack Weinberg ! ! * gcc.dg/tls/diag-3.c: Tweak dg-error regexp. ! ! 2004-01-11 Ian Lance Taylor ! ! PR c++/3478 ! * g++.dg/parse/error10.C: New test. ! * g++.dg/template/arg2.C: Accept "invalid type" error. 2004-01-11 Jakub Jelinek PR middle-end/13392 * g++.dg/opt/expect2.C: New test. ! 2004-01-10 Zack Weinberg ! * gcc.dg/Wshadow-1.c, gcc.dg/attr-noinline.c, gcc.dg/decl3.c ! * gcc.dg/redecl-1.c, gcc.dg/visibility-7.c, gcc.dg/wtr-static-1.c ! * gcc.dg/noncompile/20020220-1.c, objc.dg/method-1.m: ! Update dg-error regexps. ! 2004-01-10 Zack Weinberg ! ! * gcc.c-torture/compile/20021123-2.c: Delete; dup of 20021120-1.c. ! * gcc.c-torture/compile/20021123-3.c: Delete; dup of 20021120-2.c. ! ! 2004-01-10 Eric Botcazou ! ! * gcc.dg/pragma-re-1.c: Use right pointer type. ! ! 2004-01-10 Eric Botcazou ! ! * g++.dg/eh/simd-1.c: Ajust line number for dg-error line. ! ! 2004-01-09 Geoffrey Keating ! ! * gcc.dg/rs6000-ldouble-1.c: New. ! ! 2004-01-10 Giovanni Bajo ! ! DR 337 ! PR c++/9256 ! * g++.dg/other/abstract1.C: New test. ! ! 2004-01-09 Alexandre Oliva ! ! * g++.dg/lookup/strong-using-1.C: New. ! ! 2004-01-09 Joseph S. Myers ! ! PR c/11234 ! * gcc.dg/func-ptr-conv-1.c: New test. ! * gcc.dg/weak/weak-6.c, gcc.dg/weak/weak-7.c: Update. ! ! 2004-01-09 Kazu Hirata ! ! PR target/13380. ! * gcc.c-torture/compile/20040109-1.c: New. ! ! 2004-01-08 Stuart Hastings ! ! * testsuite/gcc.dg/20020523-2.c (bail_if_no_sse): Moved cpu-ID code... ! testsuite/gcc.dg/i386-cpuid.h (i386_cpuid): ...to here, to share with... ! * testsuite/gcc.dg/i386-sse-6.c: ...this new testcase. ! ! 2004-01-09 Alan Modra ! ! * gcc.dg/array-quals-1.c: Accept .data.rel.ro. ! ! 2004-01-08 Eric Botcazou ! ! * ada/acats/run_acats: Treat 'gnatchop' the same way ! as 'gnatmake'. Export GCC_DRIVER. ! * ada/acats/run_all.sh: Add target_gnatchop. Use ! 'host_gnatchop' and 'target_gnatchop' instead of 'gnatshop'. ! ! 2004-01-08 Giovanni Bajo ! ! PR c++/12573 ! * g++.dg/template/dependent-expr4.C: New test. ! ! 2004-01-08 Hartmut Penner ! ! * gcc.dg/altivec-11.c: New test. ! ! 2004-01-07 Mark Mitchell ! ! * g++.dg/abi/vbase10.C: Use -mstructure-size-boundary=8 on ARM. ! ! 2004-01-07 Joseph S. Myers ! ! PR c/6024 ! * gcc.dg/enum-compat-1.c: New test. ! * gcc.c-torture/execute/builtin-types-compatible-p.c: Update. ! ! 2004-01-07 Joseph S. Myers ! ! PR c/12165 ! * gcc.dg/array-quals-1.c, gcc.dg/c90-idem-qual-3.c, ! gcc.dg/c99-idem-qual-3.c: New tests. ! ! 2004-01-07 Alan Modra ! ! * gcc.dg/winline-7.c: Don't cast void * to int. ! ! 2004-01-06 Jan Hubicka ! ! * gcc.dg/i386-sse-5.c: New test ! * g++.dg/eh/simd-1.c: Add -w argument for i386. ! ! 2004-01-05 Mark Mitchell ! ! PR c++/12815 ! * g++.dg/rtti/typeid4.C: New test. ! ! 2004-01-05 Eric Botcazou ! ! * gcc.dg/compat/sdata-section.h: Declare 'abort'. ! ! 2004-01-05 Mark Mitchell ! ! PR c++/12132 ! * g++.dg/template/error11.C: New test. ! ! PR c++/13451 ! * g++.dg/template/class2.C: New test. ! ! 2004-01-05 Nathan Sidwell ! Richard Sandiford ! ! PR c++/13387 ! * g++.dg/opt/alias3.C: New test. ! ! 2004-01-04 Mark Mitchell ! ! PR c++/13157 ! * g++.dg/template/koenig3.C: New test. ! ! PR c++/13529 ! * g++.dg/parse/offsetof3.C: New test. ! ! * g++.dg/init/copy7.C: Add missing dg-error markers. ! ! PR c++/12226 ! * g++.dg/init/copy7.c: New test. ! ! PR c++/13536 ! * g++.dg/parse/cast1.C: New test. ! ! 2004-01-04 Jan Hubicka ! ! * gcc.dg/winline[1-7].c: New tests. ! ! 2004-01-02 Kriang Lerdsuwanakij ! ! PR c++/13520 ! * g++.dg/template/qualttp22.C: New test. ! ! 2004-01-01 Jan Hubicka ! ! * gcc.dg/debug/20031231-1.c: New. ! * gcc.c-torture/compile/20040101-1.c: New. ! * gcc.dg/dwarf-die-[1-7].c: New. 2004-01-01 Jakub Jelinek PR optimization/13521 * gcc.c-torture/compile/20031231-1.c: New test. ! 2003-12-30 Kazu Hirata ! ! * gcc.dg/sibcall-4.c: Replace mn10?00 with mn10300. ! ! 2003-12-30 Volker Reichelt ! ! PR c++/10079 ! * g++.dg/template/crash16.C: New test. ! ! 2003-12-30 Mark Mitchell ! ! * g++.dg/abi/vbase10.C: XFAIL on arm*-*-*. ! ! 2003-12-30 Kazu Hirata ! ! * g++.old-deja/g++.jason/thunk2.C: Remove traces of dead ! ports. ! * g++.old-deja/g++.jason/thunk3.C: Likewise. ! * g++.old-deja/g++.law/profile1.C: Likewise. ! * gcc.c-torture/compile/981006-1.c: Likewise. ! * gcc.c-torture/execute/loop-2e.x: Likewise. ! * gcc.c-torture/execute/loop-2f.x: Remove. ! * gcc.c-torture/execute/loop-2g.x: Likewise. ! * gcc.c-torture/execute/strct-varg-1.x: Likewise. ! * gcc.dg/20020312-2.c: Remove traces of dead ports. ! ! 2003-12-30 Nathan Sidwell ! ! PR c++/13507 ! * g++.dg/ext/attrib11.C: New test. ! ! PR c++/13494 ! * g++.dg/template/array2-1.C: New test. ! * g++.dg/template/array2-2.C: New test. ! ! 2003-12-29 Mark Mitchell ! ! * g++.old-deja/g++.pt/static11.C: Correct XFAIL syntax. ! ! 2003-12-29 Nathan Sidwell ! ! PR c++/12774 ! * g++.dg/template/array1-1.C: New test. ! * g++.dg/template/array1-2.C: New test. ! ! 2003-12-29 Roger Sayle PR fortran/12632 * g77.dg/12632.f: New test case. ! 2003-12-29 Kriang Lerdsuwanakij ! PR c++/13289 ! * g++.dg/parse/nontype1.C: New test. ! ! 2003-12-29 Kriang Lerdsuwanakij ! ! PR c++/12403 ! * g++.dg/parse/explicit1.C: New test. ! * g++.old-deja/g++.pt/explicit71.C: Adjust expected error. ! ! 2003-12-28 Mark Mitchell ! ! PR c++/13081 ! * g++.dg/opt/inline6.C: New test. ! ! PR c++/12613 ! * g++.dg/parse/error9.C: New test. ! ! * gcc.dg/const-elim-1.c: XFAIL on arm-*-*. ! ! 2003-12-28 Mark Mitchell ! ! PR c++/13009 ! * g++.dg/init/assign1.C: New test. 2003-12-28 Roger Sayle PR c++/13070 * g++.dg/warn/format3.C: New test case. ! 2003-12-27 Zdenek Dvorak ! * gcc.c-torture/compile/20031227-1.c: New test. ! 2003-12-23 Mark Mitchell ! ! * g++.dg/bprob/bprob.exp: Load target-supports.exp ! * g77.dg/bprob/bprob.exp: Likewise. ! * gcc.misc-tests/bprob.exp: Likewise. ! * gcc.dg/builtins-18.c: Use builtins-config.h. Do not test float ! variants on systems where the library does not provide that ! functionality. ! * gcc.dg/builtins-20.c: Use builtins-config.h. ! * gcc.dg/builtins-config.h: New file. ! ! 2003-12-23 Mark Mitchell ! ! * lib/gcc-dg.exp (dg-require-profiling): New function. ! * lib/target-supports.exp (check_profiling_available): Likewise. ! * g++.dg/bprob/bprob.exp: Use check_profiling_available. ! * g77.dg/bprob/bprob.exp: Likewise. ! * gcc.misc-tests/bprob.exp: Likewise. ! * g++.old-deja/g++.law/profile1.C: Use dg-require-profiling. ! * gcc.dg/20021014-1.c: Likewise. ! * gcc.dg/nest.c: Likewise. ! ! 2003-12-23 Mark Mitchell ! ! * g++.dg/lookup/java1.C: Use -fdollars-in-identifiers when ! compiling. ! * g++.dg/lookup/java2.C: Likewise. ! * gcc.dg/cpp/lexident.c: Likewise. ! ! 2003-12-23 Kazu Hirata ! ! * gcc.c-torture/compile/20020604-1.c: XFAIL on H8 if -mn is ! given. ! * gcc.c-torture/compile/961203-1.c: Likewise. ! * gcc.c-torture/compile/980506-1.c: Likewise. ! ! 2003-12-23 Zack Weinberg ! ! * lib/gcc-dg.exp (dg-prune-output): New annotation. ! (additional_prunes): New global. ! (gcc-dg-prune): Handle additional per-test pruning. ! (dg-test): Clear additional_prunes between tests. ! ! * gcc.c-torture/compile/920625-1.c: Remove xfail. Use ! dg-prune-output to avoid spurious failures from assembler ! complaining about nonexistent WAW violations. ! * gcc.c-torture/compile/981223-1.c: Remove dg-options line. ! Use dg-prune-output to avoid spurious failures from assembler ! warning about Itanium B-step errata. ! ! 2003-12-23 Mark Mitchell ! ! * g++.dg/abi/macro0.C: New test. ! * g++.dg/abi/macro1.C: Likewise. ! * g++.dg/abi/macro2.C: Likewise. ! ! * g++.dg/abi/bitfield5.C: Add explicit -fabi-version=1 option. ! * g++.dg/abi/bitfield7.C: Likewise. ! * g++.dg/abi/dtor2.C: Likewise. ! * g++.dg/abi/mangle11.C: Likewise. ! * g++.dg/abi/mangle12.C: Likewise. ! * g++.dg/abi/mangle14.C: Likewise. ! * g++.dg/abi/mangle17.C: Likewise. ! * g++.dg/abi/vbase10.C: Likewise. ! * g++.dg/abi/vbase14.C: Likewise. ! * g++.dg/template/qualttp17.C: Likewise. ! ! 2003-12-21 Andrew Pinski ! ! PR c/11995 ! * gcc.dg/20031223-1.c: New test. 2003-12-23 Eric Botcazou *************** *** 77,167 **** * gcc.dg/null-pointer-1.c: New test. 2003-12-22 Andrew Pinski ! PR c++/5050 ! * g++.dg/template/recurse1.C: New test. 2003-12-21 Mark Mitchell PR c++/11554 * testsuite/g++.dg/warn/ctor-init-1.C: New test. ! 2003-12-21 Roger Sayle ! PR middle-end/13400 ! * gcc.c-torture/execute/20031215-1.c: New test case. 2003-12-20 Roger Sayle PR optimization/13031 * gcc.c-torture/compile/20031220-1.c: New test case. 2003-12-19 Jakub Jelinek PR c++/13239 * g++.dg/opt/expect1.C: New test. 2003-12-18 Kriang Lerdsuwanakij PR c++/13262 * g++.dg/template/access13.C: New test. ! 2003-12-16 Zack Weinberg ! * gcc.c-torture/compile/981223-1.x: Add -mb-step to command line ! options on ia64-*-* instead of XFAILing the test case. 2003-12-16 Hartmut Penner * testsuite/gcc.dg/altivec-10.c: Test vec_cmple and vec_all_numeric. ! 2003-12-12 Roger Sayle ! PR optimization/13037 ! * g77.f-torture/execute/13037.f: New test case. ! 2003-12-12 Jakub Jelinek ! * g++.dg/eh/ia64-1.C: New test. ! 2003-12-12 Hans-Peter Nilsson ! PR target/13256 ! PR target/12598 ! Backport from mainline: ! * gcc.dg/torture/dg-torture.exp: New directory. New file. ! * gcc.dg/torture/cris-volatile-1.c: New test. ! * gcc.c-torture/execute/20031201-1.c: New test. ! 2003-12-12 Nathanael Nerode ! * gcc.dg/cpp/trad/xwin1.c: Remove, breaks testsuite (and I don't ! know how to make it work). ! 2003-12-11 Eric Botcazou ! Backport from mainline: ! 2003-12-07 Wolfgang Bangerth ! * gcc.dg/overflow-1.c: New test. ! 2003-12-11 Eric Botcazou ! Backport from mainline: ! 2003-12-07 Eric Botcazou ! * g77.f-torture/compile/13060.f: New test. ! 2003-12-11 Eric Botcazou ! Backport from mainline: ! 2003-12-07 Falk Hueffner ! * g++.dg/opt/noreturn-1.C: New test. 2003-12-10 Robert Schiele --- 1437,1761 ---- * gcc.dg/null-pointer-1.c: New test. + 2003-12-22 Mark Mitchell + + * g++.old-deja/g++.jason/template18.C: Remove. + * g++.old-deja/g++.jason/template37.C: Likewise. + + PR c++/12862 + * g++.dg/lookup/ns1.C: New test. + + PR c++/12397 + * g++.dg/template/lookup3.C: New test. + 2003-12-22 Andrew Pinski ! * g++.dg/template/recurse1.C: New test ! ! 2003-12-22 Mark Mitchell ! ! PR c++/12479 ! * g++.dg/parse/semicolon1.C: New test. ! * g++.dg/parse/semicolon1.h: Likewise. ! ! 2003-12-22 Fariborz Jahanian ! ! * gcc.dg/darwin-misaligned.c: New test. ! ! 2003-12-22 Andrew Pinski ! ! PR c/9163 ! * gcc.dg/20031222-1.c: New test. 2003-12-21 Mark Mitchell + PR c++/13438 + * g++.dg/parse/error8.C: New test. + PR c++/11554 * testsuite/g++.dg/warn/ctor-init-1.C: New test. ! 2003-12-21 Kazu Hirata ! * gcc.c-torture/compile/20020910-1.c: Disable if __INT_MAX is ! too small. ! * gcc.c-torture/compile/930217-1.c: Likewise. ! * gcc.c-torture/compile/930513-1.c: Likewise. ! * gcc.c-torture/execute/920908-2.c: Likewise. ! * gcc.c-torture/execute/921204-1.c: Likewise. ! * gcc.c-torture/execute/930621-1.c: Likewise. ! * gcc.c-torture/execute/930630-1.c: Likewise. ! * gcc.c-torture/execute/931031-1.c: Likewise. ! * gcc.c-torture/execute/980602-2.c: Likewise. ! * gcc.c-torture/execute/comp-goto-1.c: Likewise. ! * gcc.c-torture/execute/compndlit-1.c: Likewise. ! * gcc.c-torture/execute/extzvsi.c: Likewise. ! * gcc.c-torture/unsorted/ext.c: Likewise. ! ! 2003-12-20 Andrew Pinski ! ! PR target/12749 ! * gcc.c-torture/compile/20031220-2.c: New test case. 2003-12-20 Roger Sayle PR optimization/13031 * gcc.c-torture/compile/20031220-1.c: New test case. + 2003-12-20 Eric Botcazou + + * gcc.dg/cast-function-1.c: New test. + + 2003-12-19 Joseph S. Myers + + * gcc.dg/format/ext-1.c: Allow 'I' flag on floating point decimal + formats. + + 2003-12-19 Mark Mitchell + + PR c++/12795 + * g++.dg/ext/attrib10.C: New test. + + 2003-12-19 Jakub Jelinek + + * gcc.dg/cleanup-10.c: New test. + * gcc.dg/cleanup-11.c: New test. + 2003-12-19 Jakub Jelinek PR c++/13239 * g++.dg/opt/expect1.C: New test. + 2003-12-19 Hartmut Penner + + * gcc.dg/altivec-varargs-1.c: Enable testcase on ppc linux. + + 2003-12-18 Andrew Pinski + + PR debug/12923 + * gcc.dg/20031218-1.c: New test. + + PR debug/12389 + * gcc.dg/20031218-2.c: New test. + * gcc.dg/20031218-3.c: New test. + + * g++.dg/abi/mangle18-1.C: Modify regexp to test for `[: \t\n]' at end + of label name and allow for USER_LABEL_PREFIX == "_" names. + * g++.dg/abi/mangle18-2.C: Likewise. + * g++.dg/abi/mangle19-1.C: Likewise. + * g++.dg/abi/mangle19-2.C: Likewise. + * g++.dg/abi/mangle20-1.C: Likewise. + * g++.dg/abi/mangle20-2.C: Likewise. + + 2003-12-18 Richard Henderson + + * gcc.dg/bitfld-1.c: Expect warnings for enum bitfields. + + 2003-12-18 Steven Bosscher + Dan Kegel + + PR other/12009 + * g++.dg/compat/compat.exp: Do not set LD_LIBRARY_PATH when + testing a cross compiler, it causes spurious compile failures. + * lib/g++.exp: Likewise. + 2003-12-18 Kriang Lerdsuwanakij PR c++/13262 * g++.dg/template/access13.C: New test. ! 2003-12-18 Ulrich Weigand ! * gcc.dg/20031216-1.c: New test. ! ! 2003-12-18 Giovanni Bajo ! ! PR c++/9154 ! * g++.dg/template/error10.C: New test. ! ! 2003-12-18 Eric Botcazou ! ! * g++.dg/eh/simd-1.C: XFAIL on SPARC. ! * g++.dg/eh/simd-2.C: Likewise. ! ! 2003-12-17 James E Wilson ! Roger Sayle ! ! * gcc.c-torture/execute/ieee/mzero5.c: New. ! ! 2003-12-17 Mark Mitchell ! ! PR c++/10603 ! * g++.dg/parse/error6.C: New test. ! ! PR c++/12827 ! * g++.dg/parse/error7.C: New test. ! ! 2003-12-17 Eric Botcazou ! ! * lib/gcc-dg.exp (gcc-dg-debug-runtest): Do not run debug-[12].c ! at -O with stabs debugging formats. ! * gcc.dg/debug/debug-1.c: Turn 'p' into a global variable. ! * gcc.dg/debug/debug-2.c: Likewise. ! ! 2003-12-16 Mark Mitchell ! ! PR c++/12696 ! * g++.dg/init/error1.C: New test. ! ! PR c++/12218 ! * g++.dg/init/pm3.C: New test. ! ! 2003-12-17 Joseph S. Myers ! ! PR c/3347 ! * gcc.dg/bitfld-8.c: New test. ! ! 2003-12-16 James Lemke ! ! * gcc.dg/arm-scd42-[123].c: New tests. ! ! 2003-12-16 Nathan Sidwell ! ! PR c++/9043 ! * g++.dg/abi/mangle20-1.C: New test. ! * g++.dg/abi/mangle20-2.C: New test. ! ! 2003-12-16 Mark Mitchell ! ! PR c++/13275 ! * g++.dg/other/offsetof2.C: Remove XFAIL. ! * g++.dg/parse/offsetof1.C: New test. ! * g++.gd/parse/offsetof2.C: Likewise. ! ! 2003-12-16 Giovanni Bajo ! ! * g++.dg/template/nontype3.C: New test. ! * g++.dg/template/static2.C: Tweaked the dg-error clause. ! ! 2003-12-16 Kriang Lerdsuwanakij ! ! * g++.dg/warn/noreturn-3.C: Also test instantiation. ! ! 2003-12-16 Nathan Sidwell ! ! PR c++/13387 ! * g++.dg/expr/assign1.C: New test. ! ! PR c++/13242 ! * g++.dg/abi/mangle19-1.C: New test. ! * g++.dg/abi/mangle19-2.C: New test. 2003-12-16 Hartmut Penner * testsuite/gcc.dg/altivec-10.c: Test vec_cmple and vec_all_numeric. ! 2003-12-16 Eric Botcazou ! * gcc.c-torture/execute/20031216-1.c: New test. ! 2003-12-16 Giovanni Bajo ! * g++.dg/template/ptrmem7.C: Simplified the test case to not hit ! an ICE regression. ! 2003-12-15 Mark Mitchell ! PR c++/10926 ! * g++.dg/template/error9.C: New test. ! PR c++/11116 ! * g++.dg/template/error8.C: New test. ! 2003-12-15 Roger Sayle ! PR middle-end/13400 ! * gcc.c-torture/execute/20031215-1.c: New test case. ! 2003-12-15 Mark Mitchell ! PR c++/13269 ! * g++.dg/parse/error5.C: New test. ! PR c++/12989 ! * g++.dg/expr/sizeof1.C: New test. ! PR c++/13310 ! * g++.dg/template/crash15.C: New test. ! 2003-12-15 Geoffrey Keating ! * g++.old-deja/g++.pt/vaarg3.C: Don't expect an error for passing ! a non-POD type as the last named parameter of a varargs function. ! 2003-12-15 Mark Mitchell ! PR c++/13243 ! PR c++/12573 ! * g++.dg/template/crash14.C: New test. ! * g++.dg/template/dependent-expr3.C: Add dg-error markers. ! 2003-12-15 Nathan Sidwell ! * g++.dg/other/java1.C: New test. ! PR c++/13241 ! * g++.dg/abi/mangle18-1.C: New test. ! * g++.dg/abi/mangle18-2.C: New test. ! ! 2003-12-15 Zdenek Dvorak ! ! PR optimization/10312 ! * gcc.c-torture/execute/20031214-1.c: New. ! ! 2003-12-14 Mark Mitchell ! ! PR c++/10779 ! PR c++/12160 ! * g++.dg/parse/error3.C: New test. ! * g++.dg/parse/error4.C: Likewise. ! * g++.dg/abi/mangle4.C: Tweak error messages. ! * g++.dg/lookup/using5.C: Likewise. ! * g++.dg/other/error2.C: Likewise. ! * g++.dg/parse/typename5.C: Likewise. ! * g++.dg/parse/undefined1.C: Likewise. ! * g++.dg/template/arg2.C: Likewise. ! * g++.dg/template/ttp3.C: Likewise. ! * g++.dg/template/type1.C: Likewise. ! * g++.old-deja/g++.other/crash32.C: Likewise. ! * g++.old-djea/g++.pt/defarg8.C: Likewise. ! ! 2003-12-14 Kriang Lerdsuwanakij ! ! PR c++/13106 ! * g++.dg/warn/noreturn-3.C: New test. ! ! 2003-12-12 Nathan Sidwell ! ! PR c++/13118 ! * g++.dg/abi/covariant3.C: New. ! ! 2003-12-12 Jakub Jelinek ! ! * g++.dg/eh/ia64-1.C: New test. ! ! 2003-12-12 Roger Sayle ! ! PR optimization/13037 ! * g77.f-torture/execute/13037.f: New test case. ! ! 2003-12-12 Nathan Sidwell ! ! PR c++/12881 ! * g++.dg/abi/covariant2.C: New. ! ! 2003-12-12 Neil Booth ! ! * testsuite/gcc.dg/cpp/trad/macro.c: New tests. ! ! 2003-12-11 Zack Weinberg ! ! * gcc.c-torture/execute/wchar_t-1.x: Delete. 2003-12-10 Robert Schiele *************** *** 172,218 **** * lib/g77.exp (g77_version): Likewise. * lib/objc.exp (default_objc_version): Likewise. ! 2003-12-10 Nathanael Nerode ! Backport from mainline: ! * gcc.dg/cpp/trad/xwin1.c: New test case. ! 2003-12-10 Eric Botcazou ! Backport from mainline: ! 2003-11-05 Eric Botcazou ! * gcc.dg/uninit-C.c: XFAIL on non 64-bit Solaris versions. 2003-12-06 Mark Mitchell PR c++/13323 * g++.dg/inherit/operator2.C: New test. 2003-12-05 Stuart Menefy ! J"orn Rennecke ! PR target/13302 ! * g++.dg/other/struct-va_list.C: New test. 2003-12-03 Jakub Jelinek * gcc.dg/20031202-1.c: New test. ! 2003-12-03 Josef Zlomek ! Backport from mainline ! 2003-10-31 Josef Zlomek ! PR/10239 ! * gcc.c-torture/compile/20031031-2.c: New test. ! 2003-10-31 Josef Zlomek ! PR/11640 ! * gcc.c-torture/compile/20031031-1.c: New test. 2003-12-01 Roger Sayle --- 1766,1892 ---- * lib/g77.exp (g77_version): Likewise. * lib/objc.exp (default_objc_version): Likewise. ! 2003-12-10 Richard Henderson ! * gcc.c-torture/execute/wchar_t-1.c: Convert to utf-8. ! * gcc.dg/intermod-1.c: Adjust assembler scan pattern for alpha. ! 2003-12-08 Matt Austern ! PR c/13134 ! * lib/gcc-dg.exp (dg-require-visibility): Define. ! * lib/target-supports (check_visibility_available): Define. ! * gcc.dg/visibility-1.c: New test. ! * gcc.dg/visibility-2.c: Likewise. ! * gcc.dg/visibility-3.c: Likewise. ! * gcc.dg/visibility-4.c: Likewise. ! * gcc.dg/visibility-5.c: Likewise. ! * gcc.dg/visibility-6.c: Likewise. ! * g++.dg/ext/visibility-1.C: Likewise. ! * g++.dg/ext/visibility-2.C: Likewise. ! * g++.dg/ext/visibility-3.C: Likewise. ! * g++.dg/ext/visibility-4.C: Likewise. ! * g++.dg/ext/visibility-5.C: Likewise. ! * g++.dg/ext/visibility-6.C: Likewise. ! 2003-12-07 Giovanni Bajo ! ! * g++.dg/lookup/java1.C: New test. ! * g++.dg/lookup/java2.C: New test. ! ! 2003-12-07 Falk Hueffner ! ! * g++.dg/opt/noreturn-1.C: New test. ! ! 2003-12-07 Wolfgang Bangerth ! ! * gcc.dg/overflow-1.c: New test. ! ! 2003-12-07 Eric Botcazou ! ! * g77.f-torture/compile/13060.f: New test. 2003-12-06 Mark Mitchell PR c++/13323 * g++.dg/inherit/operator2.C: New test. + 2003-12-05 Mark Mitchell + + PR c++/13305 + * g++.dg/ext/attrib9.C: New test. + + 2003-12-05 Mark Mitchell + + PR c++/13314 + * g++.dg/template/error7.C: New test. + 2003-12-05 Stuart Menefy ! J"orn Rennecke ! PR target/13302 ! * g++.dg/other/struct-va_list.C: New test. ! ! 2003-12-05 Kriang Lerdsuwanakij ! ! PR c++/13166 ! * g++.dg/parse/defarg6.C: New test. ! ! 2003-12-05 Hans-Peter Nilsson ! ! PR target/13256 ! * gcc.c-torture/execute/20031201-1.c: New test. ! ! 2003-12-05 Arnaud Charlet ! ! * ada/acats/run_acats: Add checks against missing gnatlib/gnattools. ! ! 2003-12-05 Eric Botcazou ! ! * gcc.dg/builtin-return-1.c: New test. ! ! 2003-12-04 Stuart Menefy ! J"orn Rennecke ! ! PR optimization/13260 ! * gcc.c-torture/execute/20031204-1.c: New test. ! ! 2003-12-03 Mark Mitchell ! ! PR c++/9127 ! * g++.dg/template/error6.C: New test. 2003-12-03 Jakub Jelinek * gcc.dg/20031202-1.c: New test. ! 2003-12-03 Mark Mitchell ! PR c++/13179 ! * g++.dg/template/eh1.C: New test. ! PR c++/10771 ! * g++.dg/template/error5.C: New test. ! 2003-12-02 David Ung ! * gcc.dg/compat/vector-check.h: Corrected type for var ! g_##TMODE ! 2003-12-02 Giovanni Bajo ! ! PR c++/10126 ! * g++.dg/template/ptrmem8.C: New test. ! ! 2003-12-02 Giovanni Bajo ! ! PR c++/12573 ! * g++.dg/template/dependent-expr3.C: New test. ! ! 2003-12-01 James Lemke ! ! * gcc.dg/arm-g2.c: New test. 2003-12-01 Roger Sayle *************** *** 224,324 **** PR 11433 * objc.dg/proto-lossage-3.m: New test. 2003-12-01 Eric Botcazou ! Backport from mainline: ! 2003-11-27 Eric Botcazou * g++.dg/opt/reg-stack4.C: New test. ! 2003-11-14 Bernardo Innocenti ! Backport from 3.4-branch ! 2003-06-25 Giovanni Bajo PR c++/2094 ! * g++.dg/template/ptrmem6.C: New test. 2003-11-13 Eric Botcazou * g++.dg/opt/const3.C: New test. 2003-11-10 Waldek Hebisch * gcc.dg/trampoline-1.c: New test. 2003-11-08 Roger Sayle ! Backport from mainline ! PR optimization/10467, PR optimization/11741 ! * gcc.dg/20030926-1.c: New test case. * gcc.dg/20031108-1.c: New test case. ! 2003-11-08 Bernardo Innocenti ! Backport from 3.4-branch ! 2003-10-08 Giovanni Bajo ! * g++.dg/parse/error7.C: New test. ! 2003-11-04 H.J. Lu ! Backport from 3.4-branch ! 2003-04-25 H.J. Lu ! * gcc.dg/ia64-sync-4.c: New test. 2003-10-28 Franz Sirl PR libgcj/10610 * gcc.dg/ppc-stackalign-1.c: New test. ! 2003-10-28 Falk Hueffner ! PR target/12654 ! * gcc.c-torture/execute/20031020-1.c: New test. 2003-10-25 Eric Botcazou * g++.dg/opt/reg-stack3.C: New test. ! 2003-10-16 Release Manager ! * GCC 3.3.2 Released. ! 2003-10-15 Kriang Lerdsuwanakij PR c++/12369 * g++.dg/template/friend25.C: New test. ! 2003-10-15 Kriang Lerdsuwanakij ! PR c++/7939 ! * g++.dg/template/crash11.C: New test. ! 2003-10-14 Steven Bosscher ! * g++.dg/tls/init-2.C: Fix. Expect two warnings. 2003-10-11 Eric Botcazou * gcc.c-torture/compile/20031011-1.c: New test. ! 2003-10-09 Volker Reichelt ! * gcc.dg/20031009-1.c: New test. 2003-10-09 Mark Mitchell * g++.dg/ext/attrib8.C: Only run it on x86 targets. ! 2003-10-07 Mark Mitchell ! * g++.dg/template/ptrmem4.C: Revise in view of fixes for PR ! c++/10147. 2003-10-06 Bob Wilson --- 1898,2475 ---- PR 11433 * objc.dg/proto-lossage-3.m: New test. + 2003-12-01 Roger Sayle + + PR optimization/12628 + * gcc.dg/20031201-1.c: New test case. + 2003-12-01 Eric Botcazou ! * gcc.dg/unaligned-1.c: New test. ! 2003-11-30 Mark Mitchell ! ! PR c++/9849 ! * g++.dg/template/error4.C: New test. ! * g++.dg/template/nested3.C: Adjust error markers. ! ! 2003-11-30 Kaveh R. Ghazi ! ! * gcc.dg/cpp/assert4.c: Check more #system assertions. ! ! 2003-11-29 Joseph S. Myers ! ! PR c/10333 ! * gcc.dg/bitfld-7.c: New test. ! ! 2003-11-29 Richard Sandiford ! ! * gcc.dg/tls/asm-1.C: New test. ! ! 2003-11-28 Kaveh R. Ghazi ! ! * gcc.dg/cpp/assert4.c: Update. ! ! 2003-11-28 Eric Botcazou ! ! * gcc.dg/builtin-apply2.c: Set size of stack argument data to 64. ! * gcc.dg/builtin-apply3.c: New test. ! ! 2003-11-27 Eric Botcazou ! ! * lib/compat.exp (compat-obj): New xfaildata parameter. ! Use it to set compiler_conditional_xfail_data before compiling. ! (compat-get-options): Handle dg-xfail-if. ! (compat-execute): Retrieve XFAIL data and pass them to compat-obj. ! * gcc.dg/compat/vector-1_x.c: XFAIL on SPARC. ! * gcc.dg/compat/vector-1_y.c: Likewise. ! * gcc.dg/compat/vector-2_x.c: Likewise. ! * gcc.dg/compat/vector-2_y.c: Likewise. ! ! 2003-11-27 Eric Botcazou * g++.dg/opt/reg-stack4.C: New test. ! 2003-11-27 Eric Botcazou ! * gcc.dg/builtin-apply2.c: New test. ! 2003-11-26 Eric Botcazou ! ! * gcc.c-torture/compile/20031023-4.c: Don't XFAIL on SPARC64. ! ! 2003-11-23 Kriang Lerdsuwanakij ! ! PR c++/12924 ! * g++.dg/template/template-id-2.C: New test. ! ! 2003-11-22 Kriang Lerdsuwanakij ! ! PR c++/5369 ! * g++.dg/template/memfriend1.C: New test. ! * g++.dg/template/memfriend2.C: Likewise. ! * g++.dg/template/memfriend3.C: Likewise. ! * g++.dg/template/memfriend4.C: Likewise. ! * g++.dg/template/memfriend5.C: Likewise. ! * g++.dg/template/memfriend6.C: Likewise. ! * g++.dg/template/memfriend7.C: Likewise. ! * g++.dg/template/memfriend8.C: Likewise. ! * g++.old-deja/g++.pt/friend44.C: Remove a bogus error. ! ! 2003-11-21 Mark Mitchell ! ! PR c++/12515 ! * g++.dg/ext/cond1.C: New test. ! ! 2003-11-20 Richard Henderson ! ! * gcc.dg/20020201-2.c: Remove. ! * gcc.dg/20020201-4.c: Remove. ! * gcc.dg/20020304-1.c: Remove. ! ! 2003-11-19 Nathanael Nerode ! ! * gcc.dg/cpp/trad/xwin1.c: New test case. ! ! 2003-11-19 Andreas Tobler ! ! * g++.dg/compat/compat.exp: Add DYLD_LIBRARY_PATH for darwin. ! * lib/g77.exp: Likewise. ! * lib/objc.exp: Likewise. ! * lib/g++.exp: Likewise, add -multiply_defined suppress flag ! for darwin. ! ! 2003-11-18 Kriang Lerdsuwanakij ! ! PR c++/12932 ! * g++.dg/template/static5.C: New test. ! ! 2003-11-18 Joseph S. Myers ! ! * gcc.dg/nested-func-1.c: New test. ! ! 2003-11-16 Kaveh R. Ghazi ! ! * gcc.dg/cpp/assert4.c: New test. ! ! 2003-11-14 Giovanni Bajo ! ! PR c++/2294 ! * g++.dg/lookup/using9.c: New test. ! ! 2003-11-14 Mark Mitchell ! ! PR c++/12762 ! * g++.dg/template/error3.C: New test. ! ! 2003-11-14 Arnaud Charlet ! ! PR ada/13035 ! * ada/acats/run_acats, run_all.sh: Fix syntax error. ! No longer use a wrapper for gcc, since this does not work under ! Windows. ! ! 2003-11-14 Giovanni Bajo PR c++/2094 ! * g++.dg/template/ptrmem7.C: New test. ! ! 2003-11-13 Andrew Pinski ! ! * gcc.c-torture/compile/20031113-1.c: New test. ! ! 2003-11-13 Mark Mitchell ! Kean Johnston ! ! PR c/13029 ! * gcc.dg/unused-4.c: Update. 2003-11-13 Eric Botcazou * g++.dg/opt/const3.C: New test. + 2003-11-13 Jan Hubicka + + * gcc.c-torture/compile/20031112-1.c: New test. + + 2003-11-12 Mark Mitchell + + * g++.dg/parse/crash10.C: Remove bogus error marker. + + 2003-11-12 Rainer Orth + + * ada/acats/run_acats (host_gnatmake): Use type in a /bin/sh script. + (host_gcc): Likewise. + (ROOT): Honor $PWDCMD. + (BASE): Likewise. + * ada/acats/run_all.sh (dir): Honor $PWDCMD. + + 2003-11-12 Catherine Moore + + * gcc.c-torture/execute/20020720-1.x: Add xfail for frv-*-*. + + 2003-11-12 Andreas Jaeger + Jakub Jelinek + Andrew Pinski + Richard Henderson + + * gcc.dg/c90-const-expr-2.c (foo): Avoid extra warning on 64-bit + systems. + * gcc.dg/c99-const-expr-2.c (foo): Likewise. + + * gcc.dg/20030926-1.c: Make it work on x86_64 systems. + * gcc.dg/i386-pentium4-not-mull.c: Likewise. + + 2003-11-11 Andreas Jaeger + + * gcc.c-torture/execute/20020720-1.x: Test passes also on x86_64. + + * gcc.c-torture/execute/20020227-1.x: Test passes also on x86_64. + + 2003-11-10 Arnaud Charlet + + * ada/acats/run_all.sh: Add handling of unsupported (tasking) tests. + Clean ups. + 2003-11-10 Waldek Hebisch * gcc.dg/trampoline-1.c: New test. + 2003-11-09 Andrew Pinski + + * gcc.c-torture/compile/200031109-1.c: New test. + + 2003-11-08 Joseph S. Myers + + PR c/3190 + PR c/8714 + * gcc.dg/format/c90-strftime-1.c, gcc.dg/format/c90-strftime-2.c, + gcc.dg/format/c99-strftime-1.c, gcc.dg/format/ext3.c, + gcc.dg/format/no-y2k-1.c: Update. + 2003-11-08 Roger Sayle ! PR optimization/10467 * gcc.dg/20031108-1.c: New test case. ! 2003-11-07 Geoffrey Keating ! * gcc.dg/pch/warn-1.c: Allow for more helpful error message. ! 2003-11-08 Joseph S. Myers ! * gcc.dg/compound-lvalue-1.c: New test. ! * gcc.dg/c90-const-expr-2.c, gcc.dg/c99-const-expr-2.c: Remove ! some XFAILs. ! 2003-11-06 Geoffrey Keating ! * gcc.dg/altivec-varargs-1.c: New test. ! 2003-11-05 Eric Botcazou ! ! * gcc.c-torture/compile/20031023-4.c: XFAIL on SPARC64 ! * gcc.c-torture/compile/simd-5.c: XFAIL on SPARC64 at -O0 and -O1. ! * gcc.c-torture/execute/simd-4.x: New file. XFAIL on SPARC at -O0. ! * gcc.c-torture/execute/va-arg-25.x: New file. XFAIL on SPARC. ! * gcc.dg/uninit-C.c: XFAIL on non 64-bit Solaris versions. ! ! 2003-11-05 Joseph S. Myers ! ! * gcc.dg/cond-lvalue-1.c: New test. ! ! 2003-11-05 Gernot Hillier ! ! * g++.old-deja/g++.pt/asm1.C: Enable for e.g. x86_64-*-linux-gnu. ! ! 2003-11-05 Kriang Lerdsuwanakij ! ! PR c++/11616 ! * g++.dg/template/instantiate5.C: New test. ! ! 2003-11-03 Volker Reichelt ! ! PR c++/12726 ! * g++.dg/ext/complit2.C: Replace test with self-contained version. ! * ChangeLog: Add missing first entry for above test. ! ! 2003-11-02 Kriang Lerdsuwanakij ! ! PR c++/9810 ! * g++.dg/template/using8.C: New test. ! * g++.old-deja/g++.other/access11.C: Adjust expected error location. ! ! 2003-11-02 Roger Sayle ! ! PR optimization/10817 ! * gcc.c-torture/compile/20031102-1.c: New test case. ! ! 2003-11-02 Kazu Hirata ! ! * gcc.c-torture/execute/va-arg-25.c: Enable only if INT_MAX == ! 2147483647. ! ! 2003-11-02 Eric Botcazou ! ! * gcc.dg/20031102-1.c: New test. ! ! 2003-11-02 Eric Botcazou ! ! * gcc.dg/complex-1.c: New test. ! ! 2003-11-01 Kriang Lerdsuwanakij ! ! PR c++/12796 ! * g++.dg/template/crash13.C: Adjust expected error location. ! * g++.old-deja/g++.brendan/ns1.C: Likewise. ! ! 2003-10-31 Richard Earnshaw ! ! * g++.dg/bprob/bprob.exp: Disable test on arm-elf configs. ! ! 2003-10-31 Josef Zlomek ! ! PR/10239 ! * gcc.c-torture/compile/20031031-2.c: New test. ! ! 2003-10-31 Josef Zlomek ! ! PR/11640 ! * gcc.c-torture/compile/20031031-1.c: New test. ! ! 2003-10-31 Richard Earnshaw ! ! * g77.dg/bprob/bprob.exp: Disable test on arm-elf configs. ! * gcc.misc-tests/bprob.exp: Likewise. ! * g77.dg/execute/20001201.x, 6367.x, io0.x, io1.x, u77-test.x: XFAIL ! the execution test on arm-elf configs. ! * g77.dg/execute/10197.x: New file. XFAIL the execution test on ! configs that don't support scratch files. ! * g77.dg/execute/u77-test.x: XFAIL compilation on arm-elf configs. ! ! 2003-10-30 Arnaud Charlet ! ! * ada/acats/run_all.sh: Do not print PASS messages to stdout, as ! done by dejagnu. ! ! 2003-10-29 Arnaud Charlet ! ! * ada/acats/run_all.sh: Redirect mv output to /dev/null ! Avoid non pure sh syntax. Add more logging. ! ! * ada/acats/norun.lst: Disable cdd2a03, since it is expected to ! fail. 2003-10-28 Franz Sirl PR libgcj/10610 * gcc.dg/ppc-stackalign-1.c: New test. ! 2003-10-28 Arnaud Charlet ! * ada/acats/run_all.sh: Change output to be more compliant with ! dejagnu framework. ! Create acats.sum and acats.log files under testsuite/ada/acats ! Only run [a-z]* directories, to filter out e.g. CVS. ! Redirect build output to log file. ! ! 2003-10-27 Arnaud Charlet ! ! * README.ada: Removed, integrated in ../doc/sourcebuild.texi ! ! 2003-10-27 Arnaud Charlet ! ! PR ada/5909: ! * README.ada, ada/acats: Import ACATS 2.5 for GCC Ada test suite. ! ! 2003-10-27 Jakub Jelinek ! ! * gcc.c-torture/compile/20031023-1.c: New test. ! * gcc.c-torture/compile/20031023-2.c: New test. ! * gcc.c-torture/compile/20031023-3.c: New test. ! * gcc.c-torture/compile/20031023-4.c: New test. ! ! 2003-10-26 Kriang Lerdsuwanakij ! ! PR c++/10371 ! * g++.dg/lookup/scoped8.C: New test. 2003-10-25 Eric Botcazou * g++.dg/opt/reg-stack3.C: New test. ! 2003-10-24 Joseph S. Myers ! * gcc.dg/c99-arraydecl-2.c: New test. PR c/11943. ! 2003-10-24 Kriang Lerdsuwanakij ! ! PR c++/11076 ! * g++.dg/template/crash13.C: New test. ! ! 2003-10-24 Joseph S. Myers ! ! * gcc.dg/c99-restrict-2.c: New test. ! ! 2003-10-24 Nathan Sidwell ! ! PR c++/12698, c++/12699, c++/12700, c++/12566 ! * g++.dg/inherit/covariant9.C: New test. ! * g++.dg/inherit/covariant10.C: New test. ! * g++.dg/inherit/covariant11.C: New test. ! ! 2003-10-23 Jason Merrill ! ! PR c++/12726 ! * g++.dg/ext/complit2.C: New test. ! ! 2003-10-20 Falk Hueffner ! ! PR target/12654 ! * gcc.c-torture/execute/20031020-1.c: New test. ! ! 2003-10-20 Zdenek Dvorak ! ! * gcc.dg/old-style-asm-1.c: Also check for (set (pc) on lines ! following the jump_insn. ! ! 2003-10-22 Joseph S. Myers ! ! * gcc.dg/cast-lvalue-1.c: New test. ! ! 2003-10-21 Mark Mitchell ! ! PR c++/11962 ! * g++.dg/template/cond2.C: New test. ! ! 2003-10-20 Joseph S. Myers ! ! * gcc.dg/builtins-28.c: New test. ! ! 2003-10-20 Jan Hubicka ! ! * testsuite/g++.dg/opt/inline4.C: Do not use min-inline-insns ! parameter. ! * testsuite/gcc.dg/inline-2.c: Likewise. ! ! 2003-10-20 Phil Edwards ! ! * gcc.dg/20021014-1.c: XFAIL for *-*-windiss targets. ! * gcc.dg/nest.c: Likewise. ! ! 2003-10-20 Kriang Lerdsuwanakij ! ! PR c++/9781, c++/10583, c++/11862 ! * g++.dg/parse/crash13.C: New test. ! ! 2003-10-20 Zdenek Dvorak ! ! * gcc.dg/old-style-asm-1.c: Count jump_insns instead of labels. ! ! 2003-10-20 Eric Botcazou ! ! * gcc.dg/builtins-18.c: Wrap C99 tests with HAVE_C99_RUNTIME. ! Define HAVE_C99_RUNTIME except on Solaris. ! * gcc.dg/builtins-20.c: Likewise. ! ! 2003-10-19 Zdenek Dvorak ! ! * gcc.dg/old-style-asm-1.c: Use scan-assembler-times. ! ! 2003-10-18 Kriang Lerdsuwanakij ! ! PR c++/12495 ! * g++.dg/template/crash21.C: New test. ! ! 2003-10-17 Kriang Lerdsuwanakij ! ! PR c++/2513 ! * g++.dg/template/typename5.C: New test. ! ! 2003-10-17 Kriang Lerdsuwanakij PR c++/12369 * g++.dg/template/friend25.C: New test. ! 2003-10-16 Ziemowit Laski ! * objc.dg/try-catch-2.m: Relax target triple to all Darwin ! versions. ! 2003-10-16 Kazu Hirata ! * gcc.c-torture/execute/20031003-1.c: Enable only when INT_MAX ! == 2147483647. ! ! 2003-10-15 Kazu Hirata ! ! * gcc.c-torture/execute/960416-1.x: Remove. ! * gcc.c-torture/execute/divconst-3.x: Likewise. ! ! 2003-10-15 Hans-Peter Nilsson ! ! PR target/12598 ! * gcc.dg/torture/cris-volatile-1.c: New test. ! ! 2003-10-14 Roger Sayle ! ! PR optimization/9325 ! * gcc.c-torture/execute/20031003-1.c: Remove non-portable tests ! for overflowing floating point to integer conversion during RTL ! simplification. ! ! 2003-10-13 Ziemowit Laski ! ! * objc/execute/_cmd.m: Fix typo. ! * objc.dg/image-info.m, objc.dg/symtab-1.m: ! Relax 'scan-assembler' regexp. ! * objc.dg/try-catch-1.m, objc.dg/try-catch-3.m, ! objc.dg/try-catch-4.m: Run on non-Darwin targets. ! * objc.dg/zero-link-2.m: Remove blank line. ! * objc.dg/zero-link-3.m: New test case. ! ! 2003-10-13 Geoffrey Keating ! ! * g77.f-torture/execute/980520-1.x: XFAIL at -O0. ! ! * gcc.dg/asm-names.c: Use scan-assembler-not rather ! than linker trickery. ! ! 2003-10-13 Volker Reichelt ! ! PR c++/12370 ! * g++.dg/other/friend2.C: New test. ! ! 2003-10-12 Steven Bosscher ! ! * gcc.dg/20031012-1.c: New test. ! ! 2003-10-12 Steven Bosscher ! ! * gcc.dg/weak/weak-3.c: Fix for new warning. ! ! 2003-10-12 Kelley Cook ! ! PR optimization/8750 ! * gcc.c-torture/execute/20031012-1.c: New test case. ! ! 2003-10-11 Roger Sayle ! ! * gcc.c-torture/execute/string-opt-8.c: Don't test optimizations ! that inline strncmp as cmpstrsi on i386 when compiled with -Os. ! ! 2003-10-11 Roger Sayle ! ! PR optimization/12260 ! * gcc.c-torture/compile/20031011-2.c: New test case. ! ! 2003-10-11 Roger Sayle ! ! * gcc.c-torture/execute/20031011-1.c: New testcase. 2003-10-11 Eric Botcazou * gcc.c-torture/compile/20031011-1.c: New test. ! 2003-10-11 Jan Hubicka ! * g++.dg/other/first-global.C: New test. ! ! 2003-10-11 Roger Sayle ! ! * gcc.c-torture/execute/string-opt-18.c: New testcase. ! ! 2003-10-10 Ian Lance Taylor ! ! * gcc.c-torture/compile/20031010-1.c: New test. ! ! 2003-10-10 Geoffrey Keating ! ! * gcc.c-torture/execute/va-arg-24.c: Correct, and rename to... ! * gcc.c-torture/execute/va-arg-25.c: ... here. 2003-10-09 Mark Mitchell * g++.dg/ext/attrib8.C: Only run it on x86 targets. ! 2003-10-08 Richard Sandiford ! * gcc.c-torture/compile/mipscop-[1-4].c: Disable for mips16. ! ! 2003-10-08 Giovanni Bajo ! ! * g++.dg/parse/error2.C: New test. ! ! 2003-10-08 Giovanni Bajo ! ! PR c++/11097 ! * g++.dg/other/error5.C: Modify the error message. ! * g++.dg/lookup/using8.C: New test. ! ! 2003-10-07 Geoffrey Keating ! ! * gcc.dg/darwin-abi-2.c: New file. ! * gcc.c-torture/execute/va-arg-24.c: New file. 2003-10-06 Bob Wilson *************** *** 327,338 **** --- 2478,2498 ---- 2003-10-06 Mark Mitchell + PR c++/10147 + * g++.dg/other/error4.C: Update error messages. + * g++.dg/template/ptrmem4.C: Likewise. + PR c++/12337 * g++.dg/init/new9.C: New test. PR c++/12334, c++/12236, c++/8656 * g++.dg/ext/attrib8.C: New test. + 2003-10-06 Devang Patel + + * gcc.dg/debug/dwarf2-3.h: New test. + * gcc.dg/debug/dwarf2-3.c: New test case for -feliminate-dwarf2-dups. + 2003-10-06 Wolfgang Bangerth * g++.dg/opt/cfg2.C: New test. *************** *** 341,370 **** * g++.dg/opt/float1.C: New test. - 2003-10-04 Roger Sayle - - PR c++/11409 - * g++.dg/overload/builtin3.C: New test case. - 2003-10-04 Eric Botcazou * gcc.dg/c90-array-lval-6.c: New test. * gcc.dg/c99-array-lval-6.c: New test. 2003-10-02 Mark Mitchell PR optimization/12180 * gcc.dg/20031002-1.c: New test. - 2003-10-02 Mark Mitchell - PR c++/12486 * g++.dg/inherit/error1.C: New test. ! 2003-10-02 Alexandre Oliva ! * g++.dg/parse/parameter-declaration-1.C: Fix line number of ! expected error message. 2003-10-02 Josef Zlomek --- 2501,2539 ---- * g++.dg/opt/float1.C: New test. 2003-10-04 Eric Botcazou * gcc.dg/c90-array-lval-6.c: New test. * gcc.dg/c99-array-lval-6.c: New test. + 2003-10-03 Alexander Malmberg + Ziemowit Laski + + * objc.dg/method-6.m ('starboard'): Move prototype from 'Base' to + 'Derived', so that it is never considered a class method; add + new warning for '+port' method ambiguity. + * objc.dg/method-12.m: Include instead of + (needed on Mac OS X). + * objc.dg/method-13.m: New test. + + 2003-10-03 Roger Sayle + + PR optimization/9325, PR java/6391 + * gcc.c-torture/execute/20031003-1.c: New test case. + 2003-10-02 Mark Mitchell PR optimization/12180 * gcc.dg/20031002-1.c: New test. PR c++/12486 * g++.dg/inherit/error1.C: New test. ! 2003-10-02 Chris Demetriou ! * lib/f-torture.exp (search_for): Rename to... ! (search_for_re): This. Also, clean up comments and the ! "regexp" invocation. 2003-10-02 Josef Zlomek *************** *** 374,387 **** --- 2543,2619 ---- * g++.dg/opt/cond1.C: New test. + 2003-10-01 Kelley Cook + + * gcc.dg/Wold-style-definition-2.c: New testcase. + * gcc.dg/wtr-func-def-1.c: Modify to reflect new warning. + + 2003-09-29 Richard Henderson + + * g++.dg/init/array10.C: Add dg-options. + 2003-09-29 Eric Botcazou * g++.dg/opt/unroll1.C: Change unsigned to __SIZE_TYPE__. + 2003-09-28 Kriang Lerdsuwanakij + + * g++.dg/template/friend19.C: Fix typo. + * g++.old-deja/g++.other/crash31.C: Adjust expected error. + + 2003-09-28 Richard Sandiford + + * gcc.c-torture/execute/20030928-1.c: New test. + * gcc.dg/torture/mips-sdata-1.c (f): Refer to x[0] rather than x[3]. + 2003-09-27 Eric Botcazou * g++.dg/opt/unroll1.C: New test. + 2003-09-26 Roger Sayle + + PR optimization/11741 + * gcc.dg/20030926-1.c: New test case. + + 2003-09-25 Kriang Lerdsuwanakij + + PR c++/5655 + * g++.dg/parse/access7.C: New test. + * g++.old-deja/g++.brendan/crash56.C: Fix redeclaration error. + + 2003-09-24 Ziemowit Laski + + MERGE OF objc-improvements-branch into MAINLINE: + * lib/objc.exp (objc_target_compile): Do not point at libobjc headers + if libobjc has not been built. + * objc/execute/IMP.m, objc/execute/_cmd.m, objc/execute/bf-common.h, + objc/execute/bycopy-3.m, objc/execute/class-{1-14}.m, + objc/execute/class-self-2.m, objc/execute/many_args_method.m, + objc/execute/nested-3.m, objc/execute/np-2.m, + objc/execute/object_is_class.m, objc/execute/object_is_meta_class.m, + objc/execute/redefining_self.m, objc/execute/root_methods.m, + objc/execute/static-{1-2}.m, objc/execute/string-{1-4}.m, + objc/execute/va_method.m, objc.dg/comp-types-4.m, objc.dg/headers.m, + objc.dg/special/unclaimed-category-1.h, + objc.dg/special/unclaimed-category-1.m: Make usable with NeXT as + well as GNU runtime. + * execute/next_mapping.h: New header, for GNU->NeXT impedance matching. + * execute/cascading-1.m, execute/function-message-1.m, + objc.dg/anon-1.m, objc.dg/bitfield-{3-4}.m, + objc.dg/call-super-{1-3}.m, objc.dg/category-1.m, + objc.dg/const-str-{3-6}.m, objc.dg/encode-{1-4}.m, + objc.dg/func-ptr-1.m, objc.dg/gnu-runtime-1.m, objc.dg/image-info.m, + objc.dg/method-{3-12}.m, objc.dg/missing-proto-{1-3}.m, + objc.dg/nested-func-1.m, objc.dg/proto-lossage-2.m, + objc.dg/proto-qual-1.m, objc.dg/sizeof-1.m, objc.dg/static-1.m, + objc.dg/symtab-1.m, objc.dg/try-catch-{1-4}.m, + objc.dg/type-size-{1-2}.m, objc.dg/zero-link-{1-2}.m: New test cases. + * objc.dg/bitfield-2.m: Run only on Darwin. + * objc.dg/class-2.m, objc.dg/comp-types-1.m, objc.dg/desig-init-1.m, + objc.dg/method-{1-2}.m, objc.dg/proto-hier-1.m, + objc.dg/proto-lossage-1.m: Adjust for message wording changes. + * objc.dg/const-str-1.m: Fix constant string layout. + 2003-09-24 Alexandre Oliva * gcc.dg/cpp/Wunknown-pragmas-1.c: New test. *************** *** 390,395 **** --- 2622,2632 ---- * gcc.dg/darwin-abi-1.c: New file. + 2003-09-21 Andrew Pinski + + PR target/12281 + * gcc.c-torture/compile/20030921-1.c: New test. + 2003-09-22 Eric Botcazou * g++.dg/opt/reg-stack2.C: New test. *************** *** 398,420 **** * g++.dg/eh/delayslot1.C: New test. ! 2003-09-19 Andrew Pinski * g++.dg/init/array11.C: Change unsigned to __SIZE_TYPE__ so that it will not complain on LP64 targets. 2003-09-18 Mark Mitchell PR target/11184 * gcc.dg/builtin-apply1.c: New test. 2003-09-17 Mark Mitchell PR c++/11991 * g++.dg/rtti/typeid3.C: New test. - 2003-09-17 Mark Mitchell - PR c++/12266 * g++.dg/overload/template1.C: New test. --- 2635,2709 ---- * g++.dg/eh/delayslot1.C: New test. ! 2003-09-20 Richard Henderson ! ! * gcc.dg/format/gcc_diag-1.c: Add tests for %J. ! ! 2003-09-20 Roger Sayle ! ! * gcc.c-torture/execute/20030920-1.c: New test case. ! ! 2003-09-20 Kriang Lerdsuwanakij ! ! * g++.dg/rtti/typeid3.C: Correct expected error message. ! ! 2003-09-20 Kriang Lerdsuwanakij ! ! PR c++/157 ! * g++.dg/parse/crash12.C: New test. ! ! 2003-09-19 Janis Johnson ! ! * gcc.dg/compat/mixed-struct-check.h: New. ! * gcc.dg/compat/mixed-struct-defs.h: New. ! * gcc.dg/compat/mixed-struct-init.h: New. ! * gcc.dg/compat/struct-by-value-19_main.c: New. ! * gcc.dg/compat/struct-by-value-19_x.c: New. ! * gcc.dg/compat/struct-by-value-19_y.c: New. ! * gcc.dg/compat/struct-by-value-20_main.c: New. ! * gcc.dg/compat/struct-by-value-20_x.c: New. ! * gcc.dg/compat/struct-by-value-20_y.c: New. ! * gcc.dg/compat/struct-return-19_main.c: New. ! * gcc.dg/compat/struct-return-19_x.c: New. ! * gcc.dg/compat/struct-return-19_y.c: New. ! * gcc.dg/compat/struct-return-20_main.c: New. ! * gcc.dg/compat/struct-return-20_x.c: New. ! * gcc.dg/compat/struct-return-20_y.c: New. + 2003-09-19 Andrew Pinski * g++.dg/init/array11.C: Change unsigned to __SIZE_TYPE__ so that it will not complain on LP64 targets. + 2003-09-19 Kriang Lerdsuwanakij + + PR c++/495 + * g++.dg/template/friend24.C: New test. + + 2003-09-19 Nathan Sidwell + + PR c++/12332 + * g++.dg/template/memtmpl2.C: New test. + 2003-09-18 Mark Mitchell PR target/11184 * gcc.dg/builtin-apply1.c: New test. + 2003-09-18 Nathan Sidwell + + PR c++/9848 + * g++.dg/warn/Wunused-4.C: New test. + + 2003-09-18 Volker Reichelt + + PR c++/12316 + * g++.dg/other/gc2.C: New test. + 2003-09-17 Mark Mitchell PR c++/11991 * g++.dg/rtti/typeid3.C: New test. PR c++/12266 * g++.dg/overload/template1.C: New test. *************** *** 422,434 **** * g++.dg/opt/cfg3.C: New test. 2003-09-14 Mark Mitchell PR c++/3907 * g++.dg/parse/template12.C: New test. - 2003-09-14 Mark Mitchell - * g++.dg/abi/bitfield11.C: New test. * g++.dg/abi/bitfield12.C: Likewise. --- 2711,2740 ---- * g++.dg/opt/cfg3.C: New test. + 2003-09-16 Kriang Lerdsuwanakij + + PR c++/7939 + * g++.dg/template/crash11.C: New test. + + 2003-09-16 Jason Merrill + Jakub Jelinek + + * gcc.dg/attr-warn-unused-result.c: New test. + + 2003-09-15 Nathan Sidwell + + PR c++/12184 + * g++.dg/expr/call2.C: New test. + + 2003-09-15 Andreas Jaeger + + * gcc.dg/Wold-style-definition-1.c: New test. + 2003-09-14 Mark Mitchell PR c++/3907 * g++.dg/parse/template12.C: New test. * g++.dg/abi/bitfield11.C: New test. * g++.dg/abi/bitfield12.C: Likewise. *************** *** 438,463 **** non-expansion of functional macro name without arguments at EOL. * gcc.dg/cpp/spacing1.c: Revert 2003-08-04's change. Likewise. 2003-09-10 Eric Botcazou * gcc.dg/ultrasp10.c: New test. 2003-09-08 Mark Mitchell ! PR c++/11786 ! * g++.dg/lookup/koenig2.C: New test. 2003-09-08 Mark Mitchell PR c++/5296 * g++.dg/rtti/typeid2.C: New test. 2003-09-07 Eric Botcazou * g++.dg/opt/longbranch2.C: New test. 2003-09-07 Andrew Pinski PR middle-end/11665 * gcc.c-torture/compile/20030907-1.c: New test. * g++.dg/init/array11.C: New test. --- 2744,2809 ---- non-expansion of functional macro name without arguments at EOL. * gcc.dg/cpp/spacing1.c: Revert 2003-08-04's change. Likewise. + 2003-09-14 Richard Sandiford + + * gcc.c-torture/execute/20030914-[12].c: New tests. + + 2003-09-11 Nathan Sidwell + + PR c++/11788 + * g++.dg/overload/addr1.C: New test. + + 2003-09-10 Ian Lance Taylor + + * gcc.dg/20030909-1.c: New test. + 2003-09-10 Eric Botcazou * gcc.dg/ultrasp10.c: New test. + 2003-09-09 Devang Patel + + * gcc.dg/darwin-ld-6.c: New test. + + 2003-09-09 Kaveh R. Ghazi + + * gcc.dg/torture/builtin-explog-1.c: New testcase. + 2003-09-08 Mark Mitchell ! * gcc.dg/ia64-types1.c: New test. ! * gcc.dg/ia64-types2.c: Likewise. ! ! 2003-09-08 Kaveh R. Ghazi ! ! * gcc.dg/builtins-1.c: Add more _Complex tests. ! * gcc.dg/torture/builtin-attr-1.c: Likewise. ! ! * gcc.dg/builtins-1.c: Test existing _Complex functions. ! * gcc.dg/torture/builtin-attr-1.c: Likewise. 2003-09-08 Mark Mitchell + PR c++/11786 + * g++.dg/lookup/koenig2.C: New test. + PR c++/5296 * g++.dg/rtti/typeid2.C: New test. + 2003-09-08 Jakub Jelinek + + * gcc.c-torture/compile/20030904-1.c: New test. + 2003-09-07 Eric Botcazou * g++.dg/opt/longbranch2.C: New test. 2003-09-07 Andrew Pinski + * g++.dg/template/crash10.C: Only compile it. + + 2003-09-07 Andrew Pinski + PR middle-end/11665 * gcc.c-torture/compile/20030907-1.c: New test. * g++.dg/init/array11.C: New test. *************** *** 472,486 **** PR c++/12181 * g++.dg/expr/comma1.C: New test. - 2003-09-07 Eric Botcazou - - * gcc.c-torture/execute/20030907-1.c: New test. - 2003-09-06 Mark Mitchell PR c++/11867 * g++.dg/expr/static_cast5.C: New test. 2003-09-05 Mark Mitchell PR c++/12163 --- 2818,2871 ---- PR c++/12181 * g++.dg/expr/comma1.C: New test. 2003-09-06 Mark Mitchell PR c++/11867 * g++.dg/expr/static_cast5.C: New test. + 2003-09-06 Andrew Pinski + + PR c++/11507 + * g++.dg/lookup/scoped7.C: New test. + + PR c++/9574 + * g++.dg/other/static1.C: New test. + + PR c++/11490 + * g++.dg/warn/template-1.C: New test. + + PR c++/11432 + * g++.dg/template/crash10.C: New test. + + PR c++/2478 + * g++.dg/overload/VLA.C: New test. + + PR c++/10804 + * g++.dg/template/call1.C: New test. + + 2003-09-06 Nathan Sidwell + + PR c++/11794 + * g++.dg/parse/using3.C: New test. + + 2003-09-06 Roger Sayle + + PR c++/11409 + * g++.dg/overload/builtin3.C: New test case. + + 2003-09-06 Steven Bosscher + + PR c/9862 + * gcc.dg/20030906-1.c: New test. + * gcc.dg/20030906-2.c: Likewise. + + 2003-09-06 Nathan Sidwell + + PR c++/12167 + * g++.dg/parse/defarg5.C: New test. + + * g++.dg/template/non-type-template-argument-1.C: Tweak expected error. + 2003-09-05 Mark Mitchell PR c++/12163 *************** *** 489,581 **** PR c++/12146 * g++.dg/template/crash9.C: New test. 2003-09-04 Mark Mitchell ! Revert this patch: ! * g++.dg/abi/layout4.C: New test. 2003-09-03 Mark Mitchell PR c++/12053 * g++.dg/abi/layout4.C: New test. 2003-09-01 Mark Mitchell PR c++/12114 * g++.dg/init/ref9.C: New test. 2003-08-29 Mark Mitchell PR c++/11928 * g++.dg/inherit/conv1.C: New test. 2003-08-26 Matt Kraai * gcc.dg/noncompile/20030818-1.c: Expect second line of error. 2003-08-25 Ulrich Weigand * gcc.dg/20030702-1.c: New test. 2003-08-23 Jakub Jelinek * gcc.dg/20030815-1.c: New test. ! 2003-08-22 Alexandre Oliva ! * gcc.dg/cpp/separate-1.c: New test. ! * gcc.dg/cpp/spacing1.c: Update. 2003-08-22 Mark Mitchell * gcc.misc-tests/linkage.exp: Treat all HP-UX platforms identically. - 2003-08-22 Roger Sayle - Jim Wilson - - * gcc.dg/uninit-C.c: Only test TImode on 64-bit platforms. - 2003-08-22 Mark Mitchell * g++.old-deja/g++.ext/attrib5.C: XFAIL on hppa2*-hp-hpux11*. * gcc.dg/20020313-1.c: Add "-w" to dg-options. * gcc.misc-tests/linkage.exp: Add logic for ia64-hp-hpux*. * g++.dg/other/packed1.C: Add XFAIL marker for ia64-hp-hpux*. 2003-08-21 Kazu Hirata PR target/11805 * gcc.c-torture/compile/20030821-1.c: New. 2003-08-18 Matt Kraai * gcc.dg/noncompile/20030818-1.c: New. ! 2003-08-08 Roger Sayle ! PR c/11370 ! * gcc.dg/Wunreachable-6.c: New testcase. ! * gcc.dg/Wunreachable-7.c: New testcase. 2003-07-26 Geoffrey Keating * gcc.c-torture/compile/zero-strct-2.c: New test. ! 2003-08-04 Release Manager ! * GCC 3.3.1 Released. ! 2003-08-04 Mark Mitchell ! * g++.dg/overload/operator1.C: New test. ! 2003-07-24 Alexandre Oliva ! * g++.dg/init/enum2.C: New. 2003-07-24 Mark Mitchell --- 2874,3448 ---- PR c++/12146 * g++.dg/template/crash9.C: New test. + 2003-09-05 Andrew Pinski + + * g++.old-deja/g++.ext/pretty2.C: Update for change + in __FUNCTION__. + * g++.old-deja/g++.ext/pretty3.C: Likewise. + + 2003-09-05 Nathan Sidwell + + PR c++/11922 + * g++/dg/template/qualified-id1.C: New test. + + PR c++/12037 + * g++.dg/warn/noeffect4.C: New test. + + 2003-09-04 Matt Austern + + * g++.dg/ext/fnname1.C: New test. (__func__ for C++.) + * g++.dg/ext/fnname2.C: Likewise. + * g++.dg/ext/fnname3.C: Likewise. + 2003-09-04 Mark Mitchell ! * g++.dg/expr/lval1.C: New test. ! * g++.dg/ext/lvcast.C: Remove. ! ! 2003-09-03 Roger Sayle ! ! PR optimization/11700. ! * gcc.c-torture/compile/20030903-1.c: New test case. 2003-09-03 Mark Mitchell PR c++/12053 * g++.dg/abi/layout4.C: New test. + 2003-09-02 Scott Brumbaugh + + PR c++/11553 + * g++.dg/parse/friend3.C: New test. + + 2003-09-02 Mark Mitchell + + PR c++/11847 + * g++.dg/template/class1.C: New test. + + PR c++/11808 + * g++.dg/expr/call1.C: New test. + 2003-09-01 Mark Mitchell PR c++/12114 * g++.dg/init/ref9.C: New test. + PR c++/11972 + * g++.dg/template/nested4.C: New test. + 2003-08-29 Mark Mitchell + PR c++/12093 + * g++.dg/template/non-dependent4.C: New test. + PR c++/11928 * g++.dg/inherit/conv1.C: New test. + 2003-08-29 Mark Mitchell + + PR c++/6196 + * g++.dg/ext/label1.C: New test. + * g++.dg/ext/label2.C: Likewise. + + 2003-08-28 Mark Mitchell + + * g++.dg/expr/cond3.C: New test. + + 2003-08-28 Kaveh R. Ghazi + + * gcc.dg/builtins-1.c: Add new builtin cases. + + 2003-08-28 Kaveh R. Ghazi + + * gcc.dg/builtins-1.c: Add new cases. + * gcc.dg/torture/builtin-attr-1.c: Likewise. + + 2003-08-28 Kaveh R. Ghazi + + * gcc.dg/builtins-1.c: Add more math builtin tests. + * gcc.dg/torture/builtin-attr-1.c: New test. + + 2003-08-28 Mark Mitchell + + PR optimization/5079 + * g++.dg/opt/static3.C: New test. + + 2003-08-27 Zdenek Dvorak + + * gcc.misc-tests/gcov-10b.c: New test. + + 2003-08-27 Mark Mitchell + + * g++.dg/opt/ptrmem3.C: New test. + + * g++.old-deja/g++.pt/overload8.C: Remove XFAIL. + + 2003-08-27 Jakub Jelinek + + * gcc.dg/20030826-2.c: New test. + + 2003-08-26 Roger Sayle + + PR middle-end/12002 + * g77.f-torture/compile/12002.f: New test case. + + 2003-08-26 Roger Sayle + + * gcc.dg/20030826-1.c: New test case. + 2003-08-26 Matt Kraai * gcc.dg/noncompile/20030818-1.c: Expect second line of error. + 2003-08-26 Nathan Sidwell + + PR c++/11871 + * c++.dg/lookup/crash1.C: New test. + + * c++.dg/warn/noeffect3.C: New test. + + 2003-08-25 Janis Johnson + + * gcc.dg/compat/vector-1_x.c: Compile with -w. + * gcc.dg/compat/vector-1_y.c: Ditto. + * gcc.dg/compat/vector-2_x.c: Ditto. + * gcc.dg/compat/vector-2_y.c: Ditto. + 2003-08-25 Ulrich Weigand * gcc.dg/20030702-1.c: New test. + 2003-08-25 Mark Mitchell + + PR c++/8795 + * g++.dg/ext/altivec-1.C: New test. + + 2003-08-24 Richard Henderson + + * g++.dg/eh/simd-2.C: Add -w for x86. + 2003-08-23 Jakub Jelinek * gcc.dg/20030815-1.c: New test. ! 2003-08-23 Kriang Lerdsuwanakij ! PR c++/3765 ! * g++.dg/parse/access6.C: New test. ! ! 2003-08-23 Kriang Lerdsuwanakij ! ! PR c++/641, c++/11876 ! * g++.dg/template/friend22.C: New test. ! * g++.dg/template/friend23.C: Likewise. 2003-08-22 Mark Mitchell * gcc.misc-tests/linkage.exp: Treat all HP-UX platforms identically. 2003-08-22 Mark Mitchell * g++.old-deja/g++.ext/attrib5.C: XFAIL on hppa2*-hp-hpux11*. + 2003-08-22 Mark Mitchell + * gcc.dg/20020313-1.c: Add "-w" to dg-options. + 2003-08-22 Mark Mitchell + * gcc.misc-tests/linkage.exp: Add logic for ia64-hp-hpux*. + 2003-08-22 Mark Mitchell + * g++.dg/other/packed1.C: Add XFAIL marker for ia64-hp-hpux*. + 2003-08-21 Mark Mitchell + + PR c++/11919 + * g++.dg/overload/prom1.C: New test. + + PR c++/11551 + * g++.dg/parse/dtor2.C: New test. + + PR c++/10762 + * g++.dg/parse/using2.C: New test. + 2003-08-21 Kazu Hirata PR target/11805 * gcc.c-torture/compile/20030821-1.c: New. + 2003-08-20 Mark Mitchell + + PR c++/11834 + * g++.dg/template/deduce2.C: New test. + + 2003-08-21 Josef Zlomek + + * gcc.c-torture/execute/20030821-1.c: New test. + + 2003-08-20 Roger Sayle + + PR middle-end/11984 + * gcc.dg/20030820-1.c: New test case. + + 2003-08-20 Nathan Sidwell + + PR c++/11945 + * g++.dg/warn/noeffect2.C: New test. + + 2003-08-19 Mark Mitchell + + PR c++/10926 + * g++.dg/template/dtor2.C: New test. + + PR c++/11684 + * g++.dg/template/operator1.C: New test. + * g++.dg/parse/operator4.C: New test. + + PR c++/11946.C + * g++.dg/expr/enum1.C: New test. + * gcc.dg/c99-bool-1.c: Remove bogus warning. + + PR c++/11036.C + * g++.dg/parse/elab2.C: New test. + * g++.dg/parse/typedef4.C: Change error message. + * g++.old-deja/g++.robertl/eb133.C: Remove bogus error markers. + * g++.old-deja/g++.robertl/eb133a.C: Remove bogus error markers. + * g++.old-deja/g++.robertl/eb133b.C: Remove bogus error markers. + + 2003-08-19 Geoffrey Keating + + * gcc.dg/pch/warn-1.c: New. + * gcc.dg/pch/warn-1.hs: New. + + * lib/dg-pch.exp (dg-pch): Use 'return' not 'continue' to skip + not-tested file. + + 2003-08-19 Andrew Pinski + + * gcc.dg/uninit-E.c: Add forgotten dg-warning marker. + + 2003-08-19 Andrew Pinski + + * gcc.dg/uninit-D.c: New Test. + * gcc.dg/uninit-E.c: New Test. + * gcc.dg/uninit-F.c: New Test. + * gcc.dg/uninit-G.c: New Test. + + 2003-08-19 Michael Ritzert + + * g++.dg/README: Describe the pch directory. + + 2003-08-19 Kriang Lerdsuwanakij + + PR c++/11174 + * g++.dg/parse/access4.C: New test. + * g++.dg/parse/access5.C: Likewise. + * g++.old-deja/g++.jason/access17.C: Adjust error message. + 2003-08-18 Matt Kraai * gcc.dg/noncompile/20030818-1.c: New. ! 2003-08-18 Nathan Sidwell ! PR c++/11957 ! * g++.dg/warn/noeffect1.C: New test. ! ! * g++.dg/template/scope2.C: New test. ! * g++.dg/template/error2.C: Correct dg-error ! ! 2003-08-18 Richard Sandiford ! ! * gcc.c-torture/compile/mipscop*.c: Turn into compile-only tests. ! ! 2003-08-16 Nathan Sidwell ! ! PR C++/11512 ! * g++.dg/template/warn1.C: New. ! ! 2003-08-15 Nathan Sidwell ! ! * g++.dg/template/error2.C: New test. ! * g++.dg/lookup/using7.C: Adjust errors ! * g++.old-deja/g++.pt/crash36.C: Likewise. ! * g++.old-deja/g++.pt/derived3.C: Likewise. ! ! 2003-08-14 Kaveh R. Ghazi ! ! * gcc.c-torture/execute/builtins/lib/strcat.c: New. ! * gcc.c-torture/execute/builtins/string-9-lib.c: New. ! * gcc.c-torture/execute/builtins/string-9.c: New, from ! string-opt-9.c. Adjust for execute/builtins framework. ! * gcc.c-torture/execute/string-opt-9.c: Delete. ! ! 2003-08-12 Mark Mitchell ! ! * g++.dg/init/new8.C: Use __SIZE_TYPE__ to get the type of size_t. ! ! * g++.dg/parse/ret-type2.C: New test. ! ! PR c++/11703 ! * g++.dg/init/new8.C: New test. ! ! PR c++/10923 ! * g++.dg/parse/typedef5.C: New test. ! ! PR c++/9512 ! * g++.dg/parse/qualified2.C: New test. ! * g++.old-deja/g++.other/decl5.C: Mark one more instance of ! invalid code. ! ! 2003-08-11 Mark Mitchell ! ! * g++.dg/conversion/ptrmem1.C: New test. ! ! 2003-08-11 Jakub Jelinek ! ! PR target/11693 ! * gcc.dg/20030811-1.c: New test. ! ! PR target/11535 ! * gcc.c-torture/execute/20030811-1.c: New test. ! ! 2003-08-10 Kaveh R. Ghazi ! ! * gcc.c-torture/execute/string-opt-9.c: Add more strcat cases. ! ! 2003-08-10 Mark Mitchell ! ! PR c++/11789.C ! * g++.dg/inherit/multiple1.C: New test. ! ! 2003-08-10 Nathan Sidwell ! ! * gcc.dg/spe1.c: New test. ! ! PR c++/11670 ! * g++.dg/expr/cast2.C: New test. ! ! PR c++/10530 ! * g++.dg/template/dependent-name2.C: New test. ! ! 2003-08-08 Andrew Pinski ! ! * g++.dg/parse/crash11.C: Put the dg options in comments. ! ! 2003-08-08 Neil Booth ! ! * lib/gcc-dg.exp: Update for diagnostic change. ! ! 2003-08-07 Kriang Lerdsuwanakij ! ! PR c++/5767 ! * g++.dg/parse/crash11.C: New test. ! ! 2003-08-06 Alexandre Oliva ! ! * gcc.dg/cpp/spacing1.c: Update. ! ! 2003-08-04 Janis Johnson ! ! PR target/11739 ! * gcc.misc-tests/i386-prefetch.exp: Use -march=i386 when specifying ! a value for -mtune. ! ! 2003-08-04 Roger Sayle ! ! PR middle-end/11771 ! * gcc.c-torture/compile/20030804-1.c: New test case. ! ! 2003-08-04 Roger Sayle ! ! * gcc.dg/20030804-1.c: New test case. ! ! 2003-08-04 Alexandre Oliva ! ! * gcc.dg/cpp/separate-1.c: New test. ! ! 2003-08-03 Nathan Sidwell ! ! PR c++/11704 ! * g++.dg/template/dependent-expr2.C: New test. ! ! PR c++/11766 ! * g++.dg/expr/ptrmem1.C: New test. ! ! 2003-08-03 Kriang Lerdsuwanakij ! ! PR c++/9453 ! * g++.dg/template/friend15.C: New test. ! ! 2003-08-03 Neil Booth ! ! * lib/dg-pch.exp: Work round PCH bug. ! ! 2003-08-02 Kaveh R. Ghazi ! ! * gcc.dg/builtins-1.c: Add macro helpers. Add missing math ! builtins. Move cases from builtins-4.c here. ! ! * gcc.dg/torture/builtin-math-1.c: New test taken from ! bits of gcc.dg/builtins-3.c, gcc.dg/builtins-5.c and also some ! additional cases. ! ! * gcc.dg/builtins-3.c, gcc.dg/builtins-4.c, gcc.dg/builtins-5.c: ! Delete. ! ! 2003-08-02 Nathan Sidwell ! ! PR c++/9447 ! * g++.dg/template/using7.C: New test. ! ! 2003-08-02 Neil Booth ! ! * import1.c, import2.c: New tests. ! ! 2003-08-01 Jakub Jelinek ! ! * g++.dg/eh/crossjump1.C: New test. ! ! 2003-08-01 Mark Mitchell ! ! PR c++/11697 ! * g++.dg/template/using6.C: New test. ! ! PR c++/11744 ! * g++.dg/template/koenig2.C: New test. ! ! 2003-08-01 Kriang Lerdsuwanakij ! ! PR c++/7983 ! * g++.dg/parse/typedef4.C: New test. ! ! 2003-08-01 Kriang Lerdsuwanakij ! ! PR c++/8442, c++/8806 ! * g++.dg/template/elab1.C: New test. ! * g++.dg/template/type2.C: Likewise. ! * g++.dg/template/ttp3.C: Adjust expected error message. ! * g++.old-deja/g++.law/visibility13.C: Likewise. ! * g++.old-deja/g++.niklas/t135.C: Likewise. ! * g++.old-deja/g++.pt/ttp41.C: Likewise. ! * g++.old-deja/g++.pt/ttp43.C: Use qualified name for template ! template argument. ! * g++.old-deja/g++.pt/ttp44.C: Likewise. ! ! 2003-08-01 Nathan Sidwell ! ! PR c++/11295 ! * g++.dg/ext/stmtexpr1.C: New test. ! ! * g++.dg/opt/tmp1.C: New test. ! ! PR c++/11525 ! * g++.dg/parse/constant4.C: New test. ! ! PR c++/9447 ! * g++.dg/template/using5.C: New test. ! ! 2003-07-31 Roger Sayle ! ! * gcc.dg/builtins-27.c: New test case. ! ! 2003-07-31 Jakub Jelinek ! ! * gcc.dg/tls/opt-7.c: New test. ! ! 2003-07-31 Andrew Pinski ! ! * g++.old-deja/g++.other/crash18.C: Remove. ! ! 2003-07-31 Nathan Sidwell ! ! * g++.dg/template/explicit3.C: New. ! * g++.dg/template/explicit4.C: New. ! * g++.dg/template/explicit5.C: New. ! ! PR c++/11347 ! * g++.dg/template/memtmpl1.C: New. ! ! 2003-07-29 Andrew Pinski ! ! PR target/11565 ! * gcc.dg/i386-387-1.c (dg-options): Add -march=i386. ! * gcc.dg/i386-387-5.c (dg-options): Likewise. ! ! 2003-07-30 Jan Hubicka ! ! * vtgc1.c: Kill. ! ! 2003-07-29 Zack Weinberg ! ! * gcc.dg/struct-in-proto-1.c: New test. ! ! 2003-07-29 Neil Booth ! ! * gcc.dg/cpp/include2.c: Only expect one message. ! ! 2003-07-29 Nathan Sidwell ! ! PR c++/9447 ! * g++.dg/template/using1.C: New test. ! * g++.dg/template/using2.C: New test. ! * g++.dg/template/using3.C: New test. ! * g++.dg/template/using4.C: New test. ! ! 2003-07-29 Alexandre Oliva ! ! * gcc.c-torture/execute/string-opt-9.c: strcmp returns int. ! * gcc.c-torture/execute/string-opt-10.c: Likewise. ! ! 2003-07-28 Jan Hubicka ! ! PR c++/11530 ! * g++.dg/opt/call1.C: New test. ! ! 2003-07-28 Alexandre Oliva ! ! PR c++/11667 ! * g++.dg/init/enum2.C: New test. ! * g++.dg/template/overload1.C: Add "-w" option. ! ! 2003-07-28 ! ! * gcc.dg/Wdeclaration-after-statement-1.c, ! gcc.dg/Wdeclaration-after-statement-2.c: New tests. ! ! 2003-07-28 Jakub Jelinek ! ! * gcc.c-torture/compile/20030725-1.c: New test. ! ! 2003-07-28 Aldy Hernandez ! ! * gcc.dg/20030505.c: Only run for SPE. ! Remove definition of opaque type. ! ! 2003-07-27 Mark Mitchell ! ! * g++.dg/template/ptrmem6.C: New test. 2003-07-26 Geoffrey Keating * gcc.c-torture/compile/zero-strct-2.c: New test. ! 2003-07-25 Geoffrey Keating ! * gcc.dg/intermod-1.c: New test. ! 2003-07-25 Nathan Sidwell ! PR c++/11617 ! * g++.dg/template/lookup2.C: New test. ! * g++.dg/template/memclass1.C: Remove instantiated from error. ! * g++.dg/other/error2.C: Tweak expected errors. ! PR c++/11596 ! * g++.dg/template/defarg3.C: New test. ! * g++.dg/ext/packed2.C: Pack member struct too. Explain why. 2003-07-24 Mark Mitchell *************** *** 586,605 **** PR c++/11513 * g++.dg/template/crash8.C: New test. 2003-07-23 Mark Mitchell PR c++/11645 * g++.dg/inherit/access4.C: New test. 2003-07-23 Nathan Sidwell ! PR c++/11282 ! * g++.dg/parse/crash7.C: New test. ! 2003-07-23 Mark Mitchell ! PR optimization/10679 ! * g++.dg/opt/inline4.C: New test. 2003-07-21 Eric Botcazou --- 3453,3548 ---- PR c++/11513 * g++.dg/template/crash8.C: New test. + 2003-07-23 Steven Bosscher + + PR c/10602 + * gcc.dg/noncompile/incomplete-2.c: New test. + 2003-07-23 Mark Mitchell PR c++/11645 * g++.dg/inherit/access4.C: New test. + PR c++/11517 + * g++.dg/expr/cond2.C: New test. + + PR optimization/10679 + * g++.dg/opt/inline4.C: New test. + 2003-07-23 Nathan Sidwell ! * g++.dg/parse/crash10: New test. ! 2003-07-22 Nathan Sidwell ! * g++.dg/ext/flexary1.C: New test. ! ! 2003-07-22 Kriang Lerdsuwanakij ! ! PR c++/10793 ! * g++.dg/template/crash9.C: New test. ! ! 2003-07-22 Volker Reichelt ! ! PR c++/3004 ! * g++.dg/parse/typedef3.C: New test. ! ! PR c++/7906 ! * g++.dg/parse/operator2.C: New test. ! ! PR c++/8895 ! * g++.dg/parse/def-tmpl-arg1.C: New test. ! ! PR c++/9282 ! * g++.dg/parse/funptr1.C: New test. ! ! PR c++/9452 ! * g++.dg/parse/ambig3.C: New test. ! ! PR c++/9454 ! * g++.dg/parse/operator3.C: New test. ! ! PR c++/9486 ! * g++.dg/parse/template10.C: New test. ! ! PR c++/9488 ! * g++.dg/parse/template11.C: New test. ! ! PR c++/10150 ! * g++.dg/parse/invalid-op1.C: New test. ! ! PR c++/10247 ! * g++.dg/parse/condexpr1.C: New test. ! ! 2003-07-22 Nathan Sidwell ! ! * g++.dg/ext/packed3.C: New test. ! * g++.dg/ext/packed4.C: New test. ! ! * gcc.dg/pack-test-3.c: New test. ! ! 2003-07-21 Janis Johnson ! ! * lib/compat.exp: Handle dg-options per source file. ! * g++.dg/compat/abi/bitfield1_x.C: Specify dg-options. ! * g++.dg/compat/abi/bitfield1_y.C: Ditto. ! * g++.dg/compat/abi/bitfield2_x.C: Ditto. ! * g++.dg/compat/abi/bitfield2_y.C: Ditto. ! * g++.dg/compat/abi/vbase8-10_x.C: Ditto. ! * g++.dg/compat/abi/vbase8-10_y.C: Ditto. ! * g++.dg/compat/abi/vbase8-21_x.C: Ditto. ! * g++.dg/compat/abi/vbase8-21_y.C: Ditto. ! * g++.dg/compat/abi/vbase8-22_x.C: Ditto. ! * g++.dg/compat/abi/vbase8-22_y.C: Ditto. ! * g++.dg/compat/abi/vbase8-4_x.C: Ditto. ! * g++.dg/compat/abi/vbase8-4_y.C: Ditto. ! * g++.dg/compat/break/bitfield7_x.C: Ditto. ! * g++.dg/compat/break/bitfield7_y.C: Ditto. ! ! 2003-07-21 Andrew Pinski ! ! PR c/10320 ! * gcc.c-torture/execute/20030718-1.c: New test. 2003-07-21 Eric Botcazou *************** *** 611,616 **** --- 3554,3580 ---- PR c++/11546 * g++.dg/template/lookup1.C: New test. + 2003-07-19 Zack Weinberg + + * gcc.dg/noncompile/label-1.c: New comprehensive test case for + diagnostics of ill-formed constructs involving labels. + * gcc.dg/noncompile/label-lineno-1.c: Add error regexp for + the new 'previously defined here' message. + + 2003-07-18 Nathan Sidwell + + * g++.dg/parse/non-dependent2.C: New test. + + 2003-07-18 Andrew Pinski + + * g++.dg/init/init-ref4.C: xfail on targets without + weak symbols. + + 2003-07-17 Jakub Jelinek + + PR target/11087 + * gcc.c-torture/execute/20030717-1.c: New test. + 2003-07-18 Eric Botcazou * g++.dg/opt/cfg1.C: New test. *************** *** 620,639 **** --- 3584,3697 ---- PR optimization/11557 * gcc.dg/20030717-1.c: New test. + 2003-07-17 Andrew Pinski + + PR c++/10476 + * g++.dg/expr/crash-1.C: New test. + + PR c++/11027 + * g++.dg/template/init3.C: New test. + + PR c++/8222 + * g++.dg/template/non-dependent1.C: New test. + + PR c++/11070 + * g++.dg/template/non-dependent2.C: New test. + + PR c++/11071 + * g++.dg/template/non-dependent3.C: New test. + + PR c++/9907 + * g++.dg/template/sizeof5.C: New test. + + 2003-07-17 Geoffrey Keating + + PR 11498 + * gcc.c-torture/compile/mangle-1.c: New file. + + 2003-07-17 Kriang Lerdsuwanakij + + PR c++/7809 + * g++.dg/parse/access3.C: New test. + + 2003-07-17 Andrew Pinski + + PR c++/11384 + * g++.dg/init/init-ref4.C: New test. + + 2003-07-16 Mark Mitchell + + PR c++/11547 + * g++.dg/parse/constant3.C: New test. + * g++.dg/parse/crash7.C: Likewise. + + 2003-07-16 Andrew Pinski + + PR target/11008 + * gcc.dg/i386-pentium4-not-mull.c: New. + + 2003-07-16 J"orn Rennecke + + * gcc.dg/asm-names.c (ymain): Make it weak. + + 2003-07-16 Kriang Lerdsuwanakij + + PR c++/5421 + * g++.dg/template/friend21.C: New test. + + 2003-07-16 Jakub Jelinek + + * gcc.dg/cleanup-8.c: New test. + * gcc.dg/cleanup-9.c: New test. + + 2003-07-16 Danny Smith + + * g++.dg/ext/dll-MI1.h: New file. + * g++.dg/ext/dllexport-MI1.C: New file. + * g++.dg/ext/dllimport-MI1.C: New file. + + 2003-07-15 Jakub Jelinek + + * gcc.c-torture/execute/string-opt-8.c (main): Remove i370 and s390, + it does not have cmpstrsi patterns (just cmpmemsi). + 2003-07-15 Mark Mitchell PR debug/11473 * g++.dg/debug/debug8.C: New test. + 2003-07-15 Kriang Lerdsuwanakij + + PR c++/10108 + * g++.dg/template/crash7.C: New test. + + 2003-07-15 Kazu Hirata + + PR target/10795 + * gcc.c-torture/compile/20030708-1.c: New. + 2003-07-15 Eric Botcazou * gcc.c-torture/execute/20030715-1.c: New test. + 2003-07-14 Geoffrey Keating + + * gcc.dg/pch/inline-3.c: New file. + * gcc.dg/pch/inline-3.hs: New file. + * gcc.dg/pch/inline-4.c: New file. + * gcc.dg/pch/inline-4.hs: New file. + 2003-07-14 Mark Mitchell + PR c++/11509 + * g++.dg/template/crash6.C: New test. + PR c++/7053 * g++.dg/template/friend20.C: New test. + PR c++/7019 + * g++.dg/template/overload2.C: New test. + 2003-07-14 Franz Sirl PR optimization/11440 *************** *** 649,684 **** PR c++/11503 * g++.dg/template/anon1.C: New test. ! 2003-07-13 Roger Sayle ! ! PR optimization/11059 ! * g++.dg/opt/emptyunion.C: New testcase. ! ! 2003-07-11 Danny Smith ! ! Backport from mainline. ! 2003-05-21 Danny Smith ! PR c++/9738 ! * g++.dg/ext/dllimport2.C: New file. ! * g++.dg/ext/dllimport3.C: New file. ! 2003-07-04 Danny Smith ! PR c++/5287, PR c++/7910, PR c++/11021 ! * testsuite/g++.dg/ext/dllimport1.C: Add mingw32 as target. Add ! tests for warnings. ! * g++.dg/ext/dllimport2.C: Add tests for warnings. ! * g++.dg/ext/dllimport3.C: Likewise. ! * g++.dg/ext/dllimport4.C: New file. ! * g++.dg/ext/dllimport5.C: New file. ! * g++.dg/ext/dllimport6.C: New file. ! * g++.dg/ext/dllimport7.C: New file. ! * g++.dg/ext/dllimport8.C: New file. ! * g++.dg/ext/dllimport9.C: New file. ! * g++.dg/ext/dllimport10.C: New file. ! * g++.dg/ext/dllexport1.C: New file. 2003-07-11 Mark Mitchell --- 3707,3739 ---- PR c++/11503 * g++.dg/template/anon1.C: New test. ! PR c++/11493 ! PR c++/11495 ! * g++.dg/parse/template9.C: Likewise. ! * g++.dg/template/crash4.C: New test. ! * g++.dg/template/koenig1.C: Likewise. ! * g++.old-deja/g++.benjamin/tem03.C: Adjust error markers. ! * g++.old-deja/g++.benjamin/tem06.C: Declare "x". ! * g++.old-deja/g++.jason/overload33.C: Use this-> when calling ! functions. ! * g++.old-deja/g++.jason/template36.C: Likewise. ! * g++.old-deja/g++.mike/p1989.C: Likewise. ! * g++.old-deja/g++.pt/lookup2.C: Use -fpermissive when compiling. ! * g++.old-deja/g++.pt/ttp20.C: Use this->. ! * g++.old-deja/g++.pt/ttp21.C: Use this->. ! * g++.old-deja/g++.pt/typename13.C: Use -fpermissive when ! compiling. ! * g++.old-deja/g++.pt/union2.C: Use this->. ! 2003-07-11 Jakub Jelinek ! * gcc.dg/20030711-1.c: New test. ! 2003-07-11 Nathan Sidwell ! PR c++/11050 ! * g++.dg/parse/args1.C: New test. ! * g++.pt/defarg8.C: Change expected errors. 2003-07-11 Mark Mitchell *************** *** 688,773 **** PR c++/10558 * g++.dg/parse/template8.C: New test. 2003-07-10 Mark Mitchell PR c++/10032 * g++.dg/warn/pedantic1.C: New test. 2003-07-10 Kriang Lerdsuwanakij PR c++/10849 * g++.dg/template/access12.C: New test. 2003-07-08 Jakub Jelinek PR c/11420 ! * gcc.dg/20030707-1.c: New test. * g++.dg/opt/strength-reduce.C: New test. 2003-07-07 Richard Kenner Eric Botcazou * g++.dg/opt/stack1.C: New test. - 2003-07-06 Mark Mitchell - - PR c++/11345 - * g++.old-deja/g++.jason/access8.C: Reove error marker. - 2003-07-05 Mark Mitchell PR c++/11431 * g++.dg/expr/static_cast3.C: New test. 2003-07-03 Eric Botcazou * gcc.dg/i386-call-1.c: New test. 2003-07-03 Roger Sayle PR target/10700 * gcc.c-torture/compile/20030703-1.c: New test case. 2003-07-03 Eric Botcazou * gcc.dg/i386-volatile-1.c: New test. ! 2003-07-01 Mark Mitchell ! PR c++/6949 ! * g++.dg/template/local3.C: New test. ! 2003-06-30 Giovanni Bajo ! * g++.dg/other/error5.C: Change line number of expected error. 2003-07-01 Mark Mitchell ! PR c++/11137 ! * g++.dg/init/attrib1.C: New test. PR c++/11149 * g++.dg/lookup/scoped6.C: New test. 2003-07-01 Mark Mitchell PR c++/9559 * g++.dg/init/static1.C: New test. 2003-06-30 Giovanni Bajo * g++.dg/other/error6.C: New test. 2003-06-30 Giovanni Bajo PR c++/11106 * g++.dg/other/error5.C: New test. 2003-06-27 Mark Mitchell PR c++/10468 ! * g++.dg/ext/typeof5.C: New test. 2003-06-27 Mark Mitchell --- 3743,4080 ---- PR c++/10558 * g++.dg/parse/template8.C: New test. + PR c++/8327 + * g++.dg/template/scope1.C: New test. + + * g++.dg/warn/Wsign-compare-1.C: New test. + + 2003-07-10 Kazu Hirata + + * gcc.dg/20021018-1.c: Disable if the sizeof (int) < 4. + 2003-07-10 Mark Mitchell + PR c++/9411 + * g++.dg/template/explicit2.C: New test. + PR c++/10032 * g++.dg/warn/pedantic1.C: New test. + 2003-07-10 Nathan Sidwell + + PR c++ 9483 + * g++.dg/other/field1.C: New test. + + 2003-07-10 Kazu Hirata + + PR c/11449 + * gcc.c-torture/compile/20030707-1.c: New. + 2003-07-10 Kriang Lerdsuwanakij PR c++/10849 * g++.dg/template/access12.C: New test. + 2003-07-09 Nathan Sidwell + + * g++.dg/bprob/bprob.exp (prof_ext): Update. + * g77.dg/bprob/bprob.exp (prof_ext): Update. + * gcc.misc-tests/bprob.exp (prof_ext): Update. + * gcc.misc-tests/gcov.exp: Update + * g++.dg/gcov/gcov.exp: Update + * lib/gcov.exp: Update. + + 2003-07-08 Mark Mitchell + + * g++.dg/abi/mangle17.C: Make sure template expressions are + dependent. + * g++.dg/abi/mangle4.C: Mark erroneous casts. + * g++.dg/debug/debug7.C: Mark erronous new-declarator. + * g++.dg/opt/stack1.C: Remove erroneous code. + * g++.dg/parse/template7.C: New test. + * g++.dg/template/dependent-expr1.C: Mark erroneous code. + * g++.old-deja/g++.pt/crash4.C: Likewise. + + 2003-07-09 John David Anglin + + * gcc.dg/const-elim-1.c (dg-final): Change regexp to match labels + with zero or one occurence of `$' after the initial `L'. + + 2003-07-08 Kazu Hirata + + * gcc.c-torture/compile/20030704-1.c: Add a comment. + + 2003-07-08 Roger Sayle + + PR c/11370 + * gcc.dg/Wunreachable-6.c: New testcase. + * gcc.dg/Wunreachable-7.c: New testcase. + 2003-07-08 Jakub Jelinek PR c/11420 ! * gcc.dg/20030708-1.c: New test. ! ! 2003-07-08 Richard Sandiford ! ! * gcc.dg/compat/sdata-section.h: New file. ! * gcc.dg/compat/sdata-1_{x,y,main}.c: New test. ! * gcc.dg/torture/mips-sdata-1.c: New test. ! ! 2003-07-08 Kriang Lerdsuwanakij ! ! PR c++/11030 ! * g++.dg/template/friend19.C: New test. ! ! 2003-07-08 Jakub Jelinek * g++.dg/opt/strength-reduce.C: New test. + 2003-07-07 Roger Sayle + + PR target/10979 + * gcc.dg/20030707-1.c: New testcase. + + 2003-07-07 Roger Sayle + + PR optimization/11059 + * g++.dg/opt/emptyunion.C: New testcase. + 2003-07-07 Richard Kenner Eric Botcazou * g++.dg/opt/stack1.C: New test. 2003-07-05 Mark Mitchell + * g++.old-deja/g++.jason/typeid1.C: Make it a compile test, not a + run test. + PR c++/11431 * g++.dg/expr/static_cast3.C: New test. + 2003-07-04 Zack Weinberg + + * gcc.c-torture/execute/wchar_t-1.x: New file; XFAIL wchar_t-1.c + everywhere. + * gcc.dg/concat.c: Concatenation of string constants with + __FUNCTION__ / __PRETTY_FUNCTION__ is now a hard error. + * gcc.dg/wtr-strcat-1.c: Loosen dg-warning regexp. + * gcc.dg/cpp/escape-2.c: Use wide character constants where + necessary to avoid multi-character character constant warning. + * gcc.dg/cpp/escape.c: Likewise. + * gcc.dg/cpp/ucs.c: Likewise. + Remove backslashes from dg-bogus comments, as they confuse Tcl. + Fix a typo. + + 2003-07-04 Kazu Hirata + + PR c/11428 + * gcc.c-torture/compile/20030704-1.c: New. + + 2003-07-04 Kazu Hirata + + * gcc.dg/compat/fnptr-by-value-1_x.c: Add a prototype for testva. + + 2003-07-04 Danny Smith + + PR c++/5287, PR c++/7910, PR c++/11021 + * g++.dg/ext/dllimport1.C: Add mingw32 as target. Add + tests for warnings. + * g++.dg/ext/dllimport2.C: Add tests for warnings. + * g++.dg/ext/dllimport3.C: Likewise. + * g++.dg/ext/dllimport4.C: New file. + * g++.dg/ext/dllimport5.C: New file. + * g++.dg/ext/dllimport6.C: New file. + * g++.dg/ext/dllimport7.C: New file. + * g++.dg/ext/dllimport8.C: New file. + * g++.dg/ext/dllimport9.C: New file. + * g++.dg/ext/dllimport10.C: New file. + * g++.dg/ext/dllexport1.C: New file. + + 2003-07-03 Mark Mitchell + + * g++.old-deja/g++.jason/typeid1.C: Add dg-error marker. + * g++.old-deja/g++.mike/net36.C: Tweak error messages. + + 2003-07-03 Roger Sayle + + * gcc.dg/builtins-25.c: New testcase. + * gcc.dg/builtins-26.c: New testcase. + + 2003-07-03 Janis Johnson + + * gcc.dg/compat/vector-defs.h: New file. + * gcc.dg/compat/vector-setup.h: New file. + * gcc.dg/compat/vector-check.h: New file. + * gcc.dg/compat/vector-1_main.c: New file. + * gcc.dg/compat/vector-1_x.c: New file. + * gcc.dg/compat/vector-1_y.c: New file. + * gcc.dg/compat/vector-2_main.c: New file. + * gcc.dg/compat/vector-2_x.c: New file. + * gcc.dg/compat/vector-2_y.c: New file. + + * gcc.dg/compat/fnptr-by-value-1_main.c: New file. + * gcc.dg/compat/fnptr-by-value-1_x.c: New file. + * gcc.dg/compat/fnptr-by-value-1_y.c: New file. + * gcc.dg/compat/struct-align-1.h: New file. + * gcc.dg/compat/struct-align-1_main.c: New file. + * gcc.dg/compat/struct-align-1_x.c: New file. + * gcc.dg/compat/struct-align-1_y.c: New file. + * gcc.dg/compat/struct-align-2.h: New file. + * gcc.dg/compat/struct-align-2_main.c: New file. + * gcc.dg/compat/struct-align-2_x.c: New file. + * gcc.dg/compat/struct-align-2_y.c: New file. + + * gcc.dg/compat/compat-common.h (DEBUG_FINI): New. + * gcc.dg/compat/scalar-by-value-1_x.c: Use it. + * gcc.dg/compat/scalar-by-value-2_x.c: Ditto. + * gcc.dg/compat/scalar-by-value-3_x.c: Ditto. + * gcc.dg/compat/scalar-by-value-4_x.c: Ditto. + * gcc.dg/compat/scalar-return-1_x.c: Ditto. + * gcc.dg/compat/scalar-return-2_x.c: Ditto. + * gcc.dg/compat/scalar-return-3_x.c: Ditto. + * gcc.dg/compat/scalar-return-4_x.c: Ditto. + * gcc.dg/compat/struct-by-value-10_x.c: Ditto. + * gcc.dg/compat/struct-by-value-11_x.c: Ditto. + * gcc.dg/compat/struct-by-value-12_x.c: Ditto. + * gcc.dg/compat/struct-by-value-13_x.c: Ditto. + * gcc.dg/compat/struct-by-value-14_x.c: Ditto. + * gcc.dg/compat/struct-by-value-15_x.c: Ditto. + * gcc.dg/compat/struct-by-value-16_x.c: Ditto. + * gcc.dg/compat/struct-by-value-17_x.c: Ditto. + * gcc.dg/compat/struct-by-value-18_x.c: Ditto. + * gcc.dg/compat/struct-by-value-2_x.c: Ditto. + * gcc.dg/compat/struct-by-value-3_x.c: Ditto. + * gcc.dg/compat/struct-by-value-4_x.c: Ditto. + * gcc.dg/compat/struct-by-value-5_x.c: Ditto. + * gcc.dg/compat/struct-by-value-6_x.c: Ditto. + * gcc.dg/compat/struct-by-value-7_x.c: Ditto. + * gcc.dg/compat/struct-by-value-8_x.c: Ditto. + * gcc.dg/compat/struct-by-value-9_x.c: Ditto. + * gcc.dg/compat/struct-return-10_x.c: Ditto. + * gcc.dg/compat/struct-return-2_x.c: Ditto. + * gcc.dg/compat/struct-return-3_x.c: Ditto. + 2003-07-03 Eric Botcazou * gcc.dg/i386-call-1.c: New test. + 2003-07-03 Nathan Sidwell + + PR c++/9162 + * g++.dg/parse/defarg4.C: New. + 2003-07-03 Roger Sayle PR target/10700 * gcc.c-torture/compile/20030703-1.c: New test case. + 2003-07-03 Mark Mitchell + + * g++.dg/template/local3.C: Remove extra semicolon. + 2003-07-03 Eric Botcazou * gcc.dg/i386-volatile-1.c: New test. ! 2003-07-02 Nathan Sidwell ! PR c++/11072 ! * g++.dg/other/offsetof2.C: XFAIL. ! * g++.dg/other/offsetof5.C: New. ! PR c++/10219 ! * g++.dg/template/error1.C: New. ! PR c++/9779 ! * g++.dg/template/dependent-expr1.C: New. 2003-07-01 Mark Mitchell ! PR c++/6949 ! * g++.dg/template/local3.C: New test. PR c++/11149 * g++.dg/lookup/scoped6.C: New test. + 2003-07-01 Giovanni Bajo + + PR c++/8046 + * g++.dg/other/error7.C: New test. + + 2003-07-01 Kazu Hirata + + * g++.old-deja/g++.abi/vbase1.C: Fix comment typos. + * g++.old-deja/g++.abi/vtable3.h: Likewise. + * g++.old-deja/g++.law/code-gen5.C: Likewise. + * g++.old-deja/g++.other/union2.C: Likewise. + * gcc.dg/c90-const-expr-2.c: Likewise. + * gcc.dg/c90-const-expr-3.c: Likewise. + * gcc.dg/c99-const-expr-2.c: Likewise. + * gcc.dg/c99-const-expr-3.c: Likewise. + * gcc.dg/concat.c: Likewise. + 2003-07-01 Mark Mitchell PR c++/9559 * g++.dg/init/static1.C: New test. + 2003-06-30 Volker Reichelt + + * Changelog: Remove ">>>>>>>" from previous change. + + 2003-06-30 Volker Reichelt + + * g++.old-deja/g++.niklas/README: Fix spelling for "testcase". + * g++.old-deja/g++.other/access2.C: Likewise. + * g++.old-deja/g++.other/decl2.C: Likewise. + * gcc.c-torture/execute/20020615-1.c: Likewise. + + 2003-06-30 Giovanni Bajo + + PR c++/4933 + * g++.dg/template/sizeof4.C: New test. + 2003-06-30 Giovanni Bajo * g++.dg/other/error6.C: New test. + 2003-06-30 Giovanni Bajo + + PR c++/10750 + * g++.dg/parse/constant2.C: New test. + 2003-06-30 Giovanni Bajo PR c++/11106 * g++.dg/other/error5.C: New test. + 2003-06-29 Kaveh R. Ghazi + + * gcc.dg/format/gcc_diag-1.c: New test. + + 2003-06-28 Ulrich Weigand + + * gcc.c-torture/execute/multi-ix.c: Fix off-by-one bugs. + + 2003-06-28 Nathan Sidwell + + * g++.old-deja/g++.robertl/eb133.C: Set expected line number. + * g++.old-deja/g++.robertl/eb133a.C: Likewise. + * g++.old-deja/g++.robertl/eb133b.C: Likewise. + + 2003-06-28 Jakub Jelinek + + * gcc.c-torture/execute/builtins/string-8.c: New test. + * gcc.c-torture/execute/builtins/string-8-lib.c: New. + * gcc.c-torture/execute/stdio-opt-1.c (main): Add new tests. + * gcc.c-torture/execute/string-opt-7.c (main): Add new test. + 2003-06-27 Mark Mitchell PR c++/10468 ! * g++.dg/ext/typeof6.C: New test. 2003-06-27 Mark Mitchell *************** *** 783,788 **** --- 4090,4127 ---- PR c++/11332 * g++.dg/expr/static_cast2.C: New test. + 2003-06-26 Roger Sayle + Jakub Jelinek + + * gcc.c-torture/execute/string-opt-16.c: Remove test for disabled + sprintf(dst,"%s",src) optimization. + * gcc.c-torture/execute/20030626-1.c: New test case. + * gcc.c-torture/execute/20030626-2.c: New test case. + + 2003-06-26 J"orn Rennecke + + * gcc.c-torture/execute/multi-ix.c: New test. + + * gcc.c-torture/execute/simd-4.c (main): + Added missing semicolon at end of union. + + 2003-06-26 Giovanni Bajo + + PR c++/8266 + * g++.dg/template/explicit-instantiation3.C: New test. + + 2003-06-26 Eric Botcazou + + * gcc.dg/20030626-1.c: Use signed char. + + 2003-06-26 Eric Botcazou + + * gcc.dg/20030626-1.c: New test. + + 2003-06-26 Neil Booth + + * const-str-2.m: Update. + 2003-06-25 Mark Mitchell PR c++/10990 *************** *** 794,819 **** PR c++/10931 * g++.dg/expr/static_cast1.C: New test. - 2003-06-25 Richard Sandiford - - * gcc.c-torture/compile/20030625-1.c: New test. - 2003-06-25 Josef Zlomek * gcc.dg/20030625-1.c: New test. 2003-06-24 Mark Mitchell PR c++/5754 * g++.dg/parse/crash6.C: New test. 2003-06-23 Jakub Jelinek * g++.dg/opt/operator1.C: New test. 2003-06-21 Gabriel Dos Reis ! * g++.old-deja/g++.benjamin/16077.C: Add -Wconversion option. * g++.old-deja/g++.other/conv7.C: Likewise * g++.old-deja/g++.other/overcnv2.C: Likewise. * g++.old-deja/g++.other/overload14.C: Likewise. --- 4133,4170 ---- PR c++/10931 * g++.dg/expr/static_cast1.C: New test. 2003-06-25 Josef Zlomek * gcc.dg/20030625-1.c: New test. + 2003-06-24 Roger Sayle + + * gcc.c-torture/compile/20030624-1.c: New test case. + + 2003-06-24 Jakub Jelinek + + * gcc.c-torture/execute/string-opt-17.c: New test. + 2003-06-24 Mark Mitchell PR c++/5754 * g++.dg/parse/crash6.C: New test. + 2003-06-23 Roger Sayle + + * gcc.dg/builtins-24.c: New test case. + 2003-06-23 Jakub Jelinek * g++.dg/opt/operator1.C: New test. + 2003-06-22 Roger Sayle + + * gcc.c-torture/execute/string-opt-16.c: New test case. + 2003-06-21 Gabriel Dos Reis ! * g++.old-deja/g++.benjamin/16077.C: Add -Wconversion option. * g++.old-deja/g++.other/conv7.C: Likewise * g++.old-deja/g++.other/overcnv2.C: Likewise. * g++.old-deja/g++.other/overload14.C: Likewise. *************** *** 826,832 **** 2003-06-20 Mark Mitchell PR c++/10888 ! * g++.dg/warn/Winline-2.C: New test. PR c++/10845 * g++.dg/template/member3.C: New test. --- 4177,4200 ---- 2003-06-20 Mark Mitchell PR c++/10888 ! * g++.dg/warn/Winline-3.C: New test. ! ! 2003-06-20 Mark Mitchell ! ! * lib/target-supports.exp (check_alias_available): Make the test ! program acceptable to the Solaris assembler. ! ! PR c++/10749 ! * g++.dg/template/memclass2.C: New test. ! ! 2003-06-20 Mark Mitchell ! Eric Botcazou ! ! * lib/gcc-dg.exp (dg-xfail-if): Do not process conditional xfail ! data for non-matching targets. ! * gcc.c-torture/compile/simd-5.c: Fix typo in conditional xfail. ! ! 2003-06-20 Mark Mitchell PR c++/10845 * g++.dg/template/member3.C: New test. *************** *** 840,847 **** * g++.dg/template/static4.C: New test. * g++.old-deja/g++.other/anon7.C: Remove spurious error messages. - 2003-06-19 Mark Mitchell - PR c++/11041 * g++.dg/init/ref7.C: New test. --- 4208,4213 ---- *************** *** 853,866 **** * g++.dg/anew3.C: New test. * g++.dg/anew4.C: New test. ! 2003-06-19 Loren James Rittle ! * gcc.dg/cpp/redef3.c: New file. 2003-06-17 Mark Mitchell PR c++/10712 ! * g++.dg/lookup/using3.C: New test. PR c++/11105 * g++.dg/abi/conv1.C: Remove it. --- 4219,4250 ---- * g++.dg/anew3.C: New test. * g++.dg/anew4.C: New test. ! 2003-06-19 Kazu Hirata ! * gcc.c-torture/compile/simd-5.c: Don't XFAIL on H8. ! ! 2003-06-19 J"orn Rennecke ! ! * gcc.c-torture/execute/simd-4.c (main): Make expected value ! endian-dependent. ! ! 2003-06-17 Benjamin Kosnik ! ! * lib/g++.exp (g++_include_flags): Tweak path to testsuite_flags. ! Remove cruft. ! ! 2003-06-17 Kazu Hirata ! ! * gcc.c-torture/compile/20020604-1.c: Use dg-xfail-if for h8300. ! * gcc.c-torture/compile/961203-1.c: Likewise. ! * gcc.c-torture/compile/980506-1.c: Likewise. 2003-06-17 Mark Mitchell PR c++/10712 ! * g++.dg/lookup/using7.C: New test. ! ! 2003-06-17 Mark Mitchell PR c++/11105 * g++.dg/abi/conv1.C: Remove it. *************** *** 869,903 **** * g++.old-deja/g++.ext/pretty2.C: Do not test __FUNCTION__ for a conversion operator. 2003-06-13 Eric Botcazou * gcc.c-torture/execute/20030611-1.c: New test. 2003-06-12 Mark Mitchell PR c++/10635 * g++.dg/expr/cast1.C: New test. ! 2003-06-10 Jakub Jelinek ! * gcc.dg/noreturn-1.c: Move noreturn warning line. ! * gcc.dg/return-type-1.c: Move control reaches end warning line. 2003-06-10 Richard Henderson * gcc.dg/asm-7.c: Adjust expected warning text. 2003-06-08 Richard Henderson * gcc.dg/20011029-2.c: Fix the array reference. * gcc.dg/asm-7.c: New. 2003-06-08 Kriang Lerdsuwanakij PR c++/11039 * g++.dg/warn/implicit-typename2.C: New test. * g++.dg/warn/implicit-typename3.C: New test. 2003-06-04 Richard Henderson * gcc.dg/cleanup-1.c: New. --- 4253,4691 ---- * g++.old-deja/g++.ext/pretty2.C: Do not test __FUNCTION__ for a conversion operator. + 2003-06-17 Janis Johnson + + * gcc.dg/compat/compat-common.h (DEBUG_INIT): New. + * gcc.dg/compat/scalar-by-value-1_x.c: Use it. + * gcc.dg/compat/scalar-by-value-2_x.c: Ditto. + * gcc.dg/compat/scalar-by-value-3_x.c: Ditto. + * gcc.dg/compat/scalar-by-value-4_x.c: Ditto. + * gcc.dg/compat/scalar-return-1_x.c: Ditto. + * gcc.dg/compat/scalar-return-2_x.c: Ditto. + * gcc.dg/compat/scalar-return-3_x.c: Ditto. + * gcc.dg/compat/scalar-return-4_x.c: Ditto. + * gcc.dg/compat/struct-by-value-10_x.c: Ditto. + * gcc.dg/compat/struct-by-value-11_x.c: Ditto. + * gcc.dg/compat/struct-by-value-12_x.c: Ditto. + * gcc.dg/compat/struct-by-value-13_x.c: Ditto. + * gcc.dg/compat/struct-by-value-14_x.c: Ditto. + * gcc.dg/compat/struct-by-value-15_x.c: Ditto. + * gcc.dg/compat/struct-by-value-16_x.c: Ditto. + * gcc.dg/compat/struct-by-value-17_x.c: Ditto. + * gcc.dg/compat/struct-by-value-18_x.c: Ditto. + * gcc.dg/compat/struct-by-value-2_x.c: Ditto. + * gcc.dg/compat/struct-by-value-3_x.c: Ditto. + * gcc.dg/compat/struct-by-value-4_x.c: Ditto. + * gcc.dg/compat/struct-by-value-5_x.c: Ditto. + * gcc.dg/compat/struct-by-value-6_x.c: Ditto. + * gcc.dg/compat/struct-by-value-7_x.c: Ditto. + * gcc.dg/compat/struct-by-value-8_x.c: Ditto. + * gcc.dg/compat/struct-by-value-9_x.c: Ditto. + * gcc.dg/compat/struct-return-10_x.c: Ditto. + * gcc.dg/compat/struct-return-2_x.c: Ditto. + * gcc.dg/compat/struct-return-3_x.c: Ditto. + + 2003-06-16 Mark Mitchell + + * lib/gcc-dg.exp (dg-xfail-if): Fix thinko. + * gcc.c-torture/compile/simd-5.c: Remove spurious PowerPC-64 XFAIL + indications. + + 2003-06-16 Roger Sayle + + * gcc.dg/i386-387-5.c: New test case. + * gcc.dg/i386-387-6.c: New test case. + * gcc.dg/builtins-23.c: New test case. + + 2003-06-15 Roger Sayle + + * gcc.dg/builtins-22.c: New test case. + * gcc.dg/i386-387-1.c: Update to test exp. + * gcc.dg/i386-387-2.c: Likewise. + + 2003-06-13 Kaveh R. Ghazi + + * gcc.dg/format/asm_fprintf-1.c: Update width/precision checks. + + 2003-06-12 Mark Mitchell + + * lib/gcc-dg.exp (dg-require-dll): New function. + (dg-xfail-if): Likewise. + * gcc.c-torture/compile/compile.exp: Use dg rather than c-torture + driver. + + * gcc.c-torture/compile/20000804-1.c: Convert to dg format. + * gcc.c-torture/compile/20001205-1.c: Likewise. + * gcc.c-torture/compile/20001226-1.c: Likewise. + * gcc.c-torture/compile/20010518-2.c: Likewise. + * gcc.c-torture/compile/20020312-1.c: Likewise. + * gcc.c-torture/compile/20020604-1.c: Likewise. + * gcc.c-torture/compile/920501-12.c: Likewise. + * gcc.c-torture/compile/920501-4.c: Likewise. + * gcc.c-torture/compile/920520-1.c: Likewise. + * gcc.c-torture/compile/920521-1.c: Likewise. + * gcc.c-torture/compile/920625-1.c: Likewise. + * gcc.c-torture/compile/961203-1.c: Likewise. + * gcc.c-torture/compile/980506-1.c: Likewise. + * gcc.c-torture/compile/981006-1.c: Likewise. + * gcc.c-torture/compile/981022-1.c: Likewise. + * gcc.c-torture/compile/981223-1.c: Likewise. + * gcc.c-torture/compile/990617-1.c: Likewise. + * gcc.c-torture/compile/dll.c: Likewise. + * gcc.c-torture/compile/labels-3.c: Likewise. + * gcc.c-torture/compile/mipscop-1.c: Likewise. + * gcc.c-torture/compile/mipscop-2.c: Likewise. + * gcc.c-torture/compile/mipscop-3.c: Likewise. + * gcc.c-torture/compile/mipscop-4.c: Likewise. + * gcc.c-torture/compile/simd-5.c: Likewise. + * gcc.c-torture/compile/20000804-1.x: Remove. + * gcc.c-torture/compile/20001205-1.x: Likewise. + * gcc.c-torture/compile/20001226-1.x: Likewise. + * gcc.c-torture/compile/20010518-2.x: Likewise. + * gcc.c-torture/compile/20020312-1.x: Likewise. + * gcc.c-torture/compile/20020604-1.x: Likewise. + * gcc.c-torture/compile/920501-12.x: Likewise. + * gcc.c-torture/compile/920501-4.x: Likewise. + * gcc.c-torture/compile/920520-1.x: Likewise. + * gcc.c-torture/compile/920521-1.x: Likewise. + * gcc.c-torture/compile/920625-1.x: Likewise. + * gcc.c-torture/compile/961203-1.x: Likewise. + * gcc.c-torture/compile/980506-1.x: Likewise. + * gcc.c-torture/compile/981006-1.x: Likewise. + * gcc.c-torture/compile/981022-1.x: Likewise. + * gcc.c-torture/compile/981223-1.x: Likewise. + * gcc.c-torture/compile/990617-1.x: Likewise. + * gcc.c-torture/compile/mipscop-1.x: Likewise. + * gcc.c-torture/compile/mipscop-2.x: Likewise. + * gcc.c-torture/compile/mipscop-3.x: Likewise. + * gcc.c-torture/compile/mipscop-4.x: Likewise. + * gcc.c-torture/compile/simd-5.x: Likewise. + + * gcc.c-torture/compile/20021205-1.c: Remove bogus dg commands. + 2003-06-13 Eric Botcazou * gcc.c-torture/execute/20030611-1.c: New test. + 2003-06-12 Roger Sayle + + PR middle-end/168 + * gcc.dg/20030612-1.c: New test case. + 2003-06-12 Mark Mitchell PR c++/10635 * g++.dg/expr/cast1.C: New test. ! 2003-06-12 Roger Sayle ! * gcc.dg/builtins-21.c: New test case. ! ! 2003-06-11 Kelley Cook ! ! * lib/gcc.exp (gcc_target_compile): Put TOOL_OPTIONS at front of ! options instead of at the end. ! * lib/objc.exp (objc_target_compile): Likewise. ! ! 2003-06-11 Mark Mitchell ! ! PR c++/10432 ! * g++.dg/parse/error1.C: New test. ! ! 2003-06-11 Janis Johnson ! ! * gcc.dg/compat/struct-by-value-11_main.c: New file. ! * gcc.dg/compat/struct-by-value-11_x.c: New file. ! * gcc.dg/compat/struct-by-value-11_y.c: New file. ! * gcc.dg/compat/struct-by-value-12_main.c: New file. ! * gcc.dg/compat/struct-by-value-12_x.c: New file. ! * gcc.dg/compat/struct-by-value-12_y.c: New file. ! * gcc.dg/compat/struct-by-value-13_main.c: New file. ! * gcc.dg/compat/struct-by-value-13_x.c: New file. ! * gcc.dg/compat/struct-by-value-13_y.c: New file. ! * gcc.dg/compat/struct-by-value-14_main.c: New file. ! * gcc.dg/compat/struct-by-value-14_x.c: New file. ! * gcc.dg/compat/struct-by-value-14_y.c: New file. ! * gcc.dg/compat/struct-by-value-15_main.c: New file. ! * gcc.dg/compat/struct-by-value-15_x.c: New file. ! * gcc.dg/compat/struct-by-value-15_y.c: New file. ! * gcc.dg/compat/struct-by-value-16_main.c: New file. ! * gcc.dg/compat/struct-by-value-16_x.c: New file. ! * gcc.dg/compat/struct-by-value-16_y.c: New file. ! * gcc.dg/compat/struct-by-value-17_main.c: New file. ! * gcc.dg/compat/struct-by-value-17_x.c: New file. ! * gcc.dg/compat/struct-by-value-17_y.c: New file. ! * gcc.dg/compat/struct-by-value-18_main.c: New file. ! * gcc.dg/compat/struct-by-value-18_x.c: New file. ! * gcc.dg/compat/struct-by-value-18_y.c: New file. ! ! * gcc.dg/compat/scalar-by-value-3_main.c: New file. ! * gcc.dg/compat/scalar-by-value-3_x.c: New file. ! * gcc.dg/compat/scalar-by-value-3_y.c: New file. ! * gcc.dg/compat/scalar-by-value-4_main.c: New file. ! * gcc.dg/compat/scalar-by-value-4_x.c: New file. ! * gcc.dg/compat/scalar-by-value-4_y.c: New file. ! * gcc.dg/compat/scalar-return-3_main.c: New file. ! * gcc.dg/compat/scalar-return-3_x.c: New file. ! * gcc.dg/compat/scalar-return-3_y.c: New file. ! * gcc.dg/compat/scalar-return-4_main.c: New file. ! * gcc.dg/compat/scalar-return-4_x.c: New file. ! * gcc.dg/compat/scalar-return-4_y.c: New file. ! ! 2003-06-10 Janis Johnson ! ! * gcc.dg/compat/fp2-struct-check.h: New file. ! * gcc.dg/compat/fp2-struct-defs.h: New file. ! * gcc.dg/compat/fp2-struct-init.h: New file. ! * gcc.dg/compat/struct-by-value-10_main.c: New file. ! * gcc.dg/compat/struct-by-value-10_x.c: New file. ! * gcc.dg/compat/struct-by-value-10_y.c: New file. ! * gcc.dg/compat/struct-return-10_main.c: New file. ! * gcc.dg/compat/struct-return-10_x.c: New file. ! * gcc.dg/compat/struct-return-10_y.c: New file. ! ! * gcc.dg/compat/compat-common.h: New file. ! * gcc.dg/compat/fp-struct-check.h: Improve debugging output. ! * gcc.dg/compat/fp-struct-test-by-value-x.h: Ditto. ! * gcc.dg/compat/fp-struct-test-by-value-y.h: Ditto. ! * gcc.dg/compat/scalar-by-value-1_main.c: Ditto. ! * gcc.dg/compat/scalar-by-value-1_x.c: Ditto. ! * gcc.dg/compat/scalar-by-value-1_y.c: Ditto. ! * gcc.dg/compat/scalar-by-value-2_main.c: Ditto. ! * gcc.dg/compat/scalar-by-value-2_x.c: Ditto. ! * gcc.dg/compat/scalar-by-value-2_y.c: Ditto. ! * gcc.dg/compat/scalar-return-1_main.c: Ditto. ! * gcc.dg/compat/scalar-return-1_x.c: Ditto. ! * gcc.dg/compat/scalar-return-1_y.c: Ditto. ! * gcc.dg/compat/scalar-return-2_main.c: Ditto. ! * gcc.dg/compat/scalar-return-2_x.c: Ditto. ! * gcc.dg/compat/scalar-return-2_y.c: Ditto. ! * gcc.dg/compat/small-struct-check.h: Ditto. ! * gcc.dg/compat/struct-by-value-2_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-2_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-2_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-3_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-3_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-3_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-4_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-4_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-4_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-5_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-5_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-5_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-6_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-6_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-6_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-7_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-7_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-7_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-8_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-8_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-8_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-9_main.c: Ditto. ! * gcc.dg/compat/struct-by-value-9_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-9_y.c: Ditto. ! * gcc.dg/compat/struct-return-2_main.c: Ditto. ! * gcc.dg/compat/struct-return-2_x.c: Ditto. ! * gcc.dg/compat/struct-return-2_y.c: Ditto. ! * gcc.dg/compat/struct-return-3_main.c: Ditto. ! * gcc.dg/compat/struct-return-3_x.c: Ditto. ! * gcc.dg/compat/struct-return-3_y.c: Ditto. ! ! 2003-06-10 Geoffrey Keating ! ! * g++.dg/pch/static-1.C: New file. ! * g++.dg/pch/static-1.Hs: New file. 2003-06-10 Richard Henderson * gcc.dg/asm-7.c: Adjust expected warning text. + 2003-06-10 Roger Sayle + + * gcc.dg/builtins-20.c: New test case. + + 2003-06-10 Mark Mitchell + + PR c++/11131 + * g++.dg/opt/template1.C: New test. + + 2003-06-09 Mark Mitchell + + * lib/gcc-dg.exp (dg-test): Clear additional_files and + additional_sources. + + 2003-05-21 David Taylor + + * gcc.dg/Wpadded.c: New file. + + 2003-06-09 Mark Mitchell + + * gcc.dg/special/20000419-2.c: Fix dg-require-alias syntax. + * gcc.dg/special/weak-2.c: Add dg-require-weak. + * gcc.dg/weak/weak-3.c: Reverse order of dg-do and + dg-require-weak. + + 2003-06-09 J"orn Rennecke + + * g++.dg/other/offsetof3.C: Adjust linenumber of last expected warning. + + 2003-06-09 Mark Mitchell + + * lib/gcc-dg.exp (dg-require-weak): Fix typo. + (dg-require-alias): Likewise. + (dg-require-gc-sections): Likewise. + * lib/target-supports.exp (check_gc_sections_available): Likewise. + 2003-06-08 Richard Henderson * gcc.dg/20011029-2.c: Fix the array reference. * gcc.dg/asm-7.c: New. + 2003-06-08 Kazu Hirata + + * gcc.c-torture/compile/20000804-1.x: Disable on h8300 port. + + 2003-06-08 Mark Mitchell + + * lib/gcc-dg.exp (dg-require-alias): Fix typo. + (dg-require-gc-sections): Likewise. + + 2003-06-08 Jan Hubicka + + * i386-cmov1.c: Fix regular expression. + * i386-cvt-1.c: Likewise. + * i386-local.c: Likewise. + * i386-local2.c: Likewise. + * i386-mul.c: Likewise. + * i386-ssetype-1.c: Likewise. + * i386-ssetype-3.c: Likewise. + * i386-ssetype-5.c: Likewise. + 2003-06-08 Kriang Lerdsuwanakij PR c++/11039 * g++.dg/warn/implicit-typename2.C: New test. * g++.dg/warn/implicit-typename3.C: New test. + 2003-06-07 Richard Henderson + + * g++.dg/other/offsetof3.C: Use size_t. + * g++.dg/other/offsetof4.C: Likewise. + + 2003-06-07 H.J. Lu + + * lib/copy-file.exp: New. Implement gcc_copy_files. + + * lib/dg-pch.exp: Load copy-file.exp + (dg-pch): Use gcc_copy_files instead of "file copy". + + 2003-06-06 Mark Mitchell + + * gcc.dg/weak/weak.exp: Simplify. + * gcc.dg/weak/typeof-2.c: Use dg-require-weak. + * gcc.dg/weak/weak-1.c: Likewise. + * gcc.dg/weak/weak-2.c: Likewise. + * gcc.dg/weak/weak-3.c: Likewise. + * gcc.dg/weak/weak-4.c: Likewise. + * gcc.dg/weak/weak-5.c: Likewise. + * gcc.dg/weak/weak-6.c: Likewise. + * gcc.dg/weak/weak-7.c: Likewise. + * gcc.dg/weak/weak-8.c: Likewise. + * gcc.dg/weak/weak-9.c: Likewise. + + 2003-06-06 Richard Earnshaw + + gcc.c-torture/execute/20030606-1.c: New. + + 2003-06-06 Roger Sayle + + * gcc.dg/builtins-2.c: Correct check-in of incorrect version. + * gcc.dg/builtins-19.c: Likewise. + + 2003-06-06 Roger Sayle + + * gcc.dg/builtins-2.c: Add some more tests. + * gcc.dg/builtins-18.c: New test case. + * gcc.dg/builtins-19.c: New test case. + + 2003-06-06 Roger Sayle + Jim Wilson + + * gcc.dg/uninit-C.c: Only test TImode on 64-bit platforms. + + 2003-06-06 Jakub Jelinek + + * gcc.c-torture/execute/builtins/string-4.c (main_test): Allow some + mempcpy/stpcpy calls not to be optimized into something else. + * gcc.c-torture/execute/string-opt-3.c: Moved to... + * gcc.c-torture/execute/builtins/string-7.c: ...here. + * gcc.c-torture/execute/builtins/string-7-lib.c: New. + + 2003-06-05 Kaveh R. Ghazi + + * gcc.dg/format/asm_fprintf-1.c: New test. + + 2003-06-05 Mark Mitchell + + * lib/gcc-defs.exp (additional_sources): New variable. + (dg-additional-sources): New function. + (additional_files): New variable. + (dg-additional-files): New function. + (dg-additional-files-options): Likewise. + * lib/gcc-dg.exp (dg-require-weak): New function. + (dg-require-alias): Likewise. + (dg-require-gc-sections): Likewise. + * lib/target-supports.exp (check_alias_available): Remove testfile + parameter. + (check_gc_sections_available): New function. + * lib/g++-dg.exp (dg-gpp-additional-sources): Remove. + (dg-gpp-additional-files): Likewise. + * lib/g++.exp (additional_sources): Remove. + (additional_files): Likewise. + (g++_target_compile): Use dg-additional-files-options. + + * gcc.dg/special/special.exp: Add "ecos" tests. Remove complex + Tcl logic. + * gcc.dg/special/ecos.exp: Remove. + * gcc.dg/special/20000419-2.c: Use dg-require-*. + * gcc.dg/special/alias-1.c: Likewise. + * gcc.dg/special/alias-2.c: Likewise. + * gcc.dg/special/gcsec-1.c: Likewise. + * gcc.dg/special/weak-1.c: Likewise. + * gcc.dg/special/weak-2.c: Likewise. + * gcc.dg/special/wkali-1.c: Likewise. + * gcc.dg/special/wkali-2.c: Likewise. + + * g++.dg/special/conpr-2.C: Use dg-additional-*, not + dg-gpp-additional-*. + * g++.dg/special/conpr-3.C: Likewise. + * g++.dg/special/conpr-4.C: Likewise. + * g++.old-deja/g++.abi/vtable3a.C: Likewise. + * g++.old-deja/g++.abi/vtable3b.C: Likewise. + * g++.old-deja/g++.abi/vtable3c.C: Likewise. + * g++.old-deja/g++.abi/vtable3d.C: Likewise. + * g++.old-deja/g++.abi/vtable3e.C: Likewise. + * g++.old-deja/g++.abi/vtable3f.C: Likewise. + * g++.old-deja/g++.abi/vtable3g.C: Likewise. + * g++.old-deja/g++.abi/vtable3h.C: Likewise. + * g++.old-deja/g++.abi/vtable3i.C: Likewise. + * g++.old-deja/g++.abi/vtable3j.C: Likewise. + * g++.old-deja/g++.oliva/linkage1.C: Likewise. + * g++.old-deja/g++.other/comdat1.C: Likewise. + * g++.old-deja/g++.other/comdat2.C: Likewise. + * g++.old-deja/g++.other/comdat3.C: Likewise. + * g++.old-deja/g++.other/ctor1.C: Likewise. + * g++.old-deja/g++.pt/instantiate5.C: Likewise. + + 2003-06-05 Richard Henderson + + * gcc.dg/debug/20030605-1.c: New. + + 2003-06-04 Mark Mitchell + + * README.QMTEST: Update. + 2003-06-04 Richard Henderson * gcc.dg/cleanup-1.c: New. *************** *** 908,913 **** --- 4696,4718 ---- * gcc.dg/cleanup-6.c: New. * gcc.dg/cleanup-7.c: New. + 2003-06-04 Mark Mitchell + + * g++.dg/abi/vague1.C: Use xfail, rather than embedded Tcl code. + + * lib/dg-pch.exp: New file. + * g++.dg/pch/pch.exp: Use dg-pch.exp. + * gcc.dg/pch/pch.exp: Likewise. + + 2003-06-04 Roger Sayle + + * gcc.dg/builtins-2.c: Add tests for tan(atan(x)). + * gcc.dg/builtins-3.c: Add tests for tan(0.0) and atan(0.0). + * gcc.dg/builtins-7.c: Add tests for tan(atan(x)) == x. + * gcc.dg/builtins-17.c: New test case. + * gcc.dg/i386-387-4.c: New test case. + * gcc.c-torture/execute/ieee/mzero4.c: New test case. + 2003-06-04 Eric Botcazou * gcc.dg/ultrasp9.c: New test. *************** *** 917,936 **** --- 4722,4850 ---- * gcc.c-torture/compile/20030604-1.c: New test. * gcc.dg/sparc-constant-1.c: New test. + 2003-06-03 Glen Nakamura + + * gcc.dg/20020525-1.c: Replace 0x5a5a5a5a with -1. + + 2003-06-03 J"orn Rennecke + + * g++.dg/abi/empty6.C (B): Request alignment of 8 bytes. + + * gcc.dg/torture/builtin-noret-1.c (_exit, _Exit): Make weak. + * gcc.dg/torture/builtin-noret-2.c (_exit, _Exit): Likewise. + + 2003-06-03 Aldy Hernandez + + * gcc.c-torture/compile/simd-5.x: Remove xfail for PPC64. + 2003-06-03 Kriang Lerdsuwanakij PR c++/10940 * g++.dg/template/spec10.C: New test. + 2003-06-03 Roger Sayle + + * gcc.dg/builtins-16.c: New test case. + + 2003-06-03 Jakub Jelinek + + * gcc.c-torture/execute/builtins/string-4.c (main_test): Remove + mempcpy test with post-increments. + * gcc.c-torture/execute/string-opt-3.c: New test. + * gcc.dg/string-opt-1.c: New test. + + 2003-06-03 David Billinghurst (David.Billinghurst@riotinto.com) + + PR fortran/10965 + * g77.f-torture/compile/20000601-2.f: Fix non-standard code. + + 2003-06-02 Mark Mitchell + + * lib/scanasm.exp (dg-scan): New function, factored out of ... + (scan-assembler): ... here. Use dg-scan. + (scan-assembler-not): Likewise. + (scan-file): New function. + (scan-file-not): Likewise. + * gcc.dg/cpp/19990228-1.c: Use scan-file and/or scan-file-not. + * gcc.dg/cpp/_Pragma4.c: Likewise. + * gcc.dg/cpp/_Pragma5.c: Likewise. + * gcc.dg/cpp/avoidpaste1.c: Likewise. + * gcc.dg/cpp/avoidpaste2.c: Likewise. + * gcc.dg/cpp/cmdlne-C2.c: Likewise. + * gcc.dg/cpp/cmdlne-P.c: Likewise. + * gcc.dg/cpp/cmdlne-dD-M.c: Likewise. + * gcc.dg/cpp/cmdlne-dD-dM.c: Likewise. + * gcc.dg/cpp/cmdlne-dI-M.c: Likewise. + * gcc.dg/cpp/cmdlne-dM-M.c: Likewise. + * gcc.dg/cpp/cmdlne-dM-dD.c: Likewise. + * gcc.dg/cpp/cmdlne-dN-M.c: Likewise. + * gcc.dg/cpp/cxxcom1.c: Likewise. + * gcc.dg/cpp/line1.c: Likewise. + * gcc.dg/cpp/maccom1.c: Likewise. + * gcc.dg/cpp/maccom2.c: Likewise. + * gcc.dg/cpp/maccom3.c: Likewise. + * gcc.dg/cpp/maccom4.c: Likewise. + * gcc.dg/cpp/maccom5.c: Likewise. + * gcc.dg/cpp/maccom6.c: Likewise. + * gcc.dg/cpp/multiline.c: Likewise. + * gcc.dg/cpp/spacing1.c: Likewise. + * gcc.dg/cpp/spacing2.c: Likewise. + * gcc.dg/cpp/trad/cmdlne-C2.c: Likewise. + * gcc.dg/cpp/trad/maccom1.c: Likewise. + * gcc.dg/cpp/trad/maccom2.c: Likewise. + * gcc.dg/cpp/trad/maccom3.c: Likewise. + * gcc.dg/cpp/trad/maccom4.c: Likewise. + * gcc.dg/cpp/trad/maccom6.c: Likewise. + * gcc.dg/cpp/cxxcom2.c: Likewise. + * gcc.dg/cpp/cxxcom2.h: New file. + + * gcc.dg/cpp/truefalse.cpp: Move it to ... + * g++.dg/cpp/truefalse.C: Here. + * gcc.dg/cpp/cpp.exp: Remove scanning of ".cpp" files. + + 2003-06-01 Loren James Rittle + + * gcc.dg/cpp/redef3.c: New file. + 2003-06-01 Eric Botcazou * gcc.dg/i386-loop-3.c: New test. + 2003-05-31 Toon Moene + + * g77.dg/ffree-form-2.f: XFAIL removed, because fixed. + + 2003-05-31 Roger Sayle + + * gcc.dg/fwrapv-1.c: New test case. + * gcc.dg/fwrapv-2.c: New test case. + 2003-05-31 Kriang Lerdsuwanakij PR c++/10956 * g++.dg/template/spec9.C: New test. + 2003-05-29 Roger Sayle + + * gcc.dg/duff-4.c: New test case. + + 2003-05-27 David Billinghurst (David.Billinghurst@riotinto.com) + + PR fortran/10843 + * g77.dg/ffixed-form-1.f: New test + * g77.dg/ffixed-form-2.f: New test + * g77.dg/ffree-form-2.f: New test - XFAIL pending fix + * g77.dg/ffree-form-3.f: New test + + 2003-05-26 Andreas Tobler + + * gcc.dg/wchar_t-1.c: XFAIL on darwin, no wchar.h available. + * gcc.dg/wint_t-1.c: Likewise. + + 2003-05-25 Kriang Lerdsuwanakij + + * g++.dg/template/access11.C: New test. + 2003-05-25 Kriang Lerdsuwanakij PR c++/10849 *************** *** 941,989 **** * gcc.c-torture/compile/simd-5.x: XFAIL on SPARC64. 2003-05-23 Kriang Lerdsuwanakij PR c++/10682 * g++.dg/template/instantiate4.C: New test. ! 2003-05-16 Matthias Klose ! * parse/crash2.C: Use "(parse|syntax)" error. ! Backport from mainline ! 2003-03-17 Zack Weinberg ! * objc.dg/naming-1.m: Use "(parse|syntax)" error. ! * objc.dg/naming-2.m: Likewise. ! 2003-05-13 Release Manager ! * GCC 3.3 Released. ! 2003-05-13 Release Manager ! * GCC 3.3 Released. ! 2003-05-13 Release Manager ! * GCC 3.3 Released. 2003-05-08 Kaveh R. Ghazi * g++.dg/other/packed1.C: Mark xfail for sparc*- not sparc-. ! 2003-05-05 Mark Mitchell ! Kean Johnston ! ! * gcc.dg/unused-4.c: Update. ! 2003-05-02 Zack Weinberg ! PR c/10604 ! * gcc.dg/compare7.c, g++.dg/warn/compare1.C: New testcases. ! 2003-05-02 Richard Henderson PR c++/10570 * g++.dg/eh/forced1.C: Expect catch-all handlers to run. --- 4855,5189 ---- * gcc.c-torture/compile/simd-5.x: XFAIL on SPARC64. + 2003-05-24 Andreas Tobler + + * gcc.dg/torture/builtin-noret-1.c: Add dg-option -multiply_defined + suppress for powerpc-*-darwin*. + * gcc.dg/torture/builtin-noret-2.c: Likewise. + + 2003-05-24 Andreas Tobler + + * gcc.c-torture/execute/builtins/builtins.exp: Add -multiply_defined + suppress option for powerpc-*-darwin*. + + 2003-05-23 Roger Sayle + + * gcc.dg/builtins-1.c: Add tests for tan and atan. + * gcc.dg/builtins-4.c: Add test for fmod. + 2003-05-23 Kriang Lerdsuwanakij PR c++/10682 * g++.dg/template/instantiate4.C: New test. ! 2003-05-22 Roger Sayle ! * gcc.c-torture/execute/ieee/inf-2.c: New test case. ! 2003-05-21 Janis Johnson ! * gcc.dg/compat/scalar-return-1_main.c: New file. ! * gcc.dg/compat/scalar-return-1_x.c: New file. ! * gcc.dg/compat/scalar-return-1_y.c: New file. ! * gcc.dg/compat/scalar-return-2_main.c: New file. ! * gcc.dg/compat/scalar-return-2_x.c: New file. ! * gcc.dg/compat/scalar-return-2_y.c: New file. ! * gcc.dg/compat/struct-return-3_main.c: New file. ! * gcc.dg/compat/struct-return-3_y.c: New file. ! * gcc.dg/compat/struct-return-3_x.c: New file. ! * gcc.dg/compat/struct-return-2_main.c: New file. ! * gcc.dg/compat/struct-return-2_x.c: New file. ! * gcc.dg/compat/struct-return-2_y.c: New file. ! 2003-05-21 John David Anglin ! * g++.old-deja/g++.law/profile1.C (dg-options): Add -static to options ! for hppa*-hp-hpux*. ! * gcc.dg/20021014-1.c (dg-options): Likewise. ! * gcc.dg/nest.c (dg-options): Likewise. ! 2003-05-21 Danny Smith ! PR c++/9738 ! * g++.dg/ext/dllimport2.C: New file. ! * g++.dg/ext/dllimport3.C: New file. ! 2003-05-20 Janis Johnson ! * gcc.dg/compat/struct-by-value-3_x.c: Move common pieces to headers. ! * gcc.dg/compat/struct-by-value-3_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-5_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-5_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-6_x.c: Ditto. ! * gcc.dg/compat/struct-by-value-6_y.c: Ditto. ! * gcc.dg/compat/struct-by-value-7_x.c Ditto. ! * gcc.dg/compat/struct-by-value-7_y.c Ditto. ! * gcc.dg/compat/small-struct-defs.h: New file. ! * gcc.dg/compat/small-struct-init.h: New file. ! * gcc.dg/compat/small-struct-check.h: New file. ! * gcc.dg/compat/fp-struct-defs.h: New file. ! * gcc.dg/compat/fp-struct-check.h: New file. ! * gcc.dg/compat/fp-struct-init.h: New file. ! * gcc.dg/compat/fp-struct-test-by-value-y.h: New file. ! * gcc.dg/compat/fp-struct-test-by-value-x.h: New file. ! 2003-05-19 Jakub Jelinek ! ! * gcc.dg/20030225-2.c: New test. ! ! 2003-05-18 Roger Sayle ! Kaveh R. Ghazi ! ! * gcc.c-torture/compile/20030518-1.c: New test case. ! ! 2003-05-18 Mark Mitchell ! ! * lib/gcc-dg.exp (gcc-dg-debug-runtest): Add opt_opts parameter. ! * gcc.dg/debug/debug.exp: Pass opt_opts parameter to ! gcc-dg-debug-runtest. ! * g++.dg/debug/debug.exp: Pass opt_opts parameter to ! gcc-dg-debug-runtest. ! ! 2003-05-18 Kriang Lerdsuwanakij ! ! PR c++/9022 ! * g++.dg/lookup/using6.C: New test. ! ! 2003-05-18 Kriang Lerdsuwanakij ! ! * g++.dg/parse/access2.C: New test. ! ! 2003-05-17 Mark Mitchell ! ! * lib/gcc-dg.exp (gcc-dg-debug-runtest): New method. ! * g++.dg/debug/debug.exp: Use gcc-dg-debug-runtest. ! * gcc.dg/debug/debug.exp: Likewise. ! ! 2003-05-17 Neil Booth ! ! * gcc.dg/dollar.c: New test. ! ! 2003-05-16 Janis Johnson ! ! * gcc.dg/compat/struct-by-value-4_main.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-4_x.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-4_y.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-5_main.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-5_x.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-5_y.c: Split into multiple tests. ! * gcc.dg/compat/struct-by-value-6_main.c: New file. ! * gcc.dg/compat/struct-by-value-6_x.c: New file. ! * gcc.dg/compat/struct-by-value-6_y.c: New file. ! * gcc.dg/compat/struct-by-value-7_main.c: New file. ! * gcc.dg/compat/struct-by-value-7_x.c: New file. ! * gcc.dg/compat/struct-by-value-7_y.c: New file. ! * gcc.dg/compat/struct-by-value-8_main.c: New file. ! * gcc.dg/compat/struct-by-value-8_x.c: New file. ! * gcc.dg/compat/struct-by-value-8_y.c: New file. ! * gcc.dg/compat/struct-by-value-9_main.c: New file. ! * gcc.dg/compat/struct-by-value-9_x.c: New file. ! * gcc.dg/compat/struct-by-value-9_y.c: New file. ! ! 2003-05-16 Mark Mitchell ! ! * lib/gcc-dg.exp (gcc-dg-test): Rename to ... ! (gcc-dg-test-1): ... this. Add target_compile parameter. Add ! support for "repo" mode. ! * lib/g++-dg.exp: Use gcc-dg.exp to implement all functionality. ! * lib/g77-dg.exp: Likewise. ! * lib/obj-dg.exp: Likewise. ! ! 2003-05-16 Jakub Jelinek ! ! Merge from gcc-3_2-rhl8-branch: ! 2003-04-23 Jakub Jelinek ! ! * gcc.dg/tls/opt-6.c: New test. ! ! 2003-04-05 Jakub Jelinek ! ! * gcc.dg/20030405-1.c: New test. ! ! 2003-03-09 Jakub Jelinek ! ! * gcc.dg/20030309-1.c: New test. ! ! 2003-03-07 Eric Botcazou ! ! * gcc.c-torture/execute/20030307-1.c: New test. ! ! 2003-02-20 Randolph Chung ! ! * gcc.c-torture/compile/20030220-1.c: New test. ! ! 2003-02-18 Jakub Jelinek ! ! * gcc.dg/20030217-1.c: New test. ! ! 2003-01-29 Jakub Jelinek ! ! * gcc.c-torture/compile/20020129-1.c: New test. ! ! 2002-12-21 Eric Botcazou ! ! * gcc.dg/unroll-1.c: New test. ! ! 2002-11-16 Jan Hubicka ! ! * gcc.c-torture/execute/20020920-1.c: New test. ! ! 2002-10-08 Jakub Jelinek ! ! PR target/7434 ! * gcc.c-torture/compile/20021008-1.c: New test. ! ! 2002-08-10 Gwenole Beauchesne ! ! PR target/7559 ! * testsuite/gcc.c-torture/execute/20020810-1.c: New test. ! ! 2002-08-07 Jakub Jelinek ! ! * gcc.c-torture/compile/20020807-1.c: New test. ! ! 2002-07-30 Jakub Jelinek ! ! * gcc.dg/tls/opt-1.c: New test. ! ! 2002-07-29 Jakub Jelinek ! ! * gcc.dg/20020729-1.c: New test. ! ! 2002-07-20 Jakub Jelinek ! ! * g++.dg/opt/life1.C: New test. ! ! 2002-05-20 Jakub Jelinek ! ! * gcc.dg/20020525-1.c: New test. ! ! 2002-05-24 Jakub Jelinek ! ! PR c++/6794 ! * g++.dg/ext/pretty1.C: New test. ! * g++.dg/ext/pretty2.C: New test. ! ! 2003-05-15 Mark Mitchell ! ! PR c++/8385 ! * g++.dg/ext/typeof5.C: New test. ! ! 2003-05-15 J"orn Rennecke ! ! * gcc.c-torture/execute/builtins/string-asm-1.c: Take ! __USER_LABEL_PREFIX__ into account. ! * gcc.c-torture/execute/builtins/string-asm-2.c: Likewise. ! ! 2003-05-14 Roger Sayle ! ! * gcc.dg/builtins-15.c: New test case. ! ! 2003-05-13 Zack Weinberg ! ! * gcc.dg/const-elim-1.c: Tighten scan-assembler-not regexp. ! ! 2003-05-12 Mark Mitchell ! ! * lib/g++.exp: Tweak handling of additional source files. ! * g++.dg/special/conpr-2.C: Use dg-gpp-additional-sources. ! * g++.dg/special/conpr-2a.C: Rename to ... ! * g++.dg/special/conpr-2a.cc: ... this. ! * g++.dg/special/conpr-3.C: Use dg-gpp-additional-sources. ! * g++.dg/special/conpr-3a.C: Rename to ... ! * g++.dg/special/conpr-3a.cc: This. ! * g++.dg/special/conpr-3b.C: Rename to ... ! * g++.dg/special/conpr-3b.cc: This. ! * g++.dg/special/conpr-4.C: New test. ! * g++.dg/special/ecos.exp: Rewrite to use ordinary dg driver. ! ! 2003-05-12 David Edelsohn ! ! * debug/debug.exp: Skip debug-[12].c at -O3 on non-Dwarf targets. ! ! 2003-05-12 Kriang Lerdsuwanakij ! ! * g++.old-deja/g++.brendan/ns1.C: Remove private member warning. ! * g++.old-deja/g++.robertl/eb71.C: Likewise. ! * g++.old-deja/g++.brendan/warnings1.C: Add -Wctor-dtor-privacy. ! * g++.old-deja/g++.other/warn3.C: Likewise. ! ! 2003-05-11 Roger Sayle ! ! * gcc.dg/i386-387-1.c: Update to also test log. ! * gcc.dg/i386-387-2.c: Likewise. ! ! 2003-05-11 Toon Moene ! ! * g77.f-torture/execute/int8421.f: New test. ! ! 2003-05-11 Kriang Lerdsuwanakij ! ! PR c++/10230, c++/10481 ! * g++.dg/lookup/scoped5.C: New test. ! ! 2003-05-11 Kriang Lerdsuwanakij ! ! PR c++/10552 ! * g++.dg/template/ttp6.C: New test. ! ! 2003-05-11 Richard Sandiford ! ! * gcc.c-torture/execute/builtins: New directory. ! * gcc.c-torture/execute/string-opt-{3,4,16,17,18,19}.c: Move into ! gcc.c-torture/execute/builtins. ! * gcc.c-torture/execute/string-opt-asm-{1,2}.c: Likewise. ! * gcc.c-torture/execute/builtin-noret-{1,2}.c: Move to... ! * gcc.dg/torture: ...this new directory. Turn into link-only tests. ! * gcc.dg/no-builtin-1.c: Move into gcc.c-torture/execute/builtins. ! ! 2003-05-10 Kriang Lerdsuwanakij ! ! PR c++/9252 ! * g++.dg/template/access8.C: New test. ! * g++.dg/template/access9.C: New test. ! ! 2003-05-10 Kriang Lerdsuwanakij ! ! PR c++/9554 ! * g++.dg/parse/access1.C: New test. ! ! 2003-05-09 DJ Delorie ! ! * g++.dg/other/stdarg1.C: Make sure arg "3" is passed as a ! long, and not an int. ! ! 2003-05-09 Kriang Lerdsuwanakij ! ! PR c++/10555, c++/10576 ! * g++.dg/template/memclass1.C: New test. ! ! 2003-05-08 DJ Delorie ! ! * gcc.c-torture/execute/20020404-1.x: New, skip for 16-bit ! targets. ! * gcc.c-torture/execute/20021024-1.x: Likewise. ! * gcc.c-torture/execute/shiftdi.x: Likewise. ! * g++.old-deja/g++.mike/p700.C: Handle 16-bit targets. ! * g++.old-deja/g++.other/exprstmt1.C: Likewise. ! * gcc.dg/20021018-1.c: Likewise. 2003-05-08 Kaveh R. Ghazi * g++.dg/other/packed1.C: Mark xfail for sparc*- not sparc-. ! gcc.c-torture/execute/string-opt-19.c: Add general rodata tests. ! (bcopy): Call memmove. ! 2003-05-08 Roger Sayle ! * g77.f-torture/compile/8485.f: New test case. ! 2003-05-07 Richard Henderson PR c++/10570 * g++.dg/eh/forced1.C: Expect catch-all handlers to run. *************** *** 993,1017 **** * g++.dg/eh/forced3.C: New. * g++.dg/eh/forced4.C: New. 2003-04-29 Mark Mitchell PR c++/10551 * g++.dg/template/explicit1.C: New test. PR c++/10549 * g++.dg/other/bitfield1.C: New test. - 2003-04-29 Mark Mitchell - PR c++/10527 * g++.dg/init/new7.C: New test. - PR c++/10515 - * g++.dg/ext/desig1.C: New test. - * g++.dg/ext/init1.C: Likewise. - 2003-04-29 Mark Mitchell * g++.old-deja/g++.pt/deduct5.C: Remove unnecessary initializer. 2003-04-28 Mark Mitchell --- 5193,5359 ---- * g++.dg/eh/forced3.C: New. * g++.dg/eh/forced4.C: New. + 2003-05-07 Aldy Hernandez + + * gcc.dg/20030505.c: Fix triplet. + + 2003-05-06 DJ Delorie + + * gcc.dg/20021014-1.c: XFAIL for xstormy16 also. + * gcc.dg/nest.c: Likewise. + + 2003-05-05 Roger Sayle + + * gcc.dg/builtins-14.c: New test case. + + 2003-05-05 Janis Johnson + + * lib/compat.exp (compat-execute): New argument. + * g++.dg/compat/compat.exp: Pass new argument to compat-execute. + * gcc.dg/compat: New test directory. + * gcc.dg/compat/compat.exp: New expect script. + * gcc.dg/compat/scalar-by-value-1_main.c: New test file. + * gcc.dg/compat/scalar-by-value-1_x.c: New test file. + * gcc.dg/compat/scalar-by-value-1_y.c: New test file. + * gcc.dg/compat/scalar-by-value-2_main.c: New test file. + * gcc.dg/compat/scalar-by-value-2_x.c: New test file. + * gcc.dg/compat/scalar-by-value-2_y.c: New test file. + + * gcc.dg/compat/struct-by-value-1_main.c: New test file. + * gcc.dg/compat/struct-by-value-1_x.c: New test file. + * gcc.dg/compat/struct-by-value-1_y.c: New test file. + * gcc.dg/compat/struct-by-value-2_main.c: New test file. + * gcc.dg/compat/struct-by-value-2_x.c: New test file. + * gcc.dg/compat/struct-by-value-2_y.c: New test file. + * gcc.dg/compat/struct-by-value-3_main.c: New test file. + * gcc.dg/compat/struct-by-value-3_x.c: New test file. + * gcc.dg/compat/struct-by-value-3_y.c: New test file. + * gcc.dg/compat/struct-by-value-4_main.c: New test file. + * gcc.dg/compat/struct-by-value-4_x.c: New test file. + * gcc.dg/compat/struct-by-value-4_y.c: New test file. + * gcc.dg/compat/struct-by-value-5_main.c: New test file. + * gcc.dg/compat/struct-by-value-5_x.c: New test file. + * gcc.dg/compat/struct-by-value-5_y.c: New test file. + + 2003-05-05 Zack Weinberg + + * gcc.dg/const-elim-1.c, gcc.dg/const-elim-2.c: New testcases. + + 2003-05-05 Jakub Jelinek + + * gcc.c-torture/execute/string-opt-18.c (main): Add 3 new tests. + + 2003-05-05 Geoffrey Keating + + * gcc.c-torture/execute/ieee/fp-cmp-8.c: New test. + * gcc.dg/ppc-fsel-2.c: New test. + + * gcc.dg/unused-5.c: New test. + + 2003-05-05 Kriang Lerdsuwanakij + + PR c++/10496 + * g++.dg/warn/pmf1.C: New test. + + 2003-05-05 Kriang Lerdsuwanakij + + PR c++/4494 + * g++.dg/warn/main.C: New test. + + 2003-05-04 Kaveh R. Ghazi + + * gcc.dg/nonnull-3.c: New test. + + 2003-05-04 Neil Booth + + * gcc.dg/cpp/Wtrigraphs.c: Update. + * gcc.dg/cpp/Wtrigraphs-2.c: New tests. + + 2003-05-03 Geoffrey Keating + + * gcc.dg/ppc-fsel-1.c: New test. + + 2003-05-03 Zack Weinberg + + PR c/10604 + * gcc.dg/compare7.c, g++.dg/warn/compare1.C: New testcases. + + 2003-05-03 Kazu Hirata + + * gcc.dg/m-un-2.c: Fix the typedef of size_t. + + 2003-05-03 Kriang Lerdsuwanakij + + PR c++/9364, c++/10553, c++/10586 + * g++.dg/parse/typename4.C: New test. + * g++.dg/parse/typename5.C: Likewise. + + 2003-05-03 Richard Sandiford + + * gcc.c-torture/compile/20030503-1.c: New test. + + 2003-05-02 Kriang Lerdsuwanakij + + * g++.dg/lookup/using5.C: Fix testcase error. + + 2003-05-01 Chris Demetriou + + * gcc.dg/special/mips-abi.exp (is_meabi_config): Remove, + since MEABI is no longer supported. Remove all vestiges + of MEABI from the test. + + 2003-05-01 Kriang Lerdsuwanakij + + PR c++/10554 + * g++.dg/lookup/using5.C: New test. + + 2003-05-01 Kriang Lerdsuwanakij + + PR c++/8772 + * g++.dg/template/ttp5.C: New test. + + 2003-04-30 Mark Mitchell + + * lib/g++-dg.exp (g++-dg-test): Add "repo" option. + (dg-gpp-additional-sources): New function. + (dg-gpp-additional-files): Likewise. + * lib/g++.exp (additional_sources): New variable. + (additional_files): Likewise. + (g++_target_compile): Deal with them. + * lib/old-dejagnu.exp: Remove. + * g++.old-deja/old-deja.exp: Use dg.exp, not old-dejagnu.exp. + * g++.old-deja: Revise all tests to use dg commands. + + 2003-04-30 Kriang Lerdsuwanakij + + PR c++/9432, c++/9528 + * g++.dg/lookup/using4.C: New test. + + 2003-04-29 Geoffrey Keating + + * gcc.dg/noreturn-5.c: New file. + * gcc.dg/noreturn-6.c: New file. + + * gcc.c-torture/compile/inline-1.c: New file. + 2003-04-29 Mark Mitchell PR c++/10551 * g++.dg/template/explicit1.C: New test. + 2003-04-29 Mark Mitchell + PR c++/10549 * g++.dg/other/bitfield1.C: New test. PR c++/10527 * g++.dg/init/new7.C: New test. 2003-04-29 Mark Mitchell + * g++.dg/ext/desig1.C: New test. + * g++.dg/ext/init1.C: Update. + * g++.old-deja/g++.pt/deduct5.C: Remove unnecessary initializer. 2003-04-28 Mark Mitchell *************** *** 1019,1024 **** --- 5361,5373 ---- PR c++/10180 * g++.dg/warn/Winline-1.C: New test. + 2003-04-28 Jakub Jelinek + + * gcc.c-torture/execute/string-opt-19.c: New test. + + * gcc.c-torture/execute/string-opt-asm-1.c: New test. + * gcc.c-torture/execute/string-opt-asm-2.c: New test. + 2003-04-27 Mark Mitchell PR c++/10506 *************** *** 1031,1046 **** --- 5380,5424 ---- * g++.dg/warn/weak1.C: XFAIL on AIX4. + 2003-04-26 Kaveh R. Ghazi + + * gcc.c-torture/execute/string-opt-8.c: Don't perform cmpstr + checks for __pj__, but do them for !__OPTIMIZE__ and __s390__. + 2003-04-25 Mark Mitchell * g++.old-deja/g++.pt/instantiate12.C: Explicit instantiate initialized static data members. + 2003-04-25 H.J. Lu + + * gcc.dg/ia64-sync-4.c: New test. + + 2003-04-25 Kaveh R. Ghazi + + * gcc.c-torture/execute/string-opt-18.c: Clean up. Fix copyright + date. + + 2003-04-24 Nathan Sidwell + + PR c++/10337 + * g++.dg/warn/conv1.C: New test. + * g++.old-deja/g++.other/conv7.C: Adjust. + * g++.old-deja/g++.other/overload14.C: Adjust. + 2003-04-23 Mark Mitchell PR c++/10471 * g++.dg/template/defarg2.C: New test. + 2003-04-23 Neil Booth + + * gcc.dg/cpp/include2.c: Update. + * gcc.dg/cpp/multiline-2.c: New. + * gcc.dg/cpp/multiline.c: Update. + * gcc.dg/cpp/strify2.c: Update. + * gcc.dg/cpp/trad/literals-2.c: Update. + 2003-04-23 John David Anglin * g++.dg/other/packed1.C: XFAIL hppa*-*-*. *************** *** 1049,1079 **** * g++.dg/parse/typedef1.C: Tweak after fix for PR 10428. PR c++/10451 * g++.dg/parse/crash4.C: New test. ! 2003-04-23 Andreas Tobler ! ! * g++.dg/other/packed1.C: Append the missing brace. ! ! 2003-04-22 Devang Patel ! ! * gcc.dg/cpp/trad/funlike-5.c: New test. 2003-04-22 Mark Mitchell PR c++/10446 * g++.dg/parse/crash3.C: New test. - 2003-04-22 Mark Mitchell - PR c++/10428 * g++.dg/parse/elab1.C: New test. ! 2003-04-22 Andreas Tobler * g++.dg/other/packed1.C: Fix dg options. 2003-04-21 Mark Mitchell * g++.dg/template/recurse.C: Adjust location of error messages. --- 5427,5460 ---- * g++.dg/parse/typedef1.C: Tweak after fix for PR 10428. + 2003-04-23 Mark Mitchell + PR c++/10451 * g++.dg/parse/crash4.C: New test. ! PR c++/9847 ! * g++.dg/parse/crash5.C: New test. 2003-04-22 Mark Mitchell PR c++/10446 * g++.dg/parse/crash3.C: New test. PR c++/10428 * g++.dg/parse/elab1.C: New test. ! 2003-04-22 Devang Patel ! ! * gcc.dg/cpp/trad/funlike-5.c: New test. ! ! 2003-04-21 Andreas Tobler * g++.dg/other/packed1.C: Fix dg options. + 2003-04-22 Nathan Sidwell + + * g++.dg/other/offsetof2.C: New test. + 2003-04-21 Mark Mitchell * g++.dg/template/recurse.C: Adjust location of error messages. *************** *** 1089,1107 **** PR c++/10405 * g++.dg/lookup/struct-hack1.C: New test. 2003-04-18 Eric Botcazou * gcc.c-torture/compile/20030418-1.c: New test. 2003-04-17 Janis Johnson ! * README.compat: Remove; content now in doc/sourcebuild.texi. 2003-04-14 Hans-Peter Nilsson PR target/10377 * gcc.dg/20030414-1.c: New test. 2003-04-13 Mark Mitchell PR c++/10300 --- 5470,5548 ---- PR c++/10405 * g++.dg/lookup/struct-hack1.C: New test. + 2003-04-20 Neil Booth + + * ucs.c: Update diagnostic messages. + + 2003-04-19 Neil Booth + + * gcc.dg/cpp/truefalse.cpp: New test. + * gcc.dg/cpp/cpp.exp: Update. + * g++.dg/other/stdbool-if.C: Remove. + + 2003-04-19 Neil Booth + + * gcc.dg/cpp/_Pragma4.c: Remove stray space. + * gcc.dg/cpp/trad/escaped-eof.c: Correct line number. + 2003-04-18 Eric Botcazou * gcc.c-torture/compile/20030418-1.c: New test. 2003-04-17 Janis Johnson ! * README.compat: Remove; content moved to doc/sourcebuild.texi. ! ! 2003-04-17 Kriang Lerdsuwanakij ! ! PR c++/10347 ! g++.dg/template/dependent-name1.C: New test. ! ! 2003-04-17 J"orn Rennecke ! ! * gcc.dg/warn-1.c (tourist_guide): New array, ! contains a pointer to bar. ! ! 2003-04-16 Roger Sayle ! ! * gcc.dg/Wunreachable-5.c: New test case for PR c/10175. ! * gcc.c-torture/execute/medce-1.c: New test case. ! * gcc.c-torture/execute/medce-2.c: New test case. ! ! 2003-04-15 Mark Mitchell ! ! * lib/prune.exp: Ignore more messages. ! ! PR c++/10381 ! * g++.dg/parse/lookup3.C: New test. ! ! 2003-04-15 J"orn Rennecke ! ! * gcc.c-torture/compile/20030415-1.c : New test. ! ! 2003-04-14 Mark Mitchell ! ! * gcc.c-torture/execute/scope-2.c: Move to ... ! * gcc.dg/noncompile/scope.c: .... here. ! ! 2003-04-14 Roger Sayle ! ! * gcc.dg/20030414-2.c: New test case. 2003-04-14 Hans-Peter Nilsson PR target/10377 * gcc.dg/20030414-1.c: New test. + 2003-04-13 Roger Sayle + + * gcc.dg/builtins-12.c: New test case. + * gcc.dg/builtins-13.c: New test case. + + 2003-04-13 Kaveh R. Ghazi + + * gcc.c-torture/execute/string-opt-18.c: New test. + 2003-04-13 Mark Mitchell PR c++/10300 *************** *** 1116,1157 **** * gcc.dg/ultrasp8.c: Fix for 32-bit Sparc. ! 2003-04-11 Bud Davis PR Fortran/9263 * g77.f-torture/noncompile/9263.f: New test PR Fortran/1832 * g77.f-torture/execute/1832.f: New test 2003-04-05 Zack Weinberg PR optimization/10024 * gcc.c-torture/compile/20030405-1.c: New test. ! 2003-04-04 Glen Nakamura ! * gcc.dg/20030324-1.c: Add comments and abort if test fails. 2003-04-03 Mike Stump * lib/scanasm.exp (scan-assembler): Add xfail processing for target arg. ! (scan-assembler-not): Likewise. (scan-assembler-dem, scan-assembler-dem-not): Likewise. 2003-03-31 Mark Mitchell PR c/9936 * gcc.dg/20030331-2.c: New test. PR c++/10278 * g++.dg/parse/crash2.C: New test. 2003-03-30 Mark Mitchell PR c++/7647 * g++.dg/lookup-class-member-2.C: New test. 2003-03-28 Eric Botcazou * gcc.dg/ultrasp8.c: New test. --- 5557,5718 ---- * gcc.dg/ultrasp8.c: Fix for 32-bit Sparc. ! 2003-04-11 Bud Davis PR Fortran/9263 * g77.f-torture/noncompile/9263.f: New test PR Fortran/1832 * g77.f-torture/execute/1832.f: New test + 2003-04-11 David Chad + Loren J. Rittle + + libobjc/8562 + * objc.dg/headers.m: New test. + + 2003-04-10 Zack Weinberg + + * gcc.c-torture/execute/builtin-noret-2.c: New. + * gcc.c-torture/execute/builtin-noret-2.x: New. + XFAIL builtin-noret-2.c at -O1 and above. + * gcc.dg/redecl.c: New. + * gcc.dg/Wshadow-1.c: Update error regexps. + + 2003-04-10 Mark Mitchell + + * g++.dg/abi/bitfield10.C: New test. + + 2003-04-09 Mike Stump + + * gcc.dg/pch/pch.exp: Make testcase names longer. + * g++.dg/pch/pch.exp: Make testcase names longer. + + 2003-04-08 Roger Sayle + + * gcc.dg/builtins-11.c: New test case. + + 2003-04-08 Roger Sayle + + * gcc.dg/builtins-9.c: New test case. + * gcc.dg/builtins-10.c: New test case. + + 2003-04-07 J"orn Rennecke + + * gcc.dg/noncompile/init-4.c.c: New test. + + 2003-04-06 Nathan Sidwell + + * gcc.misc-test/gcov-9.c: New test. + * gcc.misc-test/gcov-10.c: New test + * gcc.misc-test/gcov-11.c: New test. + 2003-04-05 Zack Weinberg PR optimization/10024 * gcc.c-torture/compile/20030405-1.c: New test. ! 2003-04-04 Geoffrey Keating ! * gcc.dg/pch/static-3.c: New. ! * gcc.dg/pch/static-3.hs: New. ! * gcc.dg/pch/pch.exp: Test with -O0 -g too. ! ! 2003-04-04 Richard Henderson ! ! * g++.dg/eh/forced1.C: Use _Unwind_SjLj_ForcedUnwind as appropriate. ! * g++.dg/eh/forced2.C: Likewise. 2003-04-03 Mike Stump * lib/scanasm.exp (scan-assembler): Add xfail processing for target arg. ! (scan-assembler-times, scan-assembler-not): Likewise. (scan-assembler-dem, scan-assembler-dem-not): Likewise. + 2003-04-03 Eric Botcazou + + * gcc.dg/sparc-loop-1.c: New test. + + 2003-04-02 Geoffrey Keating + + PR other/9274 + * g++.dg/pch/system-2.C: New. + * g++.dg/pch/system-2.Hs: New. + + 2003-04-02 Aldy Hernandez + + * g++.dg/eh/simd-2.C (vecfunc): Fix typo. + + * g++.dg/eh/simd-1.C (vecfunc): Same. + + 2003-04-01 Roger Sayle + + * gcc.c-torture/execute/20030401-1.c: New test case. + + 2003-04-01 Ziemowit Laski + + * objc.dg/defs.m: New. + + 2003-04-01 Aldy Hernandez + + * g++.dg/eh/simd-1.C: New. + * g++.dg/eh/simd-2.C: New. + + 2003-03-01 Aldy Hernandez + + * gcc.c-torture/execute/simd-3.c: New. + 2003-03-31 Mark Mitchell PR c/9936 * gcc.dg/20030331-2.c: New test. + 2003-03-31 Mark Mitchell + PR c++/10278 * g++.dg/parse/crash2.C: New test. + 2003-03-31 Richard Sandiford + + * gcc.c-torture/compile/20030331-1.c: New test, moved from... + * gcc.c-torture/execute/20030331-1.c: ...here. + + 2003-03-31 Richard Sandiford + + * gcc.c-torture/execute/20030331-1.c: New test. + + 2003-03-31 Nathan Sidwell + + * lib/gcov.exp: Adjust call return testing strings. + * g77.dg/gcov/gcov-1.f: Don't expect unconditional branches. + + 2003-03-31 Roger Sayle + + * gcc.dg/builtins-3.c: Add new tests for sin and cos. + * gcc.dg/builtins-7.c: New test case. + * gcc.dg/builtins-8.c: New test case. + + 2003-03-31 Richard Sandiford + + * gcc.c-torture/execute/ieee/20030331-1.c: New test. + 2003-03-30 Mark Mitchell PR c++/7647 * g++.dg/lookup-class-member-2.C: New test. + 2003-03-30 Glen Nakamura + + * gcc.dg/20030324-1.c: Add comments and abort if test fails. + + 2003-03-28 Roger Sayle + + * gcc.c-torture/execute/ieee/fp-cmp-6.c: Correct test for -O0. + + 2003-03-28 Mark Mitchell + + * g++.dg/init/attrib1.C: New test. + 2003-03-28 Eric Botcazou * gcc.dg/ultrasp8.c: New test. *************** *** 1169,1176 **** --- 5730,5769 ---- * gcc.dg/sparc-dwarf2.c: New test. + 2003-03-27 Roger Sayle + + * gcc.c-torture/execute/ieee/fp-cmp-6.c: New test case. + * gcc.c-torture/execute/ieee/fp-cmp-7.c: New test case. + + 2003-03-27 Mark Mitchell + + * lib/gcov.exp (run-gcov): Add branches and calls options, rather + than reading .x files. + * g++.dg/gcov/gcov-1.C: Use run-gcov options, not .x files. + * g77.dg/gcov/gcov-1.f: Likewise. + * gcc.misc-tests/gcov-4b.c: Likewise. + * gcc.misc-tests/gcov-5b.c: Likewise. + * gcc.misc-tests/gcov-6.c: Likewise. + * gcc.misc-tests/gcov-7.c: Likewise. + * gcc.misc-tests/gcov-8.c: Likewise. + * g++.dg/gcov/gcov-1.x: Remove. + * g77.dg/gcov/gcov-1.x: Likewise. + * gcc.misc-tests/gcov-4b.x: Likewise. + * gcc.misc-tests/gcov-5b.x: Likewise. + * gcc.misc-tests/gcov-6.x: Likewise. + * gcc.misc-tests/gcov-7.x: Likewise. + * gcc.misc-tests/gcov-8.x: Likewise. + + 2003-03-27 Glen Nakamura + + PR opt/10087 + * gcc.dg/20030324-1.c: New test. + 2003-03-27 Nathan Sidwell + PR c++/10224 + * g++.dg/template/arg3.C: New test. + PR c++/10158 * g++.dg/template/friend18.C: New test. *************** *** 1188,1193 **** --- 5781,5790 ---- * gcc.dg/ia64-sync-3.c: New test. + 2003-03-26 Alan Modra + + * gcc.dg/loop-2.c: Replace "inline" with "__inline__". + 2003-03-26 Eric Botcazou * gcc.dg/ultrasp6.c: New test. *************** *** 1202,1228 **** * gcc.dg/ultrasp5.c: Fix options. - 2003-03-24 Bud Davis - - PR fortran/10197 - * g77.f-torture/execute/10197.f: New test. - 2003-03-24 Eric Botcazou * gcc.dg/ultrasp5.c: Fix comment. ! 2003-03-24 Glen Nakamura ! PR opt/10087 ! * gcc.dg/20030324-1.c: New test. 2003-03-24 Nathan Sidwell PR c++/9898, c++/383 * g++.dg/template/conv6.C: New test. ! PR c++/10199 ! * g++.dg/lookup/template1.C: New test. 2003-03-23 Eric Botcazou --- 5799,5830 ---- * gcc.dg/ultrasp5.c: Fix options. 2003-03-24 Eric Botcazou * gcc.dg/ultrasp5.c: Fix comment. ! 2003-03-24 Bud Davis ! PR fortran/10197 ! * g77.f-torture/execute/10197.f: New test. 2003-03-24 Nathan Sidwell PR c++/9898, c++/383 * g++.dg/template/conv6.C: New test. ! PR c++/10119 ! * g++.dg/template/ptrmem5.C: New test. ! ! PR c++/10026 ! * g++.dg/lookup/koenig1.C: New test. ! ! PR C++/10199 ! * g++.dg/lookup/template2.C: New test. ! ! 2003-03-24 Jakub Jelinek ! ! * g++.dg/opt/rtti1.C: New test. 2003-03-23 Eric Botcazou *************** *** 1239,1270 **** PR c/8224 * gcc.dg/20030323-1.c: New test. 2003-03-22 Ulrich Weigand * gcc.dg/20030321-1.c: New test. 2003-03-22 Bud Davis * g77.f-torture/execute/select.f: New test. * g77.f-torture/noncompile/select_no_compile.f: New test. 2003-03-20 Mark Mitchell - PR c++/6412 * g++.dg/template/friend17.C: New test. ! 2003-03-19 Jakub Jelinek ! * gcc.dg/20030309-1.c: New test. ! 2003-03-19 Jakub Jelinek ! * gcc.c-torture/execute/20030313-1.c: New test. ! 2003-03-17 Nathan Sidwell ! PR c++/9629 ! * g++.dg/init/ctor2.C: New test. 2003-03-16 Mark Mitchell --- 5841,5906 ---- PR c/8224 * gcc.dg/20030323-1.c: New test. + 2003-03-23 Roger Sayle + + * gcc.c-torture/compile/20030323-1.c: New test case. + 2003-03-22 Ulrich Weigand * gcc.dg/20030321-1.c: New test. + 2003-03-22 Zack Weinberg + + * gcc.dg/Wshadow-1.c: Add a dg-warning line. + + 2003-03-22 Nathan Sidwell + + PR c++/9978, c++/9708 + * g++.dg/ext/vlm1.C: Adjust expected error. + * g++.dg/ext/vla2.C: New test. + * g++.dg/template/arg1.C: New test. + * g++.dg/template/arg2.C: New test. + 2003-03-22 Bud Davis * g77.f-torture/execute/select.f: New test. * g77.f-torture/noncompile/select_no_compile.f: New test. + 2003-03-21 Nathan Sidwell + + PR c++/9898 + * g++.dg/other/error4.C: New test. + 2003-03-20 Mark Mitchell * g++.dg/template/friend17.C: New test. ! 2003-03-21 Alan Modra ! * gcc.c-torture/compile/20030320-1.c: New. ! 2003-03-20 Roger Sayle ! * gcc.dg/builtins-6.c: New test case. ! 2003-03-19 Alan Modra ! PR target/10073 ! * gcc.c-torture/compile/20030319-1.c: New. ! ! 2003-03-18 Jan Hubicka ! ! * gcc.dg/i386-cvt-1.c: New test. ! ! 2003-03-17 Zack Weinberg ! ! * objc.dg/naming-1.m: Use "(parse|syntax) error". ! * objc.dg/naming-2.m: Likewise. ! ! 2003-03-17 Mark Mitchell ! ! PR c++/9639 ! * g++.dg/parse/crash1.C: New test. 2003-03-16 Mark Mitchell *************** *** 1275,1280 **** --- 5911,5925 ---- * gcc.c-torture/execute/20030316-1.c: New test case. + 2003-03-16 Nathan Sidwell + + PR c++/9629 + * g++.dg/init/ctor2.C: New test. + + 2003-03-15 Roger Sayle + + * g77.f-torture/compile/xformat.f: New test case. + 2003-03-15 John David Anglin * g++.old-deja/g++.mike/eh33.C: Remove xfail for hppa*-*-*. *************** *** 1286,1301 **** * g++.dg/template/spec7.C: New test. * g++.dg/template/spec8.C: Likewise. 2003-03-14 Eric Botcazou * gcc.c-torture/compile/20030314-1.c: New test. ! 2003-03-13 Mark Mitchell ! * g++.dg/parse/namespace9.C: New test. 2003-03-13 Mark Mitchell * g++.dg/init/ref5.C: New test. * g++.dg/parse/ptrmem1.C: Likewise. --- 5931,5964 ---- * g++.dg/template/spec7.C: New test. * g++.dg/template/spec8.C: Likewise. + 2003-03-14 Jakub Jelinek + + * gcc.c-torture/execute/20030313-1.c: New test. + + 2003-03-14 Richard Henderson + + * gcc.dg/inline-2.c: Adjust alpha test for external call. + 2003-03-14 Eric Botcazou * gcc.c-torture/compile/20030314-1.c: New test. ! 2003-03-13 Danny Smith ! * gcc.dg/dll-1.c: Remove thumb target. Change exp to _exp. ! * gcc.dg/dll-2.c: Enable for cygwin and mingw. Remove ! thumb target, ! * gcc.dg/dll-3.c: Likewise. Adjust scan-assembler ! to accept newer _imp__ prefix and additional ! newline in .drectve section. ! * gcc.dg/dll-4.c: Likewise. ! * gcc.dg/dll-5.c: New file to test -mnop-fun-dllimport ! switch. 2003-03-13 Mark Mitchell + * g++.dg/parse/namespace9.C: New test. + * g++.dg/init/ref5.C: New test. * g++.dg/parse/ptrmem1.C: Likewise. *************** *** 1304,1315 **** * gcc.dg/special/ecos.exp (gcsec-1.c): Find linker used by gcc. * gcc.dg/old-style-asm-1.c (dg-final): Add hpux label alternative to regular expression. * gcc.dg/inline-1.c (dg-final): Check for "xyzzy?,%r" on hppa*-*-*. - 2003-03-12 Steven Bosscher - - * gcc.dg/return-type-3.c: New test. - 2003-03-12 Daniel Jacobowitz * gcc.c-torture/execute/20030224-2.c: New test. --- 5967,5975 ---- * gcc.dg/special/ecos.exp (gcsec-1.c): Find linker used by gcc. * gcc.dg/old-style-asm-1.c (dg-final): Add hpux label alternative to regular expression. + * gcc.dg/funcorder.c (dg-final): Check for "link_error,%r" on hppa*-*-*. * gcc.dg/inline-1.c (dg-final): Check for "xyzzy?,%r" on hppa*-*-*. 2003-03-12 Daniel Jacobowitz * gcc.c-torture/execute/20030224-2.c: New test. *************** *** 1327,1359 **** PR c++/9474 * g++.dg/parse/namespace8.C: New test. - 2003-03-11 Mark Mitchell - PR c++/9924 * g++.dg/overload/builtin2.C: New test. 2003-03-10 Devang Patel - PR c++/9394 * g++.dg/cpp/c++_cmd_1.C: New test. * g++.dg/cpp/c++_cmd_1.h: New file. ! 2003-03-09 Mark Mitchell ! PR c++/9373 ! * cp-lang.c (cxx_get_alias_set): Use alias set zero for ! pointers to member functions. ! 2003-03-09 Mark Mitchell ! PR c++/8534 ! * g++.dg/opt/ptrmem1.C: New test. 2003-03-09 Mark Mitchell ! PR c++/9912 ! * g++.dg/parse/class1.C: New test. ! * g++.old-deja/g++.other/decl5.C: Adjust. 2003-03-09 Eric Botcazou --- 5987,6030 ---- PR c++/9474 * g++.dg/parse/namespace8.C: New test. PR c++/9924 * g++.dg/overload/builtin2.C: New test. + 2003-03-11 Steven Bosscher + + * gcc.dg/return-type-3.c: New test. + + 2003-03-11 D.Venkatasubramanian + + * gcc.misc-tests/bprob.exp: Disable test cases for h8300-*-* as + profiling options are not supported. + + 2003-03-10 Mark Mitchell + + * g++.old-deja/g++.benjamin/16077.C: Adjust warnings. + * g++.old-deja/g++.warn/impint2.C: Likewise. + 2003-03-10 Devang Patel * g++.dg/cpp/c++_cmd_1.C: New test. * g++.dg/cpp/c++_cmd_1.h: New file. ! 2003-03-10 Segher Boessenkool ! * gcc.dg/altivec-9.c: New file. ! 2003-03-10 Franz Sirl ! * gcc.dg/ppc-sdata-1.c: New test. ! * gcc.dg/ppc-sdata-2.c: New test. 2003-03-09 Mark Mitchell ! PR c++/9373 ! * g++.dg/opt/ptrmem2.C: New test. ! ! PR c++/8534 ! * g++.dg/opt/ptrmem1.C: New test. 2003-03-09 Eric Botcazou *************** *** 1364,1369 **** --- 6035,6045 ---- PR c++/9970 * g++.dg/lookup/friend1.C: New test. + 2003-03-08 Mark Mitchell + + PR c++/9823 + * g++.dg/parser/constructor1.C: New test. + 2003-03-08 Hans-Peter Nilsson * gcc.c-torture/execute/20020720-1.x: Add xfail for cris-*-*. *************** *** 1374,1423 **** * gcc.dg/cpp/Wunused.c: Update test. 2003-03-08 Mark Mitchell PR c++/9809 * g++.dg/parse/builtin1.C: New test. 2003-03-07 Mark Mitchell * g++.dg/init/ref4.C: New test. ! 2003-03-07 Eric Botcazou ! * gcc.c-torture/execute/20030307-1.c: New test. 2003-03-06 Mark Mitchell * g++.dg/init/ref3.C: New test. - 2003-03-06 Mark Mitchell - PR c++/9965 * g++.dg/init/ref2.C: New test. PR c++/9400 * g++.dg/warn/Wshadow-2.C: New test. - 2003-03-06 Mark Mitchell - PR c++/9791 * g++.dg/warn/Woverloaded-1.C: New test. 2003-03-05 Eric Botcazou ! * gcc.c-torture/compile/20030305-1.c: New test. ! 2003-03-04 Roger Sayle ! * g++.old-deja/g++.other/builtins10.C: New test for PR 9367. ! * gcc.dg/format/attr-5.c: Handle new conflicting types warning. 2003-03-03 Mark Mitchell PR c++/9878 * g++.dg/init/ref1.C: New test. 2003-03-02 Stephane Carrez * gcc.c-torture/execute/960312-1.x: New file, must pass -mshort --- 6050,6149 ---- * gcc.dg/cpp/Wunused.c: Update test. + 2003-03-08 Jan Hubicka + + * gcc.dg/inline-3.c: New test. + 2003-03-08 Mark Mitchell PR c++/9809 * g++.dg/parse/builtin1.C: New test. + PR c++/9982 + * g++.dg/abi/cookie1.C: New test. + * g++.dg/abi/cookie2.C: Likewise. + + PR c++/9524 + * g++.dg/template/field1.C: New test. + + PR c++/9912 + * g++.dg/parse/class1.C: New test. + * g++.dg/parse/namespace7.C: Likewise. + * g++.old-deja/g++.other/decl5.C: Remove XFAILs. + 2003-03-07 Mark Mitchell * g++.dg/init/ref4.C: New test. ! 2003-03-07 Jan Hubicka ! * gcc.dg/i386-local2.c: Fix problems with certain versions of dejagnu. ! * gcc.dg/inline-3.c: New test. 2003-03-06 Mark Mitchell * g++.dg/init/ref3.C: New test. PR c++/9965 * g++.dg/init/ref2.C: New test. PR c++/9400 * g++.dg/warn/Wshadow-2.C: New test. PR c++/9791 * g++.dg/warn/Woverloaded-1.C: New test. + 2003-03-05 Jan Hubicka + + * gcc.dg/i386-local2.c: New. + * gcc.dg/i386-local.c: Fix typo. + + 2003-03-05 Mark Mitchell + + * g++.dg/abi/layout3.C: New test. + 2003-03-05 Eric Botcazou ! * gcc.c-torture/compile/20030305-1.c ! 2003-03-05 Jan Hubicka ! * gcc.dg/i386-local.c: New. ! ! 2003-03-04 J"orn Rennecke ! ! * gcc.dg/sh-relax.c: Disable for sh64-*-*. ! ! 2003-03-04 Eric Botcazou ! ! * gcc.dg/switch-2.c: New test. ! * gcc.dg/switch-3.c: New test. ! * gcc.dg/Wswitch.c: Adjust line numbers. ! * gcc.dg/Wswitch-default.c: Likewise. ! * gcc.dg/Wswitch-enum.c: Likewise. ! ! 2003-03-04 Alexandre Oliva ! ! * gcc.c-torture/execute/20030222-1.c: New test. ! ! 2003-03-03 James E Wilson ! ! * gcc.dg/m68k-slp-ice.c: New test for PR c/7872. 2003-03-03 Mark Mitchell PR c++/9878 * g++.dg/init/ref1.C: New test. + 2003-03-03 J"orn Rennecke + + * gcc.dg/sh-relax.c: New SH-only test. + + 2003-03-03 Geoffrey Keating + + * gcc.c-torture/compile/20010327-1.c: Back out last change. Add + comment explaining purpose of testcase. + 2003-03-02 Stephane Carrez * gcc.c-torture/execute/960312-1.x: New file, must pass -mshort *************** *** 1435,1455 **** * gcc.c-torture/compile/980506-1.x: Don't execute this test on HC11/HC12 (array is too large). 2003-02-28 Mark Mitchell PR c++/9879 * testsuite/g++.dg/init/new4.C: New test. 2003-02-25 Mark Mitchell PR c++/9829 ! * g++.dg/parse/namespace1.C: New test. 2003-02-25 Franz Sirl PR target/9732 * gcc.dg/20030225-1.c: New test. 2003-02-24 Rainer Orth * g++.dg/other/pragma-ep-1.C: Test for __PRAGMA_EXTERN_PREFIX. --- 6161,6238 ---- * gcc.c-torture/compile/980506-1.x: Don't execute this test on HC11/HC12 (array is too large). + 2003-03-01 Geoffrey Keating + + * lib/gcc-dg.exp (gcc-dg-test): Change .pch to .gch. + * lib/g++-dg.exp (g++-dg-test): Likewise. + + 2003-03-01 Roger Sayle + + * g++.old-deja/g++.other/builtins10.C: New test for PR 9367. + * gcc.dg/format/attr-5.c: Handle new conflicting types warning. + + 2003-03-01 Kriang Lerdsuwanakij + + * g++.dg/warn/implicit-typename1.C: Remove warning. + + 2003-02-28 Richard Henderson + + * gcc.dg/noreturn-1.c: Move noreturn warning line. + * gcc.dg/return-type-1.c: Move control reaches end warning line. + + 2003-02-28 Geoffrey Keating + + * gcc.dg/pch/pch.exp: Change .pch to .gch. + * g++.dg/pch/pch.exp: Likewise. + 2003-02-28 Mark Mitchell PR c++/9879 * testsuite/g++.dg/init/new4.C: New test. + 2003-02-28 Richard Earnshaw + + * gcc.dg/arm-asm.c: Enable for StrongARM and XScale targets. + + 2003-02-28 Alexandre Oliva + + * gcc.c-torture/compile/20010327-1.c: Use __SIZE_TYPE__ instead of + unsigned long. + + * gcc.c-torture/compile/simd-3.c: Do nothing if double is not + wider than float. + + 2003-02-26 Zdenek Dvorak + + * lib/scanasm.exp: Add support for counting numbers of + occurences. + * gcc.dg/unswitch-1.c, gcc.dg/peel-1.c, gcc.dg/unroll-1.c, + gcc.dg/unroll-2.c, gcc.dg/unroll-3.c: New tests. + 2003-02-25 Mark Mitchell + PR c++/9683 + * g++.dg/template/static3.C: New test. + PR c++/9829 ! * g++.dg/parse/namespace6.C: New test. 2003-02-25 Franz Sirl PR target/9732 * gcc.dg/20030225-1.c: New test. + 2003-02-24 Mark Mitchell + + * README: Remove out-of-date information. + + PR c++/9836 + * g++.dg/template/spec6.C: New test. + + 2003-02-24 Jeff Law + + * gcc.c-torture/compile/20030224-1.c: New test for ia32 backend bug. + 2003-02-24 Rainer Orth * g++.dg/other/pragma-ep-1.C: Test for __PRAGMA_EXTERN_PREFIX. *************** *** 1460,1499 **** PR c++/9602 * g++.dg/template/friend16.C: New test. 2003-02-23 Kriang Lerdsuwanakij PR c++/7982 * g++.dg/warn/implicit-typename1.C: New test. ! 2003-02-22 Hans-Peter Nilsson ! * gcc.dg/asmreg-1.c: New test. ! 2003-02-21 Richard Henderson ! * gcc.dg/attr-invalid.c: Allow __used__ on static data. 2003-02-21 Mark Mitchell PR c++/9749 * g++.dg/parse/varmod1.C: New test. PR c++/9727 * g++.dg/template/op1.C: New test. - 2003-02-21 Zack Weinberg - - * gcc.dg/cpp/include3.c: New test. - * gcc.dg/cpp/inc/foo.h: New file. - 2003-02-21 Mark Mitchell PR c++/8906 * g++.dg/template/nested2.C: New test. PR c++/8724 * g++.dg/expr/dtor1.C: New test. 2003-02-21 Glen Nakamura * gcc.c-torture/execute/20030221-1.c: New test. --- 6243,6317 ---- PR c++/9602 * g++.dg/template/friend16.C: New test. + 2003-02-23 Mark Mitchell + + PR c++/5333 + * g++.dg/parse/fused-params1.C: Adjust error messages. + * g++.dg/template/nested3.C: New test. + + 2003-02-24 Alan Modra + + * g++.dg/abi/param1.C: New test. + 2003-02-23 Kriang Lerdsuwanakij PR c++/7982 * g++.dg/warn/implicit-typename1.C: New test. ! 2003-02-22 Kelley Cook ! * g++.old-deja/g++.other/store-expr1.C: Replace "mcpu" ! with "mtune". ! * g++.old-deja/g++.other/store-expr2.C: Likewise. ! * gcc.c-torture/execute/20010129-1.x: Likewise. ! * gcc.dg/20011107-1.c: Likewise. ! * gcc.dg/20020108-1.c: Likewise. ! * gcc.dg/20020122-3.c: Likewise. ! * gcc.dg/20020206-1.c: Likewise. ! * gcc.dg/20020310-1.c: Likewise. ! * gcc.dg/20020426-2.c: Likewise. ! * gcc.dg/20020517-1.c: Likewise. ! * gcc.dg/991230-1.c: Likewise. ! * gcc.dg/i386-unroll-1.c: Likewise. ! * gcc.misc-tests/i386-prefetch.exp: Likewise. ! 2003-02-22 Jan Hubicka ! * gcc.dg/i386-mul.c: New test. ! ! 2003-02-21 Roger Sayle ! ! * gcc.dg/builtins-5.c: New test case. ! ! 2003-02-22 Hans-Peter Nilsson ! ! * gcc.dg/asmreg-1.c: New test. 2003-02-21 Mark Mitchell PR c++/9749 * g++.dg/parse/varmod1.C: New test. + 2003-02-21 Mark Mitchell + PR c++/9727 * g++.dg/template/op1.C: New test. 2003-02-21 Mark Mitchell PR c++/8906 * g++.dg/template/nested2.C: New test. + 2003-02-21 Mark Mitchell + PR c++/8724 * g++.dg/expr/dtor1.C: New test. + 2003-02-21 Zack Weinberg + + * gcc.dg/cpp/include3.c: New test. + * gcc.dg/cpp/inc/foo.h: New file. + 2003-02-21 Glen Nakamura * gcc.c-torture/execute/20030221-1.c: New test. *************** *** 1511,1538 **** * gcc.c-torture/compile/20030219-1.c: New test. 2003-02-18 Kazu Hirata * gcc.c-torture/execute/20030218-1.c: New. 2003-02-18 Mark Mitchell PR c++/9704 * g++.dg/init/copy5.C: New test. ! 2003-02-18 Kriang Lerdsuwanakij PR c++/9459 * g++.dg/ext/typeof4.C: New test. ! 2003-02-12 Jan Hubicka ! * gcc.dg/i386-mmx-3.c: Change -march=k8 to -march=athlon. ! * gcc.dg/i386-ssetype-1.c: Likewise. ! * gcc.dg/i386-ssetype-2.c: Likewise. ! * gcc.dg/i386-ssetype-3.c: Likewise. ! * gcc.dg/i386-ssetype-4.c: Likewise. ! * gcc.dg/i386-ssetype-5.c: Likewise. 2003-02-14 Josef Zlomek --- 6329,6386 ---- * gcc.c-torture/compile/20030219-1.c: New test. + 2003-02-18 Jan Hubicka + + * gcc.dg/funcorder.c: New test. + 2003-02-18 Kazu Hirata * gcc.c-torture/execute/20030218-1.c: New. + 2003-02-18 Aldy Hernandez + + * gcc.dg/20030218-1.c: New. + + 2003-02-18 Richard Henderson + + * gcc.dg/attr-invalid.c: Allow __used__ on static data. + * gcc.dg/attr-used-2.c: New. + 2003-02-18 Mark Mitchell PR c++/9704 * g++.dg/init/copy5.C: New test. ! 2003-02-18 Geoffrey Keating ! ! * gcc.dg/pch/pch.exp: Delete $bname.h before copying into it. ! * g++.dg/pch/pch.exp: Likewise. ! ! 2003-02-18 Kazu Hirata ! ! * gcc.c-torture/execute/20030209-1.c: Enable the test if ! STACK_SIZE is not defined. ! ! 2003-02-17 Kriang Lerdsuwanakij ! ! PR c++/9457 ! * g++.dg/template/init1.C: New test. ! ! 2003-02-16 Jan HUbicka ! ! * gcc.dg/c90-const-expr-3.c (DZERO): New static variable ! (foo): Add few extra tests ! * gcc.dg/c99-const-expr-3.c: Likewise. ! * gcc.c-torture/execute/20030216-1.c: New. ! ! 2003-02-16 Kriang Lerdsuwanakij PR c++/9459 * g++.dg/ext/typeof4.C: New test. ! 2003-02-15 Roger Sayle ! * gcc.dg/i386-387-3.c: New test case. 2003-02-14 Josef Zlomek *************** *** 1543,1587 **** * gcc.dg/20030213-1.c: New test. ! 2003-02-11 Mark Mitchell ! * g++.dg/parse/octal1.C: New file. 2003-02-10 Eric Botcazou Christian Ehrhardt * gcc.dg/decl-2.c: New test. 2003-02-06 Kaveh R. Ghazi * gcc.dg/20020430-1.c: Fix dg command typos. * gcc.dg/20020503-1.c: Likewise. 2003-02-06 Eric Botcazou * gcc.c-torture/compile/20030206-1.c: New test. 2003-02-05 Kaveh R. Ghazi * gcc.c-torture/execute/20020227-1.x: Update specific XFAIL conditions for SPARC targets. 2003-02-04 Jan Hubicka ! * gcc.dg/i386-ssetype-?.c: Compile using -march=k8; fix for register ! passing convetions. 2003-02-03 Mark Mitchell PR c++/7129 * testsuite/g++.dg/ext/max.C: New test. 2003-02-03 Richard Earnshaw * gcc.c-torture/exectue/ieee/20000320-1.c: The ARM VFP format is 'natural-endian'. ! 2003-02-01 Loren J. Rittle * gcc.dg/struct-ret-libc.c: New test. --- 6391,6541 ---- * gcc.dg/20030213-1.c: New test. ! 2003-02-12 Roger Sayle ! * gcc.dg/i386-387-1.c: Add new test for __builtin_atan2. ! * gcc.dg/i386-387-2.c: Likewise. ! ! 2003-02-12 Aldy Hernandez ! ! * gcc.dg/ppc-spe.c: Fix formatting. ! Enable tests that were previously unsupported by gas. ! Delete tests for instructions that no longer exist. ! Switch arguments on evsubifw builtin. ! ! 2003-02-12 Kazu Hirata ! ! * gcc.c-torture/execute/20030209-1.c: Disable the test if ! STACK_SIZE is too small. 2003-02-10 Eric Botcazou Christian Ehrhardt * gcc.dg/decl-2.c: New test. + 2003-02-10 Jan Hubicka + + * gcc.dg/i386-fpcvt-1.c: New test. + + 2002-02-09 Richard Sandiford + + * gcc.c-torture/execute/20030209-1.c: New test. + + 2003-02-09 Kazu Hirata + + * gcc.c-torture/execute/builtin-bitops-1.c: When testing the + int-wide bitops, use the constants of the same width. + Likewise, if long long is 32-bit wide, test bitops using + 32-bit constants. + + 2003-02-07 Loren James Rittle + + * gcc.dg/20021014-1.c: Annotate with expected notice text. + + 2003-02-07 Roger Sayle + + * testsuite/gcc.dg/builtins-4.c: New test case. + 2003-02-06 Kaveh R. Ghazi * gcc.dg/20020430-1.c: Fix dg command typos. * gcc.dg/20020503-1.c: Likewise. + 2003-02-06 Volker Reichelt + + PR c++/8785 + * g++.dg/parse/fused-params1.C: New test. + + PR c++/8857 + * g++.dg/parse/tmpl-tmpl-operator1.C: New test. + + PR c++/8921 + * g++.dg/parse/non-dependent1.C: New test. + + PR c++/8928 + * g++.dg/parse/dupl-tmpl-args1.C: New test. + + PR c++/9228 + * g++.dg/parse/undefined7.C: New test. + * g++.dg/parse/non-templ1.C: New test. + + PR c++/9229 + * g++.dg/parse/too-many-tmpl-args1.C: New test. + 2003-02-06 Eric Botcazou * gcc.c-torture/compile/20030206-1.c: New test. + 2003-02-05 Roger Sayle + + * gcc.c-torture/compile/921206-1.c: Rename undeclared function from + "pow" to "foo" to avoid potential confusion with a math built-in. + 2003-02-05 Kaveh R. Ghazi * gcc.c-torture/execute/20020227-1.x: Update specific XFAIL conditions for SPARC targets. + 2003-02-05 Jakub Jelinek + + * gcc.dg/20030204-1.c: New test. + + 2003-02-04 Volker Reichelt + + PR c++/38 + * g++.dg/parse/array-size1.C: New test. + + PR c++/5657 + * g++.dg/parse/undefined3.C: New test. + + PR c++/5665 + * g++.dg/parse/undefined4.C: New test. + + PR c++/5975 + * g++.dg/parse/undefined5.C: New test. + + PR c++/7259 + * g++.dg/parse/tmpl-tmpl-param1.C: New test. + + PR c++/8578 + * g++.dg/parse/casting-operator1.C: New test. + + PR c++/8596 + * g++.dg/parse/undefined6.C: New test. + + PR c++/8736 + * g++.dg/parse/missing-template1.C: New test. + 2003-02-04 Jan Hubicka ! * gcc.dg/i386-cadd.c: Compile using -march=k8. ! * gcc.dg/i386-cmov?.c: Likewise. ! * gcc.dg/i386-fpcvt-?.c: Likewise. ! * gcc.dg/i386-ssefp-1.c: Likewise. ! * gcc.dg/i386-ssetype-?.c: Likewise; fix for register passing ! conventions. 2003-02-03 Mark Mitchell PR c++/7129 * testsuite/g++.dg/ext/max.C: New test. + 2003-02-03 Jan Hubicka + + * gcc.c-torture/execute/20030203-1.c: New test. + 2003-02-03 Richard Earnshaw * gcc.c-torture/exectue/ieee/20000320-1.c: The ARM VFP format is 'natural-endian'. ! 2003-02-01 Richard Sandiford ! ! * g++.dg/init/new1.C: Remove -fvolatile dg-options line. ! * g++.dg/init/new2.C: Likewise. ! * g++.dg/other/new1.C: Likewise. ! ! 2003-01-31 Loren J. Rittle * gcc.dg/struct-ret-libc.c: New test. *************** *** 1589,1627 **** * gcc.dg/20030129-1.c: New test. - 2003-01-31 Paolo Carlini - - Further tweaks for Bison-1.875. - * g++.dg/lookup/using2.C: Test for "(parse|syntax) error". - * g++.dg/other/do1.C: Likewise. - * g++.dg/parse/angle-bracket.C: Likewise. - * g++.dg/template/typename3.C: Likewise. - 2003-01-31 Kriang Lerdsuwanakij PR c++/8849 * g++.dg/template/ptrmem4.C: New test. ! 2003-01-31 Kriang Lerdsuwanakij ! PR c++/9453 ! * g++.dg/template/friend14.C: New test. ! * g++.dg/template/friend15.C: New test. ! * g++.old-deja/g++.other/defarg1.C: Adjust error message. 2003-01-29 Nathan Sidwell PR c++/9437 * g++.dg/template/unify4.C: New test. 2003-01-28 Nathan Sidwell ! * g++.dg/abi/dcast1.C: New test. 2003-01-28 Toon Moene PR fortran/9258 ! * g77.dg/pr9258.f: New test. 2003-01-27 Jeffrey D. Oldham --- 6543,6608 ---- * gcc.dg/20030129-1.c: New test. 2003-01-31 Kriang Lerdsuwanakij PR c++/8849 * g++.dg/template/ptrmem4.C: New test. ! 2003-01-29 Mark Mitchell ! * g++.dg/parser/constant1.C: New test. ! ! 2003-01-29 Kriang Lerdsuwanakij ! ! PR c++/8591 ! * g++.dg/parse/friend2.C: New test. 2003-01-29 Nathan Sidwell PR c++/9437 * g++.dg/template/unify4.C: New test. + 2003-01-28 Richard Sandiford + + * gcc.c-torture/execute/20030128-1.c: New test. + + 2003-01-28 Jeffrey D. Oldham + + * g++.dg/lookup/nested1.C: Test moved from ... + * g++.old-deja/g++.other/lookup24.C: ... here. + + 2003-01-28 Jan Hubicka + + * gcc.dg/i386-cmov5.c: New test. + + 2003-01-28 D.Venkatasubramanian + + * gcc.c-torture/execute/20010925-1.c: Changed the + memcpy declaration. + 2003-01-28 Nathan Sidwell ! PR c++/3902 ! * g++.dg/parse/template5.C: New test. 2003-01-28 Toon Moene PR fortran/9258 ! * g77.dg/pr9258: New test. ! ! 2003-01-28 Gerald Pfeifer ! ! * README: Move relevant parts from README.g++. ! ! * README.g++: Remove this file. ! ! 2003-01-28 Nathan Sidwell ! ! * g++.dg/abi/dcast1.C: New test. ! ! 2003-01-28 Kaveh R. Ghazi ! ! * gcc.c-torture/execute/builtin-constant.x: Only expect failure at -O1. 2003-01-27 Jeffrey D. Oldham *************** *** 1633,1651 **** PR middle-end/7227 * gcc.dg/uninit-C.c: New test. 2003-01-25 Jan Hubicka PR opt/8492 * gcc.c-torture/compile/20030125-1.c ! 2003-01-25 Ulrich Weigand ! * gcc.dg/20030123-1.c: New test. 2003-01-25 Paolo Carlini Tweaks for Bison-1.875. From the NEWS file: ! "- `parse error' -> `syntax error' Bison now uniformly uses the term `syntax error'" * gcc.dg/cpp/19990413-1.c: Test for "(parse|syntax) error". * gcc.dg/cpp/digraph2.c: Likewise. --- 6614,6661 ---- PR middle-end/7227 * gcc.dg/uninit-C.c: New test. + 2003-01-27 Nathan Sidwell + + * g++.dg/abi/covariant1.C: New test. + + 2003-01-25 Ulrich Weigand + + * gcc.dg/20030123-1.c: New test. + 2003-01-25 Jan Hubicka PR opt/8492 * gcc.c-torture/compile/20030125-1.c ! 2003-01-25 Nathan Sidwell ! PR c++/9403 ! * g++.dg/parse/template3.C: New test. ! * g++.old-deja/g++.pt/memclass5.C: Add needed template keyword. ! ! PR c++/795 ! * g++.dg/parse/template4.C: New test. ! ! PR c++/9415 ! * g++.dg/template/qual2.C: New test. ! ! PR c++/8545 ! * g++.old-deja/g++.brendan/parse3.C: Remove XFAIL. ! ! * g++.old-deja/g++.ns/bogus1.C: Change expected error. ! ! 2003-01-25 Roger Sayle ! ! * gcc.c-torture/execute/switch-1.c: New test case. ! ! 2003-01-25 Jan Hubicka ! ! * gcc.c-torture/execute/20030125-1.[cx]: New test. 2003-01-25 Paolo Carlini Tweaks for Bison-1.875. From the NEWS file: ! "- `parse error' -> `syntax error' Bison now uniformly uses the term `syntax error'" * gcc.dg/cpp/19990413-1.c: Test for "(parse|syntax) error". * gcc.dg/cpp/digraph2.c: Likewise. *************** *** 1661,1675 **** --- 6671,6839 ---- * gcc.dg/noncompile/971104-1.c: Likewise. * gcc.dg/noncompile/990416-1.c: Likewise. + 2003-01-24 Paolo Carlini + + * g++.dg/parse/undefined1.C: Add error message. + 2003-01-22 Mark Mitchell + PR c++/9354 + * g++.dg/parse/new1.C: New test. + + PR c++/9216 + * g++.dg/parse/template2.C: New test. + + PR c++/9354 + * g++.dg/parse/typedef2.C: New test. + PR c++/9328 * g++.dg/ext/typeof3.C: New test. + 2003-01-22 Volker Reichelt + + PR c++/2738 + * g++.dg/parse/ret-type1.C: New test. + + PR c++/3792 + * g++.dg/parse/tmpl-outside1.C: New test. + + PR c++/4207 + * g++.dg/parse/int-as-enum1.C: New test. + + PR c++/4903 + * g++.dg/parse/no-typename1.C: New test. + + PR c++/5533 + * g++.dg/parse/no-value1.C: New test. + + PR c++/5921 + * g++.dg/parse/wrong-inline1.C: New test. + + PR c++/6402 + * g++.dg/parse/ref1.C: New test. + + PR c++/6992 + * g++.dg/parse/attr-ctor1.C: New test. + + PR c++/7229 + * g++.dg/parse/namespace5.C: New test. + + PR c++/7917 + * g++.dg/parse/func-def1.C: New test. + + PR c++/8143 + * g++.dg/parse/undefined1.C: New test. + + PR c++/5723, PR c++/8522 + * g++.dg/parse/specialization1.C: New test. + + PR c++/163, PR c++/8595 + * g++.dg/parse/struct-as-enum1.C: New test. + + PR c++/9173 + * g++.dg/parse/undefined2.C: New test. + + 2003-01-22 Mark Mitchell + + PR c++/9298 + * g++.dg/parse/template1.C: New test. + + PR c++/9384 + * g++.dg/parse/using1.C: New test. + + PR c++/9285 + PR c++/9294 + * g++.dg/parse/expr2.C: New test. + + PR c++/9388 + * g++.dg/parse/lookup2.C: Likewise. + + 2003-01-21 Jan Hubicka + + * gcc.c-torture/execute/990208-1.c: Add noinline attributes as needed. + * gcc.c-torture/execute/eeprof-1.c: Likewise. + * gcc.c-torture/execute/stdio-opt-*.c: Likewise. + * gcc.c-torture/execute/string-opt-*.c: Likewise. + + 2003-01-20 Nick Clifton + + * gcc.c-torture/execute/20030117-1.c: New test case. Exposes + problem with ARM sibcall code generation. + 2003-01-20 Kazu Hirata * gcc.c-torture/execute/20030120-1.c: New. + 2003-01-19 Paolo Carlini + + * g++.old-deja/g++.pt/typename13.C: Remove XFAIL. + + 2003-01-17 Mark Mitchell + + PR c++/9272 + * g++.dg/parse/ctor1.C: New test. + + PR c++/9294: + * g++.dg/parse/qualified1.C: New test. + + * g++.dg/parse/typename3.C: New test. + + 2003-01-16 Richard Henderson + + * g++.dg/tls/init-2.C: Fix error matches for real this time. + + 2003-01-16 Richard Henderson + + * g++.dg/pch/pch.exp: Copy test header to the working directory + before using it either for precompilation or direct use. + * g++.dg/pch/*.Hs: Rename from gcc.dg/pch/*.H. + * g++.dg/pch/*.C: Include foo.H, not foo.Hp. + + 2003-01-16 Richard Henderson + + * gcc.dg/pch/pch.exp: Copy test header to the working directory + before using it either for precompilation or direct use. + * gcc.dg/pch/*.hs: Rename from gcc.dg/pch/*.h. + * gcc.dg/pch/*.c: Include foo.h, not foo.hp. + + 2003-01-16 Mark Mitchell + + * gcc/testsuite/g++.dg/ext/typename1.C: Add typename keyword. + * gcc/testsuite/g++.dg/template/crash1.C: Update error messages. + * gcc/testsuite/g++.dg/template/crash2.C: Remove error message. + * gcc/testsuite/g++.dg/parse/typename2.C: New test. + * gcc/testsuite/g++.dg/template/typename2.C: Change implicit + typename warning into error. + * gcc/testsuite/g++.old-deja/g++.benjamin/tem03.C: Issue more + error messages. + * gcc/testsuite/g++.old-deja/g++.benjamin/tem04.C: Fix typos. + * gcc/testsuite/g++.old-deja/g++.brendan/crash56.C: Add this->. + * gcc/testsuite/g++.old-deja/g++.law/visibility13.C: Remove error + messages. + * gcc/testsuite/g++.old-deja/g++.ns/template17.C: Reorder code to + make declaration visible in template. + * gcc/testsuite/g++.old-deja/g++.pt/crash3.C: Fix typos. + * gcc/testsuite/g++.old-deja/g++.pt/crash36.C: Issue more error + messages. + * gcc/testsuite/g++.old-deja/g++.pt/crash5.C: Improve error + message. + * gcc/testsuite/g++.old-deja/g++.pt/crash67.C: Remove warning. + * gcc/testsuite/g++.old-deja/g++.pt/inherit1.C: Add this->. + * gcc/testsuite/g++.old-deja/g++.pt/niklas01a.C: Add error message. + * gcc/testsuite/g++.old-deja/g++.pt/typename16.C: Replace implicit + typename warning with error message. + * gcc/testsuite/g++.old-deja/g++.pt/typename19.C: Remove warning. + * gcc/testsuite/g++.old-deja/g++.robertl/eb112.C: Fix typo. + * gcc/testsuite/g++.old-deja/g++.robertl/eb24.C: Use this->. + + 2003-01-16 Nathan Sidwell + + * g++.dg/parse/ambig2.C: New test. + + 2003-01-15 Richard Henderson + + * g++.dg/tls/init-2.C: Update error message string. + 2003-01-15 Kaveh R. Ghazi * gcc.c-torture/execute/builtin-constant.x: XFAIL the test. *************** *** 1684,1731 **** * gcc.c-torture/compile/961203-1.x: Likewise. * gcc.c-torture/compile/20020604-1.x: Likewise. 2003-01-14 Eric Botcazou * gcc.dg/i386-mmx-3.c: New test. 2003-01-10 Josef Zlomek * gcc.c-torture/compile/20030110-1.c: New test. 2003-01-09 Eric Botcazou * gcc.dg/old-style-asm-1.c: New test. 2003-01-09 Eric Botcazou * gcc.c-torture/execute/20030109-1.c: New test. ! 2003-01-07 Kriang Lerdsuwanakij PR c++/9030 * g++.dg/template/friend12.C: New test. * g++.dg/template/friend13.C: Likewise. * g++.old-deja/g++.eh/spec6.C: Add missing error message. ! * g++.old-deja/g++.other/defarg1.C: Change expected error message. 2003-01-06 Mark Mitchell PR c++/9165 * g++.dg/warn/Wunused-3.C: New test. 2003-01-03 Nathan Sidwell * g++.dg/template/ntp2.C: New test. 2003-01-02 Kazu Hirata * gcc.dg/h8300-stack-1.c: New. 2002-12-31 Janis Johnson * lib/profopt.exp: Change the name of a global variable to avoid possible clashes with other test suites. 2002-12-26 Nathan Sidwell * g++.dg/warn/inline1.C: New test. --- 6848,7486 ---- * gcc.c-torture/compile/961203-1.x: Likewise. * gcc.c-torture/compile/20020604-1.x: Likewise. + 2003-01-15 Jan Hubicka + + * gcc.c-torture/compile/20030115-1.c: New test. + + * gcc.dg/i386-fpcvt-1.c: New test. + * gcc.dg/i386-fpcvt-2.c: New test. + + 2003-01-14 Jeffrey D. Oldham + + Further conform g++'s __vmi_class_type_info to the C++ ABI + specification. + * g++.old-deja/g++.abi/vmihint.C (main): Revise expected flags per + the specification. + + 2003-01-14 Jan Hubicka + + * gcc.dg/i386-fpcvt-1.c: New test. + * gcc.dg/i386-fpcvt-2.c: New test. + 2003-01-14 Eric Botcazou * gcc.dg/i386-mmx-3.c: New test. + 2003-01-12 Mark Mitchell + + PR c++/9264 + * g++.dg/parse/octal1.C: New file. + + PR c++/9172 + * g++.dg/parse/typename1.C: New file. + + 2003-01-10 Danny Smith + + * gcc.dg/bf-ms-layout.c: Enable for cygwin and mingw32 targets. + * gcc.dg/bf-no-ms-layout.c: Likewise. + * gcc.dg/bf-ms-attrib.c: Likewise. + + 2003-01-10 Mark Mitchell + + PR c++/9099 + * g++.dg/parse/dtor1.C: New file. + + PR c++/9128 + * g++.dg/rtti/typeid1.C: New file. + + PR c++/9153 + * g++.dg/parse/lookup1.C: New file. + + PR c++/9171 + * g++.dg/templ/spec5.C: New file. + 2003-01-10 Josef Zlomek * gcc.c-torture/compile/20030110-1.c: New test. + 2003-01-09 Geoffrey Keating + + Merge from pch-branch: + + 2002-12-23 Geoffrey Keating + + * gcc.dg/pch/cpp-1.h: New. + * gcc.dg/pch/cpp-1.c: New. + * gcc.dg/pch/cpp-2.h: New. + * gcc.dg/pch/cpp-2.c: New. + + 2002-11-19 Geoffrey Keating + + * gcc.dg/pch/except-1.h: New. + * gcc.dg/pch/except-1.c: New. + + 2002-11-13 Geoffrey Keating + + * gcc.dg/pch/pch.exp: Ensure that .hp doesn't exist before + running test. + * gcc.dg/pch: Include *.hp not *.h. + * gcc.dg/pch/system-1.h: New. + * gcc.dg/pch/system-1.c: New. + + 2002-11-11 Geoffrey Keating + + * gcc.dg/pch/pch.exp: Compare .s files with/without PCH, + rather than trying to build and run a program using PCH. + * gcc.dg/pch: Remove dg-do commands from test files. + + 2002-11-08 Geoffrey Keating + + * gcc.dg/pch/macro-3.c: New. + * gcc.dg/pch/macro-3.h: New. + + 2002-11-04 Geoffrey Keating + + * gcc.dg/pch/common-1.c: New. + * gcc.dg/pch/common-1.h: New. + * gcc.dg/pch/decl-1.c: New. + * gcc.dg/pch/decl-1.h: New. + * gcc.dg/pch/decl-2.c: New. + * gcc.dg/pch/decl-2.h: New. + * gcc.dg/pch/decl-3.c: New. + * gcc.dg/pch/decl-3.h: New. + * gcc.dg/pch/decl-4.c: New. + * gcc.dg/pch/decl-4.h: New. + * gcc.dg/pch/decl-5.c: New. + * gcc.dg/pch/decl-5.h: New. + * gcc.dg/pch/global-1.c: New. + * gcc.dg/pch/global-1.h: New. + * gcc.dg/pch/inline-1.c: New. + * gcc.dg/pch/inline-1.h: New. + * gcc.dg/pch/inline-2.c: New. + * gcc.dg/pch/inline-2.h: New. + * gcc.dg/pch/static-1.c: New. + * gcc.dg/pch/static-1.h: New. + * gcc.dg/pch/static-2.c: New. + * gcc.dg/pch/static-2.h: New. + + 2002-09-01 Geoffrey Keating + + * g++.dg/pch/pch.exp: Better handle failing testcases. + * gcc.dg/pch/pch.exp: Likewise. + * gcc.dg/pch/macro-1.c: New. + * gcc.dg/pch/macro-1.h: New. + * gcc.dg/pch/macro-2.c: New. + * gcc.dg/pch/macro-2.h: New. + + 2002-08-27 Geoffrey Keating + + * g++.dg/dg.exp: Treat files in pch/ specially. + * g++.dg/pch/pch.exp: New file. + * g++.dg/pch/empty.H: New file. + * g++.dg/pch/empty.C: New file. + * lib/g++-dg.exp (g++-dg-test): Add case for when $do_what is + "precompile". + + * gcc.dg/pch/pch.exp: New file. + * gcc.dg/pch/empty.h: New file. + * gcc.dg/pch/empty.c: New file. + * lib/gcc-dg.exp (gcc-dg-test): Add case for when $do_what is + "precompile". + + 2003-01-09 Kriang Lerdsuwanakij + + * g++.dg/template/friend14.C: New test. + 2003-01-09 Eric Botcazou * gcc.dg/old-style-asm-1.c: New test. + 2003-01-09 Richard Sandiford + + * gcc.c-torture/compile/20030109-1.c: New test. + 2003-01-09 Eric Botcazou * gcc.c-torture/execute/20030109-1.c: New test. ! 2003-01-08 Larin Hennessey ! ! * g++.old-deja/g++.mike/dyncast1.C: Remove reference to AMD A29K ! * g++.old-deja/g++.mike/dyncast2.C: Likewise ! * g++.old-deja/g++.mike/dyncast3.C: Likewise ! * g++.old-deja/g++.mike/eh2.C: Likewise ! * g++.old-deja/g++.mike/eh3.C: Likewise ! * g++.old-deja/g++.mike/eh5.C: Likewise ! * g++.old-deja/g++.mike/eh6.C: Likewise ! * g++.old-deja/g++.mike/eh7.C: Likewise ! * g++.old-deja/g++.mike/eh8.C: Likewise ! * g++.old-deja/g++.mike/eh9.C: Likewise ! * g++.old-deja/g++.mike/eh10.C: Likewise ! * g++.old-deja/g++.mike/eh12.C: Likewise ! * g++.old-deja/g++.mike/eh13.C: Likewise ! * g++.old-deja/g++.mike/eh14.C: Likewise ! * g++.old-deja/g++.mike/eh16.C: Likewise ! * g++.old-deja/g++.mike/eh17.C: Likewise ! * g++.old-deja/g++.mike/eh18.C: Likewise ! * g++.old-deja/g++.mike/eh21.C: Likewise ! * g++.old-deja/g++.mike/eh23.C: Likewise ! * g++.old-deja/g++.mike/eh24.C: Likewise ! * g++.old-deja/g++.mike/eh25.C: Likewise ! * g++.old-deja/g++.mike/eh26.C: Likewise ! * g++.old-deja/g++.mike/eh27.C: Likewise ! * g++.old-deja/g++.mike/eh28.C: Likewise ! * g++.old-deja/g++.mike/eh29.C: Likewise ! * g++.old-deja/g++.mike/eh31.C: Likewise ! * g++.old-deja/g++.mike/eh33.C: Likewise ! * g++.old-deja/g++.mike/eh34.C: Likewise ! * g++.old-deja/g++.mike/eh35.C: Likewise ! * g++.old-deja/g++.mike/eh36.C: Likewise ! * g++.old-deja/g++.mike/eh37.C: Likewise ! * g++.old-deja/g++.mike/eh38.C: Likewise ! * g++.old-deja/g++.mike/eh39.C: Likewise ! * g++.old-deja/g++.mike/eh40.C: Likewise ! * g++.old-deja/g++.mike/eh41.C: Likewise ! * g++.old-deja/g++.mike/eh42.C: Likewise ! * g++.old-deja/g++.mike/eh44.C: Likewise ! * g++.old-deja/g++.mike/eh46.C: Likewise ! * g++.old-deja/g++.mike/eh47.C: Likewise ! * g++.old-deja/g++.mike/eh48.C: Likewise ! * g++.old-deja/g++.mike/eh49.C: Likewise ! * g++.old-deja/g++.mike/eh50.C: Likewise ! * g++.old-deja/g++.mike/eh51.C: Likewise ! * g++.old-deja/g++.mike/eh53.C: Likewise ! * g++.old-deja/g++.mike/eh55.C: Likewise ! * g++.old-deja/g++.mike/p7912.C: Likewise ! * g++.old-deja/g++.mike/p9706.C: Likewise ! * g++.old-deja/g++.mike/p10416.C: Likewise ! * g++.old-deja/g++.mike/p11667.C: Likewise ! * g77.f-torture/compile/20010519-1.f: Remove reference to Convex. ! Remove redundant reference to Iris. ! * gcc.dg/20020312-2.c: Remove references to AMD A29K, Clipper, Convex, ! Elxsi, i860, Pico Java, and WE32K. ! ! 2003-01-07 Mark Mitchell ! ! * g++.dg/ext/asm4.C: New test. ! ! 2003-01-08 Kriang Lerdsuwanakij PR c++/9030 * g++.dg/template/friend12.C: New test. * g++.dg/template/friend13.C: Likewise. * g++.old-deja/g++.eh/spec6.C: Add missing error message. ! ! 2003-01-08 Jan Hubicka ! ! * gcc.dg/i386-cadd.c: New test. ! * gcc.dg/i386-cmov4.c: Likewise. 2003-01-06 Mark Mitchell PR c++/9165 * g++.dg/warn/Wunused-3.C: New test. + * g++.dg/abi/bitfield9.C: New test. + + PR c++/9189 + * g++.dg/parse/defarg3.C: New test. + + 2003-01-06 Nathan Sidwell + + * g++.dg/parse/ambig1.C: New test. + * g++.dg/parse/defarg2.C: New test. + + 2003-01-05 Mark Mitchell + + * g++.dg/template/defarg-1.C: New test. + * g++.dg/template/local2.C: Likewise. + + 2003-01-05 Richard Sandiford + + * gcc.c-torture/execute/20030105-1.c: New test. + + 2003-01-04 Kriang Lerdsuwanakij + + * g++.dg/parse/namespace3.C: Remove extra semicolons. + * g++.dg/parse/namespace4.C: Likewise. + 2003-01-03 Nathan Sidwell * g++.dg/template/ntp2.C: New test. + 2003-01-03 Nathanael Nerode + + * g++.dg/parse/extern-C-1.C: New test. + + * g++.dg/parse/namespace4.C: New test. + + * g++.dg/template/nested1.C: New test. + + * g++.dg/parse/namespace3.C: New test. + + 2003-01-02 Nathanael Nerode + + * g++.dg/lookup/two-stage1.C: New test. + + 2003-01-02 Kaveh R. Ghazi + + * g++.old-deja/g++.bugs/900404_04.C: Remove XFAIL. + * g++.old-deja/g++.jason/access8.C: Likewise. + * g++.old-deja/g++.other/decl5.C: Likewise. + + 2003-01-02 Neil Booth + + * g++.dg/parse/parse7.C: New test. + + 2003-01-02 Mark Mitchell + + PR c++/2843 + * g++.dg/ext/attrib7.C: New test. + + 2003-01-02 Neil Booth + + * g++.dg/parse/parse6.C: New test. + 2003-01-02 Kazu Hirata * gcc.dg/h8300-stack-1.c: New. + 2003-01-01 Nathanael Nerode + + g++.dg/lookup/exception1.C: New test. + + g++.dg/lookup/template1.C: New test. + + g++.dg/parse/namespace2.C: New test. + + g++.dg/parse/parens2.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/parse/parse5.C: New test. + * g++.dg/lookup/scoped4.C: New test. + + 2003-01-01 Nathanael Nerode + + * g++.dg/parse/parens1.C: New test. + + * g++.dg/parse/parens2.C: Removed, turned out to duplicate + angle-bracket1.C. + * g++.dg/parse/parens2.C: New test. + + * g++.dg/lookup/scope-operator1.C: New test. + + * g++.dg/parse/operator1.C: New test. + + 2003-01-01 Kriang Lerdsuwanakij + + * g++.old-deja/g++.jason/ambig3.C: Remove XFAIL. + * g++.old-deja/g++.other/access6.C: Likewise. + * g++.old-deja/g++.other/decl1.C: Likewise. + * g++.old-deja/g++.pt/typename12.C: Likewise. + + 2002-12-31 Mark Mitchell + + * g++.dg/parse/namespace1.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/parse/parse4.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/parse/parse3.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/parse/parse2.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/template/friend11.C: New test. + + 2003-01-01 Neil Booth + + * g++.dg/parse/parse1.C: New test. + 2002-12-31 Janis Johnson * lib/profopt.exp: Change the name of a global variable to avoid possible clashes with other test suites. + 2002-12-31 Nathan Sidwell + + * g++.dg/inherit/covariant8.C: New test. + + 2002-12-31 Mark Mitchell + + * g++.dg/init/array9.C: New test. + + PR c++/9112 + * g++.dg/parse/expr1.C: New test. + + 2002-12-30 Daniel Jacobowitz + + * gcc.c-torture/compile/20021230-1.c: New test. + + 2002-12-30 Nathan Sidwell + + * g++.dg/inherit/covariant5.C: New test. + * g++.dg/inherit/covariant6.C: New test. + * g++.dg/inherit/covariant7.C: New test. + + 2002-12-29 Kriang Lerdsuwanakij + + PR c++/2739 + * g++.dg/other/access2.C: New test. + + 2002-12-29 Gabriel Dos Reis + + * g++.dg/other/anon-struct.C: No longer fails + * g++.old-deja/g++.brendan/parse4.C: Likewise. + * g++.old-deja/g++.brendan/parse5.C: Likewise. + * g++.old-deja/g++.brendan/parse6.C: Likewise. + + 2002-12-28 Gabriel Dos Reis + + * g++.dg/parse/angle-bracket.C (main): No longer fails. + + 2002-12-27 Mark Mitchell + + * g++.dg/eh/spec4.C: Remove stray semicolon. + * g++.dg/expr/pmf-1.C: Change error message. + * g++.dg/ext/asm1.C: Remove stray semicolon. + * g++.dg/ext/typename1.C: Add missing typenames. + * g++.dg/inherit/template-as-base.C: Change error message. + * g++.dg/lookup/scoped1.C: Likewise. + * g++.dg/lookup/scoped2.C: Likewise. + * g++.dg/lookup/using2.C: Likewise. + * g++.dg/other/component1.C: Remove stray semicolon. + * g++.dg/other/do1.C: Change error message. + * g++.dg/other/error2.C: Likewise. + * g++.dg/other/init1.C: Likewise. + * g++.dg/other/packed1.C: Remove stray semicolon. + * g++.dg/other/ptrmem2.C: Change error message. + * g++.dg/parse/parameter-declaration-1.C: Remove line number + marker. + * g++.dg/special/initp1.C: Remove invalid attribute usage. + * g++.dg/template/access3.C: Add typename keyword. + * g++.dg/template/access5.C: Remove stray semicolon. + * g++.dg/template/access6.C: Likewise. + * g++.dg/template/complit1.C: Likewise. + * g++.dg/template/crash1.C: Change error message. + * g++.dg/template/inherit2.C: Remove stray semicolon. + * g++.dg/template/instantiate2.C: Likewise. + * g++.dg/template/instantiate3.C: Change error message. + * g++.dg/template/qual1.C: Remove stray semicolon. + * g++.dg/template/qualttp18.C: Change error message. + * g++.dg/template/ref1.C: Remove stray semicolon. + * g++.dg/template/sizeof1.C (A::value): Declare it. + * g++.dg/template/spec4.C: Change error message. + * g++.dg/template/static1.C: Likewise. + * g++.dg/template/type1.C: Likewise. + * g++.dg/template/typename3.C: Likewise. + * g++.old-deja/g++.benjamin/13478.C: Change error message. + * g++.old-deja/g++.benjamin/15799.C: Remove stray semicolon. + * g++.old-deja/g++.benjamin/bool01.C: Likewise. + * g++.old-deja/g++.benjamin/bool02.C: Likewise. + * g++.old-deja/g++.benjamin/p13417.C: Now fails due to use of + named return value extension. + * g++.old-deja/g++.benjamin/tem06.C: Remove stray semicolon. + * g++.old-deja/g++.benjmain/warn01.C: Likewise. + * g++.old-deja/g++.bob/extern_C.C: Likewise. + * g++.old-deja/g++.bob/inherit2.C: Likewise. + * g++.old-deja/g++.brendan/complex1.C: Likewise. + * g++.old-deja/g++.brendan/copy5.C: Likewise. + * g++.old-deja/g++.brendan/crash13.C: Likewise. + * g++.old-deja/g++.brendan/crash15.C: Likewise. + * g++.old-deja/g++.brendan/crash18.C: Change error message. + * g++.old-deja/g++.brendan/crash37.C: Remove stray semicolon. + * g++.old-deja/g++.brendan/crash38.C: Likewise. + * g++.old-deja/g++.brendan/crash50.C: Likewise. + * g++.old-deja/g++.brendan/crash56.C: Likewise. + * g++.old-deja/g++.brendan/crash6.C: Use explicit specialization + syntax. + * g++.old-deja/g++.brendan/crash66.C: Remove stray semicolon. + * g++.old-deja/g++.brendan/crash8.C: Change error message. + * g++.old-deja/g++.brendan/ctors1.C: Remove stray semicolon. + * g++.old-deja/g++.brendan/ctors2.C: Likewise. + * g++.old-deja/g++.brendan/shadow1.C: Likewise. + * g++.old-deja/g++.brendan/template11.C: Likewise. + * g++.old-deja/g++.brendan/template26.C: Likewise. + * g++.old-deja/g++.brendan/template27.C: Use explicit + specialization syntax. + * g++.old-deja/g++.brendan/template30.C: Likewise. + * g++.old-deja/g++.brendan/template5.C: Remove stray semicolon. + * g++.old-deja/g++.brendan/visibility3.C: Account for use of + non-dependent names. + * g++.old-deja/g++.brendan/warnings4.C: Remove stray semicolon. + * g++.old-deja/g++.brendan/warnings7.C: Likewise. + * g++.old-deja/g++.bugs/900121_02.C: Likewise. + * g++.old-deja/g++.eh/catchptr1.C: Likewise. + * g++.old-deja/g++.ext/addrfunc4.C: Likewise. + * g++.old-deja/g++.ext/namedret1.C: Now fails due to use of + named return value extension. + * g++.old-deja/g++.ext/namedret2.C: Likewise. + * g++.old-deja/g++.ext/namedret3.C: Likewise. + * g++.old-deja/g++.ext/return1.C: Likewise. + * g++.old-deja/g++.ext/typename1.C: Add missing typename keywords. + * g++.old-deja/g++.jason/access17.C: Issue more error messages. + * g++.old-deja/g++.jason/access8.C: Likewise. + * g++.old-deja/g++.jason/bool.C: Remove stray semicolon. + * g++.old-deja/g++.jason/destruct.C: Remove incorrect + pseudo-destructor names. + * g++.old-deja/g++.jason/dtor3.C: Remove stray semicolon. + * g++.old-deja/g++.jason/dtor5.C: Remove incorrect + pseudo-destructor names. + * g++.old-deja/g++.jason/opeq3.C: Remove stray semicolon. + * g++.old-deja/g++.jason/overload19.C: Likewise. + * g++.old-deja/g++.jason/overload32.C: Likewise. + * g++.old-deja/g++.jason/parse11.C: Issue error messages about + stray semicolons. + * g++.old-deja/g++.jason/pmem2.C: Remove stray semicolon. + * g++.old-deja/g++.jason/return.C: Likewise. + * g++.old-deja/g++.jason/return2.C: Likewise. + * g++.old-deja/g++.jason/shadow1.C: Likewise. + * g++.old-deja/g++.jason/special.C: Use explicit specialization + syntax. + * g++.old-deja/g++.jason/template10.C: Account for use of + non-dependent names. + * g++.old-deja/g++.jason/template11.C: Use explicit specialization + syntax. + * g++.old-deja/g++.jason/template37.C: Likewise. + * g++.old-deja/g++.law/access4.C: Change error messages. + * g++.old-deja/g++.law/arm13.C: Remove incorrect + pseudo-destructor names. + * g++.old-deja/g++.law/code-gen5.C: Remove stray semicolon. + * g++.old-deja/g++.law/ctors9.C: Likewise. + * g++.old-deja/g++.law/cvt22.C: Likewise. + * g++.old-deja/g++.law/dtors5.C: Likewise. + * g++.old-deja/g++.law/global-init1.C: Likewise. + * g++.old-deja/g++.law/missed-error3.C: Likewise. + * g++.old-deja/g++.law/operators28.C: Likewise. + * g++.old-deja/g++.law/visibility28.C: Likewise. + * g++.old-deja/g++.martin/eval1.C: Likewise. + * g++.old-deja/g++.martin/pmf2.C: Remove qualifier in constructor + name. + * g++.old-deja/g++.mike/hog1.C: Remove stray semicolon. + * g++.old-deja/g++.mike/net34.C: Likewise. + * g++.old-deja/g++.mike/net36.C: Likewise. + * g++.old-deja/g++.mike/ns2.C: Likewise. + * g++.old-deja/g++.mike/p12306.C: Likewise. + * g++.old-deja/g++.mike/p646.C: Adjust for removal of named return + value extension. + * g++.old-deja/g++.mike/p700.C: Likewise. + * g++.old-deja/g++.mike/p701.C: Remove stray semicolon. + * g++.old-deja/g++.mike/p710.C: Likewise. + * g++.old-deja/g++.mike/p784.C: Adjust for removal of named return + value extension. + * g++.old-deja/g++.mike/pmf7.C: Remove stray semicolon. + * g++.old-deja/g++.mike/pmf9.C: Likewise. + * g++.old-deja/g++.ns/crash2.C: Likewise. + * g++.old-deja/g++.ns/crash3.C: Likewise. + * g++.old-deja/g++.ns/invalid1.C: Likewise. + * g++.old-deja/g++.ns/ns17.C: Likewise. + * g++.old-deja/g++.ns/template16.C: Likewise. + * g++.old-deja/g++.ns/template5.C: Remove invalid use of template + keyword. + * g++.old-deja/g++.ns/template6.C: Remove stray semicolon. + * g++.old-deja/g++.ns/using9.C: Remove stray semicolon. + * g++.old-deja/g++.oliva/nameret1.C: Now fails due to use of + named return value extension. + * g++.old-deja/g++.oliva/nameret2.C: Likewise. + * g++.old-deja/g++.other/access4.C: Issue additional error + messages. + * g++.old-deja/g++.other/array6.C: Remove stray semicolon. + * g++.old-deja/g++.other/crash1.C: Isue additional error messages. + * g++.old-deja/g++.other/crash11.C: Add missing class-key. + * g++.old-deja/g++.other/crash25.C: Change error message. + * g++.old-deja/g++.other/crash4.C: Change error message. + * g++.old-deja/g++.other/debug7.C: Remove stray semicolon. + * g++.old-deja/g++.other/decl5.C: Issue more error messages. + * g++.old-deja/g++.other/defarg7.C: Remove circular dependency + checks. + * g++.old-deja/g++.other/defarg8.C: Likewise. + * g++.old-deja/g++.other/dtor1.C: Remove stray semicolon. + * g++.old-deja/g++.other/dtor10.C: Likewise. + * g++.old-deja/g++.other/incomplete.C: Likewise. + * g++.old-deja/g++.other/linkage7.C: Likewise. + * g++.old-deja/g++.other/lookup19.C: Now fails due to corrected + lookup algorithm. + * g++.old-deja/g++.other/mangle2.C: Likewise. + * g++.old-deja/g++.other/refinit2.C: Likewise. + * g++.old-deja/g++.other/sizeof2.C: Change error messages. + * g++.old-deja/g++.other/std1.C: Remove stray semicolon. + * g++.old-deja/g++.pt/crash28.C: Likewise. + * g++.old-deja/g++.pt/crash29.C: Use explicit specialization + syntax. + * g++.old-deja/g++.pt/crash32.C: Change error message. + * g++.old-deja/g++.pt/crash43.C: Adjust error messages. + * g++.old-deja/g++.pt/crash58.C: Remove stray semicolon. + * g++.old-deja/g++.pt/crash65.C: Tweak to acount for change in + error message position. + * g++.old-deja/g++.pt/defarg5.C: Remove stray semicolon. + * g++.old-deja/g++.pt/defarg8.C: Change error message. + * g++.old-deja/g++.pt/eichin01.C: Use explicit specialization + syntax. + * g++.old-deja/g++.pt/eichin01a.C: Define static data members. + * g++.old-deja/g++.pt/eichin01b.C: Likewise. + * g++.old-deja/g++.pt/enum7.C: Remove stray semicolon. + * g++.old-deja/g++.pt/explicit12.C: Remove invalid use of template + keyword. + * g++.old-deja/g++.pt/explicit31.C: Likewise. + * g++.old-deja/g++.pt/explicit33.C: Remove stray semicolon. + * g++.old-deja/g++.pt/explicit35.C: Remove invalid use of template + keyword. + * g++.old-deja/g++.pt/explicit71.C: Change error message. + * g++.old-deja/g++.pt/explicit80.C: Use explicit specialization + syntax. + * g++.old-deja/g++.pt/friend28.C: Account for use of + non-dependent names. + * g++.old-deja/g++.pt/friend29.C: Likewise. + * g++.old-deja/g++.pt/friend46.C: Adjust for correct name lookup + rules. + * g++.old-deja/g++.pt/friend48.C: Remove stray semicolon. + * g++.old-deja/g++.pt/instantiate1.C: Use correct class-key. + * g++.old-deja/g++.pt/instantiate11.C: Adjust for correct name + lookup rules. + * g++.old-deja/g++.pt/instantiate8.C: Remove stray semicolon. + * g++.old-deja/g++.pt/instantiate9.C: Insert missing typename + keyword. + * g++.old-deja/g++.pt/memclass20.C: Likewise. + * g++.old-deja/g++.pt/memclass5.C: Likewise. + * g++.old-deja/g++.pt/memclass7.C: Remove invalid use of template + keyword. + * g++.old-deja/g++.pt/memtemp75.C: Likewise. + * g++.old-deja/g++.pt/memtemp81.C: Remove stray semicolon. + * g++.old-deja/g++.pt/memtemp87.C: Add missing access specifier. + * g++.old-deja/g++.pt/overload13.C: Correct error messages. + * g++.old-deja/g++.pt/parms2.C: Add missing typename keyword. + * g++.old-deja/g++.pt/ptrmem1.C: Remove invalid use of template + keyword. + * g++.old-deja/g++.pt/spec10.C: Likewise. + * g++.old-deja/g++.pt/spec28.C: Reorder declarations. + * g++.old-deja/g++.pt/t10.C: Add explicit specialization syntax. + * g++.old-deja/g++.pt/t32.C: Remove stray semicolon. + * g++.old-deja/g++.pt/t35a.C: Add explicit specialization syntax. + * g++.old-deja/g++.pt/ttp24.C: Remove stray semicolon. + * g++.old-deja/g++.pt/ttp62.C: Likewise. + * g++.old-deja/g++.pt/ttp64.C: Likewise. + * g++.old-deja/g++.pt/typename11.C: Add missing typename keyword. + * g++.old-deja/g++.pt/typename15.C: Likewise. + * g++.old-deja/g++.pt/typename22.C: Likewise. + * g++.old-deja/g++.pt/typename6.C: Change error messages. + * g++.old-deja/g++.pt/using1.C: Remove stray semicolon. + * g++.old-deja/g++.pt/virtual2.C: Likewise. + * g++.old-deja/g++.robertl/eb118.C: Add explicit specialization + syntax. + * g++.old-deja/g++.robertl/eb27.C: Now fails due to use of named + return value extension. + * g++.old-deja/g++.robertl/eb43.C: Remove stray semicolon. + * g++.old-deja/g++.robertl/eb79.C: Correct for new name lookup rules. + * g++.old-deja/g++.robertl/eb82.C: Remove stray semicolons. + * g++.old-deja/g++.robertl/eb86.C: Add missing forward declaration. + 2002-12-26 Nathan Sidwell * g++.dg/warn/inline1.C: New test. *************** *** 1756,1788 **** gcc.c-torture/execute/20021024-1.c: Add tests previously added only to 3.1 or 3.2 branch. 2002-12-22 Nathan Sidwell * g++.dg/parse/conv_op1.C: New test. ! 2002-12-19 Devang Patel ! * gcc.dg/darwin-ld-5.c: Rewrite test to test -dynamic. 2002-12-19 Eric Botcazou * gcc.c-torture/execute/20021219-1.c: New test. 2002-12-18 Kriang Lerdsuwanakij PR c++/8099 * g++.dg/template/friend9.C: New test. ! 2002-12-18 Kriang Lerdsuwanakij PR c++/3663 * g++.dg/template/access7.C: New test. ! 2002-12-18 Kriang Lerdsuwanakij ! PR c++/8442 ! * g++.dg/template/type2.C: New test. ! * g++.dg/template/ttp3.C: Change expected error message. 2002-12-12 Devang Patel * gcc.dg/darwin-ld-1.c: New test. --- 7511,7561 ---- gcc.c-torture/execute/20021024-1.c: Add tests previously added only to 3.1 or 3.2 branch. + 2002-12-23 Mark Mitchell + + * gcc.dg/i386-bitfield3.c: New test. + + * gcc.dg/i386-bitfield2.c: New test. + 2002-12-22 Nathan Sidwell * g++.dg/parse/conv_op1.C: New test. ! 2002-12-21 Josef Zlomek ! * gcc.c-torture/compile/20021220-1.c: Removed until bug fix is ! approved. ! ! 2002-12-20 Josef Zlomek ! ! * gcc.c-torture/compile/20021220-1.c: New test. ! ! 2002-12-19 Casper S. Hornstrup ! ! * gcc.dg/i386-fastcall-1.c: New. 2002-12-19 Eric Botcazou * gcc.c-torture/execute/20021219-1.c: New test. + 2002-12-19 Eric Botcazou + + * gcc.dg/i386-pic-1.c: New test. + 2002-12-18 Kriang Lerdsuwanakij PR c++/8099 * g++.dg/template/friend9.C: New test. ! 2002-11-18 Kriang Lerdsuwanakij PR c++/3663 * g++.dg/template/access7.C: New test. ! 2002-12-18 Nick Clifton ! * lib/g++.exp (g++_include_flags): Only invoke testsuite_flags if ! the libstdc++-v3 directory has been found. 2002-12-12 Devang Patel * gcc.dg/darwin-ld-1.c: New test. *************** *** 1837,1842 **** --- 7610,7623 ---- * gcc.c-torture/compile/20021204-1.c: New test. + 2002-12-03 Nathan Sidwell + + * g++.dg/inherit/covariant2.C: New test. + * g++.dg/inherit/covariant3.C: New test. + * g++.dg/inherit/covariant4.C: New test. + * g++.dg/inherit/covariant1.C: Remove XFAIL. + * g++.old-deja/g++.robertl/eb17.C: Likewise. + 2002-12-03 Mark Mitchell PR c++/8688 *************** *** 1904,1909 **** --- 7685,7695 ---- * gcc.c-torture/execute/20021127.[cx]: New test. + 2002-11-26 Jan Hubicka + + * gcc.dg/i386-cmov[123].c: New tests for conditional move code + quality. + 2002-11-26 Geoffrey Keating * g++.dg/init/brace2.C: New test. *************** *** 1913,1918 **** --- 7699,7708 ---- * g++.dg/abi/empty10.C: Don't run on non-x86 targets. + 2002-11-25 Andreas Bauer + + * gcc.dg/sibcall-6: New test for indirect sibcalls. + 2002-11-25 Mark Mitchell * testsuite/g++.dg/abi/empty11.C: New test. *************** *** 2042,2047 **** --- 7832,7842 ---- 2002-11-08 Jan Hubicka + * gcc.dg/i386-ssefp-1.c: New test. + * gcc.dg/i386-ssefp-1.c: New test. + + 2002-11-08 Jan Hubicka + * gcc.c-torture/compile/20021108-1.c: New testcase for x86-64 failure. 2002-11-07 Mark Mitchell *************** *** 2185,2190 **** --- 7980,7989 ---- * g++.dg/expr/cond1.C: New test. + 2002-10-21 Zack Weinberg + + * gcc.dg/sibcall-5.c: Correct { dg-do run } line. + 2002-10-21 Mark Mitchell * g++.dg/abi/vbase13.C: New test. *************** *** 2226,2232 **** 2002-10-21 Mark Mitchell ! * g++.dg/init/array6.C: Add additional tests. 2002-10-21 Ulrich Weigand --- 8025,8031 ---- 2002-10-21 Mark Mitchell ! * g++.dg/init/array6.C: Add additional tests. 2002-10-21 Ulrich Weigand *************** *** 2444,2449 **** --- 8243,8252 ---- * gcc.c-torture/compile/simd-5.c: New test. + 2002-10-10 Roger Sayle + + * gcc.c-torture/execute/shiftopt-1.c: New test case. + 2002-10-10 Jim Wilson * gcc.c-torture/execute/20021010-1.c: New test. *************** *** 2863,2868 **** --- 8666,8676 ---- * gcc.dg/typeof-2.c: New test. + 2002-09-03 Roger Sayle + + * gcc.dg/builtins-2.c: New testcase. + * gcc.dg/builtins-3.c: New testcase. + 2002-09-03 Neil Booth * gcc.dg/cpp/_Pragma4.c: New test. *************** Mon 18-Sep-2000 19:23:11 BST Neil Booth *** 9483,9494 **** * gcc.c-torture/execute/20000917-1.c: New test. * gcc.c-torture/execute/20000917-1.x: XFAIL. ! Sat 16-Sep-2000 08:14:58 BST Neil Booth * gcc.dg/cpp/macro2.c: Testcase for multi-context arguments in nested macro bug. ! Fri 15-Sep-2000 06:50:11 BST Neil Booth * gcc.dg/cpp/paste10.c: Testcase for PASTE_LEFT buglet. --- 15291,15302 ---- * gcc.c-torture/execute/20000917-1.c: New test. * gcc.c-torture/execute/20000917-1.x: XFAIL. ! 2000-09-16 Neil Booth * gcc.dg/cpp/macro2.c: Testcase for multi-context arguments in nested macro bug. ! 2000-09-15 Neil Booth * gcc.dg/cpp/paste10.c: Testcase for PASTE_LEFT buglet. *************** rlsruhe.de> *** 15376,15379 **** correspond to c-torture 1.11. * New file. - --- 21184,21186 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/bprob/bprob.exp gcc-3.4.0/gcc/testsuite/g77.dg/bprob/bprob.exp *** gcc-3.3.3/gcc/testsuite/g77.dg/bprob/bprob.exp 2002-10-21 20:20:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/bprob/bprob.exp 2004-02-21 03:00:46.000000000 +0000 *************** *** 17,26 **** # Test the functionality of programs compiled with profile-directed block # ordering using -fprofile-arcs followed by -fbranch-probabilities. # Some targets don't have any implementation of __bb_init_func or are # missing other needed machinery. ! if { [istarget mmix-*-*] ! || [istarget cris-*-*] } { return } --- 17,27 ---- # Test the functionality of programs compiled with profile-directed block # ordering using -fprofile-arcs followed by -fbranch-probabilities. + load_lib target-supports.exp + # Some targets don't have any implementation of __bb_init_func or are # missing other needed machinery. ! if { ![check_profiling_available "-fprofile-arcs"] } { return } *************** if { [istarget mmix-*-*] *** 28,34 **** set tool g77 set profile_option -fprofile-arcs set feedback_option -fbranch-probabilities ! set prof_ext da set perf_ext tim # Override the list defined in profopt.exp. --- 29,35 ---- set tool g77 set profile_option -fprofile-arcs set feedback_option -fbranch-probabilities ! set prof_ext gcda set perf_ext tim # Override the list defined in profopt.exp. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/ffixed-form-1.f gcc-3.4.0/gcc/testsuite/g77.dg/ffixed-form-1.f *** gcc-3.3.3/gcc/testsuite/g77.dg/ffixed-form-1.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/ffixed-form-1.f 2003-05-27 05:07:58.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + ! Test compiler flags: -ffixed-form + ! Origin: David Billinghurst + ! + ! { dg-do compile } + ! { dg-options "-ffixed-form" } + end diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/ffixed-form-2.f gcc-3.4.0/gcc/testsuite/g77.dg/ffixed-form-2.f *** gcc-3.3.3/gcc/testsuite/g77.dg/ffixed-form-2.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/ffixed-form-2.f 2003-05-27 05:07:58.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + ! PR fortran/10843 + ! Origin: Brad Davis + ! + ! { dg-do compile } + ! { dg-options "-ffixed-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + GO TO = 55 + END + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/ffree-form-2.f gcc-3.4.0/gcc/testsuite/g77.dg/ffree-form-2.f *** gcc-3.3.3/gcc/testsuite/g77.dg/ffree-form-2.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/ffree-form-2.f 2003-05-31 19:49:59.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + ! PR fortran/10843 + ! Origin: Brad Davis + ! + ! { dg-do compile } + ! { dg-options "-ffree-form" } + GO TO 3 + GOTO 3 + 3 CONTINUE + GOTO = 55 + END + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/ffree-form-3.f gcc-3.4.0/gcc/testsuite/g77.dg/ffree-form-3.f *** gcc-3.3.3/gcc/testsuite/g77.dg/ffree-form-3.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/ffree-form-3.f 2003-05-27 05:07:58.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + ! Test acceptance of keywords in free format + ! Origin: David Billinghurst + ! + ! { dg-do compile } + ! { dg-options "-ffree-form" } + integer i, j + i = 1 + if ( i .eq. 1 ) then + go = 2 + endif + if ( i .eq. 3 ) then + i = 4 + end if + do i = 1, 3 + j = i + end do + do j = 1, 3 + i = j + enddo + end diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/gcov/gcov-1.f gcc-3.4.0/gcc/testsuite/g77.dg/gcov/gcov-1.f *** gcc-3.3.3/gcc/testsuite/g77.dg/gcov/gcov-1.f 2001-09-14 20:46:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/gcov/gcov-1.f 2003-03-31 15:18:24.000000000 +0000 *************** C Test simple GOTO. *** 118,126 **** if (f .ne. 0) goto 100 ! count(2) ! branch(end) gt1 = 1 ! count(1) - ! branch(100) goto 101 ! count(1) - ! branch(end) 100 gt1 = 2 ! count(1) 101 continue ! count(2) end --- 118,124 ---- *************** C Test simple GOTO again, this time out *** 136,144 **** if (i .eq. f) goto 100 ! count(19) end do gt2 = 4 ! count(1) - ! branch(100) goto 101 ! count(1) - ! branch(end) 100 gt2 = 8 ! count(1) 101 continue ! count(2) end --- 134,140 ---- *************** C Test computed GOTO. *** 149,165 **** integer i goto (101, 102, 103, 104), i ! count(2) gt3 = 8 ! count(1) - ! branch(100) goto 105 ! count(1) - ! branch(end) 101 gt3 = 1024 goto 105 102 gt3 = 2048 goto 105 103 gt3 = 16 ! count(1) - ! branch(100) goto 105 ! count(1) - ! branch(end) 104 gt3 = 4096 goto 105 105 gt3 = gt3 * 2 ! count(2) --- 145,157 ---- *************** C Test nested IF statements and IF with *** 424,427 **** end if end C ! C { dg-final { run-gcov -b gcov-1.f } } --- 416,419 ---- end if end C ! C { dg-final { run-gcov branches calls { -b gcov-1.f } } } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.dg/gcov/gcov-1.x gcc-3.4.0/gcc/testsuite/g77.dg/gcov/gcov-1.x *** gcc-3.3.3/gcc/testsuite/g77.dg/gcov/gcov-1.x 2001-09-14 20:47:19.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.dg/gcov/gcov-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,3 **** - set gcov_verify_branches 1 - set gcov_verify_calls 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/12002.f gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/12002.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/12002.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/12002.f 2003-08-26 21:44:46.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + C PR middle-end/12002 + COMPLEX TE1 + TE1=-2. + TE1=TE1+TE1 + END diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20000601-2.f gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20000601-2.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20000601-2.f 2001-01-19 07:59:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20000601-2.f 2003-06-03 00:10:35.000000000 +0000 *************** *** 11,24 **** INTEGER KL, KU, LDAB, M REAL AB( LDAB, * ) ! INTEGER J, JB, JJ, JP, KV, KM REAL WORK13(65,64), WORK31(65,64) KV = KU + KL DO J = 1, M JB = MIN( 1, M-J+1 ) DO JJ = J, J + JB - 1 KM = MIN( KL, M-JJ ) ! JP = MAX( KM+1, AB( KV+1, JJ ) ) CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) END DO --- 11,24 ---- INTEGER KL, KU, LDAB, M REAL AB( LDAB, * ) ! INTEGER J, JB, JJ, JP, KV, KM, F REAL WORK13(65,64), WORK31(65,64) KV = KU + KL DO J = 1, M JB = MIN( 1, M-J+1 ) DO JJ = J, J + JB - 1 KM = MIN( KL, M-JJ ) ! JP = F( KM+1, AB( KV+1, JJ ) ) CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1, $ AB( KV+JP+JJ-J, J ), LDAB-1 ) END DO diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20010519-1.f gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20010519-1.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20010519-1.f 2002-09-16 13:29:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20010519-1.f 2003-01-09 00:46:10.000000000 +0000 *************** C of the Hessian. *** 28,34 **** C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/impnon.fcm' ! C..##IF VAX CONVEX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA IMPLICIT NONE C..##ENDIF C----------------------------------------------------------------------- --- 28,34 ---- C----------------------------------------------------------------------- C----------------------------------------------------------------------- C:::##INCLUDE '~/charmm_fcm/impnon.fcm' ! C..##IF VAX IRIS HPUX IRIS GNU CSPP OS2 GWS CRAY ALPHA IMPLICIT NONE C..##ENDIF C----------------------------------------------------------------------- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20030115-1.c gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20030115-1.c *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/20030115-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/20030115-1.c 2003-01-15 12:43:34.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + SUBROUTINE FOO (B) + + 10 CALL BAR(A) + ASSIGN 20 TO M + IF(100.LT.A) GOTO 10 + GOTO 40 + C + 20 IF(B.LT.ABS(A)) GOTO 10 + ASSIGN 30 TO M + GOTO 40 + C + 30 ASSIGN 10 TO M + 40 GOTO M,(10,20,30) + END diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/8485.f gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/8485.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/8485.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/8485.f 2003-05-08 13:13:59.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + C Extracted from PR fortran/8485 + PARAMETER (PPMULT = 1.0E5) + INTEGER*8 NWRONG + PARAMETER (NWRONG = 8) + PARAMETER (DDMULT = PPMULT * NWRONG) + PRINT 10, DDMULT + 10 FORMAT (F10.3) + END diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/xformat.f gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/xformat.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/compile/xformat.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/compile/xformat.f 2003-03-15 19:17:50.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + PRINT 10, 2, 3 + 10 FORMAT (I1, X, I1) + END diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/10197.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/10197.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/10197.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/10197.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + # Scratch files aren't implemented for mmixware + # (_stat is a stub and files can't be deleted). + # Similar restrictions exist for most simulators. + + if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] + || [istarget "cris-*-elf"] } { + set torture_execute_xfail [istarget] + } + + return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/12884.f gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/12884.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/12884.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/12884.f 2004-01-31 14:14:59.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + IMPLICIT NONE + C properly handle a "/" in a $ $END namelist + C pr12884 -- + C error in reading a namelist when it is preceded by a line with a SLASH + C + CHARACTER*80 DL(7) + DATA DL /'$file', + 1 'oms omsmc.i2', + 2 'pseu pseudo/PSN', + 3 '$end', + 4 '$CNTRL', + 5 'ispher=1,NOSYM=2,RUNFLG=3,noprop=4,', + 6 '$END'/ + C $file is not a valid namelist, but it still + C is parsed by the runtime + INTEGER*4 ISPHER,NOSYM,RUNFLG,NOPROP /-1 / + INTEGER I + NAMELIST /CNTRL/ ISPHER,NOSYM,RUNFLG,NOPROP + C make a unique datafile + OPEN(UNIT=9,STATUS='SCRATCH') + WRITE(9,*,ERR=100)(DL(I),I=1,7) + REWIND(9) + READ(9,NML=CNTRL,ERR=100) + CLOSE(9) + IF (ISPHER.NE.1.OR.NOSYM.NE.2.OR.RUNFLG.NE.3.OR.NOPROP.NE.4)THEN + CALL ABORT + ENDIF + C all is well at this point !! + STOP + 100 PRINT*,'FILE ERROR(S)' + CALL ABORT + END diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/20001201.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/20001201.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/20001201.x 2002-04-22 01:19:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/20001201.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 3,8 **** --- 3,11 ---- # Similar restrictions exist for most simulators. if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] || [istarget "cris-*-elf"] } { set torture_execute_xfail [istarget] } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/6367.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/6367.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/6367.x 2002-04-22 01:19:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/6367.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 3,8 **** --- 3,11 ---- # Similar restrictions exist for most simulators. if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscalearm*-*-elf"] || [istarget "cris-*-elf"] } { set torture_execute_xfail [istarget] } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/int8421.f gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/int8421.f *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/int8421.f 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/int8421.f 2003-05-11 13:03:58.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + integer*1 i1, i11 + integer*2 i2, i22 + integer i, ii + integer*4 i4, i44 + integer*8 i8, i88 + real r, rr + real*4 r4, r44 + double precision d, dd + real*8 r8, r88 + parameter (i1 = 1, i2 = 2, i4 = 4, i = 5, i8 = i + i4*i2 + i2*i1) + parameter (r = 3.0, r4 = 4.0, r8 = 8.d0, d = i8*r + r4*i2 + r8*i1) + if (i8 .ne. 15 ) call abort + if (d .ne. 61.d0) call abort + i11 = 1; i22 = 2; i44 = 4; ii = 5 + i88 = i + i4*i2 + i2*i1 + if (i88 .ne. i8) call abort + rr = 3.0; r44 = 4.0; r88 = 8.0d0 + dd = i88*rr + r44*i22 + r88*i11 + if (dd .ne. d) call abort + end diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/io0.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/io0.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/io0.x 2002-04-22 01:19:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/io0.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 3,8 **** --- 3,11 ---- # Similar restrictions exist for most simulators. if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] || [istarget "cris-*-elf"] } { set torture_execute_xfail [istarget] } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/io1.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/io1.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/io1.x 2002-04-22 01:19:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/io1.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 3,8 **** --- 3,11 ---- # Similar restrictions exist for most simulators. if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] || [istarget "cris-*-elf"] } { set torture_execute_xfail [istarget] } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/u77-test.x gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/u77-test.x *** gcc-3.3.3/gcc/testsuite/g77.f-torture/execute/u77-test.x 2002-04-22 01:19:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g77.f-torture/execute/u77-test.x 2003-10-31 10:49:15.000000000 +0000 *************** *** 2,7 **** --- 2,10 ---- # link time. if { [istarget "mmix-knuth-mmixware"] + || [istarget "arm*-*-elf"] + || [istarget "strongarm*-*-elf"] + || [istarget "xscale*-*-elf"] || [istarget "cris-*-elf"] } { set torture_compile_xfail [istarget] } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000211-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000211-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000211-3.c 2000-02-11 22:26:41.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000211-3.c 2004-01-14 23:03:57.000000000 +0000 *************** void f_clos(int x) *** 3,9 **** { switch(x) { default: ! mumble: } } --- 3,9 ---- { switch(x) { default: ! mumble:; } } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000518-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000518-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000518-1.c 2000-05-18 22:03:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000518-1.c 2004-01-14 23:03:57.000000000 +0000 *************** extern __inline__ void test() *** 6,12 **** callit1(&&l1); ! l1: } --- 6,12 ---- callit1(&&l1); ! l1:; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000804-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000804-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000804-1.c 2000-08-04 22:06:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000804-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000 Free Software Foundation */ __complex__ long long f () { int i[99]; --- 1,8 ---- ! /* This does not work on m68hc11 or h8300 due to the use of an asm ! statement to force a 'long long' (64-bits) to go in a register. */ ! /* { dg-do assemble { xfail m6811-*-* m6812-*-* h8300-*-* } } */ ! ! /* Copyright (C) 2000, 2003 Free Software Foundation */ __complex__ long long f () { int i[99]; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000804-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000804-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20000804-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20000804-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,8 **** - # This does not work on m68hc11 due to the use of an asm statement - # to force a 'long long' (64-bits) to go in a register. - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001205-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001205-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001205-1.c 2000-12-05 08:13:27.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001205-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* This does not work on m68hc11 due to the asm statement which forces + two 'long' (32-bits) variables to go in registers. */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + static inline unsigned long rdfpcr(void) { unsigned long tmp, ret; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001205-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001205-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001205-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001205-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,7 **** - # This does not work on m68hc11 due to the asm statement which - # forces two 'long' (32-bits) variables to go in registers. - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001226-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001226-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001226-1.c 2000-12-27 11:01:03.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001226-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* This does not assemble on m68hc11 because the function is larger + than 64K. */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + /* { dg-xfail-if "jump beyond 128K not supported" "xtensa-*-*" "-O0" "" } */ + /* This testcase exposed two branch shortening bugs on powerpc. */ #define C(a,b) \ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001226-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001226-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20001226-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20001226-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,22 **** - # This does not assemble on m68hc11 because the function is larger - # than 64K. - - global target_triplet - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - - # It doesn't work on Xtensa with -O0 because the function is larger - # than the range of a jump instruction (+- 128K) and the assembler - # does not yet relax jumps to indirect jumps. - - set torture_eval_before_compile { - set compiler_conditional_xfail_data { - "jump beyond 128K not supported" \ - "xtensa-*-*" \ - { "-O0" } \ - { "" } - } - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/200031109-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/200031109-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/200031109-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/200031109-1.c 2003-11-09 21:27:16.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* For a short time on the tree-ssa branch this would warn that + value was not initialized as it was optimizing !(value = (m?1:2)) + to 0 and not setting value before. */ + + int t(int m) + { + int value; + if (!(value = (m?1:2))) + value = 0; + return value; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010327-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010327-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010327-1.c 2001-11-15 02:32:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010327-1.c 2003-03-03 19:02:28.000000000 +0000 *************** *** 1,2 **** --- 1,9 ---- + /* This testcase tests whether GCC can produce static initialized data + that references addresses of size 'unsigned long', even if that's not + the same as __SIZE_TYPE__. (See 20011114-1.c for the same test of + size __SIZE_TYPE__.) + + Some rare environments might not have the required relocs to support + this; they should have this test disabled in the .x file. */ extern void _text; static unsigned long x = (unsigned long) &_text - 0x10000000L - 1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010518-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010518-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010518-2.c 2001-05-25 19:38:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010518-2.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,10 ---- + /* { dg-do compile } */ + + /* This test fails on HC11/HC12 when it is compiled without -mshort because + the array is too large (INT_MAX/2 > 64K). Force to use 16-bit ints + for it. */ + /* { dg-options "-w -mshort" { target m6811-*-* m6812-*-* } } */ + /* Large static storage. */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010518-2.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010518-2.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20010518-2.x 2003-03-02 22:10:58.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20010518-2.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,8 **** - # This test fails on HC11/HC12 when it is compiled without -mshort because - # the array is too large (INT_MAX/2 > 64K). Force to use 16-bit ints for it. - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - set options "-S -mshort" - } else { - set options "-S" - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020129-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020129-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020129-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020129-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Test call to static variable. */ + + typedef struct + { + long long a[10]; + } A; + + void bar (A *); + + typedef int (*B)(int); + + void foo (void) + { + static A a; + bar (&a); + (*(B)&a) (1); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020312-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020312-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020312-1.c 2002-03-13 07:49:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020312-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* This does not compile on HC11/HC12 due to the asm which requires + two 32-bit registers. */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + /* PR optimization/5892 */ typedef struct { unsigned long a; unsigned int b, c; } A; typedef struct { unsigned long a; A *b; int c; } B; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020312-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020312-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020312-1.x 2003-03-02 22:35:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020312-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,6 **** - # This does not compile on HC11/HC12 due to the asm which requires - # two 32-bit registers. - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020604-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020604-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020604-1.c 2002-06-07 16:28:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020604-1.c 2003-12-23 20:36:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* The array is too big. */ + /* { dg-xfail-if "The array too big" { "h8300-*-*" } { "-mno-h" "-mn" } { "" } } */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + /* PR c/6957 This testcase ICEd at -O2 on IA-32, because (insn 141 139 142 (set (subreg:SF (reg:QI 72) 0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020604-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020604-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020604-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020604-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,10 **** - # The array is too big. - if { [istarget "h8300-*-*"] } { - return 1; - } - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1; - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020807-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020807-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020807-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020807-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + int x; + + static int + __attribute__ ((noinline)) + foo (void) + { + return 0; + } + + static void + __attribute__ ((noinline)) + bar (void) + { + } + + static inline void + baz (void) + { + char arr[x]; + + lab: + if (foo () == -1) + { + bar (); + goto lab; + } + } + + void + test (void) + { + baz (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020910-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020910-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20020910-1.c 2002-09-10 15:44:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20020910-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int a; + #else unsigned int x0 = 0; typedef struct { *************** static void foo (void) *** 11,14 **** { yy.field1 = (unsigned int ) (&x0); } ! --- 16,19 ---- { yy.field1 = (unsigned int ) (&x0); } ! #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021008-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021008-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021008-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021008-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Origin: PR target/7434 Gwenole Beauchesne */ + + int main(void) + { + static const int align_g[] = { 1, 2, 4, 8, 16 }; + char * buf; + int i = 0; + volatile long double val = 0; + val = *((long double *)(buf + align_g[i])); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021108-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021108-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021108-1.c 2002-11-08 11:58:53.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021108-1.c 2004-01-14 23:03:58.000000000 +0000 *************** main() *** 3,7 **** { l1: return &&l1-&&l2; ! l2: } --- 3,7 ---- { l1: return &&l1-&&l2; ! l2:; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021123-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021123-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021123-2.c 2002-12-24 19:10:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021123-2.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,9 **** - /* PR c/8518 */ - /* Contributed by Volker Reichelt. */ - - /* Verify that GCC doesn't get confused by the - redefinition of an extern inline function. */ - - extern int inline foo () { return 0; } - extern int inline bar () { return 0; } - static int inline bar () { return foo(); } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021123-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021123-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021123-3.c 2002-12-24 19:10:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021123-3.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,9 **** - /* PR c/8518 */ - /* Contributed by Volker Reichelt. */ - - /* Verify that GCC doesn't get confused by the - redefinition of an extern inline function. */ - - extern int inline foo () { return 0; } - extern int inline bar () { return 0; } - static int bar () { return foo(); } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021205-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021205-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021205-1.c 2002-12-14 00:54:02.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021205-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,5 **** - /* dg-do compile */ - /* dg-options "-O3" */ typedef struct x x; extern void *baz(char *); struct x { char * (*bar) (int); }; --- 1,3 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021230-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021230-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20021230-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20021230-1.c 2002-12-30 20:33:42.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* SH has special handling for combined and/shift sequences. Make + sure that it behaves properly when one input is in the MACL register. */ + int r, t; + + static void initRGB() + { + t = ((r*255/3) & 0xff) << 16; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030109-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030109-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030109-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030109-1.c 2003-01-09 09:43:23.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + void foo () + { + int x1, x2, x3; + + bar (&x2 - &x1, &x3 - &x2); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030216-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030216-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030216-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030216-1.c 2003-02-16 08:33:17.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + /* PR c/8086 */ + + #define P(x) \ + (((((((((((((((((((((((((((((((( \ + (x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) \ + *(x)+a) + + int + polynomial(int a) + { + return P(3); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030220-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030220-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030220-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030220-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* PR optimization/9768 */ + /* Originator: Randolph Chung */ + + inline int fixfloor (long x) + { + if (x >= 0) + return (x >> 16); + else + return ~((~x) >> 16); + } + + inline int fixtoi (long x) + { + return fixfloor(x) + ((x & 0x8000) >> 15); + } + + int foo(long x, long y) + { + return fixtoi(x*y); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030224-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030224-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030224-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030224-1.c 2003-02-26 03:35:32.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + void zzz (char *s1, char *s2, int len, int *q) + { + int z = 5; + unsigned int i, b; + struct { char a[z]; } x; + + for (i = 0; i < len; i++) + s1[i] = s2[i]; + + b = z & 0x3; + + len += (b == 0 ? 0 : 1) + z; + + *q = len; + + foo (x, x); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030319-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030319-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030319-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030319-1.c 2003-03-19 01:29:15.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* PR 10073 */ + typedef struct + { + unsigned short digits[4]; + } INT_64; + + INT_64 int_64_com (INT_64 a) + { + a.digits[0] ^= 0xFFFF; + a.digits[1] ^= 0xFFFF; + a.digits[2] ^= 0xFFFF; + a.digits[3] ^= 0xFFFF; + return a; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030320-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030320-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030320-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030320-1.c 2003-03-21 00:13:41.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + /* Failed on powerpc64-linux with a segfault due to ifcvt generating + conditional returns without updating dominance info. + Extracted from glibc's dl-load.c. */ + + typedef unsigned long size_t; + + static size_t + is_dst (const char *start, const char *name, const char *str, + int is_path, int secure) + { + size_t len; + _Bool is_curly = 0; + + if (name[0] == '{') + { + is_curly = 1; + ++name; + } + + len = 0; + while (name[len] == str[len] && name[len] != '\0') + ++len; + + if (is_curly) + { + if (name[len] != '}') + return 0; + + + --name; + + len += 2; + } + else if (name[len] != '\0' && name[len] != '/' + && (!is_path || name[len] != ':')) + return 0; + + if (__builtin_expect (secure, 0) + && ((name[len] != '\0' && (!is_path || name[len] != ':')) + || (name != start + 1 && (!is_path || name[-2] != ':')))) + return 0; + + return len; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030323-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030323-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030323-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030323-1.c 2003-03-23 21:25:13.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR c/10178. The following code would ICE because we didn't check for + overflow when computing the range of the switch-statment, and therefore + decided it could be implemented using bit-tests. */ + + int + banana(long citron) + { + switch (citron) { + case 0x80000000: + case 0x40000: + case 0x40001: + return 1; + break; + } + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030331-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030331-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030331-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030331-1.c 2003-03-31 20:32:14.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* From PR/9301. Fixed by ebotcazou's patch for PR/9493. */ + + void bar (void); + + void foo (int a, int b, int c, int d, int e) + { + if (a) + bar(); + if (b && c) + ; + if (d && e) + ; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030410-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030410-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030410-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030410-1.c 2003-04-11 16:22:29.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* PR 10201 */ + + extern struct _zend_compiler_globals compiler_globals; + typedef struct _zend_executor_globals zend_executor_globals; + extern zend_executor_globals executor_globals; + + typedef struct _zend_ptr_stack { + int top; + void **top_element; + } zend_ptr_stack; + struct _zend_compiler_globals { + }; + struct _zend_executor_globals { + int *uninitialized_zval_ptr; + zend_ptr_stack argument_stack; + }; + + static inline void safe_free_zval_ptr(int *p) + { + if (p!=(executor_globals.uninitialized_zval_ptr)) { + } + } + zend_executor_globals executor_globals; + static inline void zend_ptr_stack_clear_multiple(void) + { + executor_globals.argument_stack.top -= 2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030415-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030415-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030415-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030415-1.c 2003-04-15 13:34:01.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + float g(float f) + { + return fabs(f); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030503-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030503-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030503-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030503-1.c 2003-05-03 08:42:58.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + void foo () + { + if (1) + goto foo; + else + for (;;) + { + foo: + bar (); + return; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030518-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030518-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030518-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030518-1.c 2003-05-18 22:50:29.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test case from PR middle-end/10472 */ + + extern void f (char *); + + void foo (char *s) + { + f (__builtin_stpcpy (s, "hi")); + } + + void bar (char *s) + { + f (__builtin_mempcpy (s, "hi", 3)); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030605-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030605-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030605-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030605-1.c 2003-06-05 16:31:49.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test for proper preparation of the comparison operands for + generation of a conditional trap. Produced unrecognizable + rtl on Sparc. */ + + struct blah { char *b_data; }; + + void set_bh_page(struct blah *bh, unsigned long offset) + { + if ((1UL << 12 ) <= offset) + __builtin_trap() ; + bh->b_data = (char *)offset; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030612-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030612-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030612-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030612-1.c 2003-06-13 00:34:04.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + static inline void + foo (long long const v0, long long const v1) + { + bar (v0 == v1); + } + + void + test (void) + { + foo (0, 1); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030624-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030624-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030624-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030624-1.c 2003-06-25 03:09:06.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* Derived from PR optimization/11311 */ + + double pow(double, double); + + double foo(double x) { return pow(x,261); } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030625-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030625-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030625-1.c 2003-06-25 06:50:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030625-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1 **** - void foo (const char *s, ...) { bar (&s); } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030704-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030704-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030704-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030704-1.c 2003-07-09 03:02:17.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR c/11428. */ + + /* fold_single_bit_test() failed to return a tree of the type that the + outer expression was looking for. Specifically, it returned a tree + whose type corresponded to QImode for !p->m, but the desired result + type was int, which corresponded to SImode. emit_move_insn() later + tried to copy a reg:QI to reg:SI, causing an ICE. */ + + struct s { + int m : 1; + }; + + int + foo (struct s *p) + { + return !p->m; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030707-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030707-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030707-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030707-1.c 2003-07-10 12:40:10.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR c/11449. */ + + /* sign_bit_p() in fold-const.c failed to notice that (int) 0x80000000 + was the sign bit of m. As a result, fold_single_bit_test() + returned ((unsigned int) m >> 31), and that was eventually passed + to invert_truthvalue(), which did not know how to handle + RROTATE_EXPR, causing an ICE. */ + + int + foo (int m) + { + return !(m & ((int) 0x80000000)); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030708-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030708-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030708-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030708-1.c 2003-07-15 13:44:50.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR 10795. */ + + /* ix86_expand_carry_flag_compare() in i386.c swapped the comparison + operands without checking that the compare instruction, cmpl, would + accept the swapped operands. */ + + extern const char a[]; + + int + foo (const char *p) + { + return (p > a) ? 0 : 2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030725-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030725-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030725-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030725-1.c 2003-07-28 15:42:24.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* This testcase caused ICE on any 64-bit arch at -O2/-O3 due to + fold/extract_muldiv/convert destroying its argument. */ + int x, *y, z, *p; + + void + foo (void) + { + p = y + (8 * (x == 1 || x == 3) + z); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030804-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030804-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030804-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030804-1.c 2003-08-04 23:46:34.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Extracted from PR middle-end/11771. */ + /* The following testcase used to ICE without -ffast-math from unbounded + recursion in fold. This was due to the logic in negate_expr_p not + matching that in negate_expr. */ + + double f(double x) { + return -(1 - x) + (x ? -(1 - x) : 0); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030903-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030903-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030903-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030903-1.c 2003-09-04 01:53:01.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + /* Derived from PR optimization/11700. */ + /* The compiler used to ICE during reload for m68k targets. */ + + void check_complex (__complex__ double, __complex__ double, + __complex__ double, __complex__ int); + void check_float (double, double, double, int); + extern double _Complex conj (double _Complex); + extern double carg (double _Complex __z); + + static double minus_zero; + + void + conj_test (void) + { + check_complex (conj (({ __complex__ double __retval; + __real__ __retval = (0.0); + __imag__ __retval = (0.0); + __retval; })), + ({ __complex__ double __retval; + __real__ __retval = (0.0); + __imag__ __retval = (minus_zero); + __retval; }), 0, 0); + } + + void + carg_test (void) + { + check_float (carg (({ __complex__ double __retval; + __real__ __retval = (2.0); + __imag__ __retval = (0); + __retval; })), 0, 0, 0); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030904-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030904-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030904-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030904-1.c 2003-09-08 07:23:34.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + struct A + { + long a1; + double *a2; + }; + + struct B + { + void *b1; + double b2, b3; + struct + { + int d1; + double d2; + } b4; + }; + + struct C + { + struct A *c1; + void *c2; + }; + + long fn1 (struct A *, double); + void fn2 (void *, const char *); + double fn3 (double); + double fn4 (double); + int fn5 (void *, double, double); + + int + foo (struct B *x) + { + struct C *e = x->b1; + struct A *f = e->c1; + long g, h, i; + double *j, k; + g = fn1 (f, 0.5 * (x->b2 + x->b3)), h = g + 1, i = f->a1; + j = f->a2, k = x->b4.d2; + fn2 (x, "something"); + if (g <= 0) + { + double l = j[2] - j[1]; + if (l > 0.0 && l <= 0.02) + k = (x->b4.d1 == 1 + ? ((1.0 / l) < 25 ? 25 : (1.0 / l)) + : fn3 ((1.0 / l) < 25 ? 25 : (1.0 / l))); + } + else + { + double m = j[h] - j[g], n = 0.0, l = 0.0; + if (g > 1) + n = j[g] - j[g - 1]; + if (h < i) + l = j[h + 1] - j[h]; + if (n > 0.02) + n = 0; + if (m > 0.02) + m = 0; + if (l > 0.02) + l = 0; + if (m < n) + { + double o = m; + m = n; + n = o; + } + if (l < n) + { + double o = l; + l = n; + n = o; + } + if (l < m) + { + double o = l; + l = m; + m = o; + } + if (n != 0.0) + k = (x->b4.d1 == 1 + ? ((1 / m) < 25 ? 25 : (1 / m)) + : fn3 ((1 / m) < 25 ? 25 : (1 / m))); + else if (m != 0.0) + k = (x->b4.d1 == 1 + ? ((2 / (m + l)) < 25 ? 25 : (2 / (m + l))) + : fn3 ((2 / (m + l)) < 25 ? 25 : (2 / (m + l)))); + else if (l != 0.0) + k = (x->b4.d1 == 1 + ? ((1 / l) < 25 ? 25 : (1 / l)) + : fn3 ((1 / l) < 25 ? 25 : (1 / l))); + } + fn5 (e->c2, 0.5 * (x->b2 + x->b3), (x->b4.d1 == 1 ? k : fn4 (k))); + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030921-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030921-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20030921-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20030921-1.c 2003-09-22 07:18:09.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* PR 12281 The darwin back-end was causing the function + f is not being emitted. TREE_SYMBOL_REFERENCED was being set + instead of calling mark_referenced. */ + + + static void f(void); + void g(void (*x) (void)){x();} + static inline void f(void){} + void h(){g(f);} + int main(){h();return 0;} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031010-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031010-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031010-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031010-1.c 2003-10-10 19:48:20.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* This crashed the ARM backend with -mcpu=iwmmxt -O because an insn + required a split which was not available for the iwmmxt. */ + inline int *f1(int* a, int* b) { if (*b < *a) return b; return a; } + int f2(char *d, char *e, int f) { int g = e - d; return *f1(&f, &g); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031011-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031011-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031011-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031011-2.c 2003-10-11 21:06:19.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* PR optimization/12260. */ + + extern int f(void); + extern int g(int); + + static char buf[512]; + void h(int l) { + while (l) { + char *op = buf; + if (f() == 0) + break; + if (g(op - buf + 1)) + break; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-1.c 2003-10-27 10:52:48.000000000 +0000 *************** *** 0 **** --- 1,66 ---- + #ifndef ASIZE + # define ASIZE 0x10000000000UL + #endif + + #include + + #if LONG_MAX < 8 * ASIZE + # undef ASIZE + # define ASIZE 4096 + #endif + + extern void abort (void); + + int __attribute__((noinline)) + foo (const char *s) + { + if (!s) + return 1; + if (s[0] != 'a') + abort (); + s += ASIZE - 1; + if (s[0] != 'b') + abort (); + return 0; + } + + int (*fn) (const char *) = foo; + + int __attribute__((noinline)) + bar (void) + { + char s[ASIZE]; + s[0] = 'a'; + s[ASIZE - 1] = 'b'; + foo (s); + foo (s); + return 0; + } + + int __attribute__((noinline)) + baz (long i) + { + if (i) + return fn (0); + else + { + char s[ASIZE]; + s[0] = 'a'; + s[ASIZE - 1] = 'b'; + foo (s); + foo (s); + return fn (0); + } + } + + int + main (void) + { + if (bar ()) + abort (); + if (baz (0) != 1) + abort (); + if (baz (1) != 1) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-2.c 2003-10-27 10:52:48.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define ASIZE 0x1000000000UL + #include "20031023-1.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-3.c 2003-10-27 10:52:48.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define ASIZE 0x100000000UL + #include "20031023-1.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031023-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031023-4.c 2003-11-26 09:51:24.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define ASIZE 0x80000000UL + #include "20031023-1.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031102-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031102-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031102-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031102-1.c 2003-11-02 13:56:42.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* PR optimization/10817. + Check that the following code doesn't cause any problems + for GCC's if-conversion passes. */ + + int foo(int t) + { + int result = 0; + if (t != 0) + result = t; + return result; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031112-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031112-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031112-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031112-1.c 2003-11-13 02:07:57.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + extern __inline int __finite (double __value) { return 0; } + extern __typeof (__finite) __finite __asm__ ("" "__GI___finite"); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031113-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031113-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031113-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031113-1.c 2003-11-14 01:47:55.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* On Darwin, the stub for simple_cst_equal was not being emitted at all + causing the as to die and not create an object file. */ + + int + attribute_list_contained () + { + return (simple_cst_equal ()); + } + int + simple_cst_list_equal () + { + return (simple_cst_equal ()); + } + + + int __attribute__((noinline)) + simple_cst_equal () + { + return simple_cst_list_equal (); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031208-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031208-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031208-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031208-1.c 2003-12-09 01:57:44.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + extern int foo(int, ...); + int bar(void) { + long double l = 1.2345E6; + foo(0, l); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031220-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031220-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031220-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031220-2.c 2003-12-20 21:56:47.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + /* PR target/12749 + Orgin: Matt Thomas + This used to cause GCC to write out an instruction for i386 when using a L64 host + which gas could not handle because GCC would write a full 64bit hex string out. */ + + + float fabsf (float); + typedef int __int32_t; + typedef unsigned int __uint32_t; + typedef union + { + float value; + __uint32_t word; + } ieee_float_shape_type; + extern float __ieee754_expf (float); + extern float __ieee754_sinhf (float); + static const float one = 1.0, shuge = 1.0e37; + float + __ieee754_sinhf(float x) + { + float t,w,h; + __int32_t ix,jx; + do { ieee_float_shape_type gf_u; gf_u.value = (x); (jx) = gf_u.word; } while (0); + ix = jx&0x7fffffff; + if(ix>=0x7f800000) return x+x; + h = 0.5; + if (jx<0) h = -h; + if (ix < 0x41b00000) { + if (ix<0x31800000) + if(shuge+x>one) return x; + t = expm1f(fabsf(x)); + if(ix<0x3f800000) return h*((float)2.0*t-t*t/(t+one)); + return h*(t+t/(t+one)); + } + if (ix < 0x42b17180) return h*__ieee754_expf(fabsf(x)); + if (ix<=0x42b2d4fc) { + w = __ieee754_expf((float)0.5*fabsf(x)); + t = h*w; + return t*w; + } + return x*shuge; + } + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031227-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031227-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20031227-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20031227-1.c 2003-12-27 19:51:17.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR opt/13159 -- test unswitching a loop multiple times. */ + + void + foo (void) + { + long j, k, p, g; + + while (p) + { + while (k < 0 && j < 0) + ; + if (g) + ; + else if (g) + ; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040101-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040101-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040101-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040101-1.c 2004-01-01 13:59:01.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + typedef unsigned short uint16_t; + typedef unsigned int uint32_t; + + #define CF (1<<0) + #define PF (1<<2) + #define AF (1<<4) + #define ZF (1<<6) + #define SF (1<<7) + #define OF (1<<11) + + #define EFLAGS_BITS (CF|PF|AF|ZF|SF|OF) + + void test16(uint16_t x, uint32_t eflags) + { + uint16_t bsr_result; + uint32_t bsr_eflags; + uint16_t bsf_result; + uint32_t bsf_eflags; + + __asm volatile("" + : "=&r" (bsr_result), "=&r" (bsr_eflags) + : "r" (x), "i" (~EFLAGS_BITS), "r" (eflags)); + __asm volatile("" + : "=&r" (bsf_result), "=&r" (bsf_eflags) + : "r" (x), "i" (~EFLAGS_BITS), "r" (eflags)); + printf("%08x %04x bsrw %02x %08x bsfw %02x %08x\n", + x, eflags, bsr_result, bsr_eflags, bsf_result, bsf_eflags); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040109-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040109-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040109-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040109-1.c 2004-01-09 15:49:29.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + /* PR target/13380. + On m32r, the condition code register, (reg:SI 17), was replaced with + a pseudo reg, which would cause an unrecognized insn. */ + + void + foo (unsigned int a, unsigned int b) + { + if (a > b) + { + while (a) + { + switch (b) + { + default: + a = 0; + case 2: + a = 0; + case 1: + a = 0; + case 0: + ; + } + } + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040121-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040121-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040121-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040121-1.c 2004-02-06 20:11:15.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* PR target/12898 + 0x8000 needs multiple instructions to be emitted on Alpha; the + fluff around it causes it to be emitted in a no_new_pseudos + context, which triggered a problem in alpha.c. */ + + void f (const char *, ...); + int g (void); + void *p (void); + + int isymBase, ilineBase, sym_hdr, want_line, proc_desc; + char *lines; + + void print_file_desc (int *fdp) + { + char *str_base = p (); + int symi, pdi = g (); + + for (symi = 0; isymBase;) + { + int proc_ptr = proc_desc + pdi; + f("1", isymBase, proc_ptr + *fdp, str_base); + if (want_line && *fdp) + { + int delta; + long cur_line = proc_ptr; + char *line_ptr = lines + proc_ptr; + char *line_end = p (); + + f("2", sym_hdr); + while (line_ptr < line_end) + { + delta = *line_ptr; + if (delta) + line_ptr++; + else + delta = line_ptr[1] ^ 0x8000; + f("3", cur_line, delta); + } + } + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040130-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040130-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040130-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040130-1.c 2004-01-30 07:07:30.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + /* PR target/11475 */ + /* Origin: */ + + /* This used to fail on SPARC because of a broken pattern. */ + + #pragma pack(2) + + struct + { + unsigned char G936:7; + unsigned short G937:6; + unsigned int :4; + unsigned short :14; + unsigned int G938:8; + unsigned int :30; + unsigned short :16; + unsigned int :18; + unsigned short G939:9; + } G928b; + + void TestG928(void) + { + G928b.G936 |= G928b.G939; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040209-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040209-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040209-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040209-1.c 2004-02-16 05:15:19.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* The following code used to ICE in fold_convert. */ + + float ceilf(float); + + int foo(float x) + { + return (double)ceilf(x); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040214-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040214-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040214-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040214-1.c 2004-02-14 14:46:04.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + void foo(void) + { + char c; + + for (c = -75; c <= 75; c++) + ; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040214-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040214-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040214-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040214-2.c 2004-02-20 08:20:42.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + /* http://gcc.gnu.org/ml/gcc-patches/2004-02/msg01307.html */ + + typedef struct xdef xdef; + struct xdef + { + char xtyp; + xdef *next; + int y; + }; + + extern void b (); + extern void *foo (void *bar); + extern void *foo2 (void *bar1, void *bar2); + extern void *qwe; + + static void + c (xdef * xp) + { + b (xp); + } + static void + a (xdef ** xpp) + { + xdef *xp; + xp = *xpp; + + foo (xp); + xp = foo2 (xp, qwe); + b (xp->next); + foo (xp); + if (xp->y) + { + foo (xp); + if (xp) + { + xdef *p = foo2 (xp, qwe); + foo2 (xp, p); + xp = foo (p); + } + else + { + foo2 (foo(*xpp), *xpp); + } + } + *xpp = foo2 (xpp, qwe); + } + + void + b (xdef ** xpp) + { + xdef *xp = *xpp; + if (!xp) + return; + if (xp->xtyp == 0) + a (xpp); + c (xp); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040304-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040304-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/20040304-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/20040304-1.c 2004-03-04 09:23:32.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + /* PR optimization/14235 */ + /* Origin: */ + + typedef signed char int8_t; + typedef short int16_t; + typedef int int32_t; + typedef unsigned long long uint64_t; + + static const uint64_t LOW_BYTE_MASK = 0x00000000000000ffULL; + static const uint64_t HIGH_BYTE_MASK = 0x000000000000ff00ULL; + static const uint64_t WORD_MASK = 0x000000000000ffffULL; + static const uint64_t DWORD_MASK = 0x00000000ffffffffULL; + + extern uint64_t *srca_mask; + extern int *assert_thrown; + + void foo() + { + uint64_t tempA = 0; /* actually a bunch of code to set A */ + uint64_t tempB = 0; /* actually a bunch of code to set B */ + + /* cast A to right size */ + tempA = (((*srca_mask == LOW_BYTE_MASK) || + (*srca_mask == HIGH_BYTE_MASK)) ? + ((int8_t)tempA) : + ((*srca_mask == WORD_MASK) ? + ((int16_t)tempA) : + ((*srca_mask == DWORD_MASK) ? + ((int32_t)tempA) : + tempA))); + + /* cast B to right size */ + tempB = (((*srca_mask == LOW_BYTE_MASK) || + (*srca_mask == HIGH_BYTE_MASK)) ? + ((int8_t)tempB) : + ((*srca_mask == WORD_MASK) ? + ((int16_t)tempB) : + ((*srca_mask == DWORD_MASK) ? + ((int32_t)tempB) : + tempB))); + + if ((int) tempA > (int) tempB) { + *assert_thrown = 1; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-12.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-12.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-12.c 1998-12-16 22:06:46.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-12.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* This test fails on HC11/HC12 when it is compiled without -mshort because + the stack arrays are too large. Force to use 16-bit ints for it. */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + x(x){ return 3 + x;} a(x){int y[994]; return 3 + x;} b(x){int y[999]; return 2*(x + 3);} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-12.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-12.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-12.x 2003-03-02 22:10:58.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-12.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,6 **** - # This test fails on HC11/HC12 when it is compiled without -mshort because - # the stack arrays are too large. Force to use 16-bit ints for it. - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - set options "-mshort" - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-4.c 1998-12-16 22:07:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-4.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* This test fails on HC11/HC12 when it is compiled without -mshort because + the 'r0' array is too large. Force to use 16-bit ints for it. */ + /* { dg-do assemble { xfail m6811-*-* m6812-*-* } } */ + foo () { int r0[8186 ]; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-4.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-4.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920501-4.x 2003-03-02 22:10:58.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920501-4.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,6 **** - # This test fails on HC11/HC12 when it is compiled without -mshort because - # the 'r0' array is too large. Force to use 16-bit ints for it. - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - set options "-mshort" - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920520-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920520-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920520-1.c 2000-06-29 03:10:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920520-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1 **** --- 1,3 ---- + /* { dg-do compile { xfail m6811-*-* m6812-*-* } } */ + f(){asm("%0"::"r"(1.5F));}g(){asm("%0"::"r"(1.5));} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920520-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920520-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920520-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920520-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,9 **** - set options "-S" - - # This does not work on m68hc11 due to the asm which forces a - # float or a double to go in a register. - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920521-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920521-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920521-1.c 2000-06-29 03:10:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920521-1.c 2003-06-13 05:40:59.000000000 +0000 *************** *** 1 **** --- 1,3 ---- + /* { dg-do compile } */ + f(){asm("f":::"cc");}g(x,y){asm("g"::"%r"(x), "r"(y));} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920521-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920521-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920521-1.x 2000-06-29 03:10:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920521-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,2 **** - set options "-S" - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920625-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920625-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920625-1.c 1998-12-16 22:07:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920625-1.c 2003-12-23 20:25:49.000000000 +0000 *************** *** 1,3 **** --- 1,22 ---- + /* The problem on IA-64 is that if-conversion creates a sequence + + (p17) cmp.geu p6, p7 = r48, r15 + (p16) cmp.gtu p6, p7 = r48, r15 + + where p16 and p17 are complemenary, but the assembler DV validation + code doesn't recognize that p6 and p7 are complimentary, and so + we end up warning for a later use + + (p6) addl r14 = 1, r0 + (p7) mov r14 = r0 + + that appears to be a WAW violation. */ + + /* { dg-prune-output "Assembler messages" } */ + /* { dg-prune-output "violate\[^\n\]*dependency" } */ + /* { dg-prune-output "first path encountering" } */ + /* { dg-prune-output "location of the conflicting" } */ + typedef unsigned long int unsigned_word; typedef signed long int signed_word; typedef unsigned_word word; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920625-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920625-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/920625-1.x 2002-04-02 00:05:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/920625-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,25 **** - # The problem on IA-64 is that if-conversion creates a sequence - # - # (p17) cmp.geu p6, p7 = r48, r15 - # (p16) cmp.gtu p6, p7 = r48, r15 - # - # where p16 and p17 are complemenary, but the assembler DV validation - # code doesn't recognize that p6 and p7 are complimentary, and so - # we end up warning for a later use - # - # (p6) addl r14 = 1, r0 - # (p7) mov r14 = r0 - # - # that appears to be a WAW violation. - - set torture_eval_before_compile { - - set compiler_conditional_xfail_data { - "missing .pred.rel.mutex directive" \ - "ia64-*-*" \ - { "-O1" "-O2" "-O3" "-Os" } \ - { "" } - } - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/921206-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/921206-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/921206-1.c 1998-12-16 22:08:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/921206-1.c 2003-02-06 01:26:40.000000000 +0000 *************** f() *** 24,28 **** } } for (l = sm; l <= sx; l++) ! smap[l] = l > 0 ? 1 + pow(sin(.1 * l / sx)) : 1 - pow(sin(.1 * l / sm)); } --- 24,28 ---- } } for (l = sm; l <= sx; l++) ! smap[l] = l > 0 ? 1 + foo(sin(.1 * l / sx)) : 1 - foo(sin(.1 * l / sm)); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/930217-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/930217-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/930217-1.c 1998-12-16 22:08:25.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/930217-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int a; + #else double g (); typedef union { struct { *************** f(x, n) *** 12,14 **** --- 17,20 ---- ((s *)&x)->u.e -= n; x = g((double)x, -n); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/930513-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/930513-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/930513-1.c 1998-12-16 22:08:38.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/930513-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int a; + #else struct s { int f1 : 26; int f2 : 8; *************** f (struct s *x) *** 7,9 **** --- 12,15 ---- { return x->f2++ == 0; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/950922-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/950922-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/950922-1.c 1998-12-16 22:09:41.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/950922-1.c 2004-01-14 23:03:56.000000000 +0000 *************** f (int ch, char *fp, char *ap) *** 40,46 **** nosign: if (_uquad != 0 || prec != 0); break; ! default: } if ((f & 0x100) == 0) { } else { --- 40,46 ---- nosign: if (_uquad != 0 || prec != 0); break; ! default:; } if ((f & 0x100) == 0) { } else { *************** f (int ch, char *fp, char *ap) *** 64,68 **** } } ! error: } --- 64,68 ---- } } ! error:; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/961203-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/961203-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/961203-1.c 1998-12-16 22:10:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/961203-1.c 2003-12-23 20:36:59.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* The structure is too large for the xstormy16 - won't fit in 16 + bits. */ + /* { dg-xfail-if "The array too big" { "h8300-*-*" } { "-mno-h" "-mn" } { "" } } */ + /* { dg-do assemble { xfail xstormy16-*-* m6811-*-* m6812-*-* } } */ + struct s { char a[0x32100000]; int x:30, y:30; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/961203-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/961203-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/961203-1.x 2003-01-15 21:27:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/961203-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,17 **** - # The structure is too large for the xstormy16 - won't fit in 16 bits. - - if { [istarget "xstormy16-*-*"] } { - return 1; - } - - if { [istarget "h8300-*-*"] } { - return 1 - } - - # Array 'a' in this test is too large to fit in 64K. - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"]} { - return 1 - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/980506-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/980506-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/980506-1.c 1998-12-16 22:10:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/980506-1.c 2003-12-23 20:36:59.000000000 +0000 *************** *** 1,3 **** --- 1,7 ---- + /* The arrays are too large for the xstormy16 - won't fit in 16 bits. */ + /* { dg-xfail-if "The array too big" { "h8300-*-*" } { "-mno-h" "-mn" } { "" } } */ + /* { dg-do assemble { xfail xstormy16-*-* m6811-*-* m6812-*-* } } */ + unsigned char TIFFFax2DMode[20][256]; unsigned char TIFFFax2DNextState[20][256]; unsigned char TIFFFaxUncompAction[20][256]; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/980506-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/980506-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/980506-1.x 2003-03-02 22:10:58.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/980506-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,13 **** - # The arrays are too large for the xstormy16 - won't fit in 16 bits. - if { [istarget "xstormy16-*-*"] } { - return 1; - } - - if { [istarget "h8300-*-*"] } { - return 1; - } - - if { [istarget "m6811-*-*"] || [istarget "m6812-*-*"] } { - return 1 - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981006-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981006-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981006-1.c 2000-06-29 03:10:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981006-1.c 2003-12-30 17:25:48.000000000 +0000 *************** *** 3,9 **** used uninitialized. This is broken in egcs 1998/10/06 for mips in pic mode. */ ! /* { dg-do compile } */ int foo (int a, int b) { --- 3,12 ---- used uninitialized. This is broken in egcs 1998/10/06 for mips in pic mode. */ ! /* { dg-do assemble } */ ! /* For MIPS at least, pic is needed to trigger the problem. */ ! /* { dg-options "-w -Wuninitialized -Werror -fpic" } */ ! /* { dg-options "-w -Wuninitialized -Werror" { target rs6000-*-aix* powerpc*-*-aix* arm*-*-* xscale*-*-* strongarm*-*-* fr30-*-* sh-*-hms sh-*-coff h8300*-*-* cris-*-elf* cris-*-aout* mmix-*-* } } */ int foo (int a, int b) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981006-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981006-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981006-1.x 2002-07-10 17:38:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981006-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,20 **** - # For MIPS at least, pic is needed to trigger the problem. - if { [istarget rs6000-*-aix*] - || [istarget powerpc*-*-aix*] - || [istarget arm*-*-*] - || [istarget xscale-*-*] - || [istarget strongarm*-*-*] - || [istarget fr30-*-*] - || [istarget sh-*-hms] - || [istarget sh-*-coff] - || [istarget h8300*-*-*] - || [istarget mn10200*-*-*] - || [istarget cris-*-elf*] - || [istarget cris-*-aout*] - || [istarget mmix-*-*] - } { - set options "-Wuninitialized -Werror" - } else { - set options "-Wuninitialized -Werror -fpic" - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981022-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981022-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981022-1.c 1998-12-16 22:10:27.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981022-1.c 2003-06-13 05:41:01.000000000 +0000 *************** int x, y; *** 4,9 **** int main () { ! (x ?: y) = 0; return 0; } --- 4,9 ---- int main () { ! (x ?: y) = 0; /* { dg-bogus "lvalue" "" { xfail *-*-* } } */ return 0; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981022-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981022-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981022-1.x 1998-12-16 22:10:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981022-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,2 **** - set torture_compile_xfail "*-*-*" - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981223-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981223-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981223-1.c 1999-09-04 15:09:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981223-1.c 2003-12-23 20:25:49.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The problem on IA-64 is that the assembler emits + + Warning: Additional NOP may be necessary to workaround Itanium + processor A/B step errata */ + + /* { dg-prune-output "Assembler messages" } */ + /* { dg-prune-output "Additional NOP may be necessary" } */ + + __complex__ float func (__complex__ float x) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981223-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981223-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/981223-1.x 2003-12-16 23:56:56.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/981223-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,14 **** - # On IA-64 the assembler may emit - # - # Warning: Additional NOP may be necessary to workaround Itanium - # processor A/B step errata - # - # This can be fixed by adding "-mb-step" to the command line, which - # does in fact add the extra nop. - - if [istarget "ia64-*-*"] { - set torture_eval_before_compile { - set option "$option -mb-step" - } - } - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/990617-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/990617-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/990617-1.c 1999-09-04 15:09:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/990617-1.c 2003-06-13 05:41:01.000000000 +0000 *************** *** 1,3 **** --- 1,6 ---- + /* 0x70000000 is too large a constant to become a pointer on + xstormy16. */ + /* { dg-do assemble { xfail xstormy16-*-* } } */ int main() { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/990617-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/990617-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/990617-1.x 2001-11-09 01:17:07.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/990617-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,7 **** - # 0x70000000 is too large a constant to become a pointer on xstormy16. - - if { [istarget "xstormy16-*-*"] } { - return 1; - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/compile.exp gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/compile.exp *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/compile.exp 2001-10-09 10:16:21.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/compile.exp 2003-06-13 05:41:01.000000000 +0000 *************** *** 1,5 **** # Expect driver script for GCC Regression Tests ! # Copyright (C) 1993, 1995, 1997 Free Software Foundation # # 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 --- 1,5 ---- # Expect driver script for GCC Regression Tests ! # Copyright (C) 1993, 1995, 1997, 2003 Free Software Foundation # # 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 *************** *** 18,35 **** # These tests come from Torbjorn Granlund's (tege@cygnus.com) # C torture test suite, and other contributors. ! if $tracelevel then { ! strace $tracelevel ! } ! # load support procs ! load_lib c-torture.exp ! foreach testcase [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 $testcase] then { ! continue ! } ! c-torture $testcase ! } --- 18,34 ---- # These tests come from Torbjorn Granlund's (tege@cygnus.com) # C torture test suite, and other contributors. ! # Load support procs. ! load_lib gcc-dg.exp ! # Initialize `dg'. ! dg-init ! # Main loop. ! set saved-dg-do-what-default ${dg-do-what-default} ! set dg-do-what-default "assemble" ! gcc-dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] "-w" ! set dg-do-what-default ${saved-dg-do-what-default} ! # All done. ! dg-finish diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/complex-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/complex-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/complex-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/complex-1.c 2004-02-19 08:06:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + extern void u (int, int); + extern void v (float, float); + + void f (__complex__ int x) + { + u (0, x); + } + + void g (__complex__ float x) + { + v (0, x); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/dll.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/dll.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/dll.c 1999-09-04 15:09:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/dll.c 2003-06-13 05:41:01.000000000 +0000 *************** *** 1,3 **** --- 1,5 ---- + /* { dg-require-dll "" } */ + __declspec (dllimport) int foo; extern int (* import) (void) __attribute__((dllimport)); int func2 (void) __attribute__((dllexport)); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/fix-trunc-mem-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/fix-trunc-mem-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/fix-trunc-mem-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/fix-trunc-mem-1.c 2004-02-20 22:25:47.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* PR target/14201 */ + /* Excercise float -> integer in memory patterns. */ + /* { dg-options "-mieee" { target alpha*-*-* } } */ + + void f1 (float v, int *p) { *p = v; } + void f2 (float v, unsigned int*p) { *p = v; } + void f3 (float v, long long *p) { *p = v; } + void f4 (float v, unsigned long long *p) { *p = v; } + void f5 (double v, int *p) { *p = v; } + void f6 (double v, unsigned int *p) { *p = v; } + void f7 (double v, long long *p) { *p = v; } + void f8 (double v, unsigned long long *p) { *p = v; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/inline-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/inline-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/inline-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/inline-1.c 2003-04-29 23:32:44.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + typedef __builtin_va_list va_list; + + extern void foo (va_list); + + static void + build_message_string (const char *msg, ...) + { + va_list ap; + + __builtin_va_start (ap, msg); + foo (ap); + __builtin_va_end (ap); + } + + void + file_name_as_prefix (f) + const char *f; + { + build_message_string ("%s: ", f); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/labels-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/labels-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/labels-3.c 2002-02-08 22:20:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/labels-3.c 2003-06-13 05:41:01.000000000 +0000 *************** *** 1,3 **** --- 1,9 ---- + /* This test does not compile on mips-irix6 using the native assembler, + though it does work with gas. See PR6200. Since we cannot (???) + distinguish which assembler is being used, always pass -S for + irix. */ + /* { dg-options "-w -S" { target mips*-*-irix* } } */ + /* Verify that we can narrow the storage associated with label diffs. */ int foo (int a) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/labels-3.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/labels-3.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/labels-3.x 2002-04-24 19:04:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/labels-3.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,7 **** - # This test does not compile on mips-irix6 using the native assembler, - # though it does work with gas. See PR6200. Since we cannot (???) - # distinguish which assembler is being used, always pass -S for irix. - - if { [istarget "mips*-*-irix*"] } { set options "-S" } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/libcall-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/libcall-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/libcall-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/libcall-1.c 2004-02-18 17:29:11.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Failed on ARM because rtx_varies_p didn't like the REG_EQUAL notes + generated for libcalls. + http://gcc.gnu.org/ml/gcc-patches/2004-02/msg01518.html */ + static const char digs[] = "0123456789ABCDEF"; + int __attribute__((pure)) bar(); + + int foo (int i) + { + int len; + if (i) + return 0; + len = bar(); + return digs[len]; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mangle-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mangle-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mangle-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mangle-1.c 2003-07-17 21:52:51.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + int foo(void) + { + static int x asm ("x") = 3; + return x++; + } + + int X2 asm ("x.0") = 4; + int X3 asm ("_x.0") = 5; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-1.c 2002-04-25 19:31:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-1.c 2003-10-08 07:20:22.000000000 +0000 *************** *** 1,3 **** --- 1,6 ---- + /* { dg-do compile { target mips*-*-* } } */ + + #ifndef __mips16 register unsigned int cp0count asm ("$c0r1"); int *************** main (int argc, char *argv[]) *** 8,10 **** --- 11,14 ---- d = cp0count + 3; printf ("%d\n", d); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-1.x 2002-05-16 00:11:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,10 **** - global target_triplet - - if { ![istarget "*mips*"] } { - return 1 - } else { - set torture_compile_xfail "$target_triplet" - } - - return 0 - --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-2.c 2002-04-25 19:31:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-2.c 2003-10-08 07:20:22.000000000 +0000 *************** *** 1,3 **** --- 1,6 ---- + /* { dg-do compile { target mips*-*-* } } */ + + #ifndef __mips16 register unsigned int c3r1 asm ("$c3r1"); extern unsigned int b, c; *************** foo () *** 14,16 **** --- 17,20 ---- d = c3r1; printf ("%d\n", d); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-2.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-2.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-2.x 2002-05-16 00:11:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-2.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,10 **** - global target_triplet - - if { ![istarget "*mips*"] } { - return 1 - } else { - set torture_compile_xfail "$target_triplet" - } - - return 0 - --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-3.c 2002-04-25 19:31:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-3.c 2003-10-08 07:20:22.000000000 +0000 *************** *** 1,3 **** --- 1,6 ---- + /* { dg-do compile { target mips*-*-* } } */ + + #ifndef __mips16 register unsigned int c3r1 asm ("$c3r1"), c3r2 asm ("$c3r2"); extern unsigned int b, c; *************** foo () *** 14,16 **** --- 17,20 ---- d = c3r1; printf ("%d\n", d); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-3.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-3.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-3.x 2002-05-16 00:11:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-3.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,10 **** - global target_triplet - - if { ![istarget "*mips*"] } { - return 1 - } else { - set torture_compile_xfail "$target_triplet" - } - - return 0 - --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-4.c 2002-04-25 19:31:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-4.c 2003-10-08 07:20:22.000000000 +0000 *************** *** 1,3 **** --- 1,6 ---- + /* { dg-do compile { target mips*-*-* } } */ + + #ifndef __mips16 register unsigned long c3r1 asm ("$c3r1"), c3r2 asm ("$c3r2"); extern unsigned long b, c; *************** foo () *** 14,16 **** --- 17,20 ---- d = c3r1; printf ("%d\n", d); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-4.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-4.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/mipscop-4.x 2002-05-16 00:11:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/mipscop-4.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,10 **** - global target_triplet - - if { ![istarget "*mips*"] } { - return 1 - } else { - set torture_compile_xfail "$target_triplet" - } - - return 0 - --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/pr13889.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/pr13889.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/pr13889.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/pr13889.c 2004-03-21 23:02:00.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* PR target/13889 */ + struct { long long a; } *p; + void initNetFlowFunct(void) { + unsigned int b = (unsigned int)-1; + p->a = b; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-3.c 2002-07-11 23:53:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-3.c 2003-02-28 08:08:23.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + #include + + /* If double is not wider than float, we probably don't have DFmode, + or at least it's not as wide as double. */ + #if DBL_MANT_DIG > FLT_MANT_DIG typedef float floatvect2 __attribute__((mode(V2DF))); typedef union *************** void tempf(double *x, double *y) *** 15,17 **** --- 20,23 ---- x[0]=temp2.f[0]; x[1]=temp2.f[1]; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-5.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-5.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-5.c 2002-10-11 09:59:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-5.c 2003-11-05 20:15:01.000000000 +0000 *************** *** 1,3 **** --- 1,8 ---- + /* On SPARC64/SPARC-V9 it fails at -O0 and -O1, except with -m32. */ + /* { dg-xfail-if "PR target/9200" { "sparc64-*-*" "sparcv9-*-*" } { "-O0" "-O1" } { "-m32" } } */ + /* On regular SPARC it doesn't fail, except with -m64 at -O0 and -O1. */ + /* { dg-xfail-if "PR target/9200" { "sparc-*-*" } { "-m64 -O0" "-m64 -O1" } { "" } } */ + #define vector64 __attribute__((vector_size(8))) main(){ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-5.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-5.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-5.x 2003-05-24 11:55:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-5.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,41 **** - # h8300 does not have long long - if { [istarget "h8300-*-*"] } { - return 1; - } - - if { [istarget "sparc64-*-*"] || [istarget "sparcv9-*-*"] } { - # On SPARC64/SPARC-V9 it fails, except with -m32. - set torture_eval_before_compile { - global compiler_conditional_xfail_data - set compiler_conditional_xfail_data { - "PR target/9200" \ - { "*-*-*" } \ - { "*" } \ - { "-m32" } - } - } - } elseif { [istarget "sparc-*-*"] } { - # On regular SPARC it doesn't fail, except with -m64. - set torture_eval_before_compile { - global compiler_conditional_xfail_data - set compiler_conditional_xfail_data { - "PR target/9200" \ - { "*-*-*" } \ - { "-m64" } \ - { "" } - } - } - } elseif { [istarget "powerpc64-*-*"] } { - # On PowerPC-64 it fails unconditionally. - set torture_eval_before_compile { - global compiler_conditional_xfail_data - set compiler_conditional_xfail_data { - "PR target/9680" \ - "*-*-*" \ - { "*" } \ - { "" } - } - } - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-6.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-6.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/compile/simd-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/compile/simd-6.c 2003-05-05 20:31:45.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + typedef int __attribute__((mode(V2SI))) vec; + + vec a[] = {(vec) {1, 2}, {3, 4}}; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20010129-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20010129-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20010129-1.x 2001-01-29 18:31:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20010129-1.x 2003-02-23 03:10:03.000000000 +0000 *************** *** 1,4 **** if { [istarget "i?86-*-*"] } { ! set additional_flags "-mcpu=i686" } return 0 --- 1,4 ---- if { [istarget "i?86-*-*"] } { ! set additional_flags "-mtune=i686" } return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20010925-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20010925-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20010925-1.c 2001-09-25 11:52:13.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20010925-1.c 2003-01-28 18:33:19.000000000 +0000 *************** *** 1,7 **** extern void exit(int); extern void abort (void); ! extern void * memcpy (void *, const void *, unsigned int); int foo (void *, void *, unsigned int c); int src[10]; --- 1,7 ---- extern void exit(int); extern void abort (void); ! extern void * memcpy (void *, const void *, __SIZE_TYPE__); int foo (void *, void *, unsigned int c); int src[10]; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020227-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020227-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020227-1.x 2003-03-26 23:18:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020227-1.x 2003-11-11 21:54:03.000000000 +0000 *************** if { [istarget "sparc64-*-*"] || [istarg *** 24,31 **** { "-O0" "-O1" } } } ! } elseif { [istarget "powerpc64-*-*"] } { ! # PowerPC-64 doesn't fail at any optimization level. } elseif { [istarget "*64*-*-*"] || [istarget "alpha*-*-*"] || [istarget "mmix-*-*"] || [istarget "mips*-*-irix6*"] } { # Other 64-bit targets fail at all optimization levels. --- 24,31 ---- { "-O0" "-O1" } } } ! } elseif { [istarget "powerpc64-*-*"] || [istarget "x86_64-*-*"] } { ! # PowerPC-64 and x86_64 do not fail at any optimization level. } elseif { [istarget "*64*-*-*"] || [istarget "alpha*-*-*"] || [istarget "mmix-*-*"] || [istarget "mips*-*-irix6*"] } { # Other 64-bit targets fail at all optimization levels. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020404-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020404-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020404-1.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020404-1.x 2003-05-08 23:38:03.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + # 16-bit "int" + if { [istarget "xstormy16-*"] } { + return 1 + } + + return 0 + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020615-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020615-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020615-1.c 2002-06-18 15:35:36.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020615-1.c 2003-06-30 21:11:44.000000000 +0000 *************** *** 1,7 **** /* PR target/7042. When reorg.c changed branches into return insns, it completely forgot about any current_function_epilogue_delay_list and dropped those insns. Uncovered on cris-axis-elf, where an insn in an ! epilogue delay-slot set the return-value register with the test-case below. Derived from ghostscript-6.52 (GPL) by hp@axis.com. */ typedef struct font_hints_s { --- 1,7 ---- /* PR target/7042. When reorg.c changed branches into return insns, it completely forgot about any current_function_epilogue_delay_list and dropped those insns. Uncovered on cris-axis-elf, where an insn in an ! epilogue delay-slot set the return-value register with the testcase below. Derived from ghostscript-6.52 (GPL) by hp@axis.com. */ typedef struct font_hints_s { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020720-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020720-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020720-1.x 2003-03-08 14:34:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020720-1.x 2004-02-16 18:10:11.000000000 +0000 *************** *** 11,22 **** # and can make the optimization. # Don't XFAIL at -O0, that should never fail. set torture_eval_before_compile { global compiler_conditional_xfail_data set compiler_conditional_xfail_data { "This test fails to optimize completely on certain platforms." \ { "xtensa-*-*" "sh-*-*" "arm*-*-*" "strongarm*-*-*" "xscale*-*-*" \ ! "h8300*-*-*" "x86_64-*-*" "cris-*-*" } \ { "*" } \ { "-O0" } } --- 11,35 ---- # and can make the optimization. # Don't XFAIL at -O0, that should never fail. + if { [istarget "sparc*-*-*"] } { + set torture_eval_before_compile { + global compiler_conditional_xfail_data + set compiler_conditional_xfail_data { + "PR opt/10348" \ + { "*-*-*" } \ + { "-fpic" "-fPIC" } \ + { "-O0" } + } + } + return 0 + } + set torture_eval_before_compile { global compiler_conditional_xfail_data set compiler_conditional_xfail_data { "This test fails to optimize completely on certain platforms." \ { "xtensa-*-*" "sh-*-*" "arm*-*-*" "strongarm*-*-*" "xscale*-*-*" \ ! "h8300*-*-*" "cris-*-*" "frv-*-*" } \ { "*" } \ { "-O0" } } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020810-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020810-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020810-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020810-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + /* PR target/7559 + This testcase was miscompiled on x86-64, because classify_argument + wrongly computed the offset of nested structure fields. */ + + extern void abort (void); + + struct A + { + long x; + }; + + struct R + { + struct A a, b; + }; + + struct R R = { 100, 200 }; + + void f (struct R r) + { + if (r.a.x != R.a.x || r.b.x != R.b.x) + abort (); + } + + struct R g (void) + { + return R; + } + + int main (void) + { + struct R r; + f(R); + r = g(); + if (r.a.x != R.a.x || r.b.x != R.b.x) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020920-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020920-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20020920-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20020920-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + extern void abort (void); + extern void exit (int); + + struct B + { + int x; + int y; + }; + + struct A + { + int z; + struct B b; + }; + + struct A + f () + { + struct B b = { 0, 1 }; + struct A a = { 2, b }; + return a; + } + + int + main (void) + { + struct A a = f (); + if (a.z != 2 || a.b.x != 0 || a.b.y != 1) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20021024-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20021024-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20021024-1.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20021024-1.x 2003-05-08 23:38:03.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + # 16-bit "int" + if { [istarget "xstormy16-*"] } { + return 1 + } + + return 0 + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030105-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030105-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030105-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030105-1.c 2003-01-05 12:02:24.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + int __attribute__ ((noinline)) + foo () + { + const int a[8] = { 0, 1, 2, 3, 4, 5, 6, 7 }; + int i, sum; + + sum = 0; + for (i = 0; i < sizeof (a) / sizeof (*a); i++) + sum += a[i]; + + return sum; + } + + int + main () + { + if (foo () != 28) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030117-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030117-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030117-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030117-1.c 2003-01-20 18:59:43.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + int foo (int, int, int); + int bar (int, int, int); + + int main (void) + { + if (foo (5, 10, 21) != 12) + abort (); + + if (bar (9, 12, 15) != 150) + abort (); + + exit (0); + } + + int foo (int x, int y, int z) + { + return (x + y + z) / 3; + } + + int bar (int x, int y, int z) + { + return foo (x * x, y * y, z * z); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030125-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030125-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030125-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030125-1.c 2003-07-01 13:10:26.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + /* Verify whether math functions are simplified. */ + double sin(double); + double floor(double); + float + t(float a) + { + return sin(a); + } + float + q(float a) + { + return floor(a); + } + double + q1(float a) + { + return floor(a); + } + float + q2(double a) + { + return floor(a); + } + main() + { + #ifdef __OPTIMIZE__ + if (t(0)!=0) + abort (); + if (q(0)!=0) + abort (); + if (q1(0)!=0) + abort (); + if (q2(0)!=0) + abort (); + #endif + return 0; + } + __attribute__ ((noinline)) + double + floor(double a) + { + abort (); + } + __attribute__ ((noinline)) + float + floorf(float a) + { + return a; + } + __attribute__ ((noinline)) + double + sin(double a) + { + abort (); + } + __attribute__ ((noinline)) + float + sinf(float a) + { + return a; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030125-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030125-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030125-1.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030125-1.x 2003-01-25 14:54:09.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + # Only Linux does inlclude all c99 functions at the moment. + if { ! [istarget "*linux*"] } { return 1 } + return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030128-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030128-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030128-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030128-1.c 2003-01-28 22:15:50.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + unsigned char x = 50; + volatile short y = -5; + + int main () + { + x /= y; + if (x != (unsigned char) -10) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030203-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030203-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030203-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030203-1.c 2003-02-03 15:07:50.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + void f(int); + int do_layer3(int single) + { + int stereo1; + + if(single >= 0) /* stream is stereo, but force to mono */ + stereo1 = 1; + else + stereo1 = 2; + f(single); + + return stereo1; + } + + extern void abort (); + int main() + { + if (do_layer3(-1) != 2) + abort (); + return 0; + } + + void f(int i) {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030209-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030209-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030209-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030209-1.c 2003-02-18 17:48:54.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + #ifdef STACK_SIZE + #if STACK_SIZE < 8*100*100 + #define SKIP + #endif + #endif + + #ifndef SKIP + double x[100][100]; + int main () + { + int i; + + i = 99; + x[i][0] = 42; + if (x[99][0] != 42) + abort (); + exit (0); + } + #else + int + main () + { + exit (0); + } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030216-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030216-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030216-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030216-1.c 2003-02-16 22:10:10.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + void link_error (void); + const double one=1.0; + main () + { + #ifdef __OPTIMIZE__ + if ((int) one != 1) + link_error (); + #endif + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030222-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030222-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030222-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030222-1.c 2003-03-04 05:55:20.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Verify that we get the low part of the long long as an int. We + used to get it wrong on big-endian machines, if register allocation + succeeded at all. We use volatile to make sure the long long is + actually truncated to int, in case a single register is wide enough + for a long long. */ + + #include + + void + ll_to_int (long long x, volatile int *p) + { + int i; + asm ("" : "=r" (i) : "0" (x)); + *p = i; + } + + int val = INT_MIN + 1; + + int main() { + volatile int i; + + ll_to_int ((long long)val, &i); + if (i != val) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030323-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030323-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030323-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030323-1.c 2003-03-23 20:21:24.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + /* PR opt/10116 */ + /* Removed tablejump while label still in use; this is really a link test. */ + + void *NSReturnAddress(int offset) + { + switch (offset) { + case 0: return __builtin_return_address(0 + 1); + case 1: return __builtin_return_address(1 + 1); + case 2: return __builtin_return_address(2 + 1); + case 3: return __builtin_return_address(3 + 1); + case 4: return __builtin_return_address(4 + 1); + case 5: return __builtin_return_address(5 + 1); + case 6: return __builtin_return_address(6 + 1); + case 7: return __builtin_return_address(7 + 1); + case 8: return __builtin_return_address(8 + 1); + case 9: return __builtin_return_address(9 + 1); + case 10: return __builtin_return_address(10 + 1); + case 11: return __builtin_return_address(11 + 1); + case 12: return __builtin_return_address(12 + 1); + case 13: return __builtin_return_address(13 + 1); + case 14: return __builtin_return_address(14 + 1); + case 15: return __builtin_return_address(15 + 1); + case 16: return __builtin_return_address(16 + 1); + case 17: return __builtin_return_address(17 + 1); + case 18: return __builtin_return_address(18 + 1); + case 19: return __builtin_return_address(19 + 1); + case 20: return __builtin_return_address(20 + 1); + case 21: return __builtin_return_address(21 + 1); + case 22: return __builtin_return_address(22 + 1); + case 23: return __builtin_return_address(23 + 1); + case 24: return __builtin_return_address(24 + 1); + case 25: return __builtin_return_address(25 + 1); + case 26: return __builtin_return_address(26 + 1); + case 27: return __builtin_return_address(27 + 1); + case 28: return __builtin_return_address(28 + 1); + case 29: return __builtin_return_address(29 + 1); + case 30: return __builtin_return_address(30 + 1); + case 31: return __builtin_return_address(31 + 1); + case 32: return __builtin_return_address(32 + 1); + case 33: return __builtin_return_address(33 + 1); + case 34: return __builtin_return_address(34 + 1); + case 35: return __builtin_return_address(35 + 1); + case 36: return __builtin_return_address(36 + 1); + case 37: return __builtin_return_address(37 + 1); + case 38: return __builtin_return_address(38 + 1); + case 39: return __builtin_return_address(39 + 1); + case 40: return __builtin_return_address(40 + 1); + case 41: return __builtin_return_address(41 + 1); + case 42: return __builtin_return_address(42 + 1); + case 43: return __builtin_return_address(43 + 1); + case 44: return __builtin_return_address(44 + 1); + case 45: return __builtin_return_address(45 + 1); + case 46: return __builtin_return_address(46 + 1); + case 47: return __builtin_return_address(47 + 1); + case 48: return __builtin_return_address(48 + 1); + case 49: return __builtin_return_address(49 + 1); + case 50: return __builtin_return_address(50 + 1); + case 51: return __builtin_return_address(51 + 1); + case 52: return __builtin_return_address(52 + 1); + case 53: return __builtin_return_address(53 + 1); + case 54: return __builtin_return_address(54 + 1); + case 55: return __builtin_return_address(55 + 1); + case 56: return __builtin_return_address(56 + 1); + case 57: return __builtin_return_address(57 + 1); + case 58: return __builtin_return_address(58 + 1); + case 59: return __builtin_return_address(59 + 1); + case 60: return __builtin_return_address(60 + 1); + case 61: return __builtin_return_address(61 + 1); + case 62: return __builtin_return_address(62 + 1); + case 63: return __builtin_return_address(63 + 1); + case 64: return __builtin_return_address(64 + 1); + case 65: return __builtin_return_address(65 + 1); + case 66: return __builtin_return_address(66 + 1); + case 67: return __builtin_return_address(67 + 1); + case 68: return __builtin_return_address(68 + 1); + case 69: return __builtin_return_address(69 + 1); + case 70: return __builtin_return_address(70 + 1); + case 71: return __builtin_return_address(71 + 1); + case 72: return __builtin_return_address(72 + 1); + case 73: return __builtin_return_address(73 + 1); + case 74: return __builtin_return_address(74 + 1); + case 75: return __builtin_return_address(75 + 1); + case 76: return __builtin_return_address(76 + 1); + case 77: return __builtin_return_address(77 + 1); + case 78: return __builtin_return_address(78 + 1); + case 79: return __builtin_return_address(79 + 1); + case 80: return __builtin_return_address(80 + 1); + case 81: return __builtin_return_address(81 + 1); + case 82: return __builtin_return_address(82 + 1); + case 83: return __builtin_return_address(83 + 1); + case 84: return __builtin_return_address(84 + 1); + case 85: return __builtin_return_address(85 + 1); + case 86: return __builtin_return_address(86 + 1); + case 87: return __builtin_return_address(87 + 1); + case 88: return __builtin_return_address(88 + 1); + case 89: return __builtin_return_address(89 + 1); + case 90: return __builtin_return_address(90 + 1); + case 91: return __builtin_return_address(91 + 1); + case 92: return __builtin_return_address(92 + 1); + case 93: return __builtin_return_address(93 + 1); + case 94: return __builtin_return_address(94 + 1); + case 95: return __builtin_return_address(95 + 1); + case 96: return __builtin_return_address(96 + 1); + case 97: return __builtin_return_address(97 + 1); + case 98: return __builtin_return_address(98 + 1); + case 99: return __builtin_return_address(99 + 1); + } + return 0; + } + + int main() + { + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030330-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030330-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030330-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030330-1.c 2003-03-30 23:25:49.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* PR opt/10011 */ + /* This is link test for builtin_constant_p simplification + DCE. */ + + extern void link_error(void); + static void usb_hub_port_wait_reset(unsigned int delay) + { + int delay_time; + for (delay_time = 0; delay_time < 500; delay_time += delay) { + if (__builtin_constant_p(delay)) + link_error(); + } + } + + int main() { return 0; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030401-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030401-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030401-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030401-1.c 2003-04-01 22:32:37.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Testcase for PR fortran/9974. This was a miscompilation of the g77 + front-end caused by the jump bypassing optimizations not handling + instructions inserted on CFG edges. */ + + extern void abort (); + + int bar () + { + return 1; + } + + void foo (int x) + { + unsigned char error = 0; + + if (! (error = ((x == 0) || bar ()))) + bar (); + if (! error) + abort (); + } + + int main() + { + foo (1); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030408-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030408-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030408-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030408-1.c 2003-04-08 17:10:32.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + /* PR optimization/8634 */ + /* Contributed by Glen Nakamura */ + + extern void abort (void); + + struct foo { + char a, b, c, d, e, f, g, h, i, j; + }; + + int test1 () + { + const char X[8] = { 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H' }; + char buffer[8]; + __builtin_memcpy (buffer, X, 8); + if (buffer[0] != 'A' || buffer[1] != 'B' + || buffer[2] != 'C' || buffer[3] != 'D' + || buffer[4] != 'E' || buffer[5] != 'F' + || buffer[6] != 'G' || buffer[7] != 'H') + abort (); + return 0; + } + + int test2 () + { + const char X[10] = { 'A', 'B', 'C', 'D', 'E' }; + char buffer[10]; + __builtin_memcpy (buffer, X, 10); + if (buffer[0] != 'A' || buffer[1] != 'B' + || buffer[2] != 'C' || buffer[3] != 'D' + || buffer[4] != 'E' || buffer[5] != '\0' + || buffer[6] != '\0' || buffer[7] != '\0' + || buffer[8] != '\0' || buffer[9] != '\0') + abort (); + return 0; + } + + int test3 () + { + const struct foo X = { a : 'A', c : 'C', e : 'E', g : 'G', i : 'I' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != 'A' || buffer[1] != '\0' + || buffer[2] != 'C' || buffer[3] != '\0' + || buffer[4] != 'E' || buffer[5] != '\0' + || buffer[6] != 'G' || buffer[7] != '\0' + || buffer[8] != 'I' || buffer[9] != '\0') + abort (); + return 0; + } + + int test4 () + { + const struct foo X = { .b = 'B', .d = 'D', .f = 'F', .h = 'H' , .j = 'J' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != '\0' || buffer[1] != 'B' + || buffer[2] != '\0' || buffer[3] != 'D' + || buffer[4] != '\0' || buffer[5] != 'F' + || buffer[6] != '\0' || buffer[7] != 'H' + || buffer[8] != '\0' || buffer[9] != 'J') + abort (); + return 0; + } + + int main () + { + test1 (); test2 (); test3 (); test4 (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030606-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030606-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030606-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030606-1.c 2003-06-06 17:19:06.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + + int * foo (int *x, int b) + { + + *(x++) = 55; + if (b) + *(x++) = b; + + return x; + } + + main() + { + int a[5]; + + memset (a, 1, sizeof (a)); + + if (foo(a, 0) - a != 1 || a[0] != 55 || a[1] != a[4]) + abort(); + + memset (a, 1, sizeof (a)); + + if (foo(a, 2) - a != 2 || a[0] != 55 || a[1] != 2) + abort(); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030626-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030626-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030626-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030626-1.c 2003-06-27 02:50:19.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + char buf[10]; + + extern void abort (void); + extern int sprintf (char*, const char*, ...); + + int main() + { + int l = sprintf (buf, "foo\0bar"); + if (l != 3) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030626-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030626-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030626-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030626-2.c 2003-06-27 02:50:19.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + char buf[40]; + + extern int sprintf (char*, const char*, ...); + extern void abort (void); + + int main() + { + int i = 0; + int l = sprintf (buf, "%s", i++ ? "string" : "other string"); + if (l != sizeof ("other string") - 1 || i != 1) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030717-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030717-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030717-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030717-1.c 2003-07-18 11:13:37.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + /* PR target/11087 + This testcase was miscompiled on ppc64, because basic_induction_var called + convert_modes, yet did not expect it to emit any new instructions. + Those were emitted at the end of the function and destroyed during life + analysis, while the program used uninitialized pseudos created by + convert_modes. */ + + struct A + { + unsigned short a1; + unsigned long a2; + }; + + struct B + { + int b1, b2, b3, b4, b5; + }; + + struct C + { + struct B c1[1]; + int c2, c3; + }; + + static + int foo (int x) + { + return x < 0 ? -x : x; + } + + int bar (struct C *x, struct A *y) + { + int a = x->c3; + const int b = y->a1 >> 9; + const unsigned long c = y->a2; + int d = a; + unsigned long e, f; + + f = foo (c - x->c1[d].b4); + do + { + if (d <= 0) + d = x->c2; + d--; + + e = foo (c-x->c1[d].b4); + if (e < f) + a = d; + } + while (d != x->c3); + x->c1[a].b4 = c + b; + return a; + } + + int + main () + { + struct A a; + struct C b; + int c; + + a.a1 = 512; + a.a2 = 4242; + __builtin_memset (&b, 0, sizeof (b)); + b.c1[0].b3 = 424242; + b.c2 = 1; + c = bar (&b, &a); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030718-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030718-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030718-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030718-1.c 2003-07-21 17:45:34.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR c/10320 + The function temp was not being emitted in a prerelease of 3.4 20030406. + Contributed by pinskia@physics.uc.edu */ + + static inline void temp(); + int main() + { + temp(); + return 0; + } + static void temp(){} + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030811-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030811-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030811-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030811-1.c 2003-08-11 21:53:57.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + /* Origin: PR target/11535 from H. J. Lu */ + + void vararg (int i, ...) + { + (void) i; + } + + int i0[0], i1; + + void test1 (void) + { + int a = (int) (long long) __builtin_return_address (0); + vararg (0, a); + } + + void test2 (void) + { + i0[0] = (int) (long long) __builtin_return_address (0); + } + + void test3 (void) + { + i1 = (int) (long long) __builtin_return_address (0); + } + + void test4 (void) + { + volatile long long a = (long long) __builtin_return_address (0); + i0[0] = (int) a; + } + + int main (void) + { + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030821-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030821-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030821-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030821-1.c 2003-08-21 05:49:15.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + extern void abort (void); + + int + foo (int x) + { + if ((int) (x & 0x80ffffff) != (int) (0x8000fffe)) + abort (); + + return 0; + } + + int + main () + { + return foo (0x8000fffe); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030907-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030907-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030907-1.c 2003-09-07 09:59:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030907-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,22 **** - /* PR optimization/11662 */ - /* Origin: heinrich.brand@fujitsu-siemens.com */ - - /* This used to fail on SPARC at -O1 because the combiner didn't - correctly propagate an error indicator. */ - - unsigned long long r; - - void test(unsigned long a, unsigned long b, unsigned long long c) - { - r = (a^b)&c; - } - - int main() - { - test(1,2,3); - - if (r != 3) - abort(); - - return 0; - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030914-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030914-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030914-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030914-1.c 2003-09-14 10:07:51.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* On IRIX 6, PB is passed partially in registers and partially on the + stack, with an odd number of words in the register part. Check that + the long double stack argument (PC) is still accessed properly. */ + + struct s { int val[16]; }; + + long double f (int pa, struct s pb, long double pc) + { + int i; + + for (i = 0; i < 16; i++) + pc += pb.val[i]; + return pc; + } + + int main () + { + struct s x; + int i; + + for (i = 0; i < 16; i++) + x.val[i] = i + 1; + if (f (1, x, 10000.0L) != 10136.0L) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030914-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030914-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030914-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030914-2.c 2003-09-14 10:07:51.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* On IRIX 6, PA is passed partially in registers and partially on the + stack. We therefore have two potential uses of pretend_args_size: + one for the partial argument and one for the varargs save area. + Make sure that these uses don't conflict. */ + + struct s { int i[18]; }; + + int f (struct s pa, int pb, ...) + { + return pb; + } + + struct s gs; + + int main () + { + if (f (gs, 0x1234) != 0x1234) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030920-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030920-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030920-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030920-1.c 2003-09-21 02:22:45.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + extern void abort (void); + + int main() + { + int hicount = 0; + unsigned char *c; + char *str = "\x7f\xff"; + for (c = (unsigned char *)str; *c ; c++) { + if (!(((unsigned int)(*c)) < 0x80)) hicount++; + } + if (hicount != 1) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030928-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030928-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20030928-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20030928-1.c 2003-09-28 07:38:14.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + #include + + #if INT_MAX <= 32767 + int main () { exit (0); } + #else + void get_addrs (const char**x, int *y) + { + x[0] = "a1111" + (y[0] - 0x10000) * 2; + x[1] = "a1112" + (y[1] - 0x20000) * 2; + x[2] = "a1113" + (y[2] - 0x30000) * 2; + x[3] = "a1114" + (y[3] - 0x40000) * 2; + x[4] = "a1115" + (y[4] - 0x50000) * 2; + x[5] = "a1116" + (y[5] - 0x60000) * 2; + x[6] = "a1117" + (y[6] - 0x70000) * 2; + x[7] = "a1118" + (y[7] - 0x80000) * 2; + } + + int main () + { + const char *x[8]; + int y[8]; + int i; + + for (i = 0; i < 8; i++) + y[i] = 0x10000 * (i + 1); + get_addrs (x, y); + for (i = 0; i < 8; i++) + if (*x[i] != 'a') + abort (); + exit (0); + } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031003-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031003-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031003-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031003-1.c 2003-10-16 10:58:14.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* PR optimization/9325 */ + + #include + + extern void abort (void); + + int f1() + { + return (int)2147483648.0f; + } + + int f2() + { + return (int)(float)(2147483647); + } + + int main() + { + #if INT_MAX == 2147483647 + if (f1() != 2147483647) + abort (); + if (f2() != 2147483647) + abort (); + #endif + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031011-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031011-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031011-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031011-1.c 2003-10-11 21:00:51.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + /* Check that MAX_EXPR and MIN_EXPR are working properly. */ + + #define MAX(X,Y) ((X) > (Y) ? (X) : (Y)) + #define MIN(X,Y) ((X) < (Y) ? (X) : (Y)) + + extern void abort (void); + + int main() + { + int ll_bitsize, ll_bitpos; + int rl_bitsize, rl_bitpos; + int end_bit; + + ll_bitpos = 32; ll_bitsize = 32; + rl_bitpos = 0; rl_bitsize = 32; + + end_bit = MAX (ll_bitpos + ll_bitsize, rl_bitpos + rl_bitsize); + if (end_bit != 64) + abort (); + end_bit = MAX (rl_bitpos + rl_bitsize, ll_bitpos + ll_bitsize); + if (end_bit != 64) + abort (); + end_bit = MIN (ll_bitpos + ll_bitsize, rl_bitpos + rl_bitsize); + if (end_bit != 32) + abort (); + end_bit = MIN (rl_bitpos + rl_bitsize, ll_bitpos + ll_bitsize); + if (end_bit != 32) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031012-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031012-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031012-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031012-1.c 2003-10-16 00:57:55.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* PR optimization/8750 + Used to fail under Cygwin with + -O2 -fomit-frame-pointer + Testcase by David B. Trout */ + + #if defined(STACK_SIZE) && STACK_SIZE < 16000 + #define ARRAY_SIZE (STACK_SIZE / 2) + #define STRLEN (ARRAY_SIZE - 9) + #else + #define ARRAY_SIZE 15000 + #define STRLEN 13371 + #endif + + extern void *memset (void *, int, __SIZE_TYPE__); + extern void abort (void); + + static void foo () + { + char a[ARRAY_SIZE]; + + a[0]=0; + memset( &a[0], 0xCD, STRLEN ); + a[STRLEN]=0; + if (strlen(a) != STRLEN) + abort (); + } + + int main ( int argc, char* argv[] ) + { + foo(); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031204-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031204-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031204-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031204-1.c 2003-12-04 21:02:34.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + /* PR optimization/13260 */ + + #include + + typedef unsigned long u32; + + u32 in_aton(const char* x) + { + return 0x0a0b0c0d; + } + + u32 root_nfs_parse_addr(char *name) + { + u32 addr; + int octets = 0; + char *cp, *cq; + + cp = cq = name; + while (octets < 4) { + while (*cp >= '0' && *cp <= '9') + cp++; + if (cp == cq || cp - cq > 3) + break; + if (*cp == '.' || octets == 3) + octets++; + if (octets < 4) + cp++; + cq = cp; + } + + if (octets == 4 && (*cp == ':' || *cp == '\0')) { + if (*cp == ':') + *cp++ = '\0'; + addr = in_aton(name); + strcpy(name, cp); + } else + addr = (-1); + + return addr; + } + + int + main() + { + static char addr[] = "10.11.12.13:/hello"; + u32 result = root_nfs_parse_addr(addr); + if (result != 0x0a0b0c0d) { abort(); } + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031214-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031214-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031214-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031214-1.c 2003-12-15 09:37:03.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* PR optimization/10312 */ + /* Originator: Peter van Hoof

*/ + + /* Verify that the strength reduction pass doesn't find + illegitimate givs. */ + + struct + { + double a; + int n[2]; + } g = { 0., { 1, 2}}; + + int k = 0; + + void + b (int *j) + { + } + + int + main () + { + int j; + + for (j = 0; j < 2; j++) + k = (k > g.n[j]) ? k : g.n[j]; + + k++; + b (&j); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031216-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031216-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20031216-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20031216-1.c 2003-12-16 07:50:31.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* PR optimization/13313 */ + /* Origin: Mike Lerwill */ + + extern void abort(void); + + void DisplayNumber (unsigned long v) + { + if (v != 0x9aL) + abort(); + } + + unsigned long ReadNumber (void) + { + return 0x009a0000L; + } + + int main (void) + { + unsigned long tmp; + tmp = (ReadNumber() & 0x00ff0000L) >> 16; + DisplayNumber (tmp); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-1.c 2004-02-14 12:12:17.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + int main () + { + long double x; + + x = 0x1.0p-500L; + x *= 0x1.0p-522L; + if (x != 0x1.0p-1022L) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-2.c 2004-02-14 12:12:17.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + int main () + { + long double x, y; + + x = 0x1.fffffffffffff8p1022L; + x *= 2; + y = 0x1.fffffffffffff8p1023L; + if (memcmp (&x, &y, sizeof (x)) != 0) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-2.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-2.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040208-2.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040208-2.x 2004-02-17 19:14:05.000000000 +0000 *************** *** 0 **** --- 1 ---- + return [expr ![istarget mips*-*-irix6*]] diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040218-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040218-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040218-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040218-1.c 2004-02-22 11:09:27.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + /* PR target/14209. Bug in cris.md, shrinking access size of + postincrement. + Origin: . */ + + long int xb (long int *y) __attribute__ ((__noinline__)); + long int xw (long int *y) __attribute__ ((__noinline__)); + short int yb (short int *y) __attribute__ ((__noinline__)); + + long int xb (long int *y) + { + long int xx = *y & 255; + return xx + y[1]; + } + + long int xw (long int *y) + { + long int xx = *y & 65535; + return xx + y[1]; + } + + short int yb (short int *y) + { + short int xx = *y & 255; + return xx + y[1]; + } + + int main (void) + { + long int y[] = {-1, 16000}; + short int yw[] = {-1, 16000}; + + if (xb (y) != 16255 + || xw (y) != 81535 + || yb (yw) != 16255) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040302-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040302-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040302-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040302-1.c 2004-03-03 00:39:27.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + int code[]={0,0,0,0,1}; + + void foo(int x) { + volatile int b; + b = 0xffffffff; + } + + void bar(int *pc) { + static const void *l[] = {&&lab0, &&end}; + + foo(0); + goto *l[*pc]; + lab0: + foo(0); + pc++; + goto *l[*pc]; + end: + return; + } + + int main() { + bar(code); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040307-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040307-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040307-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040307-1.c 2004-03-14 04:42:04.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + int main() + { + int b = 0; + + struct { + unsigned int bit0:1; + unsigned int bit1:1; + unsigned int bit2:1; + unsigned int bit3:1; + unsigned int bit4:1; + unsigned int bit5:1; + unsigned int bit6:1; + unsigned int bit7:1; + } sdata = {0x01}; + + while ( sdata.bit0-- > 0 ) { + b++ ; + if ( b > 100 ) break; + } + + if (b != 1) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040308-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040308-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040308-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040308-1.c 2004-03-08 06:58:29.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040313-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040313-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040313-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040313-1.c 2004-03-13 18:26:24.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR middle-end/14470 */ + /* Origin: Lodewijk Voge */ + + 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040331-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040331-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040331-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040331-1.c 2004-04-01 16:09:15.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* PR c++/14755 */ + extern void abort (void); + extern void exit (int); + + int + main (void) + { + struct { int count: 31; } s = { 0 }; + while (s.count--) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040401-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040401-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/20040401-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/20040401-1.c 2004-04-02 23:05:42.000000000 +0000 *************** *** 0 **** --- 1,74 ---- + /* PR optimization/8634 */ + + extern void abort (void); + + struct foo { + const char a, b, c, d, e, f, g, h, i, j; + }; + + struct bar { + const char a, b, c, d, e, f, g, h, i; + char j; + }; + + int test1 () + { + struct foo X = { a : 'A', c : 'C', e : 'E', g : 'G', i : 'I' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != 'A' || buffer[1] != '\0' + || buffer[2] != 'C' || buffer[3] != '\0' + || buffer[4] != 'E' || buffer[5] != '\0' + || buffer[6] != 'G' || buffer[7] != '\0' + || buffer[8] != 'I' || buffer[9] != '\0') + abort (); + return 0; + } + + int test2 () + { + struct bar X = { a : 'A', c : 'C', e : 'E', g : 'G', i : 'I' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != 'A' || buffer[1] != '\0' + || buffer[2] != 'C' || buffer[3] != '\0' + || buffer[4] != 'E' || buffer[5] != '\0' + || buffer[6] != 'G' || buffer[7] != '\0' + || buffer[8] != 'I' || buffer[9] != '\0') + abort (); + return 0; + } + + int test3 () + { + struct foo X = { .b = 'B', .d = 'D', .f = 'F', .h = 'H' , .j = 'J' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != '\0' || buffer[1] != 'B' + || buffer[2] != '\0' || buffer[3] != 'D' + || buffer[4] != '\0' || buffer[5] != 'F' + || buffer[6] != '\0' || buffer[7] != 'H' + || buffer[8] != '\0' || buffer[9] != 'J') + abort (); + return 0; + } + + int test4 () + { + struct bar X = { .b = 'B', .d = 'D', .f = 'F', .h = 'H' , .j = 'J' }; + char buffer[10]; + __builtin_memcpy (buffer, &X, 10); + if (buffer[0] != '\0' || buffer[1] != 'B' + || buffer[2] != '\0' || buffer[3] != 'D' + || buffer[4] != '\0' || buffer[5] != 'F' + || buffer[6] != '\0' || buffer[7] != 'H' + || buffer[8] != '\0' || buffer[9] != 'J') + abort (); + return 0; + } + + int main () + { + test1 (); test2 (); test3 (); test4 (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/920908-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/920908-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/920908-2.c 1998-12-16 22:11:33.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/920908-2.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else /* CONF:m68k-sun-sunos4.1.1 OPTIONS:-O *************** t.c=0xffff11; *** 21,23 **** --- 30,33 ---- if(f(t)!=0x11)abort(); exit(0); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/921204-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/921204-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/921204-1.c 1998-12-16 22:11:56.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/921204-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else typedef struct { unsigned b0:1, f1:17, b18:1, b19:1, b20:1, f2:11; } bf; *************** main() *** 34,36 **** --- 43,46 ---- abort(); exit(0); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/930621-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/930621-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/930621-1.c 1998-12-16 22:12:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/930621-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else f () { struct { *************** main () *** 17,19 **** --- 26,29 ---- abort (); exit (0); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/930630-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/930630-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/930630-1.c 1998-12-16 22:12:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/930630-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else main () { struct *************** f (x) *** 17,19 **** --- 26,29 ---- if (x != 7) abort (); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/931031-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/931031-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/931031-1.c 1998-12-16 22:13:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/931031-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else struct foo { unsigned y:1; *************** main () *** 22,24 **** --- 31,34 ---- abort (); exit (0); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/960416-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/960416-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/960416-1.x 2002-02-25 23:07:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/960416-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,5 **** - if { [istarget "h8300*-*-*"] } { - return 1 - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/980602-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/980602-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/980602-2.c 1998-12-16 22:14:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/980602-2.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else struct { unsigned bit : 30; } t; *************** int main() *** 9,11 **** --- 18,21 ---- else abort (); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/990208-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/990208-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/990208-1.c 2000-05-12 16:51:20.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/990208-1.c 2003-01-21 19:43:53.000000000 +0000 *************** static __inline__ void doit(void **pptr, *** 14,29 **** --- 14,32 ---- } } + __attribute__ ((noinline)) static void f(int cond) { doit (&ptr1, cond); } + __attribute__ ((noinline)) static void g(int cond) { doit (&ptr2, cond); } + __attribute__ ((noinline)) static void bar(void); int main() diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/990208-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/990208-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/990208-1.x 2002-09-20 15:14:19.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/990208-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,14 **** - # Doesn't work at -O3 because of ifcvt.c optimizations which - # cause the 2 inlined labels to be at the same location. - - set torture_eval_before_execute { - - set compiler_conditional_xfail_data { - "ifcvt transforms 2 inlined labels to the same address" \ - { "ia64-*-*" "arm*-*-*" "strongarm*-*-*" "xscale*-*-*" } \ - { "-O3" } \ - { "" } - } - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-bitops-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-bitops-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-bitops-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-bitops-1.c 2003-02-09 13:09:45.000000000 +0000 *************** *** 0 **** --- 1,263 ---- + #include + #include + + #if __INT_MAX__ > 2147483647L + # if __INT_MAX__ >= 9223372036854775807L + # define BITSIZEOF_INT 64 + # else + # define BITSIZEOF_INT 32 + # endif + #else + # if __INT_MAX__ >= 2147483647L + # define BITSIZEOF_INT 32 + # else + # define BITSIZEOF_INT 16 + # endif + #endif + + #if __LONG_MAX__ > 2147483647L + # if __LONG_MAX__ >= 9223372036854775807L + # define BITSIZEOF_LONG 64 + # else + # define BITSIZEOF_LONG 32 + # endif + #else + # define BITSIZEOF_LONG 32 + #endif + + #if __LONG_LONG_MAX__ > 2147483647L + # if __LONG_LONG_MAX__ >= 9223372036854775807L + # define BITSIZEOF_LONG_LONG 64 + # else + # define BITSIZEOF_LONG_LONG 32 + # endif + #else + # define BITSIZEOF_LONG_LONG 32 + #endif + + #define MAKE_FUNS(suffix, type) \ + int my_ffs##suffix(type x) { \ + int i; \ + if (x == 0) \ + return 0; \ + for (i = 0; i < CHAR_BIT * sizeof (type); i++) \ + if (x & ((type) 1 << i)) \ + break; \ + return i + 1; \ + } \ + \ + int my_ctz##suffix(type x) { \ + int i; \ + for (i = 0; i < CHAR_BIT * sizeof (type); i++) \ + if (x & ((type) 1 << i)) \ + break; \ + return i; \ + } \ + \ + int my_clz##suffix(type x) { \ + int i; \ + for (i = 0; i < CHAR_BIT * sizeof (type); i++) \ + if (x & ((type) 1 << ((CHAR_BIT * sizeof (type)) - i - 1))) \ + break; \ + return i; \ + } \ + \ + int my_popcount##suffix(type x) { \ + int i; \ + int count = 0; \ + for (i = 0; i < CHAR_BIT * sizeof (type); i++) \ + if (x & ((type) 1 << i)) \ + count++; \ + return count; \ + } \ + \ + int my_parity##suffix(type x) { \ + int i; \ + int count = 0; \ + for (i = 0; i < CHAR_BIT * sizeof (type); i++) \ + if (x & ((type) 1 << i)) \ + count++; \ + return count & 1; \ + } + + MAKE_FUNS (, unsigned); + MAKE_FUNS (l, unsigned long); + MAKE_FUNS (ll, unsigned long long); + + extern void abort (void); + extern void exit (int); + + #define NUMS16 \ + { \ + 0x0000U, \ + 0x0001U, \ + 0x8000U, \ + 0x0002U, \ + 0x4000U, \ + 0x0100U, \ + 0x0080U, \ + 0xa5a5U, \ + 0x5a5aU, \ + 0xcafeU, \ + 0xffffU \ + } + + #define NUMS32 \ + { \ + 0x00000000UL, \ + 0x00000001UL, \ + 0x80000000UL, \ + 0x00000002UL, \ + 0x40000000UL, \ + 0x00010000UL, \ + 0x00008000UL, \ + 0xa5a5a5a5UL, \ + 0x5a5a5a5aUL, \ + 0xcafe0000UL, \ + 0x00cafe00UL, \ + 0x0000cafeUL, \ + 0xffffffffUL \ + } + + #define NUMS64 \ + { \ + 0x0000000000000000ULL, \ + 0x0000000000000001ULL, \ + 0x8000000000000000ULL, \ + 0x0000000000000002ULL, \ + 0x4000000000000000ULL, \ + 0x0000000100000000ULL, \ + 0x0000000080000000ULL, \ + 0xa5a5a5a5a5a5a5a5ULL, \ + 0x5a5a5a5a5a5a5a5aULL, \ + 0xcafecafe00000000ULL, \ + 0x0000cafecafe0000ULL, \ + 0x00000000cafecafeULL, \ + 0xffffffffffffffffULL \ + } + + unsigned int ints[] = + #if BITSIZEOF_INT == 64 + NUMS64; + #elif BITSIZEOF_INT == 32 + NUMS32; + #else + NUMS16; + #endif + + unsigned long longs[] = + #if BITSIZEOF_LONG == 64 + NUMS64; + #else + NUMS32; + #endif + + unsigned long long longlongs[] = + #if BITSIZEOF_LONG_LONG == 64 + NUMS64; + #else + NUMS32; + #endif + + #define N(table) (sizeof (table) / sizeof (table[0])) + + int + main (void) + { + int i; + + for (i = 0; i < N(ints); i++) + { + if (__builtin_ffs (ints[i]) != my_ffs (ints[i])) + abort (); + if (ints[i] != 0 + && __builtin_clz (ints[i]) != my_clz (ints[i])) + abort (); + if (ints[i] != 0 + && __builtin_ctz (ints[i]) != my_ctz (ints[i])) + abort (); + if (__builtin_popcount (ints[i]) != my_popcount (ints[i])) + abort (); + if (__builtin_parity (ints[i]) != my_parity (ints[i])) + abort (); + } + + for (i = 0; i < N(longs); i++) + { + if (__builtin_ffsl (longs[i]) != my_ffsl (longs[i])) + abort (); + if (longs[i] != 0 + && __builtin_clzl (longs[i]) != my_clzl (longs[i])) + abort (); + if (longs[i] != 0 + && __builtin_ctzl (longs[i]) != my_ctzl (longs[i])) + abort (); + if (__builtin_popcountl (longs[i]) != my_popcountl (longs[i])) + abort (); + if (__builtin_parityl (longs[i]) != my_parityl (longs[i])) + abort (); + } + + for (i = 0; i < N(longlongs); i++) + { + if (__builtin_ffsll (longlongs[i]) != my_ffsll (longlongs[i])) + abort (); + if (longlongs[i] != 0 + && __builtin_clzll (longlongs[i]) != my_clzll (longlongs[i])) + abort (); + if (longlongs[i] != 0 + && __builtin_ctzll (longlongs[i]) != my_ctzll (longlongs[i])) + abort (); + if (__builtin_popcountll (longlongs[i]) != my_popcountll (longlongs[i])) + abort (); + if (__builtin_parityll (longlongs[i]) != my_parityll (longlongs[i])) + abort (); + } + + /* Test constant folding. */ + + #define TEST(x, suffix) \ + if (__builtin_ffs##suffix (x) != my_ffs##suffix (x)) \ + abort (); \ + if (x != 0 && __builtin_clz##suffix (x) != my_clz##suffix (x)) \ + abort (); \ + if (x != 0 && __builtin_ctz##suffix (x) != my_ctz##suffix (x)) \ + abort (); \ + if (__builtin_popcount##suffix (x) != my_popcount##suffix (x)) \ + abort (); \ + if (__builtin_parity##suffix (x) != my_parity##suffix (x)) \ + abort (); + + #if BITSIZEOF_INT == 32 + TEST(0x00000000UL,); + TEST(0x00000001UL,); + TEST(0x80000000UL,); + TEST(0x40000000UL,); + TEST(0x00010000UL,); + TEST(0x00008000UL,); + TEST(0xa5a5a5a5UL,); + TEST(0x5a5a5a5aUL,); + TEST(0xcafe0000UL,); + TEST(0x00cafe00UL,); + TEST(0x0000cafeUL,); + TEST(0xffffffffUL,); + #endif + + #if BITSIZEOF_LONG_LONG == 64 + TEST(0x0000000000000000ULL, ll); + TEST(0x0000000000000001ULL, ll); + TEST(0x8000000000000000ULL, ll); + TEST(0x0000000000000002ULL, ll); + TEST(0x4000000000000000ULL, ll); + TEST(0x0000000100000000ULL, ll); + TEST(0x0000000080000000ULL, ll); + TEST(0xa5a5a5a5a5a5a5a5ULL, ll); + TEST(0x5a5a5a5a5a5a5a5aULL, ll); + TEST(0xcafecafe00000000ULL, ll); + TEST(0x0000cafecafe0000ULL, ll); + TEST(0x00000000cafecafeULL, ll); + TEST(0xffffffffffffffffULL, ll); + #endif + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-constant.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-constant.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-constant.x 2003-01-15 22:43:55.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-constant.x 2003-01-28 14:21:26.000000000 +0000 *************** set torture_eval_before_execute { *** 3,10 **** set compiler_conditional_xfail_data { "This test fails on all targets when optimizing." \ { "*-*-*" } \ ! { "*" } \ ! { "-O0" } } } --- 3,10 ---- set compiler_conditional_xfail_data { "This test fails on all targets when optimizing." \ { "*-*-*" } \ ! { "-O1" } \ ! { "" } } } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-noret-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-noret-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-noret-1.c 2002-07-11 12:29:07.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-noret-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,84 **** - /* Test for builtin noreturn attributes. */ - /* Origin: Joseph Myers */ - - extern void abort (void); - extern void exit (int); - extern void _exit (int); - extern void _Exit (int); - - extern void tabort (void); - extern void texit (void); - extern void t_exit (void); - extern void t_Exit (void); - - extern void link_failure (void); - - int - main (void) - { - volatile int i = 0; - /* The real test here is that the program links. */ - if (i) - tabort (); - if (i) - texit (); - if (i) - t_exit (); - if (i) - t_Exit (); - exit (0); - } - - void - tabort (void) - { - abort (); - link_failure (); - } - - void - texit (void) - { - exit (1); - link_failure (); - } - - void - t_exit (void) - { - _exit (1); - link_failure (); - } - - /* Some non-Unix libcs might not have _exit. This version should never - get called. */ - static void - _exit (int i) - { - abort (); - } - - void - t_Exit (void) - { - _Exit (1); - link_failure (); - } - - /* Some libcs might not have _Exit. This version should never get called. */ - static void - _Exit (int i) - { - abort (); - } - - /* When optimizing, no calls to link_failure should remain. In any case, - link_failure should not be called. */ - - #ifndef __OPTIMIZE__ - void - link_failure (void) - { - abort (); - } - #endif --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* Test for -fno-builtin-FUNCTION. */ + /* Origin: Joseph Myers . */ + /* GCC normally handles abs and labs as built-in functions even without + optimization. So test that with -fno-builtin-abs, labs is so handled + but abs isn't. */ + + int abs_called = 0; + + extern int abs (int); + extern long labs (long); + extern void abort (void); + extern void exit (int); + + void + main_test (void) + { + if (labs (0) != 0) + abort (); + if (abs (0) != 0) + abort (); + if (!abs_called) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + extern int abs_called; + extern int inside_main; + + /* The labs call should have been optimized, but the abs call + shouldn't have been. */ + + int + abs (int x) + { + if (inside_main) + abs_called = 1; + return (x < 0 ? -x : x); + } + + long + labs (long x) + { + if (inside_main) + abort (); + return (x < 0 ? -x : x); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/abs-1.x 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + set additional_flags -fno-builtin-abs + return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/builtins.exp gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/builtins.exp *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/builtins.exp 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/builtins.exp 2003-05-24 05:58:15.000000000 +0000 *************** *** 0 **** --- 1,30 ---- + # This harness is for testing builtin support. Each test has two files: + # + # - foo.c defines the main testing function, main_test(). + # - foo-lib.c implements the library functions that foo.c is testing. + # + # The functions in foo-lib.c will often want to abort on certain inputs. + # They can use the global variable inside_main to see whether they are + # being called from the test program or part of the common runtime. + # + # In many cases, the library functions will behave as normal at -O0 + # and abort when optimisation is enabled. Such implementations should + # go into the lib/ directory so that they can be included by any test + # that needs them. They shouldn't call any external functions in case + # those functions were overridden too. + + load_lib c-torture.exp + + set additional_flags "" + if [istarget "powerpc-*-darwin*"] { + lappend additional_flags "-Wl,-multiply_defined,suppress" + } + + foreach src [lsort [find $srcdir/$subdir *.c]] { + if {![string match *-lib.c $src] && [runtest_file_p $runtests $src]} { + c-torture-execute [list $src \ + [file root $src]-lib.c \ + $srcdir/$subdir/lib/main.c] \ + $additional_flags + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/main.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/main.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/main.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + extern void main_test (void); + int inside_main; + + int + main () + { + inside_main = 1; + main_test (); + inside_main = 0; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memcmp.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memcmp.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memcmp.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memcmp.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + extern int inside_main; + + int + memcmp (const void *s1, const void *s2, __SIZE_TYPE__ len) + { + const unsigned char *sp1, *sp2; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + sp1 = s1; + sp2 = s2; + while (len != 0 && *sp1 == *sp2) + sp1++, sp2++, len--; + + if (len == 0) + return 0; + return *sp1 - *sp2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memmove.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memmove.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memmove.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/memmove.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,30 ---- + extern int inside_main; + + void * + memmove (void *dst, const void *src, __SIZE_TYPE__ n) + { + char *dstp; + const char *srcp; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + srcp = src; + dstp = dst; + if (srcp < dstp) + while (n-- != 0) + dstp[n] = srcp[n]; + else + while (n-- != 0) + *dstp++ = *srcp++; + + return dst; + } + + void + bcopy (const void *src, void *dst, __SIZE_TYPE__ n) + { + memmove (dst, src, n); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/mempcpy.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/mempcpy.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/mempcpy.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/mempcpy.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + extern int inside_main; + + void * + mempcpy (void *dst, const void *src, __SIZE_TYPE__ n) + { + const char *srcp; + char *dstp; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + srcp = src; + dstp = dst; + while (n-- != 0) + *dstp++ = *srcp++; + + return dstp; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/stpcpy.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/stpcpy.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/stpcpy.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/stpcpy.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + extern int inside_main; + + char * + stpcpy (char *dst, const char *src) + { + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + while (*src != 0) + *dst++ = *src++; + + *dst = 0; + return dst; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcat.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcat.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcat.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcat.c 2003-08-14 14:26:15.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + extern int inside_main; + extern void abort(void); + + char * + strcat (char *dst, const char *src) + { + char *p = dst; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + while (*p) + p++; + while ((*p++ = *src++)) + ; + return dst; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strchr.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strchr.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strchr.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strchr.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + extern int inside_main; + + char * + strchr (const char *s, int c) + { + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + for (;;) + { + if (*s == c) + return (char *) s; + if (*s == 0) + return 0; + s++; + } + } + + char * + index (const char *s, int c) + { + return strchr (s, c); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcmp.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcmp.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcmp.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strcmp.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + extern int inside_main; + + int + strcmp (const char *s1, const char *s2) + { + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + while (*s1 != 0 && *s1 == *s2) + s1++, s2++; + + if (*s1 == 0 || *s2 == 0) + return (unsigned char) *s1 - (unsigned char) *s2; + return *s1 - *s2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strlen.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strlen.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strlen.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strlen.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + extern int inside_main; + + __SIZE_TYPE__ + strlen (const char *s) + { + __SIZE_TYPE__ i; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + i = 0; + while (s[i] != 0) + i++; + + return i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strrchr.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strrchr.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strrchr.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/lib/strrchr.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + extern int inside_main; + + char * + strrchr (const char *s, int c) + { + __SIZE_TYPE__ i; + + #ifdef __OPTIMIZE__ + if (inside_main) + abort (); + #endif + + i = 0; + while (s[i] != 0) + i++; + + do + if (s[i] == c) + return (char *) s + i; + while (i-- != 0); + + return 0; + } + + char * + rindex (const char *s, int c) + { + return strrchr (s, c); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-1.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,87 ---- + /* Copyright (C) 2000, 2003 Free Software Foundation. + + Ensure all expected transformations of builtin strlen, strcmp, + strrchr and rindex occur and perform correctly. + + Written by Jakub Jelinek, 11/7/2000. */ + + extern void abort (void); + extern __SIZE_TYPE__ strlen (const char *); + extern int strcmp (const char *, const char *); + extern char *strrchr (const char *, int); + extern char *rindex (const char *, int); + + int x = 6; + char *bar = "hi world"; + + void + main_test (void) + { + const char *const foo = "hello world"; + + if (strlen (foo) != 11) + abort (); + if (strlen (foo + 4) != 7) + abort (); + if (strlen (foo + (x++ & 7)) != 5) + abort (); + if (x != 7) + abort (); + if (strcmp (foo, "hello") <= 0) + abort (); + if (strcmp (foo + 2, "llo") <= 0) + abort (); + if (strcmp (foo, foo) != 0) + abort (); + if (strcmp (foo, "hello world ") >= 0) + abort (); + if (strcmp (foo + 10, "dx") >= 0) + abort (); + if (strcmp (10 + foo, "dx") >= 0) + abort (); + if (strcmp (bar, "") <= 0) + abort (); + if (strcmp ("", bar) >= 0) + abort (); + if (strcmp (bar+8, "") != 0) + abort (); + if (strcmp ("", bar+8) != 0) + abort (); + if (strcmp (bar+(--x), "") <= 0 || x != 6) + abort (); + if (strcmp ("", bar+(++x)) >= 0 || x != 7) + abort (); + if (strrchr (foo, 'x')) + abort (); + if (strrchr (foo, 'o') != foo + 7) + abort (); + if (strrchr (foo, 'e') != foo + 1) + abort (); + if (strrchr (foo + 3, 'e')) + abort (); + if (strrchr (foo, '\0') != foo + 11) + abort (); + if (strrchr (bar, '\0') != bar + 8) + abort (); + if (strrchr (bar + 4, '\0') != bar + 8) + abort (); + if (strrchr (bar + (x++ & 3), '\0') != bar + 8) + abort (); + if (x != 8) + abort (); + /* Test only one instance of rindex since the code path is the same + as that of strrchr. */ + if (rindex ("hello", 'z') != 0) + abort (); + + /* Test at least one instance of the __builtin_ style. We do this + to ensure that it works and that the prototype is correct. */ + if (__builtin_rindex (foo, 'o') != foo + 7) + abort (); + if (__builtin_strrchr (foo, 'o') != foo + 7) + abort (); + if (__builtin_strlen (foo) != 11) + abort (); + if (__builtin_strcmp (foo, "hello") <= 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-1-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-1-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-1-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-1-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + #include "lib/strrchr.c" + #include "lib/strlen.c" + #include "lib/strcmp.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-2.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + /* Copyright (C) 2000, 2003 Free Software Foundation. + + Ensure all expected transformations of builtin strchr and index + occur and perform correctly. + + Written by Jakub Jelinek, 11/7/2000. */ + + extern void abort (void); + extern char *strchr (const char *, int); + extern char *index (const char *, int); + + void + main_test (void) + { + const char *const foo = "hello world"; + + if (strchr (foo, 'x')) + abort (); + if (strchr (foo, 'o') != foo + 4) + abort (); + if (strchr (foo + 5, 'o') != foo + 7) + abort (); + if (strchr (foo, '\0') != foo + 11) + abort (); + /* Test only one instance of index since the code path is the same + as that of strchr. */ + if (index ("hello", 'z') != 0) + abort (); + + /* Test at least one instance of the __builtin_ style. We do this + to ensure that it works and that the prototype is correct. */ + if (__builtin_strchr (foo, 'o') != foo + 4) + abort (); + if (__builtin_index (foo, 'o') != foo + 4) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-2-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-2-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-2-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-2-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1 ---- + #include "lib/strchr.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-3.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + /* Copyright (C) 2002, 2003 Free Software Foundation. + + Ensure that builtin memset operations for constant length and + non-constant assigned value don't cause compiler problems. + + Written by Roger Sayle, 21 April 2002. */ + + extern void abort (void); + typedef __SIZE_TYPE__ size_t; + extern void *memset (void *, int, size_t); + + char buffer[32]; + int argc = 1; + + void + main_test (void) + { + memset (buffer, argc, 0); + memset (buffer, argc, 1); + memset (buffer, argc, 2); + memset (buffer, argc, 3); + memset (buffer, argc, 4); + memset (buffer, argc, 5); + memset (buffer, argc, 6); + memset (buffer, argc, 7); + memset (buffer, argc, 8); + memset (buffer, argc, 9); + memset (buffer, argc, 10); + memset (buffer, argc, 11); + memset (buffer, argc, 12); + memset (buffer, argc, 13); + memset (buffer, argc, 14); + memset (buffer, argc, 15); + memset (buffer, argc, 16); + memset (buffer, argc, 17); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-3-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-3-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-3-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-3-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + extern int inside_main; + + void * + memset (void *dst, int c, __SIZE_TYPE__ n) + { + /* Single-byte memsets should be done inline when optimisation + is enabled. */ + #ifdef __OPTIMIZE__ + if (inside_main && n < 2) + abort (); + #endif + + while (n-- != 0) + n[(char *) dst] = c; + + return dst; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-4.c 2003-06-06 10:11:06.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Ensure builtin mempcpy and stpcpy perform correctly. + + Written by Kaveh Ghazi, 4/11/2003. */ + + extern void abort (void); + extern char *strcpy (char *, const char *); + extern char *stpcpy (char *, const char *); + typedef __SIZE_TYPE__ size_t; + extern size_t strlen(const char *); + extern void *memcpy (void *, const void *, size_t); + extern void *mempcpy (void *, const void *, size_t); + extern int memcmp (const void *, const void *, size_t); + extern int inside_main; + + const char s1[] = "123"; + char p[32] = ""; + char *s2 = "defg"; + char *s3 = "FGH"; + size_t l1 = 1; + + void + main_test (void) + { + int i; + + #if !defined __i386__ && !defined __x86_64__ + /* The functions below might not be optimized into direct stores on all + arches. It depends on how many instructions would be generated and + what limits the architecture chooses in STORE_BY_PIECES_P. */ + inside_main = 0; + #endif + + if (stpcpy (p, "abcde") != p + 5 || memcmp (p, "abcde", 6)) + abort (); + if (stpcpy (p + 16, "vwxyz" + 1) != p + 16 + 4 || memcmp (p + 16, "wxyz", 5)) + abort (); + if (stpcpy (p + 1, "") != p + 1 + 0 || memcmp (p, "a\0cde", 6)) + abort (); + if (stpcpy (p + 3, "fghij") != p + 3 + 5 || memcmp (p, "a\0cfghij", 9)) + abort (); + if (mempcpy (p, "ABCDE", 6) != p + 6 || memcmp (p, "ABCDE", 6)) + abort (); + if (mempcpy (p + 16, "VWX" + 1, 2) != p + 16 + 2 || memcmp (p + 16, "WXyz", 5)) + abort (); + if (mempcpy (p + 1, "", 1) != p + 1 + 1 || memcmp (p, "A\0CDE", 6)) + abort (); + if (mempcpy (p + 3, "FGHI", 4) != p + 3 + 4 || memcmp (p, "A\0CFGHIj", 9)) + abort (); + + i = 8; + memcpy (p + 20, "qrstu", 6); + if (stpcpy ((i++, p + 20 + 1), "23") != (p + 20 + 1 + 2) || i != 9 || memcmp (p + 20, "q23\0u", 6)) + abort (); + + memcpy (p + 25, "QRSTU", 6); + if (mempcpy (p + 25 + 1, s1, 3) != (p + 25 + 1 + 3) || memcmp (p + 25, "Q123U", 6)) + abort (); + + if (stpcpy (stpcpy (p, "ABCD"), "EFG") != p + 7 || memcmp (p, "ABCDEFG", 8)) + abort(); + if (mempcpy (mempcpy (p, "abcdEFG", 4), "efg", 4) != p + 8 || memcmp (p, "abcdefg", 8)) + abort(); + + /* Test at least one instance of the __builtin_ style. We do this + to ensure that it works and that the prototype is correct. */ + if (__builtin_stpcpy (p, "abcde") != p + 5 || memcmp (p, "abcde", 6)) + abort (); + if (__builtin_mempcpy (p, "ABCDE", 6) != p + 6 || memcmp (p, "ABCDE", 6)) + abort (); + + /* If the result of stpcpy/mempcpy is ignored, gcc should use + strcpy/memcpy. This should be optimized always, so set inside_main + again. */ + inside_main = 1; + stpcpy (p + 3, s2); + if (memcmp (p, "ABCdefg", 8)) + abort (); + mempcpy (p + 5, s3, 1); + if (memcmp (p, "ABCdeFg", 8)) + abort (); + mempcpy (p + 6, s3 + 1, l1); + if (memcmp (p, "ABCdeFG", 8)) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-4-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-4-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-4-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-4-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "lib/stpcpy.c" + #include "lib/mempcpy.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-5.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-5.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-5.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Ensure builtin memmove and bcopy perform correctly. + + Written by Jakub Jelinek, 4/26/2003. */ + + extern void abort (void); + typedef __SIZE_TYPE__ size_t; + extern void *memmove (void *, const void *, size_t); + extern void bcopy (const void *, void *, size_t); + extern int memcmp (const void *, const void *, size_t); + + const char s1[] = "123"; + char p[32] = ""; + + static const struct foo + { + char *s; + double d; + long l; + } foo[] = + { + { "hello world1", 3.14159, 101L }, + { "hello world2", 3.14159, 102L }, + { "hello world3", 3.14159, 103L }, + { "hello world4", 3.14159, 104L }, + { "hello world5", 3.14159, 105L }, + { "hello world6", 3.14159, 106L } + }; + + static const struct bar + { + char *s; + const struct foo f[3]; + } bar[] = + { + { + "hello world10", + { + { "hello1", 3.14159, 201L }, + { "hello2", 3.14159, 202L }, + { "hello3", 3.14159, 203L }, + } + }, + { + "hello world11", + { + { "hello4", 3.14159, 204L }, + { "hello5", 3.14159, 205L }, + { "hello6", 3.14159, 206L }, + } + } + }; + + static const int baz[] = { 1, 2, 3, 4, 5, 6, 7, 8, 9, 0 }; + + void + main_test (void) + { + const char *s; + struct foo f1[sizeof foo/sizeof*foo]; + struct bar b1[sizeof bar/sizeof*bar]; + int bz[sizeof baz/sizeof*baz]; + + if (memmove (f1, foo, sizeof (foo)) != f1 || memcmp (f1, foo, sizeof(foo))) + abort(); + if (memmove (b1, bar, sizeof (bar)) != b1 || memcmp (b1, bar, sizeof(bar))) + abort(); + bcopy (baz, bz, sizeof (baz)); + if (memcmp (bz, baz, sizeof(baz))) + abort(); + + if (memmove (p, "abcde", 6) != p || memcmp (p, "abcde", 6)) + abort (); + s = s1; + if (memmove (p + 2, ++s, 0) != p + 2 || memcmp (p, "abcde", 6) || s != s1 + 1) + abort (); + if (__builtin_memmove (p + 3, "", 1) != p + 3 || memcmp (p, "abc\0e", 6)) + abort (); + bcopy ("fghijk", p + 2, 4); + if (memcmp (p, "abfghi", 7)) + abort (); + s = s1 + 1; + bcopy (s++, p + 1, 0); + if (memcmp (p, "abfghi", 7) || s != s1 + 2) + abort (); + __builtin_bcopy ("ABCDE", p + 4, 1); + if (memcmp (p, "abfgAi", 7)) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-5-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-5-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-5-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-5-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1 ---- + #include "lib/memmove.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-6.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-6.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-6.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + /* Copyright (C) 2001 Free Software Foundation. + + Ensure that builtin memcmp operations when all three arguments + are constant is optimized and performs correctly. Taken from + PR optimize/3508. + + Written by Roger Sayle, 12/26/2001. */ + + extern void abort (void); + extern void link_error (void); + + typedef __SIZE_TYPE__ size_t; + extern int memcmp (const void *, const void *, size_t); + + void + main_test (void) + { + if (memcmp ("abcd", "efgh", 4) >= 0) + link_error (); + if (memcmp ("abcd", "abcd", 4) != 0) + link_error (); + if (memcmp ("efgh", "abcd", 4) <= 0) + link_error (); + } + + #ifndef __OPTIMIZE__ + /* When not optimizing, the above tests may generate references to + the function link_error, but should never actually call it. */ + void + link_error () + { + abort (); + } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-6-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-6-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-6-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-6-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1 ---- + #include "lib/memcmp.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-7.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-7.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-7.c 2003-06-06 10:11:06.000000000 +0000 *************** *** 0 **** --- 1,169 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Ensure that builtin mempcpy and stpcpy perform correctly. + + Written by Jakub Jelinek, 21/05/2003. */ + + extern void abort (void); + typedef __SIZE_TYPE__ size_t; + extern void *mempcpy (void *, const void *, size_t); + extern int memcmp (const void *, const void *, size_t); + extern char *stpcpy (char *, const char *); + extern int inside_main; + + long buf1[64]; + char *buf2 = (char *) (buf1 + 32); + long buf5[20]; + char buf7[20]; + + int + __attribute__((noinline)) + test (long *buf3, char *buf4, char *buf6, int n) + { + int i = 0; + + /* These should probably be handled by store_by_pieces on most arches. */ + if (mempcpy (buf1, "ABCDEFGHI", 9) != (char *) buf1 + 9 + || memcmp (buf1, "ABCDEFGHI\0", 11)) + abort (); + + if (mempcpy (buf1, "abcdefghijklmnopq", 17) != (char *) buf1 + 17 + || memcmp (buf1, "abcdefghijklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf3, "ABCDEF", 6) != (char *) buf1 + 6 + || memcmp (buf1, "ABCDEFghijklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf3, "a", 1) != (char *) buf1 + 1 + || memcmp (buf1, "aBCDEFghijklmnopq\0", 19)) + abort (); + + if (mempcpy ((char *) buf3 + 2, "bcd" + ++i, 2) != (char *) buf1 + 4 + || memcmp (buf1, "aBcdEFghijklmnopq\0", 19) + || i != 1) + abort (); + + /* These should probably be handled by move_by_pieces on most arches. */ + if (mempcpy ((char *) buf3 + 4, buf5, 6) != (char *) buf1 + 10 + || memcmp (buf1, "aBcdRSTUVWklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy ((char *) buf1 + ++i + 8, (char *) buf5 + 1, 1) + != (char *) buf1 + 11 + || memcmp (buf1, "aBcdRSTUVWSlmnopq\0", 19) + || i != 2) + abort (); + + if (mempcpy ((char *) buf3 + 14, buf6, 2) != (char *) buf1 + 16 + || memcmp (buf1, "aBcdRSTUVWSlmnrsq\0", 19)) + abort (); + + if (mempcpy (buf3, buf5, 8) != (char *) buf1 + 8 + || memcmp (buf1, "RSTUVWXYVWSlmnrsq\0", 19)) + abort (); + + if (mempcpy (buf3, buf5, 17) != (char *) buf1 + 17 + || memcmp (buf1, "RSTUVWXYZ01234567\0", 19)) + abort (); + + __builtin_memcpy (buf3, "aBcdEFghijklmnopq\0", 19); + + /* These should be handled either by movstrendM or mempcpy + call. */ + if (mempcpy ((char *) buf3 + 4, buf5, n + 6) != (char *) buf1 + 10 + || memcmp (buf1, "aBcdRSTUVWklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy ((char *) buf1 + ++i + 8, (char *) buf5 + 1, n + 1) + != (char *) buf1 + 12 + || memcmp (buf1, "aBcdRSTUVWkSmnopq\0", 19) + || i != 3) + abort (); + + if (mempcpy ((char *) buf3 + 14, buf6, n + 2) != (char *) buf1 + 16 + || memcmp (buf1, "aBcdRSTUVWkSmnrsq\0", 19)) + abort (); + + i = 1; + + /* These might be handled by store_by_pieces. */ + if (mempcpy (buf2, "ABCDEFGHI", 9) != buf2 + 9 + || memcmp (buf2, "ABCDEFGHI\0", 11)) + abort (); + + if (mempcpy (buf2, "abcdefghijklmnopq", 17) != buf2 + 17 + || memcmp (buf2, "abcdefghijklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf4, "ABCDEF", 6) != buf2 + 6 + || memcmp (buf2, "ABCDEFghijklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf4, "a", 1) != buf2 + 1 + || memcmp (buf2, "aBCDEFghijklmnopq\0", 19)) + abort (); + + if (mempcpy (buf4 + 2, "bcd" + i++, 2) != buf2 + 4 + || memcmp (buf2, "aBcdEFghijklmnopq\0", 19) + || i != 2) + abort (); + + /* These might be handled by move_by_pieces. */ + if (mempcpy (buf4 + 4, buf7, 6) != buf2 + 10 + || memcmp (buf2, "aBcdRSTUVWklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf2 + i++ + 8, buf7 + 1, 1) + != buf2 + 11 + || memcmp (buf2, "aBcdRSTUVWSlmnopq\0", 19) + || i != 3) + abort (); + + if (mempcpy (buf4 + 14, buf6, 2) != buf2 + 16 + || memcmp (buf2, "aBcdRSTUVWSlmnrsq\0", 19)) + abort (); + + __builtin_memcpy (buf4, "aBcdEFghijklmnopq\0", 19); + + /* These should be handled either by movstrendM or mempcpy + call. */ + if (mempcpy (buf4 + 4, buf7, n + 6) != buf2 + 10 + || memcmp (buf2, "aBcdRSTUVWklmnopq\0", 19)) + abort (); + + if (__builtin_mempcpy (buf2 + i++ + 8, buf7 + 1, n + 1) + != buf2 + 12 + || memcmp (buf2, "aBcdRSTUVWkSmnopq\0", 19) + || i != 4) + abort (); + + if (mempcpy (buf4 + 14, buf6, n + 2) != buf2 + 16 + || memcmp (buf2, "aBcdRSTUVWkSmnrsq\0", 19)) + abort (); + + /* Now stpcpy tests. */ + if (stpcpy ((char *) buf3, "abcdefghijklmnop") != (char *) buf1 + 16 + || memcmp (buf1, "abcdefghijklmnop", 17)) + abort (); + + if (__builtin_stpcpy ((char *) buf3, "ABCDEFG") != (char *) buf1 + 7 + || memcmp (buf1, "ABCDEFG\0ijklmnop", 17)) + abort (); + + if (stpcpy ((char *) buf3 + i++, "x") != (char *) buf1 + 5 + || memcmp (buf1, "ABCDx\0G\0ijklmnop", 17)) + abort (); + + return 0; + } + + void + main_test (void) + { + /* All these tests are allowed to call mempcpy/stpcpy. */ + inside_main = 0; + __builtin_memcpy (buf5, "RSTUVWXYZ0123456789", 20); + __builtin_memcpy (buf7, "RSTUVWXYZ0123456789", 20); + test (buf1, buf2, "rstuvwxyz", 0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-7-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-7-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-7-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-7-lib.c 2003-06-06 10:11:06.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "lib/stpcpy.c" + #include "lib/mempcpy.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-8.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-8.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-8.c 2003-06-28 12:19:27.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test strlen optimizations on conditional expressions. + + Written by Jakub Jelinek, June 23, 2003. */ + + typedef __SIZE_TYPE__ size_t; + extern char *strcpy (char *, const char *); + extern int memcmp (const void *, const void *, size_t); + extern void abort (void); + extern void exit (int); + extern int inside_main; + + size_t g, h, i, j, k, l; + + size_t + foo (void) + { + if (l) + abort (); + return ++l; + } + + void + main_test (void) + { + if (strlen (i ? "foo" + 1 : j ? "bar" + 1 : "baz" + 1) != 2) + abort (); + if (strlen (g++ ? "foo" : "bar") != 3 || g != 1) + abort (); + if (strlen (h++ ? "xfoo" + 1 : "bar") != 3 || h != 1) + abort (); + if (strlen ((i++, "baz")) != 3 || i != 1) + abort (); + /* The following calls might not optimize strlen call away. */ + inside_main = 0; + if (strlen (j ? "foo" + k++ : "bar" + k++) != 3 || k != 1) + abort (); + if (strlen (foo () ? "foo" : "bar") != 3 || l != 1) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-8-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-8-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-8-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-8-lib.c 2003-06-28 12:19:27.000000000 +0000 *************** *** 0 **** --- 1 ---- + #include "lib/strlen.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-9.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-9.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-9.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-9.c 2003-08-14 14:26:15.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + /* Copyright (C) 2000, 2003 Free Software Foundation. + + Ensure all expected transformations of builtin strcat occur and + perform correctly. + + Written by Kaveh R. Ghazi, 11/27/2000. */ + + extern int inside_main; + extern void abort (void); + typedef __SIZE_TYPE__ size_t; + extern char *strcat (char *, const char *); + extern char *strcpy (char *, const char *); + extern int strcmp (const char *, const char *); + extern void *memset (void *, int, size_t); + extern int memcmp (const void *, const void *, size_t); + #define RESET_DST_WITH(FILLER) \ + do { memset (dst, 'X', sizeof (dst)); strcpy (dst, (FILLER)); } while (0) + + void main_test (void) + { + const char *const s1 = "hello world"; + const char *const s2 = ""; + char dst[64], *d2; + + RESET_DST_WITH (s1); + if (strcat (dst, "") != dst || strcmp (dst, s1)) + abort(); + RESET_DST_WITH (s1); + if (strcat (dst, s2) != dst || strcmp (dst, s1)) + abort(); + RESET_DST_WITH (s1); d2 = dst; + if (strcat (++d2, s2) != dst+1 || d2 != dst+1 || strcmp (dst, s1)) + abort(); + RESET_DST_WITH (s1); d2 = dst; + if (strcat (++d2+5, s2) != dst+6 || d2 != dst+1 || strcmp (dst, s1)) + abort(); + RESET_DST_WITH (s1); d2 = dst; + if (strcat (++d2+5, s1+11) != dst+6 || d2 != dst+1 || strcmp (dst, s1)) + abort(); + + #ifndef __OPTIMIZE_SIZE__ + # if !defined __i386__ && !defined __x86_64__ + /* The functions below might not be optimized into direct stores on all + arches. It depends on how many instructions would be generated and + what limits the architecture chooses in STORE_BY_PIECES_P. */ + inside_main = 0; + # endif + + RESET_DST_WITH (s1); + if (strcat (dst, " 1111") != dst + || memcmp (dst, "hello world 1111\0XXX", 20)) + abort(); + + RESET_DST_WITH (s1); + if (strcat (dst+5, " 2222") != dst+5 + || memcmp (dst, "hello world 2222\0XXX", 20)) + abort(); + + RESET_DST_WITH (s1); d2 = dst; + if (strcat (++d2+5, " 3333") != dst+6 || d2 != dst+1 + || memcmp (dst, "hello world 3333\0XXX", 20)) + abort(); + + RESET_DST_WITH (s1); + strcat (strcat (strcat (strcat (strcat (strcat (dst, ": this "), ""), + "is "), "a "), "test"), "."); + if (memcmp (dst, "hello world: this is a test.\0X", 30)) + abort(); + + /* Set inside_main again. */ + inside_main = 1; + #endif + + /* Test at least one instance of the __builtin_ style. We do this + to ensure that it works and that the prototype is correct. */ + RESET_DST_WITH (s1); + if (__builtin_strcat (dst, "") != dst || strcmp (dst, s1)) + abort(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-9-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-9-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-9-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-9-lib.c 2003-08-14 14:26:15.000000000 +0000 *************** *** 0 **** --- 1 ---- + #include "lib/strcat.c" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1.c 2003-05-15 15:06:01.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + /* Copyright (C) 2000, 2003 Free Software Foundation. + + Ensure all expected transformations of builtin strstr occur and + perform correctly in presence of redirect. */ + + #define ASMNAME(cname) ASMNAME2 (__USER_LABEL_PREFIX__, cname) + #define ASMNAME2(prefix, cname) STRING (prefix) cname + #define STRING(x) #x + + typedef __SIZE_TYPE__ size_t; + extern void abort (void); + extern char *strstr (const char *, const char *) + __asm (ASMNAME ("my_strstr")); + + const char *p = "rld", *q = "hello world"; + + void + main_test (void) + { + const char *const foo = "hello world"; + + if (strstr (foo, "") != foo) + abort (); + if (strstr (foo + 4, "") != foo + 4) + abort (); + if (strstr (foo, "h") != foo) + abort (); + if (strstr (foo, "w") != foo + 6) + abort (); + if (strstr (foo + 6, "o") != foo + 7) + abort (); + if (strstr (foo + 1, "world") != foo + 6) + abort (); + if (strstr (foo + 2, p) != foo + 8) + abort (); + if (strstr (q, "") != q) + abort (); + if (strstr (q + 1, "o") != q + 4) + abort (); + + /* Test at least one instance of the __builtin_ style. We do this + to ensure that it works and that the prototype is correct. */ + if (__builtin_strstr (foo + 1, "world") != foo + 6) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-1-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + extern int inside_main; + extern const char *p; + + char * + my_strstr (const char *s1, const char *s2) + { + __SIZE_TYPE__ len = strlen (s2); + + #ifdef __OPTIMIZE__ + /* If optimizing, we should be called only in the strstr (foo + 2, p) + case. All other cases should be optimized. */ + if (inside_main) + if (s2 != p || strcmp (s1, "hello world" + 2) != 0) + abort (); + #endif + if (len == 0) + return (char *) s1; + for (s1 = strchr (s1, *s2); s1; s1 = strchr (s1 + 1, *s2)) + if (strncmp (s1, s2, len) == 0) + return (char *) s1; + return (char *) 0; + } + + char * + strstr (const char *s1, const char *s2) + { + if (inside_main) + abort (); + + return my_strstr (s1, s2); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2.c 2003-05-15 15:06:01.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test memcpy and memset in presence of redirect. */ + + #define ASMNAME(cname) ASMNAME2 (__USER_LABEL_PREFIX__, cname) + #define ASMNAME2(prefix, cname) STRING (prefix) cname + #define STRING(x) #x + + typedef __SIZE_TYPE__ size_t; + extern void abort (void); + extern void *memcpy (void *, const void *, size_t) + __asm (ASMNAME ("my_memcpy")); + extern void bcopy (const void *, void *, size_t) + __asm (ASMNAME ("my_bcopy")); + extern void *memset (void *, int, size_t) + __asm (ASMNAME ("my_memset")); + extern void bzero (void *, size_t) + __asm (ASMNAME ("my_bzero")); + extern int memcmp (const void *, const void *, size_t); + + struct A { char c[32]; } a = { "foobar" }; + char x[64] = "foobar", y[64]; + int i = 39, j = 6, k = 4; + + void + main_test (void) + { + struct A b = a; + struct A c = { { 'x' } }; + + if (memcmp (b.c, x, 32) || c.c[0] != 'x' || memcmp (c.c + 1, x + 32, 31)) + abort (); + if (__builtin_memcpy (y, x, i) != y || memcmp (x, y, 64)) + abort (); + if (memcpy (y + 6, x, j) != y + 6 + || memcmp (x, y, 6) || memcmp (x, y + 6, 58)) + abort (); + if (__builtin_memset (y + 2, 'X', k) != y + 2 + || memcmp (y, "foXXXXfoobar", 13)) + abort (); + bcopy (y + 1, y + 2, 6); + if (memcmp (y, "fooXXXXfobar", 13)) + abort (); + __builtin_bzero (y + 4, 2); + if (memcmp (y, "fooX\0\0Xfobar", 13)) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2-lib.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2-lib.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2-lib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtins/string-asm-2-lib.c 2003-05-11 08:20:34.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + extern int inside_main; + typedef __SIZE_TYPE__ size_t; + + #define TEST_ABORT if (inside_main) abort() + + void * + my_memcpy (void *d, const void *s, size_t n) + { + char *dst = (char *) d; + const char *src = (const char *) s; + while (n--) + *dst++ = *src++; + return (char *) d; + } + + void + my_bcopy (const void *s, void *d, size_t n) + { + char *dst = (char *) d; + const char *src = (const char *) s; + if (src >= dst) + while (n--) + *dst++ = *src++; + else + { + dst += n; + src += n; + while (n--) + *--dst = *--src; + } + } + + void * + my_memset (void *d, int c, size_t n) + { + char *dst = (char *) d; + while (n--) + *dst++ = c; + return (char *) d; + } + + void + my_bzero (void *d, size_t n) + { + char *dst = (char *) d; + while (n--) + *dst++ = '\0'; + } + + void * + memcpy (void *d, const void *s, size_t n) + { + TEST_ABORT; + return my_memcpy (d, s, n); + } + + void + bcopy (const void *s, void *d, size_t n) + { + TEST_ABORT; + my_bcopy (s, d, n); + } + + void * + memset (void *d, int c, size_t n) + { + TEST_ABORT; + return my_memset (d, c, n); + } + + void + bzero (void *d, size_t n) + { + TEST_ABORT; + my_bzero (d, n); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-types-compatible-p.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-types-compatible-p.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/builtin-types-compatible-p.c 2001-12-08 22:29:03.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/builtin-types-compatible-p.c 2004-01-07 22:24:44.000000000 +0000 *************** int main (void) *** 19,25 **** && __builtin_types_compatible_p (typeof (hot), int) && __builtin_types_compatible_p (typeof (hot), typeof (laura)) && __builtin_types_compatible_p (int[5], int[]) - && __builtin_types_compatible_p (typeof (dingos), typeof (cranberry)) && __builtin_types_compatible_p (same1, same2))) abort (); --- 19,24 ---- *************** int main (void) *** 28,33 **** --- 27,33 ---- || __builtin_types_compatible_p (char *, const char *) || __builtin_types_compatible_p (long double, double) || __builtin_types_compatible_p (typeof (i), typeof (d)) + || __builtin_types_compatible_p (typeof (dingos), typeof (cranberry)) || __builtin_types_compatible_p (char, int) || __builtin_types_compatible_p (char *, char **)) abort (); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/comp-goto-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/comp-goto-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/comp-goto-1.c 2001-11-20 03:51:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/comp-goto-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,13 **** #include ! #if !defined(NO_LABEL_VALUES) && (!defined(STACK_SIZE) || STACK_SIZE >= 4000) ! #if __INT_MAX__ == 32767 ! typedef unsigned long uint32; ! typedef signed long sint32; ! #else typedef unsigned int uint32; typedef signed int sint32; - #endif typedef uint32 reg_t; --- 1,8 ---- #include ! #if !defined(NO_LABEL_VALUES) && (!defined(STACK_SIZE) || STACK_SIZE >= 4000) && __INT_MAX__ >= 2147483647 typedef unsigned int uint32; typedef signed int sint32; typedef uint32 reg_t; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/compndlit-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/compndlit-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/compndlit-1.c 1998-12-16 22:15:29.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/compndlit-1.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else struct S { int a:3; *************** main () *** 13,15 **** --- 22,25 ---- abort (); exit (0); } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/divconst-3.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/divconst-3.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/divconst-3.x 2002-02-25 23:07:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/divconst-3.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,5 **** - if { [istarget "h8300*-*-*"] } { - return 1 - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/eeprof-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/eeprof-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/eeprof-1.c 2000-06-29 03:10:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/eeprof-1.c 2003-01-21 19:43:53.000000000 +0000 *************** int entry_calls, exit_calls; *** 5,17 **** --- 5,20 ---- void (*last_fn_entered)(); void (*last_fn_exited)(); + __attribute__ ((noinline)) int main () NOCHK; + __attribute__ ((noinline)) void foo () { ASSERT (last_fn_entered == foo); } + __attribute__ ((noinline)) static void foo2 () { ASSERT (entry_calls == 1 && exit_calls == 0); *************** static void foo2 () *** 22,27 **** --- 25,31 ---- ASSERT (last_fn_exited == foo); } + __attribute__ ((noinline)) void nfoo (void) NOCHK; void nfoo () { *************** int main () *** 55,65 **** --- 59,71 ---- void __cyg_profile_func_enter (void (*fn)(), void (*parent)()) NOCHK; void __cyg_profile_func_exit (void (*fn)(), void (*parent)()) NOCHK; + __attribute__ ((noinline)) void __cyg_profile_func_enter (void (*fn)(), void (*parent)()) { entry_calls++; last_fn_entered = fn; } + __attribute__ ((noinline)) void __cyg_profile_func_exit (void (*fn)(), void (*parent)()) { exit_calls++; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/extzvsi.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/extzvsi.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/extzvsi.c 2002-09-05 22:53:20.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/extzvsi.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else /* Failed on powerpc due to bad extzvsi pattern. */ struct ieee *************** main (void) *** 29,31 **** --- 38,41 ---- abort (); return 0; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/20030331-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/20030331-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/20030331-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/20030331-1.c 2003-03-31 06:28:56.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + extern void exit (int); + extern void abort (void); + float x = -1.5f; + + float + rintf () + { + static const float TWO23 = 8388608.0; + + if (__builtin_fabs (x) < TWO23) + { + if (x > 0.0) + { + x += TWO23; + x -= TWO23; + } + else if (x < 0.0) + { + x = TWO23 - x; + x = -(x - TWO23); + } + } + + return x; + } + + int main (void) + { + if (rintf () != -2.0) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-6.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-6.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-6.c 2003-03-28 22:10:18.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + + const double dnan = 1.0/0.0 - 1.0/0.0; + double x = 1.0; + + extern void link_error (void); + extern void abort (void); + + main () + { + #if ! defined (__vax__) && ! defined (_CRAY) + /* NaN is an IEEE unordered operand. All these test should be false. */ + if (dnan == dnan) + link_error (); + if (dnan != x) + x = 1.0; + else + link_error (); + + if (dnan < x) + link_error (); + if (dnan > x) + link_error (); + if (dnan <= x) + link_error (); + if (dnan >= x) + link_error (); + if (dnan == x) + link_error (); + #endif + exit (0); + } + + #ifndef __OPTIMIZE__ + void link_error (void) + { + abort (); + } + #endif + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-7.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-7.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-7.c 2003-03-28 02:41:14.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + extern void link_error (); + + void foo(double x) + { + if (x > __builtin_inf()) + link_error (); + } + + int main () + { + foo (1.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-8.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-8.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/fp-cmp-8.c 2003-05-05 19:33:52.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + /* Like fp-cmp-4.c, but test that the cmove patterns are correct. */ + + static double + test_isunordered(double x, double y, double a, double b) + { + return __builtin_isunordered(x, y) ? a : b; + } + + static double + test_not_isunordered(double x, double y, double a, double b) + { + return !__builtin_isunordered(x, y) ? a : b; + } + + static double + test_isless(double x, double y, double a, double b) + { + return __builtin_isless(x, y) ? a : b; + } + + static double + test_not_isless(double x, double y, double a, double b) + { + return !__builtin_isless(x, y) ? a : b; + } + + static double + test_islessequal(double x, double y, double a, double b) + { + return __builtin_islessequal(x, y) ? a : b; + } + + static double + test_not_islessequal(double x, double y, double a, double b) + { + return !__builtin_islessequal(x, y) ? a : b; + } + + static double + test_isgreater(double x, double y, double a, double b) + { + return __builtin_isgreater(x, y) ? a : b; + } + + static double + test_not_isgreater(double x, double y, double a, double b) + { + return !__builtin_isgreater(x, y) ? a : b; + } + + static double + test_isgreaterequal(double x, double y, double a, double b) + { + return __builtin_isgreaterequal(x, y) ? a : b; + } + + static double + test_not_isgreaterequal(double x, double y, double a, double b) + { + return !__builtin_isgreaterequal(x, y) ? a : b; + } + + static double + test_islessgreater(double x, double y, double a, double b) + { + return __builtin_islessgreater(x, y) ? a : b; + } + + static double + test_not_islessgreater(double x, double y, double a, double b) + { + return !__builtin_islessgreater(x, y) ? a : b; + } + + static void + one_test(double x, double y, int expected, + double (*pos) (double, double, double, double), + double (*neg) (double, double, double, double)) + { + if (((*pos)(x, y, 1.0, 2.0) == 1.0) != expected) + abort (); + if (((*neg)(x, y, 3.0, 4.0) == 4.0) != expected) + abort (); + } + + #define NAN (0.0 / 0.0) + #define INF (1.0 / 0.0) + + int + main() + { + struct try + { + double x, y; + int result[6]; + }; + + static struct try const data[] = + { + { NAN, NAN, { 1, 0, 0, 0, 0, 0 } }, + { 0.0, NAN, { 1, 0, 0, 0, 0, 0 } }, + { NAN, 0.0, { 1, 0, 0, 0, 0, 0 } }, + { 0.0, 0.0, { 0, 0, 1, 0, 1, 0 } }, + { 1.0, 2.0, { 0, 1, 1, 0, 0, 1 } }, + { 2.0, 1.0, { 0, 0, 0, 1, 1, 1 } }, + { INF, 0.0, { 0, 0, 0, 1, 1, 1 } }, + { 1.0, INF, { 0, 1, 1, 0, 0, 1 } }, + { INF, INF, { 0, 0, 1, 0, 1, 0 } }, + { 0.0, -INF, { 0, 0, 0, 1, 1, 1 } }, + { -INF, 1.0, { 0, 1, 1, 0, 0, 1 } }, + { -INF, -INF, { 0, 0, 1, 0, 1, 0 } }, + { INF, -INF, { 0, 0, 0, 1, 1, 1 } }, + { -INF, INF, { 0, 1, 1, 0, 0, 1 } }, + }; + + struct test + { + double (*pos)(double, double, double, double); + double (*neg)(double, double, double, double); + }; + + static struct test const tests[] = + { + { test_isunordered, test_not_isunordered }, + { test_isless, test_not_isless }, + { test_islessequal, test_not_islessequal }, + { test_isgreater, test_not_isgreater }, + { test_isgreaterequal, test_not_isgreaterequal }, + { test_islessgreater, test_not_islessgreater } + }; + + const int n = sizeof(data) / sizeof(data[0]); + int i, j; + + for (i = 0; i < n; ++i) + for (j = 0; j < 6; ++j) + one_test (data[i].x, data[i].y, data[i].result[j], + tests[j].pos, tests[j].neg); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/inf-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/inf-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/inf-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/inf-2.c 2003-05-23 03:46:53.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + extern void abort (void); + + void test(double f, double i) + { + if (f == __builtin_inf()) + abort (); + if (f == -__builtin_inf()) + abort (); + if (i == -__builtin_inf()) + abort (); + if (i != __builtin_inf()) + abort (); + + if (f >= __builtin_inf()) + abort (); + if (f > __builtin_inf()) + abort (); + if (i > __builtin_inf()) + abort (); + if (f <= -__builtin_inf()) + abort (); + if (f < -__builtin_inf()) + abort (); + } + + void testf(float f, float i) + { + if (f == __builtin_inff()) + abort (); + if (f == -__builtin_inff()) + abort (); + if (i == -__builtin_inff()) + abort (); + if (i != __builtin_inff()) + abort (); + + if (f >= __builtin_inff()) + abort (); + if (f > __builtin_inff()) + abort (); + if (i > __builtin_inff()) + abort (); + if (f <= -__builtin_inff()) + abort (); + if (f < -__builtin_inff()) + abort (); + } + + void testl(long double f, long double i) + { + if (f == __builtin_infl()) + abort (); + if (f == -__builtin_infl()) + abort (); + if (i == -__builtin_infl()) + abort (); + if (i != __builtin_infl()) + abort (); + + if (f >= __builtin_infl()) + abort (); + if (f > __builtin_infl()) + abort (); + if (i > __builtin_infl()) + abort (); + if (f <= -__builtin_infl()) + abort (); + if (f < -__builtin_infl()) + abort (); + } + + int main() + { + test (34.0, __builtin_inf()); + testf (34.0f, __builtin_inff()); + testf (34.0l, __builtin_infl()); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/mzero4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/mzero4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/mzero4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/mzero4.c 2003-06-04 12:20:40.000000000 +0000 *************** *** 0 **** --- 1,58 ---- + /* Copyright (C) 2003 Free Software Foundation. + by Roger Sayle , derived from mzero3.c + + Constant folding of sin(-0.0), tan(-0.0) and atan(-0.0) should + all return -0.0, for both double and float forms. */ + + void abort (void); + typedef __SIZE_TYPE__ size_t; + extern int memcmp (const void *, const void *, size_t); + + double sin (double); + double tan (double); + double atan (double); + + float sinf (float); + float tanf (float); + float atanf (float); + + void expectd (double, double); + void expectf (float, float); + + void + expectd (double value, double expected) + { + if (value != expected + || memcmp ((void *)&value, (void *) &expected, sizeof (double)) != 0) + abort (); + } + + void + expectf (float value, float expected) + { + if (value != expected + || memcmp ((void *)&value, (void *) &expected, sizeof (float)) != 0) + abort (); + } + + int main () + { + expectd (sin (0.0), 0.0); + expectd (tan (0.0), 0.0); + expectd (atan (0.0), 0.0); + + expectd (sin (-0.0), -0.0); + expectd (tan (-0.0), -0.0); + expectd (atan (-0.0), -0.0); + + expectf (sinf (0.0f), 0.0f); + expectf (tanf (0.0f), 0.0f); + expectf (atanf (0.0f), 0.0f); + + expectf (sinf (-0.0f), -0.0f); + expectf (tanf (-0.0f), -0.0f); + expectf (atanf (-0.0f), -0.0f); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/mzero5.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/mzero5.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/ieee/mzero5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/ieee/mzero5.c 2003-12-18 02:45:18.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* Test gcse handling of IEEE 0/-0 rules. */ + static double zero = 0.0; + + int + negzero_check (double d) + { + if (d == 0) + return !!memcmp ((void *)&zero, (void *)&d, sizeof (double)); + return 0; + } + + int + sub (double d, double e) + { + if (d == 0.0 && e == 0.0 + && negzero_check (d) == 0 && negzero_check (e) == 0) + return 1; + else + return 0; + } + + int + main (void) + { + double minus_zero = -0.0; + if (sub (minus_zero, 0)) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2e.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2e.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2e.x 2002-07-17 17:55:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2e.x 2003-12-30 17:25:49.000000000 +0000 *************** *** 1,11 **** - # This doesn't work on m68k-motorola-sysv - # It also doesn't work on m88k-motorola-sysv3 - global target_triplet - if { [istarget "m68k-motorola-sysv"] || [istarget "m88k-motorola-sysv3"] } { - set torture_compile_xfail "$target_triplet" - } - if { [istarget "i?86-*"] } { set torture_eval_before_execute { global compiler_conditional_xfail_data --- 1,4 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2f.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2f.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2f.x 1998-12-16 22:15:56.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2f.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,9 **** - # This doesn't work on m68k-motorola-sysv - # It also doesn't work on m88k-motorola-sysv3 - - global target_triplet - if { [istarget "m68k-motorola-sysv"] || [istarget "m88k-motorola-sysv3"] } { - set torture_compile_xfail "$target_triplet" - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2g.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2g.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/loop-2g.x 1998-12-16 22:15:58.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/loop-2g.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,9 **** - # This doesn't work on m68k-motorola-sysv - # It also doesn't work on m88k-motorola-sysv3 - - global target_triplet - if { [istarget "m68k-motorola-sysv"] || [istarget "m88k-motorola-sysv3"] } { - set torture_compile_xfail "$target_triplet" - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/medce-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/medce-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/medce-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/medce-1.c 2003-04-17 01:22:51.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + + extern void abort (void); + extern void link_error (void); + + static int ok = 0; + + void bar (void) + { + ok = 1; + } + + void foo(int x) + { + switch (x) + { + case 0: + if (0) + { + link_error(); + case 1: + bar(); + } + } + } + + int main() + { + foo (1); + if (!ok) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/medce-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/medce-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/medce-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/medce-2.c 2003-04-17 01:22:51.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + + extern void abort (); + + static int ok = 0; + + int bar(void) + { + ok |= 1; + return 1; + } + + void bat(void) + { + ok |= 2; + } + + void baz(void) + { + ok |= 4; + } + + void foo() + { + goto lab; + + if (0) + { + if (({lab: bar();})) + bat (); + else + baz (); + } + } + + int main() + { + foo(); + if (ok != 3) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/multi-ix.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/multi-ix.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/multi-ix.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/multi-ix.c 2003-06-28 21:30:30.000000000 +0000 *************** *** 0 **** --- 1,181 ---- + /* Test for a reload bug: + if you have a memory reference using the indexed addressing + mode, and the base address is a pseudo containing an address in the frame + and this pseudo fails to get a hard register, we end up with a double PLUS, + so the frame address gets reloaded. Now, when the index got a hard register, + and it dies in this insn, push_reload will consider that hard register as + a reload register, and disregrad overlaps with rld[n_reloads].in . That is + fine as long as the add can be done with a single insn, but when the + constant is so large that it has to be reloaded into a register first, + that clobbers the index. */ + + #include + + #ifdef STACK_SIZE + #define CHUNK ((STACK_SIZE-100)/40/sizeof(int)) + #else + #define CHUNK 500 + #endif + + void s(int, ...); + void z(int, ...); + void c(int, ...); + + typedef int l[CHUNK]; + + void + f (int n) + { + int i; + l a0, a1, a2, a3, a4, a5, a6, a7, a8, a9; + l a10, a11, a12, a13, a14, a15, a16, a17, a18, a19; + l a20, a21, a22, a23, a24, a25, a26, a27, a28, a29; + l a30, a31, a32, a33, a34, a35, a36, a37, a38, a39; + int i0, i1, i2, i3, i4, i5, i6, i7, i8, i9; + int i10, i11, i12, i13, i14, i15, i16, i17, i18, i19; + int i20, i21, i22, i23, i24, i25, i26, i27, i28, i29; + int i30, i31, i32, i33, i34, i35, i36, i37, i38, i39; + + for (i = 0; i < n; i++) + { + s (40, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, + a30, a31, a32, a33, a34, a35, a36, a37, a38, a39); + i0 = a0[0]; + i1 = a1[0]; + i2 = a2[0]; + i3 = a3[0]; + i4 = a4[0]; + i5 = a5[0]; + i6 = a6[0]; + i7 = a7[0]; + i8 = a8[0]; + i9 = a9[0]; + i10 = a10[0]; + i11 = a11[0]; + i12 = a12[0]; + i13 = a13[0]; + i14 = a14[0]; + i15 = a15[0]; + i16 = a16[0]; + i17 = a17[0]; + i18 = a18[0]; + i19 = a19[0]; + i20 = a20[0]; + i21 = a21[0]; + i22 = a22[0]; + i23 = a23[0]; + i24 = a24[0]; + i25 = a25[0]; + i26 = a26[0]; + i27 = a27[0]; + i28 = a28[0]; + i29 = a29[0]; + i30 = a30[0]; + i31 = a31[0]; + i32 = a32[0]; + i33 = a33[0]; + i34 = a34[0]; + i35 = a35[0]; + i36 = a36[0]; + i37 = a37[0]; + i38 = a38[0]; + i39 = a39[0]; + z (40, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, + a30, a31, a32, a33, a34, a35, a36, a37, a38, a39); + a0[i0] = i0; + a1[i1] = i1; + a2[i2] = i2; + a3[i3] = i3; + a4[i4] = i4; + a5[i5] = i5; + a6[i6] = i6; + a7[i7] = i7; + a8[i8] = i8; + a9[i9] = i9; + a10[i10] = i10; + a11[i11] = i11; + a12[i12] = i12; + a13[i13] = i13; + a14[i14] = i14; + a15[i15] = i15; + a16[i16] = i16; + a17[i17] = i17; + a18[i18] = i18; + a19[i19] = i19; + a20[i20] = i20; + a21[i21] = i21; + a22[i22] = i22; + a23[i23] = i23; + a24[i24] = i24; + a25[i25] = i25; + a26[i26] = i26; + a27[i27] = i27; + a28[i28] = i28; + a29[i29] = i29; + a30[i30] = i30; + a31[i31] = i31; + a32[i32] = i32; + a33[i33] = i33; + a34[i34] = i34; + a35[i35] = i35; + a36[i36] = i36; + a37[i37] = i37; + a38[i38] = i38; + a39[i39] = i39; + c (40, a0, a1, a2, a3, a4, a5, a6, a7, a8, a9, + a10, a11, a12, a13, a14, a15, a16, a17, a18, a19, + a20, a21, a22, a23, a24, a25, a26, a27, a28, a29, + a30, a31, a32, a33, a34, a35, a36, a37, a38, a39); + } + } + + int + main () + { + f (1); + exit (0); + } + + void s(int n, ...) + { + va_list list; + + va_start (list, n); + while (n--) + { + int *a = va_arg (list, int *); + a[0] = n; + } + va_end (list); + } + + void z(int n, ...) + { + va_list list; + + va_start (list, n); + while (n--) + { + int *a = va_arg (list, int *); + bzero (a, sizeof (l)); + } + va_end (list); + } + + void c(int n, ...) + { + va_list list; + + va_start (list, n); + while (n--) + { + int *a = va_arg (list, int *); + if (a[n] != n) + abort (); + } + va_end (list); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/nestfunc-5.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/nestfunc-5.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/nestfunc-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/nestfunc-5.c 2003-12-05 11:11:08.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + extern void abort (void); + extern void exit (int); + + #ifndef NO_TRAMPOLINES + static void recursive (int n, void (*proc) (void)) + { + __label__ l1; + + void do_goto (void) + { + goto l1; + } + + if (n == 3) + recursive (n - 1, do_goto); + else if (n > 0) + recursive (n - 1, proc); + else + (*proc) (); + return; + + l1: + if (n == 3) + exit (0); + else + abort (); + } + + int main () + { + recursive (10, abort); + abort (); + } + #else + int main () { return 0; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/nestfunc-6.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/nestfunc-6.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/nestfunc-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/nestfunc-6.c 2003-12-05 11:21:48.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* Test that the GP gets properly restored, either by the nonlocal + receiver or the nested function. */ + + #ifndef NO_TRAMPOLINES + + typedef __SIZE_TYPE__ size_t; + extern void abort (void); + extern void exit (int); + extern void qsort(void *, size_t, size_t, int (*)(const void *, const void *)); + + int main () + { + __label__ nonlocal; + int compare (const void *a, const void *b) + { + goto nonlocal; + } + + char array[3]; + qsort (array, 3, 1, compare); + abort (); + + nonlocal: + exit (0); + } + + #else + int main() { return 0; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/pure-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/pure-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/pure-1.c 2002-06-19 00:43:33.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/pure-1.c 2003-01-21 19:43:53.000000000 +0000 *************** *** 1,3 **** --- 1,4 ---- + /* Origin: Kaveh Ghazi 2002-05-27. */ /* Use a different function for each test so the link failures diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/scope-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/scope-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/scope-2.c 1998-12-16 22:16:15.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/scope-2.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,17 **** - static int v = 3; - - f () - { - int v = 4; - { - extern int v; - if (v != 3) - abort (); - } - } - - main () - { - f (); - exit (0); - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/shiftdi.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/shiftdi.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/shiftdi.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/shiftdi.x 2003-05-08 23:38:03.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + # 16-bit "int" + if { [istarget "xstormy16-*"] } { + return 1 + } + + return 0 + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/shiftopt-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/shiftopt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/shiftopt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/shiftopt-1.c 2002-12-16 18:22:42.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + /* Copyright (C) 2002 Free Software Foundation + + Check that constant folding of shift operations is working. + + Roger Sayle, 10th October 2002. */ + + extern void abort (void); + extern void link_error (void); + + void + utest (unsigned int x) + { + if (x >> 0 != x) + link_error (); + + if (x << 0 != x) + link_error (); + + if (0 << x != 0) + link_error (); + + if (0 >> x != 0) + link_error (); + + if (-1 >> x != -1) + link_error (); + + if (~0 >> x != ~0) + link_error (); + } + + void + stest (int x) + { + if (x >> 0 != x) + link_error (); + + if (x << 0 != x) + link_error (); + + if (0 << x != 0) + link_error (); + + if (0 >> x != 0) + link_error (); + + if (-1 >> x != -1) + link_error (); + + if (~0 >> x != ~0) + link_error (); + } + + int + main () + { + utest(9); + utest(0); + + stest(9); + stest(0); + + return 0; + } + + #ifndef __OPTIMIZE__ + void + link_error () + { + abort (); + } + #endif + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/simd-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/simd-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/simd-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/simd-4.c 2003-06-26 13:10:55.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + typedef int __attribute__((vector_size(8))) v2si; + long long s64; + + static inline long long + __ev_convert_s64 (v2si a) + { + return (long long) a; + } + + int main() + { + union { long long ll; int i[2]; } endianness_test; + endianness_test.ll = 1; + int little_endian = endianness_test.i[0]; + s64 = __ev_convert_s64 ((v2si){1,0xffffffff}); + if (s64 != (little_endian ? 0xffffffff00000001LL : 0x1ffffffffLL)) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/simd-4.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/simd-4.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/simd-4.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/simd-4.x 2003-11-05 20:15:01.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + # This doesn't work on sparc*-*-* at -O0. + + set torture_eval_before_compile { + global compiler_conditional_xfail_data + set compiler_conditional_xfail_data { + "PR target/12916" \ + { "sparc*-*-*" } \ + { "-O0" } \ + { "" } + } + } + + return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-1.c 2003-03-24 01:26:29.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-1.c 2003-06-28 12:19:27.000000000 +0000 *************** extern void abort(void); *** 12,17 **** --- 12,19 ---- If stdio.h provides one, that is okay. */ extern int fputs(); + int i; + int main() { FILE *s_array[] = {stdout, NULL}, **s_ptr = s_array; *************** int main() *** 51,56 **** --- 53,67 ---- __builtin_fputc ('\n', *s_ptr); __builtin_fwrite ("hello\n", 1, 6, *s_ptr); + /* Check side-effects in conditional expression. */ + s_ptr = s_array; + fputs (i++ ? "f" : "x", *s_ptr++); + if (s_ptr != s_array+1 || *s_ptr != 0 || i != 1) + abort(); + fputs (--i ? "\n" : "\n", *--s_ptr); + if (s_ptr != s_array || i != 0) + abort(); + return 0; } *************** int main() *** 58,63 **** --- 69,75 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int fputs(const char *string, FILE *stream) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-2.c 2001-01-28 01:27:25.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-2.c 2003-01-21 19:43:53.000000000 +0000 *************** int main() *** 45,50 **** --- 45,51 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int printf (const char *string, ...) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/stdio-opt-3.c 2001-01-07 23:15:47.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/stdio-opt-3.c 2003-01-21 19:43:53.000000000 +0000 *************** int main() *** 57,62 **** --- 57,63 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int fprintf (FILE *stream, const char *string, ...) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/strct-varg-1.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/strct-varg-1.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/strct-varg-1.x 2002-11-28 17:41:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/strct-varg-1.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,7 **** - # This doesn't work on mn10200 - - if { [istarget "mn10200*-*-*"] } { - set torture_execute_xfail "mn10200*-*-*" - } - - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-10.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-10.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-10.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-10.c 2003-07-29 06:25:53.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000 Free Software Foundation. Ensure all expected transformations of builtin strncat occur and perform correctly. --- 1,4 ---- ! /* Copyright (C) 2000, 2003 Free Software Foundation. Ensure all expected transformations of builtin strncat occur and perform correctly. *************** extern void abort (void); *** 9,15 **** typedef __SIZE_TYPE__ size_t; extern char *strncat (char *, const char *, size_t); extern char *strcpy (char *, const char *); ! extern char *strcmp (const char *, const char *); int x = 123; int main () --- 9,15 ---- typedef __SIZE_TYPE__ size_t; extern char *strncat (char *, const char *, size_t); extern char *strcpy (char *, const char *); ! extern int strcmp (const char *, const char *); int x = 123; int main () *************** int main () *** 76,81 **** --- 76,82 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static char * strncat (char *s1, const char *s2, size_t n) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-11.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-11.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-11.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-11.c 2003-01-21 19:43:53.000000000 +0000 *************** int main () *** 58,63 **** --- 58,64 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static size_t strspn (const char *s1, const char *s2) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-12.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-12.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-12.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-12.c 2003-01-21 19:43:53.000000000 +0000 *************** int main () *** 58,63 **** --- 58,64 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static size_t strcspn (const char *s1, const char *s2) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-13.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-13.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-13.c 2001-11-14 23:37:31.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-13.c 2003-01-21 19:43:53.000000000 +0000 *************** main () *** 49,54 **** --- 49,55 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static size_t strlen (const char *s) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-14.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-14.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-14.c 2001-12-13 00:43:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-14.c 2003-01-21 19:43:53.000000000 +0000 *************** main () *** 25,36 **** --- 25,38 ---- something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static void * memset (void *s, int c, size_t n) { abort (); } + __attribute__ ((noinline)) static void * memcpy (void *dest, const void *src, size_t n) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-15.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-15.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-15.c 2001-12-13 00:43:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-15.c 2004-02-08 01:27:19.000000000 +0000 *************** main () *** 37,44 **** /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ static int ! memcmp (const char *p1, const char *p2, size_t len) { abort (); } --- 37,45 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int ! memcmp (const void *p1, const void *p2, size_t len) { abort (); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-16.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-16.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-16.c 2001-12-27 23:34:31.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-16.c 2003-06-27 02:50:18.000000000 +0000 *************** *** 1,26 **** ! /* Copyright (C) 2001 Free Software Foundation. ! Ensure that builtin memcmp operations when all three arguments ! are constant is optimized and performs correctly. Taken from ! PR optimize/3508. ! Written by Roger Sayle, 12/26/2001. */ ! extern void abort (void); ! extern void link_error (void); typedef __SIZE_TYPE__ size_t; ! extern int memcmp (const void *, const void *, size_t); ! int ! main (int argc) { ! if (memcmp ("abcd", "efgh", 4) >= 0) ! link_error (); ! if (memcmp ("abcd", "abcd", 4) != 0) ! link_error (); ! if (memcmp ("efgh", "abcd", 4) <= 0) ! link_error (); return 0; } --- 1,73 ---- ! /* Copyright (C) 2003 Free Software Foundation. ! Test sprintf optimizations don't break anything and return the ! correct results. ! Written by Roger Sayle, June 22, 2003. */ ! static char buffer[32]; + extern void abort (); typedef __SIZE_TYPE__ size_t; ! extern int sprintf(char*, const char*, ...); ! extern void *memset(void*, int, size_t); ! extern int memcmp(const void*, const void*, size_t); ! void test1() { ! sprintf(buffer,"foo"); ! } ! ! int test2() ! { ! return sprintf(buffer,"foo"); ! } ! ! void test3() ! { ! sprintf(buffer,"%s","bar"); ! } ! ! int test4() ! { ! return sprintf(buffer,"%s","bar"); ! } ! ! void test5(char *ptr) ! { ! sprintf(buffer,"%s",ptr); ! } ! ! ! int main() ! { ! memset (buffer, 'A', 32); ! test1 (); ! if (memcmp(buffer, "foo", 4) || buffer[4] != 'A') ! abort (); ! ! memset (buffer, 'A', 32); ! if (test2 () != 3) ! abort (); ! if (memcmp(buffer, "foo", 4) || buffer[4] != 'A') ! abort (); ! ! memset (buffer, 'A', 32); ! test3 (); ! if (memcmp(buffer, "bar", 4) || buffer[4] != 'A') ! abort (); ! ! memset (buffer, 'A', 32); ! if (test4 () != 3) ! abort (); ! if (memcmp(buffer, "bar", 4) || buffer[4] != 'A') ! abort (); ! ! memset (buffer, 'A', 32); ! test5 ("barf"); ! if (memcmp(buffer, "barf", 5) || buffer[5] != 'A') ! abort (); ! return 0; } *************** main (int argc) *** 28,43 **** /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ static int ! memcmp (const void *s1, const void *s2, size_t len) ! { ! abort (); ! } ! #else ! /* When not optimizing, the above tests may generate references to ! the function link_error, but should never actually call it. */ ! static void ! link_error () { abort (); } --- 75,83 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int ! sprintf (char *buf, const char *fmt, ...) { abort (); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-17.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-17.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-17.c 2002-04-23 10:16:48.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-17.c 2003-06-24 17:29:09.000000000 +0000 *************** *** 1,50 **** ! /* Copyright (C) 2002 Free Software Foundation. ! ! Ensure that builtin memset operations for constant length and ! non-constant assigned value don't cause compiler problems. ! Written by Roger Sayle, 21 April 2002. */ - extern void abort (void); typedef __SIZE_TYPE__ size_t; ! extern void *memset (void *, int, size_t); ! char buffer[32]; ! int ! main (int argc) { ! memset (buffer, argc, 0); ! memset (buffer, argc, 1); ! memset (buffer, argc, 2); ! memset (buffer, argc, 3); ! memset (buffer, argc, 4); ! memset (buffer, argc, 5); ! memset (buffer, argc, 6); ! memset (buffer, argc, 7); ! memset (buffer, argc, 8); ! memset (buffer, argc, 9); ! memset (buffer, argc, 10); ! memset (buffer, argc, 11); ! memset (buffer, argc, 12); ! memset (buffer, argc, 13); ! memset (buffer, argc, 14); ! memset (buffer, argc, 15); ! memset (buffer, argc, 16); ! memset (buffer, argc, 17); ! return 0; } ! #ifdef __OPTIMIZE__ ! /* When optimizing, most of the above cases should be transformed into ! something else. So any remaining calls to the original function ! for short lengths should abort. */ ! static void * ! memset (void *dst, int c, size_t len) { ! if (len < 2) abort (); } - #endif - --- 1,45 ---- ! /* Copyright (C) 2003 Free Software Foundation. ! Test strcpy optimizations don't evaluate side-effects twice. ! ! Written by Jakub Jelinek, June 23, 2003. */ typedef __SIZE_TYPE__ size_t; ! extern char *strcpy (char *, const char *); ! extern int memcmp (const void *, const void *, size_t); ! extern void abort (void); ! extern void exit (int); ! size_t ! test1 (char *s, size_t i) ! { ! strcpy (s, "foobarbaz" + i++); ! return i; ! } ! size_t ! check2 (void) { ! static size_t r = 5; ! if (r != 5) ! abort (); ! return ++r; ! } ! void ! test2 (char *s) ! { ! strcpy (s, "foobarbaz" + check2 ()); } ! int ! main (void) { ! char buf[10]; ! if (test1 (buf, 7) != 8 || memcmp (buf, "az", 3)) ! abort (); ! test2 (buf); ! if (memcmp (buf, "baz", 4)) abort (); + exit (0); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-18.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-18.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-18.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-18.c 2003-10-11 14:09:44.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test equal pointer optimizations don't break anything. + + Written by Roger Sayle, July 14, 2003. */ + + extern void abort (); + typedef __SIZE_TYPE__ size_t; + + extern void *memcpy(void*, const void*, size_t); + extern void *mempcpy(void*, const void*, size_t); + extern void *memmove(void*, const void*, size_t); + extern char *strcpy(char*, const char*); + extern int memcmp(const void*, const void*, size_t); + extern int strcmp(const char*, const char*); + extern int strncmp(const char*, const char*, size_t); + + + void test1 (void *ptr) + { + if (memcpy(ptr,ptr,8) != ptr) + abort (); + } + + void test2 (char *ptr) + { + if (mempcpy(ptr,ptr,8) != ptr+8) + abort (); + } + + void test3 (void *ptr) + { + if (memmove(ptr,ptr,8) != ptr) + abort (); + } + + void test4 (char *ptr) + { + if (strcpy(ptr,ptr) != ptr) + abort (); + } + + void test5 (void *ptr) + { + if (memcmp(ptr,ptr,8) != 0) + abort (); + } + + void test6 (const char *ptr) + { + if (strcmp(ptr,ptr) != 0) + abort (); + } + + void test7 (const char *ptr) + { + if (strncmp(ptr,ptr,8) != 0) + abort (); + } + + + int main () + { + char buf[10]; + + test1 (buf); + test2 (buf); + test3 (buf); + test4 (buf); + test5 (buf); + test6 (buf); + test7 (buf); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-1.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-1.c 2003-01-21 19:43:53.000000000 +0000 *************** int main() *** 37,42 **** --- 37,43 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static char * strstr(const char *s1, const char *s2) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-2.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-2.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-2.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-2.c 2003-01-21 19:43:53.000000000 +0000 *************** int main() *** 46,51 **** --- 46,52 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static char * strpbrk(const char *s1, const char *s2) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-3.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-3.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-3.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-3.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,124 **** - /* Copyright (C) 2000 Free Software Foundation. - - Ensure all expected transformations of builtin strlen, strcmp, - strrchr and rindex occur and perform correctly. - - Written by Jakub Jelinek, 11/7/2000. */ - - extern void abort (void); - extern __SIZE_TYPE__ strlen (const char *); - extern int strcmp (const char *, const char *); - extern char *strrchr (const char *, int); - extern char *rindex (const char *, int); - - int x = 6; - char *bar = "hi world"; - - int main() - { - const char *const foo = "hello world"; - - if (strlen (foo) != 11) - abort (); - if (strlen (foo + 4) != 7) - abort (); - if (strlen (foo + (x++ & 7)) != 5) - abort (); - if (x != 7) - abort (); - if (strcmp (foo, "hello") <= 0) - abort (); - if (strcmp (foo + 2, "llo") <= 0) - abort (); - if (strcmp (foo, foo) != 0) - abort (); - if (strcmp (foo, "hello world ") >= 0) - abort (); - if (strcmp (foo + 10, "dx") >= 0) - abort (); - if (strcmp (10 + foo, "dx") >= 0) - abort (); - if (strcmp (bar, "") <= 0) - abort (); - if (strcmp ("", bar) >= 0) - abort (); - if (strcmp (bar+8, "") != 0) - abort (); - if (strcmp ("", bar+8) != 0) - abort (); - if (strcmp (bar+(--x), "") <= 0 || x != 6) - abort (); - if (strcmp ("", bar+(++x)) >= 0 || x != 7) - abort (); - if (strrchr (foo, 'x')) - abort (); - if (strrchr (foo, 'o') != foo + 7) - abort (); - if (strrchr (foo, 'e') != foo + 1) - abort (); - if (strrchr (foo + 3, 'e')) - abort (); - if (strrchr (foo, '\0') != foo + 11) - abort (); - if (strrchr (bar, '\0') != bar + 8) - abort (); - if (strrchr (bar + 4, '\0') != bar + 8) - abort (); - if (strrchr (bar + (x++ & 3), '\0') != bar + 8) - abort (); - if (x != 8) - abort (); - /* Test only one instance of rindex since the code path is the same - as that of strrchr. */ - if (rindex ("hello", 'z') != 0) - abort (); - - /* Test at least one instance of the __builtin_ style. We do this - to ensure that it works and that the prototype is correct. */ - if (__builtin_rindex (foo, 'o') != foo + 7) - abort (); - if (__builtin_strrchr (foo, 'o') != foo + 7) - abort (); - if (__builtin_strlen (foo) != 11) - abort (); - if (__builtin_strcmp (foo, "hello") <= 0) - abort (); - - return 0; - } - - static char * - rindex (const char *s, int c) - { - /* For systems which don't have rindex, we ensure no link failures - occur by always providing a backup definition. During - optimization this function aborts to catch errors. */ - #ifdef __OPTIMIZE__ - abort (); - #else - return strrchr(s, c); - #endif - } - - #ifdef __OPTIMIZE__ - /* When optimizing, all the above cases should be transformed into - something else. So any remaining calls to the original function - should abort. */ - static __SIZE_TYPE__ - strlen (const char *s) - { - abort (); - } - - static int - strcmp (const char *s1, const char *s2) - { - abort (); - } - - static char * - strrchr (const char *s, int c) - { - abort (); - } - #endif --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-4.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-4.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-4.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-4.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,61 **** - /* Copyright (C) 2000 Free Software Foundation. - - Ensure all expected transformations of builtin strchr and index - occur and perform correctly. - - Written by Jakub Jelinek, 11/7/2000. */ - - extern void abort (void); - extern char *strchr (const char *, int); - extern char *index (const char *, int); - - int main() - { - const char *const foo = "hello world"; - - if (strchr (foo, 'x')) - abort (); - if (strchr (foo, 'o') != foo + 4) - abort (); - if (strchr (foo + 5, 'o') != foo + 7) - abort (); - if (strchr (foo, '\0') != foo + 11) - abort (); - /* Test only one instance of index since the code path is the same - as that of strchr. */ - if (index ("hello", 'z') != 0) - abort (); - - /* Test at least one instance of the __builtin_ style. We do this - to ensure that it works and that the prototype is correct. */ - if (__builtin_strchr (foo, 'o') != foo + 4) - abort (); - if (__builtin_index (foo, 'o') != foo + 4) - abort (); - - return 0; - } - - static char * - index (const char *s, int c) - { - /* For systems which don't have index, we ensure no link failures - occur by always providing a backup definition. During - optimization this function aborts to catch errors. */ - #ifdef __OPTIMIZE__ - abort (); - #else - return strchr(s, c); - #endif - } - - #ifdef __OPTIMIZE__ - /* When optimizing, all the above cases should be transformed into - something else. So any remaining calls to the original function - should abort. */ - static char * - strchr (const char *s, int c) - { - abort (); - } - #endif --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-6.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-6.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-6.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-6.c 2003-01-21 19:43:53.000000000 +0000 *************** int main() *** 45,50 **** --- 45,51 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static char * strcpy (char *d, const char *s) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-7.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-7.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-7.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-7.c 2003-06-28 12:19:27.000000000 +0000 *************** extern int strcmp (const char *, const c *** 12,17 **** --- 12,19 ---- extern int strncmp (const char *, const char *, size_t); extern void *memset (void *, int, size_t); + int i; + int main () { const char *const src = "hello world"; *************** int main () *** 62,67 **** --- 64,75 ---- if (__builtin_strncpy (dst, src, 4) != dst || strncmp (dst, src, 4)) abort(); + memset (dst, 0, sizeof (dst)); + if (strncpy (dst, i++ ? "xfoo" + 1 : "bar", 4) != dst + || strcmp (dst, "bar") + || i != 1) + abort (); + return 0; } *************** int main () *** 69,74 **** --- 77,83 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static char * strncpy(char *s1, const char *s2, size_t n) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-8.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-8.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-8.c 2002-06-27 18:23:33.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-8.c 2003-10-11 21:11:29.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000, 2001 Free Software Foundation. Ensure all expected transformations of builtin strncmp occur and perform correctly. --- 1,4 ---- ! /* Copyright (C) 2000, 2001, 2003 Free Software Foundation. Ensure all expected transformations of builtin strncmp occur and perform correctly. *************** int main () *** 65,72 **** s2 = s1; s3 = s1+4; if (strncmp (++s2, ++s3+2, 1) >= 0 || s2 != s1+1 || s3 != s1+5) abort(); ! #if defined(__i386__) || defined (__pj__) || defined (__i370__) ! /* These tests work on platforms which support cmpstrsi. */ s2 = s1; if (strncmp (++s2, "ello", 3) != 0 || s2 != s1+1) abort(); --- 65,73 ---- s2 = s1; s3 = s1+4; if (strncmp (++s2, ++s3+2, 1) >= 0 || s2 != s1+1 || s3 != s1+5) abort(); ! #if !defined(__OPTIMIZE__) || (defined(__i386__) && !defined(__OPTIMIZE_SIZE__)) ! /* These tests work on platforms which support cmpstrsi. We test it ! at -O0 on all platforms to ensure the strncmp logic is correct. */ s2 = s1; if (strncmp (++s2, "ello", 3) != 0 || s2 != s1+1) abort(); *************** int main () *** 231,236 **** --- 232,238 ---- /* When optimizing, all the above cases should be transformed into something else. So any remaining calls to the original function should abort. */ + __attribute__ ((noinline)) static int strncmp(const char *s1, const char *s2, size_t n) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-9.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-9.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/string-opt-9.c 2000-12-27 15:29:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/string-opt-9.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,54 **** - /* Copyright (C) 2000 Free Software Foundation. - - Ensure all expected transformations of builtin strcat occur and - perform correctly. - - Written by Kaveh R. Ghazi, 11/27/2000. */ - - extern void abort (void); - typedef __SIZE_TYPE__ size_t; - extern char *strcat (char *, const char *); - extern char *strcpy (char *, const char *); - extern char *strcmp (const char *, const char *); - - int main () - { - const char *const s1 = "hello world"; - const char *const s2 = ""; - char dst[64], *d2; - - strcpy (dst, s1); - if (strcat (dst, "") != dst || strcmp (dst, s1)) - abort(); - strcpy (dst, s1); - if (strcat (dst, s2) != dst || strcmp (dst, s1)) - abort(); - strcpy (dst, s1); d2 = dst; - if (strcat (++d2, s2) != dst+1 || d2 != dst+1 || strcmp (dst, s1)) - abort(); - strcpy (dst, s1); d2 = dst; - if (strcat (++d2+5, s2) != dst+6 || d2 != dst+1 || strcmp (dst, s1)) - abort(); - strcpy (dst, s1); d2 = dst; - if (strcat (++d2+5, s1+11) != dst+6 || d2 != dst+1 || strcmp (dst, s1)) - abort(); - - /* Test at least one instance of the __builtin_ style. We do this - to ensure that it works and that the prototype is correct. */ - strcpy (dst, s1); - if (__builtin_strcat (dst, "") != dst || strcmp (dst, s1)) - abort(); - - return 0; - } - - #ifdef __OPTIMIZE__ - /* When optimizing, all the above cases should be transformed into - something else. So any remaining calls to the original function - should abort. */ - static char * - strcat (char *s1, const char *s2) - { - abort(); - } - #endif --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/switch-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/switch-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/switch-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/switch-1.c 2003-01-25 17:30:29.000000000 +0000 *************** *** 0 **** --- 1,57 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test that switch statements suitable using case bit tests are + implemented correctly. + + Written by Roger Sayle, 01/25/2001. */ + + extern void abort (void); + + int + foo (int x) + { + switch (x) + { + case 4: + case 6: + case 9: + case 11: + return 30; + } + return 31; + } + + int + main (int argc) + { + int i, r; + + for (i=-1; i<66; i++) + { + r = foo (i); + if (i == 4) + { + if (r != 30) + abort (); + } + else if (i == 6) + { + if (r != 30) + abort (); + } + else if (i == 9) + { + if (r != 30) + abort (); + } + else if (i == 11) + { + if (r != 30) + abort (); + } + else if (r != 31) + abort (); + } + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/va-arg-25.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/va-arg-25.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/va-arg-25.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/va-arg-25.c 2003-11-02 13:09:37.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + /* Varargs and vectors! */ + + #include + #include + + #define vector __attribute__((vector_size(16))) + + const vector unsigned int v1 = {10,11,12,13}; + const vector unsigned int v2 = {20,21,22,23}; + + void foo(int a, ...) + { + va_list args; + vector unsigned int v; + + va_start (args, a); + v = va_arg (args, vector unsigned int); + if (a != 1 || memcmp (&v, &v1, sizeof (v)) != 0) + abort (); + a = va_arg (args, int); + if (a != 2) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v2, sizeof (v)) != 0) + abort (); + va_end (args); + } + + int main(void) + { + #if INT_MAX == 2147483647 + foo (1, (vector unsigned int){10,11,12,13}, 2, + (vector unsigned int){20,21,22,23}); + #endif + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/va-arg-25.x gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/va-arg-25.x *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/va-arg-25.x 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/va-arg-25.x 2004-02-08 17:05:53.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + # This doesn't work on SPARC 64-bit. + + if { [istarget "sparc64-*-*"] || [istarget "sparcv9-*-*"] } { + set torture_eval_before_compile { + global compiler_conditional_xfail_data + set compiler_conditional_xfail_data { + "PR target/12916" \ + { "*-*-*" } \ + { "*" } \ + { "-m32" } + } + } + } elseif { [istarget "sparc-*-*"] } { + set torture_eval_before_compile { + global compiler_conditional_xfail_data + set compiler_conditional_xfail_data { + "PR target/12916" \ + { "*-*-*" } \ + { "-m64" } \ + { "" } + } + } + } + + return 0 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/wchar_t-1.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/wchar_t-1.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/execute/wchar_t-1.c 2002-03-12 22:36:55.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/execute/wchar_t-1.c 2004-02-02 23:02:03.000000000 +0000 *************** *** 1,6 **** typedef __WCHAR_TYPE__ wchar_t; ! wchar_t x[] = L"Ä"; ! wchar_t y = L'Ä'; extern void abort (void); extern void exit (int); --- 1,7 ---- + /* { dg-options "-finput-charset=utf-8" } */ typedef __WCHAR_TYPE__ wchar_t; ! wchar_t x[] = L"Ä"; ! wchar_t y = L'Ä'; extern void abort (void); extern void exit (int); *************** int main (void) *** 8,16 **** { if (sizeof (x) / sizeof (wchar_t) != 2) abort (); ! if (x[0] != L'Ä' || x[1] != L'\0') abort (); ! if (y != L'Ä') abort (); exit (0); } --- 9,17 ---- { if (sizeof (x) / sizeof (wchar_t) != 2) abort (); ! if (x[0] != L'Ä' || x[1] != L'\0') abort (); ! if (y != L'Ä') abort (); exit (0); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.c-torture/unsorted/ext.c gcc-3.4.0/gcc/testsuite/gcc.c-torture/unsorted/ext.c *** gcc-3.3.3/gcc/testsuite/gcc.c-torture/unsorted/ext.c 1998-12-16 22:20:10.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.c-torture/unsorted/ext.c 2003-12-22 03:32:35.000000000 +0000 *************** *** 1,3 **** --- 1,12 ---- + /* The bit-field below would have a problem if __INT_MAX__ is too + small. */ + #if __INT_MAX__ < 2147483647 + int + main (void) + { + exit (0); + } + #else struct foo { unsigned b31 : 1; *************** foo(a) *** 11,13 **** --- 20,23 ---- { return a.b30; } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20000724-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20000724-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20000724-1.c 2001-04-30 23:28:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20000724-1.c 2004-02-26 14:31:54.000000000 +0000 *************** int baz(void *x) *** 22,28 **** void do_check (struct s *) asm ("do_check") __attribute__((regparm(1))); ! void do_check(struct s *x) { if (x->a.a || x->b || x->c.a.a) abort(); --- 22,28 ---- void do_check (struct s *) asm ("do_check") __attribute__((regparm(1))); ! void __attribute__((regparm(1))) do_check(struct s *x) { if (x->a.a || x->b || x->c.a.a) abort(); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20001013-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20001013-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20001013-1.c 2002-03-25 22:33:43.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20001013-1.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 1,7 **** ! /* ??? It'd be nice to run this for sparc32 as well, if we could know ! for sure that we're on an ultrasparc, rather than an older cpu. */ ! /* { dg-do run { target sparcv9-*-* sparc64-*-* } } */ ! /* { dg-options "-O2 -m32 -mcpu=ultrasparc -mvis" } */ int l; --- 1,5 ---- ! /* { dg-do run { target sparc*-*-* } } */ ! /* { dg-options "-O2 -mcpu=ultrasparc -mvis" } */ int l; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20001101-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20001101-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20001101-1.c 2002-03-27 01:23:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20001101-1.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 1,7 **** ! /* ??? It'd be nice to run this for sparc32 as well, if we could know ! for sure that we're on an ultrasparc, rather than an older cpu. */ ! /* { dg-do run { target sparcv9-*-* sparc64-*-* } } */ ! /* { dg-options "-O2 -m32 -mcpu=ultrasparc -mvis" } */ int foo(double a, int b, int c, double *d, int h) { --- 1,5 ---- ! /* { dg-do run { target sparc*-*-* } } */ ! /* { dg-options "-O2 -mcpu=ultrasparc -mvis" } */ int foo(double a, int b, int c, double *d, int h) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20001102-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20001102-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20001102-1.c 2002-03-27 01:23:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20001102-1.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 1,7 **** ! /* ??? It'd be nice to run this for sparc32 as well, if we could know ! for sure that we're on an ultrasparc, rather than an older cpu. */ ! /* { dg-do run { target sparcv9-*-* sparc64-*-* } } */ ! /* { dg-options "-O2 -m32 -mcpu=ultrasparc -mvis" } */ int foo(double a, int b, int c, double *d, int h) { --- 1,5 ---- ! /* { dg-do run { target sparc*-*-* } } */ ! /* { dg-options "-O2 -mcpu=ultrasparc -mvis" } */ int foo(double a, int b, int c, double *d, int h) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20011107-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20011107-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20011107-1.c 2002-01-09 21:34:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20011107-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 1,5 **** /* { dg-do compile { target i?86-*-* } } */ ! /* { dg-options "-O2 -mcpu=k6" } */ void foo (unsigned char *x, const unsigned char *y) --- 1,5 ---- /* { dg-do compile { target i?86-*-* } } */ ! /* { dg-options "-O2 -mtune=k6" } */ void foo (unsigned char *x, const unsigned char *y) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020108-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020108-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020108-1.c 2002-01-08 20:10:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020108-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 5,11 **** is not valid general_operand in HImode. */ /* { dg-do compile } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mcpu=i686" { target i?86-*-* } } */ void foo (unsigned short *cp) --- 5,11 ---- is not valid general_operand in HImode. */ /* { dg-do compile } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mtune=i686" { target i?86-*-* } } */ void foo (unsigned short *cp) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020122-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020122-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020122-3.c 2002-01-23 18:54:27.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020122-3.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 4,10 **** /* { dg-do compile } */ /* { dg-options "-Os -fprefetch-loop-arrays -w" } */ ! /* { dg-options "-Os -fprefetch-loop-arrays -mcpu=pentium3 -w" { target i?86-*-* } } */ int foo (int *p, int n) { --- 4,10 ---- /* { dg-do compile } */ /* { dg-options "-Os -fprefetch-loop-arrays -w" } */ ! /* { dg-options "-Os -fprefetch-loop-arrays -mtune=pentium3 -w" { target i?86-*-* } } */ int foo (int *p, int n) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020201-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020201-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020201-2.c 2002-02-02 00:16:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020201-2.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,30 **** - /* This testcase caused ICE because gcc was not able to add instructions - on edge from ENTRY block successor to itself. */ - /* { dg-do compile } */ - /* { dg-options "-O3 -fssa" } */ - - struct A { int a1; int a2; }; - struct B { long int b[32]; }; - - extern int bar (struct B *, struct A *); - - int - foo (struct B x) - { - struct A a, b; - struct B c; - int d; - - while (1) - { - a.a1 = 0; - a.a2 = 0; - b = a; - c = x; - d = bar (&c, &b); - if (d >= 0) - return d; - } - - return 0; - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020201-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020201-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020201-4.c 2002-02-04 09:40:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020201-4.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,16 **** - /* This testcase failed because recog_for_combine used to pass a different - pattern than contained in insn to recog. */ - /* { dg-do compile } */ - /* { dg-options "-O2 -fssa -fssa-ccp" } */ - /* { dg-options "-O2 -march=i686 -fssa -fssa-ccp" { target i?86-*-* } } */ - - extern int bar (char *); - - int - foo (void) - { - char b[512]; - - bar (b); - return __builtin_strlen (b); - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020206-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020206-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020206-1.c 2002-02-06 22:16:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020206-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 4,10 **** /* { dg-do run } */ /* { dg-options "-O2 -fprefetch-loop-arrays -w" } */ ! /* { dg-options "-O2 -fprefetch-loop-arrays -mcpu=pentium3 -w" { target i?86-*-* } } */ struct reload { --- 4,10 ---- /* { dg-do run } */ /* { dg-options "-O2 -fprefetch-loop-arrays -w" } */ ! /* { dg-options "-O2 -fprefetch-loop-arrays -mtune=pentium3 -w" { target i?86-*-* } } */ struct reload { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020304-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020304-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020304-1.c 2002-03-05 11:01:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020304-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,37 **** - /* { dg-do compile } */ - /* { dg-options "-O -fssa -fssa-ccp" } */ - - double a[10][35], b[10][8]; - int c, c, d, e, f, g, h; - - int foo () - { - int i, j, k, l; - - if (c > 10) - c = 10; - - for (j = 0; j < c; j++) - { - k = 0; - for (l = 0; l < h; l++) - { - if (d != 5) - return -1; - k = l * g; - a[j][k] = (double) e; k++; - a[j][k] = (double) f; k++; - } - for (i = 0;i < 35; i++) - { - if (a[j][i] >= 0.9) - a[j][i] = 0.9; - if (a[j][i] <= 0.1) - a[j][i] = 0.1; - } - k = 0; - b[j][k] = (double) e; k++; - b[j][k] = (double) f; k++; - } - return 0; - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020310-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020310-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020310-1.c 2002-03-11 10:12:03.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020310-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 2,8 **** This testcase was miscompiled because of an rtx sharing bug. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mcpu=i586" { target i?86-*-* } } */ struct A { --- 2,8 ---- This testcase was miscompiled because of an rtx sharing bug. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mtune=i586" { target i?86-*-* } } */ struct A { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020312-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020312-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020312-2.c 2002-09-19 23:01:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020312-2.c 2003-12-30 17:25:49.000000000 +0000 *************** *** 8,16 **** /* { dg-do run } */ /* { dg-options "-O -fno-pic" } */ ! #if #cpu(a29k) ! /* No pic register. */ ! #elif defined(__alpha__) /* PIC register is $29, but is used even without -fpic. */ #elif defined(__arc__) # define PIC_REG "26" --- 8,14 ---- /* { dg-do run } */ /* { dg-options "-O -fno-pic" } */ ! #if defined(__alpha__) /* PIC register is $29, but is used even without -fpic. */ #elif defined(__arc__) # define PIC_REG "26" *************** *** 18,35 **** # define PIC_REG "9" #elif defined(AVR) /* No pic register. */ - #elif defined(__clipper__) - /* No pic register. */ - #elif defined(__convex__) - /* No pic register. */ #elif defined(__cris__) # define PIC_REG "0" #elif defined(__D30V__) /* No pic register. */ #elif defined(__dsp1600__) /* No pic register. */ - #elif defined(__elxsi__) - /* No pic register. */ #elif defined(__fr30__) /* No pic register. */ #elif defined(__H8300__) || defined(__H8300H__) || defined(__H8300S__) --- 16,27 ---- *************** *** 40,47 **** /* No pic register. */ #elif defined(__i386__) # define PIC_REG "ebx" - #elif defined(__i860__) - /* No pic register. */ #elif defined(__i960__) /* No pic register. */ #elif defined(__ia64__) --- 32,37 ---- *************** *** 50,57 **** /* No pic register. */ #elif defined(__m68k__) # define PIC_REG "a5" - #elif defined(__m88k__) - # define PIC_REG "25" #elif defined(__mc68hc1x__) /* No pic register. */ #elif defined(__mcore__) --- 40,45 ---- *************** *** 60,67 **** /* PIC register is $28, but is used even without -fpic. */ #elif defined(__MMIX__) /* No pic register. */ - #elif defined(__mn10200__) - /* No pic register. */ #elif defined(__mn10300__) /* No pic register. */ #elif #cpu(ns32k) --- 48,53 ---- *************** *** 70,85 **** /* PIC register is %r27 or %r19, but is used even without -fpic. */ #elif defined(__pdp11__) /* No pic register. */ - #elif defined(__pj__) - /* No pic register. */ #elif defined(__powerpc__) || defined(__PPC__) || defined(__POWERPC__) # ifdef __MACH__ # define PIC_REG "31" # else # define PIC_REG "30" # endif - #elif defined(__ibm032__) /* aka romp */ - /* No pic register. */ #elif defined(__s390__) # define PIC_REG "12" #elif defined(__sparc__) --- 56,67 ---- *************** *** 88,95 **** /* No pic register. */ #elif defined(__vax__) /* No pic register. */ - #elif defined(__we32000__) - /* No pic register. */ #elif defined(__xstormy16__) /* No pic register. */ #elif defined(__XTENSA__) --- 70,75 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020426-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020426-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020426-2.c 2002-04-28 19:48:10.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020426-2.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 2,8 **** Distilled from zlib sources. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -frename-registers -fomit-frame-pointer -fPIC -mcpu=i686" { target i?86-*-* } } */ typedef struct { --- 2,8 ---- Distilled from zlib sources. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -frename-registers -fomit-frame-pointer -fPIC -mtune=i686" { target i?86-*-* } } */ typedef struct { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020517-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020517-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020517-1.c 2002-05-22 21:35:56.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020517-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 2,8 **** was not sign-extended for QImode. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mcpu=i686" { target i?86-*-* } } */ #include --- 2,8 ---- was not sign-extended for QImode. */ /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mtune=i686" { target i?86-*-* } } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020523-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020523-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020523-2.c 2002-10-17 17:13:41.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020523-2.c 2004-01-09 01:01:50.000000000 +0000 *************** *** 4,9 **** --- 4,10 ---- /* { dg-do run { target i386-*-* } } */ /* { dg-options "-march=pentium3 -msse -ffast-math -O2" } */ + #include "i386-cpuid.h" extern void abort (void); extern void exit (int); *************** typedef struct *** 27,50 **** void bail_if_no_sse (void) { ! int fl1, fl2; ! ! /* See if we can use cpuid. */ ! __asm__ ("pushfl; pushfl; popl %0; movl %0,%1; xorl %2,%0;" ! "pushl %0; popfl; pushfl; popl %0; popfl" ! : "=&r" (fl1), "=&r" (fl2) ! : "i" (0x00200000)); ! if (((fl1 ^ fl2) & 0x00200000) == 0) ! exit (0); ! ! /* See if cpuid gives capabilities. */ ! __asm__ ("cpuid" : "=a" (fl1) : "0" (0) : "ebx", "ecx", "edx", "cc"); ! if (fl1 == 0) ! exit (0); ! /* See if capabilities include SSE (25th bit; 26 for SSE2). */ ! __asm__ ("cpuid" : "=a" (fl1), "=d" (fl2) : "0" (1) : "ebx", "ecx", "cc"); ! if ((fl2 & (1 << 25)) == 0) exit (0); } --- 28,37 ---- void bail_if_no_sse (void) { ! unsigned int edx; /* See if capabilities include SSE (25th bit; 26 for SSE2). */ ! edx = i386_cpuid(); ! if (!(edx & bit_SSE)) exit (0); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020525-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020525-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020525-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020525-1.c 2003-06-03 23:08:22.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + /* PR optimization/6703 + Origin: Glen Nakamura */ + /* { dg-do run } */ + /* { dg-options "-O2" } */ + + extern void abort (void); + extern void exit (int); + + void foo (int *x, int y) + { + __builtin_memset (x, 0, y); + } + + int main () + { + int x[2] = { -1, -1 }; + + if (x[1] != -1) + abort (); + foo (x, sizeof (int) + 1); + if (x[1] == -1) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20020729-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20020729-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20020729-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20020729-1.c 2003-05-16 19:35:43.000000000 +0000 *************** *** 0 **** --- 1,51 ---- + /* { dg-do compile { target i?86-*-* } } */ + /* { dg-options "-O2 -march=k6" } */ + + static inline void * + baz (void *s, unsigned long c, unsigned int count) + { + int d0, d1; + __asm__ __volatile__ ("" + : "=&c" (d0), "=&D" (d1) + :"a" (c), "q" (count), "0" (count / 4), "1" ((long) s) + :"memory"); + return s; + } + + struct A + { + unsigned long *a; + }; + + inline static void * + bar (struct A *x, int y) + { + char *ptr; + + ptr = (void *) x->a[y >> 12]; + ptr += y % (1UL << 12); + return (void *) ptr; + } + + int + foo (struct A *x, unsigned int *y, int z, int u) + { + int a, b, c, d, e; + + z += *y; + c = z + u; + a = (z >> 12) + 1; + do + { + b = (a << 12); + d = b - z; + e = c - z; + if (e < d) + d = e; + baz (bar (x, z), 0, d); + z = b; + a++; + } + while (z < c); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20021014-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20021014-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20021014-1.c 2002-10-28 18:10:56.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20021014-1.c 2004-02-21 03:00:47.000000000 +0000 *************** *** 1,14 **** /* { dg-do run } */ /* { dg-options "-O2 -p" } */ ! /* { dg-error "profiler" "No profiler support" { target mmix-*-* } 0 } */ ! /* Support for -p on solaris2 relies on mcrt1.o which comes with the ! vendor compiler. We cannot reiably predict the directory where the ! vendor compiler (and thus mcrt1.o) is installed so we can't ! necessarily find mcrt1.o even if we have it. */ ! /* { dg-error "mcrt1.o" "Optional vendor profiler support missing" { target *-*-solaris2* } 0 } */ ! /* Support for -p on irix relies on libprof1.a which doesn't appear to ! exist on any irix6 system currently posting testsuite results. */ ! /* { dg-error "libprof1.a" "Profiler support missing" { target mips*-*-irix* } 0 } */ extern void abort (void); extern void exit (int); --- 1,9 ---- /* { dg-do run } */ + /* { dg-require-profiling "-p" } */ /* { dg-options "-O2 -p" } */ ! /* { dg-options "-O2 -p -static" { target hppa*-*-hpux* } } */ ! /* { dg-error "profiler" "No profiler support" { target xstormy16-*-* } 0 } */ ! /* { dg-error "" "consider using `-pg' instead of `-p' with gprof(1)" { target *-*-freebsd* } 0 } */ extern void abort (void); extern void exit (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20021018-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20021018-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20021018-1.c 2002-10-21 20:27:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20021018-1.c 2003-07-11 03:28:56.000000000 +0000 *************** *** 4,9 **** --- 4,10 ---- extern void abort (void); extern void exit (int); + #if __INT_MAX__ >= 2147483647L static const long foo [10] = { 0, 1, 2, 3, 4, 5, 6, 7, 8, 9 }; long __attribute__((noinline)) *************** main (void) *** 19,21 **** --- 20,29 ---- abort (); exit (0); } + #else + int + main (void) + { + exit (0); + } + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030107-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030107-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030107-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030107-1.c 2003-01-07 20:14:51.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + /* { dg-do compile } */ + /* { dg-options "-fprofile-arcs" } */ + + extern void bar(void) __attribute__((noreturn)); + int foo (void) { bar(); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030121-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030121-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030121-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030121-1.c 2004-01-22 02:47:14.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile { target powerpc*-*-darwin* } } */ + /* { dg-options "-O2 -force_cpusubtype_ALL -mpowerpc64" } */ + + long long (*y)(int t); + long long get_alias_set (int t) + { + return y(t); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030123-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030123-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030123-1.c 2003-01-25 23:59:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030123-1.c 2004-01-22 00:06:57.000000000 +0000 *************** *** 1,7 **** /* This used to ICE due to a reload bug on s390*. */ /* { dg-do compile { target s390*-*-* } } */ ! /* { dg-options "-O2" } */ void func (char *p); --- 1,7 ---- /* This used to ICE due to a reload bug on s390*. */ /* { dg-do compile { target s390*-*-* } } */ ! /* { dg-options "-O2 -fno-omit-frame-pointer" } */ void func (char *p); *************** void test (void) *** 10,16 **** char *p = alloca (4096); long idx; ! asm ("" : "=r" (idx) : : "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "11", "12"); func (p + idx + 1); } --- 10,16 ---- char *p = alloca (4096); long idx; ! asm ("" : "=r" (idx) : : "1", "2", "3", "4", "5", "6", "7", "8", "9", "10", "12"); func (p + idx + 1); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030204-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030204-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030204-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030204-1.c 2003-02-05 11:29:15.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* PR optimization/8555 */ + /* { dg-do compile } */ + /* { dg-options "-O -ffast-math -funroll-loops" } */ + /* { dg-options "-march=pentium3 -O -ffast-math -funroll-loops" { target i?86-*-* } } */ + + float foo (float *a, int i) + { + int j; + float x = a[j = i - 1], y; + + for (j = i; --j >= 0; ) + if ((y = a[j]) > x) + x = y; + + return x; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030217-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030217-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030217-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030217-1.c 2003-05-16 19:35:43.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* Test whether denormal floating point constants in hexadecimal notation + are parsed correctly. */ + /* { dg-do run { target i?86-*-linux* x86_64-*-* } } */ + /* { dg-options "-std=c99" } */ + + long double d = 0x0.0000003ffffffff00000p-16357L; + long double e = 0x0.0000003ffffffff00000p-16356L; + + extern void abort (void); + extern void exit (int); + + int + main (void) + { + if (d != e / 2.0) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030218-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030218-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030218-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030218-1.c 2003-02-25 17:06:40.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* { dg-do compile { target powerpc-*-eabi* } } */ + /* { dg-options "-mcpu=8540" } */ + + /* Test vectors that can interconvert without a cast. */ + + typedef int __attribute__((mode(V2SI))) __ev64_opaque__; + + __ev64_opaque__ opp; + int vint __attribute__((mode(V2SI))); + int vshort __attribute__((mode(V4HI))); + int vfloat __attribute__((mode(V2SF))); + + int + main (void) + { + __ev64_opaque__ george = { 1, 2 }; /* { dg-error "opaque vector types cannot be initialized" } */ + + opp = vfloat; + vshort = opp; + vfloat = vshort; /* { dg-error "incompatible types in assignment" } */ + + /* Just because this is a V2SI, it doesn't make it an opaque. */ + vint = vshort; /* { dg-error "incompatible types in assignment" } */ + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030225-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030225-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030225-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030225-2.c 2003-05-19 12:15:33.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + /* { dg-do run { target ia64-*-linux* } } */ + /* { dg-options "-O3" } */ + + int __attribute__((noinline, const)) + ret4 (float value) + { + return 4; + } + + int __attribute__((noinline, const)) + ret0 (float value) + { + return 0; + } + + float __attribute__((noinline)) + test (float x, float y) + { + int clsx = ret4 (x); + int clsy = ret0 (y); + + if (clsx == 0 || clsy == 0 + || (y < 0 && clsx == 1 && clsy == 1)) + return x - y; + + return x < y ? 0 : x - y; + } + + float a = 0.0, b; + + int main (void) + { + unsigned long e; + b = a / a; + __asm__ __volatile__ ("mov.m %0=ar.fpsr" : "=r" (e)); + e &= ~0x7e000UL; + __asm__ __volatile__ ("mov.m ar.fpsr=%0" :: "r" (e) : "memory"); + a = test (0, b); + __asm__ __volatile__ ("mov.m %0=ar.fpsr" : "=r" (e)); + if (e & 0x2000) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030405-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030405-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030405-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030405-1.c 2003-05-16 19:35:43.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* { dg-do compile { target ia64-*-* } } */ + /* { dg-options "-O2" } */ + + int + foo (int x, int y) + { + if (y == 0) + { + register long r8 asm ("r8"); + register long r15 asm ("r15") = 1; + long retval; + __asm __volatile ("foo" : "=r" (r8), "=r" (r15) : "1" (r15)); + retval = r8; + y = retval; + } + + { + register long r8 asm ("r8"); + register long r15 asm ("r15") = 2; + long retval; + register long _out1 asm ("out1") = x; + register long _out0 asm ("out0") = y; + __asm __volatile ("foo" + : "=r" (r8), "=r" (r15) , "=r" (_out0), "=r" (_out1) + : "1" (r15) , "2" (_out0), "3" (_out1)); + retval = r8; + return retval; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030414-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030414-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030414-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030414-2.c 2003-04-14 20:16:58.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding (c1 - x) op c2 into x swap(op) c1-c2 + doesn't break anything. + + Written by Roger Sayle, 27th March 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void abort (void); + + int foo(double x) + { + return (10.0 - x) > 3.0; + } + + int bar (double x) + { + return (10.0 - x) == 5.0; + } + + int main() + { + if (foo (8.0)) + abort (); + + if (! foo (6.0)) + abort (); + + if (bar (1.0)) + abort (); + + if (! bar (5.0)) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030505.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030505.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030505.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030505.c 2003-07-28 15:00:50.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* { dg-do compile { target powerpc-*-eabispe* } } */ + /* { dg-options "-W" } */ + + #define __vector __attribute__((vector_size(8))) + + typedef float __vector __ev64_fs__; + + __ev64_opaque__ *p1; + __ev64_fs__ *p2; + int *x; + + extern void f (__ev64_opaque__ *); + + int main () + { + f (x); /* { dg-warning "incompatible pointer type" } */ + f (p1); + f (p2); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030612-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030612-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030612-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030612-1.c 2003-06-12 20:33:02.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* Derived from PR middle-end/168. */ + + /* { dg-do compile } */ + /* { dg-options "-W" } */ + + extern void foo (); + + unsigned char uc; + unsigned short int usi; + unsigned int ui; + + + void bar() + { + if (uc + usi >= ui) /* { dg-bogus "between signed and unsigned" } */ + foo (); + if (uc * usi >= ui) /* { dg-bogus "between signed and unsigned" } */ + foo (); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030626-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030626-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030626-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030626-1.c 2003-06-26 11:40:58.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR optimization/11210 */ + /* Originator: Guido Classen */ + /* Reduced testcase by Falk Hueffner */ + /* { dg-do compile } */ + /* { dg-options "-O" } */ + + /* Verify that the constant expressions folder doesn't + throw away the cast operation in the comparison. */ + + struct str { + int head; + signed char data[8]; + }; + + int foo(struct str t) + { + return t.data[0] || (unsigned char) t.data[2] != 130; /* { dg-bogus "comparison is always 1" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030707-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030707-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030707-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030707-1.c 2003-07-08 00:28:47.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Derived from PR target/10979. */ + /* This testcase used to ICE on x86. */ + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + void t(double); + double atan2(double,double); + + void temp(double *c) + { + double c2 = 8; + double s2 = 0; + *c = atan2(s2,c2); + t(1/s2); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030711-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030711-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030711-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030711-1.c 2003-07-11 21:04:56.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + /* Test whether strncmp has not been "optimized" into memcmp + nor any code with memcmp semantics. */ + /* { dg-do run { target i?86-*-linux* x86_64-*-linux* ia64-*-linux* alpha*-*-linux* powerpc*-*-linux* s390*-*-linux* sparc*-*-linux* } } */ + /* { dg-options "-O2" } */ + #include + #include + + void __attribute__((noinline)) test (const char *p) + { + if (__builtin_strncmp (p, "abcdefghijklmnopq", 17) == 0) + abort (); + } + + int main (void) + { + char *p = mmap (NULL, 131072, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANONYMOUS, -1, 0); + if (p == MAP_FAILED) + return 0; + if (munmap (p + 65536, 65536) < 0) + return 0; + __builtin_memcpy (p + 65536 - 5, "abcd", 5); + test (p + 65536 - 5); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030804-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030804-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030804-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030804-1.c 2003-08-04 23:42:48.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of mathematical expressions doesn't + break anything. + + Written by Roger Sayle, 3rd August 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + void test(double x) + { + if (x+x != 2.0*x) + link_error (); + if (x+x != x*2.0) + link_error (); + + if (x+x+x != 3.0*x) + link_error (); + if (x+x+x != x*3.0) + link_error (); + + if ((x+x)+x != 3.0*x) + link_error (); + if ((x+x)+x != x*3.0) + link_error (); + + if (x+(x+x) != 3.0*x) + link_error (); + if (x+(x+x) != x*3.0) + link_error (); + + if (x+4.0*x != 5.0*x) + link_error (); + if (x+4.0*x != x*5.0) + link_error (); + if (x+x*4.0 != 5.0*x) + link_error (); + if (x+x*4.0 != x*5.0) + link_error (); + if (4.0*x+x != 5.0*x) + link_error (); + if (4.0*x+x != x*5.0) + link_error (); + if (x*4.0+x != 5.0*x) + link_error (); + if (x*4.0+x != x*5.0) + link_error (); + + if (3.0*x + 5.0*x != 8.0*x) + link_error (); + if (3.0*x + 5.0*x != x*8.0) + link_error (); + if (x*3.0 + 5.0*x != 8.0*x) + link_error (); + if (x*3.0 + 5.0*x != x*8.0) + link_error (); + if (3.0*x + x*5.0 != 8.0*x) + link_error (); + if (3.0*x + x*5.0 != x*8.0) + link_error (); + if (x*3.0 + x*5.0 != 8.0*x) + link_error (); + if (x*3.0 + x*5.0 != x*8.0) + link_error (); + } + + int main() + { + test(2.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030811-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030811-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030811-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030811-1.c 2003-08-11 21:53:58.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + /* Origin: PR target/11693 from Andreas Schwab */ + /* { dg-do compile { target ia64-*-linux* } } */ + /* { dg-options "-O2 -frename-registers" } */ + + static inline unsigned long + foo (void) + { + unsigned long x; + __asm__ __volatile__ ("" : "=r" (x) :: "memory"); + return x; + } + + static inline void + bar (unsigned long x, unsigned long y) + { + __asm__ __volatile__ ("" :: "r"(x), "r"(y) : "memory"); + } + + static inline void + baz (unsigned long x, unsigned long y, unsigned long z, unsigned long p, + unsigned long q) + { + __asm__ __volatile__ ("" :: "r" (q << 2) : "memory"); + __asm__ __volatile__ ("" :: "r" (z) : "memory"); + if (x & 0x1) + __asm__ __volatile__ ("" :: "r" (y), "r" (p) : "memory"); + if (x & 0x2) + __asm__ __volatile__ ("" :: "r" (y), "r" (p) : "memory"); + } + + static inline unsigned long + ffz (unsigned long x) + { + unsigned long r; + __asm__ ("" : "=r" (r) : "r" (x & (~x - 1))); + return r; + } + + void die (const char *, ...) __attribute__ ((noreturn)); + + void + test (void *x) + { + unsigned long a, c; + + a = foo (); + bar (0xc000000000000000, 0x660); + bar (0xa00000000000c000, 0x539); + baz (2, 1, 0xa000000000008000, + ({ unsigned long b; + b = ({ unsigned long d; __asm__ ("" : "=r" (d) : "r" (x)); d; }) + + 0x10000000000661; + b; + }), + 14); + c = ffz (0x1fffffffffffffff); + if (c < 51 || c > 61) + die ("die", c - 1); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030820-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030820-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030820-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030820-1.c 2003-08-20 21:55:01.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR middle-end/11984 */ + /* The following program used to ICE in fold because we didn't check + whether the constants we were reassociating were integer constants + before calling tree_int_cst_lt. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double f(double x) + { + return 1.0 - x - 0.1; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030826-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030826-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030826-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030826-1.c 2003-08-26 13:26:31.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of mathematical expressions doesn't + break anything. + + Written by Roger Sayle, 24th August 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -ffast-math" } */ + + void abort(void); + + double foo(double x) + { + return 12.0/(x*3.0); + } + + double bar(double x) + { + return (3.0/x)*4.0; + } + + int main() + { + if (foo(2.0) != 2.0) + abort (); + + if (bar(2.0) != 6.0) + abort (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030826-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030826-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030826-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030826-2.c 2003-08-27 10:52:09.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + /* { dg-do run } */ + /* { dg-options "-O2 -fomit-frame-pointer" } */ + /* { dg-options "-O2 -fomit-frame-pointer -march=i386" { target i?86-*-* } } */ + + extern void abort (void); + extern void exit (int); + + struct S + { + int *a; + unsigned char *b, c; + }; + + int u, v, w; + + void + foo (unsigned short x) + { + u += x; + } + + int + bar (struct S **x, int *y) + { + w += *y; + *y = w + 25; + return 0; + } + + int + baz (struct S **x) + { + struct S *y = *x; + unsigned char *a = y->b; + + foo (*a); + + if (__builtin_expect (y->c != 0 || y->a == &v, 0)) + return 1; + + if (__builtin_expect (*a == 1, 0)) + { + int a, b = bar (x, &a); + + if (a) + return b; + } + + return 0; + } + + int + main (void) + { + struct S a, *b = &a; + unsigned char c; + + __builtin_memset (b, 0, sizeof (a)); + a.a = &v; + a.b = &c; + if (baz (&b) != 1) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030906-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030906-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030906-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030906-1.c 2003-09-06 13:34:00.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* Bug 9862 -- Spurious warnings with -finline-functions. + Copyright (C) 2003 Free Software Foundation Inc. */ + + /* { dg-do compile } */ + /* { dg-options "-O -finline-functions -Wextra" } */ + + extern int i; + extern int foo (void); + extern int bar (void); + + int foo (void) + { + if( i ) return 0; + else return 1; + } /* { dg-bogus "may return with or without a value" } */ + + int bar (void) + { + if( i ) return; + else return 1; + } /* { dg-warning "may return with or without a value" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030906-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030906-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030906-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030906-2.c 2003-09-06 13:34:00.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* Bug 9862 -- Spurious warnings with -finline-functions. + Copyright (C) 2003 Free Software Foundation Inc. */ + + /* { dg-do compile } */ + /* { dg-options "-O -finline-functions -Wextra" } */ + + extern int i; + extern int foo (void); + extern int bar (void); + + int foo (void) + { + if( i ) return; + else return 1; + } /* { dg-warning "may return with or without a value" } */ + + int bar (void) + { + if( i ) return 0; + else return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030909-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030909-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030909-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030909-1.c 2003-09-11 04:45:11.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + /* Verify that ands are combined. */ + /* { dg-do compile { target arm*-*-* strongarm*-*-* xscale*-*-* } } */ + /* { dg-options "-O" } */ + /* { dg-final { scan-assembler-not "#255.*#255" } } */ + int f(int a, int b) { return ((a & 0xff) + (b & 0xff)) & 0xff; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20030926-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20030926-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20030926-1.c 2003-11-08 15:24:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20030926-1.c 2003-11-12 06:44:46.000000000 +0000 *************** *** 1,6 **** /* PR optimization/11741 */ /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -minline-all-stringops -march=pentium4" } */ void foo (char *p) --- 1,7 ---- /* PR optimization/11741 */ /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -minline-all-stringops" } */ ! /* { dg-options "-O2 -minline-all-stringops -march=pentium4" { target i?86-*-* } } */ void foo (char *p) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031009-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031009-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031009-1.c 2003-10-09 20:53:40.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031009-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,19 **** - /* PR optimization/12510 */ - /* Origin: Lars Skovlund */ - /* Reduced testcase by Volker Reichelt */ - - /* Verify that one splitting pass is not missing on x86 at -O1 */ - - /* { dg-do compile } */ - /* { dg-options "-O -mcpu=i686" { target i?86-*-* } } */ - - extern foo(double); - - void bar(double x, double y) - { - foo (x); - if (y) x = y ? 0 : 1/y; - else if (y) x = y < 1 ? 1 : y; - else x = 1/y < 1 ? 1 : x; - foo (x); - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031012-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031012-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031012-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031012-1.c 2003-10-12 22:16:04.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Origin: Andrew Morton */ + /* Warn if a function addres of a non-weak function is used + as a truth value. */ + /* See thread starting at http://gcc.gnu.org/ml/gcc/2003-10/msg00414.html */ + + void foo(void) + {} + + void bar(void) + {} + + int main() { + if (foo) /* { dg-warning "" } */ + bar(); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031102-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031102-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031102-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031102-1.c 2003-11-02 08:32:23.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + /* PR optimization/12799 */ + /* Origin: Pratap Subrahmanyam */ + + /* { dg-do run } */ + /* { dg-options "-O2" } */ + /* { dg-options "-O2 -march=i686" { target i686-*-* } } */ + + /* Verify that reload_cse_move2add doesn't add unexpected CLOBBERs. */ + + extern void abort(void); + + int loo = 1; + + __inline__ char InlineFunc(void) + { + return __builtin_expect(!!(loo == 1), 1); + } + + int FooBar(void) + { + int i; + int var1 = InlineFunc() ? 2046 : 1023; + int var2 = InlineFunc() ? 512 : 1024; + + for (i = 0; i < var1; i++) + ; + + if (InlineFunc() && var2 != 512) + abort(); + + return 0; + } + + int main(void) + { + return FooBar(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031111-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031111-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031111-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031111-1.c 2003-11-11 22:33:06.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Make sure that dead code isn't eliminated too early, avoiding + detection of errors. */ + /* { dg-do compile } */ + + void foo(void) + { + if (0) + break; /* { dg-error "" } */ + if (1) + ; + else + continue; /* { dg-error "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031201-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031201-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031201-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031201-1.c 2003-12-01 21:16:59.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* PR optimization/12628 */ + /* The following test used to ICE in init_alias_analysis because the + given command line options meant that reg_scan wasn't (re)run before + the jump bypassing pass. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -fno-expensive-optimizations -fno-rerun-loop-opt" } */ + + int outbuf[100]; + int outcnt; + int bi_buf; + void send_bits(void) + { + bi_buf = 0; + outbuf[outcnt++] = 8; + outbuf[outcnt++] = 8; + if (outcnt) + bi_buf = 1; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031202-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031202-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031202-1.c 2003-12-03 22:38:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031202-1.c 2003-12-03 22:40:58.000000000 +0000 *************** *** 1,6 **** /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mcpu=i686" { target i?86-*-* } } */ extern void abort (void); extern void exit (int); --- 1,6 ---- /* { dg-do run } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mtune=i686" { target i?86-*-* } } */ extern void abort (void); extern void exit (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031216-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031216-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031216-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031216-1.c 2003-12-18 12:15:37.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + /* This used to abort due to a loop bug on s390*. */ + + /* { dg-do run } */ + /* { dg-options "-O2" } */ + /* { dg-options "-O2 -fPIC" { target s390*-*-* } } */ + + int count = 0; + char *str; + + void test (int flag) + { + char *p; + + for (;;) + { + if (count > 5) + return; + + p = "test"; + + if (flag) + count++; + + str = p; + } + } + + int main (void) + { + test (1); + + if (str[0] != 't') + abort (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-1.c 2003-12-18 22:19:11.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* Orgin: v.haisman@sh.cvut.cz + Reduced by: Wolfgang Bangerth + PR debug/12923 ICE in gen_subprogram_die with -O1 -g + The problem was that this just to ICE with -O1 -g. */ + + /* { dg-do compile } */ + /* { dg-options "-O -g" } */ + + struct S { + unsigned n; + }; + + inline void foo (struct S * mx) { + mx->n = 1; + } + + void bar () { + foo (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-2.c 2003-12-18 22:19:11.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Orgin: Richard Sandiford + PR debug/12923 ICE in gen_subprogram_die with -O2 -g + The problem was that this just to ICE with -O2 -g. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -g" } */ + + int f1 (int y) + { + int f2() { return y; } + return f2(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031218-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031218-3.c 2003-12-18 22:19:11.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Orgin: Chris Demetriou + PR debug/12923 ICE in gen_subprogram_die with -O2 -g + The problem was that this just to ICE with -O2 -g. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -g" } */ + + int x (char *s) + { + int y () { return (strlen (s)); } + return y (s); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031222-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031222-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031222-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031222-1.c 2003-12-22 18:16:56.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR c/9163 */ + /* The following test used to ICE after an error message in C99 mode + because GCC was trying to expand the tree to rtl. */ + + /* { dg-do compile } */ + /* { dg-options "-std=c99" } */ + + + + void f () + { + for (; int ; ); /* { dg-error "" } */ + } + + void foo () + { + while (int i); /* { dg-error "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20031223-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20031223-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20031223-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20031223-1.c 2003-12-23 10:33:00.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* PR c/11995 */ + /* The following test used to ICE after an error message + because GCC was trying to expand the trees to rtl. */ + + /* { dg-do compile } */ + /* { dg-options "" } */ + + void f () + { + l: int; /* { dg-error "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040112-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040112-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040112-1.c 2004-01-21 02:40:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040112-1.c 2004-01-12 16:25:31.000000000 +0000 *************** *** 1,7 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ /* { dg-options "-O2" } */ /* { dg-final { scan-assembler "testb" } } */ - void ftn (char *sp) { char status; --- 1,6 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040123-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040123-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040123-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040123-1.c 2004-01-24 11:05:10.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + /* { dg-final { scan-assembler "abort" } } */ + + extern void abort (void); + extern char a[]; + + void foo (void) + { + if ((void *) a == (void *) 0x4000UL) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040127-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040127-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040127-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040127-1.c 2004-01-27 13:33:55.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + /* PR target/10904 */ + /* Origin: */ + + /* Verify that the register allocator correctly aligns + floating-point registers on SPARC64. */ + + /* { dg-do assemble } */ + /* { dg-options "-O2" } */ + + extern int foo1(); + extern int foo2(); + + void foo(int n, int b) + { + int i, a; + + foo1(); + + a = (long)(b * ((double) 0.1)); + + for (i=0; i < n; i++) { + foo2(a); + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040127-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040127-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040127-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040127-2.c 2004-01-27 13:33:55.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* PR target/13058 */ + /* Origin: Lloyd Parkes */ + /* Reduced testcase by Falk Hueffner */ + + /* Verify that the register allocator correctly aligns + floating-point registers on SPARC64. */ + + /* { dg-do compile } */ + /* { dg-options "-O" } */ + + typedef struct { int ThumbnailSize; } ImageInfo_t; + + double ConvertAnyFormat(void) + { + return 0; + } + + void ProcessExifDir(ImageInfo_t *ImageInfoP, int NumDirEntries) + { + unsigned int ThumbnailSize; + + for (; NumDirEntries;) { + Get16u(); + switch (NumDirEntries) { + case 0x0201: + case 0x0202: + ThumbnailSize = ConvertAnyFormat(); + } + } + + ImageInfoP->ThumbnailSize = ThumbnailSize; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040217-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040217-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040217-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040217-1.c 2004-02-17 22:14:13.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* This used to ICE on s390x due to a bug in simplify_if_then_else. */ + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + + extern void use (int); + void test (void) + { + union + { + unsigned long ul; + signed char sc; + } u; + + u.sc = 8; + u.sc &= 25; + + use (u.sc); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040302-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040302-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040302-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040302-1.c 2004-04-02 23:05:44.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR optimization/12419 */ + /* Ensure external_const_array[0] is read just once. */ + /* { dg-do compile { target i?86-*-linux* x86_64-*-linux* } } */ + /* { dg-options "-O2" } */ + /* { dg-final { scan-assembler "external_const_array" } } */ + /* { dg-final { scan-assembler-not "external_const_array.*add\[^\\n\]*external_const_array" } } */ + + extern const int external_const_array []; + extern void foo (void); + + int + bar (void) + { + int n = external_const_array[0]; + foo (); + n += external_const_array[0]; + return n; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040305-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040305-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040305-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040305-1.c 2004-03-06 01:24:10.000000000 +0000 *************** *** 0 **** --- 1,50 ---- + + /* The testcase failed due to corrupted alias information. + During the crossjump analyzing step the mem alias info of the + st instructions are merged and get copied during basic block + reordering which leads to an insn with wrong alias info. + The scheduler afterwards exchanges the mvc and st instructions + not recognizing the anti dependence. */ + /* { dg-do run { target s390-*-* } } */ + /* { dg-options "-O3 -mtune=z990 -fno-inline" } */ + + int f; + int g; + int h; + + int* x = &f; + int* p1 = &g; + int* p2 = &h; + + int + foo(void) + { + + if (*x == 0) + { + x = p1; /* mvc - memory to memory */ + p1 = (int*)0; /* st - register to memory */ + return 1; + } + if (*x == 5) + { + f = 1; + g = 2; + + p2 = (int*)0; /* st */ + return 1; + } + } + + int + main (int argc, char** argv) + { + foo (); + + /* If the scheduler has exchanged the mvc and st instructions, + x is 0. The expected result is &g. */ + if (x == &g) + exit (0); + else + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040306-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040306-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040306-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040306-1.c 2004-03-07 02:44:30.000000000 +0000 *************** *** 0 **** --- 1,22 ---- + /* This used to ICE due to a reload bug on s390*. */ + + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + + + typedef struct test + { + unsigned short pad; + unsigned char type[6]; + } t; + + extern void set (t *a, t *b, t *c, t *d, t *e, t *f, t *g, t *h, + t *i, t *j, t *k, t *l, t *m, t *n, t *o, t *p); + extern void use (t a, t b, t c, t d, t e, t f, t g, t h, + t i, t j, t k, t l, t m, t n, t o, t p); + void test (void) + { + t a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p; + set (&a, &b, &c, &d, &e, &f, &g, &h, &i, &j, &k, &l, &m, &n, &o, &p); + use (a, b, c, d, e, f, g, h, i, j, k, l, m, n, o, p); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040311-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040311-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040311-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040311-2.c 2004-03-13 11:36:13.000000000 +0000 *************** *** 0 **** --- 1,36 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040322-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040322-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040322-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040322-1.c 2004-03-22 15:39:05.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* PR c/14069 */ + /* { dg-do compile } */ + struct S { int a; char b[]; char *c; }; /* { dg-error "error" "flexible array member not" } */ + struct S s = { .b = "foo", .c = .b }; /* { dg-error "error" "parse error before" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/20040331-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/20040331-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/20040331-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/20040331-1.c 2004-04-01 16:09:15.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* { dg-do run } */ + /* { dg-options "-O2 -fwrapv" } */ + + extern void abort (void); + extern void exit (int); + + int + main (void) + { + struct { int count: 2; } s = { -2 }; + while (s.count-- != -2) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/991214-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/991214-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/991214-1.c 2002-02-06 20:40:17.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/991214-1.c 2004-02-26 14:31:54.000000000 +0000 *************** *** 4,10 **** /* Test against a problem with the combiner substituting explicit hard reg references when it shouldn't. */ void foo (int, int) __attribute__ ((regparm (3))); ! void foo (int x, int y) { __asm__ __volatile__("" : : "d" (x), "r" (y)); } --- 4,10 ---- /* Test against a problem with the combiner substituting explicit hard reg references when it shouldn't. */ void foo (int, int) __attribute__ ((regparm (3))); ! void __attribute__((regparm(3))) foo (int x, int y) { __asm__ __volatile__("" : : "d" (x), "r" (y)); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/991230-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/991230-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/991230-1.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/991230-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 1,5 **** /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O -ffast-math -mcpu=i486" } */ /* Test that floating point greater-than tests are compiled correctly with -ffast-math. */ --- 1,5 ---- /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O -ffast-math -mtune=i486" } */ /* Test that floating point greater-than tests are compiled correctly with -ffast-math. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/align-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/align-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/align-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/align-1.c 2003-04-02 15:50:31.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* PR java/10145 + Test that requesting an alignment of 1 does not increase the alignment + of a long long field. + + { dg-do run } + { dg-options "" } + */ + + struct A + { + char c; + long long i; + }; + + struct B + { + char c; + long long i __attribute ((__aligned__ (1))); + }; + + int main () + { + if (sizeof (struct A) != sizeof (struct B)) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-11.c gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-11.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-11.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-11.c 2004-01-08 07:27:09.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + /* { dg-do compile { target powerpc*-*-* } } */ + /* { dg-options "-O2 -maltivec -mabi=altivec" } */ + /* { dg-final { scan-assembler-not "lvx" } } */ + #include + + void foo (vector int); + void foo_s (vector short); + void foo_c (vector char); + + /* All constants should be loaded into vector register without + load from memory. */ + void + bar (void) + { + foo ((vector int) {0, 0, 0, 0}); + foo ((vector int) {1, 1, 1, 1}); + foo ((vector int) {15, 15, 15, 15}); + foo ((vector int) {-16, -16, -16, -16}); + foo ((vector int) {0x10001, 0x10001, 0x10001, 0x10001}); + foo ((vector int) {0xf000f, 0xf000f, 0xf000f, 0xf000f}); + foo ((vector int) {0xfff0fff0, 0xfff0fff0, 0xfff0fff0, 0xfff0fff0}); + foo ((vector int) {0x1010101, 0x1010101, 0x1010101, 0x1010101}); + foo ((vector int) {0xf0f0f0f, 0xf0f0f0f, 0xf0f0f0f, 0xf0f0f0f}); + foo ((vector int) {0xf0f0f0f0, 0xf0f0f0f0, 0xf0f0f0f0, 0xf0f0f0f0}); + foo ((vector int) {0x10, 0x10, 0x10, 0x10}); + foo ((vector int) {0x1e, 0x1e, 0x1e, 0x1e}); + + foo_s ((vector short int) {0, 0, 0, 0, 0, 0, 0, 0}); + foo_s ((vector short int) {1, 1, 1, 1, 1, 1, 1, 1}); + foo_s ((vector short int) {15, 15, 15, 15, 15, 15, 15, 15}); + foo_s ((vector short int) {-16, -16, -16, -16, -16, -16, -16, -16}); + foo_s ((vector short int) {0xf0f0, 0xf0f0, 0xf0f0, 0xf0f0, + 0xf0f0, 0xf0f0, 0xf0f0, 0xf0f0}); + foo_s ((vector short int) {0xf0f, 0xf0f, 0xf0f, 0xf0f, + 0xf0f, 0xf0f, 0xf0f, 0xf0f}); + + foo_c ((vector char) {0, 0, 0, 0, 0, 0, 0, 0, + 0, 0, 0, 0, 0, 0, 0, 0}); + foo_c ((vector char) {1, 1, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 1, 1, 1, 1, 1}); + foo_c ((vector char) {15, 15, 15, 15, 15, 15, 15, 15, + 15, 15, 15, 15, 15, 15, 15, 15}); + foo_c ((vector char) {-16, -16, -16, -16, -16, -16, -16, -16, + -16, -16, -16, -16, -16, -16, -16, -16}); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-9.c gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-9.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-9.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-9.c 2003-03-10 20:52:31.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* { dg-do compile { target powerpc-*-* } } */ + /* { dg-options "-maltivec -mabi=altivec -g" } */ + + /* PR9564 */ + + extern int vfork(void); + + void + boom (void) + { + char buf[65536]; + vfork(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-varargs-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-varargs-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/altivec-varargs-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/altivec-varargs-1.c 2003-12-19 07:52:00.000000000 +0000 *************** *** 0 **** --- 1,90 ---- + /* { dg-do run { target powerpc*-*-darwin* powerpc*-*-*altivec* powerpc*-*-linux*} } */ + /* { dg-options "-maltivec -mabi=altivec -fno-inline" } */ + + #include + #include + + #define vector __attribute__((mode(V4SI))) + + const vector unsigned int v1 = {10,11,12,13}; + const vector unsigned int v2 = {20,21,22,23}; + const vector unsigned int v3 = {30,31,32,33}; + const vector unsigned int v4 = {40,41,42,43}; + + void foo(vector unsigned int a, ...) + { + va_list args; + vector unsigned int v; + + va_start (args, a); + if (memcmp (&a, &v1, sizeof (v)) != 0) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v2, sizeof (v)) != 0) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v3, sizeof (v)) != 0) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v4, sizeof (v)) != 0) + abort (); + va_end (args); + } + + void bar(vector unsigned int a, ...) + { + va_list args; + vector unsigned int v; + int b; + + va_start (args, a); + if (memcmp (&a, &v1, sizeof (v)) != 0) + abort (); + b = va_arg (args, int); + if (b != 2) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v2, sizeof (v)) != 0) + abort (); + v = va_arg (args, vector unsigned int); + if (memcmp (&v, &v3, sizeof (v)) != 0) + abort (); + va_end (args); + } + + + int main1(void) + { + /* In this call, in the Darwin ABI, the first argument goes into v2 + the second one into r9-r10 and memory, + and the next two in memory. */ + foo ((vector unsigned int){10,11,12,13}, + (vector unsigned int){20,21,22,23}, + (vector unsigned int){30,31,32,33}, + (vector unsigned int){40,41,42,43}); + /* In this call, in the Darwin ABI, the first argument goes into v2 + the second one into r9, then r10 is reserved and + there are two words of padding in memory, and the next two arguments + go after the padding. */ + bar ((vector unsigned int){10,11,12,13}, 2, + (vector unsigned int){20,21,22,23}, + (vector unsigned int){30,31,32,33}); + return 0; + } + + void + sig_ill_handler (int sig) + { + exit(0); + } + + int main (void) + { + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline2.c gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline2.c 2004-02-29 23:34:54.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + inline __attribute__ ((always_inline)) void t(void); /* { dg-error "body not available" "" } */ + void + q(void) + { + t(); /* { dg-error "called from here" "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline3.c gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline3.c 2004-02-29 23:34:54.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + inline __attribute__ ((always_inline)) void + q2(void) + { /* { dg-error "recursive" "" } */ + q2(); /* { dg-error "called from here" "" } */ + q2(); /* { dg-error "called from here" "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline.c gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/always_inline.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/always_inline.c 2004-02-29 23:34:54.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + #include + inline __attribute__ ((always_inline)) void + e(int t, ...) + { /* { dg-error "variable argument" "" } */ + va_list q; + va_start (q, t); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-asm.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-asm.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-asm.c 2002-04-04 09:35:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-asm.c 2003-02-28 13:45:31.000000000 +0000 *************** *** 1,6 **** /* ARM and Thumb asm statements should be able to access the constant pool. */ ! /* { dg-do compile { target arm*-*-* } } */ extern unsigned x[]; unsigned *trapTable() { --- 1,6 ---- /* ARM and Thumb asm statements should be able to access the constant pool. */ ! /* { dg-do compile { target arm*-*-* strongarm*-*-* xscale*-*-*} } */ extern unsigned x[]; unsigned *trapTable() { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-g2.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-g2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-g2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-g2.c 2003-12-02 02:17:18.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* Verify that hardware multiply is preferred on XScale. */ + /* { dg-do compile { target xscale*-*-* } } */ + /* { dg-options "-mcpu=xscale -O2" } */ + + /* Brett Gaines' test case. */ + unsigned BCPL(unsigned) __attribute__ ((naked)); + unsigned BCPL(unsigned seed) + { + /* Best code would be: + ldr r1, =2147001325 + ldr r2, =715136305 + mla r0, r1, r0, r2 + mov pc, lr */ + + return seed * 2147001325U + 715136305U; + } + + /* We want to suppress running for -mthumb but not for -mthumb-interwork. */ + /* { dg-final { global compiler_flags; if ![string match "*-mthumb *" $compiler_flags] { scan-assembler "mla\[ ].*" } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-mmx-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-mmx-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-mmx-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-mmx-1.c 2004-03-12 15:21:52.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* Verify that if IP is saved to ensure stack alignment, we don't load + it into sp. */ + /* { dg-do compile { target arm*-*-* strongarm*-*-* xscale*-*-*} } */ + /* { dg-options "-O -mno-apcs-frame -mcpu=iwmmxt" } */ + /* { dg-final { global compiler_flags; if ![string match "*-mthumb *" $compiler_flags] { scan-assembler "ldmfd\[ ]sp!.*ip,\[ ]*pc" } } } */ + + /* This function uses all the call-saved registers, namely r4, r5, r6, + r7, r8, r9, sl, fp. Since we also save pc, that leaves an odd + number of registers, and the compiler will push ip to align the + stack. Make sure that we restore ip into ip, not into sp as is + done when using a frame pointer. The -mno-apcs-frame option + permits the frame pointer to be used as an ordinary register. */ + int + foo(int *a, int *b, int *c, int *d, int *tot) + { + int i, j, k, l, m, n, o; + + *tot = 0; + for (i = *a; i < *b; i += *c) + for (j = *a; j < *b; j += *d) + for (k = *a; k < *c; k += *d) + for (l = *b; k < *c; k += *d) + for (m = *d; k < *c; k += *b) + *tot += i + j + k + l + m; + return *tot; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-1.c 2003-12-16 22:38:58.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Verify that mov is preferred on XScale for loading a 1 byte constant. */ + /* { dg-do compile { target xscale-*-* } } */ + /* { dg-options "-mcpu=xscale -O" } */ + + unsigned load1(void) __attribute__ ((naked)); + unsigned load1(void) + { + /* Best code would be: + mov r0, =17 + mov pc, lr */ + + return 17; + } + + /* { dg-final { scan-assembler "mov\[ ].*17" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-2.c 2003-12-16 22:38:58.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Verify that mov is preferred on XScale for loading a 2 byte constant. */ + /* { dg-do compile { target xscale-*-* } } */ + /* { dg-options "-mcpu=xscale -O" } */ + + unsigned load2(void) __attribute__ ((naked)); + unsigned load2(void) + { + /* Best code would be: + mov r0, =272 + add r0, r0, =1 + mov pc, lr */ + + return 273; + } + + /* We want to suppress running for -mthumb but not for -mthumb-interwork. */ + /* { dg-final { global compiler_flags; if ![string match "*-mthumb *" $compiler_flags] { scan-assembler "mov\[ ].*272" } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/arm-scd42-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/arm-scd42-3.c 2003-12-16 22:38:58.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Verify that ldr is preferred on XScale for loading a 3 or 4 byte constant. */ + /* { dg-do compile { target xscale-*-* } } */ + /* { dg-options "-mcpu=xscale -O" } */ + + unsigned load4(void) __attribute__ ((naked)); + unsigned load4(void) + { + /* Best code would be: + ldr r0, =65809 + mov pc, lr */ + + return 65809; + } + + /* { dg-final { scan-assembler "ldr\[ ].*" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/array-quals-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/array-quals-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/array-quals-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/array-quals-1.c 2004-01-09 00:28:29.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* Test for various combinations of const, arrays and typedefs: + should never actually get const on the final array type, but + all should end up in a read-only section. PR c/12165. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-final { scan-assembler-not "\\.data(?!\\.rel\\.ro)" } } */ + static const int a[2] = { 1, 2 }; + const int a1[2] = { 1, 2 }; + typedef const int ci; + static ci b[2] = { 3, 4 }; + ci b1[2] = { 3, 4 }; + typedef int ia[2]; + static const ia c = { 5, 6 }; + const ia c1 = { 5, 6 }; + typedef const int cia[2]; + static cia d = { 7, 8 }; + cia d1 = { 7, 8 }; + static cia e[2] = { { 1, 2 }, { 3, 4 } }; + cia e1[2] = { { 1, 2 }, { 3, 4 } }; + void *const p = &a; + void *const q = &b; + void *const r = &c; + void *const s = &d; + void *const t = &e; + void *const p1 = &a1; + void *const q1 = &b1; + void *const r1 = &c1; + void *const s1 = &d1; + void *const t1 = &e1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/asm-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/asm-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/asm-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/asm-8.c 2003-07-26 15:53:14.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* PR inline-asm/11676 */ + /* { dg-do compile } */ + /* { dg-options "-O -Wall" } */ + + void foo(void) + { + long x = 0; + asm volatile ("" : "=r"(x) : "r"(x)); /* { dg-bogus "uninitialized" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/asm-names.c gcc-3.4.0/gcc/testsuite/gcc.dg/asm-names.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/asm-names.c 2001-08-27 19:23:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/asm-names.c 2003-10-13 23:09:17.000000000 +0000 *************** *** 2,27 **** to have an underscore prefixed, even if normal symbols are. Problem reported by Krister Walfridsson . */ ! /* { dg-do link } */ /* { dg-options "-fleading-underscore" } */ extern void frobnicate (void) asm ("___frob14"); /* three underscores */ - void __frob14 (void) {} /* two underscores */ - int main (void) { frobnicate (); return 0; } - - /* In case built where the runtime expects no leading underscore on - main(). */ - extern int xmain (void) asm ("main"); - - int xmain (void) { return main(); } - - /* In case built where the runtime calls __main. */ - extern int ymain (void) asm ("___main"); - int ymain (void) { return main(); } --- 2,16 ---- to have an underscore prefixed, even if normal symbols are. Problem reported by Krister Walfridsson . */ ! /* { dg-do compile } */ /* { dg-options "-fleading-underscore" } */ + /* { dg-final { scan-assembler-not "____frob14" } } */ extern void frobnicate (void) asm ("___frob14"); /* three underscores */ int main (void) { frobnicate (); return 0; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/attr-noinline.c gcc-3.4.0/gcc/testsuite/gcc.dg/attr-noinline.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/attr-noinline.c 2002-02-06 20:40:17.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/attr-noinline.c 2004-01-11 01:18:58.000000000 +0000 *************** static inline void __attribute__((__noin *** 13,45 **** static void function_declaration_both_after(void) {} ! static void function_declaration_noinline_before(void) __attribute__((__noinline__)); /* { dg-warning "previous declaration \[^\n\]* with attribute noinline" "" } */ ! static inline void function_declaration_noinline_before(void) {} /* { dg-warning "function \[^\n\]* redeclared as inline" "" } */ ! static inline void function_declaration_noinline_after(void) {} /* { dg-warning "previous declaration \[^\n\]* was inline" "" } */ ! static void function_declaration_noinline_after(void) __attribute__((__noinline__)); /* { dg-warning "function \[^\n\]* redeclared with attribute noinline" "" } */ ! static inline void function_declaration_inline_before(void); /* { dg-warning "previous declaration \[^\n\]* was inline" "" } */ ! static void __attribute__((__noinline__)) function_declaration_inline_before(void) {} /* { dg-warning "function \[^\n\]* redeclared with attribute noinline" "" } */ ! static inline void function_declaration_inline_noinline_before(void); /* { dg-warning "previous declaration \[^\n\]* was inline" "" } */ ! static void function_declaration_inline_noinline_before(void) __attribute__((__noinline__)); /* { dg-warning "function \[^\n\]* redeclared with attribute noinline" "" } */ static void function_declaration_inline_noinline_before(void) {} static inline void function_declaration_inline_noinline_after(void); ! static void function_declaration_inline_noinline_after(void) {} /* { dg-warning "previous declaration \[^\n\]* was inline" "" } */ ! static void function_declaration_inline_noinline_after(void) __attribute__((__noinline__)); /* { dg-warning "function \[^\n\]* redeclared with attribute noinline" "" } */ ! static void function_declaration_noinline_inline_before(void) __attribute__((__noinline__)); /* { dg-warning "previous declaration\[^\n\]* with attribute noinline" "" } */ ! static inline void function_declaration_noinline_inline_before(void); /* { dg-warning "function \[^\n\]* redeclared as inline" "" } */ static void function_declaration_noinline_inline_before(void) {} --- 13,45 ---- static void function_declaration_both_after(void) {} ! static void function_declaration_noinline_before(void) __attribute__((__noinline__)); /* { dg-warning "previous declaration" "" } */ ! static inline void function_declaration_noinline_before(void) {} /* { dg-warning "follows declaration with attribute noinline" "" } */ ! static inline void function_declaration_noinline_after(void) {} /* { dg-warning "previous definition" "" } */ ! static void function_declaration_noinline_after(void) __attribute__((__noinline__)); /* { dg-warning "follows inline declaration" "" } */ ! static inline void function_declaration_inline_before(void); /* { dg-warning "previous declaration" "" } */ ! static void __attribute__((__noinline__)) function_declaration_inline_before(void) {} /* { dg-warning "follows inline declaration" "" } */ ! static inline void function_declaration_inline_noinline_before(void); /* { dg-warning "previous declaration" "" } */ ! static void function_declaration_inline_noinline_before(void) __attribute__((__noinline__)); /* { dg-warning "follows inline declaration" "" } */ static void function_declaration_inline_noinline_before(void) {} static inline void function_declaration_inline_noinline_after(void); ! static void function_declaration_inline_noinline_after(void) {} /* { dg-warning "previous definition" "" } */ ! static void function_declaration_inline_noinline_after(void) __attribute__((__noinline__)); /* { dg-warning "follows inline declaration" "" } */ ! static void function_declaration_noinline_inline_before(void) __attribute__((__noinline__)); /* { dg-warning "previous declaration" "" } */ ! static inline void function_declaration_noinline_inline_before(void); /* { dg-warning "follows declaration with attribute noinline" "" } */ static void function_declaration_noinline_inline_before(void) {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/attr-used-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/attr-used-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/attr-used-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/attr-used-2.c 2003-02-19 02:07:06.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* { dg-do compile } */ + /* { dg-options "-Wall -O2" } */ + + static int xyzzy __attribute__((__used__)) = 1; + + void foo() + { + int x __attribute__((__used__)); /* { dg-warning "attribute ignored|unused variable" } */ + } + + /* { dg-final { scan-assembler "xyzzy" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/attr-warn-unused-result.c gcc-3.4.0/gcc/testsuite/gcc.dg/attr-warn-unused-result.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/attr-warn-unused-result.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/attr-warn-unused-result.c 2003-09-16 07:58:27.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + /* warn_unused_result attribute tests. */ + /* { dg-do compile } */ + /* { dg-options "-O" } */ + + #define WUR __attribute__((warn_unused_result)) + #define WURAI __attribute__((warn_unused_result, always_inline)) inline + typedef WUR int (*fnt) (void); + + typedef struct { long i; } A; + typedef struct { long i; long j; } B; + typedef struct { char big[1024]; fnt fn; } C; + + WUR int check1 (void); + WUR void check2 (void); /* { dg-warning "attribute ignored" } */ + int foo WUR; /* { dg-warning "only applies" } */ + int bar (void); + extern WURAI int check3 (void) { return bar (); } + WUR A check4 (void); + WUR B check5 (void); + WUR C check6 (void); + A bar7 (void); + B bar8 (void); + C bar9 (void); + extern WURAI A check7 (void) { return bar7 (); } + extern WURAI B check8 (void) { return bar8 (); } + extern WURAI C check9 (void) { return bar9 (); } + /* This is useful for checking whether return value of statement + expressions (returning int in this case) is used. */ + extern WURAI int check_int_result (int res) { return res; } + #define GU(v) ({ int e = 0; (v) = bar (); if ((v) < 23) e = 14; e; }) + fnt fnptr; + WUR int check10 (void); + int baz (void); + extern WURAI int check11 (void) { return baz (); } + int k; + + void + test (void) + { + int i = 0, j; + const fnt pcheck1 = check1; + const fnt pcheck3 = check3; + A a; + B b; + C c; + if (check1 ()) + return; + i += check1 (); + i += ({ check1 (); }); + check1 (); /* { dg-warning "ignoring return value of" } */ + (void) check1 (); /* { dg-warning "ignoring return value of" } */ + check1 (), bar (); /* { dg-warning "ignoring return value of" } */ + check2 (); + (void) check2 (); + check2 (), bar (); + if (check3 ()) + return; + i += check3 (); + i += ({ check3 (); }); + check3 (); /* { dg-warning "ignoring return value of" } */ + (void) check3 (); /* { dg-warning "ignoring return value of" } */ + check3 (), bar (); /* { dg-warning "ignoring return value of" } */ + a = check4 (); + if (a.i) + return; + if (check4 ().i) + return; + if (({ check4 (); }).i) + return; + check4 (); /* { dg-warning "ignoring return value of" } */ + (void) check4 (); /* { dg-warning "ignoring return value of" } */ + check4 (), bar (); /* { dg-warning "ignoring return value of" } */ + b = check5 (); + if (b.i + b.j) + return; + if (check5 ().j) + return; + if (({ check5 (); }).j) + return; + check5 (); /* { dg-warning "ignoring return value of" } */ + (void) check5 (); /* { dg-warning "ignoring return value of" } */ + check5 (), bar (); /* { dg-warning "ignoring return value of" } */ + c = check6 (); + if (c.big[12] + c.big[29]) + return; + if (check6 ().big[27]) + return; + if (({ check6 (); }).big[0]) + return; + check6 (); /* { dg-warning "ignoring return value of" } */ + (void) check6 (); /* { dg-warning "ignoring return value of" } */ + check6 (), bar (); /* { dg-warning "ignoring return value of" } */ + a = check7 (); + if (a.i) + return; + if (check7 ().i) + return; + if (({ check7 (); }).i) + return; + check7 (); /* { dg-warning "ignoring return value of" } */ + (void) check7 (); /* { dg-warning "ignoring return value of" } */ + check7 (), bar (); /* { dg-warning "ignoring return value of" } */ + b = check8 (); + if (b.i + b.j) + return; + if (check8 ().j) + return; + if (({ check8 (); }).j) + return; + check8 (); /* { dg-warning "ignoring return value of" } */ + (void) check8 (); /* { dg-warning "ignoring return value of" } */ + check8 (), bar (); /* { dg-warning "ignoring return value of" } */ + c = check9 (); + if (c.big[12] + c.big[29]) + return; + if (check9 ().big[27]) + return; + if (({ check9 (); }).big[0]) + return; + check9 (); /* { dg-warning "ignoring return value of" } */ + (void) check9 (); /* { dg-warning "ignoring return value of" } */ + check9 (), bar (); /* { dg-warning "ignoring return value of" } */ + if (check_int_result (GU (j))) + return; + i += check_int_result (GU (j)); + i += ({ check_int_result (GU (j)); }); + check_int_result (GU (j)); /* { dg-warning "ignoring return value of" } */ + (void) check_int_result (GU (j)); /* { dg-warning "ignoring return value of" } */ + check_int_result (GU (j)), bar (); /* { dg-warning "ignoring return value of" } */ + if (fnptr ()) + return; + i += fnptr (); + i += ({ fnptr (); }); + fnptr (); /* { dg-warning "ignoring return value of" } */ + (void) fnptr (); /* { dg-warning "ignoring return value of" } */ + fnptr (), bar (); /* { dg-warning "ignoring return value of" } */ + fnptr = check1; + if (fnptr ()) + return; + i += fnptr (); + i += ({ fnptr (); }); + fnptr (); /* { dg-warning "ignoring return value of" } */ + (void) fnptr (); /* { dg-warning "ignoring return value of" } */ + fnptr (), bar (); /* { dg-warning "ignoring return value of" } */ + fnptr = check3; + if (fnptr ()) + return; + i += fnptr (); + i += ({ fnptr (); }); + fnptr (); /* { dg-warning "ignoring return value of" } */ + (void) fnptr (); /* { dg-warning "ignoring return value of" } */ + fnptr (), bar (); /* { dg-warning "ignoring return value of" } */ + if (bar9 ().fn ()) + return; + i += bar9 ().fn (); + i += ({ bar9 ().fn (); }); + bar9 ().fn (); /* { dg-warning "ignoring return value of" } */ + (void) bar9 ().fn (); /* { dg-warning "ignoring return value of" } */ + bar9 ().fn (), bar (); /* { dg-warning "ignoring return value of" } */ + if ((k ? check1 : check10) ()) + return; + i += (k ? check1 : check10) (); + i += ({ (k ? check1 : check10) (); }); + (k ? check1 : check10) (); /* { dg-warning "ignoring return value of" } */ + (void) (k ? check1 : check10) (); /* { dg-warning "ignoring return value of" } */ + (k ? check1 : check10) (), bar (); /* { dg-warning "ignoring return value of" } */ + if ((k ? check3 : check11) ()) + return; + i += (k ? check3 : check11) (); + i += ({ (k ? check3 : check11) (); }); + (k ? check3 : check11) (); /* { dg-warning "ignoring return value of" } */ + (void) (k ? check3 : check11) (); /* { dg-warning "ignoring return value of" } */ + (k ? check3 : check11) (), bar (); /* { dg-warning "ignoring return value of" } */ + if (pcheck1 ()) + return; + i += pcheck1 (); + i += ({ pcheck1 (); }); + pcheck1 (); /* { dg-warning "ignoring return value of" } */ + (void) pcheck1 (); /* { dg-warning "ignoring return value of" } */ + pcheck1 (), bar (); /* { dg-warning "ignoring return value of" } */ + if (pcheck3 ()) + return; + i += pcheck3 (); + i += ({ pcheck3 (); }); + pcheck3 (); /* { dg-warning "ignoring return value of" } */ + (void) pcheck3 (); /* { dg-warning "ignoring return value of" } */ + pcheck3 (), bar (); /* { dg-warning "ignoring return value of" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bf-ms-attrib.c gcc-3.4.0/gcc/testsuite/gcc.dg/bf-ms-attrib.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bf-ms-attrib.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bf-ms-attrib.c 2003-01-10 23:56:06.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + /* bf-ms-attrib.c */ + /* Adapted from Donn Terry testcase + posted to GCC-patches + http://gcc.gnu.org/ml/gcc-patches/2000-08/msg00577.html */ + + /* { dg-do run { target *-*-interix* *-*-mingw* *-*-cygwin* } } */ + + /* We don't want the default "pedantic-errors" in this case, since we're + testing nonstandard stuff to begin with. */ + /* { dg-options "-ansi" } */ + + #include + + struct one_gcc { + int d; + unsigned char a; + unsigned short b:7; + char c; + } __attribute__((__gcc_struct__)) ; + + + struct one_ms { + int d; + unsigned char a; + unsigned short b:7; + char c; + } __attribute__((__ms_struct__)); + + + main() + { + /* As long as the sizes are as expected, we know attributes are working. + bf-ms-layout.c makes sure the right thing happens when the attribute + is on. */ + if (sizeof(struct one_ms) != 12) + abort(); + if (sizeof(struct one_gcc) != 8) + abort(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bf-ms-layout.c gcc-3.4.0/gcc/testsuite/gcc.dg/bf-ms-layout.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bf-ms-layout.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bf-ms-layout.c 2003-01-10 23:56:06.000000000 +0000 *************** *** 0 **** --- 1,232 ---- + /* bf-ms-layout.c */ + + /* Test for MS bitfield layout */ + /* Adapted from Donn Terry testcase + posted to GCC-patches + http://gcc.gnu.org/ml/gcc-patches/2000-08/msg00577.html */ + + /* { dg-do run { target *-*-interix* *-*-mingw* *-*-cygwin* } } */ + /* { dg-options "-mms-bitfields -D_TEST_MS_LAYOUT" } */ + + #include + #include + + extern void abort(); + + #pragma pack(8) + + struct one { + int d; + unsigned char a; + unsigned short b:7; + char c; + }; + + struct two { + int d; + unsigned char a; + unsigned int b:7; + char c; + }; + + struct three { + short d; + unsigned short a:3; + unsigned short b:9; + unsigned char c:7; + }; + + + /* Bitfields of size 0 have some truly odd behaviors. */ + + struct four { + unsigned short a:3; + unsigned short b:9; + unsigned int :0; /* forces struct alignment to int */ + unsigned char c:7; + }; + + struct five { + char a; + int :0; /* ignored; prior field is not a bitfield. */ + char b; + char c; + }; + + struct six { + char a :8; + int :0; /* not ignored; prior field IS a bitfield, causes + struct alignment as well. */ + char b; + char c; + } ; + + struct seven { + char a:8; + char :0; + int :0; /* Ignored; prior field is zero size bitfield. */ + char b; + char c; + }; + + struct eight { /* ms size 4 */ + short b:3; + char c; + }; + + #ifdef _MSC_VER + #define LONGLONG __int64 + #else + #define LONGLONG long long + #endif + + union nine { /* ms size 8 */ + LONGLONG a:3; + char c; + }; + + struct ten { /* ms size 16 */ + LONGLONG a:3; + LONGLONG b:3; + char c; + }; + + + #define val(s,f) (s.f) + + #define check_struct(_X) \ + { \ + if (sizeof (struct _X) != exp_sizeof_##_X ) \ + abort(); \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_union(_X) \ + { \ + if (sizeof (union _X) != exp_sizeof_##_X ) \ + abort(); \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_struct_size(_X) \ + { \ + if (sizeof (struct _X) != exp_sizeof_##_X ) \ + abort(); \ + } + + #define check_struct_off(_X) \ + { \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_union_size(_X) \ + { \ + if (sizeof (union _X) != exp_sizeof_##_X ) \ + abort(); \ + } + + #define check_union_off(_X) \ + { \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + int main(){ + + unsigned char filler[16]; + struct one test_one; + struct two test_two; + struct three test_three; + struct four test_four; + struct five test_five; + struct six test_six; + struct seven test_seven; + struct eight test_eight; + union nine test_nine; + struct ten test_ten; + + #if defined (_TEST_MS_LAYOUT) || defined (_MSC_VER) + size_t exp_sizeof_one = 12; + size_t exp_sizeof_two = 16; + size_t exp_sizeof_three =6; + size_t exp_sizeof_four = 8; + size_t exp_sizeof_five = 3; + size_t exp_sizeof_six = 8; + size_t exp_sizeof_seven = 3; + size_t exp_sizeof_eight = 4; + size_t exp_sizeof_nine = 8; + size_t exp_sizeof_ten = 16; + + unsigned char exp_one_c = 8; + unsigned char exp_two_c = 12; + unsigned char exp_three_c = 4; + unsigned char exp_four_c = 4; + char exp_five_c = 2; + char exp_six_c = 5; + char exp_seven_c = 2; + char exp_eight_c = 2; + char exp_nine_c = 0; + char exp_ten_c = 8; + + #else /* testing -mno-ms-bitfields */ + + size_t exp_sizeof_one = 8; + size_t exp_sizeof_two = 8; + size_t exp_sizeof_three = 6; + size_t exp_sizeof_four = 6; + size_t exp_sizeof_five = 6; + size_t exp_sizeof_six = 6; + size_t exp_sizeof_seven = 6; + size_t exp_sizeof_eight = 2; + size_t exp_sizeof_nine = 8; + size_t exp_sizeof_ten = 8; + + unsigned short exp_one_c = 6; + unsigned int exp_two_c = 6; + unsigned char exp_three_c = 64; + unsigned char exp_four_c = 4; + char exp_five_c = 5; + char exp_six_c = 5; + char exp_seven_c = 5; + char exp_eight_c = 1; + char exp_nine_c = 0; + char exp_ten_c = 1; + + #endif + + unsigned char i; + for ( i = 0; i < 16; i++ ) + filler[i] = i; + + check_struct_off (one); + check_struct_off (two); + check_struct_off (three); + check_struct_off (four); + check_struct_off (five); + check_struct_off (six); + check_struct_off (seven); + check_struct_off (eight); + check_union_off (nine); + check_struct_off (ten); + + check_struct_size (one); + check_struct_size (two); + check_struct_size (three); + check_struct_size (four); + check_struct_size (five); + check_struct_size (six); + check_struct_size (seven); + check_struct_size (eight); + check_union_size (nine); + check_struct_size (ten); + + return 0; + }; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bf-no-ms-layout.c gcc-3.4.0/gcc/testsuite/gcc.dg/bf-no-ms-layout.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bf-no-ms-layout.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bf-no-ms-layout.c 2003-01-10 23:56:06.000000000 +0000 *************** *** 0 **** --- 1,232 ---- + /* bf-no-ms-layout.c */ + + /* Test for gcc bitfield layout, with -mno-ms-bitfields */ + /* Adapted from Donn Terry testcase + posted to GCC-patches + http://gcc.gnu.org/ml/gcc-patches/2000-08/msg00577.html */ + + /* { dg-do run { target *-*-interix* *-*-mingw* *-*-cygwin* } } */ + /* { dg-options "-mno-ms-bitfields" } */ + + #include + #include + + extern void abort(); + + #pragma pack(8) + + struct one { + int d; + unsigned char a; + unsigned short b:7; + char c; + }; + + struct two { + int d; + unsigned char a; + unsigned int b:7; + char c; + }; + + struct three { + short d; + unsigned short a:3; + unsigned short b:9; + unsigned char c:7; + }; + + + /* Bitfields of size 0 have some truly odd behaviors. */ + + struct four { + unsigned short a:3; + unsigned short b:9; + unsigned int :0; /* forces struct alignment to int */ + unsigned char c:7; + }; + + struct five { + char a; + int :0; /* ignored; prior field is not a bitfield. */ + char b; + char c; + }; + + struct six { + char a :8; + int :0; /* not ignored; prior field IS a bitfield, causes + struct alignment as well. */ + char b; + char c; + } ; + + struct seven { + char a:8; + char :0; + int :0; /* Ignored; prior field is zero size bitfield. */ + char b; + char c; + }; + + struct eight { /* ms size 4 */ + short b:3; + char c; + }; + + #ifdef _MSC_VER + #define LONGLONG __int64 + #else + #define LONGLONG long long + #endif + + union nine { /* ms size 8 */ + LONGLONG a:3; + char c; + }; + + struct ten { /* ms size 16 */ + LONGLONG a:3; + LONGLONG b:3; + char c; + }; + + + #define val(s,f) (s.f) + + #define check_struct(_X) \ + { \ + if (sizeof (struct _X) != exp_sizeof_##_X ) \ + abort(); \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_union(_X) \ + { \ + if (sizeof (union _X) != exp_sizeof_##_X ) \ + abort(); \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_struct_size(_X) \ + { \ + if (sizeof (struct _X) != exp_sizeof_##_X ) \ + abort(); \ + } + + #define check_struct_off(_X) \ + { \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + #define check_union_size(_X) \ + { \ + if (sizeof (union _X) != exp_sizeof_##_X ) \ + abort(); \ + } + + #define check_union_off(_X) \ + { \ + memcpy(&test_##_X, filler, sizeof(test_##_X));\ + if (val(test_##_X,c) != exp_##_X##_c) \ + abort(); \ + } + + int main(){ + + unsigned char filler[16]; + struct one test_one; + struct two test_two; + struct three test_three; + struct four test_four; + struct five test_five; + struct six test_six; + struct seven test_seven; + struct eight test_eight; + union nine test_nine; + struct ten test_ten; + + #if defined (_TEST_MS_LAYOUT) || defined (_MSC_VER) + size_t exp_sizeof_one = 12; + size_t exp_sizeof_two = 16; + size_t exp_sizeof_three =6; + size_t exp_sizeof_four = 8; + size_t exp_sizeof_five = 3; + size_t exp_sizeof_six = 8; + size_t exp_sizeof_seven = 3; + size_t exp_sizeof_eight = 4; + size_t exp_sizeof_nine = 8; + size_t exp_sizeof_ten = 16; + + unsigned char exp_one_c = 8; + unsigned char exp_two_c = 12; + unsigned char exp_three_c = 4; + unsigned char exp_four_c = 4; + char exp_five_c = 2; + char exp_six_c = 5; + char exp_seven_c = 2; + char exp_eight_c = 2; + char exp_nine_c = 0; + char exp_ten_c = 8; + + #else /* testing -mno-ms-bitfields */ + + size_t exp_sizeof_one = 8; + size_t exp_sizeof_two = 8; + size_t exp_sizeof_three = 6; + size_t exp_sizeof_four = 6; + size_t exp_sizeof_five = 6; + size_t exp_sizeof_six = 6; + size_t exp_sizeof_seven = 6; + size_t exp_sizeof_eight = 2; + size_t exp_sizeof_nine = 8; + size_t exp_sizeof_ten = 8; + + unsigned short exp_one_c = 6; + unsigned int exp_two_c = 6; + unsigned char exp_three_c = 64; + unsigned char exp_four_c = 4; + char exp_five_c = 5; + char exp_six_c = 5; + char exp_seven_c = 5; + char exp_eight_c = 1; + char exp_nine_c = 0; + char exp_ten_c = 1; + + #endif + + unsigned char i; + for ( i = 0; i < 16; i++ ) + filler[i] = i; + + check_struct_off (one); + check_struct_off (two); + check_struct_off (three); + check_struct_off (four); + check_struct_off (five); + check_struct_off (six); + check_struct_off (seven); + check_struct_off (eight); + check_union_off (nine); + check_struct_off (ten); + + check_struct_size (one); + check_struct_size (two); + check_struct_size (three); + check_struct_size (four); + check_struct_size (five); + check_struct_size (six); + check_struct_size (seven); + check_struct_size (eight); + check_union_size (nine); + check_struct_size (ten); + + return 0; + }; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-1.c 2002-02-02 00:14:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-1.c 2003-12-18 21:03:24.000000000 +0000 *************** struct bf1 *** 25,30 **** unsigned long g: 5; /* { dg-warning "GCC extension|ISO C" } */ ui h: 5; enum foo i: 2; /* { dg-error "narrower" } */ ! enum foo j: 3; unsigned int k: 256; /* { dg-error "exceeds its type" } */ }; --- 25,31 ---- unsigned long g: 5; /* { dg-warning "GCC extension|ISO C" } */ ui h: 5; enum foo i: 2; /* { dg-error "narrower" } */ ! /* { dg-warning "GCC extension|ISO C" "extension" { target *-*-* } 27 } */ ! enum foo j: 3; /* { dg-warning "GCC extension|ISO C" } */ unsigned int k: 256; /* { dg-error "exceeds its type" } */ }; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-7.c 2003-11-29 20:09:48.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* Test for rejection of typeof on bit-fields. PR c/10333. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + struct { int a:1; } x; + + typeof (x.a) z; /* { dg-error "applied to a bit-field" "typeof" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/bitfld-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/bitfld-8.c 2003-12-17 00:25:24.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* Test that too wide bit-fields are hard errors. PR c/3347. */ + /* Origin: Joseph Myers , from PR c/3347 */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + struct { int i : 1999; } x; /* { dg-bogus "warning" "warning in place of error" } */ + /* { dg-error "width" "bit-field too wide" { target *-*-* } 6 } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-apply2.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-apply2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-apply2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-apply2.c 2003-11-28 16:35:52.000000000 +0000 *************** *** 0 **** --- 1,30 ---- + /* PR target/12503 */ + /* Origin: */ + + /* Verify that __builtin_apply behaves correctly on targets + with pre-pushed arguments (e.g. SPARC). */ + + /* { dg-do run } */ + + + #define INTEGER_ARG 5 + + extern void abort(void); + + void foo(char *name, double d, double e, double f, int g) + { + if (g != INTEGER_ARG) + abort(); + } + + void bar(char *name, ...) + { + __builtin_apply(foo, __builtin_apply_args(), 64); + } + + int main(void) + { + bar("eeee", 5.444567, 8.90765, 4.567789, INTEGER_ARG); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-apply3.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-apply3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-apply3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-apply3.c 2003-11-28 16:35:52.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + /* PR middle-end/12210 */ + /* Origin: Ossadchy Yury A. */ + + /* This used to fail on i686 because the argument was not copied + to the right location by __builtin_apply after the direct call. */ + + /* { dg-do run } */ + + + #define INTEGER_ARG 5 + + extern void abort(void); + + void foo(int arg) + { + if (arg != INTEGER_ARG) + abort(); + } + + void bar(int arg) + { + foo(arg); + __builtin_apply(foo, __builtin_apply_args(), 16); + } + + int main(void) + { + bar(INTEGER_ARG); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-return-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-return-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtin-return-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtin-return-1.c 2003-12-05 06:46:35.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* PR middle-end/11151 */ + /* Originator: Andrew Church */ + /* { dg-do run } */ + + /* This used to fail on SPARC because the (undefined) return + value of 'bar' was overwriting that of 'foo'. */ + + extern void abort(void); + + int foo(int n) + { + return n+1; + } + + int bar(int n) + { + __builtin_return(__builtin_apply((void (*)(void))foo, __builtin_apply_args(), 64)); + } + + int main(void) + { + if (bar(1) != 2) + abort(); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-10.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-10.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-10.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-10.c 2003-04-08 23:24:38.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 2nd April 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + extern double exp(double); + extern double log(double); + extern double sqrt(double); + extern double pow(double,double); + + void test(double x) + { + if (sqrt(pow(x,4.0)) != x*x) + link_error (); + + if (pow(sqrt(x),4.0) != x*x) + link_error (); + + if (pow(pow(x,4.0),0.25) != x) + link_error (); + } + + void test2(double x, double y, double z) + { + if (sqrt(pow(x,y)) != pow(x,y*0.5)) + link_error (); + + if (log(pow(x,y)) != y*log(x)) + link_error (); + + if (pow(exp(x),y) != exp(x*y)) + link_error (); + + if (pow(sqrt(x),y) != pow(x,y*0.5)) + link_error (); + + if (pow(pow(x,y),z) != pow(x,y*z)) + link_error (); + } + + int main() + { + test (2.0); + test2 (2.0, 3.0, 4.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-11.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-11.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-11.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-11.c 2003-04-08 23:28:28.000000000 +0000 *************** *** 0 **** --- 1,46 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 5th April 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + extern double exp(double); + extern double sqrt(double); + extern double pow(double,double); + + void test(double x, double y, double z) + { + if (sqrt(x)*sqrt(x) != x) + link_error (); + + if (sqrt(x)*sqrt(y) != sqrt(x*y)) + link_error (); + + if (exp(x)*exp(y) != exp(x+y)) + link_error (); + + if (pow(x,y)*pow(z,y) != pow(z*x,y)) + link_error (); + + if (pow(x,y)*pow(x,z) != pow(x,y+z)) + link_error (); + + if (x/exp(y) != x*exp(-y)) + link_error (); + + if (x/pow(y,z) != x*pow(y,-z)) + link_error (); + } + + int main() + { + test (2.0, 3.0, 4.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-12.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-12.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-12.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-12.c 2003-04-14 02:55:31.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that all the malloc-like __builtin_ allocation functions are + recognized by the compiler. + + Written by Roger Sayle, 12th April 2003. */ + + /* { dg-do compile } */ + /* { dg-final { scan-assembler-not "__builtin_" } } */ + + typedef __SIZE_TYPE__ size_t; + + void *test1(size_t n) + { + return __builtin_malloc(n); + } + + void *test2(size_t n, size_t s) + { + return __builtin_calloc(n,s); + } + + char *test3(const char *ptr) + { + return __builtin_strdup(ptr); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-13.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-13.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-13.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-13.c 2003-04-14 02:55:31.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that the malloc-like __builtin_ allocation functions are + correctly aliased by the compiler. + + Written by Roger Sayle, 12th April 2003. */ + + /* { dg-do link } */ + + typedef __SIZE_TYPE__ size_t; + + extern void abort (void); + extern void *malloc (size_t); + extern void *calloc (size_t,size_t); + + extern void link_error (void); + + static int x; + + void test1(void) + { + int *ptr1, *ptr2; + + ptr1 = &x; + ptr2 = (int*) malloc (sizeof (int)); + + *ptr1 = 12; + *ptr2 = 8; + + if (*ptr1 != 12) + link_error(); + } + + void test2(void) + { + int *ptr1, *ptr2; + + ptr1 = &x; + ptr2 = (int*) calloc (1, sizeof (int)); + + *ptr1 = 12; + *ptr2 = 8; + + if (*ptr1 != 12) + link_error (); + } + + int main() + { + test1 (); + test2 (); + return 0; + } + + #ifndef __OPTIMIZE__ + void link_error (void) + { + abort (); + } + #endif + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-14.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-14.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-14.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-14.c 2003-05-06 03:14:10.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 9th April 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2" } */ + + extern void link_error(void); + + extern double pow(double,double); + + + int main() + { + if (pow (2.0, 3.0) != 8.0) + link_error (); + + if (pow (2.0, -3.0) != 0.125) + link_error (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-15.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-15.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-15.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-15.c 2003-05-14 21:13:49.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Derived from PR optimization/10764 */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double log(double x); + + double ndtri(double y0) + { + double x; + + x = log(y0); + x = log(x); + + return x; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-16.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-16.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-16.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-16.c 2003-06-03 11:27:23.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that all the __builtin_cabs? functions are recognized + by the compiler. Complex numbers are not supported with the + gcc.dg default "-pedantic-errors" option, so the dg-options + overrides this. + + Written by Roger Sayle, 1st June 2003. */ + + /* { dg-do compile } */ + /* { dg-options "-O -ansi" } */ + /* { dg-final { scan-assembler-not "__builtin_" } } */ + + double test(__complex__ double x) + { + return __builtin_cabs (x); + } + + float testf(__complex__ float x) + { + return __builtin_cabsf (x); + } + + long double testl(__complex__ long double x) + { + return __builtin_cabsl (x); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-17.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-17.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-17.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-17.c 2003-06-04 12:20:40.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 25th May 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + extern double exp(double); + + + int main() + { + if (exp (1.0) < 2.71 || exp (1.0) > 2.72) + link_error (); + if (exp (2.0) < 7.38 || exp (2.0) > 7.39) + link_error (); + if (exp (-2.0) < 0.13 || exp (-2.0) > 0.14) + link_error (); + if (atan (1.0) < 0.78 || atan (1.0) > 0.79) + link_error (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-18.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-18.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-18.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-18.c 2003-12-24 06:52:27.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that built-in cabs, cabsf and cabsl functions don't + break anything and produces the expected results. + + Written by Roger Sayle, 1st June 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + #include "builtins-config.h" + + extern void link_error(void); + + extern float cabsf (float _Complex); + extern double cabs (double _Complex); + extern long double cabsl (long double _Complex); + + int + main (void) + { + /* For each type, test both runtime and compile time (constant folding) + optimization. */ + float _Complex fc = 3.0F + 4.0iF; + double _Complex dc = 3.0 + 4.0i; + long double _Complex ldc = 3.0L + 4.0iL; + + #ifdef HAVE_C99_RUNTIME + /* Test floats. */ + if (cabsf (fc) != 5.0F) + link_error (); + if (__builtin_cabsf (fc) != 5.0F) + link_error (); + if (cabsf (3.0F + 4.0iF) != 5.0F) + link_failure (); + if (__builtin_cabsf (3.0F + 4.0iF) != 5.0F) + link_failure (); + #endif + + /* Test doubles. */ + if (cabs (dc) != 5.0) + link_error (); + if (__builtin_cabs (dc) != 5.0) + link_error (); + if (cabs (3.0 + 4.0i) != 5.0) + link_failure (); + if (__builtin_cabs (3.0 + 4.0i) != 5.0) + link_failure (); + + #ifdef HAVE_C99_RUNTIME + /* Test long doubles. */ + if (cabsl (ldc) != 5.0L) + link_error (); + if (__builtin_cabsl (ldc) != 5.0L) + link_error (); + if (cabsl (3.0L + 4.0iL) != 5.0L) + link_failure (); + if (__builtin_cabsl (3.0L + 4.0iL) != 5.0L) + link_failure (); + #endif + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-19.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-19.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-19.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-19.c 2003-06-06 16:15:50.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that cabs of a non-complex argument is converted into fabs. + + Written by Roger Sayle, 1st June 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + double cabs (__complex__ double); + float cabsf (__complex__ float); + long double cabsl (__complex__ long double); + + void link_error (void); + + void test (double x) + { + if (cabs (x) != fabs (x)) + link_error (); + } + + void testf (float x) + { + if (cabsf (x) != fabsf (x)) + link_error (); + } + + void testl (long double x) + { + if (cabsl (x) != fabsl (x)) + link_error (); + } + + int main () + { + test (1.0); + testf (1.0f); + testl (1.0l); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-1.c 2002-08-04 02:08:20.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-1.c 2004-03-20 10:22:39.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation. Verify that all the __builtin_ math functions are recognized by the compiler. --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation. Verify that all the __builtin_ math functions are recognized by the compiler. *************** *** 6,28 **** Written by Roger Sayle, 11th July 2002. */ /* { dg-do compile } */ /* { dg-final { scan-assembler-not "__builtin_" } } */ ! double test1(double x) { return __builtin_sqrt(x); } ! double test2(double x) { return __builtin_cos(x); } ! double test3(double x) { return __builtin_sin(x); } ! double test4(double x) { return __builtin_exp(x); } ! double test5(double x) { return __builtin_log(x); } ! float test1f(float x) { return __builtin_sqrtf(x); } ! float test2f(float x) { return __builtin_cosf(x); } ! float test3f(float x) { return __builtin_sinf(x); } ! float test4f(float x) { return __builtin_expf(x); } ! float test5f(float x) { return __builtin_logf(x); } ! long double test1l(long double x) { return __builtin_sqrtl(x); } ! long double test2l(long double x) { return __builtin_cosl(x); } ! long double test3l(long double x) { return __builtin_sinl(x); } ! long double test4l(long double x) { return __builtin_expl(x); } ! long double test5l(long double x) { return __builtin_logl(x); } --- 6,201 ---- Written by Roger Sayle, 11th July 2002. */ /* { dg-do compile } */ + /* { dg-options "" } */ /* { dg-final { scan-assembler-not "__builtin_" } } */ ! /* These helper macros ensure we also check the float and long double ! cases. */ ! /* Test FP functions taking void. */ ! #define FPTEST0(FN) \ ! double test_##FN(void) { return __builtin_##FN(); } \ ! float test_##FN##f(void) { return __builtin_##FN##f(); } \ ! long double test_##FN##l(void) { return __builtin_##FN##l(); } ! /* Test FP functions taking one FP argument. */ ! #define FPTEST1(FN) \ ! double test_##FN(double x) { return __builtin_##FN(x); } \ ! float test_##FN##f(float x) { return __builtin_##FN##f(x); } \ ! long double test_##FN##l(long double x) { return __builtin_##FN##l(x); } ! ! /* Test FP functions taking one argument of a supplied type. */ ! #define FPTEST1ARG(FN, TYPE) \ ! double test_##FN(TYPE x) { return __builtin_##FN(x); } \ ! float test_##FN##f(TYPE x) { return __builtin_##FN##f(x); } \ ! long double test_##FN##l(TYPE x) { return __builtin_##FN##l(x); } ! ! /* Test FP functions taking two arguments, the first argument is of a ! supplied type. */ ! #define FPTEST2ARG1(FN, TYPE) \ ! double test_##FN(TYPE x, double y) { return __builtin_##FN(x, y); } \ ! float test_##FN##f(TYPE x, float y) { return __builtin_##FN##f(x, y); } \ ! long double test_##FN##l(TYPE x, long double y) { return __builtin_##FN##l(x, y); } + /* Test FP functions taking two arguments, the second argument is of a + supplied type. */ + #define FPTEST2ARG2(FN, TYPE) \ + double test_##FN(double x, TYPE y) { return __builtin_##FN(x, y); } \ + float test_##FN##f(float x, TYPE y) { return __builtin_##FN##f(x, y); } \ + long double test_##FN##l(long double x, TYPE y) { return __builtin_##FN##l(x, y); } + + /* Test FP functions taking two arguments, the second argument is a + FP pointer. */ + #define FPTEST2FPP2(FN) \ + double test_##FN(double x, double *y) { return __builtin_##FN(x, y); } \ + float test_##FN##f(float x, float *y) { return __builtin_##FN##f(x, y); } \ + long double test_##FN##l(long double x, long double *y) { return __builtin_##FN##l(x, y); } + + /* Test FP functions taking one FP argument and a supplied return + type. */ + #define FPTEST1RET(FN, TYPE) \ + TYPE test_##FN(double x) { return __builtin_##FN(x); } \ + TYPE test_##FN##f(float x) { return __builtin_##FN##f(x); } \ + TYPE test_##FN##l(long double x) { return __builtin_##FN##l(x); } + + /* Test FP functions taking two FP arguments. */ + #define FPTEST2(FN) \ + double test_##FN(double x, double y) { return __builtin_##FN(x, y); } \ + float test_##FN##f(float x, float y) { return __builtin_##FN##f(x, y); } \ + long double test_##FN##l(long double x, long double y) { return __builtin_##FN##l(x, y); } + + /* Test FP functions taking three FP arguments. */ + #define FPTEST3(FN) \ + double test_##FN(double x, double y, double z) { return __builtin_##FN(x, y, z); } \ + float test_##FN##f(float x, float y, float z) { return __builtin_##FN##f(x, y, z); } \ + long double test_##FN##l(long double x, long double y, long double z) { return __builtin_##FN##l(x, y, z); } + + /* Test FP functions taking three arguments, two FP and the third is + of a supplied type. */ + #define FPTEST3ARG3(FN, TYPE) \ + double test_##FN(double x, double y, TYPE z) { return __builtin_##FN(x, y, z); } \ + float test_##FN##f(float x, float y, TYPE z) { return __builtin_##FN##f(x, y, z); } \ + long double test_##FN##l(long double x, long double y, TYPE z) { return __builtin_##FN##l(x, y, z); } + + /* Test FP functions taking three FP arguments. The second and third + are FP pointers. The return type is void. */ + #define FPTEST3FPP23VOID(FN) \ + double test_##FN(double x, double *y, double *z) { __builtin_##FN(x, y, z); return *y * *z; } \ + float test_##FN##f(float x, float *y, float *z) { __builtin_##FN##f(x, y, z); return *y * *z; } \ + long double test_##FN##l(long double x, long double *y, long double *z) { __builtin_##FN##l(x, y, z); return *y * *z; } + + /* Test Complex functions taking one Complex argument. */ + #define CPTEST1(FN) \ + _Complex double test_##FN(_Complex double x) { return __builtin_##FN(x); } \ + _Complex float test_##FN##f(_Complex float x) { return __builtin_##FN##f(x); } \ + _Complex long double test_##FN##l(_Complex long double x) { return __builtin_##FN##l(x); } + + /* Test Complex functions taking one Complex argument and returning an FP type. */ + #define CPTEST1RETFP(FN) \ + double test_##FN(_Complex double x) { return __builtin_##FN(x); } \ + float test_##FN##f(_Complex float x) { return __builtin_##FN##f(x); } \ + long double test_##FN##l(_Complex long double x) { return __builtin_##FN##l(x); } + + /* Test Complex functions taking two Complex arguments. */ + #define CPTEST2(FN) \ + _Complex double test_##FN(_Complex double x, _Complex double y) { return __builtin_##FN(x,y); } \ + _Complex float test_##FN##f(_Complex float x, _Complex float y) { return __builtin_##FN##f(x,y); } \ + _Complex long double test_##FN##l(_Complex long double x, _Complex long double y) { return __builtin_##FN##l(x,y); } + + + /* Keep this list sorted alphabetically by function name. */ + FPTEST1 (acos) + FPTEST1 (acosh) + FPTEST1 (asin) + FPTEST1 (asinh) + FPTEST1 (atan) + FPTEST2 (atan2) + FPTEST1 (atanh) + FPTEST1 (cbrt) + FPTEST1 (ceil) + FPTEST2 (copysign) + FPTEST1 (cos) + FPTEST1 (cosh) + FPTEST2 (drem) + FPTEST1 (erf) + FPTEST1 (erfc) + FPTEST1 (exp) + FPTEST1 (exp10) + FPTEST1 (exp2) + FPTEST1 (expm1) + FPTEST1 (fabs) + FPTEST2 (fdim) + FPTEST1 (floor) + FPTEST3 (fma) + FPTEST2 (fmax) + FPTEST2 (fmin) + FPTEST2 (fmod) + FPTEST2ARG2 (frexp, int *) + FPTEST1 (gamma) + FPTEST0 (huge_val) + FPTEST2 (hypot) + FPTEST1 (ilogb) + FPTEST0 (inf) + FPTEST1 (j0) + FPTEST1 (j1) + FPTEST2ARG1 (jn, int) + FPTEST2ARG2 (ldexp, int) + FPTEST1 (lgamma) + FPTEST1RET (llrint, long long) + FPTEST1RET (llround, long long) + FPTEST1 (log) + FPTEST1 (log10) + FPTEST1 (log1p) + FPTEST1 (log2) + FPTEST1 (logb) + FPTEST1RET (lrint, long) + FPTEST1RET (lround, long) + FPTEST2FPP2 (modf) + FPTEST1 (nearbyint) + FPTEST2 (nextafter) + FPTEST2 (nexttoward) + FPTEST2 (pow) + FPTEST1 (pow10) + FPTEST2 (remainder) + FPTEST3ARG3 (remquo, int *) + FPTEST1 (rint) + FPTEST1 (round) + FPTEST2 (scalb) + FPTEST2ARG2 (scalbln, int) + FPTEST2ARG2 (scalbn, int) + FPTEST1 (significand) + FPTEST1 (sin) + FPTEST3FPP23VOID (sincos) + FPTEST1 (sinh) + FPTEST1 (sqrt) + FPTEST1 (tan) + FPTEST1 (tanh) + FPTEST1 (tgamma) + FPTEST1 (trunc) + FPTEST1 (y0) + FPTEST1 (y1) + FPTEST2ARG1 (yn, int) + + /* Keep this list sorted alphabetically by function name. */ + CPTEST1RETFP (cabs) + CPTEST1 (cacos) + CPTEST1 (cacosh) + CPTEST1RETFP (carg) + CPTEST1 (casin) + CPTEST1 (casinh) + CPTEST1 (catan) + CPTEST1 (catanh) + CPTEST1 (ccos) + CPTEST1 (ccosh) + CPTEST1 (cexp) + CPTEST1RETFP (cimag) + /*CPTEST1 (clog)*/ + CPTEST1 (conj) + CPTEST2 (cpow) + CPTEST1 (cproj) + CPTEST1RETFP (creal) + CPTEST1 (csin) + CPTEST1 (csinh) + CPTEST1 (csqrt) + CPTEST1 (ctan) + CPTEST1 (ctanh) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-20.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-20.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-20.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-20.c 2003-12-24 06:52:27.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that built-in math function constant folding doesn't break + anything and produces the expected results. + + Written by Roger Sayle, 8th June 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + #include "builtins-config.h" + + extern void link_error(void); + + void test1(double x) + { + if (cos(x) != cos(-x)) + link_error (); + + if (sin(x)/cos(x) != tan(x)) + link_error (); + + if (cos(x)/sin(x) != 1.0/tan(x)) + link_error (); + + if (tan(x)*cos(x) != sin(x)) + link_error (); + + if (cos(x)*tan(x) != sin(x)) + link_error (); + } + + void test2(double x, double y) + { + if (-tan(x-y) != tan(y-x)) + link_error (); + + if (-sin(x-y) != sin(y-x)) + link_error (); + } + + void test1f(float x) + { + if (cosf(x) != cosf(-x)) + link_error (); + + #ifdef HAVE_C99_RUNTIME + if (sinf(x)/cosf(x) != tanf(x)) + link_error (); + + if (cosf(x)/sinf(x) != 1.0f/tanf(x)) + link_error (); + + if (tanf(x)*cosf(x) != sinf(x)) + link_error (); + + if (cosf(x)*tanf(x) != sinf(x)) + link_error (); + #endif + } + + void test2f(float x, float y) + { + if (-tanf(x-y) != tanf(y-x)) + link_error (); + + if (-sinf(x-y) != sinf(y-x)) + link_error (); + } + + + void test1l(long double x) + { + if (cosl(x) != cosl(-x)) + link_error (); + + #ifdef HAVE_C99_RUNTIME + if (sinl(x)/cosl(x) != tanl(x)) + link_error (); + + if (cosl(x)/sinl(x) != 1.0l/tanl(x)) + link_error (); + + if (tanl(x)*cosl(x) != sinl(x)) + link_error (); + + if (cosl(x)*tanl(x) != sinl(x)) + link_error (); + #endif + } + + void test2l(long double x, long double y) + { + if (-tanl(x-y) != tanl(y-x)) + link_error (); + + if (-sinl(x-y) != sinl(y-x)) + link_error (); + } + + int main() + { + test1 (1.0); + test2 (1.0, 2.0); + + test1f (1.0f); + test2f (1.0f, 2.0f); + + test1l (1.0l); + test2l (1.0l, 2.0l); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-21.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-21.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-21.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-21.c 2003-06-12 12:53:01.000000000 +0000 *************** *** 0 **** --- 1,55 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that built-in math function constant folding doesn't + cause any problems for the compiler. + + Written by Roger Sayle, 7th June 2003. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double test1(double x) + { + return fabs(x*x); + } + + double test2(double x) + { + return fabs(sqrt(x)+2.0); + } + + double test3(double x) + { + return fabs(3.0*exp(x)); + } + + float test1f(float x) + { + return fabsf(x*x); + } + + float test2f(float x) + { + return fabsf(sqrtf(x)+2.0f); + } + + float test3f(float x) + { + return fabsf(3.0f*expf(x)); + } + + long double test1l(long double x) + { + return fabsl(x*x); + } + + long double test2l(long double x) + { + return fabsl(sqrtl(x)+2.0l); + } + + long double test3l(long double x) + { + return fabsl(3.0l*expl(x)); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-22.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-22.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-22.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-22.c 2003-06-15 13:32:31.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Related to PR optimization/10764 */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double exp(double x); + + double foo(double x) + { + return exp(exp(x)); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-23.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-23.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-23.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-23.c 2003-06-16 12:53:16.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Related to PR optimization/10764 */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double atan(double x); + + double foo(double x) + { + return atan(atan(x)); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-24.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-24.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-24.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-24.c 2003-06-24 02:20:12.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that the RTL expansion of floating point exponentiation by + a constant integer doesn't break anything and produces the expected + results. + + Written by Roger Sayle, 20th June 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern double pow(double,double); + extern void abort(void); + + double foo (double x) + { + return pow (x, 6); + } + + double bar (double x) + { + return pow (x, -4); + } + + int main() + { + if (foo (2.0) != 64.0) + abort (); + + if (bar (2.0) != 0.0625) + abort (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-25.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-25.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-25.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-25.c 2003-07-03 21:38:55.000000000 +0000 *************** *** 0 **** --- 1,188 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 28th June 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2" } */ + + extern void link_error(void); + + extern double trunc(double); + extern double floor(double); + extern double ceil(double); + + extern float truncf(float); + extern float floorf(float); + extern float ceilf(float); + + extern long double truncl(long double); + extern long double floorl(long double); + extern long double ceill(long double); + + void test() + { + if (trunc (0.0) != 0.0) + link_error (); + if (floor (0.0) != 0.0) + link_error (); + if (ceil (0.0) != 0.0) + link_error (); + + if (trunc (6.0) != 6.0) + link_error (); + if (floor (6.0) != 6.0) + link_error (); + if (ceil (6.0) != 6.0) + link_error (); + + if (trunc (-8.0) != -8.0) + link_error (); + if (floor (-8.0) != -8.0) + link_error (); + if (ceil (-8.0) != -8.0) + link_error (); + + if (trunc (3.2) != 3.0) + link_error (); + if (floor (3.2) != 3.0) + link_error (); + if (ceil (3.2) != 4.0) + link_error (); + + if (trunc (-2.8) != -2.0) + link_error (); + if (floor (-2.8) != -3.0) + link_error (); + if (ceil (-2.8) != -2.0) + link_error (); + + if (trunc (0.01) != 0.0) + link_error (); + if (floor (0.01) != 0.0) + link_error (); + if (ceil (0.01) != 1.0) + link_error (); + + if (trunc (-0.7) != 0.0) + link_error (); + if (floor (-0.7) != -1.0) + link_error (); + if (ceil (-0.7) != 0.0) + link_error (); + } + + void testf() + { + if (truncf (0.0f) != 0.0f) + link_error (); + if (floorf (0.0f) != 0.0f) + link_error (); + if (ceilf (0.0f) != 0.0f) + link_error (); + + if (truncf (6.0f) != 6.0f) + link_error (); + if (floorf (6.0f) != 6.0f) + link_error (); + if (ceilf (6.0f) != 6.0f) + link_error (); + + if (truncf (-8.0f) != -8.0f) + link_error (); + if (floorf (-8.0f) != -8.0f) + link_error (); + if (ceilf (-8.0f) != -8.0f) + link_error (); + + if (truncf (3.2f) != 3.0f) + link_error (); + if (floorf (3.2f) != 3.0f) + link_error (); + if (ceilf (3.2f) != 4.0f) + link_error (); + + if (truncf (-2.8f) != -2.0f) + link_error (); + if (floorf (-2.8f) != -3.0f) + link_error (); + if (ceilf (-2.8f) != -2.0f) + link_error (); + + if (truncf (0.01f) != 0.0f) + link_error (); + if (floorf (0.01f) != 0.0f) + link_error (); + if (ceilf (0.01f) != 1.0f) + link_error (); + + if (truncf (-0.7f) != 0.0f) + link_error (); + if (floorf (-0.7f) != -1.0f) + link_error (); + if (ceilf (-0.7f) != 0.0f) + link_error (); + } + + void testl() + { + if (truncl (0.0l) != 0.0l) + link_error (); + if (floorl (0.0l) != 0.0l) + link_error (); + if (ceill (0.0l) != 0.0l) + link_error (); + + if (truncl (6.0l) != 6.0l) + link_error (); + if (floorl (6.0l) != 6.0l) + link_error (); + if (ceill (6.0l) != 6.0l) + link_error (); + + if (truncl (-8.0l) != -8.0l) + link_error (); + if (floorl (-8.0l) != -8.0l) + link_error (); + if (ceill (-8.0l) != -8.0l) + link_error (); + + if (truncl (3.2l) != 3.0l) + link_error (); + if (floorl (3.2l) != 3.0l) + link_error (); + if (ceill (3.2l) != 4.0l) + link_error (); + + if (truncl (-2.8l) != -2.0l) + link_error (); + if (floorl (-2.8l) != -3.0l) + link_error (); + if (ceill (-2.8l) != -2.0l) + link_error (); + + if (truncl (0.01l) != 0.0l) + link_error (); + if (floorl (0.01l) != 0.0l) + link_error (); + if (ceill (0.01l) != 1.0l) + link_error (); + + if (truncl (-0.7l) != 0.0l) + link_error (); + if (floorl (-0.7l) != -1.0l) + link_error (); + if (ceill (-0.7l) != 0.0l) + link_error (); + } + + int main() + { + test (); + testf (); + testl (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-26.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-26.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-26.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-26.c 2003-07-03 21:38:55.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 28th June 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + extern double trunc(double); + extern double floor(double); + extern double ceil(double); + + extern float truncf(float); + extern float floorf(float); + extern float ceilf(float); + + extern long double truncl(long double); + extern long double floorl(long double); + extern long double ceill(long double); + + void test(double x) + { + if (trunc (trunc (x)) != trunc (x)) + link_error (); + if (trunc (floor (x)) != floor (x)) + link_error (); + if (trunc (ceil (x)) != ceil (x)) + link_error (); + + if (floor (trunc (x)) != trunc (x)) + link_error (); + if (floor (floor (x)) != floor (x)) + link_error (); + if (floor (ceil (x)) != ceil (x)) + link_error (); + + if (ceil (trunc (x)) != trunc (x)) + link_error (); + if (ceil (floor (x)) != floor (x)) + link_error (); + if (ceil (ceil (x)) != ceil (x)) + link_error (); + } + + void testf(float x) + { + if (truncf (truncf (x)) != truncf (x)) + link_error (); + if (truncf (floorf (x)) != floorf (x)) + link_error (); + if (truncf (ceilf (x)) != ceilf (x)) + link_error (); + + if (floorf (truncf (x)) != truncf (x)) + link_error (); + if (floorf (floorf (x)) != floorf (x)) + link_error (); + if (floorf (ceilf (x)) != ceilf (x)) + link_error (); + + if (ceilf (truncf (x)) != truncf (x)) + link_error (); + if (ceilf (floorf (x)) != floorf (x)) + link_error (); + if (ceilf (ceilf (x)) != ceilf (x)) + link_error (); + } + + void testl(long double x) + { + if (truncl (truncl (x)) != truncl (x)) + link_error (); + if (truncl (floorl (x)) != floorl (x)) + link_error (); + if (truncl (ceill (x)) != ceill (x)) + link_error (); + + if (floorl (truncl (x)) != truncl (x)) + link_error (); + if (floorl (floorl (x)) != floorl (x)) + link_error (); + if (floorl (ceill (x)) != ceill (x)) + link_error (); + + if (ceill (truncl (x)) != truncl (x)) + link_error (); + if (ceill (floorl (x)) != floorl (x)) + link_error (); + if (ceill (ceill (x)) != ceill (x)) + link_error (); + } + + + int main() + { + test (3.2); + testf (3.2f); + testl (3.2l); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-27.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-27.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-27.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-27.c 2003-08-01 00:36:53.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything and produces the expected results. + + Written by Roger Sayle, 29th July 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + extern double pow(double,double); + + void test(double x) + { + if (pow(x,2.0) != x*x) + link_error (); + + if (x*pow(x,2.0) != pow(x,3.0)) + link_error (); + + if (pow(x,2.0)*x != pow(x,3.0)) + link_error (); + + if (pow(x,3.0) != x*x*x) + link_error (); + + if (pow(x,2.0)*x != x*x*x) + link_error (); + + if (x*pow(x,2.0) != x*x*x) + link_error (); + + if (pow(x,3.0)/x != pow(x,2.0)) + link_error (); + + if (pow(x,3.0)/x != x*x) + link_error (); + } + + int main() + { + test (2.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-28.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-28.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-28.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-28.c 2003-10-20 22:03:34.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Test that creal and cimag built-in functions do not return lvalues. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + extern float crealf (float _Complex); + extern double creal (double _Complex); + extern long double creall (long double _Complex); + + extern float cimagf (float _Complex); + extern double cimag (double _Complex); + extern long double cimagl (long double _Complex); + + float _Complex fc; + double _Complex dc; + long double _Complex ldc; + + void + foo (void) + { + crealf (fc) = 0; /* { dg-error "lvalue" "crealf not lvalue" } */ + cimagf (fc) = 0; /* { dg-error "lvalue" "cimagf not lvalue" } */ + creal (dc) = 0; /* { dg-error "lvalue" "creal not lvalue" } */ + cimag (dc) = 0; /* { dg-error "lvalue" "cimag not lvalue" } */ + creall (ldc) = 0; /* { dg-error "lvalue" "creall not lvalue" } */ + cimagl (ldc) = 0; /* { dg-error "lvalue" "cimagl not lvalue" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-2.c 2003-06-06 16:15:50.000000000 +0000 *************** *** 0 **** --- 1,205 ---- + /* Copyright (C) 2002 Free Software Foundation. + + Verify that built-in math function constant folding doesn't + cause any problems for the compiler. + + Written by Roger Sayle, 16th August 2002. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + double test1(double x) + { + return log(exp(x)); + } + + double test2(double x) + { + return exp(log(x)); + } + + double test3(double x) + { + return sqrt(exp(x)); + } + + double test4(double x) + { + return log(sqrt(x)); + } + + double test5(double x, double y) + { + return sqrt(x)*sqrt(y); + } + + double test6(double x, double y) + { + return exp(x)*exp(y); + } + + double test7(double x, double y) + { + return x/exp(y); + } + + double test8(double x) + { + return fabs(sqrt(x)); + } + + double test9(double x) + { + return fabs(exp(x)); + } + + double test10(double x) + { + return tan(atan(x)); + } + + double test11(double x) + { + return fabs(fabs(x)); + } + + double test12(double x) + { + return fabs(atan(x)); + } + + double test13(double x) + { + return fabs(pow(2.0,x)); + } + + float test1f(float x) + { + return logf(expf(x)); + } + + float test2f(float x) + { + return expf(logf(x)); + } + + float test3f(float x) + { + return sqrtf(expf(x)); + } + + float test4f(float x) + { + return logf(sqrtf(x)); + } + + float test5f(float x, float y) + { + return sqrtf(x)*sqrtf(y); + } + + float test6f(float x, float y) + { + return expf(x)*expf(y); + } + + float test7f(float x, float y) + { + return x/expf(y); + } + + float test8f(float x) + { + return fabsf(sqrtf(x)); + } + + float test9f(float x) + { + return fabsf(expf(x)); + } + + float test10f(float x) + { + return tanf(atanf(x)); + } + + float test11f(float x) + { + return fabsf(fabsf(x)); + } + + float test12f(float x) + { + return fabsf(atanf(x)); + } + + float test13f(float x) + { + return fabsf(powf(2.0f,x)); + } + + long double test1l(long double x) + { + return logl(expl(x)); + } + + long double test2l(long double x) + { + return expl(logl(x)); + } + + long double test3l(long double x) + { + return sqrtl(expl(x)); + } + + long double test4l(long double x) + { + return logl(sqrtl(x)); + } + + long double test5l(long double x, long double y) + { + return sqrtl(x)*sqrtl(y); + } + + long double test6l(long double x, long double y) + { + return expl(x)*expl(y); + } + + long double test7l(long double x, long double y) + { + return x/expl(y); + } + + long double test8l(long double x) + { + return fabsl(sqrtl(x)); + } + + long double test9l(long double x) + { + return fabsl(expl(x)); + } + + long double test10l(long double x) + { + return tanl(atanl(x)); + } + + long double test11l(long double x) + { + return fabsl(fabsl(x)); + } + + long double test12l(long double x) + { + return fabsl(atanl(x)); + } + + long double test13l(long double x) + { + return fabsl(powl(2.0l,x)); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-30.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-30.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-30.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-30.c 2004-03-20 10:22:39.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* { dg-do compile } */ + /* { dg-options "-Wall -Wshadow" } */ + + extern double strtod (const char *, char **); + #define UNUSED __attribute__ ((unused)) + + /* A built-in function may be overridden by an old-style definition + specifying too few arguments... */ + double cos () + { /* { dg-warning "shadowing built-in" } */ + return strtod ("nan", 0); + } + + /* the right number, but the wrong type, arguments... */ + double sin (foo) + int foo UNUSED; /* { dg-warning "shadowing built-in" } */ + { + return strtod ("nan", 0); + } + + /* or too many arguments. */ + long double cosl (foo, bar) + long double foo UNUSED; /* { dg-warning "shadowing built-in" } */ + int bar UNUSED; + { + return strtod ("nan", 0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-35.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-35.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-35.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-35.c 2004-03-20 10:22:39.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* Test that nan functions are not built-in in C90 mode. Bug 14635. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-std=c89" } */ + + int nan, nanf, nanl, nans, nansf, nansl; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-6.c 2003-03-20 17:48:26.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that constant folding comparisons against built-in math functions + don't cause any problems for the compiler, and produce expected results. + + Written by Roger Sayle, 15th March 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -ffast-math" } */ + + #include + + extern void abort (void); + extern double sqrt (double); + + int test1(double x) + { + return sqrt(x) < -9.0; + } + + int test2(double x) + { + return sqrt(x) > -9.0; + } + + int test3(double x) + { + return sqrt(x) < 9.0; + } + + int test4(double x) + { + return sqrt(x) > 9.0; + } + + int test5(double x) + { + return sqrt(x) < DBL_MAX; + } + + int test6(double x) + { + return sqrt(x) > DBL_MAX; + } + + int main() + { + double x; + + x = 80.0; + if (test1 (x)) + abort (); + if (! test2 (x)) + abort (); + if (! test3 (x)) + abort (); + if (test4 (x)) + abort (); + if (! test5 (x)) + abort (); + if (test6 (x)) + abort (); + + x = 100.0; + if (test1 (x)) + abort (); + if (! test2 (x)) + abort (); + if (test3 (x)) + abort (); + if (! test4 (x)) + abort (); + if (! test5 (x)) + abort (); + if (test6 (x)) + abort (); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-7.c 2003-06-04 12:20:39.000000000 +0000 *************** *** 0 **** --- 1,45 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that built-in math function constant folding of constant + arguments is correctly performed by the by the compiler. + + Written by Roger Sayle, 30th March 2003. */ + + /* { dg-do link } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void link_error(void); + + void test(double x) + { + if (pow (x, 1.0) != x) + link_error (); + if (tan (atan (x)) != x) + link_error (); + } + + void testf(float x) + { + if (powf (x, 1.0f) != x) + link_error (); + if (tanf (atanf (x)) != x) + link_error (); + } + + void testl(long double x) + { + if (powl (x, 1.0l) != x) + link_error (); + if (tanl (atanl (x)) != x) + link_error (); + } + + int main() + { + test (2.0); + testf (2.0f); + testl (2.0l); + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-8.c 2003-03-31 14:30:29.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that built-in math function constant folding of functions + with one constant argument is correctly performed by the compiler. + + Written by Roger Sayle, 30th March 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern void abort(void); + + void test(double x) + { + if (pow(x,-1.0) != 1.0/x) + abort (); + + if (pow(x,2.0) != x*x) + abort (); + + if (pow(x,-2.0) != 1.0/(x*x)) + abort (); + + if (pow(x,0.5) != sqrt(x)) + abort (); + } + + int main() + { + test (1.0); + test (2.0); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-9.c gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-9.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-9.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-9.c 2003-04-08 23:24:38.000000000 +0000 *************** *** 0 **** --- 1,103 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Check that constant folding of built-in math functions doesn't + break anything. + + Written by Roger Sayle, 2nd April 2003. */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -ffast-math" } */ + + extern double log(double); + extern double exp(double); + extern double sqrt(double); + extern double pow(double,double); + + extern float logf(float); + extern float expf(float); + extern float sqrtf(float); + extern float powf(float,float); + + extern long double logl(long double); + extern long double expl(long double); + extern long double sqrtl(long double); + extern long double powl(long double,long double); + + + double test1(double x, double y) + { + return log(pow(x,y)); + } + + double test2(double x, double y) + { + return sqrt(pow(x,y)); + } + + double test3(double x, double y) + { + return pow(exp(x),y); + } + + double test4(double x, double y) + { + return pow(sqrt(x),y); + } + + double test5(double x, double y, double z) + { + return pow(pow(x,y),z); + } + + + float test1f(float x, float y) + { + return logf(powf(x,y)); + } + + float test2f(float x, float y) + { + return sqrtf(powf(x,y)); + } + + float test3f(float x, float y) + { + return powf(expf(x),y); + } + + float test4f(float x, float y) + { + return powf(sqrtf(x),y); + } + + float test5f(float x, float y, float z) + { + return powf(powf(x,y),z); + } + + + long double test1l(long double x, long double y) + { + return logl(powl(x,y)); + } + + long double test2l(long double x, long double y) + { + return sqrtl(powl(x,y)); + } + + long double test3l(long double x, long double y) + { + return powl(expl(x),y); + } + + long double test4l(long double x, long double y) + { + return powl(sqrtl(x),y); + } + + long double test5l(long double x, long double y, long double z) + { + return powl(powl(x,y),z); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-config.h gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-config.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/builtins-config.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/builtins-config.h 2004-03-04 02:41:31.000000000 +0000 *************** *** 0 **** --- 1,33 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Define macros useful in tests for bulitin functions. */ + + /* Define HAVE_C99_RUNTIME if the entire C99 runtime is available on + the target system. The value of HAVE_C99_RUNTIME should be the + same as the value of TARGET_C99_FUNCTIONS in the GCC machine + description. (Perhaps GCC should predefine a special macro + indicating whether or not TARGET_C99_FUNCTIONS is set, but it does + not presently do that.) */ + + #if defined(__hppa) && defined(__hpux) + /* PA HP-UX doesn't have the entire C99 runtime. */ + #elif defined(__sun) + /* Solaris doesn't have the entire C99 runtime. */ + #elif defined(__sgi) + /* Irix6 doesn't have the entire C99 runtime. */ + #else + /* Newlib has the "f" variants of the math functions, but not the "l" + variants. TARGET_C99_FUNCTIONS is only defined if all C99 + functions are present. Therefore, on systems using newlib, tests + of builtins will fail for both the "f" and the "l" variants, and we + should therefore not define HAVE_C99_RUNTIME. Including + gives us a way of seeing if _NEWLIB_VERSION is defined. Include + would work too, but the GLIBC math inlines cause us to + generate inferior code, which causes the test to fail, so it is + not safe to include . */ + #include + #ifdef _NEWLIB_VERSION + #else + #define HAVE_C99_RUNTIME + #endif + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c90-const-expr-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/c90-const-expr-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c90-const-expr-2.c 2000-11-14 19:34:22.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c90-const-expr-2.c 2003-11-12 06:44:46.000000000 +0000 *************** int *a; *** 14,25 **** int b; long *c; /* Assertion that n is a null pointer constant: so the conditional expression has type 'int *' instead of 'void *'. */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a null pointer constant: so the conditional ! expresions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (n))) --- 14,31 ---- int b; long *c; + #ifdef _LP64 + #define ZERO 0L + #else + #define ZERO 0 + #endif + /* Assertion that n is a null pointer constant: so the conditional expression has type 'int *' instead of 'void *'. */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a null pointer constant: so the conditional ! expressions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (n))) *************** foo (void) *** 30,36 **** ASSERT_NPC ((void *)0); ASSERT_NOT_NPC ((void *)(void *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(char *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ! ASSERT_NOT_NPC ((void *)(0, 0)); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(&"Foobar"[0] - &"Foobar"[0])); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ /* This last one is a null pointer constant in C99 only. */ ASSERT_NOT_NPC ((void *)(1 ? 0 : (0, 0))); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ --- 36,42 ---- ASSERT_NPC ((void *)0); ASSERT_NOT_NPC ((void *)(void *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(char *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ! ASSERT_NOT_NPC ((void *)(0, ZERO)); /* { dg-bogus "incompatible" "bogus null pointer constant" } */ ASSERT_NOT_NPC ((void *)(&"Foobar"[0] - &"Foobar"[0])); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ /* This last one is a null pointer constant in C99 only. */ ASSERT_NOT_NPC ((void *)(1 ? 0 : (0, 0))); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c90-const-expr-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/c90-const-expr-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c90-const-expr-3.c 2002-02-12 21:33:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c90-const-expr-3.c 2003-07-01 12:01:44.000000000 +0000 *************** *** 6,11 **** --- 6,12 ---- to give the correct behavior to conforming programs. */ static const int ZERO = 0; + static const double DZERO = 0; int *a; int b; *************** long *c; *** 16,22 **** */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a constant zero: so the conditional ! expresions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (void *)(__SIZE_TYPE__)(n))) --- 17,23 ---- */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a constant zero: so the conditional ! expressions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (void *)(__SIZE_TYPE__)(n))) *************** foo (void) *** 36,39 **** --- 37,45 ---- ASSERT_NOT_NPC ((char) ZERO); ASSERT_NPC ((int) 0); ASSERT_NOT_NPC ((int) ZERO); + ASSERT_NPC ((int) 0.0); + ASSERT_NOT_NPC ((int) DZERO); + ASSERT_NOT_NPC ((int) +0.0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ + ASSERT_NOT_NPC ((int) (0.0+0.0)); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ + ASSERT_NOT_NPC ((int) (double)0.0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c90-dupqual-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/c90-dupqual-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c90-dupqual-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c90-dupqual-1.c 2004-03-11 00:46:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c90-idem-qual-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/c90-idem-qual-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c90-idem-qual-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c90-idem-qual-3.c 2004-01-07 19:40:03.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test for idempotent type qualifiers: in C99 only. Test duplicate + type qualifiers with array element types. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-std=iso9899:1990 -pedantic-errors" } */ + + typedef const int cia[2]; + const cia a; /* { dg-bogus "warning" "warning in place of error" } */ + /* { dg-error "duplicate" "duplicate type qualifier error" { target *-*-* } 8 } */ + const cia b[2]; /* { dg-bogus "warning" "warning in place of error" } */ + /* { dg-error "duplicate" "duplicate type qualifier error" { target *-*-* } 10 } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c90-init-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/c90-init-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c90-init-1.c 2001-01-12 23:18:05.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c90-init-1.c 2004-02-08 20:56:54.000000000 +0000 *************** struct A { *** 7,16 **** int B; short C[2]; }; ! int a[10] = { 10, [4] = 15 }; /* { dg-error "ISO C89 forbids specifying subobject to initialize" } */ ! struct A b = { .B = 2 }; /* { dg-error "ISO C89 forbids specifying subobject to initialize" } */ ! struct A c[] = { [3].C[1] = 1 }; /* { dg-error "ISO C89 forbids specifying subobject to initialize" } */ ! struct A d[] = { [4 ... 6].C[0 ... 1] = 2 }; /* { dg-error "(forbids specifying range of elements to initialize)|(ISO C89 forbids specifying subobject to initialize)" } */ int e[] = { [2] 2 }; /* { dg-error "use of designated initializer without" } */ struct A f = { C: { 0, 1 } }; /* { dg-error "use of designated initializer with " } */ int g; --- 7,16 ---- int B; short C[2]; }; ! int a[10] = { 10, [4] = 15 }; /* { dg-error "ISO (C89|C90) forbids specifying subobject to initialize" } */ ! struct A b = { .B = 2 }; /* { dg-error "ISO (C89|C90) forbids specifying subobject to initialize" } */ ! struct A c[] = { [3].C[1] = 1 }; /* { dg-error "ISO (C89|C90) forbids specifying subobject to initialize" } */ ! struct A d[] = { [4 ... 6].C[0 ... 1] = 2 }; /* { dg-error "(forbids specifying range of elements to initialize)|(ISO (C89|C90) forbids specifying subobject to initialize)" } */ int e[] = { [2] 2 }; /* { dg-error "use of designated initializer without" } */ struct A f = { C: { 0, 1 } }; /* { dg-error "use of designated initializer with " } */ int g; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-arraydecl-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-arraydecl-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-arraydecl-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-arraydecl-2.c 2003-10-24 15:30:37.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Test for C99 array declarators: expression must be an + assignment-expression. PR 11943. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + + void + foo (void) + { + int a[2, 3]; /* { dg-error "parse|syntax" "bad array declarator" } */ + void b(int x[2, 3]); /* { dg-error "parse|syntax" "bad array declarator" } */ + void c(int [2, 3]); /* { dg-error "parse|syntax" "bad array declarator" } */ + void d(int *x[restrict 2, 3]); /* { dg-error "parse|syntax" "bad array declarator" } */ + void e(int *x[static restrict 2, 3]); /* { dg-error "parse|syntax" "bad array declarator" } */ + void f(int *x[restrict static 2, 3]); /* { dg-error "parse|syntax" "bad array declarator" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-bool-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-bool-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-bool-1.c 2002-09-16 13:29:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-bool-1.c 2003-08-20 07:06:47.000000000 +0000 *************** main (void) *** 228,236 **** abort (); if ((u |= 2) != 1) abort (); ! /* ??? A bit queer, since this gets optimized to ((u = (u != 3)) != 1) ! early in semantic analysis, which then yields the warning below. */ ! if ((u ^= 3) != 1) /* { dg-warning "always true due to limited range" } */ abort (); /* Test comma expressions. */ u = 1; --- 228,234 ---- abort (); if ((u |= 2) != 1) abort (); ! if ((u ^= 3) != 1) abort (); /* Test comma expressions. */ u = 1; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-const-expr-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-const-expr-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-const-expr-2.c 2000-11-14 19:34:22.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-const-expr-2.c 2003-11-12 11:19:09.000000000 +0000 *************** int *a; *** 14,25 **** int b; long *c; /* Assertion that n is a null pointer constant: so the conditional expression has type 'int *' instead of 'void *'. */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a null pointer constant: so the conditional ! expresions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (n))) --- 14,31 ---- int b; long *c; + #ifdef _LP64 + #define ZERO 0L + #else + #define ZERO 0 + #endif + /* Assertion that n is a null pointer constant: so the conditional expression has type 'int *' instead of 'void *'. */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a null pointer constant: so the conditional ! expressions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (n))) *************** foo (void) *** 30,36 **** ASSERT_NPC ((void *)0); ASSERT_NOT_NPC ((void *)(void *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(char *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ! ASSERT_NOT_NPC ((void *)(0, 0)); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(&"Foobar"[0] - &"Foobar"[0])); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ /* This last one is a null pointer constant in C99 only. */ ASSERT_NPC ((void *)(1 ? 0 : (0, 0))); --- 36,42 ---- ASSERT_NPC ((void *)0); ASSERT_NOT_NPC ((void *)(void *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ASSERT_NOT_NPC ((void *)(char *)0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ ! ASSERT_NOT_NPC ((void *)(0, ZERO)); /* { dg-bogus "incompatible" "bogus null pointer constant" } */ ASSERT_NOT_NPC ((void *)(&"Foobar"[0] - &"Foobar"[0])); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ /* This last one is a null pointer constant in C99 only. */ ASSERT_NPC ((void *)(1 ? 0 : (0, 0))); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-const-expr-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-const-expr-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-const-expr-3.c 2002-02-12 21:33:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-const-expr-3.c 2003-07-01 12:01:44.000000000 +0000 *************** *** 6,11 **** --- 6,12 ---- to give the correct behavior to conforming programs. */ static const int ZERO = 0; + static const double DZERO = 0; int *a; int b; *************** long *c; *** 16,22 **** */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a constant zero: so the conditional ! expresions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (void *)(__SIZE_TYPE__)(n))) --- 17,23 ---- */ #define ASSERT_NPC(n) (b = *(1 ? a : (n))) /* Assertion that n is not a constant zero: so the conditional ! expressions has type 'void *' instead of 'int *'. */ #define ASSERT_NOT_NPC(n) (c = (1 ? a : (void *)(__SIZE_TYPE__)(n))) *************** foo (void) *** 36,39 **** --- 37,45 ---- ASSERT_NOT_NPC ((char) ZERO); ASSERT_NPC ((int) 0); ASSERT_NOT_NPC ((int) ZERO); + ASSERT_NPC ((int) 0.0); + ASSERT_NOT_NPC ((int) DZERO); + ASSERT_NOT_NPC ((int) +0.0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ + ASSERT_NOT_NPC ((int) (0.0+0.0)); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ + ASSERT_NOT_NPC ((int) (double)0.0); /* { dg-bogus "incompatible" "bogus null pointer constant" { xfail *-*-* } } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-dupqual-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-dupqual-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-dupqual-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-dupqual-1.c 2004-03-11 00:46:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-idem-qual-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-idem-qual-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-idem-qual-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-idem-qual-3.c 2004-01-07 19:40:03.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test for idempotent type qualifiers: in C99 only. Test duplicate + type qualifiers with array element types. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + + typedef const int cia[2]; + const cia a; /* { dg-bogus "duplicate" "duplicate type qualifier warning" } */ + const cia b[2]; /* { dg-bogus "duplicate" "duplicate type qualifier warning" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/c99-restrict-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/c99-restrict-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/c99-restrict-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/c99-restrict-2.c 2003-10-24 12:00:25.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test for restrict: in C99 only. Test handling of arrays of restricted + pointers. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + + typedef int *ipa[2]; + + int *restrict x[2]; + restrict ipa y; + + void f(int *restrict a[2], restrict ipa b, int *restrict c[restrict]); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cast-function-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cast-function-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cast-function-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cast-function-1.c 2004-02-23 12:46:57.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + /* PR c/12085 */ + /* Origin: David Hollenberg */ + + /* Verify that the compiler doesn't inline a function at + a calling point where it is viewed with a different + prototype than the actual one. */ + + /* { dg-do compile } */ + /* { dg-options "-O3" } */ + + int foo1(int); + int foo2(); + + typedef struct { + double d; + int a; + } str_t; + + void bar(void) + { + double d; + int i; + str_t s; + + d = ((double (*) (int)) foo1) (i); /* { dg-warning "non-compatible|abort" } */ + i = ((int (*) (double)) foo1) (d); /* { dg-warning "non-compatible|abort" } */ + s = ((str_t (*) (int)) foo1) (i); /* { dg-warning "non-compatible|abort" } */ + ((void (*) (int)) foo1) (d); /* { dg-warning "non-compatible|abort" } */ + i = ((int (*) (int)) foo1) (i); /* { dg-bogus "non-compatible|abort" } */ + (void) foo1 (i); /* { dg-bogus "non-compatible|abort" } */ + + d = ((double (*) (int)) foo2) (i); /* { dg-warning "non-compatible|abort" } */ + i = ((int (*) (double)) foo2) (d); /* { dg-bogus "non-compatible|abort" } */ + s = ((str_t (*) (int)) foo2) (i); /* { dg-warning "non-compatible|abort" } */ + ((void (*) (int)) foo2) (d); /* { dg-warning "non-compatible|abort" } */ + i = ((int (*) (int)) foo2) (i); /* { dg-bogus "non-compatible|abort" } */ + (void) foo2 (i); /* { dg-bogus "non-compatible|abort" } */ + } + + int foo1(int arg) + { + return arg; + } + + int foo2(arg) + int arg; + { + return arg; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cast-lvalue-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cast-lvalue-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cast-lvalue-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cast-lvalue-1.c 2003-10-22 22:28:39.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test for deprecation of casts as lvalues. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + int x; + + void + foo (void) + { + (char) x = 1; /* { dg-warning "lvalue" "cast as lvalue deprecated" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-10.c gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-10.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-10.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-10.c 2003-12-19 14:00:53.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + /* { dg-do run { target i?86-*-linux* x86_64-*-linux* ia64-*-linux* alpha*-*-linux* powerpc*-*-linux* s390*-*-linux* sparc*-*-linux* mips*-*-linux* } } */ + /* { dg-options "-fasynchronous-unwind-tables -fexceptions -O2" } */ + /* Verify that cleanups work with exception handling through signal frames + on alternate stack. */ + + #include + #include + #include + #include + + static _Unwind_Reason_Code + force_unwind_stop (int version, _Unwind_Action actions, + _Unwind_Exception_Class exc_class, + struct _Unwind_Exception *exc_obj, + struct _Unwind_Context *context, + void *stop_parameter) + { + if (actions & _UA_END_OF_STACK) + abort (); + return _URC_NO_REASON; + } + + static void force_unwind () + { + struct _Unwind_Exception *exc = malloc (sizeof (*exc)); + exc->exception_class = 0; + exc->exception_cleanup = 0; + + #ifndef __USING_SJLJ_EXCEPTIONS__ + _Unwind_ForcedUnwind (exc, force_unwind_stop, 0); + #else + _Unwind_SjLj_ForcedUnwind (exc, force_unwind_stop, 0); + #endif + + abort (); + } + + int count; + char *null; + + static void counter (void *p __attribute__((unused))) + { + ++count; + } + + static void handler (void *p __attribute__((unused))) + { + if (count != 2) + abort (); + exit (0); + } + + static int __attribute__((noinline)) fn5 () + { + char dummy __attribute__((cleanup (counter))); + force_unwind (); + return 0; + } + + static void fn4 (int sig, siginfo_t *info, void *ctx) + { + char dummy __attribute__((cleanup (counter))); + fn5 (); + null = NULL; + } + + static void fn3 () + { + abort (); + } + + static int __attribute__((noinline)) fn2 () + { + *null = 0; + fn3 (); + return 0; + } + + static int __attribute__((noinline)) fn1 () + { + stack_t ss; + struct sigaction s; + + ss.ss_size = 4 * sysconf (_SC_PAGESIZE); + if (ss.ss_size < SIGSTKSZ) + ss.ss_size = SIGSTKSZ; + ss.ss_sp = malloc (ss.ss_size); + if (ss.ss_sp == NULL) + exit (1); + ss.ss_flags = 0; + if (sigaltstack (&ss, NULL) < 0) + exit (1); + + sigemptyset (&s.sa_mask); + s.sa_sigaction = fn4; + s.sa_flags = SA_ONESHOT | SA_ONSTACK; + sigaction (SIGSEGV, &s, NULL); + fn2 (); + return 0; + } + + static int __attribute__((noinline)) fn0 () + { + char dummy __attribute__((cleanup (handler))); + fn1 (); + null = 0; + return 0; + } + + int main() + { + fn0 (); + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-11.c gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-11.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-11.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-11.c 2003-12-19 14:00:53.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + /* { dg-do run { target i?86-*-linux* x86_64-*-linux* ia64-*-linux* alpha*-*-linux* powerpc*-*-linux* s390*-*-linux* sparc*-*-linux* mips*-*-linux* } } */ + /* { dg-options "-fasynchronous-unwind-tables -fexceptions -O2" } */ + /* Verify that cleanups work with exception handling through realtime signal + frames on alternate stack. */ + + #include + #include + #include + #include + + static _Unwind_Reason_Code + force_unwind_stop (int version, _Unwind_Action actions, + _Unwind_Exception_Class exc_class, + struct _Unwind_Exception *exc_obj, + struct _Unwind_Context *context, + void *stop_parameter) + { + if (actions & _UA_END_OF_STACK) + abort (); + return _URC_NO_REASON; + } + + static void force_unwind () + { + struct _Unwind_Exception *exc = malloc (sizeof (*exc)); + exc->exception_class = 0; + exc->exception_cleanup = 0; + + #ifndef __USING_SJLJ_EXCEPTIONS__ + _Unwind_ForcedUnwind (exc, force_unwind_stop, 0); + #else + _Unwind_SjLj_ForcedUnwind (exc, force_unwind_stop, 0); + #endif + + abort (); + } + + int count; + char *null; + + static void counter (void *p __attribute__((unused))) + { + ++count; + } + + static void handler (void *p __attribute__((unused))) + { + if (count != 2) + abort (); + exit (0); + } + + static int __attribute__((noinline)) fn5 () + { + char dummy __attribute__((cleanup (counter))); + force_unwind (); + return 0; + } + + static void fn4 (int sig, siginfo_t *info, void *ctx) + { + char dummy __attribute__((cleanup (counter))); + fn5 (); + null = NULL; + } + + static void fn3 () + { + abort (); + } + + static int __attribute__((noinline)) fn2 () + { + *null = 0; + fn3 (); + return 0; + } + + static int __attribute__((noinline)) fn1 () + { + stack_t ss; + struct sigaction s; + + ss.ss_size = 4 * sysconf (_SC_PAGESIZE); + if (ss.ss_size < SIGSTKSZ) + ss.ss_size = SIGSTKSZ; + ss.ss_sp = malloc (ss.ss_size); + if (ss.ss_sp == NULL) + exit (1); + ss.ss_flags = 0; + if (sigaltstack (&ss, NULL) < 0) + exit (1); + + sigemptyset (&s.sa_mask); + s.sa_sigaction = fn4; + s.sa_flags = SA_ONESHOT | SA_ONSTACK | SA_SIGINFO; + sigaction (SIGSEGV, &s, NULL); + fn2 (); + return 0; + } + + static int __attribute__((noinline)) fn0 () + { + char dummy __attribute__((cleanup (handler))); + fn1 (); + null = 0; + return 0; + } + + int main() + { + fn0 (); + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-8.c 2003-07-16 11:52:55.000000000 +0000 *************** *** 0 **** --- 1,97 ---- + /* { dg-do run { target i?86-*-linux* x86_64-*-linux* ia64-*-linux* alpha*-*-linux* powerpc*-*-linux* s390*-*-linux* sparc*-*-linux* } } */ + /* { dg-options "-fasynchronous-unwind-tables -fexceptions -O2" } */ + /* Verify that cleanups work with exception handling through signal + frames. */ + + #include + #include + #include + + static _Unwind_Reason_Code + force_unwind_stop (int version, _Unwind_Action actions, + _Unwind_Exception_Class exc_class, + struct _Unwind_Exception *exc_obj, + struct _Unwind_Context *context, + void *stop_parameter) + { + if (actions & _UA_END_OF_STACK) + abort (); + return _URC_NO_REASON; + } + + static void force_unwind () + { + struct _Unwind_Exception *exc = malloc (sizeof (*exc)); + exc->exception_class = 0; + exc->exception_cleanup = 0; + + #ifndef __USING_SJLJ_EXCEPTIONS__ + _Unwind_ForcedUnwind (exc, force_unwind_stop, 0); + #else + _Unwind_SjLj_ForcedUnwind (exc, force_unwind_stop, 0); + #endif + + abort (); + } + + int count; + char *null; + + static void counter (void *p __attribute__((unused))) + { + ++count; + } + + static void handler (void *p __attribute__((unused))) + { + if (count != 2) + abort (); + exit (0); + } + + static int __attribute__((noinline)) fn5 () + { + char dummy __attribute__((cleanup (counter))); + force_unwind (); + return 0; + } + + static void fn4 (int sig) + { + char dummy __attribute__((cleanup (counter))); + fn5 (); + null = NULL; + } + + static void fn3 () + { + abort (); + } + + static int __attribute__((noinline)) fn2 () + { + *null = 0; + fn3 (); + return 0; + } + + static int __attribute__((noinline)) fn1 () + { + signal (SIGSEGV, fn4); + fn2 (); + return 0; + } + + static int __attribute__((noinline)) fn0 () + { + char dummy __attribute__((cleanup (handler))); + fn1 (); + null = 0; + return 0; + } + + int main() + { + fn0 (); + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-9.c gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-9.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cleanup-9.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cleanup-9.c 2003-10-15 22:24:56.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + /* { dg-do run { target i?86-*-linux* x86_64-*-linux* ia64-*-linux* alpha*-*-linux* powerpc*-*-linux* s390*-*-linux* sparc*-*-linux* mips*-*-linux* } } */ + /* { dg-options "-fasynchronous-unwind-tables -fexceptions -O2" } */ + /* Verify that cleanups work with exception handling through realtime + signal frames. */ + + #include + #include + #include + + static _Unwind_Reason_Code + force_unwind_stop (int version, _Unwind_Action actions, + _Unwind_Exception_Class exc_class, + struct _Unwind_Exception *exc_obj, + struct _Unwind_Context *context, + void *stop_parameter) + { + if (actions & _UA_END_OF_STACK) + abort (); + return _URC_NO_REASON; + } + + static void force_unwind () + { + struct _Unwind_Exception *exc = malloc (sizeof (*exc)); + exc->exception_class = 0; + exc->exception_cleanup = 0; + + #ifndef __USING_SJLJ_EXCEPTIONS__ + _Unwind_ForcedUnwind (exc, force_unwind_stop, 0); + #else + _Unwind_SjLj_ForcedUnwind (exc, force_unwind_stop, 0); + #endif + + abort (); + } + + int count; + char *null; + + static void counter (void *p __attribute__((unused))) + { + ++count; + } + + static void handler (void *p __attribute__((unused))) + { + if (count != 2) + abort (); + exit (0); + } + + static int __attribute__((noinline)) fn5 () + { + char dummy __attribute__((cleanup (counter))); + force_unwind (); + return 0; + } + + static void fn4 (int sig, siginfo_t *info, void *ctx) + { + char dummy __attribute__((cleanup (counter))); + fn5 (); + null = NULL; + } + + static void fn3 () + { + abort (); + } + + static int __attribute__((noinline)) fn2 () + { + *null = 0; + fn3 (); + return 0; + } + + static int __attribute__((noinline)) fn1 () + { + struct sigaction s; + sigemptyset (&s.sa_mask); + s.sa_sigaction = fn4; + s.sa_flags = SA_ONESHOT | SA_SIGINFO; + sigaction (SIGSEGV, &s, NULL); + fn2 (); + return 0; + } + + static int __attribute__((noinline)) fn0 () + { + char dummy __attribute__((cleanup (handler))); + fn1 (); + null = 0; + return 0; + } + + int main() + { + fn0 (); + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/compat-common.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/compat-common.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/compat-common.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/compat-common.h 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* Several of the binary compatibility tests use these macros to + allow debugging the test or tracking down a failure by getting an + indication of whether each individual check passed or failed. + When DBG is defined, each check is shown by a dot (pass) or 'F' + (fail) rather than aborting as soon as a failure is detected. */ + + #ifdef DBG + #include + #define DEBUG_INIT setbuf (stdout, NULL); + #define DEBUG_FPUTS(x) fputs (x, stdout) + #define DEBUG_DOT putc ('.', stdout) + #define DEBUG_NL putc ('\n', stdout) + #define DEBUG_FAIL putc ('F', stdout); fails++ + #define DEBUG_CHECK { DEBUG_FAIL; } else { DEBUG_DOT; } + #define DEBUG_FINI if (fails) DEBUG_FPUTS ("failed\n"); \ + else DEBUG_FPUTS ("passed\n"); + #else + #define DEBUG_INIT + #define DEBUG_FPUTS(x) + #define DEBUG_DOT + #define DEBUG_NL + #define DEBUG_FAIL abort () + #define DEBUG_CHECK abort (); + #define DEBUG_FINI + #endif + + extern void abort (void); + extern int fails; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/compat.exp gcc-3.4.0/gcc/testsuite/gcc.dg/compat/compat.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/compat.exp 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/compat.exp 2003-05-05 21:59:35.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + # Copyright (C) 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. + # + # This file was written by Janis Johnson, + + + # Test interoperability of two compilers that follow the same ABI. + # + # Break simple tests into two pieces and see that they work when linked + # together. If an alternate compiler is specified then the two main + # pieces of each test are compiled with different compilers. The + # alternate compiler must be installed, and is specified by defining + # ALT_CC_UNDER_TEST in the environment. + + if $tracelevel then { + strace $tracelevel + } + + global GCC_UNDER_TEST + + # Load procedures from common libraries. + load_lib standard.exp + load_lib gcc.exp + + # + # compat-use-alt-compiler -- make the alternate compiler the default + # + proc compat-use-alt-compiler { } { + global GCC_UNDER_TEST ALT_CC_UNDER_TEST + global same_alt + + # We don't need to do this if the alternate compiler is actually + # the same as the compiler under test. + if { $same_alt == 0 } then { + set GCC_UNDER_TEST $ALT_CC_UNDER_TEST + } + } + + # + # compat-use-tst-compiler -- make compiler under test the default + # + proc compat-use-tst-compiler { } { + global GCC_UNDER_TEST save_gcc_under_test + global same_alt + + # We don't need to do this if the alternate compiler is actually + # the same as the compiler under test. + + if { $same_alt == 0 } then { + set GCC_UNDER_TEST $save_gcc_under_test + } + } + + # Load the language-independent compabibility support procedures. + # This must be done after the compat-use-*-compiler definitions. + load_lib compat.exp + + gcc_init + + # Save variables for the C compiler under test, which each test will + # change a couple of times. This must be done after calling gcc-init. + set save_gcc_under_test $GCC_UNDER_TEST + + # Define an identifier for use with this suite to avoid name conflicts + # with other compat tests running at the same time. + set sid "c_compat" + + # Find out whether there is an alternate compiler to test. If the + # variable is defined but is set to "same", that means we use the same + # compiler twice, which is meaningful if the two parts of COMPAT_OPTIONS + # are different. + set use_alt 0 + set same_alt 0 + if [info exists ALT_CC_UNDER_TEST] then { + set use_alt 1 + if [string match "same" $ALT_CC_UNDER_TEST] then { + set same_alt 1 + } + } + + # Main loop. + foreach src [lsort [find $srcdir/$subdir *_main.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 + } + + compat-execute $src $sid $use_alt + } + + # Restore the original compiler under test. + compat-use-tst-compiler diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_main.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test passing function pointers. */ + + extern void fnptr_by_value_1_x (void); + extern void exit (int); + int fails; + + int + main () + { + fnptr_by_value_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_x.c 2003-07-04 16:44:37.000000000 +0000 *************** *** 0 **** --- 1,163 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + typedef void (*fpi)(int); + typedef void (*fpd)(double); + + extern void test1a (fpi); + extern void test1b (fpi, int); + extern void test1c (double, fpd); + extern void test2a (fpi, fpd); + extern void test2b (fpi, fpd, int); + extern void test2c (fpi, int, fpd); + extern void test2d (int, fpi, fpd); + extern void test2e (fpi, fpd, int, double); + extern void test2f (fpi, int, fpd, double); + extern void test2g (fpi, int, double, fpd); + extern void test2h (double, fpd, fpi, int); + extern void test2i (double, fpd, int, fpi); + extern void test2j (int, double, fpi, fpd); + extern void testva (int, ...); + + int f1_val; + double f2_val; + + void f1 (int i) { f1_val = i; } + void f2 (double x) { f2_val = x; } + + void + checki (int x, int v) + { + if (x != v) + DEBUG_CHECK + } + + void + checkd (double x, double v) + { + if (x != v) + DEBUG_CHECK + } + + void + testit (void) + { + DEBUG_FPUTS ("test1a: "); + test1a (f1); + checki (f1_val, 1); + DEBUG_NL; + DEBUG_FPUTS ("test1b: "); + test1b (f1, 2); + checki (f1_val, 2); + DEBUG_NL; + DEBUG_FPUTS ("test1c: "); + test1c (3.0, f2); + checkd (f2_val, 3.0); + DEBUG_NL; + DEBUG_FPUTS ("test2a: "); + test2a (f1, f2); + checki (f1_val, 10); + checkd (f2_val, 10.0); + DEBUG_NL; + DEBUG_FPUTS ("test2b: "); + test2b (f1, f2, 11); + checki (f1_val, 11); + checkd (f2_val, 11.0); + DEBUG_NL; + DEBUG_FPUTS ("test2c: "); + test2c (f1, 12, f2); + checki (f1_val, 12); + checkd (f2_val, 12.0); + DEBUG_NL; + DEBUG_FPUTS ("test2d: "); + test2d (13, f1, f2); + checki (f1_val, 13); + checkd (f2_val, 13.0); + DEBUG_NL; + DEBUG_FPUTS ("test2e: "); + test2e (f1, f2, 14, 15.0); + checki (f1_val, 14); + checkd (f2_val, 15.0); + DEBUG_NL; + DEBUG_FPUTS ("test2f: "); + test2f (f1, 16, f2, 17.0); + checki (f1_val, 16); + checkd (f2_val, 17.0); + DEBUG_NL; + DEBUG_FPUTS ("test2g: "); + test2g (f1, 18, 19.0, f2); + checki (f1_val, 18); + checkd (f2_val, 19.0); + DEBUG_NL; + DEBUG_FPUTS ("test2h: "); + test2h (20.0, f2, f1, 21); + checkd (f2_val, 20.0); + checki (f1_val, 21); + DEBUG_NL; + DEBUG_FPUTS ("test2i: "); + test2i (22.0, f2, 23, f1); + checkd (f2_val, 22.0); + checki (f1_val, 23); + DEBUG_NL; + DEBUG_FPUTS ("test2j: "); + test2j (24, 25.0, f1, f2); + checki (f1_val, 24); + checkd (f2_val, 25.0); + if (test_va) + { + DEBUG_NL; + DEBUG_FPUTS ("testva: "); + testva (1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (2, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (3, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (4, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (5, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (6, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (7, f1, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (8, f1, f1, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (9, f1, f1, f1, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (10, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (11, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1); + DEBUG_NL; + DEBUG_FPUTS (" "); + testva (12, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1, f1); + } + DEBUG_NL; + } + + void + fnptr_by_value_1_x () + { + DEBUG_INIT + testit (); + DEBUG_FINI + + if (fails != 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fnptr-by-value-1_y.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + #include + + #include "compat-common.h" + + typedef void (*fpi)(int); + typedef void (*fpd)(double); + + extern int f1_val; + extern void checki (int, int); + + void + test1a (fpi f) + { + (*f)(1); + } + + void + test1b (fpi f, int i) + { + (*f)(i); + } + + void + test1c (double x, fpd f) + { + (*f)(x); + } + + void + test2a (fpi f1, fpd f2) + { + (*f1)(10); + (*f2)(10.0); + } + + void + test2b (fpi f1, fpd f2, int i) + { + (*f1)(i); + (*f2)((double)i); + } + + void + test2c (fpi f1, int i, fpd f2) + { + (*f1)(i); + (*f2)((double)i); + } + + void + test2d (int i, fpi f1, fpd f2) + { + (*f1)(i); + (*f2)((double)i); + } + + void + test2e (fpi f1, fpd f2, int i, double x) + { + (*f1)(i); + (*f2)(x); + } + + void + test2f (fpi f1, int i, fpd f2, double x) + { + (*f1)(i); + (*f2)(x); + } + + void + test2g (fpi f1, int i, double x, fpd f2) + { + (*f1)(i); + (*f2)(x); + } + + void + test2h (double x, fpd f1, fpi f2, int i) + { + (*f1)(x); + (*f2)(i); + } + + void + test2i (double x, fpd f1, int i, fpi f2) + { + (*f1)(x); + (*f2)(i); + } + + void + test2j (int i, double x, fpi f1, fpd f2) + { + (*f1)(i); + (*f2)(x); + } + + void + testva (int n, ...) + { + int i; + va_list ap; + va_start (ap, n); + for (i = 0; i < n; i++) + { + fpi fp = va_arg (ap, fpi); + (*fp)(i); + checki (f1_val, i); + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-check.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-check.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-check.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-check.h 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Function definitions that are used by multiple tests. */ + + void checkSfd (Sfd x, double y) + { if (x.f != y || x.d != y+1) DEBUG_CHECK } + void checkSfl (Sfl x, double y) + { if (x.f != y || x.l != y+1) DEBUG_CHECK } + void checkSdf (Sdf x, double y) + { if (x.d != y || x.f != y+1) DEBUG_CHECK } + void checkSdl (Sdl x, double y) + { if (x.d != y || x.l != y+1) DEBUG_CHECK } + void checkSlf (Slf x, double y) + { if (x.l != y || x.f != y+1) DEBUG_CHECK } + void checkSld (Sld x, double y) + { if (x.l != y || x.d != y+1) DEBUG_CHECK } + + void checkSfdl (Sfdl x, double y) + { if (x.f != y || x.d != y+1 || x.l != y+2) DEBUG_CHECK } + void checkSfld (Sfld x, double y) + { if (x.f != y || x.l != y+1 || x.d != y+2) DEBUG_CHECK } + void checkSdfl (Sdfl x, double y) + { if (x.d != y || x.f != y+1 || x.l != y+2) DEBUG_CHECK } + void checkSdlf (Sdlf x, double y) + { if (x.d != y || x.l != y+1 || x.f != y+2) DEBUG_CHECK } + void checkSlfd (Slfd x, double y) + { if (x.l != y || x.f != y+1 || x.d != y+2) DEBUG_CHECK } + void checkSldf (Sldf x, double y) + { if (x.l != y || x.d != y+1 || x.f != y+2) DEBUG_CHECK } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-defs.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-defs.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-defs.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-defs.h 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Type definitions that are used by multiple tests. */ + + typedef struct { float f; double d; } Sfd; + typedef struct { float f; long double l; } Sfl; + typedef struct { double d; float f; } Sdf; + typedef struct { double d; long double l; } Sdl; + typedef struct { long double l; float f; } Slf; + typedef struct { long double l; double d; } Sld; + + typedef struct { float f; double d; long double l; } Sfdl; + typedef struct { float f; long double l; double d; } Sfld; + typedef struct { double d; float f; long double l; } Sdfl; + typedef struct { double d; long double l; float f; } Sdlf; + typedef struct { long double l; float f; double d; } Slfd; + typedef struct { long double l; double d; float f; } Sldf; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-init.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-init.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp2-struct-init.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp2-struct-init.h 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* Function definitions that are used by multiple tests. */ + + void initSfd (Sfd *p, double y) + { p->f = y; p->d = y+1; } + void initSfl (Sfl *p, double y) + { p->f = y; p->l = y+1; } + void initSdf (Sdf *p, double y) + { p->d = y; p->f = y+1; } + void initSdl (Sdl *p, double y) + { p->d = y; p->l = y+1; } + void initSlf (Slf *p, double y) + { p->l = y; p->f = y+1; } + void initSld (Sld *p, double y) + { p->l = y; p->d = y+1; } + + void initSfdl (Sfdl *p, double y) + { p->f = y; p->d = y+1; p->l = y+2; } + void initSfld (Sfld *p, double y) + { p->f = y; p->l = y+1; p->d = y+2; } + void initSdfl (Sdfl *p, double y) + { p->d = y; p->f = y+1; p->l = y+2; } + void initSdlf (Sdlf *p, double y) + { p->d = y; p->l = y+1; p->f = y+2; } + void initSlfd (Slfd *p, double y) + { p->l = y; p->f = y+1; p->d = y+2; } + void initSldf (Sldf *p, double y) + { p->l = y; p->d = y+1; p->f = y+2; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-check.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-check.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-check.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-check.h 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,71 ---- + /* Function definitions that are used by multiple tests. */ + + #define CHECKS(NAME,TYPEM) \ + void checkS##NAME##1 (S##NAME##1 x, TYPEM y) \ + { if (x.a != y) DEBUG_CHECK } \ + void checkS##NAME##2 (S##NAME##2 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 ) DEBUG_CHECK } \ + void checkS##NAME##3 (S##NAME##3 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 ) \ + DEBUG_CHECK } \ + void checkS##NAME##4 (S##NAME##4 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3) \ + DEBUG_CHECK } \ + void checkS##NAME##5 (S##NAME##5 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4) DEBUG_CHECK } \ + void checkS##NAME##6 (S##NAME##6 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5) DEBUG_CHECK } \ + void checkS##NAME##7 (S##NAME##7 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6) \ + DEBUG_CHECK } \ + void checkS##NAME##8 (S##NAME##8 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7) DEBUG_CHECK } \ + void checkS##NAME##9 (S##NAME##9 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8) DEBUG_CHECK } \ + void checkS##NAME##10 (S##NAME##10 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9) \ + DEBUG_CHECK } \ + void checkS##NAME##11 (S##NAME##11 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10) DEBUG_CHECK } \ + void checkS##NAME##12 (S##NAME##12 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10 || x.l != y+11) DEBUG_CHECK } \ + void checkS##NAME##13 (S##NAME##13 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10 || x.l != y+11 || x.m != y+12) \ + DEBUG_CHECK } \ + void checkS##NAME##14 (S##NAME##14 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10 || x.l != y+11 || x.m != y+12 \ + || x.n != y+13) DEBUG_CHECK } \ + void checkS##NAME##15 (S##NAME##15 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10 || x.l != y+11 || x.m != y+12 \ + || x.n != y+13 || x.o != y+14) DEBUG_CHECK } \ + void checkS##NAME##16 (S##NAME##16 x, TYPEM y) \ + { if (x.a != y || x.b != y+1 || x.c != y+2 || x.d != y+3 \ + || x.e != y+4 || x.f != y+5 || x.g != y+6 \ + || x.h != y+7 || x.i != y+8 || x.j != y+9 \ + || x.k != y+10 || x.l != y+11 || x.m != y+12 \ + || x.n != y+13 || x.o != y+14 || x.p != y+15) \ + DEBUG_CHECK } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-defs.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-defs.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-defs.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-defs.h 2003-05-20 22:15:45.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + /* Type definitions that are used by multiple tests. */ + + #define DEFS(NAME,TYPEM) \ + typedef struct { TYPEM a; } S##NAME##1; \ + typedef struct { TYPEM a; TYPEM b; } S##NAME##2; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; } S##NAME##3; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; } \ + S##NAME##4; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; } \ + S##NAME##5; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; } S##NAME##6; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; } S##NAME##7; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; } S##NAME##8; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; } \ + S##NAME##9; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; } \ + S##NAME##10; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; } S##NAME##11; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; TYPEM l; } S##NAME##12; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; TYPEM l; TYPEM m; } S##NAME##13; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; TYPEM l; TYPEM m; TYPEM n; } \ + S##NAME##14; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; TYPEM l; TYPEM m; TYPEM n; TYPEM o; } \ + S##NAME##15; \ + typedef struct { TYPEM a; TYPEM b; TYPEM c; TYPEM d; TYPEM e; \ + TYPEM f; TYPEM g; TYPEM h; TYPEM i; TYPEM j; \ + TYPEM k; TYPEM l; TYPEM m; TYPEM n; TYPEM o; \ + TYPEM p; } S##NAME##16; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-init.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-init.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-init.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-init.h 2003-05-20 22:15:45.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + /* Function definitions that are used by multiple tests. */ + + #define INITS(NAME,TYPEM) \ + void initS##NAME##1 (S##NAME##1 *p, TYPEM y) \ + { p->a = y; } \ + void initS##NAME##2 (S##NAME##2 *p, TYPEM y) \ + { p->a = y; p->b = y+1; } \ + void initS##NAME##3 (S##NAME##3 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; } \ + void initS##NAME##4 (S##NAME##4 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; } \ + void initS##NAME##5 (S##NAME##5 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; } \ + void initS##NAME##6 (S##NAME##6 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; } \ + void initS##NAME##7 (S##NAME##7 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; } \ + void initS##NAME##8 (S##NAME##8 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; } \ + void initS##NAME##9 (S##NAME##9 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; } \ + void initS##NAME##10 (S##NAME##10 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; } \ + void initS##NAME##11 (S##NAME##11 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; } \ + void initS##NAME##12 (S##NAME##12 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; p->l = y+11; } \ + void initS##NAME##13 (S##NAME##13 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; p->l = y+11; p->m = y+12; } \ + void initS##NAME##14 (S##NAME##14 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; p->l = y+11; p->m = y+12; p->n = y+13; } \ + void initS##NAME##15 (S##NAME##15 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; p->l = y+11; p->m = y+12; p->n = y+13; \ + p->o = y+14; } \ + void initS##NAME##16 (S##NAME##16 *p, TYPEM y) \ + { p->a = y; p->b = y+1; p->c = y+2; p->d = y+3; p->e = y+4; \ + p->f = y+5; p->g = y+6; p->h = y+7; p->i = y+8; p->j = y+9; \ + p->k = y+10; p->l = y+11; p->m = y+12; p->n = y+13; \ + p->o = y+14; p->p = y+15; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-x.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-x.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-x.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-x.h 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,136 ---- + #define TEST(TYPE,MTYPE) \ + 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, MTYPE x); \ + 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, (MTYPE)1); \ + init##TYPE ( &g2s##TYPE, (MTYPE)2); \ + init##TYPE ( &g3s##TYPE, (MTYPE)3); \ + init##TYPE ( &g4s##TYPE, (MTYPE)4); \ + init##TYPE ( &g5s##TYPE, (MTYPE)5); \ + init##TYPE ( &g6s##TYPE, (MTYPE)6); \ + init##TYPE ( &g7s##TYPE, (MTYPE)7); \ + init##TYPE ( &g8s##TYPE, (MTYPE)8); \ + init##TYPE ( &g9s##TYPE, (MTYPE)9); \ + init##TYPE (&g10s##TYPE, (MTYPE)10); \ + init##TYPE (&g11s##TYPE, (MTYPE)11); \ + init##TYPE (&g12s##TYPE, (MTYPE)12); \ + init##TYPE (&g13s##TYPE, (MTYPE)13); \ + init##TYPE (&g14s##TYPE, (MTYPE)14); \ + init##TYPE (&g15s##TYPE, (MTYPE)15); \ + init##TYPE (&g16s##TYPE, (MTYPE)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; \ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-y.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-y.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-y.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/fp-struct-test-by-value-y.h 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + #define TEST(TYPE,TYPE2) \ + 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; \ + \ + extern void check##TYPE (TYPE x, TYPE2 y); \ + \ + void \ + checkg##TYPE (void) \ + { \ + check##TYPE ( g1s##TYPE, (TYPE2)1); \ + check##TYPE ( g2s##TYPE, (TYPE2)2); \ + check##TYPE ( g3s##TYPE, (TYPE2)3); \ + check##TYPE ( g4s##TYPE, (TYPE2)4); \ + check##TYPE ( g5s##TYPE, (TYPE2)5); \ + check##TYPE ( g6s##TYPE, (TYPE2)6); \ + check##TYPE ( g7s##TYPE, (TYPE2)7); \ + check##TYPE ( g8s##TYPE, (TYPE2)8); \ + check##TYPE ( g9s##TYPE, (TYPE2)9); \ + check##TYPE ( g10s##TYPE, (TYPE2)10); \ + check##TYPE ( g11s##TYPE, (TYPE2)11); \ + check##TYPE ( g12s##TYPE, (TYPE2)12); \ + check##TYPE ( g13s##TYPE, (TYPE2)13); \ + check##TYPE ( g14s##TYPE, (TYPE2)14); \ + check##TYPE ( g15s##TYPE, (TYPE2)15); \ + check##TYPE ( g16s##TYPE, (TYPE2)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, (TYPE2)1); \ + check##TYPE (s2, (TYPE2)2); \ + check##TYPE (s3, (TYPE2)3); \ + check##TYPE (s4, (TYPE2)4); \ + check##TYPE (s5, (TYPE2)5); \ + check##TYPE (s6, (TYPE2)6); \ + check##TYPE (s7, (TYPE2)7); \ + check##TYPE (s8, (TYPE2)8); \ + check##TYPE (s9, (TYPE2)9); \ + check##TYPE (s10, (TYPE2)10); \ + check##TYPE (s11, (TYPE2)11); \ + check##TYPE (s12, (TYPE2)12); \ + check##TYPE (s13, (TYPE2)13); \ + check##TYPE (s14, (TYPE2)14); \ + check##TYPE (s15, (TYPE2)15); \ + check##TYPE (s16, (TYPE2)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, (TYPE2)i+1); \ + } \ + va_end (ap); \ + } \ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-check.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-check.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-check.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-check.h 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* Function definitions that are used by multiple tests. */ + + void checkScd (Scd x, int i) + { if (x.c != (char)i || x.d != (double)i+1) DEBUG_CHECK } + void checkScdc (Scdc x, int i) + { if (x.c != (char)i || x.d != (double)i+1 || x.b != (char)i+2) DEBUG_CHECK } + void checkSd (Sd x, int i) + { if (x.d != (double)i) DEBUG_CHECK } + void checkSdi (Sdi x, int i) + { if (x.d != (double)i || x.i != i+1) DEBUG_CHECK } + void checkScsds (Scsds x, int i) + { if (x.c != (char)i || x.sd.d != (double)i+1) DEBUG_CHECK } + void checkScsdsc (Scsdsc x, int i) + { if (x.c != (char)i || x.sd.d != (double)i+1 || x.b != (char)i+2) DEBUG_CHECK } + void checkScsdis (Scsdis x, int i) + { if (x.c != (char)i || x.sdi.d != (double)i+1 || x.sdi.i != i+2) DEBUG_CHECK } + void checkScsdisc (Scsdisc x, int i) + { if (x.c != (char)i || x.sdi.d != (double)i+1 || x.sdi.i != i+2 + || x.b != (char)i+3) DEBUG_CHECK } + void checkSsds (Ssds x, int i) + { if (x.sd.d != (double)i) DEBUG_CHECK } + void checkSsdsc (Ssdsc x, int i) + { if (x.sd.d != (double)i || x.c != (char)i+1) DEBUG_CHECK } + void checkScssdss (Scssdss x, int i) + { if (x.c != (char)i || x.ssds.sd.d != (double)i+1) DEBUG_CHECK } + void checkScssdssc (Scssdssc x, int i) + { if (x.c != (char)i || x.ssds.sd.d != (double)i+1 + || x.b != (char)i+2) DEBUG_CHECK } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-defs.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-defs.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-defs.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-defs.h 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Type definitions that are used by multiple tests. */ + + typedef struct { char c; double d; } Scd; + typedef struct { char c; double d; char b; } Scdc; + typedef struct { double d; } Sd; + typedef struct { double d; int i; } Sdi; + typedef struct { char c; Sd sd; } Scsds; + typedef struct { char c; Sd sd; char b; } Scsdsc; + typedef struct { char c; Sdi sdi; } Scsdis; + typedef struct { char c; Sdi sdi; char b; } Scsdisc; + typedef struct { Sd sd; } Ssds; + typedef struct { Sd sd; char c; } Ssdsc; + typedef struct { char c; Ssds ssds; } Scssdss; + typedef struct { char c; Ssds ssds; char b; } Scssdssc; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-init.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-init.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/mixed-struct-init.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/mixed-struct-init.h 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* Function definitions that are used by multiple tests. */ + + void initScd (Scd *p, int i) + { p->c = (char)i; p->d = (double)i+1; } + void initScdc (Scdc *p, int i) + { p->c = (char)i; p->d = (double)i+1; p->b = (char)i+2; } + void initSd (Sd *p, int i) + { p->d = (double)i; } + void initSdi (Sdi *p, int i) + { p->d = (double)i; p->i = i+1; } + void initScsds (Scsds *p, int i) + { p->c = (char)i; p->sd.d = (double)i+1; } + void initScsdsc (Scsdsc *p, int i) + { p->c = (char)i; p->sd.d = (double)i+1; p->b = (char)i+2; } + void initScsdis (Scsdis *p, int i) + { p->c = (char)i; p->sdi.d = (double)i+1; p->sdi.i = i+2; } + void initScsdisc (Scsdisc *p, int i) + { p->c = (char)i; p->sdi.d = (double)i+1; p->sdi.i = i+2; p->b = (char)i+3; } + void initSsds (Ssds *p, int i) + { p->sd.d = (double)i; } + void initSsdsc (Ssdsc *p, int i) + { p->sd.d = (double)i; p->c = (char)i+1; } + void initScssdss (Scssdss *p, int i) + { p->c = (char)i; p->ssds.sd.d = (double)i+1; } + void initScssdssc (Scssdssc *p, int i) + { p->c = (char)i; p->ssds.sd.d = (double)i+1; p->b = (char)i+2; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test passing scalars by value. This test includes scalar types that + are supported by va_arg. */ + + extern void scalar_by_value_1_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_by_value_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,180 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16); \ + extern void testva##NAME (int n, ...); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v + INITVAL) \ + DEBUG_CHECK \ + } \ + \ + void \ + test2_##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08) \ + { \ + test##NAME (x01, g02##NAME, x02, g04##NAME, \ + x03, g06##NAME, x04, g08##NAME, \ + x05, g10##NAME, x06, g12##NAME, \ + x07, g14##NAME, x08, g16##NAME); \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test: "); \ + test##NAME (g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" testva:"); \ + DEBUG_NL; \ + testva##NAME (1, \ + g01##NAME); \ + DEBUG_NL; \ + testva##NAME (2, \ + g01##NAME, g02##NAME); \ + DEBUG_NL; \ + testva##NAME (3, \ + g01##NAME, g02##NAME, g03##NAME); \ + DEBUG_NL; \ + testva##NAME (4, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME); \ + DEBUG_NL; \ + testva##NAME (5, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME); \ + DEBUG_NL; \ + testva##NAME (6, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME); \ + DEBUG_NL; \ + testva##NAME (7, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME); \ + DEBUG_NL; \ + testva##NAME (8, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME); \ + DEBUG_NL; \ + testva##NAME (9, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME); \ + DEBUG_NL; \ + testva##NAME (10, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME); \ + DEBUG_NL; \ + testva##NAME (11, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME); \ + DEBUG_NL; \ + testva##NAME (12, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME); \ + DEBUG_NL; \ + testva##NAME (13, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME); \ + DEBUG_NL; \ + testva##NAME (14, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME); \ + DEBUG_NL; \ + testva##NAME (15, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME); \ + DEBUG_NL; \ + testva##NAME (16, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test2: "); \ + test2_##NAME (g01##NAME, g03##NAME, g05##NAME, g07##NAME, \ + g09##NAME, g11##NAME, g13##NAME, g15##NAME); \ + DEBUG_NL; \ + } + + T(ui, unsigned int, 51) + T(si, int, (-55)) + T(ul, unsigned long, 61) + T(sl, long, (-66)) + T(ull, unsigned long long, 71) + T(sll, long long, (-77)) + T(d, double, 91.0) + T(ld, long double, 92.0) + + #undef T + + void + scalar_by_value_1_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(ui) + T(si) + T(ul) + T(sl) + T(ull) + T(sll) + T(d) + T(ld) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-1_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,95 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1); \ + check##NAME (g02##NAME, 2); \ + check##NAME (g03##NAME, 3); \ + check##NAME (g04##NAME, 4); \ + check##NAME (g05##NAME, 5); \ + check##NAME (g06##NAME, 6); \ + check##NAME (g07##NAME, 7); \ + check##NAME (g08##NAME, 8); \ + check##NAME (g09##NAME, 9); \ + check##NAME (g10##NAME, 10); \ + check##NAME (g11##NAME, 11); \ + check##NAME (g12##NAME, 12); \ + check##NAME (g13##NAME, 13); \ + check##NAME (g14##NAME, 14); \ + check##NAME (g15##NAME, 15); \ + check##NAME (g16##NAME, 16); \ + } \ + \ + void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16) \ + { \ + check##NAME (x01, 1); \ + check##NAME (x02, 2); \ + check##NAME (x03, 3); \ + check##NAME (x04, 4); \ + check##NAME (x05, 5); \ + check##NAME (x06, 6); \ + check##NAME (x07, 7); \ + check##NAME (x08, 8); \ + check##NAME (x09, 9); \ + check##NAME (x10, 10); \ + check##NAME (x11, 11); \ + check##NAME (x12, 12); \ + check##NAME (x13, 13); \ + check##NAME (x14, 14); \ + check##NAME (x15, 15); \ + check##NAME (x16, 16); \ + } \ + \ + void \ + testva##NAME (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##NAME (t, i+1); \ + } \ + va_end (ap); \ + } \ + } + + T(ui, unsigned int, 51) + T(si, int, (-55)) + T(ul, unsigned long, 61) + T(sl, long, (-66)) + T(ull, unsigned long long, 71) + T(sll, long long, (-77)) + T(d, double, 91.0) + T(ld, long double, 92.0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Test passing scalars by value. This test includes scalar types that + are not supported by va_arg; since they require casts to pass to a + function with a variable argument list, testing them with variable + arguments is not interesting. */ + + extern void scalar_by_value_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_by_value_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,100 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v + INITVAL) \ + DEBUG_CHECK \ + } \ + \ + void \ + test2_##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08) \ + { \ + test##NAME (x01, g02##NAME, x02, g04##NAME, \ + x03, g06##NAME, x04, g08##NAME, \ + x05, g10##NAME, x06, g12##NAME, \ + x07, g14##NAME, x08, g16##NAME); \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test: "); \ + test##NAME (g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test2: "); \ + test2_##NAME (g01##NAME, g03##NAME, g05##NAME, g07##NAME, \ + g09##NAME, g11##NAME, g13##NAME, g15##NAME); \ + DEBUG_NL; \ + } + + T(c, char, 21) + T(uc, unsigned char, 22) + T(sc, signed char, (-33)) + T(us, unsigned short, 41) + T(ss, short, (-44)) + T(f, float, 90.0) + + #undef T + + void + scalar_by_value_2_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(c) + T(uc) + T(sc) + T(us) + T(ss) + T(f) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-2_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + #include + + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1); \ + check##NAME (g02##NAME, 2); \ + check##NAME (g03##NAME, 3); \ + check##NAME (g04##NAME, 4); \ + check##NAME (g05##NAME, 5); \ + check##NAME (g06##NAME, 6); \ + check##NAME (g07##NAME, 7); \ + check##NAME (g08##NAME, 8); \ + check##NAME (g09##NAME, 9); \ + check##NAME (g10##NAME, 10); \ + check##NAME (g11##NAME, 11); \ + check##NAME (g12##NAME, 12); \ + check##NAME (g13##NAME, 13); \ + check##NAME (g14##NAME, 14); \ + check##NAME (g15##NAME, 15); \ + check##NAME (g16##NAME, 16); \ + } \ + \ + void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16) \ + { \ + check##NAME (x01, 1); \ + check##NAME (x02, 2); \ + check##NAME (x03, 3); \ + check##NAME (x04, 4); \ + check##NAME (x05, 5); \ + check##NAME (x06, 6); \ + check##NAME (x07, 7); \ + check##NAME (x08, 8); \ + check##NAME (x09, 9); \ + check##NAME (x10, 10); \ + check##NAME (x11, 11); \ + check##NAME (x12, 12); \ + check##NAME (x13, 13); \ + check##NAME (x14, 14); \ + check##NAME (x15, 15); \ + check##NAME (x16, 16); \ + } + + T(c, char, 21) + T(uc, unsigned char, 22) + T(sc, signed char, (-33)) + T(us, unsigned short, 41) + T(ss, short, (-44)) + T(f, float, 90.0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_main.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test passing scalars by value. This test includes _Complex types + whose real and imaginary parts can be used in variable-length + argument lists. */ + + extern void scalar_by_value_3_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_by_value_3_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,174 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16); \ + extern void testva##NAME (int n, ...); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v + INITVAL) \ + DEBUG_CHECK \ + } \ + \ + void \ + test2_##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08) \ + { \ + test##NAME (x01, g02##NAME, x02, g04##NAME, \ + x03, g06##NAME, x04, g08##NAME, \ + x05, g10##NAME, x06, g12##NAME, \ + x07, g14##NAME, x08, g16##NAME); \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test: "); \ + test##NAME (g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" testva:"); \ + DEBUG_NL; \ + testva##NAME (1, \ + g01##NAME); \ + DEBUG_NL; \ + testva##NAME (2, \ + g01##NAME, g02##NAME); \ + DEBUG_NL; \ + testva##NAME (3, \ + g01##NAME, g02##NAME, g03##NAME); \ + DEBUG_NL; \ + testva##NAME (4, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME); \ + DEBUG_NL; \ + testva##NAME (5, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME); \ + DEBUG_NL; \ + testva##NAME (6, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME); \ + DEBUG_NL; \ + testva##NAME (7, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME); \ + DEBUG_NL; \ + testva##NAME (8, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME); \ + DEBUG_NL; \ + testva##NAME (9, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME); \ + DEBUG_NL; \ + testva##NAME (10, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME); \ + DEBUG_NL; \ + testva##NAME (11, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME); \ + DEBUG_NL; \ + testva##NAME (12, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME); \ + DEBUG_NL; \ + testva##NAME (13, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME); \ + DEBUG_NL; \ + testva##NAME (14, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME); \ + DEBUG_NL; \ + testva##NAME (15, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME); \ + DEBUG_NL; \ + testva##NAME (16, \ + g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test2: "); \ + test2_##NAME (g01##NAME, g03##NAME, g05##NAME, g07##NAME, \ + g09##NAME, g11##NAME, g13##NAME, g15##NAME); \ + DEBUG_NL; \ + } + + T(ci, _Complex int, (2,3)) + T(cl, _Complex long, (3,4)) + T(cll, _Complex long long, (5,6)) + T(cd, _Complex double, (7.0,8.0)) + T(cld, _Complex long double, (8.0,9.0)) + + #undef T + + void + scalar_by_value_3_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(ci) + T(cl) + T(cll) + T(cd) + T(cld) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-3_y.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,92 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1); \ + check##NAME (g02##NAME, 2); \ + check##NAME (g03##NAME, 3); \ + check##NAME (g04##NAME, 4); \ + check##NAME (g05##NAME, 5); \ + check##NAME (g06##NAME, 6); \ + check##NAME (g07##NAME, 7); \ + check##NAME (g08##NAME, 8); \ + check##NAME (g09##NAME, 9); \ + check##NAME (g10##NAME, 10); \ + check##NAME (g11##NAME, 11); \ + check##NAME (g12##NAME, 12); \ + check##NAME (g13##NAME, 13); \ + check##NAME (g14##NAME, 14); \ + check##NAME (g15##NAME, 15); \ + check##NAME (g16##NAME, 16); \ + } \ + \ + void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16) \ + { \ + check##NAME (x01, 1); \ + check##NAME (x02, 2); \ + check##NAME (x03, 3); \ + check##NAME (x04, 4); \ + check##NAME (x05, 5); \ + check##NAME (x06, 6); \ + check##NAME (x07, 7); \ + check##NAME (x08, 8); \ + check##NAME (x09, 9); \ + check##NAME (x10, 10); \ + check##NAME (x11, 11); \ + check##NAME (x12, 12); \ + check##NAME (x13, 13); \ + check##NAME (x14, 14); \ + check##NAME (x15, 15); \ + check##NAME (x16, 16); \ + } \ + \ + void \ + testva##NAME (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##NAME (t, i+1); \ + } \ + va_end (ap); \ + } \ + } + + T(ci, _Complex int, (2,3)) + T(cl, _Complex long, (3,4)) + T(cll, _Complex long long, (5,6)) + T(cd, _Complex double, (7.0,8.0)) + T(cld, _Complex long double, (8.0,9.0)) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_main.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test passing scalars by value. This test includes _Complex types + whose real and imaginary parts cannot be used in variable-length + argument lists. */ + + extern void scalar_by_value_4_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_by_value_4_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,94 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v + INITVAL) \ + DEBUG_CHECK \ + } \ + \ + void \ + test2_##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08) \ + { \ + test##NAME (x01, g02##NAME, x02, g04##NAME, \ + x03, g06##NAME, x04, g08##NAME, \ + x05, g10##NAME, x06, g12##NAME, \ + x07, g14##NAME, x08, g16##NAME); \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test: "); \ + test##NAME (g01##NAME, g02##NAME, g03##NAME, g04##NAME, \ + g05##NAME, g06##NAME, g07##NAME, g08##NAME, \ + g09##NAME, g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, g16##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test2: "); \ + test2_##NAME (g01##NAME, g03##NAME, g05##NAME, g07##NAME, \ + g09##NAME, g11##NAME, g13##NAME, g15##NAME); \ + DEBUG_NL; \ + } + + T(cc, _Complex char, (0,1)) + T(cs, _Complex short, (1,2)) + T(cf, _Complex float, (6.0,7.0)) + + #undef T + + void + scalar_by_value_4_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(cc) + T(cs) + T(cf) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-by-value-4_y.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1); \ + check##NAME (g02##NAME, 2); \ + check##NAME (g03##NAME, 3); \ + check##NAME (g04##NAME, 4); \ + check##NAME (g05##NAME, 5); \ + check##NAME (g06##NAME, 6); \ + check##NAME (g07##NAME, 7); \ + check##NAME (g08##NAME, 8); \ + check##NAME (g09##NAME, 9); \ + check##NAME (g10##NAME, 10); \ + check##NAME (g11##NAME, 11); \ + check##NAME (g12##NAME, 12); \ + check##NAME (g13##NAME, 13); \ + check##NAME (g14##NAME, 14); \ + check##NAME (g15##NAME, 15); \ + check##NAME (g16##NAME, 16); \ + } \ + \ + void \ + test##NAME (TYPE x01, TYPE x02, TYPE x03, TYPE x04, \ + TYPE x05, TYPE x06, TYPE x07, TYPE x08, \ + TYPE x09, TYPE x10, TYPE x11, TYPE x12, \ + TYPE x13, TYPE x14, TYPE x15, TYPE x16) \ + { \ + check##NAME (x01, 1); \ + check##NAME (x02, 2); \ + check##NAME (x03, 3); \ + check##NAME (x04, 4); \ + check##NAME (x05, 5); \ + check##NAME (x06, 6); \ + check##NAME (x07, 7); \ + check##NAME (x08, 8); \ + check##NAME (x09, 9); \ + check##NAME (x10, 10); \ + check##NAME (x11, 11); \ + check##NAME (x12, 12); \ + check##NAME (x13, 13); \ + check##NAME (x14, 14); \ + check##NAME (x15, 15); \ + check##NAME (x16, 16); \ + } + + T(cc, _Complex char, (0,1)) + T(cs, _Complex short, (1,2)) + T(cf, _Complex float, (6.0,7.0)) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test function return values. This test includes scalar types that + are supported by va_arg. */ + + extern void scalar_return_1_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_return_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern TYPE test0##NAME (void); \ + extern TYPE test1##NAME (TYPE); \ + extern TYPE testva##NAME (int n, ...); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v) \ + DEBUG_CHECK \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + TYPE rslt; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##NAME (); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##NAME (g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + if (test_va) \ + { \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" testva:"); \ + rslt = testva##NAME (1, g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + rslt = testva##NAME (5, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME); \ + check##NAME (rslt, g05##NAME); \ + rslt = testva##NAME (9, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME, g06##NAME, \ + g07##NAME, g08##NAME, g09##NAME); \ + check##NAME (rslt, g09##NAME); \ + rslt = testva##NAME (16, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME, g06##NAME, \ + g07##NAME, g08##NAME, g09##NAME, \ + g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, \ + g16##NAME); \ + check##NAME (rslt, g16##NAME); \ + } \ + DEBUG_NL; \ + } + + T(ui, unsigned int, 51) + T(si, int, (-55)) + T(ul, unsigned long, 61) + T(sl, long, (-66)) + T(ull, unsigned long long, 71) + T(sll, long long, (-77)) + T(d, double, 91.0) + T(ld, long double, 92.0) + + #undef T + + void + scalar_return_1_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(ui) + T(si) + T(ul) + T(sl) + T(ull) + T(sll) + T(d) + T(ld) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-1_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,72 ---- + #include + + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1+INITVAL); \ + check##NAME (g02##NAME, 2+INITVAL); \ + check##NAME (g03##NAME, 3+INITVAL); \ + check##NAME (g04##NAME, 4+INITVAL); \ + check##NAME (g05##NAME, 5+INITVAL); \ + check##NAME (g06##NAME, 6+INITVAL); \ + check##NAME (g07##NAME, 7+INITVAL); \ + check##NAME (g08##NAME, 8+INITVAL); \ + check##NAME (g09##NAME, 9+INITVAL); \ + check##NAME (g10##NAME, 10+INITVAL); \ + check##NAME (g11##NAME, 11+INITVAL); \ + check##NAME (g12##NAME, 12+INITVAL); \ + check##NAME (g13##NAME, 13+INITVAL); \ + check##NAME (g14##NAME, 14+INITVAL); \ + check##NAME (g15##NAME, 15+INITVAL); \ + check##NAME (g16##NAME, 16+INITVAL); \ + } \ + \ + TYPE \ + test0##NAME (void) \ + { \ + return g01##NAME; \ + } \ + \ + TYPE \ + test1##NAME (TYPE x01) \ + { \ + return x01; \ + } \ + \ + TYPE \ + testva##NAME (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(ui, unsigned int, 51) + T(si, int, (-55)) + T(ul, unsigned long, 61) + T(sl, long, (-66)) + T(ull, unsigned long long, 71) + T(sll, long long, (-77)) + T(d, double, 91.0) + T(ld, long double, 92.0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test function return values. This test includes scalar types that + are not supported by va_arg. */ + + extern void scalar_return_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_return_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,86 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern TYPE test0##NAME (void); \ + extern TYPE test1##NAME (TYPE); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v) \ + DEBUG_CHECK \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + TYPE rslt; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##NAME (); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##NAME (g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + } + + T(c, char, 21) + T(uc, unsigned char, 22) + T(sc, signed char, (-33)) + T(us, unsigned short, 41) + T(ss, short, (-44)) + T(f, float, 90.0) + + #undef T + + void + scalar_return_2_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(c) + T(uc) + T(sc) + T(us) + T(ss) + T(f) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-2_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1+INITVAL); \ + check##NAME (g02##NAME, 2+INITVAL); \ + check##NAME (g03##NAME, 3+INITVAL); \ + check##NAME (g04##NAME, 4+INITVAL); \ + check##NAME (g05##NAME, 5+INITVAL); \ + check##NAME (g06##NAME, 6+INITVAL); \ + check##NAME (g07##NAME, 7+INITVAL); \ + check##NAME (g08##NAME, 8+INITVAL); \ + check##NAME (g09##NAME, 9+INITVAL); \ + check##NAME (g10##NAME, 10+INITVAL); \ + check##NAME (g11##NAME, 11+INITVAL); \ + check##NAME (g12##NAME, 12+INITVAL); \ + check##NAME (g13##NAME, 13+INITVAL); \ + check##NAME (g14##NAME, 14+INITVAL); \ + check##NAME (g15##NAME, 15+INITVAL); \ + check##NAME (g16##NAME, 16+INITVAL); \ + } \ + \ + TYPE \ + test0##NAME (void) \ + { \ + return g01##NAME; \ + } \ + \ + TYPE \ + test1##NAME (TYPE x01) \ + { \ + return x01; \ + } + + T(c, char, 21) + T(uc, unsigned char, 22) + T(sc, signed char, (-33)) + T(us, unsigned short, 41) + T(ss, short, (-44)) + T(f, float, 90.0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_main.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test function return values. This test includes _Complex types + whose real and imaginary parts can be used in variable-length + argument lists. */ + + extern void scalar_return_3_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_return_3_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern TYPE test0##NAME (void); \ + extern TYPE test1##NAME (TYPE); \ + extern TYPE testva##NAME (int n, ...); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v) \ + DEBUG_CHECK \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + TYPE rslt; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + init##NAME (&g02##NAME, 2); \ + init##NAME (&g03##NAME, 3); \ + init##NAME (&g04##NAME, 4); \ + init##NAME (&g05##NAME, 5); \ + init##NAME (&g06##NAME, 6); \ + init##NAME (&g07##NAME, 7); \ + init##NAME (&g08##NAME, 8); \ + init##NAME (&g09##NAME, 9); \ + init##NAME (&g10##NAME, 10); \ + init##NAME (&g11##NAME, 11); \ + init##NAME (&g12##NAME, 12); \ + init##NAME (&g13##NAME, 13); \ + init##NAME (&g14##NAME, 14); \ + init##NAME (&g15##NAME, 15); \ + init##NAME (&g16##NAME, 16); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##NAME (); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##NAME (g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + if (test_va) \ + { \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" testva: "); \ + rslt = testva##NAME (1, g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + rslt = testva##NAME (5, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME); \ + check##NAME (rslt, g05##NAME); \ + rslt = testva##NAME (9, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME, g06##NAME, \ + g07##NAME, g08##NAME, g09##NAME); \ + check##NAME (rslt, g09##NAME); \ + rslt = testva##NAME (16, g01##NAME, g02##NAME, g03##NAME, \ + g04##NAME, g05##NAME, g06##NAME, \ + g07##NAME, g08##NAME, g09##NAME, \ + g10##NAME, g11##NAME, g12##NAME, \ + g13##NAME, g14##NAME, g15##NAME, \ + g16##NAME); \ + check##NAME (rslt, g16##NAME); \ + } \ + DEBUG_NL; \ + } + + T(ci, _Complex int, (2,3)) + T(cl, _Complex long, (3,4)) + T(cll, _Complex long long, (4,5)) + T(cd, _Complex double, (2.0,3.0)) + T(cld, _Complex long double, (3.0,4.0)) + + #undef T + + void + scalar_return_3_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(ci) + T(cl) + T(cll) + T(cd) + T(cld) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-3_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-3_y.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + #include + + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME, g02##NAME, g03##NAME, g04##NAME; \ + extern TYPE g05##NAME, g06##NAME, g07##NAME, g08##NAME; \ + extern TYPE g09##NAME, g10##NAME, g11##NAME, g12##NAME; \ + extern TYPE g13##NAME, g14##NAME, g15##NAME, g16##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1+INITVAL); \ + check##NAME (g02##NAME, 2+INITVAL); \ + check##NAME (g03##NAME, 3+INITVAL); \ + check##NAME (g04##NAME, 4+INITVAL); \ + check##NAME (g05##NAME, 5+INITVAL); \ + check##NAME (g06##NAME, 6+INITVAL); \ + check##NAME (g07##NAME, 7+INITVAL); \ + check##NAME (g08##NAME, 8+INITVAL); \ + check##NAME (g09##NAME, 9+INITVAL); \ + check##NAME (g10##NAME, 10+INITVAL); \ + check##NAME (g11##NAME, 11+INITVAL); \ + check##NAME (g12##NAME, 12+INITVAL); \ + check##NAME (g13##NAME, 13+INITVAL); \ + check##NAME (g14##NAME, 14+INITVAL); \ + check##NAME (g15##NAME, 15+INITVAL); \ + check##NAME (g16##NAME, 16+INITVAL); \ + } \ + \ + TYPE \ + test0##NAME (void) \ + { \ + return g01##NAME; \ + } \ + \ + TYPE \ + test1##NAME (TYPE x01) \ + { \ + return x01; \ + } \ + \ + TYPE \ + testva##NAME (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(ci, _Complex int, (2,3)) + T(cl, _Complex long, (3,4)) + T(cll, _Complex long long, (4,5)) + T(cd, _Complex double, (2.0,3.0)) + T(cld, _Complex long double, (3.0,4.0)) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_main.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test function return values. This test includes _Complex types + whose real and imaginary parts cannot be used in variable-length + argument lists. */ + + extern void scalar_return_4_x (void); + extern void exit (int); + int fails; + + int + main () + { + scalar_return_4_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + #include "compat-common.h" + + #define T(NAME, TYPE, INITVAL) \ + TYPE g01##NAME; \ + \ + extern void init##NAME (TYPE *p, TYPE v); \ + extern void checkg##NAME (void); \ + extern TYPE test0##NAME (void); \ + extern TYPE test1##NAME (TYPE); \ + \ + void \ + check##NAME (TYPE x, TYPE v) \ + { \ + if (x != v) \ + DEBUG_CHECK \ + } \ + \ + void \ + testit##NAME (void) \ + { \ + TYPE rslt; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" init: "); \ + init##NAME (&g01##NAME, 1); \ + checkg##NAME (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##NAME (); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##NAME (g01##NAME); \ + check##NAME (rslt, g01##NAME); \ + DEBUG_NL; \ + } + + T(cc, _Complex char, (0,1)) + T(cs, _Complex short, (1,2)) + T(cf, _Complex float, (1.0,2.0)) + + #undef T + + void + scalar_return_4_x () + { + DEBUG_INIT + + #define T(NAME) testit##NAME (); + + T(cc) + T(cs) + T(cf) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/scalar-return-4_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/scalar-return-4_y.c 2003-06-11 18:21:38.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(NAME, TYPE, INITVAL) \ + extern TYPE g01##NAME; \ + \ + extern void check##NAME (TYPE x, TYPE v); \ + \ + void \ + init##NAME (TYPE *p, TYPE v) \ + { \ + *p = v + INITVAL; \ + } \ + \ + void \ + checkg##NAME (void) \ + { \ + check##NAME (g01##NAME, 1+INITVAL); \ + } \ + \ + TYPE \ + test0##NAME (void) \ + { \ + return g01##NAME; \ + } \ + \ + TYPE \ + test1##NAME (TYPE x01) \ + { \ + return x01; \ + } + + T(cc, _Complex char, (0,1)) + T(cs, _Complex short, (1,2)) + T(cf, _Complex float, (1.0,2.0)) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_main.c 2003-07-08 17:36:00.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Check that sdata qualification doesn't produce out-of-range relocations + and that compilers agree on the way these declarations are handled. */ + + extern void sdata_1_x (void); + extern void exit (int); + + int + main () + { + sdata_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_x.c 2003-07-08 17:36:00.000000000 +0000 *************** *** 0 **** --- 1,25 ---- + #include "sdata-section.h" + + struct s { int x; int y[4]; }; + extern struct s small_struct SDATA_SECTION; + + /* Test "load address" operations. */ + int *xaddr (void) { return &small_struct.x; } + int *yaddr (int i) { return &small_struct.y[i]; } + + void sdata_1_x (void) + { + int i; + + /* Test direct accesses. */ + small_struct.x = 5; + for (i = 0; i < 4; i++) + small_struct.y[i] = i + 42; + + if (*xaddr () != 5) + abort (); + + for (i = 0; i < 4; i++) + if (*yaddr (i) != i + 42) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-1_y.c 2003-07-08 17:36:00.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + #include "sdata-section.h" + + struct s { int x; int y[4]; }; + struct s small_struct SDATA_SECTION; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-section.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-section.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/sdata-section.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/sdata-section.h 2004-01-05 21:29:39.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + #ifdef __mips + #define SDATA_SECTION __attribute__((__section__(".sdata"))) + #else + #define SDATA_SECTION + #endif + + extern void abort (void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-check.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-check.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-check.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-check.h 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* Function definitions that are used by multiple tests. */ + + void checkSc (Sc x, int i) { if (x.c != (char)i) DEBUG_CHECK } + void checkSs (Ss x, int i) { if (x.s != i) DEBUG_CHECK } + void checkSi (Si x, int i) { if (x.i != i) DEBUG_CHECK } + void checkSsc (Ssc x, int i) + { if (x.s != i || x.c != (char)i+1) DEBUG_CHECK } + void checkScs (Scs x, int i) + { if (x.c != (char)i || x.s != i+1) DEBUG_CHECK } + void checkSsi (Ssi x, int i) + { if (x.s != i || x.i != i+1) DEBUG_CHECK } + void checkSis (Sis x, int i) + { if (x.i != i || x.s != i+1) DEBUG_CHECK } + void checkSic (Sic x, int i) + { if (x.i != i || x.c != (char)i+1) DEBUG_CHECK } + void checkSci (Sci x, int i) + { if (x.c != (char)i || x.i != i+1) DEBUG_CHECK } + void checkScsi (Scsi x, int i) + { if (x.c != (char)i || x.s != i+1 || x.i != i+2) DEBUG_CHECK } + void checkScis (Scis x, int i) + { if (x.c != (char)i || x.i != i+1 || x.s != i+2) DEBUG_CHECK } + void checkSsci (Ssci x, int i) + { if (x.s != i || x.c != (char)i+1 || x.i != i+2) DEBUG_CHECK } + void checkSsic (Ssic x, int i) + { if (x.s != i || x.i != i+1 || x.c != (char)i+2) DEBUG_CHECK } + void checkSisc (Sisc x, int i) + { if (x.i != i || x.s != i+1 || x.c != (char)i+2) DEBUG_CHECK } + void checkSics (Sics x, int i) + { if (x.i != i || x.c != (char)i+1 || x.s != i+2) DEBUG_CHECK } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-defs.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-defs.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-defs.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-defs.h 2003-05-20 22:15:45.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Type definitions that are used by multiple tests. */ + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { char c; short s; } Scs; + typedef struct { int i; char c; } Sic; + typedef struct { char c; int i; } Sci; + typedef struct { short s; int i; } Ssi; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + typedef struct { short s; char c; int i; } Ssci; + typedef struct { short s; int i; char c; } Ssic; + typedef struct { int i; short s; char c; } Sisc; + typedef struct { int i; char c; short s; } Sics; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-init.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-init.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/small-struct-init.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/small-struct-init.h 2003-05-20 22:15:45.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Function definitions that are used by multiple tests. */ + + void initSc (Sc *p, int i) { p->c = (char)i; } + void initSs (Ss *p, int i) { p->s = i; } + void initSi (Si *p, int i) { p->i = i; } + void initSsc (Ssc *p, int i) { p->s = i; p->c = (char)i+1; } + void initScs (Scs *p, int i) { p->c = (char)i; p->s = i+1; } + void initSsi (Ssi *p, int i) { p->s = i; p->i = i+1; } + void initSis (Sis *p, int i) { p->i = i; p->s = i+1; } + void initSic (Sic *p, int i) { p->i = i; p->c = (char)i+1; } + void initSci (Sci *p, int i) { p->c = (char)i; p->i = i+1; } + void initScsi (Scsi *p, int i) { p->c = (char)i; p->s = i+1; p->i = i+2; } + void initScis (Scis *p, int i) { p->c = (char)i; p->i = i+1; p->s = i+2; } + void initSsci (Ssci *p, int i) { p->s = i; p->c = (char)i+1; p->i = i+2; } + void initSsic (Ssic *p, int i) { p->s = i; p->i = i+1; p->c = (char)i+2; } + void initSisc (Sisc *p, int i) { p->i = i; p->s = i+1; p->c = (char)i+2; } + void initSics (Sics *p, int i) { p->i = i; p->c = (char)i+1; p->s = i+2; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1.h 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + /* Define several variants of a struct for which the alignment differs + between powerpc64-linux and powerpc64-aix. This might be interesting + for other targets as well. */ + + #define DESC_orig "original" + struct B1_orig { + char c; + double d; + }; + + struct A2_orig { + double d; + }; + + struct B2_orig { + char c; + struct A2_orig a2; + }; + + struct A3_orig { + double d; + int i; + }; + + struct B3_orig { + char c; + struct A3_orig a3; + }; + + #define DESC_p_all "packed attribute for all" + struct B1_p_all { + char c; + double d; + } __attribute__ ((packed)); + + struct A2_p_all { + double d; + } __attribute__ ((packed)); + + struct B2_p_all { + char c; + struct A2_p_all a2; + } __attribute__ ((packed)); + + struct A3_p_all { + double d; + int i; + } __attribute__ ((packed)); + + struct B3_p_all { + char c; + struct A3_p_all a3; + } __attribute__ ((packed)); + + #define DESC_p_inner "packed attribute for inner" + struct B1_p_inner { + char c; + double d; + }; + + struct A2_p_inner { + double d; + } __attribute__ ((packed)); + + struct B2_p_inner { + char c; + struct A2_p_inner a2; + }; + + struct A3_p_inner { + double d; + int i; + } __attribute__ ((packed)); + + struct B3_p_inner { + char c; + struct A3_p_inner a3; + }; + + #define DESC_p_outer "packed attribute for outer" + struct B1_p_outer { + char c; + double d; + } __attribute__ ((packed)); + + struct A2_p_outer { + double d; + }; + + struct B2_p_outer { + char c; + struct A2_p_outer a2; + } __attribute__ ((packed)); + + struct A3_p_outer { + double d; + int i; + }; + + struct B3_p_outer { + char c; + struct A3_p_outer a3; + } __attribute__ ((packed)); + + #define DESC_a_max "maximum useful struct alignment for all" + struct B1_a_max { + char c; + double d; + } __attribute__ ((aligned)); + + struct A2_a_max { + double d; + } __attribute__ ((aligned)); + + struct B2_a_max { + char c; + struct A2_a_max a2; + } __attribute__ ((aligned)); + + struct A3_a_max { + double d; + int i; + } __attribute__ ((aligned)); + + struct B3_a_max { + char c; + struct A3_a_max a3; + } __attribute__ ((aligned)); + + #define DESC_m_outer_p_inner "maximum alignment for outer, packed inner" + struct B1_m_outer_p_inner { + char c; + double d; + } __attribute__ ((aligned)) __attribute__ ((packed)); + + struct A2_m_outer_p_inner { + double d; + } __attribute__ ((packed)); + + struct B2_m_outer_p_inner { + char c; + struct A2_m_outer_p_inner a2; + } __attribute__ ((aligned)); + + struct A3_m_outer_p_inner { + double d; + int i; + } __attribute__ ((packed)); + + struct B3_m_outer_p_inner { + char c; + struct A3_m_outer_p_inner a3; + } __attribute__ ((aligned)); + + #define DESC_m_inner_p_outer "maximum alignment for inner, packed outer" + struct B1_m_inner_p_outer { + char c; + double d; + } __attribute__ ((aligned)) __attribute__ ((packed)); + + struct A2_m_inner_p_outer { + double d; + } __attribute__ ((aligned)); + + struct B2_m_inner_p_outer { + char c; + struct A2_m_inner_p_outer a2; + } __attribute__ ((packed)); + + struct A3_m_inner_p_outer { + double d; + int i; + } __attribute__ ((aligned)); + + struct B3_m_inner_p_outer { + char c; + struct A3_m_inner_p_outer a3; + } __attribute__ ((packed)); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_main.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test compatibility of structure layout and alignment for structs + which contain doubles. The original structs here are from PR 10645. */ + + extern void struct_align_1_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_align_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_x.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,91 ---- + #include "compat-common.h" + #include "struct-align-1.h" + + #define SETUP(NAME,V1,V2,V3) \ + char v1_##NAME = V1; \ + double v2_##NAME = V2; \ + int v3_##NAME = V3; \ + \ + struct B1_##NAME b1_##NAME = { V1, V2 }; \ + struct B2_##NAME b2_##NAME = { V1, { V2 } }; \ + struct B3_##NAME b3_##NAME = { V1, { V2, V3 } }; \ + \ + struct B1_##NAME ab1_##NAME[2] = \ + { { V1, V2 }, { V1, V2 } }; \ + struct B2_##NAME ab2_##NAME[2] = \ + { { V1, { V2 } }, { V1, { V2 } } }; \ + struct B3_##NAME ab3_##NAME[2] = \ + { { V1, { V2, V3 } }, { V1, { V2, V3 } } }; \ + \ + extern void test_##NAME (void); \ + extern void checkp1_##NAME (struct B1_##NAME *); \ + extern void checkp2_##NAME (struct B2_##NAME *); \ + extern void checkp3_##NAME (struct B3_##NAME *); \ + extern void checkg1_##NAME (void); \ + extern void checkg2_##NAME (void); \ + extern void checkg3_##NAME (void); \ + \ + void \ + pass1_##NAME (struct B1_##NAME s) \ + { \ + checkp1_##NAME (&s); \ + } \ + \ + void \ + pass2_##NAME (struct B2_##NAME s) \ + { \ + checkp2_##NAME (&s); \ + } \ + \ + void \ + pass3_##NAME (struct B3_##NAME s) \ + { \ + checkp3_##NAME (&s); \ + } \ + \ + struct B1_##NAME \ + return1_##NAME (void) \ + { \ + return ab1_##NAME[0]; \ + } \ + \ + struct B2_##NAME \ + return2_##NAME (void) \ + { \ + return ab2_##NAME[0]; \ + } \ + \ + struct B3_##NAME \ + return3_##NAME (void) \ + { \ + return ab3_##NAME[0]; \ + } + + #define CHECK(NAME) test_##NAME() + + SETUP (orig, 49, 1.0, 111111) + SETUP (p_all, 50, 2.0, 222222) + SETUP (p_inner, 51, 3.0, 333333) + SETUP (p_outer, 52, 4.0, 444444) + SETUP (a_max, 53, 5.0, 555555) + SETUP (m_outer_p_inner, 54, 6.0, 666666) + SETUP (m_inner_p_outer, 55, 7.0, 777777) + + void + struct_align_1_x (void) + { + DEBUG_INIT + + CHECK (orig); + CHECK (p_all); + CHECK (p_inner); + CHECK (p_outer); + CHECK (a_max); + CHECK (m_outer_p_inner); + CHECK (m_inner_p_outer); + + DEBUG_FINI + + if (fails != 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-1_y.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,88 ---- + #include "compat-common.h" + #include "struct-align-1.h" + + #define TEST(NAME) \ + extern char v1_##NAME; \ + extern double v2_##NAME; \ + extern int v3_##NAME; \ + \ + extern struct B1_##NAME b1_##NAME, ab1_##NAME[2]; \ + extern struct B2_##NAME b2_##NAME, ab2_##NAME[2]; \ + extern struct B3_##NAME b3_##NAME, ab3_##NAME[2]; \ + \ + extern void pass1_##NAME (struct B1_##NAME); \ + extern void pass2_##NAME (struct B2_##NAME); \ + extern void pass3_##NAME (struct B3_##NAME); \ + extern struct B1_##NAME return1_##NAME (void); \ + extern struct B2_##NAME return2_##NAME (void); \ + extern struct B3_##NAME return3_##NAME (void); \ + \ + void \ + checkp1_##NAME (struct B1_##NAME *p) \ + { \ + if (p->c != v1_##NAME) \ + DEBUG_CHECK; \ + if (p->d != v2_##NAME) \ + DEBUG_CHECK; \ + } \ + \ + void \ + checkp2_##NAME (struct B2_##NAME *p) \ + { \ + if (p->c != v1_##NAME) \ + DEBUG_CHECK; \ + if (p->a2.d != v2_##NAME) \ + DEBUG_CHECK; \ + } \ + \ + void \ + checkp3_##NAME (struct B3_##NAME *p) \ + { \ + if (p->c != v1_##NAME) \ + DEBUG_CHECK; \ + if (p->a3.d != v2_##NAME) \ + DEBUG_CHECK; \ + if (p->a3.i != v3_##NAME) \ + DEBUG_CHECK; \ + } \ + \ + void \ + test_##NAME (void) \ + { \ + struct B1_##NAME s1; \ + struct B2_##NAME s2; \ + struct B3_##NAME s3; \ + DEBUG_FPUTS (DESC_##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (" global variable"); \ + checkp1_##NAME (&b1_##NAME); \ + checkp2_##NAME (&b2_##NAME); \ + checkp3_##NAME (&b3_##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (" global array"); \ + checkp1_##NAME (&ab1_##NAME[1]); \ + checkp2_##NAME (&ab2_##NAME[1]); \ + checkp3_##NAME (&ab3_##NAME[1]); \ + DEBUG_NL; \ + DEBUG_FPUTS (" argument"); \ + pass1_##NAME (b1_##NAME); \ + pass2_##NAME (b2_##NAME); \ + pass3_##NAME (b3_##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (" function result"); \ + s1 = return1_##NAME (); \ + checkp1_##NAME (&s1); \ + s2 = return2_##NAME (); \ + checkp2_##NAME (&s2); \ + s3 = return3_##NAME (); \ + checkp3_##NAME (&s3); \ + DEBUG_NL; \ + } + + TEST (orig) + TEST (p_all) + TEST (p_inner) + TEST (p_outer) + TEST (a_max) + TEST (m_outer_p_inner) + TEST (m_inner_p_outer) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2.h 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,73 ---- + /* Define several variants of struct epoll_event from the Linux kernel, + specifying various attributes that affect alignment and size. + + This test was developed for systems for which int is 32 bits and + long long is 64 bits; it might need to be disabled for systems where + either of those is not true. */ + + #define DESC_orig "original" + struct epoll_event_orig { + unsigned int events; + unsigned long long data; + }; + + #define DESC_structmax "maximum useful struct alignment" + struct epoll_event_structmax { + unsigned int events; + unsigned long long data; + } __attribute__ ((aligned)); + + + #define DESC_struct4 "4-byte struct alignment" + struct epoll_event_struct4 { + unsigned int events; + unsigned long long data; + } __attribute__ ((aligned(4))); + + #define DESC_struct8 "8-byte struct alignment" + struct epoll_event_struct8 { + unsigned int events; + unsigned long long data; + } __attribute__ ((aligned(8))); + + #define DESC_data4 "4-byte alignment for data" + struct epoll_event_data4 { + unsigned int events; + unsigned long long data __attribute__ ((aligned(4))); + }; + + #define DESC_data8 "8-byte alignment for data" + struct epoll_event_data8 { + unsigned int events; + unsigned long long data __attribute__ ((aligned(8))); + }; + + #define DESC_p "packed attribute" + struct epoll_event_p { + unsigned int events; + unsigned long long data; + } __attribute__ ((packed)); + + #define DESC_pstruct4 "packed attribute, 4-byte struct alignment" + struct epoll_event_pstruct4 { + unsigned int events; + unsigned long long data; + } __attribute__ ((packed)) __attribute__ ((aligned(4))); + + #define DESC_pstruct8 "packed attribute, 8-byte struct alignment" + struct epoll_event_pstruct8 { + unsigned int events; + unsigned long long data; + } __attribute__ ((packed)) __attribute__ ((aligned(8))); + + #define DESC_pdata4 "packed attribute, 4-byte alignment for data" + struct epoll_event_pdata4 { + unsigned int events; + unsigned long long data __attribute__ ((aligned(4))); + } __attribute__ ((packed)); + + #define DESC_pdata8 "packed attribute, 8-byte alignment for data" + struct epoll_event_pdata8 { + unsigned int events; + unsigned long long data __attribute__ ((aligned(8))); + } __attribute__ ((packed)); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_main.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test compatibility of structure layout and alignment for a struct + containing an int and a long long, with various combinations of + packed and aligned attributes. The struct is from the Linux kernel. */ + + extern void struct_align_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_align_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_x.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,79 ---- + /* Disable this test for 16-bit targets. */ + + #if __INT_MAX__ > 32767 + + #include "compat-common.h" + #include "struct-align-2.h" + + #define SETUP(NAME,V1,V2,V3) \ + struct outer_##NAME { \ + int i; \ + struct epoll_event_##NAME ee; \ + }; \ + \ + unsigned int v1_##NAME = V1; \ + unsigned int v2_##NAME = V2; \ + unsigned long long v3_##NAME = V3; \ + \ + struct outer_##NAME s_##NAME[2] = \ + { {V1, { V2, V3 } }, { V1, { V2, V3 } } }; \ + \ + extern void test_##NAME (void); \ + extern void checkp_##NAME (struct outer_##NAME *); \ + extern void checkg_##NAME (void); \ + \ + void \ + pass_##NAME (struct outer_##NAME s) \ + { \ + checkp_##NAME (&s); \ + } \ + \ + struct outer_##NAME \ + return_##NAME (void) \ + { \ + return s_##NAME[0]; \ + } + + #define CHECK(NAME) \ + test_##NAME() + + SETUP (orig,101, 102, 0x0101010101010101ULL) + SETUP (structmax, 103, 104, 0x1212121212121212ULL) + SETUP (struct4, 105, 106, 0x2323232323232323ULL) + SETUP (struct8, 107, 108, 0x3434343434343434ULL) + SETUP (data4, 109, 110, 0x4545454545454545ULL) + SETUP (data8, 111, 112, 0x5656565656565656ULL) + SETUP (p, 113, 114, 0x6767676767676767ULL) + SETUP (pstruct4, 115, 116, 0x7878787878787878ULL) + SETUP (pstruct8, 117, 118, 0x8989898989898989ULL) + SETUP (pdata4, 119, 120, 0x9A9A9A9A9A9A9A9AULL) + SETUP (pdata8, 121, 122, 0xABABABABABABABABULL) + + void + struct_align_2_x (void) + { + DEBUG_INIT + + CHECK (orig); + CHECK (structmax); + CHECK (struct4); + CHECK (struct8); + CHECK (data4); + CHECK (data8); + CHECK (p); + CHECK (pstruct4); + CHECK (pstruct8); + CHECK (pdata4); + CHECK (pdata8); + + DEBUG_FINI + + if (fails != 0) + abort (); + } + + #else + + void struct_align_2_x (void) {} + + #endif /* __INT_MAX__ */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-align-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-align-2_y.c 2003-07-03 20:15:48.000000000 +0000 *************** *** 0 **** --- 1,69 ---- + /* Disable this test for 16-bit targets. */ + + #if __INT_MAX__ > 32767 + + #include "compat-common.h" + #include "struct-align-2.h" + + #define TEST(NAME) \ + struct outer_##NAME { \ + int i; \ + struct epoll_event_##NAME ee; \ + }; \ + \ + extern unsigned int v1_##NAME; \ + extern unsigned int v2_##NAME; \ + extern unsigned long long v3_##NAME; \ + \ + extern struct outer_##NAME s_##NAME[2]; \ + \ + extern void pass_##NAME (struct outer_##NAME); \ + extern struct outer_##NAME return_##NAME (void); \ + \ + void \ + checkp_##NAME (struct outer_##NAME *p) \ + { \ + if (p->i != v1_##NAME) \ + DEBUG_CHECK; \ + if (p->ee.events != v2_##NAME) \ + DEBUG_CHECK; \ + if (p->ee.data != v3_##NAME) \ + DEBUG_CHECK; \ + } \ + \ + void \ + test_##NAME (void) \ + { \ + struct outer_##NAME s; \ + DEBUG_FPUTS (DESC_##NAME); \ + DEBUG_NL; \ + DEBUG_FPUTS (" global array"); \ + checkp_##NAME (&s_##NAME[0]); \ + checkp_##NAME (&s_##NAME[1]); \ + DEBUG_NL; \ + DEBUG_FPUTS (" argument"); \ + pass_##NAME (s_##NAME[0]); \ + DEBUG_NL; \ + DEBUG_FPUTS (" function result"); \ + s = return_##NAME (); \ + checkp_##NAME (&s); \ + DEBUG_NL; \ + } + + TEST (orig) + TEST (structmax) + TEST (struct4) + TEST (struct8) + TEST (data4) + TEST (data8) + TEST (p) + TEST (pstruct4) + TEST (pstruct8) + TEST (pdata4) + TEST (pdata8) + + #else + + int i; /* prevent compiling an empty file */ + + #endif /* __INT_MAX__ */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_main.c 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are floating + point scalars. */ + + extern void struct_by_value_10_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_10_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,184 ---- + #include "compat-common.h" + + #include "fp2-struct-defs.h" + #include "fp2-struct-check.h" + + #define TEST(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, double x); \ + 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, (double)1); \ + init##TYPE ( &g2s##TYPE, (double)2); \ + init##TYPE ( &g3s##TYPE, (double)3); \ + init##TYPE ( &g4s##TYPE, (double)4); \ + init##TYPE ( &g5s##TYPE, (double)5); \ + init##TYPE ( &g6s##TYPE, (double)6); \ + init##TYPE ( &g7s##TYPE, (double)7); \ + init##TYPE ( &g8s##TYPE, (double)8); \ + init##TYPE ( &g9s##TYPE, (double)9); \ + init##TYPE (&g10s##TYPE, (double)10); \ + init##TYPE (&g11s##TYPE, (double)11); \ + init##TYPE (&g12s##TYPE, (double)12); \ + init##TYPE (&g13s##TYPE, (double)13); \ + init##TYPE (&g14s##TYPE, (double)14); \ + init##TYPE (&g15s##TYPE, (double)15); \ + init##TYPE (&g16s##TYPE, (double)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; \ + } + + TEST(Sfd) + TEST(Sfl) + TEST(Sdf) + TEST(Sdl) + TEST(Slf) + TEST(Sld) + TEST(Sfdl) + TEST(Sfld) + TEST(Sdfl) + TEST(Sdlf) + TEST(Slfd) + TEST(Sldf) + + #undef T + + void + struct_by_value_10_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Sfd) + T(Sfl) + T(Sdf) + T(Sdl) + T(Slf) + T(Sld) + T(Sfdl) + T(Sfld) + T(Sdfl) + T(Sdlf) + T(Slfd) + T(Sldf) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-10_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-10_y.c 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,96 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp2-struct-defs.h" + #include "fp2-struct-init.h" + + #define TEST(TYPE) \ + 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; \ + \ + extern void check##TYPE (TYPE x, double y); \ + \ + void \ + checkg##TYPE (void) \ + { \ + check##TYPE ( g1s##TYPE, (double)1); \ + check##TYPE ( g2s##TYPE, (double)2); \ + check##TYPE ( g3s##TYPE, (double)3); \ + check##TYPE ( g4s##TYPE, (double)4); \ + check##TYPE ( g5s##TYPE, (double)5); \ + check##TYPE ( g6s##TYPE, (double)6); \ + check##TYPE ( g7s##TYPE, (double)7); \ + check##TYPE ( g8s##TYPE, (double)8); \ + check##TYPE ( g9s##TYPE, (double)9); \ + check##TYPE ( g10s##TYPE, (double)10); \ + check##TYPE ( g11s##TYPE, (double)11); \ + check##TYPE ( g12s##TYPE, (double)12); \ + check##TYPE ( g13s##TYPE, (double)13); \ + check##TYPE ( g14s##TYPE, (double)14); \ + check##TYPE ( g15s##TYPE, (double)15); \ + check##TYPE ( g16s##TYPE, (double)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, (double)1); \ + check##TYPE (s2, (double)2); \ + check##TYPE (s3, (double)3); \ + check##TYPE (s4, (double)4); \ + check##TYPE (s5, (double)5); \ + check##TYPE (s6, (double)6); \ + check##TYPE (s7, (double)7); \ + check##TYPE (s8, (double)8); \ + check##TYPE (s9, (double)9); \ + check##TYPE (s10, (double)10); \ + check##TYPE (s11, (double)11); \ + check##TYPE (s12, (double)12); \ + check##TYPE (s13, (double)13); \ + check##TYPE (s14, (double)14); \ + check##TYPE (s15, (double)15); \ + check##TYPE (s16, (double)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, (double)i+1); \ + } \ + va_end (ap); \ + } \ + } + + TEST(Sfd) + TEST(Sfl) + TEST(Sdf) + TEST(Sdl) + TEST(Slf) + TEST(Sld) + TEST(Sfdl) + TEST(Sfld) + TEST(Sdfl) + TEST(Sdlf) + TEST(Slfd) + TEST(Sldf) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex char. */ + + extern void struct_by_value_11_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_11_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cc, _Complex char) + CHECKS(cc, _Complex char) + + TEST(Scc1, _Complex char) + TEST(Scc2, _Complex char) + TEST(Scc3, _Complex char) + TEST(Scc4, _Complex char) + TEST(Scc5, _Complex char) + TEST(Scc6, _Complex char) + TEST(Scc7, _Complex char) + TEST(Scc8, _Complex char) + TEST(Scc9, _Complex char) + TEST(Scc10, _Complex char) + TEST(Scc11, _Complex char) + TEST(Scc12, _Complex char) + TEST(Scc13, _Complex char) + TEST(Scc14, _Complex char) + TEST(Scc15, _Complex char) + TEST(Scc16, _Complex char) + + #undef T + + void + struct_by_value_11_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scc1, _Complex char) + T(Scc2, _Complex char) + T(Scc3, _Complex char) + T(Scc4, _Complex char) + T(Scc5, _Complex char) + T(Scc6, _Complex char) + T(Scc7, _Complex char) + T(Scc8, _Complex char) + T(Scc9, _Complex char) + T(Scc10, _Complex char) + T(Scc11, _Complex char) + T(Scc12, _Complex char) + T(Scc13, _Complex char) + T(Scc14, _Complex char) + T(Scc15, _Complex char) + T(Scc16, _Complex char) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-11_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-11_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cc,_Complex char) + INITS(cc, _Complex char) + + TEST(Scc1, _Complex char) + TEST(Scc2, _Complex char) + TEST(Scc3, _Complex char) + TEST(Scc4, _Complex char) + TEST(Scc5, _Complex char) + TEST(Scc6, _Complex char) + TEST(Scc7, _Complex char) + TEST(Scc8, _Complex char) + TEST(Scc9, _Complex char) + TEST(Scc10, _Complex char) + TEST(Scc11, _Complex char) + TEST(Scc12, _Complex char) + TEST(Scc13, _Complex char) + TEST(Scc14, _Complex char) + TEST(Scc15, _Complex char) + TEST(Scc16, _Complex char) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex short. */ + + extern void struct_by_value_12_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_12_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cs, _Complex short) + CHECKS(cs, _Complex short) + + TEST(Scs1, _Complex short) + TEST(Scs2, _Complex short) + TEST(Scs3, _Complex short) + TEST(Scs4, _Complex short) + TEST(Scs5, _Complex short) + TEST(Scs6, _Complex short) + TEST(Scs7, _Complex short) + TEST(Scs8, _Complex short) + TEST(Scs9, _Complex short) + TEST(Scs10, _Complex short) + TEST(Scs11, _Complex short) + TEST(Scs12, _Complex short) + TEST(Scs13, _Complex short) + TEST(Scs14, _Complex short) + TEST(Scs15, _Complex short) + TEST(Scs16, _Complex short) + + #undef T + + void + struct_by_value_12_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scs1, _Complex short) + T(Scs2, _Complex short) + T(Scs3, _Complex short) + T(Scs4, _Complex short) + T(Scs5, _Complex short) + T(Scs6, _Complex short) + T(Scs7, _Complex short) + T(Scs8, _Complex short) + T(Scs9, _Complex short) + T(Scs10, _Complex short) + T(Scs11, _Complex short) + T(Scs12, _Complex short) + T(Scs13, _Complex short) + T(Scs14, _Complex short) + T(Scs15, _Complex short) + T(Scs16, _Complex short) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-12_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-12_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cs,_Complex short) + INITS(cs, _Complex short) + + TEST(Scs1, _Complex short) + TEST(Scs2, _Complex short) + TEST(Scs3, _Complex short) + TEST(Scs4, _Complex short) + TEST(Scs5, _Complex short) + TEST(Scs6, _Complex short) + TEST(Scs7, _Complex short) + TEST(Scs8, _Complex short) + TEST(Scs9, _Complex short) + TEST(Scs10, _Complex short) + TEST(Scs11, _Complex short) + TEST(Scs12, _Complex short) + TEST(Scs13, _Complex short) + TEST(Scs14, _Complex short) + TEST(Scs15, _Complex short) + TEST(Scs16, _Complex short) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are type + _Complex int. */ + + extern void struct_by_value_l3_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_13_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(ci, _Complex int) + CHECKS(ci, _Complex int) + + TEST(Sci1, _Complex int) + TEST(Sci2, _Complex int) + TEST(Sci3, _Complex int) + TEST(Sci4, _Complex int) + TEST(Sci5, _Complex int) + TEST(Sci6, _Complex int) + TEST(Sci7, _Complex int) + TEST(Sci8, _Complex int) + TEST(Sci9, _Complex int) + TEST(Sci10, _Complex int) + TEST(Sci11, _Complex int) + TEST(Sci12, _Complex int) + TEST(Sci13, _Complex int) + TEST(Sci14, _Complex int) + TEST(Sci15, _Complex int) + TEST(Sci16, _Complex int) + + #undef T + + void + struct_by_value_13_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sci1, _Complex int) + T(Sci2, _Complex int) + T(Sci3, _Complex int) + T(Sci4, _Complex int) + T(Sci5, _Complex int) + T(Sci6, _Complex int) + T(Sci7, _Complex int) + T(Sci8, _Complex int) + T(Sci9, _Complex int) + T(Sci10, _Complex int) + T(Sci11, _Complex int) + T(Sci12, _Complex int) + T(Sci13, _Complex int) + T(Sci14, _Complex int) + T(Sci15, _Complex int) + T(Sci16, _Complex int) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-13_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-13_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(ci,_Complex int) + INITS(ci, _Complex int) + + TEST(Sci1, _Complex int) + TEST(Sci2, _Complex int) + TEST(Sci3, _Complex int) + TEST(Sci4, _Complex int) + TEST(Sci5, _Complex int) + TEST(Sci6, _Complex int) + TEST(Sci7, _Complex int) + TEST(Sci8, _Complex int) + TEST(Sci9, _Complex int) + TEST(Sci10, _Complex int) + TEST(Sci11, _Complex int) + TEST(Sci12, _Complex int) + TEST(Sci13, _Complex int) + TEST(Sci14, _Complex int) + TEST(Sci15, _Complex int) + TEST(Sci16, _Complex int) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex long. */ + + extern void struct_by_value_14_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_14_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cl, _Complex long) + CHECKS(cl, _Complex long) + + TEST(Scl1, _Complex long) + TEST(Scl2, _Complex long) + TEST(Scl3, _Complex long) + TEST(Scl4, _Complex long) + TEST(Scl5, _Complex long) + TEST(Scl6, _Complex long) + TEST(Scl7, _Complex long) + TEST(Scl8, _Complex long) + TEST(Scl9, _Complex long) + TEST(Scl10, _Complex long) + TEST(Scl11, _Complex long) + TEST(Scl12, _Complex long) + TEST(Scl13, _Complex long) + TEST(Scl14, _Complex long) + TEST(Scl15, _Complex long) + TEST(Scl16, _Complex long) + + #undef T + + void + struct_by_value_14_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scl1, _Complex long) + T(Scl2, _Complex long) + T(Scl3, _Complex long) + T(Scl4, _Complex long) + T(Scl5, _Complex long) + T(Scl6, _Complex long) + T(Scl7, _Complex long) + T(Scl8, _Complex long) + T(Scl9, _Complex long) + T(Scl10, _Complex long) + T(Scl11, _Complex long) + T(Scl12, _Complex long) + T(Scl13, _Complex long) + T(Scl14, _Complex long) + T(Scl15, _Complex long) + T(Scl16, _Complex long) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-14_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-14_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cl,_Complex long) + INITS(cl, _Complex long) + + TEST(Scl1, _Complex long) + TEST(Scl2, _Complex long) + TEST(Scl3, _Complex long) + TEST(Scl4, _Complex long) + TEST(Scl5, _Complex long) + TEST(Scl6, _Complex long) + TEST(Scl7, _Complex long) + TEST(Scl8, _Complex long) + TEST(Scl9, _Complex long) + TEST(Scl10, _Complex long) + TEST(Scl11, _Complex long) + TEST(Scl12, _Complex long) + TEST(Scl13, _Complex long) + TEST(Scl14, _Complex long) + TEST(Scl15, _Complex long) + TEST(Scl16, _Complex long) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex long long. */ + + extern void struct_by_value_15_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_15_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cll, _Complex long long) + CHECKS(cll, _Complex long long) + + TEST(Scll1, _Complex long long) + TEST(Scll2, _Complex long long) + TEST(Scll3, _Complex long long) + TEST(Scll4, _Complex long long) + TEST(Scll5, _Complex long long) + TEST(Scll6, _Complex long long) + TEST(Scll7, _Complex long long) + TEST(Scll8, _Complex long long) + TEST(Scll9, _Complex long long) + TEST(Scll10, _Complex long long) + TEST(Scll11, _Complex long long) + TEST(Scll12, _Complex long long) + TEST(Scll13, _Complex long long) + TEST(Scll14, _Complex long long) + TEST(Scll15, _Complex long long) + TEST(Scll16, _Complex long long) + + #undef T + + void + struct_by_value_15_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scll1, _Complex long long) + T(Scll2, _Complex long long) + T(Scll3, _Complex long long) + T(Scll4, _Complex long long) + T(Scll5, _Complex long long) + T(Scll6, _Complex long long) + T(Scll7, _Complex long long) + T(Scll8, _Complex long long) + T(Scll9, _Complex long long) + T(Scll10, _Complex long long) + T(Scll11, _Complex long long) + T(Scll12, _Complex long long) + T(Scll13, _Complex long long) + T(Scll14, _Complex long long) + T(Scll15, _Complex long long) + T(Scll16, _Complex long long) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-15_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-15_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cll,_Complex long long) + INITS(cll, _Complex long long) + + TEST(Scll1, _Complex long long) + TEST(Scll2, _Complex long long) + TEST(Scll3, _Complex long long) + TEST(Scll4, _Complex long long) + TEST(Scll5, _Complex long long) + TEST(Scll6, _Complex long long) + TEST(Scll7, _Complex long long) + TEST(Scll8, _Complex long long) + TEST(Scll9, _Complex long long) + TEST(Scll10, _Complex long long) + TEST(Scll11, _Complex long long) + TEST(Scll12, _Complex long long) + TEST(Scll13, _Complex long long) + TEST(Scll14, _Complex long long) + TEST(Scll15, _Complex long long) + TEST(Scll16, _Complex long long) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex float. */ + + extern void struct_by_value_16_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_16_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cf, _Complex float) + CHECKS(cf, _Complex float) + + TEST(Scf1, _Complex float) + TEST(Scf2, _Complex float) + TEST(Scf3, _Complex float) + TEST(Scf4, _Complex float) + TEST(Scf5, _Complex float) + TEST(Scf6, _Complex float) + TEST(Scf7, _Complex float) + TEST(Scf8, _Complex float) + TEST(Scf9, _Complex float) + TEST(Scf10, _Complex float) + TEST(Scf11, _Complex float) + TEST(Scf12, _Complex float) + TEST(Scf13, _Complex float) + TEST(Scf14, _Complex float) + TEST(Scf15, _Complex float) + TEST(Scf16, _Complex float) + + #undef T + + void + struct_by_value_16_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scf1, _Complex float) + T(Scf2, _Complex float) + T(Scf3, _Complex float) + T(Scf4, _Complex float) + T(Scf5, _Complex float) + T(Scf6, _Complex float) + T(Scf7, _Complex float) + T(Scf8, _Complex float) + T(Scf9, _Complex float) + T(Scf10, _Complex float) + T(Scf11, _Complex float) + T(Scf12, _Complex float) + T(Scf13, _Complex float) + T(Scf14, _Complex float) + T(Scf15, _Complex float) + T(Scf16, _Complex float) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-16_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-16_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cf,_Complex float) + INITS(cf, _Complex float) + + TEST(Scf1, _Complex float) + TEST(Scf2, _Complex float) + TEST(Scf3, _Complex float) + TEST(Scf4, _Complex float) + TEST(Scf5, _Complex float) + TEST(Scf6, _Complex float) + TEST(Scf7, _Complex float) + TEST(Scf8, _Complex float) + TEST(Scf9, _Complex float) + TEST(Scf10, _Complex float) + TEST(Scf11, _Complex float) + TEST(Scf12, _Complex float) + TEST(Scf13, _Complex float) + TEST(Scf14, _Complex float) + TEST(Scf15, _Complex float) + TEST(Scf16, _Complex float) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex double. */ + + extern void struct_by_value_17_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_17_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cd, _Complex double) + CHECKS(cd, _Complex double) + + TEST(Scd1, _Complex double) + TEST(Scd2, _Complex double) + TEST(Scd3, _Complex double) + TEST(Scd4, _Complex double) + TEST(Scd5, _Complex double) + TEST(Scd6, _Complex double) + TEST(Scd7, _Complex double) + TEST(Scd8, _Complex double) + TEST(Scd9, _Complex double) + TEST(Scd10, _Complex double) + TEST(Scd11, _Complex double) + TEST(Scd12, _Complex double) + TEST(Scd13, _Complex double) + TEST(Scd14, _Complex double) + TEST(Scd15, _Complex double) + TEST(Scd16, _Complex double) + + #undef T + + void + struct_by_value_17_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scd1, _Complex double) + T(Scd2, _Complex double) + T(Scd3, _Complex double) + T(Scd4, _Complex double) + T(Scd5, _Complex double) + T(Scd6, _Complex double) + T(Scd7, _Complex double) + T(Scd8, _Complex double) + T(Scd9, _Complex double) + T(Scd10, _Complex double) + T(Scd11, _Complex double) + T(Scd12, _Complex double) + T(Scd13, _Complex double) + T(Scd14, _Complex double) + T(Scd15, _Complex double) + T(Scd16, _Complex double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-17_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-17_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cd,_Complex double) + INITS(cd, _Complex double) + + TEST(Scd1, _Complex double) + TEST(Scd2, _Complex double) + TEST(Scd3, _Complex double) + TEST(Scd4, _Complex double) + TEST(Scd5, _Complex double) + TEST(Scd6, _Complex double) + TEST(Scd7, _Complex double) + TEST(Scd8, _Complex double) + TEST(Scd9, _Complex double) + TEST(Scd10, _Complex double) + TEST(Scd11, _Complex double) + TEST(Scd12, _Complex double) + TEST(Scd13, _Complex double) + TEST(Scd14, _Complex double) + TEST(Scd15, _Complex double) + TEST(Scd16, _Complex double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_main.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are of type + _Complex long double. */ + + extern void struct_by_value_18_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_18_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,59 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(cld, _Complex long double) + CHECKS(cld, _Complex long double) + + TEST(Scld1, _Complex long double) + TEST(Scld2, _Complex long double) + TEST(Scld3, _Complex long double) + TEST(Scld4, _Complex long double) + TEST(Scld5, _Complex long double) + TEST(Scld6, _Complex long double) + TEST(Scld7, _Complex long double) + TEST(Scld8, _Complex long double) + TEST(Scld9, _Complex long double) + TEST(Scld10, _Complex long double) + TEST(Scld11, _Complex long double) + TEST(Scld12, _Complex long double) + TEST(Scld13, _Complex long double) + TEST(Scld14, _Complex long double) + TEST(Scld15, _Complex long double) + TEST(Scld16, _Complex long double) + + #undef T + + void + struct_by_value_18_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Scld1, _Complex long double) + T(Scld2, _Complex long double) + T(Scld3, _Complex long double) + T(Scld4, _Complex long double) + T(Scld5, _Complex long double) + T(Scld6, _Complex long double) + T(Scld7, _Complex long double) + T(Scld8, _Complex long double) + T(Scld9, _Complex long double) + T(Scld10, _Complex long double) + T(Scld11, _Complex long double) + T(Scld12, _Complex long double) + T(Scld13, _Complex long double) + T(Scld14, _Complex long double) + T(Scld15, _Complex long double) + T(Scld16, _Complex long double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-18_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-18_y.c 2003-06-11 20:29:21.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(cld,_Complex long double) + INITS(cld, _Complex long double) + + TEST(Scld1, _Complex long double) + TEST(Scld2, _Complex long double) + TEST(Scld3, _Complex long double) + TEST(Scld4, _Complex long double) + TEST(Scld5, _Complex long double) + TEST(Scld6, _Complex long double) + TEST(Scld7, _Complex long double) + TEST(Scld8, _Complex long double) + TEST(Scld9, _Complex long double) + TEST(Scld10, _Complex long double) + TEST(Scld11, _Complex long double) + TEST(Scld12, _Complex long double) + TEST(Scld13, _Complex long double) + TEST(Scld14, _Complex long double) + TEST(Scld15, _Complex long double) + TEST(Scld16, _Complex long double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_main.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. Struct members are char, int, double, + and other structs containing these types. This test was written in + response to a layout change for such structs for powerpc64-linux, + but this test only checks similar structs that are not affected by + that break in compatibility. */ + + extern void struct_by_value_19_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_19_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_x.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,178 ---- + #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(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) + + #undef T + + void + struct_by_value_19_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-19_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-19_y.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,105 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "mixed-struct-defs.h" + + extern void checkScd (Scd x, int i); + extern void checkScdc (Scdc x, int i); + extern void checkSd (Sd x, int i); + extern void checkSdi (Sdi x, int i); + extern void checkScsds (Scsds x, int i); + extern void checkScsdsc (Scsdsc x, int i); + extern void checkScsdis (Scsdis x, int i); + extern void checkScsdisc (Scsdisc x, int i); + extern void checkSsds (Ssds x, int i); + extern void checkSsdsc (Ssdsc x, int i); + extern void checkScssdss (Scssdss x, int i); + extern void checkScssdssc (Scssdssc x, int i); + + #include "mixed-struct-init.h" + + #define T(TYPE) \ + 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(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_main.c 2003-05-05 23:09:47.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test structure passing by value, using a test from gcc.dg. + Each struct that is passed contains an array of unsigned char. */ + + extern void struct_by_value_1_x (void); + extern void exit (int); + + int + main () + { + struct_by_value_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_x.c 2003-05-05 23:09:47.000000000 +0000 *************** *** 0 **** --- 1,63 ---- + #define T(N) \ + struct S##N { unsigned char i[N]; }; \ + struct S##N g1s##N, g2s##N, g3s##N; \ + \ + extern void init##N (struct S##N *p, int i); \ + extern void checkg##N (void); \ + extern void test##N (struct S##N s1, \ + struct S##N s2, struct S##N s3); \ + \ + void \ + check##N (struct S##N x, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + if (x.i[j] != i + j) abort (); \ + } \ + \ + void \ + test2_##N (struct S##N s1, struct S##N s2) \ + { \ + test##N (s1, g2s##N, s2); \ + } \ + \ + void \ + testit##N (void) \ + { \ + init##N (&g1s##N, 64); \ + init##N (&g2s##N, 128); \ + init##N (&g3s##N, 192); \ + checkg##N (); \ + test##N (g1s##N, g2s##N, g3s##N); \ + test2_##N (g1s##N, g3s##N); \ + } + + extern void abort (void); + + T(0) T(1) T(2) T(3) T(4) T(5) T(6) T(7) + T(8) T(9) T(10) T(11) T(12) T(13) T(14) T(15) + T(16) T(17) T(18) T(19) T(20) T(21) T(22) T(23) + T(24) T(25) T(26) T(27) T(28) T(29) T(30) T(31) + T(32) T(33) T(34) T(35) T(36) T(37) T(38) T(39) + T(40) T(41) T(42) T(43) T(44) T(45) T(46) T(47) + T(48) T(49) T(50) T(51) T(52) T(53) T(54) T(55) + T(56) T(57) T(58) T(59) T(60) T(61) T(62) T(63) + + #undef T + + void + struct_by_value_1_x () + { + #define T(N) testit##N (); + + T(0) T(1) T(2) T(3) T(4) T(5) T(6) T(7) + T(8) T(9) T(10) T(11) T(12) T(13) T(14) T(15) + T(16) T(17) T(18) T(19) T(20) T(21) T(22) T(23) + T(24) T(25) T(26) T(27) T(28) T(29) T(30) T(31) + T(32) T(33) T(34) T(35) T(36) T(37) T(38) T(39) + T(40) T(41) T(42) T(43) T(44) T(45) T(46) T(47) + T(48) T(49) T(50) T(51) T(52) T(53) T(54) T(55) + T(56) T(57) T(58) T(59) T(60) T(61) T(62) T(63) + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-1_y.c 2003-05-05 23:09:47.000000000 +0000 *************** *** 0 **** --- 1,40 ---- + #define T(N) \ + struct S##N { unsigned char i[N]; }; \ + extern struct S##N g1s##N, g2s##N, g3s##N; \ + \ + extern void check##N (struct S##N x, int i); \ + extern void test2_##N (struct S##N s1, struct S##N s2); \ + \ + void \ + init##N (struct S##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + p->i[j] = i + j; \ + } \ + \ + void \ + checkg##N (void) \ + { \ + check##N (g1s##N, 64); \ + check##N (g2s##N, 128); \ + check##N (g3s##N, 192); \ + } \ + \ + void \ + test##N (struct S##N s1, struct S##N s2, \ + struct S##N s3) \ + { \ + check##N (s1, 64); \ + check##N (s2, 128); \ + check##N (s3, 192); \ + } + + T(0) T(1) T(2) T(3) T(4) T(5) T(6) T(7) + T(8) T(9) T(10) T(11) T(12) T(13) T(14) T(15) + T(16) T(17) T(18) T(19) T(20) T(21) T(22) T(23) + T(24) T(25) T(26) T(27) T(28) T(29) T(30) T(31) + T(32) T(33) T(34) T(35) T(36) T(37) T(38) T(39) + T(40) T(41) T(42) T(43) T(44) T(45) T(46) T(47) + T(48) T(49) T(50) T(51) T(52) T(53) T(54) T(55) + T(56) T(57) T(58) T(59) T(60) T(61) T(62) T(63) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_main.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. Tested structs end with double. + This test was written in response to a layout change for such + structs for powerpc64-linux that breaks compatibility between + 3.3 and 3.4. */ + + extern void struct_by_value_20_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_20_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_x.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,166 ---- + #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(Scd) + T(Scsds) + T(Scssdss) + + #undef T + + void + struct_by_value_20_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Scd) + T(Scsds) + T(Scssdss) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-20_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-20_y.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,99 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "mixed-struct-defs.h" + + extern void checkScd (Scd x, int i); + extern void checkScdc (Scdc x, int i); + extern void checkSd (Sd x, int i); + extern void checkSdi (Sdi x, int i); + extern void checkScsds (Scsds x, int i); + extern void checkScsdsc (Scsdsc x, int i); + extern void checkScsdis (Scsdis x, int i); + extern void checkScsdisc (Scsdisc x, int i); + extern void checkSsds (Ssds x, int i); + extern void checkSsdsc (Ssdsc x, int i); + extern void checkScssdss (Scssdss x, int i); + extern void checkScssdssc (Scssdssc x, int i); + + #include "mixed-struct-init.h" + + #define T(TYPE) \ + 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(Scd) + T(Scsds) + T(Scssdss) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. + This test is based on one contributed by Alan Modra. */ + + extern void struct_by_value_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,221 ---- + #include "compat-common.h" + + #define T(N, NAME, TYPE) \ + struct S##NAME##N { TYPE i[N]; }; \ + struct S##NAME##N g1s##NAME##N, g2s##NAME##N; \ + struct S##NAME##N g3s##NAME##N, g4s##NAME##N; \ + struct S##NAME##N g5s##NAME##N, g6s##NAME##N; \ + struct S##NAME##N g7s##NAME##N, g8s##NAME##N; \ + struct S##NAME##N g9s##NAME##N, g10s##NAME##N; \ + struct S##NAME##N g11s##NAME##N, g12s##NAME##N; \ + struct S##NAME##N g13s##NAME##N, g14s##NAME##N; \ + struct S##NAME##N g15s##NAME##N, g16s##NAME##N; \ + \ + extern void init##NAME##N (struct S##NAME##N *p, int i); \ + extern void checkg##NAME##N (void); \ + extern void \ + test##NAME##N (struct S##NAME##N s1, struct S##NAME##N s2, \ + struct S##NAME##N s3, struct S##NAME##N s4, \ + struct S##NAME##N s5, struct S##NAME##N s6, \ + struct S##NAME##N s7, struct S##NAME##N s8, \ + struct S##NAME##N s9, struct S##NAME##N s10, \ + struct S##NAME##N s11, struct S##NAME##N s12, \ + struct S##NAME##N s13, struct S##NAME##N s14, \ + struct S##NAME##N s15, struct S##NAME##N s16); \ + extern void testva##NAME##N (int n, ...); \ + extern void \ + test2_##NAME##N (struct S##NAME##N s1, struct S##NAME##N s2, \ + struct S##NAME##N s3, struct S##NAME##N s4, \ + struct S##NAME##N s5, struct S##NAME##N s6, \ + struct S##NAME##N s7, struct S##NAME##N s8); \ + \ + void \ + check##NAME##N (struct S##NAME##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + if (p->i[j] != (TYPE) (i + j)) \ + DEBUG_CHECK \ + } \ + \ + void \ + test2_##NAME##N (struct S##NAME##N s1, struct S##NAME##N s2, \ + struct S##NAME##N s3, struct S##NAME##N s4, \ + struct S##NAME##N s5, struct S##NAME##N s6, \ + struct S##NAME##N s7, struct S##NAME##N s8) \ + { \ + test##NAME##N (s1, g2s##NAME##N, s2, g4s##NAME##N, \ + s3, g6s##NAME##N, s4, g8s##NAME##N, \ + s5, g10s##NAME##N, s6, g12s##NAME##N, \ + s7, g14s##NAME##N, s8, g16s##NAME##N); \ + } \ + \ + void \ + testit##NAME##N (void) \ + { \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" init: "); \ + init##NAME##N ( &g1s##NAME##N, 1*16); \ + init##NAME##N ( &g2s##NAME##N, 2*16); \ + init##NAME##N ( &g3s##NAME##N, 3*16); \ + init##NAME##N ( &g4s##NAME##N, 4*16); \ + init##NAME##N ( &g5s##NAME##N, 5*16); \ + init##NAME##N ( &g6s##NAME##N, 6*16); \ + init##NAME##N ( &g7s##NAME##N, 7*16); \ + init##NAME##N ( &g8s##NAME##N, 8*16); \ + init##NAME##N ( &g9s##NAME##N, 9*16); \ + init##NAME##N (&g10s##NAME##N, 10*16); \ + init##NAME##N (&g11s##NAME##N, 11*16); \ + init##NAME##N (&g12s##NAME##N, 12*16); \ + init##NAME##N (&g13s##NAME##N, 13*16); \ + init##NAME##N (&g14s##NAME##N, 14*16); \ + init##NAME##N (&g15s##NAME##N, 15*16); \ + init##NAME##N (&g16s##NAME##N, 16*16); \ + checkg##NAME##N (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" test: "); \ + test##NAME##N (g1s##NAME##N, g2s##NAME##N, \ + g3s##NAME##N, g4s##NAME##N, \ + g5s##NAME##N, g6s##NAME##N, \ + g7s##NAME##N, g8s##NAME##N, \ + g9s##NAME##N, g10s##NAME##N, \ + g11s##NAME##N, g12s##NAME##N, \ + g13s##NAME##N, g14s##NAME##N, \ + g15s##NAME##N, g16s##NAME##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" testva:"); \ + testva##NAME##N (16, \ + g1s##NAME##N, g2s##NAME##N, \ + g3s##NAME##N, g4s##NAME##N, \ + g5s##NAME##N, g6s##NAME##N, \ + g7s##NAME##N, g8s##NAME##N, \ + g9s##NAME##N, g10s##NAME##N, \ + g11s##NAME##N, g12s##NAME##N, \ + g13s##NAME##N, g14s##NAME##N, \ + g15s##NAME##N, g16s##NAME##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" test2: "); \ + test2_##NAME##N (g1s##NAME##N, g3s##NAME##N, \ + g5s##NAME##N, g7s##NAME##N, \ + g9s##NAME##N, g11s##NAME##N, \ + g13s##NAME##N, g15s##NAME##N); \ + DEBUG_NL; \ + } + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) + + #undef T + + void + struct_by_value_2_x () + { + DEBUG_INIT + + #define T(N, NAME, TYPE) testit##NAME##N (); + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-2_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,152 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(N, NAME, TYPE) \ + struct S##NAME##N { TYPE i[N]; }; \ + \ + extern struct S##NAME##N g1s##NAME##N, g2s##NAME##N; \ + extern struct S##NAME##N g3s##NAME##N, g4s##NAME##N; \ + extern struct S##NAME##N g5s##NAME##N, g6s##NAME##N; \ + extern struct S##NAME##N g7s##NAME##N, g8s##NAME##N; \ + extern struct S##NAME##N g9s##NAME##N, g10s##NAME##N; \ + extern struct S##NAME##N g11s##NAME##N, g12s##NAME##N; \ + extern struct S##NAME##N g13s##NAME##N, g14s##NAME##N; \ + extern struct S##NAME##N g15s##NAME##N, g16s##NAME##N; \ + \ + extern void check##NAME##N (struct S##NAME##N *p, int i); \ + extern void \ + test2_##NAME##N (struct S##NAME##N s1, struct S##NAME##N s2, \ + struct S##NAME##N s3, struct S##NAME##N s4, \ + struct S##NAME##N s5, struct S##NAME##N s6, \ + struct S##NAME##N s7, struct S##NAME##N s8); \ + \ + void \ + init##NAME##N (struct S##NAME##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + p->i[j] = i + j; \ + } \ + \ + void \ + checkg##NAME##N (void) \ + { \ + check##NAME##N ( &g1s##NAME##N, 1*16); \ + check##NAME##N ( &g2s##NAME##N, 2*16); \ + check##NAME##N ( &g3s##NAME##N, 3*16); \ + check##NAME##N ( &g4s##NAME##N, 4*16); \ + check##NAME##N ( &g5s##NAME##N, 5*16); \ + check##NAME##N ( &g6s##NAME##N, 6*16); \ + check##NAME##N ( &g7s##NAME##N, 7*16); \ + check##NAME##N ( &g8s##NAME##N, 8*16); \ + check##NAME##N ( &g9s##NAME##N, 9*16); \ + check##NAME##N (&g10s##NAME##N, 10*16); \ + check##NAME##N (&g11s##NAME##N, 11*16); \ + check##NAME##N (&g12s##NAME##N, 12*16); \ + check##NAME##N (&g13s##NAME##N, 13*16); \ + check##NAME##N (&g14s##NAME##N, 14*16); \ + check##NAME##N (&g15s##NAME##N, 15*16); \ + check##NAME##N (&g16s##NAME##N, 16*16); \ + } \ + \ + void \ + test##NAME##N (struct S##NAME##N s1, struct S##NAME##N s2, \ + struct S##NAME##N s3, struct S##NAME##N s4, \ + struct S##NAME##N s5, struct S##NAME##N s6, \ + struct S##NAME##N s7, struct S##NAME##N s8, \ + struct S##NAME##N s9, struct S##NAME##N s10, \ + struct S##NAME##N s11, struct S##NAME##N s12, \ + struct S##NAME##N s13, struct S##NAME##N s14, \ + struct S##NAME##N s15, struct S##NAME##N s16) \ + { \ + check##NAME##N (&s1, 1*16); \ + check##NAME##N (&s2, 2*16); \ + check##NAME##N (&s3, 3*16); \ + check##NAME##N (&s4, 4*16); \ + check##NAME##N (&s5, 5*16); \ + check##NAME##N (&s6, 6*16); \ + check##NAME##N (&s7, 7*16); \ + check##NAME##N (&s8, 8*16); \ + check##NAME##N (&s9, 9*16); \ + check##NAME##N (&s10, 10*16); \ + check##NAME##N (&s11, 11*16); \ + check##NAME##N (&s12, 12*16); \ + check##NAME##N (&s13, 13*16); \ + check##NAME##N (&s14, 14*16); \ + check##NAME##N (&s15, 15*16); \ + check##NAME##N (&s16, 16*16); \ + } \ + \ + void \ + testva##NAME##N (int n, ...) \ + { \ + int i; \ + va_list ap; \ + if (test_va) \ + { \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + { \ + struct S##NAME##N t = va_arg (ap, struct S##NAME##N); \ + check##NAME##N (&t, (i+1)*16); \ + } \ + va_end (ap); \ + } \ + } + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. All struct members are scalar + integral types, and the structs are "small": 1, 2, 4, 8, and 12 + bytes for LP64. */ + + extern void struct_by_value_3_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_3_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,190 ---- + #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 "small-struct-defs.h" + #include "small-struct-check.h" + + T(Sc) + T(Ss) + T(Si) + T(Scs) + T(Ssc) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) + + #undef T + + void + struct_by_value_3_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Sc) + T(Ss) + T(Si) + T(Scs) + T(Ssc) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-3_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-3_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,114 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "small-struct-defs.h" + + extern void checkSc (Sc x, int i); + extern void checkSs (Ss x, int i); + extern void checkSi (Si x, int i); + extern void checkSsc (Ssc x, int i); + extern void checkScs (Scs x, int i); + extern void checkSsi (Ssi x, int i); + extern void checkSis (Sis x, int i); + extern void checkSic (Sic x, int i); + extern void checkSci (Sci x, int i); + extern void checkScsi (Scsi x, int i); + extern void checkScis (Scis x, int i); + extern void checkSsci (Ssci x, int i); + extern void checkSsic (Ssic x, int i); + extern void checkSisc (Sisc x, int i); + extern void checkSics (Sics x, int i); + + #include "small-struct-init.h" + + #define T(TYPE) \ + 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(Sc) + T(Ss) + T(Si) + T(Ssc) + T(Scs) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. Each struct contains an array + of small structs with a single member. */ + + extern void struct_by_value_4_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_4_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + #include "compat-common.h" + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void init##TYPE (TYPE *p, int i); \ + extern void checkg##TYPE##N (void); \ + extern void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16); \ + extern void testva##TYPE##N (int n, ...); \ + \ + \ + void \ + init##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + init##TYPE(&p->i[j], i+j); \ + } \ + \ + void \ + check##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + check##TYPE(p->i[j], i+j); \ + } \ + \ + void \ + test2_##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8) \ + { \ + test##TYPE##N (s1, g2s##TYPE##N, s2, g4s##TYPE##N, \ + s3, g6s##TYPE##N, s4, g8s##TYPE##N, \ + s5, g10s##TYPE##N, s6, g12s##TYPE##N, \ + s7, g14s##TYPE##N, s8, g16s##TYPE##N); \ + } \ + \ + void \ + testit##TYPE##N (void) \ + { \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" init: "); \ + init##TYPE##N ( &g1s##TYPE##N, 1*16); \ + init##TYPE##N ( &g2s##TYPE##N, 2*16); \ + init##TYPE##N ( &g3s##TYPE##N, 3*16); \ + init##TYPE##N ( &g4s##TYPE##N, 4*16); \ + init##TYPE##N ( &g5s##TYPE##N, 5*16); \ + init##TYPE##N ( &g6s##TYPE##N, 6*16); \ + init##TYPE##N ( &g7s##TYPE##N, 7*16); \ + init##TYPE##N ( &g8s##TYPE##N, 8*16); \ + init##TYPE##N ( &g9s##TYPE##N, 9*16); \ + init##TYPE##N (&g10s##TYPE##N, 10*16); \ + init##TYPE##N (&g11s##TYPE##N, 11*16); \ + init##TYPE##N (&g12s##TYPE##N, 12*16); \ + init##TYPE##N (&g13s##TYPE##N, 13*16); \ + init##TYPE##N (&g14s##TYPE##N, 14*16); \ + init##TYPE##N (&g15s##TYPE##N, 15*16); \ + init##TYPE##N (&g16s##TYPE##N, 16*16); \ + checkg##TYPE##N (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test: "); \ + test##TYPE##N (g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" testva:"); \ + testva##TYPE##N (16, \ + g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test2: "); \ + test2_##TYPE##N (g1s##TYPE##N, g3s##TYPE##N, \ + g5s##TYPE##N, g7s##TYPE##N, \ + g9s##TYPE##N, g11s##TYPE##N, \ + g13s##TYPE##N, g15s##TYPE##N); \ + DEBUG_NL; \ + } + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + void checkSc (Sc x, int i) { if (x.c != i/16) DEBUG_CHECK } + void checkSs (Ss x, int i) { if (x.s != i) DEBUG_CHECK } + void checkSi (Si x, int i) { if (x.i != i) DEBUG_CHECK } + void checkSsc (Ssc x, int i) + { if (x.s != i || x.c != (i/16)+1) DEBUG_CHECK } + void checkSis (Sis x, int i) + { if (x.i != i || x.s != i+1) DEBUG_CHECK } + void checkScsi (Scsi x, int i) + { if (x.c != i/16 || x.s != i+1 || x.i != i+2) DEBUG_CHECK } + void checkScis (Scis x, int i) + { if (x.c != i/16 || x.i != i+1 || x.s != i+2) DEBUG_CHECK } + + T(0, Sc) + T(1, Sc) + T(2, Sc) + T(3, Sc) + T(4, Sc) + T(5, Sc) + T(6, Sc) + T(7, Sc) + T(8, Sc) + T(9, Sc) + T(10, Sc) + T(11, Sc) + T(12, Sc) + T(13, Sc) + T(14, Sc) + T(15, Sc) + T(0, Ss) + T(1, Ss) + T(2, Ss) + T(3, Ss) + T(4, Ss) + T(5, Ss) + T(6, Ss) + T(7, Ss) + T(8, Ss) + T(9, Ss) + T(10, Ss) + T(11, Ss) + T(12, Ss) + T(13, Ss) + T(14, Ss) + T(15, Ss) + T(0, Si) + T(1, Si) + T(2, Si) + T(3, Si) + T(4, Si) + T(5, Si) + T(6, Si) + T(7, Si) + T(8, Si) + T(9, Si) + T(10, Si) + T(11, Si) + T(12, Si) + T(13, Si) + T(14, Si) + T(15, Si) + + #undef T + + void + struct_by_value_4_x () + { + DEBUG_INIT + + #define T(N, TYPE) testit##TYPE##N (); + + T(0, Sc) + T(1, Sc) + T(2, Sc) + T(3, Sc) + T(4, Sc) + T(5, Sc) + T(6, Sc) + T(7, Sc) + T(8, Sc) + T(9, Sc) + T(10, Sc) + T(11, Sc) + T(12, Sc) + T(13, Sc) + T(14, Sc) + T(15, Sc) + T(0, Ss) + T(1, Ss) + T(2, Ss) + T(3, Ss) + T(4, Ss) + T(5, Ss) + T(6, Ss) + T(7, Ss) + T(8, Ss) + T(9, Ss) + T(10, Ss) + T(11, Ss) + T(12, Ss) + T(13, Ss) + T(14, Ss) + T(15, Ss) + T(0, Si) + T(1, Si) + T(2, Si) + T(3, Si) + T(4, Si) + T(5, Si) + T(6, Si) + T(7, Si) + T(8, Si) + T(9, Si) + T(10, Si) + T(11, Si) + T(12, Si) + T(13, Si) + T(14, Si) + T(15, Si) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-4_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-4_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,157 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + void initSc (Sc *p, int i) { p->c = i/16; } + void initSs (Ss *p, int i) { p->s = i; } + void initSi (Si *p, int i) { p->i = i; } + void initSsc (Ssc *p, int i) { p->s = i; p->c = (i/16)+1; } + void initSis (Sis *p, int i) { p->i = i; p->s = i+1; } + void initScsi (Scsi *p, int i) { p->c = i/16; p->s = i+1; p->i = i+2; } + void initScis (Scis *p, int i) { p->c = i/16; p->i = i+1; p->s = i+2; } + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + extern struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + extern struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + extern struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + extern struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + extern struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + extern struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + extern struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + extern struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void check##TYPE (TYPE x, int i); \ + extern void \ + check##TYPE##N (struct S##TYPE##N *p, int i); \ + \ + void \ + checkg##TYPE##N (void) \ + { \ + check##TYPE##N ( &g1s##TYPE##N, 1*16); \ + check##TYPE##N ( &g2s##TYPE##N, 2*16); \ + check##TYPE##N ( &g3s##TYPE##N, 3*16); \ + check##TYPE##N ( &g4s##TYPE##N, 4*16); \ + check##TYPE##N ( &g5s##TYPE##N, 5*16); \ + check##TYPE##N ( &g6s##TYPE##N, 6*16); \ + check##TYPE##N ( &g7s##TYPE##N, 7*16); \ + check##TYPE##N ( &g8s##TYPE##N, 8*16); \ + check##TYPE##N ( &g9s##TYPE##N, 9*16); \ + check##TYPE##N (&g10s##TYPE##N, 10*16); \ + check##TYPE##N (&g11s##TYPE##N, 11*16); \ + check##TYPE##N (&g12s##TYPE##N, 12*16); \ + check##TYPE##N (&g13s##TYPE##N, 13*16); \ + check##TYPE##N (&g14s##TYPE##N, 14*16); \ + check##TYPE##N (&g15s##TYPE##N, 15*16); \ + check##TYPE##N (&g16s##TYPE##N, 16*16); \ + } \ + \ + void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16) \ + { \ + check##TYPE##N (&s1, 1*16); \ + check##TYPE##N (&s2, 2*16); \ + check##TYPE##N (&s3, 3*16); \ + check##TYPE##N (&s4, 4*16); \ + check##TYPE##N (&s5, 5*16); \ + check##TYPE##N (&s6, 6*16); \ + check##TYPE##N (&s7, 7*16); \ + check##TYPE##N (&s8, 8*16); \ + check##TYPE##N (&s9, 9*16); \ + check##TYPE##N (&s10, 10*16); \ + check##TYPE##N (&s11, 11*16); \ + check##TYPE##N (&s12, 12*16); \ + check##TYPE##N (&s13, 13*16); \ + check##TYPE##N (&s14, 14*16); \ + check##TYPE##N (&s15, 15*16); \ + check##TYPE##N (&s16, 16*16); \ + } \ + \ + void \ + testva##TYPE##N (int n, ...) \ + { \ + int i; \ + va_list ap; \ + if (test_va) \ + { \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + { \ + struct S##TYPE##N t = va_arg (ap, struct S##TYPE##N); \ + check##TYPE##N (&t, (i+1)*16); \ + } \ + va_end (ap); \ + } \ + } + + T(0, Sc) + T(1, Sc) + T(2, Sc) + T(3, Sc) + T(4, Sc) + T(5, Sc) + T(6, Sc) + T(7, Sc) + T(8, Sc) + T(9, Sc) + T(10, Sc) + T(11, Sc) + T(12, Sc) + T(13, Sc) + T(14, Sc) + T(15, Sc) + T(0, Ss) + T(1, Ss) + T(2, Ss) + T(3, Ss) + T(4, Ss) + T(5, Ss) + T(6, Ss) + T(7, Ss) + T(8, Ss) + T(9, Ss) + T(10, Ss) + T(11, Ss) + T(12, Ss) + T(13, Ss) + T(14, Ss) + T(15, Ss) + T(0, Si) + T(1, Si) + T(2, Si) + T(3, Si) + T(4, Si) + T(5, Si) + T(6, Si) + T(7, Si) + T(8, Si) + T(9, Si) + T(10, Si) + T(11, Si) + T(12, Si) + T(13, Si) + T(14, Si) + T(15, Si) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are float + scalars. */ + + extern void struct_by_value_5a_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_5a_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(f, float) + CHECKS(f, float) + + TEST(Sf1, float) + TEST(Sf2, float) + TEST(Sf3, float) + TEST(Sf4, float) + TEST(Sf5, float) + TEST(Sf6, float) + TEST(Sf7, float) + TEST(Sf8, float) + + #undef T + + void + struct_by_value_5a_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sf1, float) + T(Sf2, float) + T(Sf3, float) + T(Sf4, float) + T(Sf5, float) + T(Sf6, float) + T(Sf7, float) + T(Sf8, float) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5a_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(f,float) + INITS(f, float) + + TEST(Sf1, float) + TEST(Sf2, float) + TEST(Sf3, float) + TEST(Sf4, float) + TEST(Sf5, float) + TEST(Sf6, float) + TEST(Sf7, float) + TEST(Sf8, float) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are float + scalars. */ + + extern void struct_by_value_5b_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_5b_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(f, float) + CHECKS(f, float) + + TEST(Sf9, float) + TEST(Sf10, float) + TEST(Sf11, float) + TEST(Sf12, float) + TEST(Sf13, float) + TEST(Sf14, float) + TEST(Sf15, float) + TEST(Sf16, float) + + #undef T + + void + struct_by_value_5b_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sf9, float) + T(Sf10, float) + T(Sf11, float) + T(Sf12, float) + T(Sf13, float) + T(Sf14, float) + T(Sf15, float) + T(Sf16, float) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-5b_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(f,float) + INITS(f, float) + + TEST(Sf9, float) + TEST(Sf10, float) + TEST(Sf11, float) + TEST(Sf12, float) + TEST(Sf13, float) + TEST(Sf14, float) + TEST(Sf15, float) + TEST(Sf16, float) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are double + scalars. */ + + extern void struct_by_value_6a_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_6a_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(d, double) + CHECKS(d, double) + + TEST(Sd1, double) + TEST(Sd2, double) + TEST(Sd3, double) + TEST(Sd4, double) + TEST(Sd5, double) + TEST(Sd6, double) + TEST(Sd7, double) + TEST(Sd8, double) + + #undef T + + void + struct_by_value_6a_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sd1, double) + T(Sd2, double) + T(Sd3, double) + T(Sd4, double) + T(Sd5, double) + T(Sd6, double) + T(Sd7, double) + T(Sd8, double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6a_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(d, double) + INITS(d, double) + + TEST(Sd1, double) + TEST(Sd2, double) + TEST(Sd3, double) + TEST(Sd4, double) + TEST(Sd5, double) + TEST(Sd6, double) + TEST(Sd7, double) + TEST(Sd8, double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are double + scalars. */ + + extern void struct_by_value_6b_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_6b_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(d, double) + CHECKS(d, double) + + TEST(Sd9, double) + TEST(Sd10, double) + TEST(Sd11, double) + TEST(Sd12, double) + TEST(Sd13, double) + TEST(Sd14, double) + TEST(Sd15, double) + TEST(Sd16, double) + + #undef T + + void + struct_by_value_6b_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sd9, double) + T(Sd10, double) + T(Sd11, double) + T(Sd12, double) + T(Sd13, double) + T(Sd14, double) + T(Sd15, double) + T(Sd16, double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-6b_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(d, double) + INITS(d, double) + + TEST(Sd9, double) + TEST(Sd10, double) + TEST(Sd11, double) + TEST(Sd12, double) + TEST(Sd13, double) + TEST(Sd14, double) + TEST(Sd15, double) + TEST(Sd16, double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are long double + scalars. */ + + extern void struct_by_value_7a_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_7a_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(ld, long double) + CHECKS(ld, long double) + + TEST(Sld1, long double) + TEST(Sld2, long double) + TEST(Sld3, long double) + TEST(Sld4, long double) + TEST(Sld5, long double) + TEST(Sld6, long double) + TEST(Sld7, long double) + TEST(Sld8, long double) + + #undef T + + void + struct_by_value_7a_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sld1, long double) + T(Sld2, long double) + T(Sld3, long double) + T(Sld4, long double) + T(Sld5, long double) + T(Sld6, long double) + T(Sld7, long double) + T(Sld8, long double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7a_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(ld, long double) + INITS(ld, long double) + + TEST(Sld1, long double) + TEST(Sld2, long double) + TEST(Sld3, long double) + TEST(Sld4, long double) + TEST(Sld5, long double) + TEST(Sld6, long double) + TEST(Sld7, long double) + TEST(Sld8, long double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_main.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument lists. All struct members are long double + scalars. */ + + extern void struct_by_value_7b_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_7b_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_x.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + #include "compat-common.h" + + #include "fp-struct-defs.h" + #include "fp-struct-check.h" + #include "fp-struct-test-by-value-x.h" + + DEFS(ld, long double) + CHECKS(ld, long double) + + TEST(Sld9, long double) + TEST(Sld10, long double) + TEST(Sld11, long double) + TEST(Sld12, long double) + TEST(Sld13, long double) + TEST(Sld14, long double) + TEST(Sld15, long double) + TEST(Sld16, long double) + + #undef T + + void + struct_by_value_7b_x () + { + DEBUG_INIT + + #define T(TYPE, MTYPE) testit##TYPE (); + + T(Sld9, long double) + T(Sld10, long double) + T(Sld11, long double) + T(Sld12, long double) + T(Sld13, long double) + T(Sld14, long double) + T(Sld15, long double) + T(Sld16, long double) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-7b_y.c 2004-04-12 13:58:36.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp-struct-defs.h" + #include "fp-struct-init.h" + #include "fp-struct-test-by-value-y.h" + + DEFS(ld, long double) + INITS(ld, long double) + + TEST(Sld9, long double) + TEST(Sld10, long double) + TEST(Sld11, long double) + TEST(Sld12, long double) + TEST(Sld13, long double) + TEST(Sld14, long double) + TEST(Sld15, long double) + TEST(Sld16, long double) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. Each struct contains an array + of small structs with two scalar members. */ + + extern void struct_by_value_8_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_8_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,213 ---- + #include "compat-common.h" + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void init##TYPE (TYPE *p, int i); \ + extern void checkg##TYPE##N (void); \ + extern void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16); \ + extern void testva##TYPE##N (int n, ...); \ + \ + \ + void \ + init##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + init##TYPE(&p->i[j], i+j); \ + } \ + \ + void \ + check##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + check##TYPE(p->i[j], i+j); \ + } \ + \ + void \ + test2_##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8) \ + { \ + test##TYPE##N (s1, g2s##TYPE##N, s2, g4s##TYPE##N, \ + s3, g6s##TYPE##N, s4, g8s##TYPE##N, \ + s5, g10s##TYPE##N, s6, g12s##TYPE##N, \ + s7, g14s##TYPE##N, s8, g16s##TYPE##N); \ + } \ + \ + void \ + testit##TYPE##N (void) \ + { \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" init: "); \ + init##TYPE##N ( &g1s##TYPE##N, 1*16); \ + init##TYPE##N ( &g2s##TYPE##N, 2*16); \ + init##TYPE##N ( &g3s##TYPE##N, 3*16); \ + init##TYPE##N ( &g4s##TYPE##N, 4*16); \ + init##TYPE##N ( &g5s##TYPE##N, 5*16); \ + init##TYPE##N ( &g6s##TYPE##N, 6*16); \ + init##TYPE##N ( &g7s##TYPE##N, 7*16); \ + init##TYPE##N ( &g8s##TYPE##N, 8*16); \ + init##TYPE##N ( &g9s##TYPE##N, 9*16); \ + init##TYPE##N (&g10s##TYPE##N, 10*16); \ + init##TYPE##N (&g11s##TYPE##N, 11*16); \ + init##TYPE##N (&g12s##TYPE##N, 12*16); \ + init##TYPE##N (&g13s##TYPE##N, 13*16); \ + init##TYPE##N (&g14s##TYPE##N, 14*16); \ + init##TYPE##N (&g15s##TYPE##N, 15*16); \ + init##TYPE##N (&g16s##TYPE##N, 16*16); \ + checkg##TYPE##N (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test: "); \ + test##TYPE##N (g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" testva:"); \ + testva##TYPE##N (16, \ + g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test2: "); \ + test2_##TYPE##N (g1s##TYPE##N, g3s##TYPE##N, \ + g5s##TYPE##N, g7s##TYPE##N, \ + g9s##TYPE##N, g11s##TYPE##N, \ + g13s##TYPE##N, g15s##TYPE##N); \ + DEBUG_NL; \ + } + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + void checkSc (Sc x, int i) { if (x.c != i/16) DEBUG_CHECK } + void checkSs (Ss x, int i) { if (x.s != i) DEBUG_CHECK } + void checkSi (Si x, int i) { if (x.i != i) DEBUG_CHECK } + void checkSsc (Ssc x, int i) + { if (x.s != i || x.c != (i/16)+1) DEBUG_CHECK } + void checkSis (Sis x, int i) + { if (x.i != i || x.s != i+1) DEBUG_CHECK } + void checkScsi (Scsi x, int i) + { if (x.c != i/16 || x.s != i+1 || x.i != i+2) DEBUG_CHECK } + void checkScis (Scis x, int i) + { if (x.c != i/16 || x.i != i+1 || x.s != i+2) DEBUG_CHECK } + + T(0, Ssc) + T(1, Ssc) + T(2, Ssc) + T(3, Ssc) + T(4, Ssc) + T(5, Ssc) + T(6, Ssc) + T(7, Ssc) + T(8, Ssc) + T(9, Ssc) + T(10, Ssc) + T(11, Ssc) + T(12, Ssc) + T(13, Ssc) + T(14, Ssc) + T(15, Ssc) + T(0, Sis) + T(1, Sis) + T(2, Sis) + T(3, Sis) + T(4, Sis) + T(5, Sis) + T(6, Sis) + T(7, Sis) + T(8, Sis) + T(9, Sis) + T(10, Sis) + T(11, Sis) + T(12, Sis) + T(13, Sis) + T(14, Sis) + T(15, Sis) + + #undef T + + void + struct_by_value_8_x () + { + DEBUG_INIT + + #define T(N, TYPE) testit##TYPE##N (); + + T(0, Ssc) + T(1, Ssc) + T(2, Ssc) + T(3, Ssc) + T(4, Ssc) + T(5, Ssc) + T(6, Ssc) + T(7, Ssc) + T(8, Ssc) + T(9, Ssc) + T(10, Ssc) + T(11, Ssc) + T(12, Ssc) + T(13, Ssc) + T(14, Ssc) + T(15, Ssc) + T(0, Sis) + T(1, Sis) + T(2, Sis) + T(3, Sis) + T(4, Sis) + T(5, Sis) + T(6, Sis) + T(7, Sis) + T(8, Sis) + T(9, Sis) + T(10, Sis) + T(11, Sis) + T(12, Sis) + T(13, Sis) + T(14, Sis) + T(15, Sis) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-8_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-8_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + void initSc (Sc *p, int i) { p->c = i/16; } + void initSs (Ss *p, int i) { p->s = i; } + void initSi (Si *p, int i) { p->i = i; } + void initSsc (Ssc *p, int i) { p->s = i; p->c = (i/16)+1; } + void initSis (Sis *p, int i) { p->i = i; p->s = i+1; } + void initScsi (Scsi *p, int i) { p->c = i/16; p->s = i+1; p->i = i+2; } + void initScis (Scis *p, int i) { p->c = i/16; p->i = i+1; p->s = i+2; } + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + extern struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + extern struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + extern struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + extern struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + extern struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + extern struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + extern struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + extern struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void check##TYPE (TYPE x, int i); \ + extern void \ + check##TYPE##N (struct S##TYPE##N *p, int i); \ + \ + void \ + checkg##TYPE##N (void) \ + { \ + check##TYPE##N ( &g1s##TYPE##N, 1*16); \ + check##TYPE##N ( &g2s##TYPE##N, 2*16); \ + check##TYPE##N ( &g3s##TYPE##N, 3*16); \ + check##TYPE##N ( &g4s##TYPE##N, 4*16); \ + check##TYPE##N ( &g5s##TYPE##N, 5*16); \ + check##TYPE##N ( &g6s##TYPE##N, 6*16); \ + check##TYPE##N ( &g7s##TYPE##N, 7*16); \ + check##TYPE##N ( &g8s##TYPE##N, 8*16); \ + check##TYPE##N ( &g9s##TYPE##N, 9*16); \ + check##TYPE##N (&g10s##TYPE##N, 10*16); \ + check##TYPE##N (&g11s##TYPE##N, 11*16); \ + check##TYPE##N (&g12s##TYPE##N, 12*16); \ + check##TYPE##N (&g13s##TYPE##N, 13*16); \ + check##TYPE##N (&g14s##TYPE##N, 14*16); \ + check##TYPE##N (&g15s##TYPE##N, 15*16); \ + check##TYPE##N (&g16s##TYPE##N, 16*16); \ + } \ + \ + void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16) \ + { \ + check##TYPE##N (&s1, 1*16); \ + check##TYPE##N (&s2, 2*16); \ + check##TYPE##N (&s3, 3*16); \ + check##TYPE##N (&s4, 4*16); \ + check##TYPE##N (&s5, 5*16); \ + check##TYPE##N (&s6, 6*16); \ + check##TYPE##N (&s7, 7*16); \ + check##TYPE##N (&s8, 8*16); \ + check##TYPE##N (&s9, 9*16); \ + check##TYPE##N (&s10, 10*16); \ + check##TYPE##N (&s11, 11*16); \ + check##TYPE##N (&s12, 12*16); \ + check##TYPE##N (&s13, 13*16); \ + check##TYPE##N (&s14, 14*16); \ + check##TYPE##N (&s15, 15*16); \ + check##TYPE##N (&s16, 16*16); \ + } \ + \ + void \ + testva##TYPE##N (int n, ...) \ + { \ + int i; \ + va_list ap; \ + if (test_va) \ + { \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + { \ + struct S##TYPE##N t = va_arg (ap, struct S##TYPE##N); \ + check##TYPE##N (&t, (i+1)*16); \ + } \ + va_end (ap); \ + } \ + } + + T(0, Ssc) + T(1, Ssc) + T(2, Ssc) + T(3, Ssc) + T(4, Ssc) + T(5, Ssc) + T(6, Ssc) + T(7, Ssc) + T(8, Ssc) + T(9, Ssc) + T(10, Ssc) + T(11, Ssc) + T(12, Ssc) + T(13, Ssc) + T(14, Ssc) + T(15, Ssc) + T(0, Sis) + T(1, Sis) + T(2, Sis) + T(3, Sis) + T(4, Sis) + T(5, Sis) + T(6, Sis) + T(7, Sis) + T(8, Sis) + T(9, Sis) + T(10, Sis) + T(11, Sis) + T(12, Sis) + T(13, Sis) + T(14, Sis) + T(15, Sis) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test structures passed by value, including to a function with a + variable-length argument list. Each struct contains an array + of small structs, each with three scalar members. */ + + extern void struct_by_value_9_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_by_value_9_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,216 ---- + #include "compat-common.h" + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void init##TYPE (TYPE *p, int i); \ + extern void checkg##TYPE##N (void); \ + extern void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16); \ + extern void testva##TYPE##N (int n, ...); \ + \ + \ + void \ + init##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + init##TYPE(&p->i[j], i+j); \ + } \ + \ + void \ + check##TYPE##N (struct S##TYPE##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + check##TYPE(p->i[j], i+j); \ + } \ + \ + void \ + test2_##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8) \ + { \ + test##TYPE##N (s1, g2s##TYPE##N, s2, g4s##TYPE##N, \ + s3, g6s##TYPE##N, s4, g8s##TYPE##N, \ + s5, g10s##TYPE##N, s6, g12s##TYPE##N, \ + s7, g14s##TYPE##N, s8, g16s##TYPE##N); \ + } \ + \ + void \ + testit##TYPE##N (void) \ + { \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" init: "); \ + init##TYPE##N ( &g1s##TYPE##N, 1*16); \ + init##TYPE##N ( &g2s##TYPE##N, 2*16); \ + init##TYPE##N ( &g3s##TYPE##N, 3*16); \ + init##TYPE##N ( &g4s##TYPE##N, 4*16); \ + init##TYPE##N ( &g5s##TYPE##N, 5*16); \ + init##TYPE##N ( &g6s##TYPE##N, 6*16); \ + init##TYPE##N ( &g7s##TYPE##N, 7*16); \ + init##TYPE##N ( &g8s##TYPE##N, 8*16); \ + init##TYPE##N ( &g9s##TYPE##N, 9*16); \ + init##TYPE##N (&g10s##TYPE##N, 10*16); \ + init##TYPE##N (&g11s##TYPE##N, 11*16); \ + init##TYPE##N (&g12s##TYPE##N, 12*16); \ + init##TYPE##N (&g13s##TYPE##N, 13*16); \ + init##TYPE##N (&g14s##TYPE##N, 14*16); \ + init##TYPE##N (&g15s##TYPE##N, 15*16); \ + init##TYPE##N (&g16s##TYPE##N, 16*16); \ + checkg##TYPE##N (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test: "); \ + test##TYPE##N (g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" testva:"); \ + DEBUG_NL; \ + testva##TYPE##N (16, \ + g1s##TYPE##N, g2s##TYPE##N, \ + g3s##TYPE##N, g4s##TYPE##N, \ + g5s##TYPE##N, g6s##TYPE##N, \ + g7s##TYPE##N, g8s##TYPE##N, \ + g9s##TYPE##N, g10s##TYPE##N, \ + g11s##TYPE##N, g12s##TYPE##N, \ + g13s##TYPE##N, g14s##TYPE##N, \ + g15s##TYPE##N, g16s##TYPE##N); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE "[" #N "]"); \ + DEBUG_FPUTS (" test2: "); \ + test2_##TYPE##N (g1s##TYPE##N, g3s##TYPE##N, \ + g5s##TYPE##N, g7s##TYPE##N, \ + g9s##TYPE##N, g11s##TYPE##N, \ + g13s##TYPE##N, g15s##TYPE##N); \ + DEBUG_NL; \ + } + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + extern void abort (void); + + void checkSc (Sc x, int i) { if (x.c != i/16) DEBUG_CHECK } + void checkSs (Ss x, int i) { if (x.s != i) DEBUG_CHECK } + void checkSi (Si x, int i) { if (x.i != i) DEBUG_CHECK } + void checkSsc (Ssc x, int i) + { if (x.s != i || x.c != (i/16)+1) DEBUG_CHECK } + void checkSis (Sis x, int i) + { if (x.i != i || x.s != i+1) DEBUG_CHECK } + void checkScsi (Scsi x, int i) + { if (x.c != i/16 || x.s != i+1 || x.i != i+2) DEBUG_CHECK } + void checkScis (Scis x, int i) + { if (x.c != i/16 || x.i != i+1 || x.s != i+2) DEBUG_CHECK } + + T(0, Scsi) + T(1, Scsi) + T(2, Scsi) + T(3, Scsi) + T(4, Scsi) + T(5, Scsi) + T(6, Scsi) + T(7, Scsi) + T(8, Scsi) + T(9, Scsi) + T(10, Scsi) + T(11, Scsi) + T(12, Scsi) + T(13, Scsi) + T(14, Scsi) + T(15, Scsi) + T(0, Scis) + T(1, Scis) + T(2, Scis) + T(3, Scis) + T(4, Scis) + T(5, Scis) + T(6, Scis) + T(7, Scis) + T(8, Scis) + T(9, Scis) + T(10, Scis) + T(11, Scis) + T(12, Scis) + T(13, Scis) + T(14, Scis) + T(15, Scis) + + #undef T + + void + struct_by_value_9_x () + { + DEBUG_INIT + + #define T(N, TYPE) testit##TYPE##N (); + + T(0, Scsi) + T(1, Scsi) + T(2, Scsi) + T(3, Scsi) + T(4, Scsi) + T(5, Scsi) + T(6, Scsi) + T(7, Scsi) + T(8, Scsi) + T(9, Scsi) + T(10, Scsi) + T(11, Scsi) + T(12, Scsi) + T(13, Scsi) + T(14, Scsi) + T(15, Scsi) + T(0, Scis) + T(1, Scis) + T(2, Scis) + T(3, Scis) + T(4, Scis) + T(5, Scis) + T(6, Scis) + T(7, Scis) + T(8, Scis) + T(9, Scis) + T(10, Scis) + T(11, Scis) + T(12, Scis) + T(13, Scis) + T(14, Scis) + T(15, Scis) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-by-value-9_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-by-value-9_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,141 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + typedef struct { char c; } Sc; + typedef struct { short s; } Ss; + typedef struct { int i; } Si; + typedef struct { short s; char c; } Ssc; + typedef struct { int i; short s; } Sis; + typedef struct { char c; short s; int i; } Scsi; + typedef struct { char c; int i; short s; } Scis; + + void initSc (Sc *p, int i) { p->c = i/16; } + void initSs (Ss *p, int i) { p->s = i; } + void initSi (Si *p, int i) { p->i = i; } + void initSsc (Ssc *p, int i) { p->s = i; p->c = (i/16)+1; } + void initSis (Sis *p, int i) { p->i = i; p->s = i+1; } + void initScsi (Scsi *p, int i) { p->c = i/16; p->s = i+1; p->i = i+2; } + void initScis (Scis *p, int i) { p->c = i/16; p->i = i+1; p->s = i+2; } + + #define T(N, TYPE) \ + struct S##TYPE##N { TYPE i[N]; }; \ + \ + extern struct S##TYPE##N g1s##TYPE##N, g2s##TYPE##N; \ + extern struct S##TYPE##N g3s##TYPE##N, g4s##TYPE##N; \ + extern struct S##TYPE##N g5s##TYPE##N, g6s##TYPE##N; \ + extern struct S##TYPE##N g7s##TYPE##N, g8s##TYPE##N; \ + extern struct S##TYPE##N g9s##TYPE##N, g10s##TYPE##N; \ + extern struct S##TYPE##N g11s##TYPE##N, g12s##TYPE##N; \ + extern struct S##TYPE##N g13s##TYPE##N, g14s##TYPE##N; \ + extern struct S##TYPE##N g15s##TYPE##N, g16s##TYPE##N; \ + \ + extern void check##TYPE (TYPE x, int i); \ + extern void \ + check##TYPE##N (struct S##TYPE##N *p, int i); \ + \ + void \ + checkg##TYPE##N (void) \ + { \ + check##TYPE##N ( &g1s##TYPE##N, 1*16); \ + check##TYPE##N ( &g2s##TYPE##N, 2*16); \ + check##TYPE##N ( &g3s##TYPE##N, 3*16); \ + check##TYPE##N ( &g4s##TYPE##N, 4*16); \ + check##TYPE##N ( &g5s##TYPE##N, 5*16); \ + check##TYPE##N ( &g6s##TYPE##N, 6*16); \ + check##TYPE##N ( &g7s##TYPE##N, 7*16); \ + check##TYPE##N ( &g8s##TYPE##N, 8*16); \ + check##TYPE##N ( &g9s##TYPE##N, 9*16); \ + check##TYPE##N (&g10s##TYPE##N, 10*16); \ + check##TYPE##N (&g11s##TYPE##N, 11*16); \ + check##TYPE##N (&g12s##TYPE##N, 12*16); \ + check##TYPE##N (&g13s##TYPE##N, 13*16); \ + check##TYPE##N (&g14s##TYPE##N, 14*16); \ + check##TYPE##N (&g15s##TYPE##N, 15*16); \ + check##TYPE##N (&g16s##TYPE##N, 16*16); \ + } \ + \ + void \ + test##TYPE##N (struct S##TYPE##N s1, struct S##TYPE##N s2, \ + struct S##TYPE##N s3, struct S##TYPE##N s4, \ + struct S##TYPE##N s5, struct S##TYPE##N s6, \ + struct S##TYPE##N s7, struct S##TYPE##N s8, \ + struct S##TYPE##N s9, struct S##TYPE##N s10, \ + struct S##TYPE##N s11, struct S##TYPE##N s12, \ + struct S##TYPE##N s13, struct S##TYPE##N s14, \ + struct S##TYPE##N s15, struct S##TYPE##N s16) \ + { \ + check##TYPE##N (&s1, 1*16); \ + check##TYPE##N (&s2, 2*16); \ + check##TYPE##N (&s3, 3*16); \ + check##TYPE##N (&s4, 4*16); \ + check##TYPE##N (&s5, 5*16); \ + check##TYPE##N (&s6, 6*16); \ + check##TYPE##N (&s7, 7*16); \ + check##TYPE##N (&s8, 8*16); \ + check##TYPE##N (&s9, 9*16); \ + check##TYPE##N (&s10, 10*16); \ + check##TYPE##N (&s11, 11*16); \ + check##TYPE##N (&s12, 12*16); \ + check##TYPE##N (&s13, 13*16); \ + check##TYPE##N (&s14, 14*16); \ + check##TYPE##N (&s15, 15*16); \ + check##TYPE##N (&s16, 16*16); \ + } \ + \ + void \ + testva##TYPE##N (int n, ...) \ + { \ + int i; \ + va_list ap; \ + if (test_va) \ + { \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + { \ + struct S##TYPE##N t = va_arg (ap, struct S##TYPE##N); \ + check##TYPE##N (&t, (i+1)*16); \ + } \ + va_end (ap); \ + } \ + } + + T(0, Scsi) + T(1, Scsi) + T(2, Scsi) + T(3, Scsi) + T(4, Scsi) + T(5, Scsi) + T(6, Scsi) + T(7, Scsi) + T(8, Scsi) + T(9, Scsi) + T(10, Scsi) + T(11, Scsi) + T(12, Scsi) + T(13, Scsi) + T(14, Scsi) + T(15, Scsi) + T(0, Scis) + T(1, Scis) + T(2, Scis) + T(3, Scis) + T(4, Scis) + T(5, Scis) + T(6, Scis) + T(7, Scis) + T(8, Scis) + T(9, Scis) + T(10, Scis) + T(11, Scis) + T(12, Scis) + T(13, Scis) + T(14, Scis) + T(15, Scis) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_main.c 2003-06-10 21:01:38.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test function return values. For this test, all struct members are + scalar floating point types. */ + + extern void struct_return_10_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_return_10_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,119 ---- + #include "compat-common.h" + + #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, double y); \ + 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.0); \ + init##TYPE (&g02##TYPE, 2.0); \ + init##TYPE (&g03##TYPE, 3.0); \ + init##TYPE (&g04##TYPE, 4.0); \ + init##TYPE (&g05##TYPE, 5.0); \ + init##TYPE (&g06##TYPE, 6.0); \ + init##TYPE (&g07##TYPE, 7.0); \ + init##TYPE (&g08##TYPE, 8.0); \ + init##TYPE (&g09##TYPE, 9.0); \ + init##TYPE (&g10##TYPE, 10.0); \ + init##TYPE (&g11##TYPE, 11.0); \ + init##TYPE (&g12##TYPE, 12.0); \ + init##TYPE (&g13##TYPE, 13.0); \ + init##TYPE (&g14##TYPE, 14.0); \ + init##TYPE (&g15##TYPE, 15.0); \ + init##TYPE (&g16##TYPE, 16.0); \ + checkg##TYPE (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##TYPE (); \ + check##TYPE (rslt, 1.0); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##TYPE (g01##TYPE); \ + check##TYPE (rslt, 1.0); \ + DEBUG_NL; \ + DEBUG_FPUTS (#TYPE); \ + DEBUG_FPUTS (" testva:"); \ + rslt = testva##TYPE (1, g01##TYPE); \ + check##TYPE (rslt, 1.0); \ + rslt = testva##TYPE (5, g01##TYPE, g02##TYPE, \ + g03##TYPE, g04##TYPE, \ + g05##TYPE); \ + check##TYPE (rslt, 5.0); \ + 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.0); \ + 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.0); \ + DEBUG_NL; \ + } + + #include "fp2-struct-defs.h" + #include "fp2-struct-check.h" + + T(Sfd); + T(Sfl); + T(Sdf); + T(Sdl); + T(Slf); + T(Sld); + T(Sfdl); + T(Sfld); + T(Sdfl); + T(Sdlf); + T(Slfd); + T(Sldf); + + #undef T + + void + struct_return_10_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Sfd); + T(Sfl); + T(Sdf); + T(Sdl); + T(Slf); + T(Sld); + T(Sfdl); + T(Sfld); + T(Sdfl); + T(Sdlf); + T(Slfd); + T(Sldf); + + DEBUG_FINI + + if (fails != 0) + return; + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-10_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-10_y.c 2003-06-10 21:01:39.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + #include + + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #include "fp2-struct-defs.h" + #include "fp2-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, double y); \ + \ + void \ + checkg##TYPE (void) \ + { \ + check##TYPE (g01##TYPE, 1.0); \ + check##TYPE (g02##TYPE, 2.0); \ + check##TYPE (g03##TYPE, 3.0); \ + check##TYPE (g04##TYPE, 4.0); \ + check##TYPE (g05##TYPE, 5.0); \ + check##TYPE (g06##TYPE, 6.0); \ + check##TYPE (g07##TYPE, 7.0); \ + check##TYPE (g08##TYPE, 8.0); \ + check##TYPE (g09##TYPE, 9.0); \ + check##TYPE (g10##TYPE, 10.0); \ + check##TYPE (g11##TYPE, 11.0); \ + check##TYPE (g12##TYPE, 12.0); \ + check##TYPE (g13##TYPE, 13.0); \ + check##TYPE (g14##TYPE, 14.0); \ + check##TYPE (g15##TYPE, 15.0); \ + check##TYPE (g16##TYPE, 16.0); \ + } \ + \ + 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; \ + if (test_va) \ + { \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + { \ + rslt = va_arg (ap, TYPE); \ + } \ + va_end (ap); \ + } \ + return rslt; \ + } + + T(Sfd) + T(Sfl) + T(Sdf) + T(Sdl) + T(Slf) + T(Sld) + T(Sfdl) + T(Sfld) + T(Sdfl) + T(Sdlf) + T(Slfd) + T(Sldf) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_main.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Test function return values. Struct members are char, int, double, + and other structs containing these types. This test was written in + response to a layout change for such structs for powerpc64-linux, + but this test only checks similar structs that are not affected by + that break in compatibility. */ + + extern void struct_return_19_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_return_19_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_x.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,123 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + 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(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) + + #undef T + + void + struct_return_19_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-19_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-19_y.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + #include + + #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(Scdc) + T(Sd) + T(Sdi) + T(Scsdsc) + T(Scsdis) + T(Scsdisc) + T(Ssds) + T(Ssdsc) + T(Scssdssc) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_main.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test function return values. Tested structs end with double. This + was written in response to a layout change for such structs for + powerpc64-linux that breaks compatibility between 3.3 and 3.4. */ + + extern void struct_return_20_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_return_20_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_x.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,111 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + 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(Scd) + T(Scsds) + T(Scssdss) + + #undef T + + void + struct_return_20_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Scd) + T(Scsds) + T(Scssdss) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-20_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-20_y.c 2003-09-19 21:09:52.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + #include + + #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(Scd) + T(Scsds) + T(Scssdss) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test function return values. This test includes structs that are + arrays of unsigned integral scalars. */ + + extern void struct_return_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_return_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,218 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + const int test_va = 0; + #else + const int test_va = 1; + #endif + + #define T(N, NAME, TYPE) \ + struct S##NAME##N { TYPE i[N]; }; \ + struct S##NAME##N g1s##NAME##N, g2s##NAME##N; \ + struct S##NAME##N g3s##NAME##N, g4s##NAME##N; \ + struct S##NAME##N g5s##NAME##N, g6s##NAME##N; \ + struct S##NAME##N g7s##NAME##N, g8s##NAME##N; \ + struct S##NAME##N g9s##NAME##N, g10s##NAME##N; \ + struct S##NAME##N g11s##NAME##N, g12s##NAME##N; \ + struct S##NAME##N g13s##NAME##N, g14s##NAME##N; \ + struct S##NAME##N g15s##NAME##N, g16s##NAME##N; \ + \ + extern void init##NAME##N (struct S##NAME##N *p, int i); \ + extern void checkg##NAME##N (void); \ + extern struct S##NAME##N test0##NAME##N (void); \ + extern struct S##NAME##N test1##NAME##N (struct S##NAME##N); \ + extern struct S##NAME##N testva##NAME##N (int n, ...); \ + \ + void \ + check##NAME##N (struct S##NAME##N *p, int i) \ + { \ + int j; \ + DEBUG_DOT; \ + for (j = 0; j < N; j++) \ + if (p->i[j] != (TYPE) (i + j)) \ + { \ + DEBUG_FAIL; \ + } \ + } \ + \ + void \ + testit##NAME##N (void) \ + { \ + struct S##NAME##N rslt; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" init: "); \ + init##NAME##N ( &g1s##NAME##N, 1*16); \ + init##NAME##N ( &g2s##NAME##N, 2*16); \ + init##NAME##N ( &g3s##NAME##N, 3*16); \ + init##NAME##N ( &g4s##NAME##N, 4*16); \ + init##NAME##N ( &g5s##NAME##N, 5*16); \ + init##NAME##N ( &g6s##NAME##N, 6*16); \ + init##NAME##N ( &g7s##NAME##N, 7*16); \ + init##NAME##N ( &g8s##NAME##N, 8*16); \ + init##NAME##N ( &g9s##NAME##N, 9*16); \ + init##NAME##N (&g10s##NAME##N, 10*16); \ + init##NAME##N (&g11s##NAME##N, 11*16); \ + init##NAME##N (&g12s##NAME##N, 12*16); \ + init##NAME##N (&g13s##NAME##N, 13*16); \ + init##NAME##N (&g14s##NAME##N, 14*16); \ + init##NAME##N (&g15s##NAME##N, 15*16); \ + init##NAME##N (&g16s##NAME##N, 16*16); \ + checkg##NAME##N (); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" test0: "); \ + rslt = test0##NAME##N (); \ + check##NAME##N (&rslt, 1*16); \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" test1: "); \ + rslt = test1##NAME##N (g1s##NAME##N); \ + check##NAME##N (&rslt, 1*16); \ + if (test_va) \ + { \ + DEBUG_NL; \ + DEBUG_FPUTS (#NAME "[" #N "]"); \ + DEBUG_FPUTS (" testva: "); \ + rslt = testva##NAME##N (1, g1s##NAME##N); \ + check##NAME##N (&rslt, 1*16); \ + rslt = testva##NAME##N (5, \ + g1s##NAME##N, g2s##NAME##N, \ + g3s##NAME##N, g4s##NAME##N, \ + g5s##NAME##N); \ + check##NAME##N (&rslt, 5*16); \ + rslt = testva##NAME##N (9, \ + g1s##NAME##N, g2s##NAME##N, \ + g3s##NAME##N, g4s##NAME##N, \ + g5s##NAME##N, g6s##NAME##N, \ + g7s##NAME##N, g8s##NAME##N, \ + g9s##NAME##N); \ + check##NAME##N (&rslt, 9*16); \ + rslt = testva##NAME##N (16, \ + g1s##NAME##N, g2s##NAME##N, \ + g3s##NAME##N, g4s##NAME##N, \ + g5s##NAME##N, g6s##NAME##N, \ + g7s##NAME##N, g8s##NAME##N, \ + g9s##NAME##N, g10s##NAME##N, \ + g11s##NAME##N, g12s##NAME##N, \ + g13s##NAME##N, g14s##NAME##N, \ + g15s##NAME##N, g16s##NAME##N); \ + check##NAME##N (&rslt, 16*16); \ + } \ + DEBUG_NL; \ + } + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) + + #undef T + + void + struct_return_2_x () + { + DEBUG_INIT + + #define T(N, NAME, TYPE) testit##NAME##N (); + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-2_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,120 ---- + #include + + #include "compat-common.h" + + #define T(N, NAME, TYPE) \ + struct S##NAME##N { TYPE i[N]; }; \ + \ + extern struct S##NAME##N g1s##NAME##N, g2s##NAME##N; \ + extern struct S##NAME##N g3s##NAME##N, g4s##NAME##N; \ + extern struct S##NAME##N g5s##NAME##N, g6s##NAME##N; \ + extern struct S##NAME##N g7s##NAME##N, g8s##NAME##N; \ + extern struct S##NAME##N g9s##NAME##N, g10s##NAME##N; \ + extern struct S##NAME##N g11s##NAME##N, g12s##NAME##N; \ + extern struct S##NAME##N g13s##NAME##N, g14s##NAME##N; \ + extern struct S##NAME##N g15s##NAME##N, g16s##NAME##N; \ + \ + extern void check##NAME##N (struct S##NAME##N *p, int i); \ + \ + void \ + init##NAME##N (struct S##NAME##N *p, int i) \ + { \ + int j; \ + for (j = 0; j < N; j++) \ + p->i[j] = i + j; \ + } \ + \ + void \ + checkg##NAME##N (void) \ + { \ + check##NAME##N ( &g1s##NAME##N, 1*16); \ + check##NAME##N ( &g2s##NAME##N, 2*16); \ + check##NAME##N ( &g3s##NAME##N, 3*16); \ + check##NAME##N ( &g4s##NAME##N, 4*16); \ + check##NAME##N ( &g5s##NAME##N, 5*16); \ + check##NAME##N ( &g6s##NAME##N, 6*16); \ + check##NAME##N ( &g7s##NAME##N, 7*16); \ + check##NAME##N ( &g8s##NAME##N, 8*16); \ + check##NAME##N ( &g9s##NAME##N, 9*16); \ + check##NAME##N (&g10s##NAME##N, 10*16); \ + check##NAME##N (&g11s##NAME##N, 11*16); \ + check##NAME##N (&g12s##NAME##N, 12*16); \ + check##NAME##N (&g13s##NAME##N, 13*16); \ + check##NAME##N (&g14s##NAME##N, 14*16); \ + check##NAME##N (&g15s##NAME##N, 15*16); \ + check##NAME##N (&g16s##NAME##N, 16*16); \ + } \ + \ + struct S##NAME##N \ + test0##NAME##N (void) \ + { \ + return g1s##NAME##N; \ + } \ + \ + struct S##NAME##N \ + test1##NAME##N (struct S##NAME##N x01) \ + { \ + return x01; \ + } \ + \ + struct S##NAME##N \ + testva##NAME##N (int n, ...) \ + { \ + int i; \ + struct S##NAME##N rslt; \ + va_list ap; \ + va_start (ap, n); \ + for (i = 0; i < n; i++) \ + rslt = va_arg (ap, struct S##NAME##N); \ + va_end (ap); \ + return rslt; \ + } + + T(0, uc, unsigned char) + T(1, uc, unsigned char) + T(2, uc, unsigned char) + T(3, uc, unsigned char) + T(4, uc, unsigned char) + T(5, uc, unsigned char) + T(6, uc, unsigned char) + T(7, uc, unsigned char) + T(8, uc, unsigned char) + T(9, uc, unsigned char) + T(10, uc, unsigned char) + T(11, uc, unsigned char) + T(12, uc, unsigned char) + T(13, uc, unsigned char) + T(14, uc, unsigned char) + T(15, uc, unsigned char) + T(0, us, unsigned short) + T(1, us, unsigned short) + T(2, us, unsigned short) + T(3, us, unsigned short) + T(4, us, unsigned short) + T(5, us, unsigned short) + T(6, us, unsigned short) + T(7, us, unsigned short) + T(8, us, unsigned short) + T(9, us, unsigned short) + T(10, us, unsigned short) + T(11, us, unsigned short) + T(12, us, unsigned short) + T(13, us, unsigned short) + T(14, us, unsigned short) + T(15, us, unsigned short) + T(0, ui, unsigned int) + T(1, ui, unsigned int) + T(2, ui, unsigned int) + T(3, ui, unsigned int) + T(4, ui, unsigned int) + T(5, ui, unsigned int) + T(6, ui, unsigned int) + T(7, ui, unsigned int) + T(8, ui, unsigned int) + T(9, ui, unsigned int) + T(10, ui, unsigned int) + T(11, ui, unsigned int) + T(12, ui, unsigned int) + T(13, ui, unsigned int) + T(14, ui, unsigned int) + T(15, ui, unsigned int) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_main.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test function return values. For this test, all struct members are + scalar integral types and the structs are "small": 1, 2, 4, 8, and 12 + bytes for LP64. */ + + extern void struct_return_3_x (void); + extern void exit (int); + int fails; + + int + main () + { + struct_return_3_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_x.c 2003-07-03 18:31:59.000000000 +0000 *************** *** 0 **** --- 1,135 ---- + #include "compat-common.h" + + /* Turn off checking for variable arguments with -DSKIPVA. */ + #ifdef SKIPVA + 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 "small-struct-defs.h" + #include "small-struct-check.h" + + T(Sc) + T(Ss) + T(Si) + T(Scs) + T(Ssc) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) + + #undef T + + void + struct_return_3_x () + { + DEBUG_INIT + + #define T(TYPE) testit##TYPE (); + + T(Sc) + T(Ss) + T(Si) + T(Scs) + T(Ssc) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) + + DEBUG_FINI + + if (fails != 0) + abort (); + + #undef T + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/struct-return-3_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/struct-return-3_y.c 2003-06-10 19:08:33.000000000 +0000 *************** *** 0 **** --- 1,76 ---- + #include + + #include "compat-common.h" + + #include "small-struct-defs.h" + #include "small-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(Sc) + T(Ss) + T(Si) + T(Scs) + T(Ssc) + T(Sic) + T(Sci) + T(Ssi) + T(Sis) + T(Scsi) + T(Scis) + T(Ssci) + T(Ssic) + T(Sisc) + T(Sics) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_main.c 2003-07-03 20:37:42.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test compatibility of vector types: layout between separately-compiled + modules, parameter passing, and function return. This test uses + vectors of integer values. */ + + extern void vector_1_x (void); + extern void exit (int); + int fails; + + int + main () + { + vector_1_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_x.c 2003-11-27 10:43:01.000000000 +0000 *************** *** 0 **** --- 1,37 ---- + /* { dg-options "-w" } */ + /* { dg-xfail-if "PR target/12916" "sparc*-*-*" "*" "" } */ + + #include "compat-common.h" + #include "vector-defs.h" + #include "vector-setup.h" + + SETUP (8, qi); + SETUP (16, qi); + SETUP (2, hi); + SETUP (4, hi); + SETUP (8, hi); + SETUP (2, si); + SETUP (4, si); + SETUP (1, di); + SETUP (2, di); + + void + vector_1_x (void) + { + DEBUG_INIT + + CHECK (8, qi); + CHECK (16, qi); + CHECK (2, hi); + CHECK (4, hi); + CHECK (8, hi); + CHECK (2, si); + CHECK (4, si); + CHECK (1, di); + CHECK (2, di); + + DEBUG_FINI + + if (fails != 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-1_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-1_y.c 2003-11-27 10:43:01.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* { dg-options "-w" } */ + /* { dg-xfail-if "PR target/12916" "sparc*-*-*" "*" "" } */ + + #include "compat-common.h" + #include "vector-defs.h" + #include "vector-check.h" + + TEST (8, qi, 101) + TEST (16, qi, 101) + TEST (2, hi, 201) + TEST (4, hi, 202) + TEST (8, hi, 203) + TEST (2, si, 301) + TEST (4, si, 302) + TEST (1, di, 401) + TEST (2, di, 402) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_main.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_main.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_main.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_main.c 2003-07-03 20:37:42.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Test compatibility of vector types: layout between separately-compiled + modules, parameter passing, and function return. This test uses + vectors of floating points values. */ + + extern void vector_2_x (void); + extern void exit (int); + int fails; + + int + main () + { + vector_2_x (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_x.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_x.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_x.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_x.c 2003-11-27 10:43:01.000000000 +0000 *************** *** 0 **** --- 1,27 ---- + /* { dg-options "-w" } */ + /* { dg-xfail-if "PR target/12916" "sparc*-*-*" "*" "" } */ + + #include "compat-common.h" + #include "vector-defs.h" + #include "vector-setup.h" + + SETUP (2, sf); + SETUP (4, sf); + SETUP (16, sf); + SETUP (2, df); + + void + vector_2_x (void) + { + DEBUG_INIT + + CHECK (2, sf); + CHECK (4, sf); + CHECK (16, sf); + CHECK (2, df); + + DEBUG_FINI + + if (fails != 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_y.c gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_y.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-2_y.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-2_y.c 2003-11-27 10:43:01.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* { dg-options "-w" } */ + /* { dg-xfail-if "PR target/12916" "sparc*-*-*" "*" "" } */ + + #include "compat-common.h" + #include "vector-defs.h" + #include "vector-check.h" + + TEST (2, sf, 301.0) + TEST (4, sf, 302.0) + TEST (16, sf, 304.0) + TEST (2, df, 402.0) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-check.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-check.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-check.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-check.h 2003-12-02 20:29:47.000000000 +0000 *************** *** 0 **** --- 1,64 ---- + #define TEST(NUM,TMODE,VAL) \ + extern v##NUM##TMODE g_v##NUM##TMODE; \ + extern TMODE g_##TMODE; \ + \ + extern void pass_v##NUM##TMODE (v##NUM##TMODE); \ + extern v##NUM##TMODE return_v##NUM##TMODE (void); \ + \ + void \ + checkp_##NUM##TMODE (TMODE *p) \ + { \ + int i; \ + for (i = 0; i < NUM; i++) \ + { \ + if (p[i] != g_##TMODE + i) \ + DEBUG_CHECK; \ + } \ + } \ + \ + void \ + checkg_##NUM##TMODE (void) \ + { \ + u##NUM##TMODE u; \ + TMODE *p = u.a; \ + \ + u.v = g_v##NUM##TMODE; \ + checkp_##NUM##TMODE (p); \ + } \ + \ + void \ + init_##NUM##TMODE (void) \ + { \ + int i; \ + u##NUM##TMODE u; \ + g_##TMODE = VAL; \ + for (i = 0; i < NUM; i++) \ + u.a[i] = VAL + i; \ + g_v##NUM##TMODE = u.v; \ + } \ + \ + void \ + test_v##NUM##TMODE (void) \ + { \ + v##NUM##TMODE v; \ + u##NUM##TMODE u; \ + TMODE *p = u.a; \ + \ + DEBUG_FPUTS ("v" #NUM #TMODE); \ + DEBUG_NL; \ + DEBUG_FPUTS (" global variable:"); \ + init_##NUM##TMODE (); \ + checkg_##NUM##TMODE (); \ + DEBUG_NL; \ + DEBUG_FPUTS (" pass global variable:"); \ + pass_v##NUM##TMODE (g_v##NUM##TMODE); \ + DEBUG_NL; \ + DEBUG_FPUTS (" pass local variable:"); \ + v = g_v##NUM##TMODE; \ + pass_v##NUM##TMODE (v); \ + DEBUG_NL; \ + DEBUG_FPUTS (" function return:"); \ + u.v = return_v##NUM##TMODE (); \ + checkp_##NUM##TMODE (p); \ + DEBUG_NL; \ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-defs.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-defs.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-defs.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-defs.h 2003-07-03 20:37:42.000000000 +0000 *************** *** 0 **** --- 1,46 ---- + /* This includes all of the vector modes that are recognized by + c_common_type_for_mode, grouped by base mode. */ + + typedef int __attribute__((mode(QI))) qi; + typedef int __attribute__((mode(V8QI))) v8qi; + typedef int __attribute__((mode(V16QI))) v16qi; + + typedef union U8QI { v8qi v; qi a[8]; } u8qi; + typedef union U16QI { v16qi v; qi a[16]; } u16qi; + + typedef int __attribute__((mode(HI))) hi; + typedef int __attribute__((mode(V2HI))) v2hi; + typedef int __attribute__((mode(V4HI))) v4hi; + typedef int __attribute__((mode(V8HI))) v8hi; + + typedef union U2HI { v2hi v; hi a[2]; } u2hi; + typedef union U4HI { v4hi v; hi a[4]; } u4hi; + typedef union U8HI { v8hi v; hi a[8]; } u8hi; + + typedef int __attribute__((mode(SI))) si; + typedef int __attribute__((mode(V2SI))) v2si; + typedef int __attribute__((mode(V4SI))) v4si; + + typedef union U2SI { v2si v; si a[2]; } u2si; + typedef union U4SI { v4si v; si a[4]; } u4si; + + typedef int __attribute__((mode(DI))) di; + typedef int __attribute__((mode(V1DI))) v1di; + typedef int __attribute__((mode(V2DI))) v2di; + + typedef union U1DI { v1di v; di a[1]; } u1di; + typedef union U2DI { v2di v; di a[2]; } u2di; + + typedef float __attribute__((mode(SF))) sf; + typedef float __attribute__((mode(V2SF))) v2sf; + typedef float __attribute__((mode(V4SF))) v4sf; + typedef float __attribute__((mode(V16SF))) v16sf; + + typedef union U2SF { v2sf v; sf a[2]; } u2sf; + typedef union U4SF { v4sf v; sf a[4]; } u4sf; + typedef union U16SF { v16sf v; sf a[16]; } u16sf; + + typedef float __attribute__((mode(DF))) df; + typedef float __attribute__((mode(V2DF))) v2df; + + typedef union U2DF { v2df v; df a[2]; } u2df; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-setup.h gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-setup.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/compat/vector-setup.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compat/vector-setup.h 2003-07-03 20:37:42.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + #define SETUP(NUM,TMODE) \ + v##NUM##TMODE g_v##NUM##TMODE; \ + TMODE g_##TMODE; \ + \ + extern void test_v##NUM##TMODE (void); \ + extern void checkp_##NUM##TMODE (TMODE *); \ + \ + void \ + pass_v##NUM##TMODE (v##NUM##TMODE v) \ + { \ + u##NUM##TMODE u; \ + int j; \ + TMODE a[NUM]; \ + \ + u.v = v; \ + for (j = 0; j < NUM; j++) \ + a[j] = u.a[j]; \ + checkp_##NUM##TMODE (a); \ + } \ + \ + v##NUM##TMODE \ + return_v##NUM##TMODE (void) \ + { \ + return g_v##NUM##TMODE; \ + } + + #define CHECK(NUM,TMODE) \ + test_v##NUM##TMODE() diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/complex-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/complex-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/complex-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/complex-1.c 2003-11-02 08:27:23.000000000 +0000 *************** *** 0 **** --- 1,31 ---- + /* { dg-do run } */ + /* { dg-options "-O" } */ + + /* Verify that the 6th complex floating-point argument is + correctly passed as unnamed argument on SPARC64. */ + + extern void abort(void); + + void foo(long arg1, long arg2, long arg3, long arg4, long arg5, ...) + { + __builtin_va_list ap; + _Complex float cf; + + __builtin_va_start(ap, arg5); + cf = __builtin_va_arg(ap, _Complex float); + __builtin_va_end(ap); + + if (__imag__ cf != 2.0f) + abort(); + } + + int bar(long arg1, long arg2, long arg3, long arg4, long arg5, _Complex float arg6) + { + foo(arg1, arg2, arg3, arg4, arg5, arg6); + return 0; + } + + int main(void) + { + return bar(0, 0, 0, 0, 0, 2.0fi); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/compound-lvalue-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/compound-lvalue-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/compound-lvalue-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/compound-lvalue-1.c 2003-11-08 01:38:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test for deprecation of compound expressions as lvalues. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + int x, y; + + void + foo (void) + { + (x, y) = 1; /* { dg-warning "lvalue" "compound expression as lvalue deprecated" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/concat.c gcc-3.4.0/gcc/testsuite/gcc.dg/concat.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/concat.c 2001-12-11 19:42:34.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/concat.c 2003-07-05 00:23:59.000000000 +0000 *************** *** 2,16 **** /* { dg-do compile } */ ! /* Test we output a warning for concatenation of artifical strings. Neil Booth, 10 Dec 2001. */ void foo () { ! char str1[] = __FUNCTION__ "."; /* { dg-warning "deprecated" } */ ! char str2[] = __PRETTY_FUNCTION__ ".";/* { dg-warning "deprecated" } */ ! char str3[] = "." __FUNCTION__; /* { dg-warning "deprecated" } */ ! char str4[] = "." __PRETTY_FUNCTION__;/* { dg-warning "deprecated" } */ ! char str5[] = "." "."; /* No warning. */ } --- 2,16 ---- /* { dg-do compile } */ ! /* Test we output an error for concatenation of artificial strings. Neil Booth, 10 Dec 2001. */ void foo () { ! char s1[] = __FUNCTION__"."; /* { dg-error "(parse|syntax|invalid)" } */ ! char s2[] = __PRETTY_FUNCTION__".";/* { dg-error "(parse|syntax|invalid)" } */ ! char s3[] = "."__FUNCTION__; /* { dg-error "(parse|syntax|invalid)" } */ ! char s4[] = "."__PRETTY_FUNCTION__;/* { dg-error "(parse|syntax|invalid)" } */ ! char s5[] = ".""."; /* No error. */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cond-lvalue-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cond-lvalue-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cond-lvalue-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cond-lvalue-1.c 2003-11-05 17:53:04.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test for deprecation of conditional expressions as lvalues. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + int x, y, z; + + void + foo (void) + { + (x ? y : z) = 1; /* { dg-warning "lvalue" "conditional expression as lvalue deprecated" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/const-elim-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/const-elim-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/const-elim-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/const-elim-1.c 2004-04-17 20:05:22.000000000 +0000 *************** *** 0 **** --- 1,54 ---- + /* Verify that constants in memory, referenced only by dead code, + are not emitted to the object file. + FIXME: Not presently possible to apply -pedantic to code with + complex constants in it. The __extension__ should shut up the + warning but doesn't. (Hard to fix -- the lexer is not aware of + the parser's state.) */ + + /* { dg-do compile } */ + /* { dg-options "-O2 -std=c99" } */ + /* This test fails on all processors where we use a block move to + initialize "S" in test2. The RTL optimizers are not clever enough + to eliminate the block move, so the constant gets emitted. + Currently known targets with this problem: all ARM; PA32 ("hppa*.*" + matches "hppa2.0w" but not "hppa64"); PPC if string instructions + are enabled (notably under AIX); Xtensa. */ + /* { dg-final { scan-assembler-not "L\\\$?C\[^A-Z\]" { xfail arm-*-* strongarm-*-* xscale-*-* hppa-*-* hppa*.*-*-* powerpc*-*-aix* xtensa-*-* } } } */ + + #define I (__extension__ 1.0iF) + + struct S { int a; double b[2]; void *c; }; + + extern void use_str(const char *); + extern void use_S(const struct S *); + extern void use_cplx(__complex__ double); + + static inline int + returns_23(void) { return 23; } + + void + test1(void) + { + if (returns_23() == 23) + return; + + use_str("waltz, nymph, for quick jigs vex bud"); + use_S(&(const struct S){12, {3.1415, 2.1828}, 0 }); + use_cplx(3.1415 + 2.1828*I); + } + + void + test2(void) + { + const char *str = "pack my box with five dozen liquor jugs"; + const struct S S = { 23, { 1.414, 1.618 }, 0 }; + const __complex__ double cplx = 1.414 + 1.618*I; + + if (returns_23() == 23) + return; + + use_str(str); + use_S(&S); + use_cplx(cplx); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/const-elim-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/const-elim-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/const-elim-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/const-elim-2.c 2003-05-05 21:57:54.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* The string constant in this test case should be emitted exactly once. */ + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + /* { dg-final { scan-assembler-times "hi there" 1 } } */ + + static inline int returns_23() { return 23; } + + const char *test1(void) { if (returns_23()) return 0; return "hi there"; } + const char *test2(void) { return "hi there"; } + const char *test3(void) { return "hi there"; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/19990228-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/19990228-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/19990228-1.c 2000-06-27 22:26:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/19990228-1.c 2003-06-02 19:21:15.000000000 +0000 *************** foo ("\ *** 18,29 **** ", NULL); ! /* ! { dg-final { if ![file exists 990228-1.i] { return } } } ! { dg-final { set tmp [grep 990228-1.i ".#"] } } ! { dg-final { if { [string length $tmp] == 0 } \{ } } ! { dg-final { pass "990228-1.c: linemarkers in middle of line" } } ! { dg-final { \} else \{ } } ! { dg-final { fail "990228-1.c: linemarkers in middle of line" } } ! { dg-final { \} } } ! */ --- 18,21 ---- ", NULL); ! /* { dg-final { scan-file-not 19990228-1.i "\[^\\n\]#" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/assert4.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/assert4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/assert4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/assert4.c 2004-02-10 07:39:49.000000000 +0000 *************** *** 0 **** --- 1,445 ---- + /* Copyright (C) 2003 Free Software Foundation, Inc. + Test builtin preprocessor assertions. + By Kaveh Ghazi . */ + + /* { dg-do preprocess } */ + + /* Check for #system assertions. */ + + #if defined __gnu_linux__ + # if !#system(linux) || !#system(unix) || !#system(posix) + # error + # endif + #elif #system(linux) + # error + #endif + + #if defined __gnu_hurd__ + # if !#system(gnu) || !#system(unix) || !#system(posix) || !#system(mach) + # error + # endif + #elif #system(gnu) + # error + #endif + + #if defined __FreeBSD__ + # if !#system(FreeBSD) || !#system(unix) || !#system(bsd) + # error + # endif + #elif #system(FreeBSD) + # error + #endif + + #if defined __NetBSD__ + # if !#system(NetBSD) || !#system(unix) || !#system(bsd) + # error + # endif + #elif #system(NetBSD) + # error + #endif + + #if defined __OpenBSD__ + # if !#system(OpenBSD) || !#system(unix) || !#system(bsd) + # error + # endif + #elif #system(OpenBSD) + # error + #endif + + #if defined __svr4__ || defined __SYSTYPE_SVR4__ + # if !#system(svr4) || !#system(unix) + # error + # endif + #elif #system(svr4) + # error + #endif + + #if defined __hpux__ + # if !#system(hpux) || !#system(unix) + # error + # endif + #elif #system(hpux) + # error + #endif + + #if defined _AIX + # if !#system(aix) || !#system(unix) + # error + # endif + #elif #system(aix) + # error + #endif + + #if defined __lynx__ + # if !#system(lynx) || !#system(unix) + # error + # endif + #elif #system(lynx) + # error + #endif + + #if defined __unix__ + # if !#system(unix) + # error + # endif + #elif #system(unix) + # error + #endif + + #if defined __rtems__ + # if !#system(rtems) + # error + # endif + #elif #system(rtems) + # error + #endif + + #if defined __vms__ + # if !#system(vms) + # error + # endif + #elif #system(vms) + # error + #endif + + #if defined __mvs__ + # if !#system(mvs) + # error + # endif + #elif #system(mvs) + # error + #endif + + #if defined __MSDOS__ + # if !#system(msdos) + # error + # endif + #elif #system(msdos) + # error + #endif + + #if defined __WINNT__ + # if !#system(winnt) + # error + # endif + #elif #system(winnt) + # error + #endif + + #if defined __BEOS__ + # if !#system(beos) + # error + # endif + #elif #system(beos) + # error + #endif + + #if defined __netware__ + # if !#system(netware) + # error + # endif + #elif #system(netware) + # error + #endif + + + /* Check for #cpu and #machine assertions. */ + + #if defined __arc__ + # if !#cpu(arc) || !#machine(arc) + # error + # endif + #elif #cpu(arc) || #machine(arc) + # error + #endif + + #if defined __alpha__ + # if !#cpu(alpha) || !#machine(alpha) \ + || (defined __alpha_cix__ && !#cpu(cix)) \ + || (!defined __alpha_cix__ && #cpu(cix)) \ + || (defined __alpha_fix__ && !#cpu(fix)) \ + || (!defined __alpha_fix__ && #cpu(fix)) \ + || (defined __alpha_bwx__ && !#cpu(bwx)) \ + || (!defined __alpha_bwx__ && #cpu(bwx)) \ + || (defined __alpha_max__ && !#cpu(max)) \ + || (!defined __alpha_max__ && #cpu(max)) \ + || (defined __alpha_ev6__ && !#cpu(ev6)) \ + || (!defined __alpha_ev6__ && #cpu(ev6)) \ + || (defined __alpha_ev5__ && !#cpu(ev5)) \ + || (!defined __alpha_ev5__ && #cpu(ev5)) \ + || (defined __alpha_ev4__ && !#cpu(ev4)) \ + || (!defined __alpha_ev4__ && #cpu(ev4)) + # error + # endif + #elif #cpu(alpha) || #machine(alpha) || #cpu(cix) || #cpu(fix) || #cpu(bwx) \ + || #cpu(max) || #cpu(ev6) || #cpu(ev5) || #cpu(ev4) + # error + #endif + + #if defined __arm__ + # if !#cpu(arm) || !#machine(arm) + # error + # endif + #elif #cpu(arm) || #machine(arm) + # error + #endif + + #if defined __cris__ + # if !#cpu(cris) || !#machine(cris) + # error + # endif + #elif #cpu(cris) || #machine(cris) + # error + #endif + + #if defined __d30v__ + # if !#cpu(d30v) || !#machine(d30v) + # error + # endif + #elif #cpu(d30v) || #machine(d30v) + # error + #endif + + #if defined __fr30__ + # if !#cpu(fr30) || !#machine(fr30) + # error + # endif + #elif #cpu(fr30) || #machine(fr30) + # error + #endif + + #if defined __frv__ + # if !#cpu(frv) || !#machine(frv) + # error + # endif + #elif #cpu(frv) || #machine(frv) + # error + #endif + + #if defined __h8300__ + # if !#cpu(h8300) || !#machine(h8300) \ + || (defined __H8300__ && (!#cpu(h8300) || !#machine(h8300))) \ + || (defined __H8300H__ && (!#cpu(h8300h) || !#machine(h8300h))) \ + || (!defined __H8300H__ && (#cpu(h8300h) || #machine(h8300h))) \ + || (defined __H8300S__ && (!#cpu(h8300s) || !#machine(h8300s))) \ + || (!defined __H8300S__ && (#cpu(h8300s) || #machine(h8300s))) + # error + # endif + #elif #cpu(h8300) || #machine(h8300) || #cpu(h8300h) || #machine(h8300h) || \ + #cpu(h8300s) || #machine(h8300s) + # error + #endif + + #if defined __hppa__ + # if !#cpu(hppa) || !#machine(hppa) + # error + # endif + #elif #cpu(hppa) || #machine(hppa) + # error + #endif + + #if defined __i370__ + # if !#cpu(i370) || !#machine(i370) + # error + # endif + #elif #cpu(i370) || #machine(i370) + # error + #endif + + #if defined __x86_64__ + # if !#cpu(x86_64) || !#machine(x86_64) + # error + # endif + #elif #cpu(x86_64) || #machine(x86_64) + # error + #endif + + #if defined __i386__ + # if !#cpu(i386) || !#machine(i386) + # error + # endif + #elif #cpu(i386) || #machine(i386) + # error + #endif + + #if defined __i860__ + # if !#cpu(i860) || !#machine(i860) + # error + # endif + #elif #cpu(i860) || #machine(i860) + # error + #endif + + #if defined __i960__ + # if !#cpu(i960) || !#machine(i960) + # error + # endif + #elif #cpu(i960) || #machine(i960) + # error + #endif + + #if defined __ia64__ + # if !#cpu(ia64) || !#machine(ia64) + # error + # endif + #elif #cpu(ia64) || #machine(ia64) + # error + #endif + + #if defined __iq2000__ + # if !#cpu(iq2000) || !#machine(iq2000) + # error + # endif + #elif #cpu(iq2000) || #machine(iq2000) + # error + #endif + + #if defined __M32R__ + # if !#cpu(m32r) || !#machine(m32r) + # error + # endif + #elif #cpu(m32r) || #machine(m32r) + # error + #endif + + #if defined __m68k__ + # if !#cpu(m68k) || !#machine(m68k) + # error + # endif + #elif #cpu(m68k) || #machine(m68k) + # error + #endif + + #if defined __mcore__ + # if !#cpu(mcore) || !#machine(mcore) + # error + # endif + #elif #cpu(mcore) || #machine(mcore) + # error + #endif + + #if defined __mips__ + # if !#cpu(mips) || (defined __sgi__ && !#machine(sgi)) \ + || (!defined __sgi__ && !#machine(mips)) + # error + # endif + #elif #cpu(mips) || #machine(sgi) || #machine(mips) + # error + #endif + + #if defined __mmix__ + # if !#cpu(mmix) || !#machine(mmix) + # error + # endif + #elif #cpu(mmix) || #machine(mcore) + # error + #endif + + #if defined __mn10300__ + # if !#cpu(mn10300) || !#machine(mn10300) + # error + # endif + #elif #cpu(mn10300) || #machine(mn10300) + # error + #endif + + #if defined __ns32k__ + # if !#cpu(ns32k) || !#machine(ns32k) + # error + # endif + #elif #cpu(ns32k) || #machine(ns32k) + # error + #endif + + #if defined __pdp11__ + # if !#cpu(pdp11) || !#machine(pdp11) + # error + # endif + #elif #cpu(pdp11) || #machine(pdp11) + # error + #endif + + #if defined __powerpc__ + # if defined __powerpc64__ + # if (#cpu(powerpc) || #machine(powerpc) \ + || !#cpu(powerpc64) || !#machine(powerpc64)) + # error + # endif + # else + # if (!#cpu(powerpc) || !#machine(powerpc) \ + || #cpu(powerpc64) || #machine(powerpc64)) + # error + # endif + # endif + #elif (#cpu(powerpc) || #machine(powerpc) \ + || #cpu(powerpc64) || #machine(powerpc64)) + # error + #endif + + #if defined __rs6000__ + # if !#cpu(rs6000) || !#machine(rs6000) + # error + # endif + #elif #cpu(rs6000) || #machine(rs6000) + # error + #endif + + #if defined __s390__ + # if !#cpu(s390) || !#machine(s390) + # error + # endif + #elif #cpu(s390) || #machine(s390) + # error + #endif + + #if defined __sh__ + # if !#cpu(sh) || !#machine(sh) + # error + # endif + #elif #cpu(sh) || #machine(sh) + # error + #endif + + #if defined __sparc__ + # if (defined __arch64__ \ + && (!#cpu(sparc64) || !#machine(sparc64) || #cpu(sparc) || #machine(sparc))) + || (!defined __arch64__ \ + && (#cpu(sparc64) || #machine(sparc64) || !#cpu(sparc) || !#machine(sparc))) + # error + # endif + #elif #cpu(sparc64) || #machine(sparc64) || #cpu(sparc) || #machine(sparc) + # error + #endif + + #if defined __xstormy16__ + # if !#cpu(xstormy16) || !#machine(xstormy16) + # error + # endif + #elif #cpu(xstormy16) || #machine(xstormy16) + # error + #endif + + #if defined __v850__ + # if !#cpu(v850) || !#machine(v850) + # error + # endif + #elif #cpu(v850) || #machine(v850) + # error + #endif + + #if defined __vax__ + # if !#cpu(vax) || !#machine(vax) + # error + # endif + #elif #cpu(vax) || #machine(vax) + # error + #endif + + #if defined __XTENSA__ + # if !#cpu(xtensa) || !#machine(xtensa) + # error + # endif + #elif #cpu(xtensa) || #machine(xtensa) + # error + #endif + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/avoidpaste1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/avoidpaste1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/avoidpaste1.c 2002-09-16 13:29:50.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/avoidpaste1.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2001 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ --- 1,4 ---- ! /* Copyright (C) 2001, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ *************** in future, this test needs to change. * *** 24,33 **** :: :g: :f(): :f(^): tricky :f(:): .. .__INCLUDE_LEVEL__ __INCLUDE_LEVEL__. /* Check builtins, too. */ ! /* ! { dg-final { if ![file exists avoidpaste1.i] { return } } } ! { dg-final { if { [grep avoidpaste1.i ":: : : : : :\\^: 1.0e- 1"] != "" } \{ } } ! { dg-final { if { [grep avoidpaste1.i ": : : \\\.\\\. \\\. 0 0 \\\."] != "" } \{ } } ! { dg-final { return \} \} } } ! { dg-final { fail "avoidpaste1.c: paste avoidance" } } ! */ --- 24,28 ---- :: :g: :f(): :f(^): tricky :f(:): .. .__INCLUDE_LEVEL__ __INCLUDE_LEVEL__. /* Check builtins, too. */ ! /* { dg-final { scan-file avoidpaste1.i ":: : : : : :\\^: 1.0e- 1" } } ! { dg-final { scan-file avoidpaste1.i ": : : \\\.\\\. \\\. 0 0 \\\." } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/avoidpaste2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/avoidpaste2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/avoidpaste2.c 2001-02-01 19:15:06.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/avoidpaste2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2001 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ --- 1,4 ---- ! /* Copyright (C) 2001, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ *************** We used to get a space at the start of t *** 26,35 **** f(:,) g(2, 2) ! /* ! { dg-final { if ![file exists avoidpaste2.i] { return } } } ! { dg-final { if { [grep avoidpaste2.i "^: : : - > - >"] != "" } \{ } } ! { dg-final { if { [grep avoidpaste2.i "^:2: :22 22:"] != "" } \{ } } ! { dg-final { return \} \} } } ! { dg-final { fail "avoidpaste2.c: paste avoidance" } } ! */ --- 26,30 ---- f(:,) g(2, 2) ! /* { dg-final { scan-file avoidpaste2.i "(^|\\n): : : - > - >" } } ! { dg-final { scan-file avoidpaste2.i "(^|\\n):2: :22 22:" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c90-if-comma-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c90-if-comma-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c90-if-comma-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c90-if-comma-1.c 2004-02-11 23:52:59.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test for commas in constant expressions in #if: not permitted in C90 + but permitted in unevaluated subexpressions in C99. */ + /* Origin: Joseph Myers */ + /* { dg-do preprocess } */ + /* { dg-options "-std=iso9899:1990 -pedantic-errors" } */ + + #if (1, 2) /* { dg-error "comma" "evaluated comma" } */ + #endif + + #if 1 || (1, 2) /* { dg-error "comma" "unevaluated comma" } */ + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c99-hexfloat-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c99-hexfloat-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c99-hexfloat-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c99-hexfloat-3.c 2003-03-31 15:50:33.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* Test for hex floating point constants: in C99 only. Compiler test. */ + /* Origin: Michael Matz */ + /* { dg-do compile } */ + /* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + + double d = 0x.2p2; /* { dg-bogus "radix 16" "bogus C99 hex float error" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c99-if-comma-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c99-if-comma-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/c99-if-comma-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/c99-if-comma-1.c 2004-02-11 23:52:59.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test for commas in constant expressions in #if: not permitted in C90 + but permitted in unevaluated subexpressions in C99. */ + /* Origin: Joseph Myers */ + /* { dg-do preprocess } */ + /* { dg-options "-std=iso9899:1999 -pedantic-errors" } */ + + #if (1, 2) /* { dg-error "comma" "evaluated comma" } */ + #endif + + #if 1 || (1, 2) + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-C2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-C2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-C2.c 2001-10-09 06:16:25.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-C2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000, 2001 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C" } */ --- 1,4 ---- ! /* Copyright (C) 2000, 2001, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C" } */ *************** *** 13,21 **** ZERO: ! /* ! { dg-final { if ![file exists cmdlne-C2.i] { return } } } ! { dg-final { if { [grep cmdlne-C2.i "c+omment:"] == "" } { return } } } ! { dg-final { fail "cmdlne-C2.i: C++ comments in macros with -C" } } ! */ --- 13,17 ---- ZERO: ! /* { dg-final { scan-file-not cmdlne-C2.i "c+omment:" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-dM.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-dM.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-dM.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-dM.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dD -dM" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dD -dM" } */ *************** *** 10,16 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dD-dM.i] { return } } } ! { dg-final { if { [grep cmdlne-dD-dM.i "^#define foo bar$"] == "" } { fail "cmdlne-dD-dM.c: #define line not printed" } } } ! { dg-final { if { [grep cmdlne-dD-dM.i "variable"] != "" } { fail "cmdlne-dD-dM.c: non-#define line printed" } } } ! { dg-final { return } } */ --- 10,14 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file cmdlne-dD-dM.i "(^|\\n)#define foo bar($|\\n)" } } ! { dg-final { scan-file-not cmdlne-dD-dM.i "variable" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-M.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-M.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-M.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dD-M.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dD -M" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dD -M" } */ *************** *** 10,17 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dD-M.i] { return } } } ! { dg-final { if { [grep cmdlne-dD-M.i "^#define foo bar$"] != "" } { fail "cmdlne-dD-M.c: #define line printed" } } } ! { dg-final { if { [grep cmdlne-dD-M.i "variable"] != "" } { fail "cmdlne-dD-M.c: non-#define line printed" } } } ! { dg-final { if { [grep cmdlne-dD-M.i "^cmdlne-dD-M.*:.*cmdlne-dD-M.c"] == "" } { xfail "cmdlne-dD-M.c: dependency rule not printed" } } } ! { dg-final { return } } */ --- 10,15 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file-not cmdlne-dD-M.i "(^|\\n)#define foo bar($|\\n)" } } ! { dg-final { scan-file-not cmdlne-dD-M.i "variable" } } ! { dg-final { scan-file-not cmdlne-dD-M.i "(^|\n)cmdlne-dD-M.*:.*cmdlne-dD-M.c" { xfail *-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dI-M.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dI-M.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dI-M.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dI-M.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dI -M" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dI -M" } */ *************** *** 11,18 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dI-M.i] { return } } } ! { dg-final { if { [grep cmdlne-dI-M.i "^#define foo bar$"] != "" } { fail "cmdlne-dI-M.c: #define line printed" } } } ! { dg-final { if { [grep cmdlne-dI-M.i "variable"] != "" } { fail "cmdlne-dI-M.c: non-#define line printed" } } } ! { dg-final { if { [grep cmdlne-dI-M.i "^cmdlne-dI-M.*:.*cmdlne-dI-M.c"] == "" } { xfail "cmdlne-dI-M.c: dependency rule not printed" } } } ! { dg-final { return } } */ --- 11,16 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file-not cmdlne-dI-M.i "(^|\\n)#define foo bar($|\\n)" } } ! { dg-final { scan-file-not cmdlne-dI-M.i "variable" } } ! { dg-final { scan-file cmdlne-dI-M.i "(^|\\n)cmdlne-dI-M.*:\[^\\n\]*cmdlne-dI-M.c" { xfail *-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-dD.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-dD.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-dD.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-dD.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dM -dD" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dM -dD" } */ *************** *** 10,16 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dM-dD.i] { return } } } ! { dg-final { if { [grep cmdlne-dM-dD.i "^#define foo bar$"] == "" } { fail "cmdlne-dM-dD.c: #define line not printed" } } } ! { dg-final { if { [grep cmdlne-dM-dD.i "variable"] == "" } { fail "cmdlne-dM-dD.c: non-#define line not printed" } } } ! { dg-final { return } } */ --- 10,14 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file cmdlne-dM-dD.i "(^|\\n)#define foo bar($|\\n)" } } ! { dg-final { scan-file cmdlne-dM-dD.i "variable" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-M.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-M.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-M.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dM-M.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dM -M" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dM -M" } */ *************** *** 10,17 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dM-M.i] { return } } } ! { dg-final { if { [grep cmdlne-dM-M.i "^#define foo bar$"] == "" } { fail "cmdlne-dM-M.c: #define line not printed" } } } ! { dg-final { if { [grep cmdlne-dM-M.i "variable"] != "" } { fail "cmdlne-dM-M.c: non-#define line printed" } } } ! { dg-final { if { [grep cmdlne-dM-M.i "^cmdlne-dM-M.*:.*cmdlne-dM-M.c"] == "" } { xfail "cmdlne-dM-M.c: dependency rule not printed" } } } ! { dg-final { return } } */ --- 10,15 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file cmdlne-dM-M.i "(^|\\n)#define foo bar($|\\n)" } } ! { dg-final { scan-file-not cmdlne-dM-M.i "variable" } } ! { dg-final { scan-file cmdlne-dM-M.i "(^|\\n)cmdlne-dM-M\[^\\n\]*:\[^\\n\]*cmdlne-dM-M.c" { xfail *-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dN-M.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dN-M.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-dN-M.c 2002-05-03 20:28:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-dN-M.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dN -M" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-dN -M" } */ *************** *** 10,17 **** #define funlike(like) fun like int variable; ! /* { dg-final { if ![file exists cmdlne-dN-M.i] { return } } } ! { dg-final { if { [grep cmdlne-dN-M.i "^#define foo"] != "" } { fail "cmdlne-dN-M.c: #define line printed" } } } ! { dg-final { if { [grep cmdlne-dN-M.i "variable"] != "" } { fail "cmdlne-dN-M.c: non-#define line printed" } } } ! { dg-final { if { [grep cmdlne-dN-M.i "^cmdlne-dN-M.*:.*cmdlne-dN-M.c"] == "" } { xfail "cmdlne-dN-M.c: dependency rule not printed" } } } ! { dg-final { return } } */ --- 10,15 ---- #define funlike(like) fun like int variable; ! /* { dg-final { scan-file-not cmdlne-dN-M.i "(^|\\n)#define foo" } } ! { dg-final { scan-file-not cmdlne-dN-M.i "variable" } } ! { dg-final { scan-file cmdlne-dN-M.i "(^|\\n)cmdlne-dM-M\[^\\n\]*:\[^\\n\]*cmdlne-dM-M.c" { xfail *-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-P.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-P.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cmdlne-P.c 2000-12-18 19:37:18.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cmdlne-P.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-P" } */ --- 1,4 ---- ! /* Copyright (C) 2000, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-P" } */ *************** *** 8,13 **** int x = 1; ! /* { dg-final { if ![file exists cmdlne-P.i] { return } } } ! { dg-final { if { [grep cmdlne-P.i "^int x = 1;$"] != "" } { return } } } ! { dg-final { fail "cmdlne-P.c: stair-stepping with -P" } } */ --- 8,11 ---- int x = 1; ! /* { dg-final { scan-file cmdlne-P.i "(^|\n)int x = 1;($|\n)" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cpp.exp gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cpp.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cpp.exp 2002-08-07 18:32:13.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cpp.exp 2003-06-02 15:25:50.000000000 +0000 *************** *** 1,4 **** ! # Copyright (C) 1997, 2000 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 --- 1,4 ---- ! # Copyright (C) 1997, 2000, 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 *************** if ![info exists DEFAULT_CFLAGS] then { *** 36,42 **** dg-init # Main loop. ! dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cCS\]]] \ "" $DEFAULT_CFLAGS # All done. --- 36,42 ---- dg-init # Main loop. ! dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.{c,S} ]] \ "" $DEFAULT_CFLAGS # All done. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom1.c 2000-06-27 22:26:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom1.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 7,20 **** /* ...but we don't bitch about it more than once. */ // C++ comment is not in C89 { dg-bogus "style comment" "bad warning" } ! /* ! { dg-final { if ![file exists cxx-comments-1.i] { return } } } ! { dg-final { set tmp [grep cxx-comments-1.i "is not in C89" line] } } ! { dg-final { # send_user "$tmp\n" } } ! { dg-final { if [regexp "is not in C89" $tmp] \{ } } ! { dg-final { fail "cxx-comments-1: comment strip check" } } ! { dg-final { \} else \{ } } ! { dg-final { pass "cxx-comments-1: comment strip check" } } ! { dg-final { \} } } ! */ --- 7,11 ---- /* ...but we don't bitch about it more than once. */ // C++ comment is not in C89 { dg-bogus "style comment" "bad warning" } ! /* { dg-final { scan-file-not cxxcom1.i "is not in C89" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom2.c 2000-10-28 18:01:40.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,20 **** /* { dg-do preprocess } */ ! /* { dg-options "-pedantic -std=c89" } */ ! ! /* This is an extension and therefore gets a warning. */ ! #line 5 "cxx-comments-2.c" 3 /* { dg-warning "extra tokens" "#line extension" } */ ! /* A system header may contain C++ comments irrespective of mode. */ ! // C++ comment is not in C89 { dg-bogus "style comment" "bad warning" } ! /* ! { dg-final { if ![file exists cxx-comments-2.i] { return } } } ! { dg-final { set tmp [grep cxx-comments-2.i "is not in C89" line] } } ! { dg-final { # send_user "$tmp\n" } } ! { dg-final { if [regexp "is not in C89" $tmp] \{ } } ! { dg-final { fail "cxx-comments-2: comment strip check" } } ! { dg-final { \} else \{ } } ! { dg-final { pass "cxx-comments-2: comment strip check" } } ! { dg-final { \} } } ! */ --- 1,7 ---- /* { dg-do preprocess } */ ! /* { dg-options "-pedantic -std=c89 -Wall" } */ ! #include "cxxcom2.h" ! /* { dg-final { scan-file-not cxxcom2.i "is not in C89" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom2.h gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom2.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/cxxcom2.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/cxxcom2.h 2003-06-02 19:21:15.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* A system header may contain C++ comments irrespective of mode. */ + #pragma GCC system_header + // C++ comment is not in C89 { dg-bogus "style comment" "bad warning" } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/escape-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/escape-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/escape-2.c 2001-05-23 22:50:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/escape-2.c 2003-07-05 00:23:59.000000000 +0000 *************** *** 10,20 **** #if '\e' /* { dg-warning "non-ISO" "non-ISO \\e" } */ #endif ! #if '\u00a0' /* { dg-bogus "unknown" "\\u is known in C99" } */ #endif void foo () { int c = '\E'; /* { dg-warning "non-ISO" "non-ISO \\E" } */ ! c = '\u00a0'; /* { dg-bogus "unknown" "\\u is known in C99" } */ } --- 10,20 ---- #if '\e' /* { dg-warning "non-ISO" "non-ISO \\e" } */ #endif ! #if L'\u00a0' /* { dg-bogus "unknown" "\\u is known in C99" } */ #endif void foo () { int c = '\E'; /* { dg-warning "non-ISO" "non-ISO \\E" } */ ! c = L'\u00a0'; /* { dg-bogus "unknown" "\\u is known in C99" } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/escape.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/escape.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/escape.c 2001-05-23 22:50:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/escape.c 2003-07-05 00:23:59.000000000 +0000 *************** *** 13,19 **** #if '\x1a' != 26 /* { dg-warning "traditional" "traditional hex" } */ #error bad hex /* { dg-bogus "bad" "bad hexadecimal evaluation" } */ #endif ! #if '\u' /* { dg-warning "unknown" "\u is unknown in C89" } */ #endif void foo () --- 13,19 ---- #if '\x1a' != 26 /* { dg-warning "traditional" "traditional hex" } */ #error bad hex /* { dg-bogus "bad" "bad hexadecimal evaluation" } */ #endif ! #if L'\u00a1' /* { dg-warning "only valid" "\u is unknown in C89" } */ #endif void foo () *************** void foo () *** 21,25 **** int c = '\a'; /* { dg-warning "traditional" "traditional bell" } */ c = '\xa1'; /* { dg-warning "traditional" "traditional hex" } */ ! c = '\u'; /* { dg-warning "unknown" "\u is unknown in C89" } */ } --- 21,25 ---- int c = '\a'; /* { dg-warning "traditional" "traditional bell" } */ c = '\xa1'; /* { dg-warning "traditional" "traditional hex" } */ ! c = L'\u00a1'; /* { dg-warning "only valid" "\u is unknown in C89" } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import1.c 2003-08-02 16:29:46.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Copyright (C) 2003 Free Software Foundation, Inc. */ + + /* { dg-do preprocess } */ + /* { dg-options "" } */ + + /* This tests that our eagerness to apply the multiple include guard + optimization to the #import doesn't stop us marking the file + once-only. + + Neil Booth, 2 August 2003. */ + + #include "import1.h" + #import "import1.h" + #undef IMPORT1_H + #define BUG + #include "import1.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import1.h gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import1.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import1.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import1.h 2003-08-02 16:29:46.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + #ifndef IMPORT1_H + #define IMPORT1_H + #ifdef BUG + #error Should not happen + #endif + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import2.c 2003-08-02 16:29:46.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Copyright (C) 2003 Free Software Foundation, Inc. */ + + /* { dg-do preprocess } */ + /* { dg-options "" } */ + + /* This tests that the file is only included once + Neil Booth, 2 August 2003. */ + + #include "import2.h" + #import "import2.h" + #include "import2.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import2.h gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import2.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/import2.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/import2.h 2003-08-02 16:29:46.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + #ifdef BUG + #error Should not happen! + #endif + #define BUG diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/include2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/include2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/include2.c 2000-11-25 15:39:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/include2.c 2003-07-29 22:26:13.000000000 +0000 *************** *** 8,17 **** /* Source: Neil Booth, 4 Nov 2000. */ #include > /* { dg-warning "extra tokens" "" } */ ! #include "silly\"" /* { dg-error "missing" "" } */ ! /* These first 2 errors are No such file or directory. However, this message is locale-dependent, so don't test for it. */ /* { dg-error "silly" "" { target *-*-* } 10 } */ ! /* { dg-error "silly" "" { target *-*-* } 11 } */ ! /* { dg-warning "extra tokens" "" { target *-*-* } 11 } */ --- 8,16 ---- /* Source: Neil Booth, 4 Nov 2000. */ #include > /* { dg-warning "extra tokens" "" } */ ! #include "silly\"" /* { dg-warning "extra tokens" "" } */ ! /* 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 } */ ! diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/lexident.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/lexident.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/lexident.c 2000-07-04 22:26:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/lexident.c 2003-12-23 22:41:27.000000000 +0000 *************** *** 1,7 **** /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ ! /* { dg-options "-trigraphs" } */ /* Test lexing of identifiers. */ --- 1,7 ---- /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ ! /* { dg-options "-trigraphs -fdollars-in-identifiers" } */ /* Test lexing of identifiers. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/line1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/line1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/line1.c 2000-06-27 22:26:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/line1.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000 Free Software Foundation. by Alexandre Oliva */ --- 1,4 ---- ! /* Copyright (C) 2000, 2003 Free Software Foundation. by Alexandre Oliva */ *************** *** 9,18 **** #line 10 "baz" wibble ! /* ! { dg-final { if \{ [grep line1.i baz] != "" \} \{ } } ! { dg-final { pass "line1.i: #line directive optimization" } } ! { dg-final { \} else \{ } } ! { dg-final { fail "line1.i: #line directive optimization" } } ! { dg-final { \} } } ! */ --- 9,12 ---- #line 10 "baz" wibble ! /* { dg-final { scan-file line1.i baz } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom1.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom1.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 10,17 **** def ! /* ! { dg-final { if ![file exists maccom1.i] { return } } } ! { dg-final { if { [grep maccom1.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom1.c: comment between # and directive name with -CC" } } ! */ --- 10,14 ---- def ! /* { dg-final { scan-file maccom1.i "(^|\\n)passed" } } */ ! diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom2.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 11,18 **** def ! /* ! { dg-final { if ![file exists maccom2.i] { return } } } ! { dg-final { if { [grep maccom2.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom2.c: comment between #define and identifier with -CC" } } ! */ --- 11,14 ---- def ! /* { dg-final { scan-file maccom2.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom3.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom3.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom3.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 10,17 **** def(x,y) ! /* ! { dg-final { if ![file exists maccom3.i] { return } } } ! { dg-final { if { [grep maccom3.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom3.c: comment in macro parameter list with -CC" } } ! */ --- 10,13 ---- def(x,y) ! /* { dg-final { scan-file maccom3.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom4.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom4.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom4.c 2003-06-02 19:21:15.000000000 +0000 *************** def *** 13,19 **** /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { if ![file exists maccom4.i] { return } } } ! { dg-final { if { [grep maccom4.i "p+assed"] != "" } { return } } } ! { dg-final { fail "maccom4.c: comment in macro expansion with -CC" } } */ --- 13,17 ---- /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { scan-file maccom4.i "p+assed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom5.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom5.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom5.c 2003-06-02 19:21:15.000000000 +0000 *************** def: *** 13,21 **** /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { if ![file exists maccom5.i] { return } } } ! { dg-final { if \{ [grep maccom5.i "p+assed"] != "" \} \{ } } ! { dg-final { if \{ [grep maccom5.i "p+assed:"] == "" \} \{ } } ! { dg-final { return \} \} } } ! { dg-final { fail "maccom5.c: C++ comment in macro expansion with -CC" } } */ --- 13,18 ---- /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { scan-file maccom5.i "p+assed" } } ! { dg-final { scan-file-not maccom5.i "p+assed:" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom6.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/maccom6.c 2002-04-07 03:12:23.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/maccom6.c 2003-06-02 19:21:15.000000000 +0000 *************** failed *** 17,24 **** passed #endif ! /* ! { dg-final { if ![file exists maccom6.i] { return } } } ! { dg-final { if { [grep maccom6.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom6.c: comments in macro expressions with -CC" } } ! */ --- 17,20 ---- passed #endif ! /* { dg-final { scan-file maccom6.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/multiline-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/multiline-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/multiline-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/multiline-2.c 2003-04-23 22:44:05.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* Copyright (C) 2000, 2003 Free Software Foundation, Inc. */ + + /* { dg-do compile } */ + + /* Test that multi-line tokens are rejected by the compiler. Source: + Neil Booth. */ + + const char *p = "line 1 + " + ""; /* The compiler front end sees this. */ + + /* { dg-error "missing term" "multiline strings" { target *-*-* } 8 } */ + /* { dg-error "missing term" "multiline strings" { target *-*-* } 9 } */ + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/multiline.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/multiline.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/multiline.c 2002-09-15 17:51:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/multiline.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C" } */ /* Test that multi-line tokens are recognized by cpp0 as being --- 1,4 ---- ! /* Copyright (C) 2000, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C" } */ /* Test that multi-line tokens are recognized by cpp0 as being *************** L"line 1 *** 18,32 **** line 4" /* Nowhere in the output of this file should there be a blank line. We check for that in the .i file. ! { dg-final { if ![file exists multiline.i] { return } } } ! { dg-final { if \{ [grep multiline.i "^$"] == "" \} \{ } } ! { dg-final { return \} } } ! { dg-final { fail "multiline.c: multi-line tokens" } } */ ! /* { dg-error "missing term" "multiline strings" { target *-*-* } 11 } */ ! /* { dg-error "missing term" "multiline strings" { target *-*-* } 14 } */ ! /* { dg-error "missing term" "multiline strings" { target *-*-* } 15 } */ ! /* { dg-error "missing term" "multiline strings" { target *-*-* } 18 } */ ! /* { dg-bogus "warning" "warning in place of error" { target *-*-* } 11 } */ ! /* { dg-bogus "warning" "warning in place of error" { target *-*-* } 14 } */ /* { dg-bogus "warning" "warning in place of error" { target *-*-* } 15 } */ - /* { dg-bogus "warning" "warning in place of error" { target *-*-* } 18 } */ --- 18,23 ---- line 4" /* Nowhere in the output of this file should there be a blank line. We check for that in the .i file. ! { dg-final { scan-file-not multiline.i "(^|\\n)\\n" } } */ ! /* { dg-bogus "missing term" "multiline strings" { target *-*-* } 11 } */ /* { dg-bogus "warning" "warning in place of error" { target *-*-* } 15 } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/_Pragma4.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/_Pragma4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/_Pragma4.c 2002-09-06 16:38:36.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/_Pragma4.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 5,12 **** #define b foo _Pragma ("bar") baz a b c ! /* ! { dg-final { if ![file exists _Pragma4.i] { return } } } ! { dg-final { if { [grep _Pragma4.i "#pragma bar "] != "" } { return } } } ! { dg-final { fail "_Pragma4.c: #pragma appearing on its own line" } } ! */ --- 5,8 ---- #define b foo _Pragma ("bar") baz a b c ! /* { dg-final { scan-file "_Pragma4.i" "(^|\\n)#pragma bar($|\\n)" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/_Pragma5.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/_Pragma5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/_Pragma5.c 2002-11-18 20:43:40.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/_Pragma5.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 7,14 **** #define GAMMA(C) _Pragma("moose") ALPHA(C) BETA(C) GAMMA(baz); ! /* ! { dg-final { if ![file exists _Pragma5.i] { return } } } ! { dg-final { if { [grep _Pragma5.i "alpha_baz beta_baz;"] != "" } { return } } } ! { dg-final { fail "_Pragma5.c: _Pragma in macro" } } ! */ --- 7,10 ---- #define GAMMA(C) _Pragma("moose") ALPHA(C) BETA(C) GAMMA(baz); ! /* { dg-final { scan-file "_Pragma5.i" "alpha_baz beta_baz;" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/spacing1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/spacing1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/spacing1.c 2003-09-14 13:26:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/spacing1.c 2003-09-14 13:52:56.000000000 +0000 *************** f (g) str *** 56,70 **** ) f (bam) baz ! /* ! { dg-final { if ![file exists spacing1.i] { return } } } ! { dg-final { if \{ [grep spacing1.i " 44 ;"] != "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "B Q B Q A Q A:"] != "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "f.*bar"] == "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "^bar"] != "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "^A$"] != "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "^bad$"] != "" \} \{ } } ! { dg-final { if \{ [grep spacing1.i "g \"1 2\" bam baz"] != "" \} \{ } } ! { dg-final { return \} \} \} \} \} \} \} } } ! { dg-final { fail "spacing1.c: spacing and new-line preservation" } } ! */ --- 56,65 ---- ) f (bam) baz ! /* { dg-final { scan-file spacing1.i " 44 ;" } } ! { dg-final { scan-file spacing1.i "B Q B Q A Q A:" } } ! { dg-final { scan-file-not spacing1.i "f\[^\n\]*bar" } } ! { dg-final { scan-file spacing1.i "(^|\n)bar" } } ! { dg-final { scan-file spacing1.i "(^|\n)A($|\n)" } } ! { dg-final { scan-file spacing1.i "(^|\n)bad($|\n)" } } ! { dg-final { scan-file spacing1.i "g \"1 2\" bam baz" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/spacing2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/spacing2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/spacing2.c 2001-10-12 22:31:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/spacing2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2001 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ --- 1,4 ---- ! /* Copyright (C) 2001, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ *************** *** 13,21 **** a = EMPTY foo.. /* No leading space on output. */ ! /* ! { dg-final { if ![file exists spacing2.i] { return } } } ! { dg-final { if \{ [grep spacing2.i "^bar\.\."] != "" \} \{ } } ! { dg-final { return \} } } ! { dg-final { fail "spacing2.c: spacing issues" } } ! */ --- 13,16 ---- a = EMPTY foo.. /* No leading space on output. */ ! /* { dg-final { scan-file spacing2.i "(^|\n)bar\.\." } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/strify2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/strify2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/strify2.c 2000-10-28 18:10:41.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/strify2.c 2003-04-23 22:44:05.000000000 +0000 *************** *** 1,7 **** /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do run } */ ! /* { dg-options "-std=c99 -pedantic-errors" } */ /* Tests a whole bunch of things are correctly stringified. */ --- 1,7 ---- /* Copyright (C) 2000 Free Software Foundation, Inc. */ /* { dg-do run } */ ! /* { dg-options "-std=c99 -pedantic-errors -fno-show-column" } */ /* Tests a whole bunch of things are correctly stringified. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/cmdlne-C2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/cmdlne-C2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/cmdlne-C2.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/cmdlne-C2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 1,4 **** ! /* Copyright (C) 2002 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C -traditional-cpp" } */ --- 1,4 ---- ! /* Copyright (C) 2002, 2003 Free Software Foundation, Inc. */ /* { dg-do preprocess } */ /* { dg-options "-C -traditional-cpp" } */ *************** *** 7,15 **** Neil Booth, 24 Jun 2002. */ ! /* ! { dg-final { if ![file exists cmdlne-C2.i] { return } } } ! { dg-final { if { [grep cmdlne-C2.i "dg-final"] != "" } { return } } } ! { dg-final { fail "cmdlne-C2.i: C comments output with -C" } } ! */ --- 7,11 ---- Neil Booth, 24 Jun 2002. */ ! /* { dg-final { scan-file cmdlne-C2.i "dg-final" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/escaped-eof.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/escaped-eof.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/escaped-eof.c 2002-06-21 05:29:09.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/escaped-eof.c 2003-04-19 00:22:51.000000000 +0000 *************** *** 2,6 **** /* { dg-do preprocess } */ ! /* { dg-warning "backslash-new" "escaped EOF warning" { target *-*-* } 7 } */ \ --- 2,6 ---- /* { dg-do preprocess } */ ! /* { dg-warning "backslash-new" "escaped EOF warning" { target *-*-* } 6 } */ \ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/literals-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/literals-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/literals-2.c 2002-06-22 11:08:20.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/literals-2.c 2003-04-23 22:44:06.000000000 +0000 *************** *** 3,8 **** /* { dg-do preprocess } */ ! /* { dg-error "missing terminating" "bad charconst" { target *-*-* } 7 } */ #if 'x #endif --- 3,8 ---- /* { dg-do preprocess } */ ! /* { dg-error "not valid" "bad charconst" { target *-*-* } 7 } */ #if 'x #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom1.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom1.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 10,17 **** def ! /* ! { dg-final { if ![file exists maccom1.i] { return } } } ! { dg-final { if { [grep maccom1.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom1.c: comment between # and directive name with -CC" } } ! */ --- 10,13 ---- def ! /* { dg-final { scan-file maccom1.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom2.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom2.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 11,18 **** def ! /* ! { dg-final { if ![file exists maccom2.i] { return } } } ! { dg-final { if { [grep maccom2.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom2.c: comment between #define and identifier with -CC" } } ! */ --- 11,14 ---- def ! /* { dg-final { scan-file maccom2.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom3.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom3.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom3.c 2003-06-02 19:21:15.000000000 +0000 *************** *** 10,17 **** def(x,y) ! /* ! { dg-final { if ![file exists maccom3.i] { return } } } ! { dg-final { if { [grep maccom3.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom3.c: comment in macro parameter list with -CC" } } ! */ --- 10,13 ---- def(x,y) ! /* { dg-final { scan-file maccom3.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom4.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom4.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom4.c 2003-06-02 19:21:15.000000000 +0000 *************** def *** 13,19 **** /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { if ![file exists maccom4.i] { return } } } ! { dg-final { if { [grep maccom4.i "p+assed"] != "" } { return } } } ! { dg-final { fail "maccom4.c: comment in macro expansion with -CC" } } */ --- 13,17 ---- /* /* The + in the regexp prevents it from matching itself. */ ! { dg-final { scan-file maccom4.i "p+assed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom6.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/maccom6.c 2002-06-25 06:00:28.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/maccom6.c 2003-06-02 19:21:15.000000000 +0000 *************** failed *** 17,24 **** passed #endif ! /* ! { dg-final { if ![file exists maccom6.i] { return } } } ! { dg-final { if { [grep maccom6.i "^passed"] != "" } { return } } } ! { dg-final { fail "maccom6.c: comments in macro expressions with -CC" } } ! */ --- 17,20 ---- passed #endif ! /* { dg-final { scan-file maccom6.i "(^|\n)passed" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/macro.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/macro.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/macro.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/macro.c 2003-12-12 07:00:29.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test that varargs are rejected, and that we don't complain about + macro args in skipped blocks. */ + + /* { dg-do preprocess } */ + + #define f(x) + #define g(x, y...) /* { dg-error "macro parameter list" } */ + + #if 0 + #define f(a,b) /* { dg-bogus "passed 2 arguments" } */ + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/xwin1.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/xwin1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/trad/xwin1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/trad/xwin1.c 2003-11-19 18:48:53.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* XWindows (as of 4.3) does some pretty strange things with cpp. + This tests one of them; the leading comments are supposed to be + eaten by the preprocessor; but the 'directives' after them are + supposed to be retained as text, not processed, so that imake's cpp + can be run on the output! + { dg-do preprocess } + */ + + /**/#if 0 + passed + /**/#endif + + /* { dg-final { scan-file xwin1.i "(^|\n)#if 0" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/ucs.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/ucs.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/ucs.c 2002-04-03 21:59:03.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/ucs.c 2003-07-05 00:23:59.000000000 +0000 *************** *** 35,46 **** #undef long #if L'\u1234' != 0x1234 ! #error bad short ucs /* { dg-bogus "bad" "bad \u1234 evaluation" } */ #endif #if WCHAR_MAX >= 0x7ffffff # if L'\U1234abcd' != 0x1234abcd ! # error bad long ucs /* { dg-bogus "bad" "bad \U1234abcd evaluation" } */ # endif #endif --- 35,46 ---- #undef long #if L'\u1234' != 0x1234 ! #error bad short ucs /* { dg-bogus "bad" "bad u1234 evaluation" } */ #endif #if WCHAR_MAX >= 0x7ffffff # if L'\U1234abcd' != 0x1234abcd ! # error bad long ucs /* { dg-bogus "bad" "bad U1234abcd evaluation" } */ # endif #endif *************** void foo () *** 48,67 **** { int c; ! c = L'\ubad'; /* { dg-error "incomplete" "incompete UCN 1" } */ c = L"\U1234"[0]; /* { dg-error "incomplete" "incompete UCN 2" } */ ! c = L'\u000x'; /* { dg-error "non-hex" "non-hex digit in UCN" } */ /* If sizeof(HOST_WIDE_INT) > sizeof(wchar_t), we can get a multi-character constant warning even for wide characters. */ /* { dg-warning "too long|multi-character" "" { target *-*-* } 54 } */ c = '\u0024'; /* { dg-bogus "invalid" "0024 is a valid UCN" } */ c = "\u0040"[0]; /* { dg-bogus "invalid" "0040 is a valid UCN" } */ ! c = '\u00a0'; /* { dg-bogus "invalid" "00a0 is a valid UCN" } */ c = '\U00000060'; /* { dg-bogus "invalid" "0060 is a valid UCN" } */ ! c = '\u0025'; /* { dg-error "range" "0025 is an invalid UCN" } */ ! c = L"\uD800"[0]; /* { dg-error "range" "D800 is an invalid UCN" } */ ! c = L'\U0000DFFF'; /* { dg-error "range" "DFFF is an invalid UCN" } */ } --- 48,67 ---- { int c; ! c = L'\ubad'; /* { dg-error "incomplete" "incomplete UCN 1" } */ c = L"\U1234"[0]; /* { dg-error "incomplete" "incompete UCN 2" } */ ! c = L'\u000x'; /* { dg-error "incomplete" "non-hex digit in UCN" } */ /* If sizeof(HOST_WIDE_INT) > sizeof(wchar_t), we can get a multi-character constant warning even for wide characters. */ /* { dg-warning "too long|multi-character" "" { target *-*-* } 54 } */ c = '\u0024'; /* { dg-bogus "invalid" "0024 is a valid UCN" } */ c = "\u0040"[0]; /* { dg-bogus "invalid" "0040 is a valid UCN" } */ ! c = L'\u00a0'; /* { dg-bogus "invalid" "00a0 is a valid UCN" } */ c = '\U00000060'; /* { dg-bogus "invalid" "0060 is a valid UCN" } */ ! c = '\u0025'; /* { dg-error "not a valid" "0025 invalid UCN" } */ ! c = L"\uD800"[0]; /* { dg-error "not a valid" "D800 invalid UCN" } */ ! c = L'\U0000DFFF'; /* { dg-error "not a valid" "DFFF invalid UCN" } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/Wtrigraphs-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/Wtrigraphs-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/Wtrigraphs-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/Wtrigraphs-2.c 2003-05-04 21:45:08.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* { dg-do preprocess } */ + /* { dg-options "-std=c99 -Wtrigraphs -fno-show-column" } */ + + /* Test warnings for trigraphs in comments, with trigraphs enabled. + Neil Booth. 4 May 2003. */ + + /* { dg-bogus "converted" } Test ??< ??= a few ??/ random things in + { dg-warning "converted" } some ??/ + { dg-bogus "converted" } ??< comments. */ + + // { dg-bogus "converted" } More ??/ comment ??> tests. + + // { dg-warning "converted" } Another ??/ + Test + + // { dg-warning "converted" } And another with space after ??/ + the escape + + // { dg-bogus "converted" } A tricky one ??/\ + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/Wtrigraphs.c gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/Wtrigraphs.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/cpp/Wtrigraphs.c 2000-11-22 20:37:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/cpp/Wtrigraphs.c 2003-05-04 20:03:55.000000000 +0000 *************** *** 1,5 **** /* { dg-do preprocess } */ ! /* { dg-options "-Wtrigraphs -fno-show-column" } */ /* Test we don't double warn for trigraphs immediately after preceding text. Source Neil Booth. 22 Nov 2000. */ --- 1,5 ---- /* { dg-do preprocess } */ ! /* { dg-options "-std=gnu99 -Wtrigraphs -fno-show-column" } */ /* Test we don't double warn for trigraphs immediately after preceding text. Source Neil Booth. 22 Nov 2000. */ *************** *** 7,9 **** --- 7,27 ---- abcdef??< /* { dg-warning "ignored" } */ 123456??> /* { dg-warning "ignored" } */ +??= /* { dg-warning "ignored" } */ + + /* Test we warn of escaped newlines only in comments. Source Neil + Booth. 4 May 2003. */ + + /* { dg-bogus "ignored" } Test ??< ??= a few ??/ random things in + { dg-warning "ignored" } some ??/ + { dg-bogus "ignored" } ??< comments. */ + + // { dg-bogus "ignored" } More ??/ comment ??> tests. + + // { dg-warning "ignored" } Another ??/ + Test + + // { dg-warning "ignored" } And another with space after ??/ + the escape + + // { dg-bogus "ignored" } A tricky one ??/\ + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-abi-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-abi-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-abi-1.c 2003-09-24 02:55:50.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-abi-1.c 2003-12-05 00:44:56.000000000 +0000 *************** *** 1,6 **** /* { dg-do compile { target powerpc*-*-darwin* } } */ /* { dg-options "-O" } */ ! /* { dg-final { scan-assembler "li r3,12345\n\tbl " } } */ /* Check that zero-size structures don't affect parameter passing. */ --- 1,6 ---- /* { dg-do compile { target powerpc*-*-darwin* } } */ /* { dg-options "-O" } */ ! /* { dg-final { scan-assembler "li r3,12345\n\t(bl|jbsr) " } } */ /* Check that zero-size structures don't affect parameter passing. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-abi-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-abi-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-abi-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-abi-2.c 2003-10-07 19:48:23.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* { dg-do run { target powerpc*-*-darwin* } } */ + + /* You might think you'd need -maltivec for this, but actually you + don't; GCC will happily do everything in GPRs, and it still + tests that the ABI is correct. */ + + #include + + #define vector __attribute__((vector_size(16))) + + int main(void) + { + vector unsigned int v = { 100, 200, 300, 400 }; + vector unsigned int w = { 4, 5, 6, 7 }; + char x[64]; + sprintf (x, "%lvu,%d,%lvu", v, 1, w); + if (strcmp (x, "100 200 300 400,1,4 5 6 7") != 0) + { + puts (x); + abort (); + } + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-ld-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-ld-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-ld-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-ld-6.c 2003-09-10 00:43:38.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test Darwin linker option -nofixprebinding. */ + /* Developed by Devang Patel . */ + + /* { dg-options "-nofixprebinding" } */ + /* { dg-do link { target *-*-darwin* } } */ + + int main() + { + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-longlong.c gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-longlong.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-longlong.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-longlong.c 2004-02-10 01:28:11.000000000 +0000 *************** *** 0 **** --- 1,38 ---- + /* { dg-do run { target powerpc*-*-* } } */ + /* { dg-options "-mcpu=G5" } */ + + #include + + void + sig_ill_handler (int sig) + { + exit(0); + } + + + int msw(long long in) + { + union { + long long ll; + int i[2]; + } ud; + ud.ll = in; + return ud.i[0]; + } + + int main() + { + + /* Exit on systems without 64bit instructions. */ + signal (SIGILL, sig_ill_handler); + #ifdef __MACH__ + asm volatile ("extsw r0,r0"); + #else + asm volatile ("extsw 0,0"); + #endif + signal (SIGILL, SIG_DFL); + + if (msw(1) != 0) + abort(); + exit(0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-misaligned.c gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-misaligned.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/darwin-misaligned.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/darwin-misaligned.c 2003-12-22 18:37:24.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* { dg-do compile { target powerpc*-*-darwin* } } */ + /* { dg-options "-O2 -force_cpusubtype_ALL -mpowerpc64" } */ + + typedef struct Nlm_rect { + short sh1; + short sh2; + short sh3; + short sh4; + } S8; + + typedef struct udv_mouse_select { + short Action_type; + S8 rcClip; + int pgp; + } UDVselect; + + UDVselect ms; + int UDV(S8 rcClip); + + int main() + { + ms.rcClip.sh1 = 1; + ms.rcClip.sh4 = 4; + return UDV(ms.rcClip); + } + + int UDV(S8 rcClip){ + + return !(rcClip.sh1 == 1 && rcClip.sh4 == 4); + } + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20020327-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20020327-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20020327-1.c 2002-03-27 10:30:45.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20020327-1.c 2004-02-13 02:14:31.000000000 +0000 *************** *** 1,4 **** --- 1,12 ---- /* { dg-do link } */ + #ifndef __powerpc64__ + /* Fails on powerpc64-linux due to the function Letext using a global + .Letext symbol that conflicts with .Letext emitted by gcc with + -gstabs. Some day the linker will be fixed to not require global + "dot" syms, but for now disable this test entirely for powerpc64. + Using xfail doesn't work, nor does dg-excess-errors because some + combinations of command line options won't cause this test to fail. */ void Letext (void) { } + #endif int main() { return 0; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20030605-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20030605-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20030605-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20030605-1.c 2003-06-05 18:08:12.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* Verify we don't ICE on statement-expressions. */ + /* { dg-do compile } */ + + void foo(void) + { + char buf[({ 4; })]; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20031231-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20031231-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/20031231-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/20031231-1.c 2004-01-13 01:35:27.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* { dg-do compile } */ + + /* We used to fail because GCC didn't expect always inline to be inlined at + -O0. */ + typedef union tree_node *tree; + typedef struct c_pretty_print_info c_pretty_printer; + + + void pp_c_string_literal (c_pretty_printer *, tree); + + + static __inline__ __attribute__((always_inline)) void + pp_c_shift_expression (c_pretty_printer *pp, tree e) + { + } + + static void + pp_c_relational_expression (c_pretty_printer *pp, tree e) + { + pp_c_shift_expression (pp, e); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-1.c 2002-01-26 02:38:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-1.c 2003-12-17 07:14:26.000000000 +0000 *************** *** 3,9 **** /* { dg-options "-dA" } */ /* { dg-final { scan-assembler "xyzzy" } } */ ! long foo(long p) { { long xyzzy = 0; --- 3,11 ---- /* { dg-options "-dA" } */ /* { dg-final { scan-assembler "xyzzy" } } */ ! long p; ! ! long foo(void) { { long xyzzy = 0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-2.c 2002-01-26 02:38:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-2.c 2003-12-17 07:14:26.000000000 +0000 *************** *** 3,9 **** /* { dg-options "-dA" } */ /* { dg-final { scan-assembler "xyzzy" } } */ ! long foo(long p) { if (1) { --- 3,11 ---- /* { dg-options "-dA" } */ /* { dg-final { scan-assembler "xyzzy" } } */ ! long p; ! ! long foo(void) { if (1) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug-7.c 2004-02-18 11:24:51.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* { dg-do compile } */ + /* { dg-options "-dA" } */ + /* PR debug/12934. */ + + static inline int foo () + { + return 42; + } + + void bar (int *); + + void baz () + { + int a[foo ()]; + bar (a); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug.exp gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/debug.exp 2002-01-26 02:38:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/debug.exp 2003-05-18 18:59:55.000000000 +0000 *************** *** 19,78 **** # Load support procs. load_lib gcc-dg.exp - # This is the list of debugging options we'll try. Some of them won't - # be supported, that's OK; they will be quickly eliminated. - # It's probably not a good idea to add more optimisation options. - - if ![info exists DEBUG_TORTURE_OPTIONS] { - set DEBUG_TORTURE_OPTIONS "" - foreach type {-gdwarf-2 -gstabs -gstabs+ -gxcoff -gxcoff+ -gcoff} { - set comp_output [gcc_target_compile \ - "$srcdir/$subdir/trivial.c" "trivial.S" assembly \ - "additional_flags=$type"] - if { ! [string match "*: unknown or unsupported -g option*" \ - $comp_output] } { - foreach level {1 "" 3} { - lappend DEBUG_TORTURE_OPTIONS [list "${type}${level}"] - foreach opt { -O -O3 } { - lappend DEBUG_TORTURE_OPTIONS \ - [list "${type}${level}" "$opt" ] - } - } - } - } - } - - verbose -log "Using options $DEBUG_TORTURE_OPTIONS" - # Initialize `dg'. dg-init # Main loop. ! foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] { ! global runtests ! ! # If we're only testing specific files and this isn't one of ! # them, skip it. ! if ![runtest_file_p $runtests $test] { ! continue ! } ! ! set nshort [file tail [file dirname $test]]/[file tail $test] ! ! foreach flags $DEBUG_TORTURE_OPTIONS { ! set doit 1 ! if { [string match {*/debug-[126].c} "$nshort"] \ ! && [string match "*1" [lindex "$flags" 0] ] } { ! set doit 0 ! } ! ! if { $doit } { ! verbose -log "Testing $nshort, $flags" 1 ! dg-test $test $flags "" ! } ! } ! } # All done. dg-finish --- 19,31 ---- # Load support procs. load_lib gcc-dg.exp # Initialize `dg'. dg-init # Main loop. ! gcc-dg-debug-runtest gcc_target_compile trivial.c [list -O -O3] \ ! [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] # All done. dg-finish diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/c99-typedef1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/c99-typedef1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/c99-typedef1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/c99-typedef1.c 2004-03-18 18:29:37.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + // { dg-options "-std=iso9899:1999 -gdwarf-2" } + + void f() { + int n = 3; + typedef int T[n++]; + + T t; + t[0] = 7; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf2.exp 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + # 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. + + # Load support procs. + 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" + } + + # 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 + } + + # All done. + dg-finish diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die1.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die2.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die3.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die5.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die6.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2/dwarf-die7.c 2004-01-12 16:25:32.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2-3.c 2003-10-06 22:25:19.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* Test -feliminate-dwarf2-dups */ + /* Contributed by Devang Patel */ + /* { dg-do compile } */ + /* { dg-options "-feliminate-dwarf2-dups" } */ + + #include "dwarf2-3.h" + + int main() + { + struct point p; + p.x = 0; + p.y = 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2-3.h gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2-3.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/debug/dwarf2-3.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/debug/dwarf2-3.h 2003-10-06 22:25:19.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test -feliminate-dwarf2-dups */ + /* Contributed by Devang Patel */ + + struct point + { + int x; + int y; + }; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/decl-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/decl-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/decl-3.c 2003-03-12 09:59:52.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/decl-3.c 2004-01-11 01:18:58.000000000 +0000 *************** *** 1,5 **** /* PR c/9928 */ /* { dg-do compile } */ ! enum { CODES }; /* { dg-error "previous declaration" } */ enum { CODES }; /* { dg-error "conflicting types" } */ --- 1,5 ---- /* PR c/9928 */ /* { dg-do compile } */ ! enum { CODES }; /* { dg-error "previous definition" } */ enum { CODES }; /* { dg-error "conflicting types" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/decl-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/decl-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/decl-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/decl-4.c 2004-03-04 05:53:34.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* Redeclaration of parameters is an error. PR 13728. */ + /* { dg-do compile } */ + + void f (int fred, /* { dg-error "previous definition" "" } */ + int fred); /* { dg-error "redefinition of parameter" "" } */ + + void f2 (int fred, /* { dg-error "previous definition" "" } */ + int fred) /* { dg-error "redefinition of parameter" "" } */ + { + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/decl-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/decl-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/decl-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/decl-5.c 2004-03-13 19:05:48.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* PR c/14114 */ + /* Origin: */ + /* { dg-do compile } */ + /* { dg-options "-O2 -g" } */ + + /* This used to fail because the compiler thought that the + declaration of 'c' from 'b' was shadowing that from 'a'. */ + + void a() + { + void c(); + c(); + } + + void b() + { + void c(); + } + + void c() {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/decl-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/decl-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/decl-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/decl-6.c 2004-03-07 00:39:03.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* { dg-do compile } */ + + extern int var; + + int foo1(void) + { + extern int var; + + var += 1; + } + + int foo2(void) + { + var += 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/decl-global-ext.c gcc-3.4.0/gcc/testsuite/gcc.dg/decl-global-ext.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/decl-global-ext.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/decl-global-ext.c 2003-10-04 16:53:19.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + int merror = 0; + extern int merror; + + void mtherr (int code) + { + merror = code + 1; + } + + int main() + { + mtherr(7); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dll-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/dll-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dll-1.c 2001-07-24 15:17:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dll-1.c 2003-03-13 22:21:21.000000000 +0000 *************** *** 1,10 **** /* { dg-do compile { target arm*-*-pe* } } */ - /* { dg-do compile { target thumb*-*-pe* } } */ /* { dg-options -mno-nop-fun-dllimport } */ __declspec (dllimport) void imp (); ! __declspec (dllexport) void exp () { imp (); } - /* { dg-final { scan-assembler "\.section\[ \t\]*.drectve\n\[^\n\]*-export:exp.*__imp_imp" } } */ - /* { dg-final { scan-assembler-not "__imp_exp" } } */ --- 1,10 ---- /* { dg-do compile { target arm*-*-pe* } } */ /* { dg-options -mno-nop-fun-dllimport } */ __declspec (dllimport) void imp (); ! __declspec (dllexport) void _exp () { imp (); } ! ! /* { dg-final { scan-assembler "\.section\[ \t\]*.drectve\n\[^\n\]*-export:_exp.*__imp_imp" } } */ ! /* { dg-final { scan-assembler-not "__imp__exp" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dll-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/dll-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dll-2.c 2002-09-16 13:29:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dll-2.c 2003-03-13 22:21:21.000000000 +0000 *************** *** 9,15 **** and functions. In C++, it only works for functions. */ /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target thumb*-*-pe* } } */ __declspec (dllimport) int foo1 (); __declspec (dllexport) int foo1 (); --- 9,16 ---- and functions. In C++, it only works for functions. */ /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target i?86-pc-cygwin } } */ ! /* { dg-do compile { target i?86-pc-mingw* } } */ __declspec (dllimport) int foo1 (); __declspec (dllexport) int foo1 (); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dll-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/dll-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dll-3.c 2001-07-24 15:17:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dll-3.c 2003-03-13 22:21:21.000000000 +0000 *************** *** 1,7 **** /* Ensure dllexport overrides dllimport. */ /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target thumb*-*-pe* } } */ __declspec (dllimport) int foo1 (); __declspec (dllexport) int foo1 (); --- 1,8 ---- /* Ensure dllexport overrides dllimport. */ /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target i?86-pc-cygwin } } */ ! /* { dg-do compile { target i?86-pc-mingw* } } */ __declspec (dllimport) int foo1 (); __declspec (dllexport) int foo1 (); *************** __declspec (dllimport) int foo2 (); *** 12,16 **** __declspec (dllexport) int foo1 () { return foo2 (); } __declspec (dllexport) int foo2 () { return foo1 (); } ! /* { dg-final { scan-assembler "\.section\[ \t\]*\.drectve\n\[^\n\]*-export:foo1.*\.section\[ \t\]*\.drectve\n\[^\n\]*-export:foo2" } } */ ! /* { dg-final { scan-assembler-not "(__imp_foo1|__imp_foo2)" } } */ --- 13,18 ---- __declspec (dllexport) int foo1 () { return foo2 (); } __declspec (dllexport) int foo2 () { return foo1 (); } ! /* { dg-final { scan-assembler "\.section\[ \t\]*.drectve\n.*-export:foo2" } } */ ! /* { dg-final { scan-assembler "-export:foo1" } } */ ! /* { dg-final { scan-assembler-not "(__imp_foo1|_imp__foo1|__imp_foo2|_imp__foo2)" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dll-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/dll-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dll-4.c 2001-07-24 15:17:01.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dll-4.c 2003-03-13 22:21:21.000000000 +0000 *************** *** 1,5 **** /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target thumb*-*-pe* } } */ __declspec (dllimport) int foo1; int foo1; --- 1,6 ---- /* { dg-do compile { target arm*-*-pe* } } */ ! /* { dg-do compile { target i?86-pc-cygwin } } */ ! /* { dg-do compile { target i?86-pc-mingw* } } */ __declspec (dllimport) int foo1; int foo1; *************** int f () { return foo1 + foo2; } *** 11,14 **** /* FIXME: We should scan the output of nm for this case. */ /* { dg-final { scan-assembler "(foo2:.*\.comm\[ \t_\]*foo1)" } } */ ! /* { dg-final { scan-assembler-not "__imp_" } } */ --- 12,15 ---- /* FIXME: We should scan the output of nm for this case. */ /* { dg-final { scan-assembler "(foo2:.*\.comm\[ \t_\]*foo1)" } } */ ! /* { dg-final { scan-assembler-not "(__imp_|_imp__)" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dll-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/dll-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dll-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dll-5.c 2003-03-13 22:21:21.000000000 +0000 *************** *** 0 **** --- 1,22 ---- + /* { dg-do compile { target i?86-pc-cygwin } } */ + /* { dg-do compile { target i?86-pc-mingw* } } */ + /* { dg-do compile { target arm*-*-pe* } } */ + + /* { dg-options -mnop-fun-dllimport } */ + + /* The dllimport attribute should be ignored for functions. */ + __declspec (dllimport) void dllimpfn (); + + /* The dllimport attribute should not be ignored for variables. */ + __declspec (dllimport) int dllimpvar; + + /* The dllexport attribute should not be ignored. */ + __declspec (dllexport) void dllexp () + { + dllimpfn (); + dllimpvar = 0; + } + + /* { dg-final { scan-assembler-not "(__imp_dllimpfn|_imp__dllimpfn)" } } */ + /* { dg-final { scan-assembler "(__imp_dllimpvar|_imp__dllimpvar)" } } */ + /* { dg-final { scan-assembler "\.section\[ \t\]*.drectve\n\.*-export:dllexp" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/dollar.c gcc-3.4.0/gcc/testsuite/gcc.dg/dollar.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/dollar.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/dollar.c 2003-05-17 20:29:34.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Copyright (C) 2003 Free Software Foundation, Inc. */ + + /* { dg-do compile } */ + /* { dg-options -fno-dollars-in-identifiers } */ + + /* Test that -fno-dollars-in-identifiers is honoured. + Neil Booth, 17 May 2003. */ + + int foobar$; /* { dg-error "stray '\\$'" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/duff-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/duff-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/duff-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/duff-4.c 2003-05-29 16:33:47.000000000 +0000 *************** *** 0 **** --- 1,60 ---- + /* Duff's device is legal C; test to make sure the compiler + doesn't complain about it. + + Roger Sayle + Derived from duff-2.c. */ + + /* { dg-do run } */ + /* { dg-options "-O2" } */ + + extern void abort (void); + extern void exit (int); + + #if __INT_MAX__ >= 2147483647 + /* At least 32-bit integers. */ + typedef int type32; + #else + typedef long type32; + #endif + + type32 + cksum (const unsigned char *src, unsigned long size) + { + type32 ck = 0; + + switch (size & 3) + { + do + { + case 0: + ck ^= (type32)*src++ << 24; + --size; + case 3: + ck ^= (type32)*src++ << 16; + --size; + case 2: + ck ^= (type32)*src++ << 8; + --size; + case 1: + ck ^= (type32)*src++; + --size; + } + while (size > 0); + } + + return ck; + } + + const char testpat[] = "The quick brown fox jumped over the lazy dog."; + + int + main() + { + type32 ck; + + ck = cksum ((const unsigned char *) testpat, sizeof (testpat)); + if (ck != 925902908) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/enum-compat-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/enum-compat-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/enum-compat-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/enum-compat-1.c 2004-01-07 22:24:43.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* Test that enumerated types are only considered compatible when they + are the same type. PR c/6024. */ + /* Origin: Joseph Myers , based on + PR c/6024 from Richard Earnshaw */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + /* Original test from PR c/6024. */ + enum e1 {a, b}; + enum e2 {c, d}; + + void f(enum e1); /* { dg-error "prototype" "error at decl" } */ + + void f(x) + enum e2 x; + { /* { dg-error "doesn't match prototype" "error at defn" } */ + return; + } + + /* Other compatibility tests. */ + enum e3 { A }; + enum e4 { B }; + + enum e3 v3; + enum e4 *p = &v3; /* { dg-warning "incompatible" "incompatible pointer" } */ + enum e3 *q = &v3; + + void g(enum e3); /* { dg-error "declaration" "error at first decl" } */ + void g(enum e4); /* { dg-error "conflicting types" "error at second decl" } */ + + void h(enum e3); + void h(enum e3); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/asm_fprintf-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/asm_fprintf-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/asm_fprintf-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/asm_fprintf-1.c 2003-06-13 14:08:36.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + /* Test for asm_fprintf formats. */ + /* Origin: Kaveh Ghazi */ + /* { dg-do compile } */ + /* { dg-options "-Wformat" } */ + + #include "format.h" + + /* Magic identifier must be set before the attribute is used. */ + typedef long long __gcc_host_wide_int__; + + extern int asm_fprintf (const char *, ...) __attribute__ ((__format__ (__asm_fprintf__, 1, 2))) __attribute__ ((__nonnull__)); + + void + foo (int i, int i1, int i2, unsigned int u, double d, char *s, void *p, + int *n, short int *hn, long int l, unsigned long int ul, + long int *ln, long double ld, wint_t lc, wchar_t *ls, llong ll, + ullong ull, unsigned int *un, const int *cn, signed char *ss, + unsigned char *us, const signed char *css, unsigned int u1, + unsigned int u2) + { + /* Acceptable C90 specifiers, flags and modifiers. */ + asm_fprintf ("%%"); + asm_fprintf ("%d%i%o%u%x%X%c%s%%", i, i, u, u, u, u, i, s); + asm_fprintf ("%ld%li%lo%lu%lx%lX", l, l, ul, ul, ul, ul); + asm_fprintf ("%lld%lli%llo%llu%llx%llX", ll, ll, ull, ull, ull, ull); + asm_fprintf ("%-d%-i%-o%-u%-x%-X%-c%-s", i, i, u, u, u, u, i, s); + asm_fprintf ("% d% i\n", i, i); + asm_fprintf ("%#o%#x%#X", u, u, u); + asm_fprintf ("%08d%08i%08o%08u%08x%08X", i, i, u, u, u, u); + asm_fprintf ("%d\n", i); + asm_fprintf ("%+d\n", i); + asm_fprintf ("%3d\n", i); + asm_fprintf ("%-3d\n", i); + asm_fprintf ("%.7d\n", i); + asm_fprintf ("%+9.4d\n", i); + asm_fprintf ("%.3ld\n", l); + asm_fprintf ("%d %lu\n", i, ul); + + /* Extensions provided in asm_fprintf. */ + asm_fprintf ("%O%R%I%L%U%@"); + asm_fprintf ("%r", i); + asm_fprintf ("%wd%wi%wo%wu%wx%wX", ll, ll, ull, ull, ull, ull); + + /* Standard specifiers not accepted in asm_fprintf. */ + asm_fprintf ("%f\n", d); /* { dg-warning "format" "float" } */ + asm_fprintf ("%e\n", d); /* { dg-warning "format" "float" } */ + asm_fprintf ("%E\n", d); /* { dg-warning "format" "float" } */ + asm_fprintf ("%g\n", d); /* { dg-warning "format" "float" } */ + asm_fprintf ("%G\n", d); /* { dg-warning "format" "float" } */ + asm_fprintf ("%p\n", p); /* { dg-warning "format" "pointer" } */ + asm_fprintf ("%n\n", n); /* { dg-warning "format" "counter" } */ + asm_fprintf ("%hd\n", i); /* { dg-warning "format" "conversion" } */ + + /* Various tests of bad argument types. */ + asm_fprintf ("%d", l); /* { dg-warning "format" "bad argument types" } */ + asm_fprintf ("%wd", l); /* { dg-warning "format" "bad argument types" } */ + asm_fprintf ("%d", ll); /* { dg-warning "format" "bad argument types" } */ + asm_fprintf ("%*d\n", i1, i); /* { dg-warning "format" "bad * argument types" } */ + asm_fprintf ("%.*d\n", i2, i); /* { dg-warning "format" "bad * argument types" } */ + asm_fprintf ("%*.*ld\n", i1, i2, l); /* { dg-warning "format" "bad * argument types" } */ + asm_fprintf ("%ld", i); /* { dg-warning "format" "bad argument types" } */ + asm_fprintf ("%s", n); /* { dg-warning "format" "bad argument types" } */ + + /* Wrong number of arguments. */ + asm_fprintf ("%d%d", i); /* { dg-warning "arguments" "wrong number of args" } */ + asm_fprintf ("%d", i, i); /* { dg-warning "arguments" "wrong number of args" } */ + /* Miscellaneous bogus constructions. */ + asm_fprintf (""); /* { dg-warning "zero-length" "warning for empty format" } */ + asm_fprintf ("\0"); /* { dg-warning "embedded" "warning for embedded NUL" } */ + asm_fprintf ("%d\0", i); /* { dg-warning "embedded" "warning for embedded NUL" } */ + asm_fprintf ("%d\0%d", i, i); /* { dg-warning "embedded|too many" "warning for embedded NUL" } */ + asm_fprintf (NULL); /* { dg-warning "null" "null format string warning" } */ + asm_fprintf ("%"); /* { dg-warning "trailing" "trailing % warning" } */ + asm_fprintf ("%++d", i); /* { dg-warning "repeated" "repeated flag warning" } */ + asm_fprintf ((const char *)L"foo"); /* { dg-warning "wide" "wide string" } */ + asm_fprintf ("%s", (char *)0); /* { dg-warning "null" "%s with NULL" } */ + + /* Make sure we still get warnings for regular printf. */ + printf ("%d\n", ll); /* { dg-warning "format" "bad argument types" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/c90-strftime-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/c90-strftime-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/c90-strftime-1.c 2001-01-07 10:44:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/c90-strftime-1.c 2003-11-08 22:42:00.000000000 +0000 *************** *** 1,7 **** /* Test for strftime formats. Formats using C90 features. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */ #include "format.h" --- 1,7 ---- /* Test for strftime formats. Formats using C90 features. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wformat-y2k" } */ #include "format.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/c90-strftime-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/c90-strftime-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/c90-strftime-2.c 2001-01-07 10:44:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/c90-strftime-2.c 2003-11-08 22:42:00.000000000 +0000 *************** *** 2,8 **** pedantic C90 mode. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1990 -pedantic -Wformat" } */ #include "format.h" --- 2,8 ---- pedantic C90 mode. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1990 -pedantic -Wformat -Wformat-y2k" } */ #include "format.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/c99-strftime-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/c99-strftime-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/c99-strftime-1.c 2001-01-07 10:44:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/c99-strftime-1.c 2003-11-08 22:42:00.000000000 +0000 *************** *** 1,7 **** /* Test for strftime formats. Formats using C99 features. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1999 -pedantic -Wformat" } */ #include "format.h" --- 1,7 ---- /* Test for strftime formats. Formats using C99 features. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=iso9899:1999 -pedantic -Wformat -Wformat-y2k" } */ #include "format.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/ext-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/ext-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/ext-1.c 2001-12-21 02:36:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/ext-1.c 2003-12-20 00:00:39.000000000 +0000 *************** foo (quad_t q, u_quad_t uq, quad_t *qn, *** 92,98 **** */ printf ("%*2$.*1$m", i, i); printf ("%1$*2$.*1$m", i, i); /* { dg-warning "no argument" "printf %1\$m" } */ ! /* As an extension, glibc includes the "I" flag for decimal integer formats, to output using the locale's digits (e.g. in Arabic). In GCC, we require this to be in the standard place for flags, though glibc allows it also after width or precision. --- 92,98 ---- */ printf ("%*2$.*1$m", i, i); printf ("%1$*2$.*1$m", i, i); /* { dg-warning "no argument" "printf %1\$m" } */ ! /* As an extension, glibc includes the "I" flag for decimal formats, to output using the locale's digits (e.g. in Arabic). In GCC, we require this to be in the standard place for flags, though glibc allows it also after width or precision. *************** foo (quad_t q, u_quad_t uq, quad_t *qn, *** 102,113 **** printf ("%Ix", u); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%IX", u); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%In", n); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%If", d); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%IF", d); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%Ie", d); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%IE", d); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%Ig", d); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%IG", d); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%Ia", d); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%IA", d); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%Ic", i); /* { dg-warning "flag" "bad use of I flag" } */ --- 102,113 ---- printf ("%Ix", u); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%IX", u); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%In", n); /* { dg-warning "flag" "bad use of I flag" } */ ! printf ("%If", d); ! printf ("%IF", d); ! printf ("%Ie", d); ! printf ("%IE", d); ! printf ("%Ig", d); ! printf ("%IG", d); printf ("%Ia", d); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%IA", d); /* { dg-warning "flag" "bad use of I flag" } */ printf ("%Ic", i); /* { dg-warning "flag" "bad use of I flag" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/ext-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/ext-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/ext-3.c 2001-01-07 10:44:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/ext-3.c 2003-11-08 22:42:00.000000000 +0000 *************** *** 3,9 **** */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=gnu99 -Wformat" } */ #include "format.h" --- 3,9 ---- */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=gnu99 -Wformat -Wformat-y2k" } */ #include "format.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/gcc_diag-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/gcc_diag-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/gcc_diag-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/gcc_diag-1.c 2003-09-21 05:07:20.000000000 +0000 *************** *** 0 **** --- 1,194 ---- + /* Test for GCC diagnositc formats. */ + /* Origin: Kaveh Ghazi */ + /* { dg-do compile } */ + /* { dg-options "-Wformat" } */ + + #include "format.h" + + #define ATTRIBUTE_DIAG(F) __attribute__ ((__format__ (F, 1, 2))) __attribute__ ((__nonnull__)); + + /* Magic identifiers must be set before the attribute is used. */ + + typedef long long __gcc_host_wide_int__; + + typedef struct location_s + { + const char *file; + int line; + } location_t; + + union tree_node; + typedef union tree_node *tree; + + extern int diag (const char *, ...) ATTRIBUTE_DIAG(__gcc_diag__); + extern int cdiag (const char *, ...) ATTRIBUTE_DIAG(__gcc_cdiag__); + extern int cxxdiag (const char *, ...) ATTRIBUTE_DIAG(__gcc_cxxdiag__); + + void + foo (int i, int i1, int i2, unsigned int u, double d, char *s, void *p, + int *n, short int *hn, long int l, unsigned long int ul, + long int *ln, long double ld, wint_t lc, wchar_t *ls, llong ll, + ullong ull, unsigned int *un, const int *cn, signed char *ss, + unsigned char *us, const signed char *css, unsigned int u1, + unsigned int u2, location_t *loc, tree t1, union tree_node *t2, + tree *t3, tree t4[]) + { + /* Acceptable C90 specifiers, flags and modifiers. */ + diag ("%%"); + cdiag ("%%"); + cxxdiag ("%%"); + diag ("%d%i%o%u%x%c%s%p%%", i, i, u, u, u, i, s, p); + cdiag ("%d%i%o%u%x%c%s%p%%", i, i, u, u, u, i, s, p); + cxxdiag ("%d%i%o%u%x%c%s%p%%", i, i, u, u, u, i, s, p); + diag ("%ld%li%lo%lu%lx", l, l, ul, ul, ul); + cdiag ("%ld%li%lo%lu%lx", l, l, ul, ul, ul); + cxxdiag ("%ld%li%lo%lu%lx", l, l, ul, ul, ul); + diag ("%lld%lli%llo%llu%llx", ll, ll, ull, ull, ull); + cdiag ("%lld%lli%llo%llu%llx", ll, ll, ull, ull, ull); + cxxdiag ("%lld%lli%llo%llu%llx", ll, ll, ull, ull, ull); + diag ("%wd%wi%wo%wu%wx", ll, ll, ull, ull, ull); + cdiag ("%wd%wi%wo%wu%wx", ll, ll, ull, ull, ull); + cxxdiag ("%wd%wi%wo%wu%wx", ll, ll, ull, ull, ull); + diag ("%.*s", i, s); + cdiag ("%.*s", i, s); + cxxdiag ("%.*s", i, s); + + /* Extensions provided in the diagnostic framework. */ + diag ("%m"); + cdiag ("%m"); + cxxdiag ("%m"); + diag ("%H", loc); + cdiag ("%H", loc); + cxxdiag ("%H", loc); + diag ("%J", t1); + cdiag ("%J", t1); + cxxdiag ("%J", t1); + + cdiag ("%D%F%T", t1, t1, t1); + cdiag ("%D%D%D%D", t1, t2, *t3, t4[5]); + cxxdiag ("%A%D%E%F%T%V", t1, t1, t1, t1, t1, t1); + cxxdiag ("%D%D%D%D", t1, t2, *t3, t4[5]); + cxxdiag ("%#A%#D%#E%#F%#T%#V", t1, t1, t1, t1, t1, t1); + cxxdiag ("%+A%+D%+E%+F%+T%+V", t1, t1, t1, t1, t1, t1); + cxxdiag ("%+#A%+#D%+#E%+#F%+#T%+#V", t1, t1, t1, t1, t1, t1); + cxxdiag ("%C%L%O%P%Q", i, i, i, i, i); + + /* Bad stuff with extensions. */ + diag ("%m", i); /* { dg-warning "format" "extra arg" } */ + cdiag ("%m", i); /* { dg-warning "format" "extra arg" } */ + cxxdiag ("%m", i); /* { dg-warning "format" "extra arg" } */ + diag ("%#m"); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%#m"); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%#m"); /* { dg-warning "format" "bogus modifier" } */ + diag ("%+m"); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%+m"); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%+m"); /* { dg-warning "format" "bogus modifier" } */ + diag ("%H"); /* { dg-warning "format" "missing arg" } */ + cdiag ("%H"); /* { dg-warning "format" "missing arg" } */ + cxxdiag ("%H"); /* { dg-warning "format" "missing arg" } */ + diag ("%J"); /* { dg-warning "format" "missing arg" } */ + cdiag ("%J"); /* { dg-warning "format" "missing arg" } */ + cxxdiag ("%J"); /* { dg-warning "format" "missing arg" } */ + diag ("%H", i); /* { dg-warning "format" "wrong arg" } */ + cdiag ("%H", i); /* { dg-warning "format" "wrong arg" } */ + cxxdiag ("%H", i); /* { dg-warning "format" "wrong arg" } */ + diag ("%H", p); /* { dg-warning "format" "wrong arg" } */ + cdiag ("%H", p); /* { dg-warning "format" "wrong arg" } */ + cxxdiag ("%H", p); /* { dg-warning "format" "wrong arg" } */ + diag ("%J", loc); /* { dg-warning "format" "wrong arg" } */ + cdiag ("%J", loc); /* { dg-warning "format" "wrong arg" } */ + cxxdiag ("%J", loc); /* { dg-warning "format" "wrong arg" } */ + diag ("%#H", loc); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%#H", loc); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%#H", loc); /* { dg-warning "format" "bogus modifier" } */ + diag ("%+H", loc); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%+H", loc); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%+H", loc); /* { dg-warning "format" "bogus modifier" } */ + diag ("%D", t1); /* { dg-warning "format" "bogus tree" } */ + cdiag ("%A", t1); /* { dg-warning "format" "bogus tree" } */ + cdiag ("%#D", t1); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%+D", t1); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%C"); /* { dg-warning "format" "missing arg" } */ + cxxdiag ("%C", l); /* { dg-warning "format" "wrong arg" } */ + cxxdiag ("%C", i, i); /* { dg-warning "format" "extra arg" } */ + cxxdiag ("%#C", i); /* { dg-warning "format" "bogus modifier" } */ + cxxdiag ("%+C", i); /* { dg-warning "format" "bogus modifier" } */ + cdiag ("%D"); /* { dg-warning "format" "missing arg" } */ + cxxdiag ("%D"); /* { dg-warning "format" "missing arg" } */ + cdiag ("%D", i); /* { dg-warning "format" "wrong arg" } */ + cxxdiag ("%D", i); /* { dg-warning "format" "wrong arg" } */ + cdiag ("%D", t1, t1); /* { dg-warning "format" "extra arg" } */ + cxxdiag ("%D", t1, t1); /* { dg-warning "format" "extra arg" } */ + + /* Standard specifiers not accepted in the diagnostic framework. */ + diag ("%X\n", u); /* { dg-warning "format" "HEX" } */ + diag ("%f\n", d); /* { dg-warning "format" "float" } */ + diag ("%e\n", d); /* { dg-warning "format" "float" } */ + diag ("%E\n", d); /* { dg-warning "format" "float" } */ + diag ("%g\n", d); /* { dg-warning "format" "float" } */ + diag ("%G\n", d); /* { dg-warning "format" "float" } */ + diag ("%n\n", n); /* { dg-warning "format" "counter" } */ + diag ("%hd\n", i); /* { dg-warning "format" "conversion" } */ + + /* Various tests of bad argument types. */ + diag ("%-d", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%-d", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%-d", i); /* { dg-warning "format" "bad flag" } */ + diag ("% d", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("% d", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("% d", i); /* { dg-warning "format" "bad flag" } */ + diag ("%#o", u); /* { dg-warning "format" "bad flag" } */ + cdiag ("%#o", u); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%#o", u); /* { dg-warning "format" "bad flag" } */ + diag ("%0d", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%0d", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%0d", i); /* { dg-warning "format" "bad flag" } */ + diag ("%08d", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%08d", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%08d", i); /* { dg-warning "format" "bad flag" } */ + diag ("%+d\n", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%+d\n", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%+d\n", i); /* { dg-warning "format" "bad flag" } */ + diag ("%3d\n", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%3d\n", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%3d\n", i); /* { dg-warning "format" "bad flag" } */ + diag ("%-3d\n", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%-3d\n", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%-3d\n", i); /* { dg-warning "format" "bad flag" } */ + diag ("%.7d\n", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%.7d\n", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%.7d\n", i); /* { dg-warning "format" "bad flag" } */ + diag ("%+9.4d\n", i); /* { dg-warning "format" "bad flag" } */ + cdiag ("%+9.4d\n", i); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%+9.4d\n", i); /* { dg-warning "format" "bad flag" } */ + diag ("%.3ld\n", l); /* { dg-warning "format" "bad flag" } */ + cdiag ("%.3ld\n", l); /* { dg-warning "format" "bad flag" } */ + cxxdiag ("%.3ld\n", l); /* { dg-warning "format" "bad flag" } */ + diag ("%d %lu\n", i, ul); + diag ("%d", l); /* { dg-warning "format" "bad argument types" } */ + diag ("%wd", l); /* { dg-warning "format" "bad argument types" } */ + diag ("%d", ll); /* { dg-warning "format" "bad argument types" } */ + diag ("%*s", i, s); /* { dg-warning "format" "bad * argument types" } */ + diag ("%*.*s", i, i, s); /* { dg-warning "format" "bad * argument types" } */ + diag ("%*d\n", i1, i); /* { dg-warning "format" "bad * argument types" } */ + diag ("%.*d\n", i2, i); /* { dg-warning "format" "bad * argument types" } */ + diag ("%*.*ld\n", i1, i2, l); /* { dg-warning "format" "bad * argument types" } */ + diag ("%ld", i); /* { dg-warning "format" "bad argument types" } */ + diag ("%s", n); /* { dg-warning "format" "bad argument types" } */ + + /* Wrong number of arguments. */ + diag ("%d%d", i); /* { dg-warning "arguments" "wrong number of args" } */ + diag ("%d", i, i); /* { dg-warning "arguments" "wrong number of args" } */ + /* Miscellaneous bogus constructions. */ + diag (""); /* { dg-warning "zero-length" "warning for empty format" } */ + diag ("\0"); /* { dg-warning "embedded" "warning for embedded NUL" } */ + diag ("%d\0", i); /* { dg-warning "embedded" "warning for embedded NUL" } */ + diag ("%d\0%d", i, i); /* { dg-warning "embedded|too many" "warning for embedded NUL" } */ + diag (NULL); /* { dg-warning "null" "null format string warning" } */ + diag ("%"); /* { dg-warning "trailing" "trailing % warning" } */ + diag ((const char *)L"foo"); /* { dg-warning "wide" "wide string" } */ + diag ("%s", (char *)0); /* { dg-warning "null" "%s with NULL" } */ + + /* Make sure we still get warnings for regular printf. */ + printf ("%d\n", ll); /* { dg-warning "format" "bad argument types" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/format/no-y2k-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/format/no-y2k-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/format/no-y2k-1.c 2001-01-07 10:44:59.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/format/no-y2k-1.c 2003-11-08 22:42:00.000000000 +0000 *************** *** 1,7 **** ! /* Test for warnings for Y2K problems being disabled by -Wno-format-y2k. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=gnu99 -Wformat -Wno-format-y2k" } */ #include "format.h" --- 1,7 ---- ! /* Test for warnings for Y2K problems not being on by default. */ /* Origin: Joseph Myers */ /* { dg-do compile } */ ! /* { dg-options "-std=gnu99 -Wformat" } */ #include "format.h" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/funcorder.c gcc-3.4.0/gcc/testsuite/gcc.dg/funcorder.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/funcorder.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/funcorder.c 2004-04-18 18:42:30.000000000 +0000 *************** *** 0 **** --- 1,39 ---- + /* { dg-do compile } */ + /* { dg-options "-O2 -funit-at-a-time" } */ + /* { dg-final { if [ istarget hppa*-*-* ] { scan-assembler-not "link_error,%r" { xfail hppa*64*-*-* } } else { scan-assembler-not "link_error" } } } */ + /* In unit-at-time the functions should be assembled in order + e q t main, so we realize that they are pure. The test is + xfailed on hppa64 because variable r in q is sign extended + to 64-bits. As a result, "if (t!=mem)" is not simplified. */ + + static int mem; + static int e(void) __attribute__ ((noinline)); + static int q(void) __attribute__ ((noinline)); + static int t(void) __attribute__ ((noinline)); + main() + { + return t(); + } + static t() + { + int r,e; + if (mem) + t(); + e=mem; + r=q(); + if (e!=mem) + link_error(); + return r; + } + static int e() + { + return 0; + } + static int q() + { + int t=mem,r; + r=e(); + if (t!=mem) + link_error(); + return r; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/func-ptr-conv-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/func-ptr-conv-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/func-ptr-conv-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/func-ptr-conv-1.c 2004-01-09 20:03:57.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + /* Conversions between function and object pointers are not permitted + in any version of ISO C, even with casts, except for the special + case of converting a null pointer constant to function pointer + type. Likewise, comparisons between function and object pointers + are not permitted. PR c/11234. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "-pedantic" } */ + + void f(void); + + void *v1 = f; /* { dg-warning "pointer" "bad conversion" } */ + void *v2 = &f; /* { dg-warning "pointer" "bad conversion" } */ + void *v3 = (void *)f; /* { dg-warning "pointer" "bad conversion" } */ + void *v4 = (void *)&f; /* { dg-warning "pointer" "bad conversion" } */ + void *v5; + char *c1 = f; /* { dg-warning "pointer" "bad conversion" } */ + char *c2 = &f; /* { dg-warning "pointer" "bad conversion" } */ + char *c3 = (char *)f; /* { dg-warning "pointer" "bad conversion" } */ + char *c4 = (char *)&f; /* { dg-warning "pointer" "bad conversion" } */ + char *c5; + void (*fp)(void); + int a; + + void + g(void) + { + v5 = f; /* { dg-warning "pointer" "bad conversion" } */ + v5 = &f; /* { dg-warning "pointer" "bad conversion" } */ + v5 = (void *)f; /* { dg-warning "pointer" "bad conversion" } */ + v5 = (void *)&f; /* { dg-warning "pointer" "bad conversion" } */ + c5 = f; /* { dg-warning "pointer" "bad conversion" } */ + c5 = &f; /* { dg-warning "pointer" "bad conversion" } */ + c5 = (char *)f; /* { dg-warning "pointer" "bad conversion" } */ + c5 = (char *)&f; /* { dg-warning "pointer" "bad conversion" } */ + fp = v5; /* { dg-warning "pointer" "bad conversion" } */ + fp = c5; /* { dg-warning "pointer" "bad conversion" } */ + fp = (void (*)(void))v5; /* { dg-warning "pointer" "bad conversion" } */ + fp = (void (*)(void))c5; /* { dg-warning "pointer" "bad conversion" } */ + (a ? f : v3); /* { dg-warning "pointer" "bad conversion" } */ + (a ? v2 : fp); /* { dg-warning "pointer" "bad conversion" } */ + /* The following are OK. */ + fp = 0; + fp = (void *)0; + fp = 0L; + fp = (void (*)(void))0; + fp = (void (*)(void))(void *)0; + (a ? f : 0); + (a ? f : (void *)0); + (a ? (void *)0 : fp); + (a ? 0 : fp); + } + + /* The following are OK. */ + void (*fp2)(void) = 0; + void (*fp3)(void) = (void *)0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/fwrapv-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/fwrapv-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/fwrapv-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/fwrapv-1.c 2003-05-31 13:23:31.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test that the -fwrapv command line option is accepted and disables + "unsafe" optimizations that rely on undefined arithmetic overflow. + + Written by Roger Sayle, 24th March 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -fwrapv" } */ + + #include + + extern void abort (); + + int test(int x) + { + return (2*x)/2; + } + + main() + { + int x = INT_MAX; + + if (test(x) == x) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/fwrapv-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/fwrapv-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/fwrapv-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/fwrapv-2.c 2003-05-31 13:23:31.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Test that the -fno-wrapv command line option is accepted and enables + "unsafe" optimizations that rely on undefined arithmetic overflow. + + Written by Roger Sayle, 31st May 2003. */ + + /* { dg-do run } */ + /* { dg-options "-O2 -fno-wrapv" } */ + + #include + + extern void abort (); + + int test(int x) + { + return (2*x)/2; + } + + main() + { + int x = INT_MAX; + + if (test(x) != x) + abort (); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/fwritable-strings-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/fwritable-strings-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/fwritable-strings-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/fwritable-strings-1.c 2004-02-08 01:27:19.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR c/12818 */ + /* Origin: */ + + /* { dg-do run } */ + /* { dg-options "-fwritable-strings" } */ + /* { dg-error "-fwritable-strings is deprecated" "" { target *-*-* } 0 } */ + + extern void abort(void); + + char *names[] = {"alice", "bob", "john"}; + + int main (void) + { + if (names[1][0] != 'b') + abort(); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/gnu89-dupqual-1.c 2004-03-11 00:46:48.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/gnu89-init-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/gnu89-init-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/gnu89-init-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/gnu89-init-3.c 2004-03-26 23:04:39.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR 11527 */ + /* { dg-do compile } */ + /* { dg-options "-std=gnu89" } */ + + typedef struct smrdd_memory_blocks_s + { + int blocks; + int block[]; + } smrdd_memory_blocks_t; + + const smrdd_memory_blocks_t smrdd_memory_blocks = + { + 3, + { + [5] = 5, + [1] = 2, + } + }; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-1.c 2002-04-14 11:52:25.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-1.c 2003-07-30 22:48:45.000000000 +0000 *************** *** 1,10 **** /* Verify that -mno-fancy-math-387 works. */ /* { dg-do compile { target "i?86-*-*" } } */ ! /* { dg-options "-O -ffast-math -mfpmath=387 -mno-fancy-math-387" } */ /* { dg-final { scan-assembler "call\t_?sin" } } */ /* { dg-final { scan-assembler "call\t_?cos" } } */ /* { dg-final { scan-assembler "call\t_?sqrt" } } */ double f1(double x) { return __builtin_sin(x); } double f2(double x) { return __builtin_cos(x); } double f3(double x) { return __builtin_sqrt(x); } --- 1,16 ---- /* Verify that -mno-fancy-math-387 works. */ /* { dg-do compile { target "i?86-*-*" } } */ ! /* { dg-options "-O -ffast-math -mfpmath=387 -mno-fancy-math-387 -march=i386" } */ /* { dg-final { scan-assembler "call\t_?sin" } } */ /* { dg-final { scan-assembler "call\t_?cos" } } */ /* { dg-final { scan-assembler "call\t_?sqrt" } } */ + /* { dg-final { scan-assembler "call\t_?atan2" } } */ + /* { dg-final { scan-assembler "call\t_?log" } } */ + /* { dg-final { scan-assembler "call\t_?exp" } } */ double f1(double x) { return __builtin_sin(x); } double f2(double x) { return __builtin_cos(x); } double f3(double x) { return __builtin_sqrt(x); } + double f4(double x, double y) { return __builtin_atan2(x,y); } + double f5(double x) { return __builtin_log(x); } + double f6(double x) { return __builtin_exp(x); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-2.c 2002-03-29 23:24:20.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-2.c 2003-06-15 13:32:31.000000000 +0000 *************** *** 4,10 **** --- 4,16 ---- /* { dg-final { scan-assembler "fsin" } } */ /* { dg-final { scan-assembler "fcos" } } */ /* { dg-final { scan-assembler "fsqrt" } } */ + /* { dg-final { scan-assembler "fpatan" } } */ + /* { dg-final { scan-assembler "fyl2x" } } */ + /* { dg-final { scan-assembler "f2xm1" } } */ double f1(double x) { return __builtin_sin(x); } double f2(double x) { return __builtin_cos(x); } double f3(double x) { return __builtin_sqrt(x); } + double f4(double x, double y) { return __builtin_atan2(x,y); } + double f5(double x) { return __builtin_log(x); } + double f6(double x) { return __builtin_exp(x); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-3.c 2003-02-16 01:35:38.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* Verify that 387 mathematical constants are recognized. */ + /* { dg-do compile { target "i?86-*-*" } } */ + /* { dg-options "-O2 -march=i686" } */ + /* { dg-final { scan-assembler "fldpi" } } */ + + long double add_pi(long double x) + { + return x + 3.1415926535897932385128089594061862044L; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-4.c 2003-06-04 12:20:40.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* { dg-do compile { target "i?86-*-*" } } */ + /* { dg-options "-O2 -march=i686" } */ + /* { dg-final { scan-assembler "fldpi" } } */ + + long double atanl (long double); + + long double pi() + { + return 4.0 * atanl (1.0); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-5.c 2003-07-30 22:48:45.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* Verify that -mno-fancy-math-387 works. */ + /* { dg-do compile { target "i?86-*-*" } } */ + /* { dg-options "-O -ffast-math -mfpmath=387 -mno-fancy-math-387 -march=i386" } */ + /* { dg-final { scan-assembler "call\t_?atan" } } */ + + double f1(double x) { return __builtin_atan(x); } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-387-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-387-6.c 2003-06-16 12:53:16.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* Verify that -march overrides -mno-fancy-math-387. */ + /* { dg-do compile { target "i?86-*-*" } } */ + /* { dg-options "-O -ffast-math -mfpmath=387 -march=i686 -mno-fancy-math-387" } */ + /* { dg-final { scan-assembler "fpatan" } } */ + + double f1(double x) { return __builtin_atan(x); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-asm-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-asm-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-asm-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-asm-1.c 2004-02-26 14:31:54.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + /* PR inline-asm/11676 */ + /* { dg-do run { target i?86-*-* } } */ + /* { dg-options "-O2" } */ + + static int bar(int x) __asm__("bar") __attribute__((regparm(1))); + static int __attribute__((regparm(1), noinline, used)) + bar(int x) + { + if (x != 0) + abort (); + } + + static int __attribute__((regparm(1), noinline)) + foo(int x) + { + x = 0; + __asm__ __volatile__("call bar" : "=a"(x) : "a"(x)); + } + + int main() + { + foo(1); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-asm-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-asm-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-asm-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-asm-2.c 2004-03-03 18:36:58.000000000 +0000 *************** *** 0 **** --- 1,61 ---- + /* PR opt/13862 */ + /* { dg-do compile { target i?86-*-* } } */ + /* { dg-options "-O" } */ + + typedef struct _fame_syntax_t_ { + } fame_syntax_t; + + typedef struct _fame_bitbuffer_t_ + { + unsigned char * base; + unsigned char * data; + unsigned long shift; + } fame_bitbuffer_t; + + #define fast_bitbuffer_write(data, shift, c, l) \ + { \ + int d; \ + \ + asm("add %1, %%ecx\n" /* ecx = shift + length */ \ + "shrd %%cl, %2, %3\n" /* adjust code to fit in */ \ + "shr %%cl, %2\n" /* adjust code to fit in */ \ + "mov %%ecx, %1\n" /* shift += length */ \ + "bswap %2\n" /* reverse byte order of code */ \ + "shr $5, %%ecx\n" /* get dword increment */ \ + "or %2, (%0)\n" /* put first 32 bits */ \ + "bswap %3\n" /* reverse byte order of code */ \ + "lea (%0, %%ecx, 4), %0\n" /* data += (ecx>32) */ \ + "andl $31, %1\n" /* mask shift */ \ + "orl %3, (%0)\n" /* put last 32 bits */ \ + : "=r"(data), "=r"(shift), "=a"(d), "=d"(d), "=c"(d) \ + : "0"(data), "1"(shift), "2"((unsigned long) c), "3"(0), \ + "c"((unsigned long) l) \ + : "memory"); \ + } + + #define bitbuffer_write(bb, c, l) \ + fast_bitbuffer_write((bb)->data, (bb)->shift, c, l) + + typedef enum { frame_type_I, frame_type_P } frame_type_t; + + typedef struct _fame_syntax_mpeg1_t_ { + fame_bitbuffer_t buffer; + frame_type_t frame_type; + } fame_syntax_mpeg1_t; + + #define FAME_SYNTAX_MPEG1(x) ((fame_syntax_mpeg1_t *) x) + + void mpeg1_start_picture(fame_syntax_t *syntax) + { + fame_syntax_mpeg1_t *syntax_mpeg1 = FAME_SYNTAX_MPEG1(syntax); + bitbuffer_write(&syntax_mpeg1->buffer, 0xFFFF, 16); + + switch(syntax_mpeg1->frame_type) { + case frame_type_I: + bitbuffer_write(&syntax_mpeg1->buffer, 0, 1); + break; + case frame_type_P: + bitbuffer_write(&syntax_mpeg1->buffer, 0, 1); + break; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield1.c 2002-08-07 21:05:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield1.c 2002-12-16 18:22:43.000000000 +0000 *************** *** 1,6 **** --- 1,7 ---- // Test for bitfield alignment in structs on IA-32 // { dg-do run { target i?86-*-* } } // { dg-options "-O2" } + // { dg-options "-mno-align-double -mno-ms-bitfields" { target *-*-interix* } } extern void abort (void); extern void exit (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield2.c 2002-12-23 02:10:18.000000000 +0000 *************** *** 0 **** --- 1,22 ---- + // Test for bitfield alignment in structs on IA-32 + // { dg-do run { target i?86-*-* } } + // { dg-options "-O2" } + // { dg-options "-mno-align-double -mno-ms-bitfields" { target *-*-interix* } } + + extern void abort (void); + extern void exit (int); + + struct X { + char a; + long long : 0; + char b; + } x; + + int main () { + if (&x.b - &x.a != 4) + abort (); + if (sizeof (x) != 5) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-bitfield3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-bitfield3.c 2002-12-23 16:38:43.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + // Test for bitfield alignment in structs on IA-32 + // { dg-do run { target i?86-*-* } } + // { dg-options "-O2" } + // { dg-options "-mno-align-double -mno-ms-bitfields" { target *-*-interix* } } + + extern void abort (void); + extern void exit (int); + + struct X { + int : 32; + }; + + struct Y { + int i : 32; + }; + + int main () { + if (__alignof__(struct X) != 1) + abort (); + if (__alignof__(struct Y) != 4) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cadd.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cadd.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cadd.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cadd.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,22 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "sbb" } } */ + + /* Conditional increment is best done using sbb $-1, val. */ + int t[]={0,0,0,0,1,1,1,1,1,1}; + q() + { + int sum=0; + int i; + for (i=0;i<10;i++) + if (t[i]) + sum++; + if (sum != 6) + abort (); + } + main() + { + int i; + for (i=0;i<10000000;i++) + q(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov1.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "sar\[^\\n\]*magic_namea" } } */ + /* { dg-final { scan-assembler "sar\[^\\n\]*magic_nameb" } } */ + /* { dg-final { scan-assembler "sar\[^\\n\]*magic_namec" } } */ + /* { dg-final { scan-assembler "shr\[^\\n\]*magic_named" } } */ + /* { dg-final { scan-assembler "shr\[^\\n\]*magic_namee" } } */ + /* { dg-final { scan-assembler "shr\[^\\n\]*magic_namef" } } */ + + /* Check code generation for several conditional moves doable by single arithmetics. */ + + int magic_namea; + char magic_nameb; + short magic_namec; + int magic_named; + char magic_namee; + short magic_namef; + + unsigned int gen; + m() + { + magic_namec=magic_namec>=0?0:-1; + magic_namea=magic_namea>=0?0:-1; + magic_nameb=magic_nameb>=0?0:-1; + magic_named=magic_named>=0?0:1; + magic_namee=magic_namee>=0?0:1; + magic_namef=magic_namef>=0?0:1; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov2.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "sbb" } } */ + + /* This conditional move is fastest to be done using sbb. */ + t(unsigned int a, unsigned int b) + { + return (a<=b?5:-5); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov3.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "cmov" } } */ + + /* This conditional move is fastest to be done using cmov. */ + t(int a, int b) + { + return (a<=b?5:-5); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov4.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov4.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "cmov" } } */ + + /* Verify that if conversion happends for memory references. */ + int ARCHnodes; + int *nodekind; + float *nodekindf; + t() + { + int i; + /* Redefine nodekind to be 1 for all surface nodes */ + + for (i = 0; i < ARCHnodes; i++) { + nodekind[i] = (int) nodekindf[i]; + if (nodekind[i] == 3) + nodekind[i] = 1; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov5.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cmov5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cmov5.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "sbb" } } */ + + int + t(float a, float b) + { + return a<=b?0:-1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cpuid.h gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cpuid.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cpuid.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cpuid.h 2004-02-17 17:16:27.000000000 +0000 *************** *** 0 **** --- 1,56 ---- + /* Helper file for i386 platform. Runtime check for MMX/SSE/SSE2 support. + Used by 20020523-2.c and i386-sse-6.c, and possibly others. */ + /* Plagarized from 20020523-2.c. */ + + #define bit_CMOV (1 << 15) + #define bit_MMX (1 << 23) + #define bit_SSE (1 << 25) + #define bit_SSE2 (1 << 26) + + #ifndef NOINLINE + #define NOINLINE __attribute__ ((noinline)) + #endif + + unsigned int i386_cpuid (void) NOINLINE; + + unsigned int NOINLINE + i386_cpuid (void) + { + int fl1, fl2; + + #ifndef __x86_64__ + /* See if we can use cpuid. On AMD64 we always can. */ + __asm__ ("pushfl; pushfl; popl %0; movl %0,%1; xorl %2,%0;" + "pushl %0; popfl; pushfl; popl %0; popfl" + : "=&r" (fl1), "=&r" (fl2) + : "i" (0x00200000)); + if (((fl1 ^ fl2) & 0x00200000) == 0) + return (0); + #endif + + /* Host supports cpuid. See if cpuid gives capabilities, try + CPUID(0). Preserve %ebx and %ecx; cpuid insn clobbers these, we + don't need their CPUID values here, and %ebx may be the PIC + register. */ + #ifdef __x86_64__ + __asm__ ("pushq %%rcx; pushq %%rbx; cpuid; popq %%rbx; popq %%rcx" + : "=a" (fl1) : "0" (0) : "rdx", "cc"); + #else + __asm__ ("pushl %%ecx; pushl %%ebx; cpuid; popl %%ebx; popl %%ecx" + : "=a" (fl1) : "0" (0) : "edx", "cc"); + #endif + if (fl1 == 0) + return (0); + + /* Invoke CPUID(1), return %edx; caller can examine bits to + determine what's supported. */ + #ifdef __x86_64__ + __asm__ ("pushq %%rcx; pushq %%rbx; cpuid; popq %%rbx; popq %%rcx" + : "=d" (fl2), "=a" (fl1) : "1" (1) : "cc"); + #else + __asm__ ("pushl %%ecx; pushl %%ebx; cpuid; popl %%ebx; popl %%ecx" + : "=d" (fl2), "=a" (fl1) : "1" (1) : "cc"); + #endif + + return fl2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cvt-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cvt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-cvt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-cvt-1.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8 -mfpmath=sse" } */ + /* { dg-final { scan-assembler "cvttsd2si\[^\\n\]*xmm" } } */ + /* { dg-final { scan-assembler "cvttss2si\[^\\n\]*xmm" } } */ + int a,a1; + double b; + float b1; + t() + { + a=b; + a1=b1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fastcall-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fastcall-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fastcall-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fastcall-1.c 2002-12-19 22:00:31.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* { dg-do compile { target i386-pc-mingw32* i386-pc-cygwin* } } */ + + void + __attribute__ ((fastcall)) + f1() { } + + void + _fastcall + f2() { } + + void + __fastcall + f3() { } + + int + __attribute__ ((fastcall)) + f4(int x, int y, int z) { } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-1.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2 -march=k8" } */ + /* { dg-final { scan-assembler-not "cvtss2sd" } } */ + float a,b; + main() + { + a=b*3.0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-2.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2 -march=k8" } */ + /* { dg-final { scan-assembler-not "cvtss2sd" } } */ + float a,b; + main() + { + return a<0.0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-3.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2 -march=k8" } */ + /* { dg-final { scan-assembler-not "cvtss2sd" } } */ + float a,b; + main() + { + a=fabs(b)+1.0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-fpcvt-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-fpcvt-4.c 2003-02-10 12:12:56.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8 -mfpmath=sse" } */ + /* { dg-final { scan-assembler "cvtsi2sd" } } */ + /* Check that conversions will get folded. */ + double + t(short a) + { + float b=a; + return b; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-local2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-local2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-local2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-local2.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -funit-at-a-time -fomit-frame-pointer" } */ + /* { dg-final { scan-assembler-not "sub\[^\\n\]*sp" } } */ + + static __attribute__ ((noinline)) q (); + int a; + + /* This function should not require any stack manipulation + for preferred stack bounday. */ + void + e () + { + if (a) + { + e (); + a--; + } + q (); + } + + static __attribute__ ((noinline)) q () + { + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-local.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-local.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-local.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-local.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -funit-at-a-time" } */ + /* { dg-final { scan-assembler "magic\[^\\n\]*eax" } } */ + + /* Verify that local calling convention is used. */ + static t(int) __attribute__ ((noinline)); + m() + { + t(1); + } + static t(int a) + { + asm("magic %0"::"g"(a)); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-1.c 2003-03-09 15:42:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-1.c 2003-03-09 15:40:00.000000000 +0000 *************** *** 1,6 **** /* PR optimization/9888 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mcpu=k6 -O3" } */ /* Verify that GCC doesn't emit out of range 'loop' instructions. */ --- 1,6 ---- /* PR optimization/9888 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mtune=k6 -O3" } */ /* Verify that GCC doesn't emit out of range 'loop' instructions. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-2.c 2003-03-12 09:35:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-2.c 2003-03-12 09:21:47.000000000 +0000 *************** *** 1,7 **** /* PR optimization/9888 */ /* Originator: Jim Bray */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mcpu=k6 -Os" } */ enum reload_type { --- 1,7 ---- /* PR optimization/9888 */ /* Originator: Jim Bray */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mtune=k6 -Os" } */ enum reload_type { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-loop-3.c 2003-06-01 16:15:10.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-loop-3.c 2003-06-01 16:10:09.000000000 +0000 *************** *** 2,8 **** /* Originator: Tim McGrath */ /* Testcase contributed by Eric Botcazou */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mcpu=k6 -O3 -ffast-math -funroll-loops" } */ typedef struct { --- 2,8 ---- /* Originator: Tim McGrath */ /* Testcase contributed by Eric Botcazou */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mtune=k6 -O3 -ffast-math -funroll-loops" } */ typedef struct { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mmx-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mmx-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mmx-3.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mmx-3.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 1,7 **** /* PR target/8870 */ /* Originator: otaylor@redhat.com */ /* { dg-do compile { target i?86-*-* x86_64-*-*} } */ ! /* { dg-options "-O1 -mmmx -march=athlon" } */ typedef int v4hi __attribute__ ((mode (V4HI))); --- 1,7 ---- /* PR target/8870 */ /* Originator: otaylor@redhat.com */ /* { dg-do compile { target i?86-*-* x86_64-*-*} } */ ! /* { dg-options "-O1 -mmmx -march=k8" } */ typedef int v4hi __attribute__ ((mode (V4HI))); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mmx-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mmx-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mmx-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mmx-4.c 2004-02-17 17:16:27.000000000 +0000 *************** *** 0 **** --- 1,245 ---- + /* { dg-do run { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -mmmx" } */ + #include + #include + #include + #include + #include "i386-cpuid.h" + + #ifndef NOINLINE + #define NOINLINE __attribute__ ((noinline)) + #endif + + #define SHIFT (4) + + typedef union { + __m64 v; + unsigned char c[8]; + unsigned short int s[4]; + unsigned long long t; + unsigned int u[2]; + }vecInWord; + + void mmx_tests (void) NOINLINE; + void dump64_16 (char *, char *, vecInWord); + void dump64_32 (char *, char *, vecInWord); + void dump64_64 (char *, char *, vecInWord); + int check (const char *, const char *[]); + + char buf[8000]; + char comparison[8000]; + static int errors = 0; + + vecInWord a64, b64, c64, d64, e64; + __m64 m64_16, s64, m64_32, m64_64; + + const char *reference_mmx[] = { + "_mm_srai_pi16 0012 0012 0012 0012 \n", + "_mm_sra_pi16 0012 0012 0012 0012 \n", + "_mm_srai_pi32 00123456 00123456 \n", + "_mm_sra_pi32 00123456 00123456 \n", + "_mm_srli_pi16 0012 0012 0012 0012 \n", + "_mm_srl_pi16 0012 0012 0012 0012 \n", + "_mm_srli_pi32 00123456 00123456 \n", + "_mm_srl_pi32 00123456 00123456 \n", + "_mm_srli_si64 00123456789abcde\n", + "_mm_srl_si64 00123456789abcde\n", + "_mm_slli_pi16 1230 1230 1230 1230 \n", + "_mm_sll_pi16 1230 1230 1230 1230 \n", + "_mm_slli_pi32 12345670 12345670 \n", + "_mm_sll_pi32 12345670 12345670 \n", + "_mm_slli_si64 123456789abcdef0\n", + "_mm_sll_si64 123456789abcdef0\n", + "" + }; + + int main() + { + unsigned long cpu_facilities; + + cpu_facilities = i386_cpuid (); + + if ((cpu_facilities & bit_MMX) == 0) + exit (0); + + d64.u[0] = 0x01234567; + d64.u[1] = 0x01234567; + + m64_32 = d64.v; + + e64.t = 0x0123456789abcdefULL; + + m64_64 = e64.v; + + a64.s[0] = 0x0123; + a64.s[1] = 0x0123; + a64.s[2] = 0x0123; + a64.s[3] = 0x0123; + + m64_16 = a64.v; + + b64.s[0] = SHIFT; + b64.s[1] = 0; + b64.s[2] = 0; + b64.s[3] = 0; + + s64 = b64.v; + + if (cpu_facilities & bit_MMX) + { + mmx_tests(); + check (buf, reference_mmx); + #ifdef DEBUG + printf ("mmx testing:\n"); + printf (buf); + printf ("\ncomparison:\n"); + printf (comparison); + #endif + buf[0] = '\0'; + } + + if (errors != 0) + abort (); + exit (0); + } + + void NOINLINE + mmx_tests (void) + { + /* psraw */ + c64.v = _mm_srai_pi16 (m64_16, SHIFT); + dump64_16 (buf, "_mm_srai_pi16", c64); + c64.v = _mm_sra_pi16 (m64_16, s64); + dump64_16 (buf, "_mm_sra_pi16", c64); + + /* psrad */ + c64.v = _mm_srai_pi32 (m64_32, SHIFT); + dump64_32 (buf, "_mm_srai_pi32", c64); + c64.v = _mm_sra_pi32 (m64_32, s64); + dump64_32 (buf, "_mm_sra_pi32", c64); + + /* psrlw */ + c64.v = _mm_srli_pi16 (m64_16, SHIFT); + dump64_16 (buf, "_mm_srli_pi16", c64); + c64.v = _mm_srl_pi16 (m64_16, s64); + dump64_16 (buf, "_mm_srl_pi16", c64); + + /* psrld */ + c64.v = _mm_srli_pi32 (m64_32, SHIFT); + dump64_32 (buf, "_mm_srli_pi32", c64); + c64.v = _mm_srl_pi32 (m64_32, s64); + dump64_32 (buf, "_mm_srl_pi32", c64); + + /* psrlq */ + c64.v = _mm_srli_si64 (m64_64, SHIFT); + dump64_64 (buf, "_mm_srli_si64", c64); + c64.v = _mm_srl_si64 (m64_64, s64); + dump64_64 (buf, "_mm_srl_si64", c64); + + /* psllw */ + c64.v = _mm_slli_pi16 (m64_16, SHIFT); + dump64_16 (buf, "_mm_slli_pi16", c64); + c64.v = _mm_sll_pi16 (m64_16, s64); + dump64_16 (buf, "_mm_sll_pi16", c64); + + /* pslld */ + c64.v = _mm_slli_pi32 (m64_32, SHIFT); + dump64_32 (buf, "_mm_slli_pi32", c64); + c64.v = _mm_sll_pi32 (m64_32, s64); + dump64_32 (buf, "_mm_sll_pi32", c64); + + /* psllq */ + c64.v = _mm_slli_si64 (m64_64, SHIFT); + dump64_64 (buf, "_mm_slli_si64", c64); + c64.v = _mm_sll_si64 (m64_64, s64); + dump64_64 (buf, "_mm_sll_si64", c64); + } + + void + dump64_16 (char *buf, char *name, vecInWord x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<4; i++) + { + sprintf (p, "%4.4x ", x.s[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + void + dump64_32 (char *buf, char *name, vecInWord x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<2; i++) + { + sprintf (p, "%8.8x ", x.u[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + void + dump64_64 (char *buf, char *name, vecInWord x) + { + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + sprintf (p, "%16.16llx\n", x.t); + } + + int + check (const char *input, const char *reference[]) + { + int broken, i, j, len; + const char *p_input; + char *p_comparison; + int new_errors = 0; + + p_comparison = &comparison[0]; + p_input = input; + + for (i = 0; *reference[i] != '\0'; i++) + { + broken = 0; + len = strlen (reference[i]); + for (j = 0; j < len; j++) + { + /* Ignore the terminating NUL characters at the end of every string in 'reference[]'. */ + if (!broken && *p_input != reference[i][j]) + { + *p_comparison = '\0'; + strcat (p_comparison, " >>> "); + p_comparison += strlen (p_comparison); + new_errors++; + broken = 1; + } + *p_comparison = *p_input; + p_comparison++; + p_input++; + } + if (broken) + { + *p_comparison = '\0'; + strcat (p_comparison, "expected:\n"); + strcat (p_comparison, reference[i]); + p_comparison += strlen (p_comparison); + } + } + *p_comparison = '\0'; + strcat (p_comparison, new_errors ? "failure\n\n" : "O.K.\n\n") ; + errors += new_errors; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mul.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mul.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-mul.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-mul.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=k8" } */ + /* { dg-final { scan-assembler "and\[^\\n\]*magic" } } */ + + /* Should be done as "andw $32767, magic". */ + unsigned short magic; + t() + { + magic%=(unsigned short)0x8000U; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-pentium4-not-mull.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-pentium4-not-mull.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-pentium4-not-mull.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-pentium4-not-mull.c 2003-11-12 06:44:46.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -march=pentium4" { target i?86-*-* } } */ + /* { dg-options "-O2 -march=pentium4 -m32" { target x86_64-*-* } } */ + /* { dg-final { scan-assembler-not "imull" } } */ + + /* Should be done not using imull. */ + int t(int x) + { + return x*29; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-pic-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-pic-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-pic-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-pic-1.c 2002-12-19 17:06:45.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR target/8340 */ + /* { dg-do compile { target i?86-*-* } } */ + /* { dg-options "-fPIC" } */ + + int foo () + { + static int a; + + __asm__ __volatile__ ( /* { dg-error "PIC register" } */ + "xorl %%ebx, %%ebx\n" + "movl %%ebx, %0\n" + : "=m" (a) + : + : "%ebx" + ); + + return a; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-regparm.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-regparm.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-regparm.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-regparm.c 2004-02-25 00:42:39.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* { dg-do compile { target i?86-*-* } } */ + /* { dg-options "-W -Wall" } */ + + /* Verify that GCC correctly detects non-matching regparm attributes. */ + int __attribute__((regparm(3))) f (void); /* { dg-error "previous" } */ + + int __attribute__((regparm(2))) f (void) { /* { dg-error "conflicting" } */ + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-1.c 2003-03-25 10:30:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-1.c 2003-03-25 10:18:47.000000000 +0000 *************** *** 1,6 **** /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mcpu=i586" } */ extern void abort (void); --- 1,6 ---- /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mtune=i586" } */ extern void abort (void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-2.c 2003-03-25 10:30:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-2.c 2003-03-25 10:18:47.000000000 +0000 *************** *** 1,6 **** /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mcpu=i586" } */ extern void abort (void); --- 1,6 ---- /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mtune=i586" } */ extern void abort (void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-signbit-3.c 2003-03-25 10:30:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-signbit-3.c 2003-03-25 10:18:47.000000000 +0000 *************** *** 1,6 **** /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mcpu=i586" } */ extern void abort (void); --- 1,6 ---- /* PR optimization/8746 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-O1 -mtune=i586" } */ extern void abort (void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-5.c 2004-01-06 10:49:58.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile { target i?86-*-* } } */ + /* { dg-options "-Winline -O2 -march=i386" } */ + typedef int v2df __attribute__ ((mode(V2DF))); + v2df p; + q(v2df t) + { /* { dg-warning "SSE" "" } */ + p=t; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-6.c 2004-02-17 17:16:27.000000000 +0000 *************** *** 0 **** --- 1,316 ---- + /* { dg-do run { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2" } */ + #include + #include + #include + #include + #include "i386-cpuid.h" + + #ifndef NOINLINE + #define NOINLINE __attribute__ ((noinline)) + #endif + + #define SHIFT (4) + + typedef union { + __m128i v; + unsigned int s[4]; + unsigned short int t[8]; + unsigned long long u[2]; + unsigned char c[16]; + }vecInLong; + + void sse2_tests (void) NOINLINE; + void dump128_16 (char *, char *, vecInLong); + void dump128_32 (char *, char *, vecInLong); + void dump128_64 (char *, char *, vecInLong); + void dump128_128 (char *, char *, vecInLong); + int check (const char *, const char *[]); + + char buf[8000]; + char comparison[8000]; + static int errors = 0; + + vecInLong a128, b128, c128, d128, e128, f128; + __m128i m128_16, m128_32, s128, m128_64, m128_128; + __m64 m64_16, s64, m64_32, m64_64; + + const char *reference_sse2[] = { + "_mm_srai_epi16 0012 0012 0012 0012 0012 0012 0012 0012 \n", + "_mm_sra_epi16 0012 0012 0012 0012 0012 0012 0012 0012 \n", + "_mm_srai_epi32 00123456 00123456 00123456 00123456 \n", + "_mm_sra_epi32 00123456 00123456 00123456 00123456 \n", + "_mm_srli_epi16 0012 0012 0012 0012 0012 0012 0012 0012 \n", + "_mm_srl_epi16 0012 0012 0012 0012 0012 0012 0012 0012 \n", + "_mm_srli_epi32 00123456 00123456 00123456 00123456 \n", + "_mm_srl_epi32 00123456 00123456 00123456 00123456 \n", + "_mm_srli_epi64 00123456789abcde 00123456789abcde \n", + "_mm_srl_epi64 00123456789abcde 00123456789abcde \n", + "_mm_srli_si128 (byte shift) 00000000ffeeddccbbaa998877665544\n", + "_mm_slli_epi16 1230 1230 1230 1230 1230 1230 1230 1230 \n", + "_mm_sll_epi16 1230 1230 1230 1230 1230 1230 1230 1230 \n", + "_mm_slli_epi32 12345670 12345670 12345670 12345670 \n", + "_mm_sll_epi32 12345670 12345670 12345670 12345670 \n", + "_mm_slli_epi64 123456789abcdef0 123456789abcdef0 \n", + "_mm_sll_epi64 123456789abcdef0 123456789abcdef0 \n", + "_mm_sll_si128 (byte shift) bbaa9988776655443322110000000000\n", + "_mm_shuffle_epi32 ffeeddcc bbaa9988 77665544 33221100 \n", + "_mm_shuffelo_epi16 7766 5544 3322 1100 9988 bbaa ddcc ffee \n", + "_mm_shuffehi_epi16 1100 3322 5544 7766 ffee ddcc bbaa 9988 \n", + "" + }; + + int main() + { + unsigned long cpu_facilities; + + cpu_facilities = i386_cpuid (); + + if ((cpu_facilities & (bit_MMX | bit_SSE | bit_SSE2 | bit_CMOV)) + != (bit_MMX | bit_SSE | bit_SSE2 | bit_CMOV)) + /* If host has no vector support, pass. */ + exit (0); + + a128.s[0] = 0x01234567; + a128.s[1] = 0x01234567; + a128.s[2] = 0x01234567; + a128.s[3] = 0x01234567; + + m128_32 = a128.v; + + d128.u[0] = 0x0123456789abcdefULL; + d128.u[1] = 0x0123456789abcdefULL; + + m128_64 = d128.v; + + /* This is the 128-bit constant 0x00112233445566778899aabbccddeeff, + expressed as two little-endian 64-bit words. */ + e128.u[0] = 0x7766554433221100ULL; + e128.u[1] = 0xffeeddccbbaa9988ULL; + + f128.t[0] = 0x0123; + f128.t[1] = 0x0123; + f128.t[2] = 0x0123; + f128.t[3] = 0x0123; + f128.t[4] = 0x0123; + f128.t[5] = 0x0123; + f128.t[6] = 0x0123; + f128.t[7] = 0x0123; + + m128_16 = f128.v; + + m128_128 = e128.v; + + b128.s[0] = SHIFT; + b128.s[1] = 0; + b128.s[2] = 0; + b128.s[3] = 0; + + s128 = b128.v; + + if (cpu_facilities & bit_SSE2) + { + sse2_tests(); + check (buf, reference_sse2); + #ifdef DEBUG + printf ("sse2 testing:\n"); + printf (buf); + printf ("\ncomparison:\n"); + printf (comparison); + #endif + buf[0] = '\0'; + } + + if (errors != 0) + abort (); + exit (0); + } + + void NOINLINE + sse2_tests (void) + { + /* psraw */ + c128.v = _mm_srai_epi16 (m128_16, SHIFT); + dump128_16 (buf, "_mm_srai_epi16", c128); + c128.v = _mm_sra_epi16 (m128_16, s128); + dump128_16 (buf, "_mm_sra_epi16", c128); + + /* psrad */ + c128.v = _mm_srai_epi32 (m128_32, SHIFT); + dump128_32 (buf, "_mm_srai_epi32", c128); + c128.v = _mm_sra_epi32 (m128_32, s128); + dump128_32 (buf, "_mm_sra_epi32", c128); + + /* psrlw */ + c128.v = _mm_srli_epi16 (m128_16, SHIFT); + dump128_16 (buf, "_mm_srli_epi16", c128); + c128.v = _mm_srl_epi16 (m128_16, s128); + dump128_16 (buf, "_mm_srl_epi16", c128); + + /* psrld */ + c128.v = _mm_srli_epi32 (m128_32, SHIFT); + dump128_32 (buf, "_mm_srli_epi32", c128); + c128.v = _mm_srl_epi32 (m128_32, s128); + dump128_32 (buf, "_mm_srl_epi32", c128); + + /* psrlq */ + c128.v = _mm_srli_epi64 (m128_64, SHIFT); + dump128_64 (buf, "_mm_srli_epi64", c128); + c128.v = _mm_srl_epi64 (m128_64, s128); + dump128_64 (buf, "_mm_srl_epi64", c128); + + /* psrldq */ + c128.v = _mm_srli_si128 (m128_128, SHIFT); + dump128_128 (buf, "_mm_srli_si128 (byte shift) ", c128); + + /* psllw */ + c128.v = _mm_slli_epi16 (m128_16, SHIFT); + dump128_16 (buf, "_mm_slli_epi16", c128); + c128.v = _mm_sll_epi16 (m128_16, s128); + dump128_16 (buf, "_mm_sll_epi16", c128); + + /* pslld */ + c128.v = _mm_slli_epi32 (m128_32, SHIFT); + dump128_32 (buf, "_mm_slli_epi32", c128); + c128.v = _mm_sll_epi32 (m128_32, s128); + dump128_32 (buf, "_mm_sll_epi32", c128); + + /* psllq */ + c128.v = _mm_slli_epi64 (m128_64, SHIFT); + dump128_64 (buf, "_mm_slli_epi64", c128); + c128.v = _mm_sll_epi64 (m128_64, s128); + dump128_64 (buf, "_mm_sll_epi64", c128); + + /* pslldq */ + c128.v = _mm_slli_si128 (m128_128, SHIFT); + dump128_128 (buf, "_mm_sll_si128 (byte shift)", c128); + + /* Shuffle constant 0x1b == 0b_00_01_10_11, e.g. swap words: ABCD => DCBA. */ + + /* pshufd */ + c128.v = _mm_shuffle_epi32 (m128_128, 0x1b); + dump128_32 (buf, "_mm_shuffle_epi32", c128); + + /* pshuflw */ + c128.v = _mm_shufflelo_epi16 (m128_128, 0x1b); + dump128_16 (buf, "_mm_shuffelo_epi16", c128); + + /* pshufhw */ + c128.v = _mm_shufflehi_epi16 (m128_128, 0x1b); + dump128_16 (buf, "_mm_shuffehi_epi16", c128); + } + + void + dump128_16 (char *buf, char *name, vecInLong x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<8; i++) + { + sprintf (p, "%4.4x ", x.t[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + void + dump128_32 (char *buf, char *name, vecInLong x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<4; i++) + { + sprintf (p, "%8.8x ", x.s[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + void + dump128_64 (char *buf, char *name, vecInLong x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<2; i++) + { + sprintf (p, "%16.16llx ", x.u[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + void + dump128_128 (char *buf, char *name, vecInLong x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=15; i>=0; i--) + { + /* This is cheating; we don't have a 128-bit int format code. + Running the loop backwards to compensate for the + little-endian layout. */ + sprintf (p, "%2.2x", x.c[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + int + check (const char *input, const char *reference[]) + { + int broken, i, j, len; + const char *p_input; + char *p_comparison; + int new_errors = 0; + + p_comparison = &comparison[0]; + p_input = input; + + for (i = 0; *reference[i] != '\0'; i++) + { + broken = 0; + len = strlen (reference[i]); + for (j = 0; j < len; j++) + { + /* Ignore the terminating NUL characters at the end of every string in 'reference[]'. */ + if (!broken && *p_input != reference[i][j]) + { + *p_comparison = '\0'; + strcat (p_comparison, " >>> "); + p_comparison += strlen (p_comparison); + new_errors++; + broken = 1; + } + *p_comparison = *p_input; + p_comparison++; + p_input++; + } + if (broken) + { + *p_comparison = '\0'; + strcat (p_comparison, "expected:\n"); + strcat (p_comparison, reference[i]); + p_comparison += strlen (p_comparison); + } + } + *p_comparison = '\0'; + strcat (p_comparison, new_errors ? "failure\n\n" : "O.K.\n\n") ; + errors += new_errors; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-7.c 2004-02-17 17:16:27.000000000 +0000 *************** *** 0 **** --- 1,139 ---- + /* { dg-do run { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse" } */ + #include + #include + #include + #include + #include "i386-cpuid.h" + + #ifndef NOINLINE + #define NOINLINE __attribute__ ((noinline)) + #endif + + #define SHIFT (4) + + typedef union { + __m64 v; + unsigned char c[8]; + unsigned short int s[4]; + unsigned long long t; + unsigned int u[2]; + }vecInWord; + + void sse_tests (void) NOINLINE; + void dump64_16 (char *, char *, vecInWord); + int check (const char *, const char *[]); + + char buf[8000]; + char comparison[8000]; + static int errors = 0; + + vecInWord c64, e64; + __m64 m64_64; + + const char *reference_sse[] = { + "_mm_shuffle_pi16 0123 4567 89ab cdef \n", + "" + }; + + int main() + { + unsigned long cpu_facilities; + + cpu_facilities = i386_cpuid (); + + if ((cpu_facilities & (bit_MMX | bit_SSE | bit_CMOV)) + != (bit_MMX | bit_SSE | bit_CMOV)) + /* If host has no vector support, pass. */ + exit (0); + + e64.t = 0x0123456789abcdefULL; + + m64_64 = e64.v; + + if (cpu_facilities & bit_SSE) + { + sse_tests(); + check (buf, reference_sse); + #ifdef DEBUG + printf ("sse testing:\n"); + printf (buf); + printf ("\ncomparison:\n"); + printf (comparison); + #endif + buf[0] = '\0'; + } + + if (errors != 0) + abort (); + exit (0); + } + + void NOINLINE + sse_tests (void) + { + /* pshufw */ + c64.v = _mm_shuffle_pi16 (m64_64, 0x1b); + dump64_16 (buf, "_mm_shuffle_pi16", c64); + } + + void + dump64_16 (char *buf, char *name, vecInWord x) + { + int i; + char *p = buf + strlen (buf); + + sprintf (p, "%s ", name); + p += strlen (p); + + for (i=0; i<4; i++) + { + sprintf (p, "%4.4x ", x.s[i]); + p += strlen (p); + } + strcat (p, "\n"); + } + + int + check (const char *input, const char *reference[]) + { + int broken, i, j, len; + const char *p_input; + char *p_comparison; + int new_errors = 0; + + p_comparison = &comparison[0]; + p_input = input; + + for (i = 0; *reference[i] != '\0'; i++) + { + broken = 0; + len = strlen (reference[i]); + for (j = 0; j < len; j++) + { + /* Ignore the terminating NUL characters at the end of every string in 'reference[]'. */ + if (!broken && *p_input != reference[i][j]) + { + *p_comparison = '\0'; + strcat (p_comparison, " >>> "); + p_comparison += strlen (p_comparison); + new_errors++; + broken = 1; + } + *p_comparison = *p_input; + p_comparison++; + p_input++; + } + if (broken) + { + *p_comparison = '\0'; + strcat (p_comparison, "expected:\n"); + strcat (p_comparison, reference[i]); + p_comparison += strlen (p_comparison); + } + } + *p_comparison = '\0'; + strcat (p_comparison, new_errors ? "failure\n\n" : "O.K.\n\n") ; + errors += new_errors; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-sse-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-sse-8.c 2004-03-06 10:19:01.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR target/14313 */ + /* Origin: */ + + /* { dg-do compile } */ + /* { dg-options "-march=pentium3" { target i?86-*-* x86_64-*-* } } */ + + int main() + { + typedef int v __attribute__ ((mode(V2DI))); + v a, b; + a = b; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssefp-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssefp-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssefp-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssefp-1.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2 -march=k8 -mfpmath=sse" } */ + /* { dg-final { scan-assembler "maxsd" } } */ + /* { dg-final { scan-assembler "minsd" } } */ + double x; + t() + { + x=x>5?x:5; + } + + double x; + q() + { + x=x<5?x:5; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssefp-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssefp-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssefp-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssefp-2.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ + /* { dg-options "-O2 -msse2 -march=k8 -mfpmath=sse" } */ + /* { dg-final { scan-assembler "maxsd" } } */ + /* { dg-final { scan-assembler "minsd" } } */ + double x; + q() + { + x=x<5?5:x; + } + + double x; + q1() + { + x=x>5?5:x; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-1.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-1.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 1,11 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=athlon" } */ ! /* { dg-final { scan-assembler "andpd.*magic" } } */ ! /* { dg-final { scan-assembler "andnpd.*magic" } } */ ! /* { dg-final { scan-assembler "xorpd.*magic" } } */ ! /* { dg-final { scan-assembler "orpd.*magic" } } */ /* { dg-final { scan-assembler-not "movdqa" } } */ ! /* { dg-final { scan-assembler "movapd.*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ --- 1,11 ---- /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=k8" } */ ! /* { dg-final { scan-assembler "andpd\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "andnpd\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "xorpd\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "orpd\[^\\n\]*magic" } } */ /* { dg-final { scan-assembler-not "movdqa" } } */ ! /* { dg-final { scan-assembler "movapd\[^\\n\]*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-2.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-2.c 2003-02-04 20:45:00.000000000 +0000 *************** *** 1,5 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=athlon" } */ /* { dg-final { scan-assembler "andpd" } } */ /* { dg-final { scan-assembler "andnpd" } } */ /* { dg-final { scan-assembler "xorpd" } } */ --- 1,5 ---- /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=k8" } */ /* { dg-final { scan-assembler "andpd" } } */ /* { dg-final { scan-assembler "andnpd" } } */ /* { dg-final { scan-assembler "xorpd" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-3.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-3.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 1,11 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=athlon" } */ ! /* { dg-final { scan-assembler "andps.*magic" } } */ ! /* { dg-final { scan-assembler "andnps.*magic" } } */ ! /* { dg-final { scan-assembler "xorps.*magic" } } */ ! /* { dg-final { scan-assembler "orps.*magic" } } */ /* { dg-final { scan-assembler-not "movdqa" } } */ ! /* { dg-final { scan-assembler "movaps.*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ --- 1,11 ---- /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=k8" } */ ! /* { dg-final { scan-assembler "andps\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "andnps\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "xorps\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "orps\[^\\n\]*magic" } } */ /* { dg-final { scan-assembler-not "movdqa" } } */ ! /* { dg-final { scan-assembler "movaps\[^\\n\]*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-4.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-4.c 2003-02-04 20:43:04.000000000 +0000 *************** *** 1,5 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=athlon" } */ /* { dg-final { scan-assembler "andps" } } */ /* { dg-final { scan-assembler "andnps" } } */ /* { dg-final { scan-assembler "xorps" } } */ --- 1,5 ---- /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=k8" } */ /* { dg-final { scan-assembler "andps" } } */ /* { dg-final { scan-assembler "andnps" } } */ /* { dg-final { scan-assembler "xorps" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-ssetype-5.c 2003-02-16 14:19:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-ssetype-5.c 2003-06-08 14:50:18.000000000 +0000 *************** *** 1,11 **** /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=athlon" } */ ! /* { dg-final { scan-assembler "pand.*magic" } } */ ! /* { dg-final { scan-assembler "pandn.*magic" } } */ ! /* { dg-final { scan-assembler "pxor.*magic" } } */ ! /* { dg-final { scan-assembler "por.*magic" } } */ /* { dg-final { scan-assembler "movdqa" } } */ ! /* { dg-final { scan-assembler-not "movaps.*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ --- 1,11 ---- /* { dg-do compile { target i?86-*-* x86_64-*-* } } */ ! /* { dg-options "-O2 -msse2 -march=k8" } */ ! /* { dg-final { scan-assembler "pand\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "pandn\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "pxor\[^\\n\]*magic" } } */ ! /* { dg-final { scan-assembler "por\[^\\n\]*magic" } } */ /* { dg-final { scan-assembler "movdqa" } } */ ! /* { dg-final { scan-assembler-not "movaps\[^\\n\]*magic" } } */ /* Verify that we generate proper instruction with memory operand. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/i386-unroll-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/i386-unroll-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/i386-unroll-1.c 2002-11-21 22:08:15.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/i386-unroll-1.c 2003-02-23 03:10:03.000000000 +0000 *************** *** 1,6 **** /* PR optimization/8599 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mcpu=k6 -O2 -funroll-loops" } */ extern void exit (int); --- 1,6 ---- /* PR optimization/8599 */ /* { dg-do run { target i?86-*-* } } */ ! /* { dg-options "-mtune=k6 -O2 -funroll-loops" } */ extern void exit (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ia64-types1.c gcc-3.4.0/gcc/testsuite/gcc.dg/ia64-types1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ia64-types1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ia64-types1.c 2003-09-09 03:35:31.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* { dg-do compile { target ia64*-hp-hpux* } } */ + + /* Test that __fpreg is distinct from any other builtin type. */ + + extern float fr1; /* { dg-error "" } */ + extern __fpreg fr1; /* { dg-error "" } */ + extern double fr2; /* { dg-error "" } */ + extern __fpreg fr2; /* { dg-error "" } */ + extern long double fr3; /* { dg-error "" } */ + extern __fpreg fr3; /* { dg-error "" } */ + extern __float80 fr4; /* { dg-error "" } */ + extern __fpreg fr4; /* { dg-error "" } */ + extern __float128 fr5; /* { dg-error "" } */ + extern __fpreg fr5; /* { dg-error "" } */ + + /* Test that __float80 is distinct from any other builtin type. */ + + extern float f801; /* { dg-error "" } */ + extern __float80 f801; /* { dg-error "" } */ + extern double f802; /* { dg-error "" } */ + extern __float80 f802; /* { dg-error "" } */ + extern long double f803; /* { dg-error "" } */ + extern __float80 f803; /* { dg-error "" } */ + extern __fpreg f804; /* { dg-error "" } */ + extern __float80 f804; /* { dg-error "" } */ + extern __float128 f805; /* { dg-error "" } */ + extern __float80 f805; /* { dg-error "" } */ + + /* Test that __float128 is distinct from any other builtin type -- + except "long double", for which it is a synonym. */ + + extern float f1281; /* { dg-error "" } */ + extern __float128 f1281; /* { dg-error "" } */ + extern double f1282; /* { dg-error "" } */ + extern __float128 f1282; /* { dg-error "" } */ + extern long double f1283; + extern __float128 f1283; + extern __fpreg f1284; /* { dg-error "" } */ + extern __float128 f1284; /* { dg-error "" } */ + extern __float80 f1285; /* { dg-error "" } */ + extern __float128 f1285; /* { dg-error "" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ia64-types2.c gcc-3.4.0/gcc/testsuite/gcc.dg/ia64-types2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ia64-types2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ia64-types2.c 2003-09-09 03:35:31.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* { dg-do run { target ia64*-hp-hpux* } } */ + /* { dg-options } */ + + /* Test that the sizes and alignments of the extra floating-point + types are correct. */ + + int main () { + if (sizeof (__fpreg) != 16) + return 1; + if (__alignof__ (__fpreg) != 16) + return 2; + + if (sizeof (__float80) != 16) + return 3; + if (__alignof__ (__float80) != 16) + return 4; + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/inline-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/inline-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/inline-2.c 2002-10-02 08:26:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/inline-2.c 2003-10-20 21:46:55.000000000 +0000 *************** static int foo(void) *** 11,19 **** int bar(void) { ! return foo() + 1; } ! /* { dg-final { scan-assembler "bsr" { target alpha*-*-* } } } */ /* { dg-final { scan-assembler-not "PLT" { target i?86-*-* x86_64-*-* } } } */ /* { dg-final { scan-assembler-not "plt" { target powerpc*-*-* } } } */ --- 11,20 ---- int bar(void) { ! /* Call twice to avoid bypassing the limit for functions called once. */ ! return foo() + foo() + 1; } ! /* { dg-final { scan-assembler-not "jsr" { target alpha*-*-* } } } */ /* { dg-final { scan-assembler-not "PLT" { target i?86-*-* x86_64-*-* } } } */ /* { dg-final { scan-assembler-not "plt" { target powerpc*-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/inline-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/inline-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/inline-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/inline-3.c 2003-03-08 13:26:37.000000000 +0000 *************** *** 0 **** --- 1,47 ---- + /* { dg-options "-O2 -funit-at-a-time" } */ + /* { dg-final { scan-assembler-not "big_function_2" } } */ + static void + big_function_2(void); + void + big_function_1() + { + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + big_function_2(); + } + static void + big_function_2() + { + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + while (t()); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/inline-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/inline-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/inline-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/inline-4.c 2003-03-26 22:53:37.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + /* { dg-final { scan-assembler-not "big_static_inline" } } */ + + extern void f(void); + static inline void big_static_inline(void) + { + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + f(); f(); f(); f(); f(); f(); f(); f(); f(); f(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/inline-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/inline-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/inline-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/inline-5.c 2004-02-29 23:34:54.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* PR middle-end/13448 */ + + /* { dg-options "-O3" } */ + + void funct (const int n) + { + n++; /* { dg-error "" } */ + } + + int main () { + funct (1); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/intermod-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/intermod-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/intermod-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/intermod-1.c 2003-12-10 09:30:07.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* { dg-do compile } */ + /* { dg-final { scan-assembler-not {foo[1-9]\.[0-9]} } } */ + + /* Check that we don't get .0 suffixes on static variables when not using + intermodule analysis. */ + + static int foo1; + static int foo2 = 1; + + static void foo5(void) { } + static void foo6(void); + static void foo6(void) { } + static void foo7(void); + void foo7(void) { } + + void foo9(void) + { + foo1 = 2; + foo2 = 3; + foo5(); + foo6(); + foo7(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/label-compound-stmt-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/label-compound-stmt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/label-compound-stmt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/label-compound-stmt-1.c 2004-01-14 23:03:55.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* Test that labels at ends of compound statements are hard errors. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + void f(void) { g: } /* { dg-bogus "warning" "warning in place of error" } */ + /* { dg-error "label|parse|syntax" "label at end of compound statement" { target *-*-* } 6 } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/local1.c gcc-3.4.0/gcc/testsuite/gcc.dg/local1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/local1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/local1.c 2004-03-18 18:29:37.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + static int i; + + extern int i; + + static void f() { + extern int i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/loop-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/loop-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/loop-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/loop-2.c 2003-03-26 12:48:28.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* PR optimization/10171 */ + /* Bug: unroll_loop misoptimized the function so that we got + 0 iterations of the loop rather than the correct 1. */ + /* { dg-do run } */ + + __inline__ int tag() { return 0; } + + void f (); + + int main() { + int i; + for (i = 0; i < (tag() ? 2 : 1); i++) + f(); + abort (); + } + + void f () + { + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/m68k-slp-ice.c gcc-3.4.0/gcc/testsuite/gcc.dg/m68k-slp-ice.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/m68k-slp-ice.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/m68k-slp-ice.c 2003-03-04 04:30:51.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* From PR 7872, test for optabs segfault when strict low part is present. */ + /* { dg-do compile { target m68k-*-* } } */ + /* { dg-options "-O0" } */ + extern void (**table)(void); + + typedef unsigned short uw16; + typedef unsigned int gshort; + + register uw16 *pc asm("%a4"); + register gshort code asm("%d6"); + + void QMExecuteLoop(uw16 *oldPC) + { + table[code=(*(uw16*)(pc++))](); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/macho-lo-sum.c gcc-3.4.0/gcc/testsuite/gcc.dg/macho-lo-sum.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/macho-lo-sum.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/macho-lo-sum.c 2003-12-19 23:35:40.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* { dg-do compile { target powerpc*-*-darwin* } } */ + /* { dg-options "-O2 -force_cpusubtype_ALL -mpowerpc64 -mdynamic-no-pic" } */ + + long long knight_attacks[64]; + long long InitializeAttackBoards(void); + + int main() + { + return InitializeAttackBoards(); + } + + long long InitializeAttackBoards(void) + { + + int i,j; + + for(i=0;i<64;i++) { } + + for(i=0;i<64;i++) { + knight_attacks[i]=0; + for(j=0;j<8;j++) { + knight_attacks[i]= 0; + } + } + + return knight_attacks[0]; + + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/m-un-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/m-un-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/m-un-2.c 2001-10-25 17:38:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/m-un-2.c 2003-05-03 13:34:43.000000000 +0000 *************** *** 1,7 **** /* { dg-do compile } */ /* { dg-options "-W -Wall" } */ ! typedef unsigned long size_t; extern void* malloc (size_t); extern void free (void*); extern void* realloc (void*, size_t); --- 1,7 ---- /* { dg-do compile } */ /* { dg-options "-W -Wall" } */ ! typedef __SIZE_TYPE__ size_t; extern void* malloc (size_t); extern void free (void*); extern void* realloc (void*, size_t); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/nest.c gcc-3.4.0/gcc/testsuite/gcc.dg/nest.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/nest.c 2003-08-09 06:51:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/nest.c 2004-02-21 03:00:47.000000000 +0000 *************** *** 1,10 **** /* PR 5967, PR 7114 */ /* { dg-do run } */ /* { dg-options "-O2 -pg" } */ ! /* { dg-error "profiler" "No profiler support" { target mmix-*-* } 0 } */ ! /* Support for -pg on irix relies on gcrt1.o which doesn't exist yet. ! See: http://gcc.gnu.org/ml/gcc/2002-10/msg00169.html */ ! /* { dg-error "gcrt1.o" "Profiler support missing" { target mips*-*-irix* } 0 } */ /* { dg-error "-pg not supported" "Profiler support missing" { target *-*-sco3.2v5* } 0 } */ long foo (long x) --- 1,9 ---- /* PR 5967, PR 7114 */ /* { dg-do run } */ + /* { dg-require-profiling "-pg" } */ /* { dg-options "-O2 -pg" } */ ! /* { dg-options "-O2 -pg -static" { target hppa*-*-hpux* } } */ ! /* { dg-error "profiler" "No profiler support" { target xstormy16-*-* } 0 } */ /* { dg-error "-pg not supported" "Profiler support missing" { target *-*-sco3.2v5* } 0 } */ long foo (long x) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/nested-func-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/nested-func-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/nested-func-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/nested-func-1.c 2003-11-18 12:04:04.000000000 +0000 *************** *** 0 **** --- 1,35 ---- + /* Test for proper errors for break and continue in nested functions. */ + /* Origin: Joseph Myers */ + /* { dg-do compile } */ + /* { dg-options "" } */ + + void + foo (int a) + { + switch (a) { + void bar1 (void) { break; } /* { dg-error "break statement" "break switch 1" } */ + } + switch (a) { + case 0: + (void) 0; + void bar2 (void) { break; } /* { dg-error "break statement" "break switch 2" } */ + } + while (1) { + void bar3 (void) { break; } /* { dg-error "break statement" "break while" } */ + } + do { + void bar4 (void) { break; } /* { dg-error "break statement" "break do" } */ + } while (1); + for (;;) { + void bar5 (void) { break; } /* { dg-error "break statement" "break for" } */ + } + while (1) { + void bar6 (void) { continue; } /* { dg-error "continue statement" "continue while" } */ + } + do { + void bar7 (void) { continue; } /* { dg-error "continue statement" "continue do" } */ + } while (1); + for (;;) { + void bar8 (void) { continue; } /* { dg-error "continue statement" "continue for" } */ + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/no-builtin-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/no-builtin-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/no-builtin-1.c 2001-11-18 03:30:57.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/no-builtin-1.c 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,43 **** - /* Test for -fno-builtin-FUNCTION. */ - /* Origin: Joseph Myers . */ - /* { dg-do run } */ - /* { dg-options "-fno-builtin-abs" } */ - - /* GCC normally handles abs and labs as built-in functions even without - optimization. So test that with -fno-builtin-abs, labs is so handled - but abs isn't. */ - - int abs_called = 0; - - extern int abs (int); - extern long labs (long); - extern void abort (void); - extern void exit (int); - - int - main (void) - { - if (labs (0) != 0) - abort (); - if (abs (0) != 0) - abort (); - if (!abs_called) - abort (); - exit (0); - } - - /* The labs call above should have been optimized, but the abs call - shouldn't have been. */ - - static int - abs (int x) - { /* { dg-warning "static" "static decl warning" } */ - abs_called = 1; - return (x < 0 ? -1 : x); - } - - static long - labs (long x) - { - abort (); - } --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/20020220-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/20020220-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/20020220-1.c 2002-02-20 22:59:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/20020220-1.c 2004-01-11 01:18:58.000000000 +0000 *************** int foo (const char*, const char*); *** 6,12 **** void bar (void) { const char *s = "bar"; ! int i; /* { dg-error "previously declared here" } */ int size = 2; int i = foo (s, s + size); /* { dg-error "redeclaration of" } */ } --- 6,12 ---- void bar (void) { const char *s = "bar"; ! int i; /* { dg-error "previous declaration" } */ int size = 2; int i = foo (s, s + size); /* { dg-error "redeclaration of" } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/incomplete-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/incomplete-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/incomplete-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/incomplete-2.c 2003-07-24 08:58:42.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Origin: + Make sure we do not ICE when the type in the function + argument list is incomplete (Bug 10602). */ + /* { dg-options "-w" } */ + + int g95_type_for_mode (enum machine_mode); + + int + g95_type_for_mode (enum machine_mode mode) + { /* { dg-error "has incomplete type" } */ + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/init-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/init-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/init-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/init-4.c 2003-04-07 11:55:27.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + struct a { char *b; } c[D] /* { dg-error "undeclared" } */ + = /* { dg-error "storage size" } */ + { { "" } } ; /* { dg-warning "braces around scalar initializer|near" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/label-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/label-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/label-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/label-1.c 2003-07-19 23:32:55.000000000 +0000 *************** *** 0 **** --- 1,175 ---- + /* Test various diagnostics of ill-formed constructs involving labels. */ + /* { dg-do compile } */ + /* { dg-options "-Wunused" } */ + + extern void dummy(void); + + /* labels must be defined */ + void a(void) + { + goto l; /* { dg-error "used but not defined" "no label" } */ + } + + /* warnings for labels defined but not used, or declared but not defined */ + void b(void) + { + __label__ l; + l: /* { dg-warning "defined but not used" "no goto 1" } */ + m: /* { dg-warning "defined but not used" "no goto 2" } */ + dummy(); + } + + void c(void) + { + __label__ l; /* { dg-warning "declared but not defined" "only __label__" } */ + dummy(); + } + + /* can't have two labels with the same name in the same function */ + void d(void) + { + l: dummy(); /* { dg-error "previously defined" "prev def same scope" } */ + l: dummy(); /* { dg-error "duplicate label" "dup label same scope" } */ + goto l; + } + + /* even at different scopes */ + void e(void) + { + l: dummy(); /* { dg-error "previously defined" "prev def diff scope" } */ + { + l: dummy(); /* { dg-error "duplicate label" "dup label diff scope" } */ + } + goto l; + } + + /* but, with __label__, you can */ + void f(void) + { + l: dummy(); + { + __label__ l; + l: dummy(); /* { dg-warning "defined but not used" "unused shadow 1" } */ + }; + goto l; /* this reaches the outer l */ + } + + /* a __label__ is not visible outside its scope */ + void g(void) + { + dummy(); + { + __label__ l; + l: dummy(); + goto l; + } + goto l; /* { dg-error "used but not defined" "label ref out of scope" } */ + } + + /* __label__ can appear at top level of a function, too... + ... but doesn't provide a definition of the label */ + void h(void) + { + __label__ l; + dummy (); + + goto l; /* { dg-error "used but not defined" "used, only __label__" } */ + } + + /* A nested function may not goto a label outside itself */ + void i(void) + { + auto void nest(void); + + l: nest(); + + void nest(void) + { + goto l; /* { dg-error "used but not defined" "nest use outer label" } */ + } + + goto l; /* reaches the outer l */ + } + + /* which means that a nested function may have its own label with the + same name as the outer function */ + void j(void) + { + auto void nest(void); + + l: nest(); + + void nest(void) + { + l: dummy(); /* { dg-warning "defined but not used" "nest label same name" } */ + } + + goto l; /* reaches the outer l */ + } + + /* and, turnabout, an outer function may not goto a label in a nested + function */ + void k(void) + { + void nest(void) + { + l: dummy(); /* { dg-warning "defined but not used" "outer use nest label" } */ + } + + goto l; /* { dg-error "used but not defined" "outer use nest label" } */ + nest(); + } + + /* not even with __label__ */ + void l(void) + { + void nest(void) + { + __label__ l; + l: dummy(); /* { dg-warning "defined but not used" "outer use nest __label__" } */ + } + + goto l; /* { dg-error "used but not defined" "outer use nest __label__" } */ + nest(); + } + + + /* but if the outer label is declared with __label__, then a nested + function can goto that label (accomplishing a longjmp) */ + void m(void) + { + __label__ l; + void nest(void) { goto l; } + nest(); + dummy(); + l:; + } + + /* and that means the nested function cannot have its own label with + the same name as an outer label declared with __label__ */ + + void n(void) + { + __label__ l; /* { dg-error "previously declared" "outer label decl" } */ + void nest(void) + { + l: goto l; /* { dg-error "duplicate label" "inner label defn" } */ + } + + l: + nest(); + } + + /* unless the nested function uses __label__ too! */ + void o(void) + { + __label__ l; + void nest(void) + { + __label__ l; + l: goto l; + } + + l: goto l; + nest(); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/label-lineno-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/label-lineno-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/label-lineno-1.c 2002-02-07 09:08:24.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/label-lineno-1.c 2003-07-19 23:32:55.000000000 +0000 *************** *** 4,10 **** void foo(int i) { ! my_label: i++; --- 4,10 ---- void foo(int i) { ! my_label: /* { dg-error "previously defined" "prev label" } */ i++; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/scope.c gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/scope.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noncompile/scope.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noncompile/scope.c 2003-04-15 01:37:03.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + static int v = 3; + + f () + { + int v = 4; + { + extern int v; /* { dg-error "static" } */ + if (v != 3) + abort (); + } + } + + main () + { + f (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/nonnull-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/nonnull-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/nonnull-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/nonnull-3.c 2003-05-04 22:18:17.000000000 +0000 *************** *** 0 **** --- 1,75 ---- + /* Test for the "nonnull" function attribute on builtins. Use the + "__builtin_" style below so we don't need prototypes. */ + /* Origin: Kaveh R. Ghazi */ + /* { dg-do compile } */ + /* { dg-options "-Wnonnull" } */ + + #include + + void + foo (void *p, char *s) + { + __builtin_bzero (NULL, 0); + __builtin_bcopy (NULL, p, 0); + __builtin_bcopy (p, NULL, 0); + __builtin_bcmp (NULL, p, 0); + __builtin_bcmp (p, NULL, 0); + __builtin_index (NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_rindex (NULL, 16); /* { dg-warning "null" "null pointer check" } */ + + __builtin_memcpy (p, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memcpy (NULL, p, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memmove (p, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memmove (NULL, p, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memcmp (p, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memcmp (NULL, p, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_memset (NULL, 0, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_mempcpy (p, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_mempcpy (NULL, p, 16); /* { dg-warning "null" "null pointer check" } */ + + __builtin_strcat (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strcat (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncat (NULL, s, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncat (s, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_stpcpy (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_stpcpy (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strcpy (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strcpy (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncpy (NULL, s, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncpy (s, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strcmp (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strcmp (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncmp (NULL, s, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strncmp (s, NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strlen (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strstr (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strstr (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strpbrk (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strpbrk (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strspn (NULL, s); /* { dg-warning "null" "null pointer check" } */ + __builtin_strspn (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_strchr (NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strrchr (NULL, 16); /* { dg-warning "null" "null pointer check" } */ + __builtin_strdup (NULL); /* { dg-warning "null" "null pointer check" } */ + + __builtin_nan (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_nanf (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_nanl (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_nans (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_nansf (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_nansl (NULL); /* { dg-warning "null" "null pointer check" } */ + + __builtin_puts (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputc (*s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputs (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputs (NULL, p); /* { dg-warning "null" "null pointer check" } */ + __builtin_fwrite (s, 16, 16, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fwrite (NULL, 16, 16, p); /* { dg-warning "null" "null pointer check" } */ + __builtin_puts_unlocked (NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputc_unlocked (*s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputs_unlocked (s, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fputs_unlocked (NULL, p); /* { dg-warning "null" "null pointer check" } */ + __builtin_fwrite_unlocked (s, 16, 16, NULL); /* { dg-warning "null" "null pointer check" } */ + __builtin_fwrite_unlocked (NULL, 16, 16, p); /* { dg-warning "null" "null pointer check" } */ + + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noreturn-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/noreturn-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noreturn-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noreturn-5.c 2003-04-30 01:28:39.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* { dg-do compile } */ + /* { dg-options "-std=gnu99" } */ + /* Check that 'noreturn' and 'volatile extern' are compatible. + The testsuite uses -ansi -pedantic-errors by default, so this has + to override. */ + extern void xxx (int) __attribute__((noreturn)); + __volatile extern void xxx (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/noreturn-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/noreturn-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/noreturn-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/noreturn-6.c 2003-04-30 01:28:39.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* { dg-do compile } */ + /* Check for volatile behaviour. */ + extern int xxx (void); + volatile extern int xxx (void); /* { dg-error "not compatible" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/old-style-asm-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/old-style-asm-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/old-style-asm-1.c 2003-03-13 03:29:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/old-style-asm-1.c 2003-10-23 20:48:53.000000000 +0000 *************** *** 1,6 **** /* PR inline-asm/8832 */ /* { dg-do compile } */ ! /* { dg-options "-O2" } */ /* Verify that GCC doesn't optimize old style asm instructions. */ --- 1,6 ---- /* PR inline-asm/8832 */ /* { dg-do compile } */ ! /* { dg-options "-O2 -dP" } */ /* Verify that GCC doesn't optimize old style asm instructions. */ *************** void foo(int v) *** 18,27 **** /* The purpose of the test below is to check that there are two branches in the generated code, supposedly corresponding to the if-statements. ! Warning: this is fragile and assumes that one of the generated labels ! for the branches matches the string "L2", or as with ! mmix-knuth-mmixware, "L:2". That assumption is generally invalid, ! because for example it depends on the target macro ! ASM_GENERATE_INTERNAL_LABEL to generate a name matching this regexp (as ! with the default definition). */ ! /* { dg-final { scan-assembler "L(:|\\\$0*)?2" } } */ --- 18,23 ---- /* The purpose of the test below is to check that there are two branches in the generated code, supposedly corresponding to the if-statements. ! It tries to check for jump_insn (set (pc) pattern, so that jump_insns ! corresponding to return are not taken into account. */ ! /* { dg-final { scan-assembler "jump_insn.*set \\(pc\\).*jump_insn.*set \\(pc\\)"} } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-3.c 2003-07-22 09:26:01.000000000 +0000 *************** *** 0 **** --- 1,44 ---- + /* { dg-do compile } */ + + /* Copyright (C) 2003 Free Software Foundation, Inc. + Contributed by Nathan Sidwell 15 Jul 2003 */ + + /* you should not be able to pack a typedef to a struct, only the + underlying struct can be packed. */ + + /* ok */ + struct u1 + { + char field1; + short field2; + int field3; + }; + + /* ok */ + typedef struct p1 { + char field1; + short field2; + int field3; + } __attribute__ ((packed)) p1_t1; + + /* ok */ + typedef struct __attribute__ ((packed)) p2 { + char field1; + short field2; + int field3; + } p2_t1; + + int ary1[sizeof (struct p1) == sizeof (p1_t1) ? 1 : -1]; + int ary2[sizeof (struct p2) == sizeof (p2_t1) ? 1 : -1]; + int ary3[sizeof (struct p1) == sizeof (struct p2) ? 1 : -1]; + + /* not ok */ + typedef struct u1 __attribute__ ((packed)) u1_t1; /* { dg-warning "attribute ignored" "" }*/ + typedef struct u1 u1_t2 __attribute__ ((packed)); /* { dg-warning "attribute ignored" "" }*/ + + typedef struct p3 { + char field1; + short field2; + int field3; + } p3_t1 __attribute__ ((packed)); /* { dg-warning "attribute ignored" "" }*/ + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-4.c 2003-10-15 02:37:10.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + /* PR c/11885 + Bug: flag4 was allocated into the same byte as the other flags. + { dg-options "" } + { dg-do run } */ + + typedef unsigned char uint8_t; + + typedef struct { + uint8_t flag1:2; + uint8_t flag2:1; + uint8_t flag3:1; + + uint8_t flag4; + + } __attribute__ ((packed)) MyType; + + int main (void) + { + MyType a; + MyType *b = &a; + + b->flag1 = 0; + b->flag2 = 0; + b->flag3 = 0; + + b->flag4 = 0; + + b->flag4++; + + if (b->flag1 != 0) + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pack-test-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pack-test-5.c 2003-10-20 22:01:58.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* PR c/11446: packed on a struct takes precedence over aligned on the type + of a field. */ + /* { dg-do run } */ + + struct A { + double d; + } __attribute__ ((aligned)); + + struct B { + char c; + struct A a; + } __attribute__ ((packed)); + + int main () + { + if (sizeof (struct B) != sizeof (char) + sizeof (struct A)) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/common-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/common-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/common-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/common-1.c 2003-01-17 02:48:08.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + #include "common-1.h" + int foo2 = 3; + int zz = 2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/common-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/common-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/common-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/common-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + static int foo1 = 9; + int foo2; + extern int zz; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + #include "cpp-1.h" + #if !defined(__GNUC__) + panic! panic! + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1 ---- + /* Empty. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-2.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* { dg-options "-Wunknown-pragmas -I." } */ + #include "cpp-2.h" + #pragma GCC poison not_used + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-2.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-2.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/cpp-2.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/cpp-2.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1 ---- + /* Empty. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "decl-1.h" + int main(void) { return foo; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1 ---- + extern int foo; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-2.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "decl-2.h" + int main(void) { return fun (1, 2); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-2.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-2.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-2.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-2.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + extern int fun (int a, int b); + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-3.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + #include "decl-3.h" + + foo_p bar (void) + { + return foop; + } + + struct foo *bar2 (void) + { + return foop; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-3.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-3.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-3.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-3.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,3 ---- + struct foo; + typedef struct foo *foo_p; + extern foo_p foop; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-4.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + #include "decl-4.h" + + int bar (foo_p f) + { + if (f->a + foop->a) + return f->c->b + foop->b; + else + return foop->c->b + f->a; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-4.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-4.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-4.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-4.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + typedef struct foo { + int a; + char b; + struct foo *c; + } foo_s; + typedef struct foo *foo_p; + extern foo_p foop; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-5.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "decl-5.h" + static int (*t)(void) = foo; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-5.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-5.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/decl-5.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/decl-5.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1 ---- + extern int foo(void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/empty.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/empty.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/empty.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/empty.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* Yes, it's called "empty" because it has no contents at all. + Even this comment goes here, rather than in empty.h. */ + #include "empty.h" + + int main(void) + { + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/except-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/except-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/except-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/except-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* { dg-options "-fexceptions -I." } */ + #include "except-1.h" + + int main(void) + { + return foo(1); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/except-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/except-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/except-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/except-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* { dg-options "-fexceptions" } */ + extern inline int + foo(int a) + { + return a + 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/global-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/global-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/global-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/global-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include "global-1.h" + const int bar = 3; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/global-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/global-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/global-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/global-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1 ---- + const int foo = 2; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + #include "inline-1.h" + int bar(int a, int b) + { + return foo(a) + b; + } + + int baz(void) + { + return foo(3); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + extern inline int + foo(int a) + { + return a * 2 + 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-2.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + #include "inline-2.h" + extern inline char + bar(int a) + { + return foo(a)[0]; + } + + extern inline char + baz(void) + { + return foo(0)[0]; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-2.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-2.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-2.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-2.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + extern inline const char * + foo(int a) + { + return "abcdefgh"+a; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-3.c 2003-07-15 05:21:37.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + #include "inline-3.h" + unsigned bar(double d) + { + foo (d); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-3.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-3.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-3.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-3.hs 2003-07-15 05:21:37.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + extern double rint(double); + extern double fmod (double, double); + static inline unsigned foo(double d) { + double a; + a = rint(d); + return (unsigned)(fmod(a, (double)0xFFFFFFFF) + ((d - a) * 0xFFFFFFFF)); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-4.c 2003-07-15 05:21:37.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + #include "inline-4.h" + int main(void) { + printf (getstring()); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-4.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-4.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/inline-4.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/inline-4.hs 2003-07-15 05:21:37.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + static inline char *getstring(void) + { + return "hello"; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + #include "macro-1.h" + + int main(void) + { + return DEFINED_VALUE + 1 - DEFINED_PARAM (3); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define DEFINED_VALUE 3 + #define DEFINED_PARAM(x) (x+1) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-2.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + #define DEFINED_VALUE_2 3 + + #include "macro-2.h" + + int main(void) + { + return DEFINED_VALUE - DEFINED_VALUE_2; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-2.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-2.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-2.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-2.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define DEFINED_VALUE 3 + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-3.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + #define DEFINED_FUNC_2(x) (3 + (x)) + + #include "macro-3.h" + + int main(void) + { + return DEFINED_FUNC (1) - DEFINED_FUNC_2 (-1); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-3.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-3.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/macro-3.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/macro-3.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #define DEFINED_FUNC(x) 3 - (x) + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/pch.exp gcc-3.4.0/gcc/testsuite/gcc.dg/pch/pch.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/pch.exp 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/pch.exp 2003-06-04 15:32:08.000000000 +0000 *************** *** 0 **** --- 1,43 ---- + # 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 precompiled header interaction, + # that uses the `dg.exp' driver. + + # Load support procs. + load_lib gcc-dg.exp + load_lib dg-pch.exp + + # Initialize `dg'. + dg-init + + set old_dg_do_what_default "${dg-do-what-default}" + + # Main loop. + foreach test [lsort [glob -nocomplain $srcdir/$subdir/*.c]] { + global torture_without_loops + + # We don't try to use the loop-optimizing options, since they are highly + # unlikely to make any difference to PCH. However, we do want to + # add -O0 -g, since users who want PCH usually want debugging and quick + # compiles. + dg-pch $subdir $test [concat [list {-O0 -g}] $torture_without_loops] ".h" + } + + set dg-do-what-default "$old_dg_do_what_default" + + # All done. + dg-finish diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + #include "static-1.h" + static int bar(void) + { + static int counter; + return counter++; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + static int foo(void) + { + static int counter; + return counter++; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-2.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + #include "static-2.h" + int bar(void) + { + static int counter; + return counter++; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-2.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-2.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-2.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-2.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + static int foo(void) + { + static int counter; + return counter++; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-3.c 2003-04-05 07:01:51.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + #include "static-3.h" + int bar(int *a) + { + int i, tot; + for (i = tot = 0; i < 100; i++) + tot += a[i]; + return tot; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-3.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-3.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/static-3.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/static-3.hs 2003-04-05 07:01:51.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + static int foo(int *a) + { + int i, tot; + for (i = tot = 0; i < 100; i++) + tot += a[i]; + return tot; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/system-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/system-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/system-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/system-1.c 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + #include "system-1.h" + int main(void) + { + puts ("hello world!"); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/system-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/system-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/system-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/system-1.hs 2003-01-17 02:48:09.000000000 +0000 *************** *** 0 **** --- 1,2 ---- + #include + #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/warn-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pch/warn-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/warn-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/warn-1.c 2003-11-08 02:17:51.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* { dg-options "-I. -Winvalid-pch" } */ + + #define DEFINED_VALUE 3 + + #include "warn-1.h"/* { dg-error "not used because `DEFINED_VALUE' is defined|No such file|they were invalid" } */ + + int main(void) + { + return DEFINED_VALUE; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pch/warn-1.hs gcc-3.4.0/gcc/testsuite/gcc.dg/pch/warn-1.hs *** gcc-3.3.3/gcc/testsuite/gcc.dg/pch/warn-1.hs 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pch/warn-1.hs 2003-08-20 04:04:47.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + enum { + DEFINED_VALUE + }; + + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/postincr-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/postincr-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/postincr-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/postincr-1.c 2002-12-18 20:00:28.000000000 +0000 *************** *** 0 **** --- 1,19 ---- + /* Simple test for proper postincrement semantics. */ + /* { dg-do run } */ + + int i; + int c; + int *f () + { + ++c; + return &i; + } + + int main () + { + int r; + r = (*f())++; + if (!(r == 0 && i == 1 && c == 1)) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-1.c 2004-01-14 09:23:06.000000000 +0000 *************** *** 0 **** --- 1,363 ---- + /* { dg-do run { target powerpc64-*-* } } */ + /* { dg-options "-O2" } */ + #include + #include + #include + + /* Testcase to check for ABI compliance of parameter passing + for the PowerPC64 ABI. + Parameter passing of integral and floating point is tested. */ + + extern void abort (void); + + typedef struct + { + unsigned long gprs[8]; + double fprs[13]; + } reg_parms_t; + + reg_parms_t gparms; + + + /* Testcase could break on future gcc's, if parameter regs + are changed before this asm. */ + + #ifndef __MACH__ + #define save_parms(lparms) \ + asm volatile ("ld 11,gparms@got(2)\n\t" \ + "std 3,0(11)\n\t" \ + "std 4,8(11)\n\t" \ + "std 5,16(11)\n\t" \ + "std 6,24(11)\n\t" \ + "std 7,32(11)\n\t" \ + "std 8,40(11)\n\t" \ + "std 9,48(11)\n\t" \ + "std 10,56(11)\n\t" \ + "stfd 1,64(11)\n\t" \ + "stfd 2,72(11)\n\t" \ + "stfd 3,80(11)\n\t" \ + "stfd 4,88(11)\n\t" \ + "stfd 5,96(11)\n\t" \ + "stfd 6,104(11)\n\t" \ + "stfd 7,112(11)\n\t" \ + "stfd 8,120(11)\n\t" \ + "stfd 9,128(11)\n\t" \ + "stfd 10,136(11)\n\t" \ + "stfd 11,144(11)\n\t" \ + "stfd 12,152(11)\n\t" \ + "stfd 13,160(11)\n\t":::"11", "memory"); \ + lparms = gparms; + #else + #define save_parms(lparms) \ + asm volatile ("ld r11,gparms@got(r2)\n\t" \ + "std r3,0(r11)\n\t" \ + "std r4,8(r11)\n\t" \ + "std r5,16(r11)\n\t" \ + "std r6,24(r11)\n\t" \ + "std r7,32(r11)\n\t" \ + "std r8,40(r11)\n\t" \ + "std r9,48(r11)\n\t" \ + "std r10,56(r11)\n\t" \ + "stfd f1,64(r11)\n\t" \ + "stfd f2,72(r11)\n\t" \ + "stfd f3,80(r11)\n\t" \ + "stfd f4,88(r11)\n\t" \ + "stfd f5,96(r11)\n\t" \ + "stfd f6,104(r11)\n\t" \ + "stfd f7,112(r11)\n\t" \ + "stfd f8,120(r11)\n\t" \ + "stfd f9,128(r11)\n\t" \ + "stfd f10,136(r11)\n\t" \ + "stfd f11,144(r11)\n\t" \ + "stfd f12,152(r11)\n\t" \ + "stfd f13,160(r11)\n\t":::"r11", "memory"); \ + lparms = gparms; + #endif + + /* Stackframe structure relevant for parameter passing. */ + typedef union + { + double d; + unsigned long l; + unsigned int i[2]; + } parm_t; + + typedef struct sf + { + struct sf *backchain; + long a1; + long a2; + long a3; + long a4; + long a5; + parm_t slot[100]; + } stack_frame_t; + + + /* Paramter passing. + s : gpr 3 + l : gpr 4 + d : fpr 1 + */ + void __attribute__ ((noinline)) fcld (char *s, long l, double d) + { + reg_parms_t lparms; + save_parms (lparms); + + if (s != (char *) lparms.gprs[0]) + abort (); + + if (l != lparms.gprs[1]) + abort (); + + if (d != lparms.fprs[0]) + abort (); + } + + /* Paramter passing. + s : gpr 3 + l : gpr 4 + d : fpr 2 + i : gpr 5 + */ + void __attribute__ ((noinline)) + fcldi (char *s, long l, double d, signed int i) + { + reg_parms_t lparms; + save_parms (lparms); + + if (s != (char *) lparms.gprs[0]) + abort (); + + if (l != lparms.gprs[1]) + abort (); + + if (d != lparms.fprs[0]) + abort (); + + if ((signed long) i != lparms.gprs[3]) + abort (); + } + + /* Paramter passing. + s : gpr 3 + l : gpr 4 + d : fpr 2 + i : gpr 5 + */ + void __attribute__ ((noinline)) + fcldu (char *s, long l, float d, unsigned int i) + { + reg_parms_t lparms; + save_parms (lparms); + + if (s != (char *) lparms.gprs[0]) + abort (); + + if (l != lparms.gprs[1]) + abort (); + + if ((double) d != lparms.fprs[0]) + abort (); + + if ((unsigned long) i != lparms.gprs[3]) + abort (); + } + + /* Paramter passing. + s : gpr 3 + l : slot 1 + d : slot 2 + */ + + void __attribute__ ((noinline)) fceld (char *s, ...) + { + stack_frame_t *sp; + reg_parms_t lparms; + va_list arg; + double d; + long l; + save_parms (lparms); + + va_start (arg, s); + + if (s != (char *) lparms.gprs[0]) + abort (); + + l = va_arg (arg, long); + d = va_arg (arg, double); + + /* Go back one frame. */ + sp = __builtin_frame_address (0); + sp = sp->backchain; + + if (sp->slot[1].l != l) + abort (); + + if (sp->slot[2].d != d) + abort (); + } + + /* Paramter passing. + s : gpr 3 + i : gpr 4 + j : gpr 5 + d : slot 3 + l : slot 4 + */ + void __attribute__ ((noinline)) fciiedl (char *s, int i, int j, ...) + { + stack_frame_t *sp; + reg_parms_t lparms; + va_list arg; + double d; + long l; + save_parms (lparms); + + va_start (arg, j); + + if (s != (char *) lparms.gprs[0]) + abort (); + + if ((long) i != lparms.gprs[1]) + abort (); + + if ((long) j != lparms.gprs[2]) + abort (); + + d = va_arg (arg, double); + l = va_arg (arg, long); + + sp = __builtin_frame_address (0); + sp = sp->backchain; + + if (sp->slot[3].d != d) + abort (); + + if (sp->slot[4].l != l) + abort (); + } + + /* + Parameter Register Offset in parameter save area + c r3 0-7 (not stored in parameter save area) + ff f1 8-15 (not stored) + d r5 16-23 (not stored) + ld f2 24-31 (not stored) + f r7 32-39 (not stored) + s r8,r9 40-55 (not stored) + gg f3 56-63 (not stored) + t (none) 64-79 (stored in parameter save area) + e (none) 80-87 (stored) + hh f4 88-95 (stored) + + */ + + typedef struct + { + int a; + double dd; + } sparm; + + typedef union + { + int i[2]; + long l; + double d; + } double_t; + + /* Example from ABI documentation with slight changes. + Paramter passing. + c : gpr 3 + ff : fpr 1 + d : gpr 5 + ld : fpr 2 + f : gpr 7 + s : gpr 8 - 9 + gg : fpr 3 + t : save area offset 64 - 79 + e : save area offset 80 - 88 + hh : fpr 4 + */ + + void __attribute__ ((noinline)) + fididisdsid (int c, double ff, int d, double ld, int f, + sparm s, double gg, sparm t, int e, double hh) + { + stack_frame_t *sp; + reg_parms_t lparms; + double_t dx, dy; + + save_parms (lparms); + + /* Parm 0: int. */ + if ((long) c != lparms.gprs[0]) + abort (); + + /* Parm 1: double. */ + if (ff != lparms.fprs[0]) + abort (); + + /* Parm 2: int. */ + if ((long) d != lparms.gprs[2]) + abort (); + + /* Parm 3: double. */ + if (ld != lparms.fprs[1]) + abort (); + + /* Parm 4: int. */ + if ((long) f != lparms.gprs[4]) + abort (); + + /* Parm 5: struct sparm. */ + dx.l = lparms.gprs[5]; + dy.l = lparms.gprs[6]; + + if (s.a != dx.i[0]) + abort (); + if (s.dd != dy.d) + abort (); + + /* Parm 6: double. */ + if (gg != lparms.fprs[2]) + abort (); + + sp = __builtin_frame_address (0); + sp = sp->backchain; + + /* Parm 7: struct sparm. */ + dx.l = sp->slot[8].l; + dy.l = sp->slot[9].l; + if (t.a != dx.i[0]) + abort (); + if (t.dd != dy.d) + abort (); + + /* Parm 8: int. */ + if (e != sp->slot[10].l) + abort (); + + /* Parm 9: double. */ + + if (hh != lparms.fprs[3]) + abort (); + } + + int + main () + { + char *s = "ii"; + + fcld (s, 1, 1.0); + fcldi (s, 1, 1.0, -2); + fcldu (s, 1, 1.0, 2); + fceld (s, 1, 1.0); + fciiedl (s, 1, 2, 1.0, 3); + fididisdsid (1, 1.0, 2, 2.0, -1, (sparm) + { + 3, 3.0}, 4.0, (sparm) + { + 5, 5.0}, 6, 7.0); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-2.c 2004-01-22 12:54:46.000000000 +0000 *************** *** 0 **** --- 1,405 ---- + /* { dg-do run { target powerpc64-*-linux* } } */ + /* { dg-options "-O2 -fprofile -mprofile-kernel -maltivec -mabi=altivec" } */ + #include + #include + #include + + /* Testcase to check for ABI compliance of parameter passing + for the PowerPC64 ABI. */ + + void __attribute__((no_instrument_function)) + sig_ill_handler (int sig) + { + exit(0); + } + + extern void abort (void); + + typedef struct + { + unsigned long gprs[8]; + double fprs[13]; + long pad; + vector int vrs[12]; + } reg_parms_t; + + reg_parms_t gparms; + + /* _mcount call is done on Linux ppc64 early in the prologue. + my_mcount will provide a entry point _mcount, + which will save all register to gparms. + Note that _mcount need to restore lr to original value, + therefor use ctr to return. + */ + + void __attribute__((no_instrument_function)) + my_mcount() + { + asm volatile (".type _mcount,@function\n\t" + ".globl _mcount\n\t" + "_mcount:\n\t" + "mflr 0\n\t" + "mtctr 0\n\t" + "ld 0,16(1)\n\t" + "mtlr 0\n\t" + "ld 11,gparms@got(2)\n\t" + "std 3,0(11)\n\t" + "std 4,8(11)\n\t" + "std 5,16(11)\n\t" + "std 6,24(11)\n\t" + "std 7,32(11)\n\t" + "std 8,40(11)\n\t" + "std 9,48(11)\n\t" + "std 10,56(11)\n\t" + "stfd 1,64(11)\n\t" + "stfd 2,72(11)\n\t" + "stfd 3,80(11)\n\t" + "stfd 4,88(11)\n\t" + "stfd 5,96(11)\n\t" + "stfd 6,104(11)\n\t" + "stfd 7,112(11)\n\t" + "stfd 8,120(11)\n\t" + "stfd 9,128(11)\n\t" + "stfd 10,136(11)\n\t" + "stfd 11,144(11)\n\t" + "stfd 12,152(11)\n\t" + "stfd 13,160(11)\n\t" + "li 3,176\n\t" + "stvx 2,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 3,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 4,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 5,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 6,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 7,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 8,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 9,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 10,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 11,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 12,3,11\n\t" + "addi 3,3,16\n\t" + "stvx 13,3,11\n\t" + "ld 3,0(11)\n\t" + "bctr"); + } + + /* Stackframe structure relevant for parameter passing. */ + typedef union + { + double d; + unsigned long l; + unsigned int i[2]; + } parm_t; + + typedef struct sf + { + struct sf *backchain; + long a1; + long a2; + long a3; + long a4; + long a5; + parm_t slot[100]; + } stack_frame_t; + + typedef union + { + unsigned int i[4]; + unsigned long l[2]; + vector int v; + } vector_int_t; + + /* Paramter passing. + s : gpr 3 + v : vpr 2 + i : gpr 7 + */ + void __attribute__ ((noinline)) + fcvi (char *s, vector int v, int i) + { + reg_parms_t lparms = gparms; + + if (s != (char *) lparms.gprs[0]) + abort(); + + if (!vec_all_eq (v, lparms.vrs[0])) + abort (); + + if ((long) i != lparms.gprs[4]) + abort(); + } + /* Paramter passing. + s : gpr 3 + v : vpr 2 + w : vpr 3 + */ + + void __attribute__ ((noinline)) + fcvv (char *s, vector int v, vector int w) + { + vector int a, c = {6, 8, 10, 12}; + reg_parms_t lparms = gparms; + + if (s != (char *) lparms.gprs[0]) + abort(); + + if (!vec_all_eq (v, lparms.vrs[0])) + abort (); + + if (!vec_all_eq (w, lparms.vrs[1])) + abort (); + + a = vec_add (v,w); + + if (!vec_all_eq (a, c)) + abort (); + } + + /* Paramter passing. + s : gpr 3 + i : gpr 4 + v : vpr 2 + w : vpr 3 + */ + void __attribute__ ((noinline)) + fcivv (char *s, int i, vector int v, vector int w) + { + vector int a, c = {6, 8, 10, 12}; + reg_parms_t lparms = gparms; + + if (s != (char *) lparms.gprs[0]) + abort(); + + if ((long) i != lparms.gprs[1]) + abort(); + + if (!vec_all_eq (v, lparms.vrs[0])) + abort (); + + if (!vec_all_eq (w, lparms.vrs[1])) + abort (); + + a = vec_add (v,w); + + if (!vec_all_eq (a, c)) + abort (); + } + + /* Paramter passing. + s : gpr 3 + v : slot 2-3 + w : slot 4-5 + */ + + void __attribute__ ((noinline)) + fcevv (char *s, ...) + { + vector int a, c = {6, 8, 10, 12}; + vector int v,w; + stack_frame_t *sp; + reg_parms_t lparms = gparms; + va_list arg; + + va_start (arg, s); + + if (s != (char *) lparms.gprs[0]) + abort(); + + v = va_arg(arg, vector int); + w = va_arg(arg, vector int); + a = vec_add (v,w); + + if (!vec_all_eq (a, c)) + abort (); + + /* Go back one frame. */ + sp = __builtin_frame_address(0); + sp = sp->backchain; + + if (sp->slot[2].l != 0x100000002ULL + || sp->slot[4].l != 0x500000006ULL) + abort(); + } + + /* Paramter passing. + s : gpr 3 + i : gpr 4 + j : gpr 5 + v : slot 4-5 + w : slot 6-7 + */ + void __attribute__ ((noinline)) + fciievv (char *s, int i, int j, ...) + { + vector int a, c = {6, 8, 10, 12}; + vector int v,w; + stack_frame_t *sp; + reg_parms_t lparms = gparms; + va_list arg; + + va_start (arg, j); + + if (s != (char *) lparms.gprs[0]) + abort(); + + if ((long) i != lparms.gprs[1]) + abort(); + + if ((long) j != lparms.gprs[2]) + abort(); + + v = va_arg(arg, vector int); + w = va_arg(arg, vector int); + a = vec_add (v,w); + + if (!vec_all_eq (a, c)) + abort (); + + sp = __builtin_frame_address(0); + sp = sp->backchain; + + if (sp->slot[4].l != 0x100000002ULL + || sp->slot[6].l != 0x500000006ULL) + abort(); + } + + void __attribute__ ((noinline)) + fcvevv (char *s, vector int x, ...) + { + vector int a, c = {7, 10, 13, 16}; + vector int v,w; + stack_frame_t *sp; + reg_parms_t lparms = gparms; + va_list arg; + + va_start (arg, x); + + v = va_arg(arg, vector int); + w = va_arg(arg, vector int); + + a = vec_add (v,w); + a = vec_add (a, x); + + if (!vec_all_eq (a, c)) + abort (); + + sp = __builtin_frame_address(0); + sp = sp->backchain; + + if (sp->slot[4].l != 0x100000002ULL + || sp->slot[6].l != 0x500000006ULL) + abort(); + } + + void fnp_cvvvv(); + + int __attribute__((no_instrument_function, noinline)) + main1() + { + char *s = "vv"; + vector int v = {1, 2, 3, 4}; + vector int w = {5, 6, 7, 8}; + + fcvi (s, v, 2); + fcvv (s, v, w); + fnp_cvvvv (s, v, w, v, w); + fcivv (s, 1, v, w); + fcevv (s, v, w); + fciievv (s, 1, 2, v, w); + fcvevv (s, v, v, w); + return 0; + } + + int __attribute__((no_instrument_function)) + main() + { + /* Exit on systems without altivec. */ + signal (SIGILL, sig_ill_handler); + /* Altivec instruction, 'vor %v0,%v0,%v0'. */ + asm volatile (".long 0x10000484"); + signal (SIGILL, SIG_DFL); + + return main1 (); + } + + /* Paramter passing. + Function called with no prototype. + s : gpr 3 + v : vpr 2 gpr 5-6 + w : vpr 3 gpr 7-8 + x : vpr 4 gpr 9-10 + y : vpr 5 slot 8-9 + */ + void + fnp_cvvvv (char *s, vector int v, vector int w, + vector int x, vector int y) + { + vector int a, c = {12, 16, 20, 24}; + reg_parms_t lparms = gparms; + stack_frame_t *sp; + vector_int_t v0, v1, v2, v3; + + if (s != (char *) lparms.gprs[0]) + abort(); + + if (!vec_all_eq (v, lparms.vrs[0])) + abort (); + + if (!vec_all_eq (w, lparms.vrs[1])) + abort (); + + if (!vec_all_eq (x, lparms.vrs[2])) + abort (); + + if (!vec_all_eq (y, lparms.vrs[3])) + abort (); + + a = vec_add (v,w); + a = vec_add (a,x); + a = vec_add (a,y); + + if (!vec_all_eq (a, c)) + abort (); + + v0.v = lparms.vrs[0]; + v1.v = lparms.vrs[1]; + v2.v = lparms.vrs[2]; + v3.v = lparms.vrs[3]; + + if (v0.l[0] != lparms.gprs[2]) + abort (); + + if (v0.l[1] != lparms.gprs[3]) + abort (); + + if (v1.l[0] != lparms.gprs[4]) + abort (); + + if (v1.l[1] != lparms.gprs[5]) + abort (); + + if (v2.l[0] != lparms.gprs[6]) + abort (); + + if (v2.l[1] != lparms.gprs[7]) + abort (); + + sp = __builtin_frame_address(0); + sp = sp->backchain; + + if (sp->slot[8].l != v3.l[0]) + abort (); + + if (sp->slot[9].l != v3.l[1]) + abort (); + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc64-abi-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc64-abi-3.c 2004-02-12 10:47:13.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* { dg-do compile { target powerpc64-*-linux* } } */ + /* { dg-options "-Wall" } */ + /* Testcase to check for ABI compliance of parameter passing + for the PowerPC64 ABI. */ + + typedef int __attribute__((mode(V4SI))) v4si; + typedef int __attribute__((mode(V2SI))) v2si; + + v4si + f(v4si v) + { /* { dg-error "altivec instructions are disabled" } */ + return v; + } + + v2si + g(v2si v) + { + return v; + } + + int + main() + { + v4si v; + v2si w; + v = f (v); /* { dg-error "altivec instructions are disabled" } */ + w = g (w); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-fsel-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-fsel-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-fsel-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-fsel-1.c 2003-05-03 23:16:56.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* { dg-do compile { target powerpc*-*-* } } */ + /* { dg-options "-O -mpowerpc-gfxopt" } */ + /* { dg-final { scan-assembler "fsel" } } */ + + /* Check that fsel can be generated even without -ffast-math. */ + + double foo(double a, double b, double c, double d) + { + return a < b ? c : d; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-fsel-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-fsel-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-fsel-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-fsel-2.c 2003-05-05 19:33:52.000000000 +0000 *************** *** 0 **** --- 1,80 ---- + /* { dg-do compile { target powerpc*-*-* } } */ + /* { dg-options "-O -mpowerpc-gfxopt -g0 -ffinite-math-only" } */ + /* { dg-final { scan-assembler-not "^L" } } */ + + /* Every single one of these should be compiled into straight-line + code using fsel (or, in a few cases, hardwired to 'true' or + 'false'), no branches anywhere. */ + + double + test_isunordered(double x, double y, double a, double b) + { + return __builtin_isunordered(x, y) ? a : b; + } + + double + test_not_isunordered(double x, double y, double a, double b) + { + return !__builtin_isunordered(x, y) ? a : b; + } + + double + test_isless(double x, double y, double a, double b) + { + return __builtin_isless(x, y) ? a : b; + } + + double + test_not_isless(double x, double y, double a, double b) + { + return !__builtin_isless(x, y) ? a : b; + } + + double + test_islessequal(double x, double y, double a, double b) + { + return __builtin_islessequal(x, y) ? a : b; + } + + double + test_not_islessequal(double x, double y, double a, double b) + { + return !__builtin_islessequal(x, y) ? a : b; + } + + double + test_isgreater(double x, double y, double a, double b) + { + return __builtin_isgreater(x, y) ? a : b; + } + + double + test_not_isgreater(double x, double y, double a, double b) + { + return !__builtin_isgreater(x, y) ? a : b; + } + + double + test_isgreaterequal(double x, double y, double a, double b) + { + return __builtin_isgreaterequal(x, y) ? a : b; + } + + double + test_not_isgreaterequal(double x, double y, double a, double b) + { + return !__builtin_isgreaterequal(x, y) ? a : b; + } + + double + test_islessgreater(double x, double y, double a, double b) + { + return __builtin_islessgreater(x, y) ? a : b; + } + + double + test_not_islessgreater(double x, double y, double a, double b) + { + return !__builtin_islessgreater(x, y) ? a : b; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-sdata-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-sdata-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-sdata-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-sdata-1.c 2003-03-10 20:42:23.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* { dg-do compile { target powerpc-*-linux* powerpc-*-sysv* powerpc-*-eabi* } } */ + /* { dg-options "-O2 -fno-common -G 8 -meabi -msdata=eabi" } */ + /* { dg-final { scan-assembler "\\.section\[ \t\]\\.sdata," } } */ + /* { dg-final { scan-assembler "\\.section\[ \t\]\\.sdata2," } } */ + /* { dg-final { scan-assembler "sdat@sdarel\\(13\\)" } } */ + /* { dg-final { scan-assembler "sdat2@sda21\\(2\\)" } } */ + + + int sdat = 2; + const char sdat2[] = "1234"; + + const char * test (void) + { + return sdat ? sdat2 : 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-sdata-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-sdata-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-sdata-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-sdata-2.c 2003-03-10 20:42:23.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* { dg-do compile { target powerpc-*-linux* powerpc-*-sysv* powerpc-*-eabi* } } */ + /* { dg-options "-O2 -fno-common -G 8 -msdata=sysv" } */ + /* { dg-final { scan-assembler "\\.section\[ \t\]\\.sdata," } } */ + /* { dg-final { scan-assembler-not "\\.section\[ \t\]\\.sdata2," } } */ + /* { dg-final { scan-assembler "sdat@sdarel\\(13\\)" } } */ + /* { dg-final { scan-assembler "sdat2@sdarel\\(13\\)" } } */ + + + int sdat = 2; + const char sdat2[] = "1234"; + + const char * test (void) + { + return sdat ? sdat2 : 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-spe.c gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-spe.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ppc-spe.c 2002-07-25 02:31:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ppc-spe.c 2003-02-12 23:54:32.000000000 +0000 *************** int16_t s16; *** 26,95 **** void test_api () { ! c = __ev_addw(a, b); ! c = __ev_addiw(a, 8); ! c = __ev_subfw(a, b); ! c = __ev_subifw(a, 8); ! c = __ev_abs(a); ! c = __ev_neg(a); ! c = __ev_extsb(a); ! c = __ev_extsh(a); ! c = __ev_and(a, b); ! c = __ev_or(a, b); ! c = __ev_xor(a, b); ! c = __ev_nand(a, b); ! c = __ev_nor(a, b); ! c = __ev_eqv(a, b); ! c = __ev_andc(a, b); ! c = __ev_orc(a, b); ! c = __ev_rlw(a, b); ! c = __ev_rlwi(a, 8); ! c = __ev_slw(a, b); ! c = __ev_slwi(a, 8); ! c = __ev_srws(a, b); ! c = __ev_srwu(a, b); ! c = __ev_srwis(a, 8); ! c = __ev_srwiu(a, 8); ! c = __ev_cntlzw(a); ! c = __ev_cntlsw(a); ! c = __ev_rndw(a); ! c = __ev_mergehi(a, b); ! c = __ev_mergelo(a, b); ! c = __ev_mergelohi(a, b); ! c = __ev_mergehilo(a, b); ! c = __ev_splati(5); ! c = __ev_splatfi(6); ! c = __ev_divws(a, b); ! c = __ev_divwu(a, b); ! c = __ev_mra(a); ! i = __brinc(5, 6); /* Loads. */ ! c = __ev_lddx(ap, i); ! c = __ev_ldwx(ap, i); ! c = __ev_ldhx(ap, i); ! c = __ev_lwhex(uip, i); ! c = __ev_lwhoux(uip, i); ! c = __ev_lwhosx(uip, i); ! c = __ev_lwwsplatx(uip, i); ! c = __ev_lwhsplatx(uip, i); ! c = __ev_lhhesplatx(usp, i); ! c = __ev_lhhousplatx(usp, i); ! c = __ev_lhhossplatx(usp, i); ! c = __ev_ldd(ap, 5); ! c = __ev_ldw(ap, 6); ! c = __ev_ldh(ap, 7); ! c = __ev_lwhe(uip, 6); ! c = __ev_lwhou(uip, 6); ! c = __ev_lwhos(uip, 7); ! c = __ev_lwwsplat(uip, 7); ! c = __ev_lwhsplat(uip, 7); ! c = __ev_lhhesplat(usp, 7); ! c = __ev_lhhousplat(usp, 7); ! c = __ev_lhhossplat(usp, 7); /* Stores. */ __ev_stddx (a, ap, 9); --- 26,95 ---- void test_api () { ! c = __ev_addw (a, b); ! c = __ev_addiw (a, 8); ! c = __ev_subfw (a, b); ! c = __ev_subifw (8, a); ! c = __ev_abs (a); ! c = __ev_neg (a); ! c = __ev_extsb (a); ! c = __ev_extsh (a); ! c = __ev_and (a, b); ! c = __ev_or (a, b); ! c = __ev_xor (a, b); ! c = __ev_nand (a, b); ! c = __ev_nor (a, b); ! c = __ev_eqv (a, b); ! c = __ev_andc (a, b); ! c = __ev_orc (a, b); ! c = __ev_rlw (a, b); ! c = __ev_rlwi (a, 8); ! c = __ev_slw (a, b); ! c = __ev_slwi (a, 8); ! c = __ev_srws (a, b); ! c = __ev_srwu (a, b); ! c = __ev_srwis (a, 8); ! c = __ev_srwiu (a, 8); ! c = __ev_cntlzw (a); ! c = __ev_cntlsw (a); ! c = __ev_rndw (a); ! c = __ev_mergehi (a, b); ! c = __ev_mergelo (a, b); ! c = __ev_mergelohi (a, b); ! c = __ev_mergehilo (a, b); ! c = __ev_splati (5); ! c = __ev_splatfi (6); ! c = __ev_divws (a, b); ! c = __ev_divwu (a, b); ! c = __ev_mra (a); ! i = __brinc (5, 6); /* Loads. */ ! c = __ev_lddx (ap, i); ! c = __ev_ldwx (ap, i); ! c = __ev_ldhx (ap, i); ! c = __ev_lwhex (uip, i); ! c = __ev_lwhoux (uip, i); ! c = __ev_lwhosx (uip, i); ! c = __ev_lwwsplatx (uip, i); ! c = __ev_lwhsplatx (uip, i); ! c = __ev_lhhesplatx (usp, i); ! c = __ev_lhhousplatx (usp, i); ! c = __ev_lhhossplatx (usp, i); ! c = __ev_ldd (ap, 5); ! c = __ev_ldw (ap, 6); ! c = __ev_ldh (ap, 7); ! c = __ev_lwhe (uip, 6); ! c = __ev_lwhou (uip, 6); ! c = __ev_lwhos (uip, 7); ! c = __ev_lwwsplat (uip, 7); ! c = __ev_lwhsplat (uip, 7); ! c = __ev_lhhesplat (usp, 7); ! c = __ev_lhhousplat (usp, 7); ! c = __ev_lhhossplat (usp, 7); /* Stores. */ __ev_stddx (a, ap, 9); *************** test_api () *** 108,232 **** __ev_stwho (a, uip, 9); /* Fixed point complex. */ ! c = __ev_mhossf(a, b); ! c = __ev_mhosmf(a, b); ! c = __ev_mhosmi(a, b); ! c = __ev_mhoumi(a, b); ! c = __ev_mhessf(a, b); ! c = __ev_mhesmf(a, b); ! c = __ev_mhesmi(a, b); ! c = __ev_mheumi(a, b); ! c = __ev_mhossfa(a, b); ! c = __ev_mhosmfa(a, b); ! c = __ev_mhosmia(a, b); ! c = __ev_mhoumia(a, b); ! c = __ev_mhessfa(a, b); ! c = __ev_mhesmfa(a, b); ! c = __ev_mhesmia(a, b); ! c = __ev_mheumia(a, b); c = __ev_mhoumf (a, b); c = __ev_mheumf (a, b); c = __ev_mhoumfa (a, b); c = __ev_mheumfa (a, b); ! c = __ev_mhossfaaw(a, b); ! c = __ev_mhossiaaw(a, b); ! c = __ev_mhosmfaaw(a, b); ! c = __ev_mhosmiaaw(a, b); ! c = __ev_mhousiaaw(a, b); ! c = __ev_mhoumiaaw(a, b); ! c = __ev_mhessfaaw(a, b); ! c = __ev_mhessiaaw(a, b); ! c = __ev_mhesmfaaw(a, b); ! c = __ev_mhesmiaaw(a, b); ! c = __ev_mheusiaaw(a, b); ! c = __ev_mheumiaaw(a, b); c = __ev_mhousfaaw (a, b); c = __ev_mhoumfaaw (a, b); c = __ev_mheusfaaw (a, b); c = __ev_mheumfaaw (a, b); ! c = __ev_mhossfanw(a, b); ! c = __ev_mhossianw(a, b); ! c = __ev_mhosmfanw(a, b); ! c = __ev_mhosmianw(a, b); ! c = __ev_mhousianw(a, b); ! c = __ev_mhoumianw(a, b); ! c = __ev_mhessfanw(a, b); ! c = __ev_mhessianw(a, b); ! c = __ev_mhesmfanw(a, b); ! c = __ev_mhesmianw(a, b); ! c = __ev_mheusianw(a, b); ! c = __ev_mheumianw(a, b); c = __ev_mhousfanw (a, b); c = __ev_mhoumfanw (a, b); c = __ev_mheusfanw (a, b); c = __ev_mheumfanw (a, b); ! c = __ev_mhogsmfaa(a, b); ! c = __ev_mhogsmiaa(a, b); ! c = __ev_mhogumiaa(a, b); ! c = __ev_mhegsmfaa(a, b); ! c = __ev_mhegsmiaa(a, b); ! c = __ev_mhegumiaa(a, b); c = __ev_mhogumfaa (a, b); c = __ev_mhegumfaa (a, b); ! c = __ev_mhogsmfan(a, b); ! c = __ev_mhogsmian(a, b); ! c = __ev_mhogumian(a, b); ! c = __ev_mhegsmfan(a, b); ! c = __ev_mhegsmian(a, b); ! c = __ev_mhegumian(a, b); c = __ev_mhogumfan (a, b); c = __ev_mhegumfan (a, b); ! c = __ev_mwhssf(a, b); ! c = __ev_mwhsmf(a, b); ! c = __ev_mwhsmi(a, b); ! c = __ev_mwhumi(a, b); ! c = __ev_mwhssfa(a, b); ! c = __ev_mwhsmfa(a, b); ! c = __ev_mwhsmia(a, b); ! c = __ev_mwhumia(a, b); c = __ev_mwhumf (a, b); c = __ev_mwhumfa (a, b); ! c = __ev_mwlssf(a, b); ! c = __ev_mwlsmf(a, b); ! c = __ev_mwlumi(a, b); ! c = __ev_mwlssfa(a, b); ! c = __ev_mwlsmfa(a, b); ! c = __ev_mwlumia(a, b); ! c = __ev_mwlumiaaw(a, b); ! ! c = __ev_mwlufi (a, b); ! c = __ev_mwlufia (a, b); ! ! c = __ev_mwlssfaaw(a, b); ! c = __ev_mwlssiaaw(a, b); ! c = __ev_mwlsmfaaw(a, b); ! c = __ev_mwlsmiaaw(a, b); ! c = __ev_mwlusiaaw(a, b); ! c = __ev_mwlusiaaw(a, b); ! ! c = __ev_mwlusfaaw (a, b); ! c = __ev_mwlssfanw(a, b); ! c = __ev_mwlssianw(a, b); ! c = __ev_mwlsmfanw(a, b); ! c = __ev_mwlsmianw(a, b); ! c = __ev_mwlusianw(a, b); ! c = __ev_mwlumianw(a, b); ! c = __ev_mwlumfanw (a, b); ! c = __ev_mwlusfanw (a, b); c = __ev_mwssf (a, b); c = __ev_mwsmf (a, b); --- 108,216 ---- __ev_stwho (a, uip, 9); /* Fixed point complex. */ ! c = __ev_mhossf (a, b); ! c = __ev_mhosmf (a, b); ! c = __ev_mhosmi (a, b); ! c = __ev_mhoumi (a, b); ! c = __ev_mhessf (a, b); ! c = __ev_mhesmf (a, b); ! c = __ev_mhesmi (a, b); ! c = __ev_mheumi (a, b); ! c = __ev_mhossfa (a, b); ! c = __ev_mhosmfa (a, b); ! c = __ev_mhosmia (a, b); ! c = __ev_mhoumia (a, b); ! c = __ev_mhessfa (a, b); ! c = __ev_mhesmfa (a, b); ! c = __ev_mhesmia (a, b); ! c = __ev_mheumia (a, b); c = __ev_mhoumf (a, b); c = __ev_mheumf (a, b); c = __ev_mhoumfa (a, b); c = __ev_mheumfa (a, b); ! c = __ev_mhossfaaw (a, b); ! c = __ev_mhossiaaw (a, b); ! c = __ev_mhosmfaaw (a, b); ! c = __ev_mhosmiaaw (a, b); ! c = __ev_mhousiaaw (a, b); ! c = __ev_mhoumiaaw (a, b); ! c = __ev_mhessfaaw (a, b); ! c = __ev_mhessiaaw (a, b); ! c = __ev_mhesmfaaw (a, b); ! c = __ev_mhesmiaaw (a, b); ! c = __ev_mheusiaaw (a, b); ! c = __ev_mheumiaaw (a, b); c = __ev_mhousfaaw (a, b); c = __ev_mhoumfaaw (a, b); c = __ev_mheusfaaw (a, b); c = __ev_mheumfaaw (a, b); ! c = __ev_mhossfanw (a, b); ! c = __ev_mhossianw (a, b); ! c = __ev_mhosmfanw (a, b); ! c = __ev_mhosmianw (a, b); ! c = __ev_mhousianw (a, b); ! c = __ev_mhoumianw (a, b); ! c = __ev_mhessfanw (a, b); ! c = __ev_mhessianw (a, b); ! c = __ev_mhesmfanw (a, b); ! c = __ev_mhesmianw (a, b); ! c = __ev_mheusianw (a, b); ! c = __ev_mheumianw (a, b); c = __ev_mhousfanw (a, b); c = __ev_mhoumfanw (a, b); c = __ev_mheusfanw (a, b); c = __ev_mheumfanw (a, b); ! c = __ev_mhogsmfaa (a, b); ! c = __ev_mhogsmiaa (a, b); ! c = __ev_mhogumiaa (a, b); ! c = __ev_mhegsmfaa (a, b); ! c = __ev_mhegsmiaa (a, b); ! c = __ev_mhegumiaa (a, b); c = __ev_mhogumfaa (a, b); c = __ev_mhegumfaa (a, b); ! c = __ev_mhogsmfan (a, b); ! c = __ev_mhogsmian (a, b); ! c = __ev_mhogumian (a, b); ! c = __ev_mhegsmfan (a, b); ! c = __ev_mhegsmian (a, b); ! c = __ev_mhegumian (a, b); c = __ev_mhogumfan (a, b); c = __ev_mhegumfan (a, b); ! c = __ev_mwhssf (a, b); ! c = __ev_mwhsmf (a, b); ! c = __ev_mwhsmi (a, b); ! c = __ev_mwhumi (a, b); ! c = __ev_mwhssfa (a, b); ! c = __ev_mwhsmfa (a, b); ! c = __ev_mwhsmia (a, b); ! c = __ev_mwhumia (a, b); c = __ev_mwhumf (a, b); c = __ev_mwhumfa (a, b); ! c = __ev_mwlumi (a, b); ! c = __ev_mwlumia (a, b); ! c = __ev_mwlumiaaw (a, b); ! c = __ev_mwlssiaaw (a, b); ! c = __ev_mwlsmiaaw (a, b); ! c = __ev_mwlusiaaw (a, b); ! c = __ev_mwlusiaaw (a, b); ! c = __ev_mwlssianw (a, b); ! c = __ev_mwlsmianw (a, b); ! c = __ev_mwlusianw (a, b); ! c = __ev_mwlumianw (a, b); c = __ev_mwssf (a, b); c = __ev_mwsmf (a, b); *************** main (void) *** 536,551 **** c = __builtin_spe_evmwhssfa (a, b); c = __builtin_spe_evmwhumi (a, b); c = __builtin_spe_evmwhumia (a, b); - c = __builtin_spe_evmwlsmf (a, b); - c = __builtin_spe_evmwlsmfa (a, b); - c = __builtin_spe_evmwlsmfaaw (a, b); - c = __builtin_spe_evmwlsmfanw (a, b); c = __builtin_spe_evmwlsmiaaw (a, b); c = __builtin_spe_evmwlsmianw (a, b); - c = __builtin_spe_evmwlssf (a, b); - c = __builtin_spe_evmwlssfa (a, b); - c = __builtin_spe_evmwlssfaaw (a, b); - c = __builtin_spe_evmwlssfanw (a, b); c = __builtin_spe_evmwlssiaaw (a, b); c = __builtin_spe_evmwlssianw (a, b); c = __builtin_spe_evmwlumi (a, b); --- 520,527 ---- *************** main (void) *** 580,586 **** c = __builtin_spe_evsrwu (a, b); c = __builtin_spe_evsubfw (a, b); c = __builtin_spe_evxor (a, b); ! /* GAS bug not implemented. c = __builtin_spe_evmwhssfaa (a, b); c = __builtin_spe_evmwhssmaa (a, b); c = __builtin_spe_evmwhsmfaa (a, b); --- 556,562 ---- c = __builtin_spe_evsrwu (a, b); c = __builtin_spe_evsubfw (a, b); c = __builtin_spe_evxor (a, b); ! c = __builtin_spe_evmwhssfaa (a, b); c = __builtin_spe_evmwhssmaa (a, b); c = __builtin_spe_evmwhsmfaa (a, b); *************** main (void) *** 601,607 **** c = __builtin_spe_evmwhgsmfan (a, b); c = __builtin_spe_evmwhgsmian (a, b); c = __builtin_spe_evmwhgumian (a, b); - */ i = __builtin_spe_brinc (i, j); /* Generic unary operations. */ --- 577,582 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr10392-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr10392-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr10392-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr10392-1.c 2004-01-16 18:24:09.000000000 +0000 *************** *** 0 **** --- 1,62 ---- + /* PR optimization/10392 + * Reporter: marcus@mc.pp.se + * Summary: [3.3/3.4 regression] [SH] optimizer generates faulty array indexing + * Description: + * The address calculation of an index operation on an array on the stack + * can _under some conditions_ get messed up completely + * + * Testcase tweaked by dank@kegel.com + * Problem only happens with -O2 -m4, so it should only happen on sh4, + * but what the heck, let's test other architectures, too. + * Not marked as xfail since it's a regression. + */ + /* { dg-do run } */ + /* { dg-options "-O2" } */ + /* { dg-options "-O2 -m4" { target sh4-*-* } } */ + const char *dont_optimize_function_away; + + const char *use(const char *str) + { + dont_optimize_function_away = str; + if (str[0] != 'v') + abort(); + if (str[1] < '1' || str[1] > '6') + abort(); + if (str[2]) + abort(); + return str[2] ? "notused" : "v6"; + } + + const char *func(char *a, char *b) + { + char buf[128]; + unsigned char i; + const char *result; + + char *item[] = { + "v1", + "v2", + }; + + buf[0] = 'v'; + buf[1] = '3'; + buf[2] = 0; + + for (i = 0; i < 2; i++) { + /* bug is: following line passes wild pointer to use() on sh4 -O2 */ + result = use(item[i]); + + use(buf); + use(a); + use(b); + result = use(result); + } + return result; + } + + int main() + { + func("v4", "v5"); + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr11864-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr11864-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr11864-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr11864-1.c 2004-01-16 18:43:04.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + /* PR optimization/11864 + * Reporter: Kazumoto Kojima + * Summary: [3.3/3.4 regression] miscompiles zero extension and test + * Description: + * gcc-3.3/3.4 -O2 for sh target may miscompile the combination of zero extension + * and test if it's zero. + * + * Testcase tweaked by dank@kegel.com. Not marked as xfail because it's a regression. + */ + /* { dg-do run } */ + /* { dg-options "-O2" } */ + + extern void abort(void); + + int val = 0xff00; + + int f(void) + { + return val; + } + + unsigned char a[1]; + + void foo(void) + { + a[0] = f() & 255; + + if (!a[0]) + a[0] = f() & 255; + + if (!a[0]) + a[0] = 1 + (f() & 127); + } + + int main(int argc, char **argv) + { + foo(); + if (!a[0]) + abort(); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr14092-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr14092-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr14092-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr14092-1.c 2004-02-16 05:15:19.000000000 +0000 *************** *** 0 **** --- 1,20 ---- + /* PR c/14092 + * Origin: bonzini@gnu.org + * rejects-valid + */ + /* { dg-do compile } */ + + /* Define this so that we are more portable. The testcase in the + PR failed on 64-bit hosts. */ + typedef int __attribute__ ((mode (__pointer__))) intptr_t; + + typedef struct _PLCI { + unsigned char x; + unsigned char buf[1]; + } PLCI; + + void nl_ind(PLCI * plci) + { + plci->x = -((intptr_t)(plci->buf)) & 3; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-1.c 2004-03-09 17:44:13.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-2.c 2004-03-09 17:44:13.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr14289-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr14289-3.c 2004-03-09 17:44:13.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* 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 -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pr9365-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pr9365-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pr9365-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pr9365-1.c 2004-01-15 12:40:05.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* PR target/9365 + * Origin: marcus@mc.pp.se + * Testcase tweaked by dank@kegel.com + * gcc 3.4 coverage by joern.rennecke@superh.com + * [3.3 regression] [SH] segfault in gen_far_branch (config/sh/sh.c) + * ice-on-valid-code + * Not marked as xfail since it's a regression + */ + /* { dg-do compile } */ + /* { dg-options "-O2 -fomit-frame-pointer" } */ + + + void foo(int n, int *p) + { + switch(n) { + case 100: case 110: case 120: case 130: case 140: case 150: case 160: + case 200: case 210: case 220: case 230: case 240: case 250: case 260: + case 300: case 310: case 320: case 330: case 340: case 350: case 360: + case 400: case 410: case 420: case 430: case 440: case 450: case 460: + case 500: case 510: case 520: case 530: case 540: case 550: case 560: + case 600: case 610: case 620: case 630: case 640: case 650: case 660: + case 700: case 710: case 720: case 730: case 740: case 750: case 760: + case 800: case 810: case 820: case 830: case 840: case 850: case 860: + case 900: case 910: case 920: case 930: case 940: case 950: case 960: + break; + default: + *p = n; + break; + } + } + + int main(int argc, char **argv) + { + int p; + + (void) argv; + + foo(argc, &p); + + return p; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/pragma-re-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/pragma-re-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/pragma-re-1.c 2002-03-22 22:51:48.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/pragma-re-1.c 2004-01-10 11:25:49.000000000 +0000 *************** *** 8,11 **** #pragma redefine_extname foo bar extern int foo(void); ! void *p = (void *)foo; --- 8,11 ---- #pragma redefine_extname foo bar extern int foo(void); ! int (*p)(void) = foo; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/redecl-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/redecl-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/redecl-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/redecl-1.c 2004-01-11 01:18:58.000000000 +0000 *************** *** 0 **** --- 1,101 ---- + /* Test for various situations where a new declaration of an + identifier conflicts with an earlier declaration which isn't in the + same scope. These are all undefined behavior per C89 sections + 6.1.2.2p7, 6.1.2.6p2, and 6.3.2.2p2/footnote 38 (C99 6.2.2p7 and + 6.2.7p2 - implicit declarations are invalid in C99). */ + + /* { dg-do compile } */ + /* { dg-options "-std=c89 -pedantic -Wall -Wno-unused" } */ + + /* Extern at function scope, clashing with extern at file scope */ + + extern int foo1; /* { dg-error "previous" } */ + extern int bar1(int); /* { dg-error "previous" } */ + + void test1(void) + { + extern double foo1; /* { dg-error "conflict" } */ + extern double bar1(double); /* { dg-error "conflict" } */ + } + + /* Extern at file scope, clashing with extern at function scope */ + + void test2(void) + { + extern double foo2; /* { dg-error "previous" } */ + extern double bar2(double); /* { dg-error "previous" } */ + } + + extern int foo2; /* { dg-error "conflict" } */ + extern int bar2(int); /* { dg-error "conflict" } */ + + /* Extern at function scope, clashing with extern at earlier function + scope. Also, don't be fooled by a typedef at file scope. */ + + typedef float baz3; /* { dg-bogus } */ + + void prime3(void) + { + extern int foo3; /* { dg-error "previous" } */ + extern int bar3(int); /* { dg-error "previous" } */ + extern int baz3; /* { dg-error "previous" } */ + } + + void test3(void) + { + extern double foo3; /* { dg-error "conflict" } */ + extern double bar3(double); /* { dg-error "conflict" } */ + extern double baz3; /* { dg-error "conflict" } */ + } + + /* Extern at function scope, clashing with previous implicit decl. */ + + void prime4(void) + { + bar4(); /* { dg-error "previous|implicit" } */ + } + + void test4(void) + { + extern double bar4(double); /* { dg-error "conflict" } */ + } + + /* Implicit decl, clashing with extern at previous function scope. */ + + void prime5(void) + { + extern double bar5(double); /* { dg-error "previous" "" { xfail *-*-* } } */ + } + + void test5(void) + { + bar5(1); /* { dg-error "implicit" } */ + } + + /* Extern then static, both at file scope. */ + + extern int test6(int); /* { dg-warning "previous" "" } */ + static int test6(int x) + { return x; } /* { dg-warning "follows non-static" } */ + + + /* Extern then static, extern at previous function scope. */ + + void prime7(void) + { + extern int test7(int); /* { dg-warning "previous" "" } */ + } + + static int test7(int x) + { return x; } /* { dg-warning "follows non-static" } */ + + /* Implicit decl then static. */ + + void prime8(void) + { + test8(); /* { dg-warning "previous" "" } */ + /* { dg-warning "implicit" "" { target *-*-* } 96 } */ + } + + static int test8(int x) + { return x; } /* { dg-warning "follows non-static" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/rs6000-ldouble-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/rs6000-ldouble-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/rs6000-ldouble-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/rs6000-ldouble-1.c 2004-01-10 05:52:56.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* { dg-do run { target powerpc*-*-darwin* powerpc*-*-aix* powerpc64-*-linux rs6000-*-* } } */ + /* { dg-options "-mlong-double-128" } */ + + /* Check that long double values are rounded correctly when being converted + to 32-bit integers. All these values are of the form +/- 2 +/- 2^-60. */ + + int main(void) + { + long double l1 = 1.9999999999999999991326382620115964527941L; + long double l2 = 2.0000000000000000008673617379884035472059L; + long double l3 = -2.0000000000000000008673617379884035472059L; + long double l4 = -1.9999999999999999991326382620115964527941L; + + if ((int) l1 != 1) + abort (); + if ((int) l2 != 2) + abort (); + if ((int) l3 != -2) + abort (); + if ((int) l4 != -1) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/section1.c gcc-3.4.0/gcc/testsuite/gcc.dg/section1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/section1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/section1.c 2003-03-15 01:42:13.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + /* PR optimization/6871 */ + /* Constant variables belong in .rodata, not .bss. */ + /* { dg-final { scan-assembler-not "\.bss" } } */ + + const int i = 0; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sh-relax.c gcc-3.4.0/gcc/testsuite/gcc.dg/sh-relax.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sh-relax.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sh-relax.c 2003-03-04 19:40:34.000000000 +0000 *************** *** 0 **** --- 1,40 ---- + /* Check that -mrelax works. */ + /* { dg-do run { target sh-*-* sh?-*-* } } */ + /* { dg-options "-O1 -mrelax" } */ + + extern int qwerty (int); + + int + f (int i) + { + return qwerty (i) + 1; + } + + int + qwerty (int i) + { + switch (i) + { + case 1: + return 'q'; + case 2: + return 'w'; + case 3: + return 'e'; + case 4: + return 'r'; + case 5: + return 't'; + case 6: + return 'y'; + } + } + + int + main () + { + if (f (1) != 'q' + 1 || f (2) != 'w' + 1 || f (3) != 'e' + 1 + || f(4) != 'r' + 1 || f (5) != 't' + 1 || f (6) != 'y' + 1) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-1.c 2003-09-01 20:52:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-1.c 2002-09-29 18:16:15.000000000 +0000 *************** track (int n) *** 42,49 **** if (n == 0) trackpoint = stackpos; else if (n != 7 || trackpoint != stackpos) ! { ! printf ("%d %p %p\n", n, trackpoint, stackpos); ! abort (); ! } } --- 42,46 ---- if (n == 0) trackpoint = stackpos; else if (n != 7 || trackpoint != stackpos) ! abort (); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-3.c 2002-09-29 18:16:15.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-3.c 2004-01-15 18:35:32.000000000 +0000 *************** *** 5,11 **** Copyright (C) 2002 Free Software Foundation Inc. Contributed by Hans-Peter Nilsson */ ! /* { dg-do run { xfail arc-*-* avr-*-* c4x-*-* cris-*-* h8300-*-* i370-*-* i960-*-* ip2k-*-* m32r-*-* m68hc1?-*-* m681?-*-* m680*-*-* m68k-*-* mcore-*-* mips*-*-* mn10?00-*-* ns32k-*-* s390*-*-* xstormy16-*-* v850*-*-* vax-*-* xtensa-*-* } } */ /* { dg-options "-O2 -foptimize-sibling-calls" } */ /* The option -foptimize-sibling-calls is the default, but serves as --- 5,11 ---- Copyright (C) 2002 Free Software Foundation Inc. Contributed by Hans-Peter Nilsson */ ! /* { dg-do run { xfail arc-*-* avr-*-* c4x-*-* cris-*-* h8300-*-* i370-*-* i960-*-* ip2k-*-* m32r-*-* m68hc1?-*-* m681?-*-* m680*-*-* m68k-*-* mcore-*-* mips*-*-* mn10300-*-* ns32k-*-* s390*-*-* xstormy16-*-* v850*-*-* vax-*-* xtensa-*-* } } */ /* { dg-options "-O2 -foptimize-sibling-calls" } */ /* The option -foptimize-sibling-calls is the default, but serves as diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-4.c 2002-09-29 18:16:15.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-4.c 2003-12-30 23:35:58.000000000 +0000 *************** *** 5,11 **** Copyright (C) 2002 Free Software Foundation Inc. Contributed by Hans-Peter Nilsson */ ! /* { dg-do run { xfail arc-*-* avr-*-* c4x-*-* cris-*-* h8300-*-* i370-*-* i960-*-* ip2k-*-* m32r-*-* m68hc1?-*-* m681?-*-* m680*-*-* m68k-*-* mcore-*-* mips*-*-* mn10?00-*-* ns32k-*-* s390*-*-* xstormy16-*-* v850*-*-* vax-*-* xtensa-*-* } } */ /* { dg-options "-O2 -foptimize-sibling-calls" } */ /* The option -foptimize-sibling-calls is the default, but serves as --- 5,11 ---- Copyright (C) 2002 Free Software Foundation Inc. Contributed by Hans-Peter Nilsson */ ! /* { dg-do run { xfail arc-*-* avr-*-* c4x-*-* cris-*-* h8300-*-* i370-*-* i960-*-* ip2k-*-* m32r-*-* m68hc1?-*-* m681?-*-* m680*-*-* m68k-*-* mcore-*-* mips*-*-* mn10300-*-* ns32k-*-* s390*-*-* xstormy16-*-* v850*-*-* vax-*-* xtensa-*-* } } */ /* { dg-options "-O2 -foptimize-sibling-calls" } */ /* The option -foptimize-sibling-calls is the default, but serves as diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-5.c 2002-12-16 18:22:43.000000000 +0000 *************** *** 0 **** --- 1,41 ---- + /* Check that indirect sibcalls understand regparm. */ + /* { dg-do run { target i?86-*-* } } */ + /* { dg-options "-O2" } */ + + int (*f)(int, int) __attribute__((regparm(2))); + int (*g)(int, int, int) __attribute__((regparm(3))); + + int __attribute__((noinline)) + foo(void) + { + return f(1, 2); + } + + int __attribute__((noinline)) + bar(void) + { + return g(1, 2, 3); + } + + int __attribute__((regparm(2))) + f1(int x, int y) + { + return x*3 + y; + } + + int __attribute__((regparm(3))) + g1(int x, int y, int z) + { + return x*9 + y*3 + z; + } + + int main() + { + f = f1; + g = g1; + if (foo() != 1*3 + 2) + abort (); + if (bar() != 1*9 + 2*3 + 3) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sibcall-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sibcall-6.c 2002-12-16 18:22:43.000000000 +0000 *************** *** 0 **** --- 1,42 ---- + /* A simple check to see whether indirect calls are + being sibcall optimized on targets that do support + this notion, i.e. have the according call patterns + in place. + + Copyright (C) 2002 Free Software Foundation Inc. + Contributed by Andreas Bauer */ + + /* { dg-do run { target i?86-*-* x86_64-*-*} } */ + /* { dg-options "-O2 -foptimize-sibling-calls" } */ + + int foo (int); + int bar (int); + + int (*ptr) (int); + int *f_addr; + + int + main () + { + ptr = bar; + foo (7); + exit (0); + } + + int + bar (b) + int b; + { + if (f_addr == (int*) __builtin_return_address (0)) + return b; + else + abort (); + } + + int + foo (f) + int f; + { + f_addr = (int*) __builtin_return_address (0); + return (*ptr)(f); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sparc-loop-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/sparc-loop-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sparc-loop-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sparc-loop-1.c 2003-04-03 19:20:06.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + /* PR optimization/10157 */ + /* Originator: Peter van Hoof */ + /* { dg-do compile { target sparc*-*-* } } */ + /* { dg-options "-O2 -ffast-math" } */ + + /* Verify that the loop optimizer doesn't + emit invalid reg-to-reg copy insns. */ + + void g() { + while(1) { + int i,n; + double p,r; + for( i=0; i < n; i++ ) + if( p > 1. ) + for( i=0; i < n; i++ ) + r += 2.; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/sparc-ret.c gcc-3.4.0/gcc/testsuite/gcc.dg/sparc-ret.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/sparc-ret.c 2001-12-07 21:51:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/sparc-ret.c 2004-01-26 07:43:10.000000000 +0000 *************** *** 3,10 **** Making sure that Ultrasparc return instructions do not read below the stack. */ ! /* { dg-do compile { target sparc*-*-* } } */ ! /* { dg-options "-mcpu=ultrasparc -O -m32" } */ int bar (int a, int b, int c, int d, int e, int f, int g, int h) --- 3,10 ---- Making sure that Ultrasparc return instructions do not read below the stack. */ ! /* { dg-do compile { target sparc-*-* } } */ ! /* { dg-options "-mcpu=ultrasparc -O" } */ int bar (int a, int b, int c, int d, int e, int f, int g, int h) *************** int bar (int a, int b, int c, int d, int *** 14,20 **** toto (&res); return h; } ! /* { dg-final { scan-assembler "return\[ \t\]*%i7\\+8\n\[^\n\]*ld\[ \t\]*\\\[%sp\\+96\\\]" } } */ int bar2 () { --- 14,20 ---- toto (&res); return h; } ! /* { dg-final { global compiler_flags; if ![string match "*-m64 *" $compiler_flags] { scan-assembler "return\[ \t\]*%i7\\+8\n\[^\n\]*ld\[ \t\]*\\\[%sp\\+96\\\]" } } } */ int bar2 () { *************** int bar2 () *** 23,27 **** toto (&res); return res; } ! /* { dg-final { scan-assembler "return\[ \t\]*%i7\\+8\n\[^\n\]*nop" } } */ ! --- 23,26 ---- toto (&res); return res; } ! /* { dg-final { global compiler_flags; if ![string match "*-m64 *" $compiler_flags] { scan-assembler "return\[ \t\]*%i7\\+8\n\[^\n\]*nop" } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/spe1.c gcc-3.4.0/gcc/testsuite/gcc.dg/spe1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/spe1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/spe1.c 2003-08-10 15:17:35.000000000 +0000 *************** *** 0 **** --- 1,14 ---- + /* { dg-do compile { target powerpc-*-eabi* } } */ + /* { dg-options "-mcpu=8540 -mabi=spe -O0" } */ + + /* (Test with -O0 so we don't optimize any of them away). */ + + + typedef float __attribute__((vector_size(8))) __ev64_fs__; + + static __ev64_opaque__ Foo (void); + + void Bar () + { + __ev64_fs__ fs = Foo (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/20000419-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/20000419-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/20000419-2.c 2001-01-10 04:19:31.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/20000419-2.c 2003-06-09 17:30:08.000000000 +0000 *************** *** 1,6 **** --- 1,7 ---- /* A static function with a global alias should not get 'defined but not used' warnings. Exposed by Linux kernel. */ /* { dg-do compile } */ + /* { dg-require-alias "" } */ /* { dg-options "-Wall" } */ extern void do_something (void); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/alias-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/alias-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/alias-1.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/alias-1.c 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do link } */ + /* { dg-require-alias "" } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/alias-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/alias-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/alias-2.c 2002-03-31 11:50:42.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/alias-2.c 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,5 **** --- 1,6 ---- /* PR 3997 */ /* { dg-do run } */ + /* { dg-require-alias "" } */ extern void abort (void); extern void exit (int); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/ecos.exp gcc-3.4.0/gcc/testsuite/gcc.dg/special/ecos.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/ecos.exp 2003-03-13 03:29:14.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/ecos.exp 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,179 **** - # Copyright (C) 1999, 2000, 2001 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. - - # Please email any bugs, comments, and/or additions to this file to: - # jlarmour@cygnus.co.uk - - # This file was written by Jonathan Larmour (jlarmour@cygnus.co.uk). - - # GCC testsuite that uses the `dg.exp' driver. - - # Load support procs. - load_lib gcc-dg.exp - - ############################### - # proc gcc_target_object_format {} - ############################### - # has been moved to: gcc/testsuite/lib/file-format.exp - - ############################### - # proc check_weak_available { } - ############################### - # has been moved to: gcc/testsuite/lib/target-supports.exp - - ########## - # weak-1.c - ########## - - if { [ check_weak_available ] == 1 } { - dg-init - - set lines [gcc_target_compile "$srcdir/$subdir/weak-1a.c" "weak-1a.o" object ""] - if ![string match "" $lines] then { - fail "weak-1a.o" - } else { - dg-runtest "$srcdir/$subdir/weak-1.c" "weak-1a.o" "" - file delete weak-1a.o - } - dg-finish - } elseif { [ check_weak_available ] == 0 } { - unsupported "weak-1.c" - } else { - unresolved "weak-1.c" - } - - ########## - # weak-2.c - ########## - - if { [ check_weak_available ] == 1 } { - dg-init - - set lines [gcc_target_compile "$srcdir/$subdir/weak-2a.c" "weak-2a.o" object ""] - if ![string match "" $lines] then { - fail "weak-2a.o" - } else { - set lines [gcc_target_compile "$srcdir/$subdir/weak-2b.c" "weak-2b.o" object ""] - if ![string match "" $lines] then { - fail "weak-2b.o" - } else { - dg-runtest "$srcdir/$subdir/weak-2.c" "weak-2a.o weak-2b.o" "" - file delete weak-2a.o weak-2b.o - } - } - dg-finish - } elseif { [ check_weak_available ] == 0 } { - unsupported "weak-2.c" - } else { - unresolved "weak-2.c" - } - - ########### - # alias-1.c - ########### - - dg-init - switch [check_alias_available "$srcdir/$subdir/alias-1.c"] { - yes { dg-runtest "$srcdir/$subdir/alias-1.c" "" "" } - no { unsupported "alias-1.c" } - default { fail "alias-1.c" } - } - dg-finish - - ########### - # alias-2.c - ########### - - dg-init - switch [check_alias_available "$srcdir/$subdir/alias-2.c"] { - yes { dg-runtest "$srcdir/$subdir/alias-2.c" "" "" } - no { unsupported "alias-2.c" } - default { fail "alias-2.c" } - } - dg-finish - - ########### - # wkali-1.c - ########### - - if { [ check_weak_available ] == 1 } { - dg-init - switch [check_alias_available "$srcdir/$subdir/wkali-1.c"] { - yes { dg-runtest "$srcdir/$subdir/wkali-1.c" "" "" } - no { unsupported "wkali-1.c" } - default { fail "wkali-1.c" } - } - dg-finish - } elseif { [ check_weak_available ] == 0 } { - unsupported "wkali-1.c" - } else { - unresolved "wkali-1.c" - } - - ########### - # wkali-2.c - ########### - - if { [ check_weak_available ] == 1 } { - dg-init - set lines [gcc_target_compile "$srcdir/$subdir/wkali-2a.c" "wkali-2a.o" object ""] - if ![string match "" $lines] then { - fail "wkali-2a.o" - } else { - set lines [gcc_target_compile "$srcdir/$subdir/wkali-2b.c" "wkali-2b.o" object ""] - if [string match "*only weak aliases*" $lines] then { - xfail "wkali-2b.o" - file delete $srcdir/$subdir/wkali-2.exe - } elseif ![string match "" $lines] then { - fail "wkali-2b.o" - } else { - dg-runtest "$srcdir/$subdir/wkali-2.c" "wkali-2a.o wkali-2b.o" "" - file delete wkali-2a.o wkali-2b.o - } - } - dg-finish - } elseif { [ check_weak_available ] == 0 } { - unsupported "wkali-2.c" - } else { - unresolved "wkali-2.c" - } - - ########### - # gcsec-1.c - ########### - - # Check if the ld used by gcc supports --gc-sections. - set gcc_ld [lindex [gcc_target_compile "-print-prog-name=ld" "" "none" ""] 0] - set ld_output [remote_exec host "$gcc_ld" "--help"] - - # AIX gld supports garbage collection. But AIX gcc does not support - # -ffunction-sections or -fdata-sections. - if { [ string first "--gc-sections" $ld_output ] >= 0 - && ! [istarget rs6000-*-aix*] - && ! [istarget powerpc*-*-aix*] } { - - dg-init - if [isnative] { - dg-runtest "$srcdir/$subdir/gcsec-1.c" "-ffunction-sections -fdata-sections -Wl,--gc-sections -static" "" - } else { - dg-runtest "$srcdir/$subdir/gcsec-1.c" "-ffunction-sections -fdata-sections -Wl,--gc-sections" "" - } - dg-finish - } else { - unsupported "gcsec-1.c" - } - - ### EOF ecos.exp --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/gcsec-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/gcsec-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/gcsec-1.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/gcsec-1.c 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,4 **** ! /* { dg-do run } */ #include --- 1,10 ---- ! /* AIX gld supports garbage collection. But AIX gcc does not support ! -ffunction-sections or -fdata-sections. */ ! /* { dg-do run { xfail rs6000-*-aix* powerpc*-*-aix* } } */ ! /* { dg-require-gc-sections "" } */ ! ! /* { dg-options "-ffunction-sections -fdata-sections -Wl,--gc-sections -static" } */ ! /* { dg-options "-ffunction-sections -fdata-sections -Wl,--gc-sections -static" { target native } } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/mips-abi.exp gcc-3.4.0/gcc/testsuite/gcc.dg/special/mips-abi.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/mips-abi.exp 2002-10-17 06:56:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/mips-abi.exp 2003-05-02 01:56:10.000000000 +0000 *************** if {![istarget mips*-*-*] || [gcc_target *** 29,43 **** # flags where possible. set asm_abi_flags {-32 -n32 -64 -mabi=o64 -mabi=eabi} - # Return true if the configuration uses MEABI by default. - proc is_meabi_config {} { - return [expr {[istarget mipsisa32*-*-elf*] - || [istarget mipsisa32el-*-elf*] - || [istarget mipsisa64-*-elf*] - || [istarget mipsisa64el-*-elf*] - || [istarget mipsisa64sr71k-*-elf*]}] - } - # Try to assemble mips-abi.s (an empty file), passing -v in order to # get the assembler command line. Check whether an appropriate ABI # flag is passed. --- 29,34 ---- *************** foreach flag $default_flags { *** 100,121 **** # If the command line does specify an ABI, just check for the # appropriate assembler flag. switch -- $default_abi { - -mabi=meabi { check_mips_abi "MEABI" "" "" } -mabi=eabi { check_mips_abi "EABI" "-mabi=eabi" "" } -mabi=32 { check_mips_abi "o32" "-32" "" } -mabi=n32 { check_mips_abi "n32" "-n32" "" } -mabi=o64 { check_mips_abi "o64" "-mabi=o64" "" } -mabi=64 { check_mips_abi "n64" "-64" "" } "" { ! # MEABI configs shouldn't pass an ABI flag by default ! # but the others should. It doesn't seem worthwhile ! # duplicating the configuration to ABI logic here, ! # so just accept any ABI. ! if {[is_meabi_config]} { ! check_mips_abi "default" "" "" ! } else { ! check_mips_abi "default" $asm_abi_flags "" ! } # See whether passing a -mabi flag does the right thing. # Only try ABIs that the SGI assembler also understands. check_mips_abi "o32" "-32" "-mabi=32" --- 91,107 ---- # If the command line does specify an ABI, just check for the # appropriate assembler flag. switch -- $default_abi { -mabi=eabi { check_mips_abi "EABI" "-mabi=eabi" "" } -mabi=32 { check_mips_abi "o32" "-32" "" } -mabi=n32 { check_mips_abi "n32" "-n32" "" } -mabi=o64 { check_mips_abi "o64" "-mabi=o64" "" } -mabi=64 { check_mips_abi "n64" "-64" "" } "" { ! # An ABI should be passed to the assembler by default. ! # It doesn't seem worthwhile to duplicate the ! # configuration to ABI logic here, so just accept any ABI. ! check_mips_abi "default" $asm_abi_flags "" ! # See whether passing a -mabi flag does the right thing. # Only try ABIs that the SGI assembler also understands. check_mips_abi "o32" "-32" "-mabi=32" diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/special.exp gcc-3.4.0/gcc/testsuite/gcc.dg/special/special.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/special.exp 2001-01-10 04:19:31.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/special.exp 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,4 **** ! # Copyright (C) 2001 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 --- 1,4 ---- ! # Copyright (C) 2001, 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 *************** *** 24,40 **** # Load support procs. load_lib gcc-dg.exp - ############## - # 20000419-2.c - ############## - dg-init ! switch [check_alias_available "$srcdir/$subdir/20000419-2.c"] { ! yes { dg-runtest "$srcdir/$subdir/20000419-2.c" "" "" } ! no { unsupported "20000419-2.c" } ! default { fail "20000419-2.c" } ! } dg-finish - ### EOF special.exp --- 24,32 ---- # Load support procs. load_lib gcc-dg.exp dg-init ! dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*\[1-9\].c]] \ ! "" "" dg-finish ### EOF special.exp diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/weak-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/weak-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/weak-1.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/weak-1.c 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,4 **** --- 1,6 ---- /* { dg-do run } */ + /* { dg-require-weak "" } */ + /* { dg-additional-sources weak-1a.c } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/weak-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/weak-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/weak-2.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/weak-2.c 2003-06-09 17:30:08.000000000 +0000 *************** *** 1,4 **** --- 1,6 ---- /* { dg-do run } */ + /* { dg-require-weak "" } */ + /* { dg-additional-sources "weak-2a.c weak-2b.c" } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/wkali-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/wkali-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/wkali-1.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/wkali-1.c 2003-06-05 22:18:54.000000000 +0000 *************** *** 1,4 **** --- 1,6 ---- /* { dg-do link } */ + /* { dg-require-weak "" } */ + /* { dg-require-alias "" } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/special/wkali-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/special/wkali-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/special/wkali-2.c 2000-05-23 19:30:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/special/wkali-2.c 2004-01-12 17:22:12.000000000 +0000 *************** *** 1,4 **** --- 1,7 ---- /* { dg-do run } */ + /* { dg-require-weak "" } */ + /* { dg-require-alias "" } */ + /* { dg-additional-sources "wkali-2a.c wkali-2b.c" } */ #include diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/string-opt-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/string-opt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/string-opt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/string-opt-1.c 2003-06-03 08:57:55.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Ensure mempcpy is not "optimized" into memcpy followed by addition. */ + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + + void * + fn (char *x, char *y, int z) + { + return __builtin_mempcpy (x, y, z); + } + + /* { dg-final { scan-assembler-not "memcpy" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/struct-by-value-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/struct-by-value-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/struct-by-value-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/struct-by-value-2.c 2004-01-22 09:20:34.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* This testcase caused a sanity check to abort on SPARC64 + because of a discrepancy between two functions involved + in the calculation of structure layout. */ + + /* { dg-do compile } */ + + struct S { float f1; int i1; int i2; float f2; }; + + extern void foo(struct S); + + void bar(void) + { + struct S s; + foo(s); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/struct-in-proto-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/struct-in-proto-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/struct-in-proto-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/struct-in-proto-1.c 2003-07-29 23:58:08.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile } */ + /* { dg-options "-w" } */ + int foo(struct S { int i; } s) { + return sizeof(struct S); /* { dg-bogus "incomplete type" "S visible here" } */ + } + int bar(void) { + return sizeof(struct S); /* { dg-error "incomplete type" "not here" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/switch-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/switch-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/switch-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/switch-2.c 2003-03-04 11:06:32.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* PR c/9262 */ + /* Originator: Rasmus Hahn */ + /* { dg-do compile } */ + + int foo(int i) + { + switch (i) + case 3: + return 1, + } /* { dg-error "(parse|syntax) error" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/switch-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/switch-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/switch-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/switch-3.c 2003-03-04 11:06:32.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* PR c/9262 */ + /* Originator: Rasmus Hahn */ + /* { dg-do compile } */ + + int foo(int i) + { + switch (i) + case 3: + return 1; + case 4: /* { dg-error "not within a switch statement" } */ + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/titype-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/titype-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/titype-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/titype-1.c 2004-02-02 16:14:58.000000000 +0000 *************** *** 0 **** --- 1,34 ---- + /* { dg-do run } */ + + /* Not all platforms support TImode integers. */ + #if defined(__LP64__) || defined(__sparc__) + typedef int TItype __attribute__ ((mode (TI))); /* { dg-error "no data type for mode" "TI" { target sparc-sun-solaris2.[0-6]* } } */ + #else + typedef long TItype; + #endif + + #include + + extern void abort(void); + + + void foo(int i, ...) + { + TItype q; + va_list va; + + va_start(va, i); + q = va_arg(va, TItype); + va_end(va); + + if (q != 5) + abort(); + } + + int main(void) + { + TItype q = 5; + + foo(1, q); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/alias-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/alias-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/alias-1.c 2003-01-07 00:46:25.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/alias-1.c 2004-01-19 17:05:46.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do link } */ + /* { dg-warning "visibility" "unsupported" { target sparc*-sun-solaris2.* } 22 } */ /* Test that encode_section_info handles the change from externally defined to locally defined (via hidden). Extracted from glibc. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/alpha-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/alpha-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/alpha-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/alpha-1.c 2004-01-11 23:58:28.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Make sure that we honor initial-exec. */ + /* { dg-do compile { target alpha*-*-* } } */ + /* { dg-options "" } */ + + static __thread int xyzzy __attribute__ ((tls_model ("initial-exec"))); + int foo(void) { return xyzzy; } + + /* { dg-final { scan-assembler "gottprel" } } */ + /* { dg-final { scan-assembler-not "tprel(lo|hi|16)" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/asm-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/asm-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/asm-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/asm-1.c 2003-11-29 18:54:43.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* { dg-options "-Werror" } */ + __thread int i; + + int foo () + { + asm volatile ("" :: "m" (&i)); /* { dg-error "lvalue" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/diag-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/diag-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/diag-3.c 2002-08-15 00:16:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/diag-3.c 2004-01-11 22:35:15.000000000 +0000 *************** *** 1,7 **** /* Report invalid extern and __thread combinations. */ extern int j; /* { dg-error "previous declaration" } */ ! __thread int j; /* { dg-error "follows non thread-local" } */ extern __thread int i; /* { dg-error "previous declaration" } */ int i; /* { dg-error "follows thread-local" } */ --- 1,7 ---- /* Report invalid extern and __thread combinations. */ extern int j; /* { dg-error "previous declaration" } */ ! __thread int j; /* { dg-error "follows non-thread-local" } */ extern __thread int i; /* { dg-error "previous declaration" } */ int i; /* { dg-error "follows thread-local" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-1.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,28 ---- + /* { dg-do compile } */ + /* { dg-options "-O2 -fPIC" } */ + /* { dg-options "-O2 -fPIC -mtune=i686" { target i?86-*-* } } */ + + extern __thread int thr; + + static int x; + + static void + bar (void) + { + x = 1; + } + + static void + #ifdef __i386__ + __attribute__ ((regparm (3))) + #endif + foo (const char *x, void *y, int *z) + { + bar (); + } + + void + test (const char *x, void *y) + { + foo (x, y, &thr); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-5.c 2003-01-17 07:04:42.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + /* Sched1 moved {load_tp} pattern between strlen call and the copy + of the hard return value to its pseudo. This resulted in a + reload abort, since the hard register was not spillable. */ + + extern __thread int __libc_errno __attribute__ ((tls_model ("initial-exec"))); + + struct stat64 + { + long dummy[4]; + }; + typedef __SIZE_TYPE__ size_t; + typedef unsigned long long uint64_t; + typedef int __mode_t; + + extern size_t strlen (__const char *__s) __attribute__ ((__pure__)); + extern int strcmp (__const char *__s1, __const char *__s2) + __attribute__ ((__pure__)); + + extern int __open64 (__const char *__file, int __oflag, ...); + extern int __open (__const char *__file, int __oflag, ...); + extern int __mkdir (__const char *__path, __mode_t __mode); + extern int __lxstat64 (int __ver, __const char *__filename, + struct stat64 *__stat_buf) ; + + static const char letters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; + + int + __gen_tempname (char *tmpl, int kind) + { + int len; + char *XXXXXX; + static uint64_t value; + uint64_t random_time_bits; + unsigned int count; + int fd = -1; + int save_errno = __libc_errno; + struct stat64 st; + unsigned int attempts_min = 62 * 62 * 62; + unsigned int attempts = attempts_min < 238328 ? 238328 : attempts_min; + + len = strlen (tmpl); + if (len < 6 || strcmp(&tmpl[len - 6], "XXXXXX")) + { + (__libc_errno = (22)); + return -1; + } + + XXXXXX = &tmpl[len - 6]; + + for (count = 0; count < attempts; value += 7777, ++count) + { + uint64_t v = value; + + XXXXXX[0] = letters[v % 62]; + v /= 62; + XXXXXX[1] = letters[v % 62]; + v /= 62; + XXXXXX[2] = letters[v % 62]; + v /= 62; + XXXXXX[3] = letters[v % 62]; + v /= 62; + XXXXXX[4] = letters[v % 62]; + v /= 62; + XXXXXX[5] = letters[v % 62]; + + switch (kind) + { + case 0: + fd = __open (tmpl, 02 | 01000 | 04000, 0400 | 0200); + break; + + case 1: + fd = __open64 (tmpl, 02 | 01000 | 04000, 0400 | 0200); + break; + + case 2: + fd = __mkdir (tmpl, 0400 | 0200 | 0100); + break; + + case 3: + if (__lxstat64 (2, tmpl, &st) < 0) + { + if (__libc_errno == 2) + { + (__libc_errno = (save_errno)); + return 0; + } + else + + return -1; + } + continue; + } + + if (fd >= 0) + { + (__libc_errno = (save_errno)); + return fd; + } + else if (__libc_errno != 17) + return -1; + } + + (__libc_errno = (17)); + return -1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-6.c 2003-05-16 19:35:42.000000000 +0000 *************** *** 0 **** --- 1,70 ---- + /* { dg-do compile } */ + /* { dg-options "-O2" } */ + + extern void abort (void); + extern void exit (int); + + struct A + { + char a; + int b; + long long c; + }; + extern __thread struct A a1, a2, a3, a4; + extern struct A *f1a (void); + extern struct A *f2a (void); + extern struct A *f3a (void); + extern struct A *f4a (void); + extern struct A *f5a (void); + extern struct A *f6a (void); + extern struct A *f7a (void); + extern struct A *f8a (void); + extern struct A *f9a (void); + extern struct A *f10a (void); + extern int f1b (void); + extern int f2b (void); + extern int f3b (void); + extern int f4b (void); + extern int f5b (void); + extern int f6b (void); + extern int f7b (void); + extern int f8b (void); + extern int f9b (void); + extern int f10b (void); + extern void check1 (void); + extern void check2 (void); + __thread int dummy = 12; + __thread struct A local = { 1, 2, 3 }; + + int + main (void) + { + struct A *p; + + if (local.a != 1 || local.b != 2 || local.c != 3) + abort (); + if (a1.a != 4 || a1.b != 5 || a1.c != 6) + abort (); + if (a2.a != 22 || a2.b != 23 || a2.c != 24) + abort (); + if (a3.a != 10 || a3.b != 11 || a3.c != 12) + abort (); + if (a4.a != 25 || a4.b != 26 || a4.c != 27) + abort (); + check1 (); + check2 (); + if (f1a () != &a1 || f2a () != &a2 || f3a () != &a3 || f4a () != &a4) + abort (); + p = f5a (); if (p->a != 16 || p->b != 16 + 1 || p->c != 16 + 2) + abort (); + p = f6a (); if (p->a != 19 || p->b != 19 + 1 || p->c != 19 + 2) + abort (); + if (f7a () != &a2 || f8a () != &a4) + abort (); + p = f9a (); if (p->a != 28 || p->b != 28 + 1 || p->c != 28 + 2) + abort (); + p = f10a (); if (p->a != 31 || p->b != 31 + 1 || p->c != 31 + 2) + abort (); + + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/tls/opt-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/tls/opt-7.c 2003-07-31 22:54:29.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* { dg-do compile } */ + /* { dg-options "-O2 -fPIC" } */ + + static __thread void *baz [4] __attribute__((tls_model ("initial-exec"))); + void foo (void) + { + void **u = (void **) baz; + + u[0] = 0; + u[1] = 0; + } + + /* { dg-final { scan-assembler-not "\[48\]\\+baz" { target i?86-*-* x86_64-*-* } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-attr-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-attr-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-attr-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-attr-1.c 2003-09-09 03:29:18.000000000 +0000 *************** *** 0 **** --- 1,375 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that the `const' function attribute is applied to various + builtins and that these functions are optimized away by the + compiler under the appropriate circumstances. + + Written by Kaveh Ghazi, 2003-08-04. */ + + /* { dg-do link } */ + /* { dg-options "-ffast-math" } */ + + /* These are helper macros to test combinations of functions. We test + foo() != foo() with the same arguments, and expect the compiler to + optimize away these tests of const functions. */ + + /* Just test the __builtin_ functions. */ + #define BUILTIN_TEST1(FN, TYPE) \ + extern void link_failure_builtin_##FN(void); \ + void test_builtin_##FN(TYPE x) \ + { if (__builtin_##FN(x) != __builtin_##FN(x)) link_failure_builtin_##FN(); } + + /* Just test the __builtin_ functions. */ + #define BUILTIN_TEST2(FN, TYPE) \ + extern void link_failure_builtin_##FN(void); \ + void test_builtin_##FN(TYPE x, TYPE y) \ + { if (__builtin_##FN(x,y) != __builtin_##FN(x,y)) link_failure_builtin_##FN(); } + + /* Also test the regular (non-__builtin_) function. */ + #define TEST1(FN, TYPE) \ + BUILTIN_TEST1(FN, TYPE) \ + extern void link_failure_##FN(void); \ + void test_##FN(TYPE x) { if (FN(x) != FN(x)) link_failure_##FN(); } + + /* Test the __builtin_ functions taking void arguments (with the "f" + and "l" variants). */ + #define BUILTIN_FPTEST0(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(void) \ + { if (__builtin_##FN() != __builtin_##FN()) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(void) \ + { if (__builtin_##FN##f() != __builtin_##FN##f()) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(void) \ + { if (__builtin_##FN##l() != __builtin_##FN##l()) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking one FP argument (with the "f" + and "l" variants). */ + #define BUILTIN_FPTEST1(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(double d) \ + { if (__builtin_##FN(d) != __builtin_##FN(d)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(float f) \ + { if (__builtin_##FN##f(f) != __builtin_##FN##f(f)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(long double ld) \ + { if (__builtin_##FN##l(ld) != __builtin_##FN##l(ld)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking one argument of supplied type + (with the "f" and "l" variants). */ + #define BUILTIN_FPTEST1ARG(FN, TYPE) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(TYPE x) \ + { if (__builtin_##FN(x) != __builtin_##FN(x)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(TYPE x) \ + { if (__builtin_##FN##f(x) != __builtin_##FN##f(x)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(TYPE x) \ + { if (__builtin_##FN##l(x) != __builtin_##FN##l(x)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking two FP arguments (with the "f" + and "l" variants). */ + #define BUILTIN_FPTEST2(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(double d1, double d2) \ + { if (__builtin_##FN(d1,d2) != __builtin_##FN(d1,d2)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(float f1, float f2) \ + { if (__builtin_##FN##f(f1,f2) != __builtin_##FN##f(f1,f2)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(long double ld1, long double ld2) \ + { if (__builtin_##FN##l(ld1,ld2) != __builtin_##FN##l(ld1,ld2)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking two arguments, the first one + is of a supplied type and the second one one is of FP type (with + the "f" and "l" variants). */ + #define BUILTIN_FPTEST2ARG1(FN, TYPE) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(TYPE x, double d) \ + { if (__builtin_##FN(x,d) != __builtin_##FN(x,d)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(TYPE x, float f) \ + { if (__builtin_##FN##f(x,f) != __builtin_##FN##f(x,f)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(TYPE x, long double ld) \ + { if (__builtin_##FN##l(x,ld) != __builtin_##FN##l(x,ld)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking two arguments, the first one + is of FP type and the second one one is of a supplied type (with + the "f" and "l" variants). */ + #define BUILTIN_FPTEST2ARG2(FN, TYPE) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(double d, TYPE x) \ + { if (__builtin_##FN(d,x) != __builtin_##FN(d,x)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(float f, TYPE x) \ + { if (__builtin_##FN##f(f,x) != __builtin_##FN##f(f,x)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(long double ld, TYPE x) \ + { if (__builtin_##FN##l(ld,x) != __builtin_##FN##l(ld,x)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking three FP arguments (with the + "f" and "l" variants). */ + #define BUILTIN_FPTEST3(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(double d1, double d2, double d3) \ + { if (__builtin_##FN(d1,d2,d3) != __builtin_##FN(d1,d2,d3)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(float f1, float f2, float f3) \ + { if (__builtin_##FN##f(f1,f2,f3) != __builtin_##FN##f(f1,f2,f3)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(long double ld1, long double ld2, long double ld3) \ + { if (__builtin_##FN##l(ld1,ld2,ld3) != __builtin_##FN##l(ld1,ld2,ld3)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking one complex argument (with the + "f" and "l" variants). */ + #define BUILTIN_CPTEST1(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(_Complex double d) \ + { if (__builtin_##FN(d) != __builtin_##FN(d)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(_Complex float f) \ + { if (__builtin_##FN##f(f) != __builtin_##FN##f(f)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(_Complex long double ld) \ + { if (__builtin_##FN##l(ld) != __builtin_##FN##l(ld)) link_failure_builtin_##FN##l(); } + + /* Test the __builtin_ functions taking two complex arguments (with + the "f" and "l" variants). */ + #define BUILTIN_CPTEST2(FN) \ + extern void link_failure_builtin_##FN(void); \ + extern void link_failure_builtin_##FN##f(void); \ + extern void link_failure_builtin_##FN##l(void); \ + void test_builtin_##FN(_Complex double d1, _Complex double d2) \ + { if (__builtin_##FN(d1,d2) != __builtin_##FN(d1,d2)) link_failure_builtin_##FN(); } \ + void test_builtin_##FN##f(_Complex float f1, _Complex float f2) \ + { if (__builtin_##FN##f(f1,f2) != __builtin_##FN##f(f1,f2)) link_failure_builtin_##FN##f(); } \ + void test_builtin_##FN##l(_Complex long double ld1, _Complex long double ld2) \ + { if (__builtin_##FN##l(ld1,ld2) != __builtin_##FN##l(ld1,ld2)) link_failure_builtin_##FN##l(); } + + /* These macros additionally test the non-__builtin_ functions. */ + + /* Test the functions taking one FP argument (with the "f" and "l" + variants). */ + #define FPTEST1(FN) \ + BUILTIN_FPTEST1(FN) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(double d) \ + { if (FN(d) != FN(d)) link_failure_##FN(); } \ + void test_##FN##f(float f) \ + { if (FN##f(f) != FN##f(f)) link_failure_##FN##f(); } \ + void test_##FN##l(long double ld) \ + { if (FN##l(ld) != FN##l(ld)) link_failure_##FN##l(); } + + /* Test the functions taking two FP arguments (with the "f" and "l" + variants). */ + #define FPTEST2(FN) \ + BUILTIN_FPTEST2(FN) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(double d1, double d2) \ + { if (FN(d1,d2) != FN(d1,d2)) link_failure_##FN(); } \ + void test_##FN##f(float f1, float f2) \ + { if (FN##f(f1,f2) != FN##f(f1,f2)) link_failure_##FN##f(); } \ + void test_##FN##l(long double ld1, long double ld2) \ + { if (FN##l(ld1,ld2) != FN##l(ld1,ld2)) link_failure_##FN##l(); } + + /* Test the functions taking two arguments, the first one is of a + supplied type and the second one one is of FP type (with the "f" + and "l" variants). */ + #define FPTEST2ARG1(FN, TYPE) \ + BUILTIN_FPTEST2ARG1(FN, TYPE) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(TYPE x, double d) \ + { if (FN(x,d) != FN(x,d)) link_failure_##FN(); } \ + void test_##FN##f(TYPE x, float f) \ + { if (FN##f(x,f) != FN##f(x,f)) link_failure_##FN##f(); } \ + void test_##FN##l(TYPE x, long double ld) \ + { if (FN##l(x,ld) != FN##l(x,ld)) link_failure_##FN##l(); } + + /* Test the functions taking two arguments, the first one is of FP + type and the second one one is of a supplied type (with the "f" and + "l" variants). */ + #define FPTEST2ARG2(FN, TYPE) \ + BUILTIN_FPTEST2ARG2(FN, TYPE) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(double d, TYPE x) \ + { if (FN(d,x) != FN(d,x)) link_failure_##FN(); } \ + void test_##FN##f(float f, TYPE x) \ + { if (FN##f(f,x) != FN##f(f,x)) link_failure_##FN##f(); } \ + void test_##FN##l(long double ld, TYPE x) \ + { if (FN##l(ld,x) != FN##l(ld,x)) link_failure_##FN##l(); } + + /* Test the functions taking three FP arguments (with the "f" and "l" + variants). */ + #define FPTEST3(FN) \ + BUILTIN_FPTEST3(FN) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(double d1, double d2, double d3) \ + { if (FN(d1,d2,d3) != FN(d1,d2,d3)) link_failure_##FN(); } \ + void test_##FN##f(float f1, float f2, float f3) \ + { if (FN##f(f1,f2,f3) != FN##f(f1,f2,f3)) link_failure_##FN##f(); } \ + void test_##FN##l(long double ld1, long double ld2, long double ld3) \ + { if (FN##l(ld1,ld2,ld3) != FN##l(ld1,ld2,ld3)) link_failure_##FN##l(); } + + /* Test the functions taking one complex argument (with the "f" and + "l" variants). */ + #define CPTEST1(FN) \ + BUILTIN_CPTEST1(FN) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(_Complex double d) \ + { if (FN(d) != FN(d)) link_failure_##FN(); } \ + void test_##FN##f(_Complex float f) \ + { if (FN##f(f) != FN##f(f)) link_failure_##FN##f(); } \ + void test_##FN##l(_Complex long double ld) \ + { if (FN##l(ld) != FN##l(ld)) link_failure_##FN##l(); } + + /* Test the functions taking two complex arguments (with the "f" and + "l" variants). */ + #define CPTEST2(FN) \ + BUILTIN_CPTEST2(FN) \ + extern void link_failure_##FN(void); \ + extern void link_failure_##FN##f(void); \ + extern void link_failure_##FN##l(void); \ + void test_##FN(_Complex double d1, _Complex double d2) \ + { if (FN(d1,d2) != FN(d1,d2)) link_failure_##FN(); } \ + void test_##FN##f(_Complex float f1, _Complex float f2) \ + { if (FN##f(f1,f2) != FN##f(f1,f2)) link_failure_##FN##f(); } \ + void test_##FN##l(_Complex long double ld1, _Complex long double ld2) \ + { if (FN##l(ld1,ld2) != FN##l(ld1,ld2)) link_failure_##FN##l(); } + + + /* Test the math builtins. */ + FPTEST1 (acos) + FPTEST1 (acosh) + FPTEST1 (asin) + FPTEST1 (asinh) + FPTEST1 (atan) + FPTEST2 (atan2) + FPTEST1 (atanh) + FPTEST1 (cbrt) + FPTEST1 (ceil) + FPTEST2 (copysign) + FPTEST1 (cos) + FPTEST1 (cosh) + FPTEST2 (drem) + FPTEST1 (erf) + FPTEST1 (erfc) + FPTEST1 (exp) + FPTEST1 (exp10) + FPTEST1 (exp2) + FPTEST1 (expm1) + FPTEST1 (fabs) + FPTEST2 (fdim) + FPTEST1 (floor) + FPTEST3 (fma) + FPTEST2 (fmax) + FPTEST2 (fmin) + FPTEST2 (fmod) + FPTEST1 (gamma) + BUILTIN_FPTEST0 (huge_val) + FPTEST2 (hypot) + FPTEST1 (ilogb) + BUILTIN_FPTEST0 (inf) + FPTEST1 (j0) + FPTEST1 (j1) + FPTEST2ARG1 (jn, int) + FPTEST2ARG2 (ldexp, int) + FPTEST1 (lgamma) + FPTEST1 (llrint) + FPTEST1 (llround) + FPTEST1 (log) + FPTEST1 (log10) + FPTEST1 (log1p) + FPTEST1 (log2) + FPTEST1 (logb) + FPTEST1 (lrint) + FPTEST1 (lround) + BUILTIN_FPTEST1ARG (nan, char *) + BUILTIN_FPTEST1ARG (nans, char *) + FPTEST1 (nearbyint) + FPTEST2 (nextafter) + FPTEST2 (nexttoward) + FPTEST2 (pow) + FPTEST1 (pow10) + FPTEST2 (remainder) + FPTEST1 (rint) + FPTEST1 (round) + FPTEST2 (scalb) + FPTEST2ARG2 (scalbln, int) + FPTEST2ARG2 (scalbn, int) + FPTEST1 (significand) + FPTEST1 (sin) + FPTEST1 (sinh) + FPTEST1 (sqrt) + FPTEST1 (tan) + FPTEST1 (tanh) + FPTEST1 (tgamma) + FPTEST1 (trunc) + FPTEST1 (y0) + FPTEST1 (y1) + FPTEST2ARG1 (yn, int) + + /* Test the complex math builtins. */ + /*CPTEST1 (cabs) See http://gcc.gnu.org/ml/gcc-patches/2003-09/msg00040.html */ + CPTEST1 (cacos) + CPTEST1 (cacosh) + CPTEST1 (carg) + CPTEST1 (casin) + CPTEST1 (casinh) + CPTEST1 (catan) + CPTEST1 (catanh) + CPTEST1 (ccos) + CPTEST1 (ccosh) + CPTEST1 (cexp) + CPTEST1 (cimag) + /*CPTEST1 (clog)*/ + CPTEST1 (conj) + CPTEST2 (cpow) + CPTEST1 (cproj) + CPTEST1 (creal) + CPTEST1 (csin) + CPTEST1 (csinh) + CPTEST1 (csqrt) + CPTEST1 (ctan) + CPTEST1 (ctanh) + + /* Various other const builtins. */ + TEST1 (abs, int) + BUILTIN_TEST1 (clz, int) + BUILTIN_TEST1 (clzl, long) + BUILTIN_TEST1 (clzll, long long) + BUILTIN_TEST1 (ctz, int) + BUILTIN_TEST1 (ctzl, long) + BUILTIN_TEST1 (ctzll, long long) + TEST1 (ffs, int) + TEST1 (ffsl, long) + TEST1 (ffsll, long long) + TEST1 (imaxabs, int) + TEST1 (labs, long) + TEST1 (llabs, long long) + BUILTIN_TEST1 (parity, int) + BUILTIN_TEST1 (parityl, long) + BUILTIN_TEST1 (parityll, long long) + BUILTIN_TEST1 (popcount, int) + BUILTIN_TEST1 (popcountl, long) + BUILTIN_TEST1 (popcountll, long long) + + int main(void) + { + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-explog-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-explog-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-explog-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-explog-1.c 2003-09-09 22:10:32.000000000 +0000 *************** *** 0 **** --- 1,185 ---- + /* Copyright (C) 2003 Free Software Foundation. + + Verify that built-in math function constant folding of log & exp is + correctly performed by the compiler. + + Written by Kaveh Ghazi, 2003-09-05. */ + + /* { dg-do link } */ + /* { dg-options "-ffast-math" } */ + + /* Define "e" with as many bits as found in builtins.c:dconste. */ + #define M_E 2.7182818284590452353602874713526624977572470936999595749669676277241 + #define M_EF 2.7182818284590452353602874713526624977572470936999595749669676277241F + #define M_EL 2.7182818284590452353602874713526624977572470936999595749669676277241L + /* Precision for comparison tests. */ + #define PREC 0.0000001 + #define PRECF 0.0001F + #define PRECL 0.0000000000001L + #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); + + PROTOTYPE(exp) + PROTOTYPE(exp2) + PROTOTYPE(exp10) + PROTOTYPE(log) + PROTOTYPE(log2) + PROTOTYPE(log10) + PROTOTYPE(pow10) + PROTOTYPE(sqrt) + PROTOTYPE(cbrt) + PROTOTYPE2(pow) + + void test(double d1, double d2, float f1, float f2, + long double ld1, long double ld2) + { + #define LOG_1(LOG) \ + extern void link_failure_##LOG##_1(void); \ + if (LOG(1.0) != 0.0 || LOG##f(1.0F) != 0.0F || LOG##l(1.0L) != 0.0L) \ + link_failure_##LOG##_1() + + LOG_1(log); + LOG_1(log2); + LOG_1(log10); + + #define LOG_N(LOG, BASE) \ + extern void link_failure_##LOG##_N(void); \ + if (LOG(BASE) != 1.0 || LOG##f(BASE##F) != 1.0F || LOG##l(BASE##L) != 1.0L) \ + link_failure_##LOG##_N() + + LOG_N(log, M_E); + LOG_N(log2, 2.0); + LOG_N(log10, 10.0); + + #define LOGEXP_SAME(LOG, EXP) \ + extern void link_failure_##LOG##_##EXP##_same(void); \ + if (LOG(EXP(d1)) != d1 || LOG##f(EXP##f(f1)) != f1 \ + || LOG##l(EXP##l(ld1)) != ld1) link_failure_##LOG##_##EXP##_same() + + LOGEXP_SAME(log,exp); + LOGEXP_SAME(log2,exp2); + LOGEXP_SAME(log10,exp10); + LOGEXP_SAME(log10,pow10); + + #define LOGEXP(LOG, EXP, BASE) \ + extern void link_failure_##LOG##_##EXP(void); \ + if (LOG(EXP(d1)) != d1*LOG(BASE) || LOG##f(EXP##f(f1)) != f1*LOG##f(BASE##F) \ + || LOG##l(EXP##l(ld1)) != ld1*LOG##l(BASE##L)) link_failure_##LOG##_##EXP() + + LOGEXP(log,exp,M_E); + LOGEXP(log,exp2,2.0); + LOGEXP(log,exp10,10.0); + LOGEXP(log,pow10,10.0); + LOGEXP(log2,exp,M_E); + LOGEXP(log2,exp2,2.0); + LOGEXP(log2,exp10,10.0); + LOGEXP(log2,pow10,10.0); + LOGEXP(log10,exp,M_E); + LOGEXP(log10,exp2,2.0); + LOGEXP(log10,exp10,10.0); + LOGEXP(log10,pow10,10.0); + + #define LOG_SQRT(LOG) \ + extern void link_failure_##LOG##_sqrt(void); \ + if (LOG(sqrt(d1)) != 0.5*LOG(d1) || LOG##f(sqrtf(f1)) != 0.5F*LOG##f(f1) \ + || LOG##l(sqrtl(ld1)) != 0.5L*LOG##l(ld1)) link_failure_##LOG##_sqrt() + + LOG_SQRT(log); + LOG_SQRT(log2); + LOG_SQRT(log10); + + #define LOG_CBRT(LOG) \ + extern void link_failure_##LOG##_cbrt(void); \ + if (LOG(cbrt(d1)) != (1.0/3)*LOG(d1) \ + || LOG##f(cbrtf(f1)) != (1.0F/3)*LOG##f(f1) \ + || LOG##l(cbrtl(ld1)) != (1.0L/3)*LOG##l(ld1)) link_failure_##LOG##_cbrt() + + LOG_CBRT(log); + LOG_CBRT(log2); + LOG_CBRT(log10); + + #define LOGPOW(LOG, POW) \ + extern void link_failure_##LOG##_##POW(void); \ + if (LOG(POW(d1,d2)) != d2*LOG(d1) || LOG##f(POW##f(f1,f2)) != f2*LOG##f(f1) \ + || LOG##l(POW##l(ld1,ld2)) != ld2*LOG##l(ld1)) link_failure_##LOG##_##POW() + + LOGPOW(log,pow); + LOGPOW(log2,pow); + LOGPOW(log10,pow); + + #define EXP_0(EXP) \ + extern void link_failure_##EXP##_0(void); \ + if (EXP(0.0) != 1.0 || EXP##f(0.0F) != 1.0F || EXP##l(0.0L) != 1.0L) \ + link_failure_##EXP##_0() + + EXP_0(exp); + EXP_0(exp2); + EXP_0(exp10); + EXP_0(pow10); + + #define EXP_N(EXP, BASE) \ + extern void link_failure_##EXP##_N(void); \ + if (EXP(1.0) != BASE || EXP##f(1.0F) != BASE##F || EXP##l(1.0L) != BASE##L) \ + link_failure_##EXP##_N() + + EXP_N(exp, M_E); + EXP_N(exp2, 2.0); + EXP_N(exp10, 10.0); + EXP_N(pow10, 10.0); + + #define EXP_INT(EXP, BASE) \ + extern void link_failure_##EXP##_INT(void); \ + if (EXP(5.0) < (BASE)*(BASE)*(BASE)*(BASE)*(BASE) - PREC \ + || EXP(5.0) > (BASE)*(BASE)*(BASE)*(BASE)*(BASE) + PREC \ + || EXP##f(5.0F) < (BASE##F)*(BASE##F)*(BASE##F)*(BASE##F)*(BASE##F) -PRECF \ + || EXP##f(5.0F) > (BASE##F)*(BASE##F)*(BASE##F)*(BASE##F)*(BASE##F) +PRECF \ + || EXP##l(5.0L) < (BASE##L)*(BASE##L)*(BASE##L)*(BASE##L)*(BASE##L) -PRECL \ + || EXP##l(5.0L) > (BASE##L)*(BASE##L)*(BASE##L)*(BASE##L)*(BASE##L) +PRECL) \ + link_failure_##EXP##_INT() + + EXP_INT(exp, M_E); + EXP_INT(exp2, 2.0); + EXP_INT(exp10, 10.0); + EXP_INT(pow10, 10.0); + + #define EXPLOG_SAME(EXP, LOG) \ + extern void link_failure_##EXP##_##LOG##_same(void); \ + if (EXP(LOG(d1)) != d1 || EXP##f(LOG##f(f1)) != f1 \ + || EXP##l(LOG##l(ld1)) != ld1) link_failure_##EXP##_##LOG##_same() + + EXPLOG_SAME(exp, log); + EXPLOG_SAME(exp2, log2); + EXPLOG_SAME(exp10, log10); + EXPLOG_SAME(pow10, log10); + + #define EXPXEXP(EXP) \ + extern void link_failure_##EXP##X##EXP(void); \ + if (EXP(d1)*EXP(d2) != EXP(d1+d2) || EXP##f(f1)*EXP##f(f2) != EXP##f(f1+f2) \ + || EXP##l(ld1)*EXP##l(ld2) != EXP##l(ld1+ld2)) link_failure_##EXP##X##EXP() + + EXPXEXP(exp); + EXPXEXP(exp2); + EXPXEXP(exp10); + EXPXEXP(pow10); + + #define DIVEXP(EXP) \ + extern void link_failure_div1_##EXP(void); \ + if (d1/EXP(d2) != d1*EXP(-d2) || f1/EXP##f(f2) != f1*EXP##f(-f2) \ + || ld1/EXP##l(ld2) != ld1*EXP##l(-ld2)) link_failure_div1_##EXP(); \ + extern void link_failure_div2_##EXP(void); \ + if (EXP(d1)/EXP(d2) != EXP(d1-d2) || EXP##f(f1)/EXP##f(f2) != EXP##f(f1-f2) \ + || EXP##l(ld1)/EXP##l(ld2) != EXP##l(ld1-ld2)) link_failure_div2_##EXP() + + DIVEXP(exp); + DIVEXP(exp2); + DIVEXP(exp10); + DIVEXP(pow10); + } + + int main (void) + { + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-math-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-math-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-math-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-math-1.c 2003-08-02 19:14:25.000000000 +0000 *************** *** 0 **** --- 1,131 ---- + /* Copyright (C) 2002, 2003 Free Software Foundation. + + Verify that built-in math function constant folding of constant + arguments is correctly performed by the compiler. + + Written by Roger Sayle, 16th August 2002. */ + + /* { dg-do link } */ + + /* All references to link_error should go away at compile-time. */ + extern void link_error(void); + + void test (float f, double d, long double ld) + { + if (sqrt (0.0) != 0.0) + link_error (); + + if (sqrt (1.0) != 1.0) + link_error (); + + if (exp (0.0) != 1.0) + link_error (); + + if (exp (1.0) <= 2.71 || exp (1.0) >= 2.72) + link_error (); + + if (log (1.0) != 0.0) + link_error (); + + if (sin (0.0) != 0.0) + link_error (); + + if (cos (0.0) != 1.0) + link_error (); + + if (tan (0.0) != 0.0) + link_error (); + + if (atan (0.0) != 0.0) + link_error (); + + if (4.0*atan (1.0) <= 3.14 || 4.0*atan (1.0) >= 3.15) + link_error (); + + if (pow (d, 0.0) != 1.0) + link_error (); + + if (pow (1.0, d) != 1.0) + link_error (); + + + if (sqrtf (0.0F) != 0.0F) + link_error (); + + if (sqrtf (1.0F) != 1.0F) + link_error (); + + if (expf (0.0F) != 1.0F) + link_error (); + + if (expf (1.0F) <= 2.71F || expf (1.0F) >= 2.72F) + link_error (); + + if (logf (1.0F) != 0.0F) + link_error (); + + if (sinf (0.0F) != 0.0F) + link_error (); + + if (cosf (0.0F) != 1.0F) + link_error (); + + if (tanf (0.0F) != 0.0F) + link_error (); + + if (atanf (0.0F) != 0.0F) + link_error (); + + if (4.0F*atanf (1.0F) <= 3.14F || 4.0F*atanf (1.0F) >= 3.15F) + link_error (); + + if (powf (f, 0.0F) != 1.0F) + link_error (); + + if (powf (1.0F, f) != 1.0F) + link_error (); + + + if (sqrtl (0.0L) != 0.0L) + link_error (); + + if (sqrtl (1.0L) != 1.0L) + link_error (); + + if (expl (0.0L) != 1.0L) + link_error (); + + if (expl (1.0L) <= 2.71L || expl (1.0L) >= 2.72L) + link_error (); + + if (logl (1.0L) != 0.0L) + link_error (); + + if (sinl (0.0L) != 0.0L) + link_error (); + + if (cosl (0.0L) != 1.0L) + link_error (); + + if (tanl (0.0L) != 0.0L) + link_error (); + + if (atanl (0.0) != 0.0L) + link_error (); + + if (4.0L*atanl (1.0L) <= 3.14L || 4.0L*atanl (1.0L) >= 3.15L) + link_error (); + + if (powl (ld, 0.0L) != 1.0L) + link_error (); + + if (powl (1.0L, ld) != 1.0L) + link_error (); + } + + int main() + { + test (3.0, 3.0F, 3.0L); + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-noret-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-noret-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-noret-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-noret-1.c 2003-06-03 17:00:23.000000000 +0000 *************** *** 0 **** --- 1,78 ---- + /* Test for builtin noreturn attributes. */ + /* Origin: Joseph Myers */ + /* { dg-options "-multiply_defined suppress" { target powerpc-*-darwin* } } */ + /* { dg-do link } */ + + extern void abort (void); + extern void exit (int); + extern void _exit (int); + extern void _Exit (int); + + extern void tabort (void); + extern void texit (void); + extern void t_exit (void); + extern void t_Exit (void); + + extern void link_failure (void); + + /* Some libcs have _exit and/or _Exit, and won't allow it to be re-defined, + so make it weak. */ + #pragma weak _exit + #pragma weak _Exit + + int + main (void) + { + volatile int i = 0; + if (i) + tabort (); + if (i) + texit (); + if (i) + t_exit (); + if (i) + t_Exit (); + exit (0); + } + + void + tabort (void) + { + abort (); + link_failure (); + } + + void + texit (void) + { + exit (1); + link_failure (); + } + + void + t_exit (void) + { + _exit (1); + link_failure (); + } + + /* Some non-Unix libcs might not have _exit. */ + void + _exit (int i) + { + abort (); + } + + void + t_Exit (void) + { + _Exit (1); + link_failure (); + } + + /* Some libcs might not have _Exit. */ + void + _Exit (int i) + { + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-noret-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-noret-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/builtin-noret-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/builtin-noret-2.c 2003-06-03 17:00:23.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + /* Test for builtin noreturn attributes when the visible declarations + are function-local. Modified from builtin-noret-1.c by Zack Weinberg + . */ + /* { dg-options "-multiply_defined suppress" { target powerpc-*-darwin* } } */ + /* { dg-do link } */ + + extern void tabort (void); + extern void texit (void); + extern void t_exit (void); + extern void t_Exit (void); + + extern void link_failure (void); + + int + main (void) + { + volatile int i = 0; + if (i) + tabort (); + if (i) + texit (); + if (i) + t_exit (); + if (i) + t_Exit (); + exit (0); + } + + void + tabort (void) + { + extern void abort (void); + abort (); + link_failure (); + } + + void + texit (void) + { + extern void exit (int); + exit (1); + link_failure (); + } + + void + t_exit (void) + { + extern void _exit (int); + /* Some non-Unix libcs have _exit, and won't allow it to be re-defined, + so make it weak. */ + #pragma weak _exit + _exit (1); + link_failure (); + } + + /* Some non-Unix libcs might not have _exit. */ + /* Some non-Unix libcs have _exit, and won't allow it to be re-defined, + so make it weak. */ + #pragma weak _exit + void + _exit (int i) + { + abort (); + } + + void + t_Exit (void) + { + extern void _Exit (int); + /* Some libcs have _Exit, and won't allow it to be re-defined, + so make it weak. */ + #pragma weak _Exit + _Exit (1); + link_failure (); + } + + /* Some libcs might not have _Exit. */ + /* Some libcs have _Exit, and won't allow it to be re-defined, + so make it weak. */ + #pragma weak _Exit + void + _Exit (int i) + { + abort (); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/mips-clobber-at.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/mips-clobber-at.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/mips-clobber-at.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/mips-clobber-at.c 2004-01-25 10:19:04.000000000 +0000 *************** *** 0 **** --- 1,4 ---- + /* "$1" used to be mapped to the internal frame pointer. */ + /* { dg-do compile { target mips*-*-* } } */ + /* { dg-options "" } */ + int foo () { asm volatile ("#" ::: "$1"); } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/torture/mips-sdata-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/torture/mips-sdata-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/torture/mips-sdata-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/torture/mips-sdata-1.c 2004-03-07 10:52:45.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* Check that sdata-accesses are applied regardless of size or ABI. */ + /* { dg-options -mexplicit-relocs } */ + /* { dg-do compile { target mips*-*-elf* } } */ + + struct s { int x[4]; }; + struct s my_struct __attribute__((__section__(".sdata"))); + + int f() { return my_struct.x[0]; } + + /* { dg-final { scan-assembler {gp_?rel\(my_struct} } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/typedef-redecl.c gcc-3.4.0/gcc/testsuite/gcc.dg/typedef-redecl.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/typedef-redecl.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/typedef-redecl.c 2004-01-13 02:52:37.000000000 +0000 *************** *** 0 **** --- 1,6 ---- + /* Redeclaration of typedef (invalid but accepted in system headers) + causes ICE; PR 13656. Test case by Richard Sandiford , + reduced from glibc. */ + + #include "typedef-redecl.h" + x a; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/typedef-redecl.h gcc-3.4.0/gcc/testsuite/gcc.dg/typedef-redecl.h *** gcc-3.3.3/gcc/testsuite/gcc.dg/typedef-redecl.h 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/typedef-redecl.h 2004-01-13 02:52:37.000000000 +0000 *************** *** 0 **** --- 1,7 ---- + /* Redeclaration of typedef (invalid but accepted in system headers) + causes ICE; PR 13656. Test case by Richard Sandiford , + reduced from glibc. */ + + #pragma GCC system_header + typedef int x; + typedef int x; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp2.c gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp2.c 2001-05-15 02:45:32.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp2.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 4,13 **** /* { dg-do compile } */ /* { dg-options "" } */ ! /* { dg-options "-O0 -m64" { target sparc64-*-* } } */ ! /* { dg-options "-O0 -m64" { target sparcv9-*-* } } */ ! /* { dg-options "" { target sparc-*-solaris2.[0-6] } } */ ! /* { dg-options "" { target sparc-*-solaris2.[0-6].* } } */ short foo() { short i = (short)(1<<15); --- 4,10 ---- /* { dg-do compile } */ /* { dg-options "" } */ ! /* { dg-options "-O0" { target sparc64-*-* sparcv9-*-* } } */ short foo() { short i = (short)(1<<15); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp4.c gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp4.c 2002-01-16 17:44:24.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp4.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 1,10 **** /* Simplified from PR target/5309. */ /* { dg-do compile } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -m64 -mcpu=ultrasparc" { target sparc64-*-* } } */ ! /* { dg-options "-O2 -m64 -mcpu=ultrasparc" { target sparcv9-*-* } } */ ! /* { dg-options "-O2" { target sparc-*-solaris2.[0-6] } } */ ! /* { dg-options "-O2" { target sparc-*-solaris2.[0-6].* } } */ long bar (unsigned int); long foo (long x, unsigned int y) --- 1,7 ---- /* Simplified from PR target/5309. */ /* { dg-do compile } */ /* { dg-options "-O2" } */ ! /* { dg-options "-O2 -mcpu=ultrasparc" { target sparc64-*-* sparcv9-*-* } } */ long bar (unsigned int); long foo (long x, unsigned int y) diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp8.c gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/ultrasp8.c 2003-04-12 17:47:30.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/ultrasp8.c 2004-04-05 04:15:51.000000000 +0000 *************** *** 1,7 **** /* PR target/10067 */ /* Originator: */ /* { dg-do compile { target sparc*-*-* } } */ ! /* { dg-options "-O2 -m64 -mtune=supersparc" { target sparc64-*-* } } */ struct _reent; --- 1,7 ---- /* PR target/10067 */ /* Originator: */ /* { dg-do compile { target sparc*-*-* } } */ ! /* { dg-options "-O2 -mtune=supersparc" { target sparc64-*-* sparcv9-*-* } } */ struct _reent; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/unaligned-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/unaligned-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/unaligned-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/unaligned-1.c 2003-12-01 07:15:31.000000000 +0000 *************** *** 0 **** --- 1,49 ---- + /* PR middle-end/7847 */ + /* Originator: */ + /* { dg-do run } */ + + /* This used to fail on SPARC at runtime because of + an unaligned memory access. */ + + typedef char int8_t; + typedef short int16_t; + typedef int int32_t; + typedef unsigned char uint8_t; + typedef unsigned short uint16_t; + typedef unsigned int uint32_t; + + typedef struct { + uint32_t address; + uint16_t size; + } __attribute__ ((packed)) sml_agl_data_t; + + typedef struct { + sml_agl_data_t data[9]; + } __attribute__ ((packed)) sml_agli_t; + + typedef struct { + sml_agli_t sml_agli; + } __attribute__ ((packed)) dsi_t; + + typedef struct { + int a; + dsi_t dsi_pack; + } dvd_priv_t; + + int dvd_read_sector(dvd_priv_t *d, unsigned char* data) + { + int i, skip=0; + + for (i=0; i < 9; i++) + if ((skip=d->dsi_pack.sml_agli.data[i].address) != 0) + break; + + return skip; + } + + int main(void) + { + static dvd_priv_t dvd_priv; + dvd_read_sector(&dvd_priv, 0); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-10.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-10.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-10.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-10.c 2003-01-31 06:57:51.000000000 +0000 *************** *** 0 **** --- 1,109 ---- + /* { dg-do compile } */ + /* { dg-options "-O2 -Wall" } */ + /* On Alpha EV4, dead code elimination and cfg simplification conspired + to leave the register containing 'C' marked live, though all references + to the variable had been removed. */ + + struct operand_data + { + struct operand_data *next; + int index; + const char *predicate; + const char *constraint; + int mode; + unsigned char n_alternatives; + char address_p; + char strict_low; + char eliminable; + char seen; + }; + + struct data + { + struct data *next; + const char *name; + const char *template; + int code_number; + int index_number; + int lineno; + int n_operands; + int n_dups; + int n_alternatives; + int operand_number; + int output_format; + struct operand_data operand[40]; + }; + + extern void message_with_line (int, const char *, ...) + __attribute__ ((__format__ (__printf__, 2, 3))); + extern int have_error; + + extern char *strchr (__const char *__s, int __c) __attribute__ ((__pure__)); + + void + validate_insn_alternatives (d) + struct data *d; + { + int n = 0, start; + + for (start = 0; start < d->n_operands; start++) + if (d->operand[start].n_alternatives > 0) + { + int len, i; + const char *p; + char c; /* { dg-bogus "used uninitialized" "uninitialized variable warning" } */ + int which_alternative = 0; + int alternative_count_unsure = 0; + + for (p = d->operand[start].constraint; (c = *p); p += len) + { + len = 1; + + if (len < 1 || (len > 1 && strchr (",#*+=&%!0123456789", c))) + { + message_with_line (d->lineno, + "invalid length %d for char '%c' in alternative %d of operand %d", + len, c, which_alternative, start); + len = 1; + have_error = 1; + } + + if (c == ',') + { + which_alternative++; + continue; + } + + for (i = 1; i < len; i++) + if (p[i] == '\0') + { + message_with_line (d->lineno, + "NUL in alternative %d of operand %d", + which_alternative, start); + alternative_count_unsure = 1; + break; + } + else if (strchr (",#*", p[i])) + { + message_with_line (d->lineno, + "'%c' in alternative %d of operand %d", + p[i], which_alternative, start); + alternative_count_unsure = 1; + } + } + if (alternative_count_unsure) + have_error = 1; + else if (n == 0) + n = d->operand[start].n_alternatives; + else if (n != d->operand[start].n_alternatives) + { + message_with_line (d->lineno, + "wrong number of alternatives in operand %d", + start); + have_error = 1; + } + } + + + d->n_alternatives = n; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-C.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-C.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-C.c 2003-12-10 15:18:13.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-C.c 2003-11-05 20:15:02.000000000 +0000 *************** typedef int TItype __attribute__ ((mode *** 9,14 **** --- 9,15 ---- typedef long TItype; #endif + TItype __subvdi3 (TItype a, TItype b) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-D.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-D.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-D.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-D.c 2003-08-19 20:12:43.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test we do not warn about initializing variable with self. */ + /* { dg-do compile } */ + /* { dg-options "-O -Wuninitialized" } */ + + int f() + { + int i = i; + return i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-E.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-E.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-E.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-E.c 2003-08-20 02:03:59.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test we do warn about initializing variable with self when -Winit-self is supplied. */ + /* { dg-do compile } */ + /* { dg-options "-O -Wuninitialized -Winit-self" } */ + + int f() + { + int i = i; /* { dg-warning "i" "uninitialized variable warning" } */ + return i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-F.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-F.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-F.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-F.c 2003-08-19 20:12:43.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test we do warn about initializing variable with self in the initialization. */ + /* { dg-do compile } */ + /* { dg-options "-O -Wuninitialized" } */ + + int f() + { + int i = i + 1; /* { dg-warning "i" "uninitialized variable warning" } */ + return i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-G.c gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-G.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/uninit-G.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/uninit-G.c 2003-08-19 20:12:43.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test we do not warn about initializing variable with address of self in the initialization. */ + /* { dg-do compile } */ + /* { dg-options "-O -Wuninitialized" } */ + + void *f() + { + void *i = &i; + return i; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/unroll-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/unroll-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/unroll-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/unroll-1.c 2003-05-16 19:35:43.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* PR optimization/8599 */ + /* { dg-do run } */ + /* { dg-options "-O2 -funroll-loops" } */ + /* { dg-options "-mtune=k6 -O2 -funroll-loops" { target i?86-*-* } } */ + + extern void abort (void); + + int array[6] = { 1,2,3,4,5,6 }; + + void foo() + { + int i; + + for (i = 0; i < 5; i++) + array[i] = 0; + } + + int main() + { + foo(); + if (array[0] || array [1] || array[2] || array[3] || array[4]) + abort (); + if (array[5] != 6) + abort (); + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/unused-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/unused-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/unused-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/unused-5.c 2003-05-05 18:29:29.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile } */ + /* { dg-options "-Wunused" } */ + /* { dg-final { scan-assembler "string_to_look_for" } } */ + + /* 'volatile' variables get output and don't produce a warning about being + unused. */ + static volatile char string[] + = "string_to_look_for"; /* { dg-bogus "not used" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/va-arg-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/va-arg-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/va-arg-1.c 2002-03-31 09:52:42.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/va-arg-1.c 2004-02-23 12:46:57.000000000 +0000 *************** volatile int i; *** 7,13 **** void foo() { ! i = va_arg(v, char); /* { dg-warning "is promoted to|so you should" "char" } */ ! i = va_arg(v, short); /* { dg-warning "is promoted to" "short" } */ ! i = va_arg(v, float); /* { dg-warning "is promoted to" "float" } */ } --- 7,13 ---- void foo() { ! i = va_arg(v, char); /* { dg-warning "is promoted to|so you should|abort" "char" } */ ! i = va_arg(v, short); /* { dg-warning "is promoted to|abort" "short" } */ ! i = va_arg(v, float); /* { dg-warning "is promoted to|abort" "float" } */ } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-1.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Test visibility attribute on function definition. */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*foo" } } */ + + void + __attribute__((visibility ("hidden"))) + foo() + { } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-2.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* Test that visibility attribute on declaration extends to definition. */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*foo" } } */ + + void + __attribute__((visibility ("hidden"))) + foo(); + + void foo() { } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-3.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* Test visibility attribute on forward declaration of global variable */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*xyzzy" } } */ + + int + __attribute__((visibility ("hidden"))) + xyzzy = 5; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-4.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* Test visibility attribute on forward declaration of global variable */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*xyzzy" } } */ + + extern int + __attribute__((visibility ("hidden"))) + xyzzy; + + int xyzzy = 5; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-5.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test visibility attribute on definition of a function that has + already had a forward declaration. */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*foo" } } */ + + void foo(); + + void + __attribute__((visibility ("hidden"))) + foo() + { } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-6.c 2003-12-10 06:34:45.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* Test visibility attribute on definition of global variable that has + already had a forward declaration. */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*xyzzy" } } */ + + extern int xyzzy; + + int + __attribute__((visibility ("hidden"))) + xyzzy = 5; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-7.c 2004-01-11 01:18:58.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* Test warning from conflicting visibility specifications. */ + /* { dg-do compile } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*xyzzy" } } */ + + extern int + __attribute__((visibility ("hidden"))) + xyzzy; /* { dg-warning "previous declaration" "" } */ + + int + __attribute__((visibility ("protected"))) + xyzzy = 5; /* { dg-warning "different visibility" "" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/visibility-8.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/visibility-8.c 2004-02-08 01:52:51.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Test hidden visibility on built-in functions (for libc). PR 13856. */ + /* { dg-do compile } */ + /* { dg-options "-std=gnu99" } */ + /* { dg-require-visibility "" } */ + /* { dg-final { scan-assembler "\\.hidden.*__GI_fputs_unlocked" } } */ + + int fputs_unlocked (const char *restrict, int *restrict) + __asm__ ("__GI_fputs_unlocked") + __attribute__ ((visibility ("hidden"))); + + int + fputs_unlocked (str, fp) + const char *str; + int *fp; + { + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/volatile1.c gcc-3.4.0/gcc/testsuite/gcc.dg/volatile1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/volatile1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/volatile1.c 2003-10-20 22:02:17.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* PR c/12553: we were erroneously setting TREE_SIDE_EFFECTS on &y, which + confused tree-ssa. */ + + void f() + { + int x; + volatile int y; + &x == &y; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/warn-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/warn-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/warn-1.c 2002-10-26 01:15:16.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/warn-1.c 2003-11-12 19:53:17.000000000 +0000 *************** *** 5,14 **** static void foo (p) int p; ! { /* { dg-warning "passing arg of" } */ } ! static void bar (void) { void *vp; --- 5,14 ---- static void foo (p) int p; ! { /* { dg-warning "passing arg 1 of" } */ } ! void bar (void) { void *vp; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/wchar_t-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/wchar_t-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/wchar_t-1.c 2002-10-26 14:03:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/wchar_t-1.c 2003-05-26 18:10:20.000000000 +0000 *************** *** 5,11 **** match. */ #define _STDDEF_H ! #include __WCHAR_TYPE__ __wc_t__; wchar_t *wc_t_p; --- 5,11 ---- match. */ #define _STDDEF_H ! #include /* { dg-excess-errors "" { xfail *-*-darwin* } } */ __WCHAR_TYPE__ __wc_t__; wchar_t *wc_t_p; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-1.c 2003-07-28 20:15:44.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* Test for -Wdeclaration-after-statement emitting warnings when no + standard-specifying option is given. See also c9?-mixdecl-*. */ + /* Origin: Joseph Myers */ + /* { dg-do run } */ + /* { dg-options "-Wdeclaration-after-statement" } */ + + extern void abort (void); + extern void exit (int); + + int + main (void) + { + int i = 0; + if (i != 0) + abort (); + i++; + if (i != 1) + abort (); + int j = i; /* { dg-warning "warning" "declaration after statement" } */ + if (j != 1) + abort (); + struct foo { int i0; } k = { 4 }; /* { dg-warning "warning" "declaration after statement" } */ + if (k.i0 != 4) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wdeclaration-after-statement-2.c 2003-07-28 20:15:44.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + /* Test for C99 mixed declarations and code giving warnings, not error with + -Wdeclaration-after-statement. See also c9?-mixdecl-*. */ + /* Origin: Joseph Myers */ + /* { dg-do run } */ + /* { dg-options "-std=c99 -pedantic-errors -Wdeclaration-after-statement" } */ + + extern void abort (void); + extern void exit (int); + + int + main (void) + { + int i = 0; + if (i != 0) + abort (); + i++; + if (i != 1) + abort (); + int j = i; /* { dg-warning "warning" "declaration-after-statement" } */ + if (j != 1) + abort (); + struct foo { int i0; } k = { 4 }; /* { dg-warning "warning" "declaration-after-statement" } */ + if (k.i0 != 4) + abort (); + exit (0); + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/typeof-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/typeof-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/typeof-2.c 2002-10-21 15:42:22.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/typeof-2.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,5 **** --- 1,6 ---- /* Test typeof with __asm redirection. */ /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-O2" } */ extern int foo1 (int x) __asm ("baz1"); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-1.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-1.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?a" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-2.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-2.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?ffoo1a" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-3.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-3.c 2003-10-12 22:09:28.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?ffoo1a" } } */ *************** extern void * ffoo1f (void); *** 53,59 **** extern void * ffoox1f (void); void * foo1f (void) { ! if (ffoo1f) ffoo1f (); return 0; } --- 54,60 ---- extern void * ffoox1f (void); void * foo1f (void) { ! if (ffoo1f) /* { dg-warning "" } */ ffoo1f (); return 0; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-4.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-4.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?vfoo1a" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-5.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-5.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?vfoo1a" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-6.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-6.c 2004-01-09 20:03:58.000000000 +0000 *************** *** 1,6 **** /* { dg-do compile } */ extern void * foo (void); void * foo (void) { return (void *)foo; } /* { dg-error "precede" } */ ! #pragma weak foo --- 1,7 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ extern void * foo (void); void * foo (void) { return (void *)foo; } /* { dg-error "precede" } */ ! /* { dg-error "function pointer" "pointer conversion" { target *-*-* } 5 } */ #pragma weak foo diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-7.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-7.c 2004-01-09 20:03:58.000000000 +0000 *************** *** 1,6 **** /* { dg-do compile } */ extern void * foo (void); void * foo (void) { return (void *)foo; } /* { dg-error "precede" } */ ! extern void * foo (void) __attribute__((weak)); --- 1,7 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ extern void * foo (void); void * foo (void) { return (void *)foo; } /* { dg-error "precede" } */ ! /* { dg-error "function pointer" "pointer conversion" { target *-*-* } 5 } */ extern void * foo (void) __attribute__((weak)); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-8.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-8.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-8.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-8.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do assemble } */ + /* { dg-require-weak "" } */ __attribute__ ((weak)) int i; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-9.c gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-9.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak-9.c 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak-9.c 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** --- 1,5 ---- /* { dg-do compile } */ + /* { dg-require-weak "" } */ /* { dg-options "-fno-common" } */ /* { dg-final { scan-assembler "weak\[^ \t\]*\[ \t\]_?f1" } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak.exp gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak.exp *** gcc-3.3.3/gcc/testsuite/gcc.dg/weak/weak.exp 2002-09-06 13:00:39.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/weak/weak.exp 2003-06-06 21:34:41.000000000 +0000 *************** *** 1,4 **** ! # 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 --- 1,4 ---- ! # Copyright (C) 1997, 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 *************** if ![info exists DEFAULT_CFLAGS] then { *** 25,41 **** set DEFAULT_CFLAGS " -ansi -pedantic-errors" } ! if { [ check_weak_available ] == 1 } { ! ! dg-init ! ! dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] \ ! "" $DEFAULT_CFLAGS ! ! dg-finish ! ! } elseif { [ check_weak_available ] == 0 } { ! unsupported "gcc.dg/weak" ! } else { ! unresolved "gcc.dg/weak" ! } --- 25,31 ---- set DEFAULT_CFLAGS " -ansi -pedantic-errors" } ! dg-init ! dg-runtest [lsort [glob -nocomplain $srcdir/$subdir/*.\[cS\]]] \ ! "" $DEFAULT_CFLAGS ! dg-finish diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-1.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,13 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + + void q(void); + inline int t(void) + { + int ret; + q(); + ret = t(); /* We define sane semantics for inline keyword on recursive + functions, so do not warn here. */ + q(); + return ret; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-2.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + + inline int q(void); /* { dg-warning "body not available" "" } */ + inline int t(void) + { + return q(); /* { dg-warning "called from here" "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-3.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2 --param max-inline-insns-single=1" } */ + + void big (void); + inline int q(void) + { /* { dg-warning "max-inline-insns-single" "" } */ + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + } + inline int t (void) + { + return q (); /* { dg-warning "called from here" "" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-4.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O1 -fno-unit-at-a-time" } */ + + inline int q(void); /* { dg-warning "body not available" } */ + inline int t(void) + { + return q(); /* { dg-warning "called from here" } */ + } + int q(void) + { + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-5.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,29 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2 --param inline-unit-growth=0" } */ + + void big (void); + inline int q(void) + { /* { dg-warning "inline-unit-growth" } */ + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + } + inline int q1(void) + { + big(); + big(); + big(); + } + int t (void) + { + /* We allow one inlining over limit. */ + q1(); + return q (); /* { dg-warning "called from here" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-6.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-6.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-6.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-6.c 2004-01-04 14:39:13.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2 --param large-function-growth=0 --param large-function-insns=1" } */ + + void big (void); + inline int q(void) + { /* { dg-warning "large-function-growth" } */ + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + big(); + } + inline int t (void) + { + return q (); /* { dg-warning "called from here" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/winline-7.c gcc-3.4.0/gcc/testsuite/gcc.dg/winline-7.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/winline-7.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/winline-7.c 2004-01-07 12:40:42.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* { dg-do compile } */ + /* { dg-options "-Winline -O2" } */ + + void big (void); + inline void *q (void) + { /* { dg-warning "(function not inlinable|alloca)" } */ + return alloca (10); + } + inline void *t (void) + { + return q (); /* { dg-warning "called from here" } */ + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/wint_t-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/wint_t-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/wint_t-1.c 2002-10-26 14:03:12.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/wint_t-1.c 2003-05-26 18:10:20.000000000 +0000 *************** *** 5,11 **** match. */ #define _STDDEF_H ! #include __WINT_TYPE__ __wi_t__; wint_t *wi_t_p; --- 5,11 ---- match. */ #define _STDDEF_H ! #include /* { dg-excess-errors "" { xfail *-*-darwin* } } */ __WINT_TYPE__ __wi_t__; wint_t *wi_t_p; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wold-style-definition-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wold-style-definition-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wold-style-definition-1.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wold-style-definition-1.c 2003-09-15 09:31:16.000000000 +0000 *************** *** 0 **** --- 1,24 ---- + /* Test for warning about old-style function definition. */ + + /* Origin: Andreas Jaeger */ + /* { dg-do compile } */ + /* { dg-options "-Wold-style-definition" } */ + + void + bar (a) int a; { } /* { dg-warning "old-style parameter declaration" } */ + + void bar1 () {} /* { dg-warning "old-style parameter declaration" } */ + + extern void bar2 (void); + + void bar2 () {} /* { dg-warning "old-style parameter declaration" } */ + + extern void bar3 (int); + + void bar3 (a) {} /* { dg-warning "old-style parameter declaration" } */ + + void bar4 (a) {} /* { dg-warning "old-style parameter declaration" } */ + + void bar5 (int a) {} + + void bar6 (void) {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wold-style-definition-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wold-style-definition-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wold-style-definition-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wold-style-definition-2.c 2003-10-02 00:07:50.000000000 +0000 *************** *** 0 **** --- 1,10 ---- + /* PR c/12466 + Test for not warning about ellipsises with -Wold-style-definition. */ + + /* Origin: Kelley Cook */ + /* { dg-do compile } */ + /* { dg-options "-Wold-style-definition" } */ + + void bar1 ( ... ) {} /* { dg-error "ISO C requires a named argument" } */ + + void bar2 (int a, ... ) {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wpadded.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wpadded.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wpadded.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wpadded.c 2003-06-09 23:04:50.000000000 +0000 *************** *** 0 **** --- 1,9 ---- + /* Source: EMC. */ + + /* { dg-do compile } */ + /* { dg-options "-Wpadded" } */ + + struct foo { + char bar; + long baz; /* { dg-warning "padding struct to align" } */ + } futz; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wshadow-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wshadow-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wshadow-1.c 2001-12-05 23:20:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wshadow-1.c 2004-01-11 01:18:58.000000000 +0000 *************** void foo (double decl1) /* { dg-warning *** 10,19 **** { } ! void foo1 (int d) { double d; /* { dg-bogus "warning" "warning in place of error" } */ ! /* { dg-error "shadows a parameter" "" { target *-*-* } 15 } */ } void foo2 (int d) /* { dg-warning "shadowed declaration" } */ --- 10,19 ---- { } ! void foo1 (int d) /* { dg-warning "previous definition" } */ { double d; /* { dg-bogus "warning" "warning in place of error" } */ ! /* { dg-error "redeclared as different" "" { target *-*-* } 15 } */ } void foo2 (int d) /* { dg-warning "shadowed declaration" } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wshadow-2.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wshadow-2.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wshadow-2.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wshadow-2.c 2004-03-22 17:58:34.000000000 +0000 *************** *** 0 **** --- 1,8 ---- + /* PR 13129 */ + /* { dg-options "-Wshadow" } */ + + extern struct foo bar; + void dummy() + { + extern struct foo bar; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch.c 2002-02-04 22:05:15.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch.c 2003-03-04 11:06:32.000000000 +0000 *************** foo (int i, int j, enum e ei, enum e ej, *** 19,27 **** case 4: return 3; default: break; } ! switch (ei) ! { /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" } */ ! } /* { dg-warning "enumeration value `e2' not handled in switch" "enum e2" { target *-*-* } 23 } */ switch (ej) { default: break; --- 19,27 ---- case 4: return 3; default: break; } ! switch (ei) /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" } */ ! { /*{ dg-warning "enumeration value `e2' not handled in switch" "enum e2" { target *-*-* } 22 } */ ! } switch (ej) { default: break; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch-default.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch-default.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch-default.c 2002-03-23 16:33:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch-default.c 2003-03-04 11:06:32.000000000 +0000 *************** foo (int i, int j, enum e ei, enum e ej, *** 18,25 **** case 4: return 3; default: break; } ! switch (ei) ! { /* { dg-warning "switch missing default case" } */ } switch (ej) { --- 18,25 ---- case 4: return 3; default: break; } ! switch (ei) /* { dg-warning "switch missing default case" } */ ! { } switch (ej) { diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch-enum.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch-enum.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wswitch-enum.c 2002-03-26 15:36:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wswitch-enum.c 2003-03-04 11:06:32.000000000 +0000 *************** foo (int i, int j, enum e ei, enum e ej, *** 19,27 **** case 4: return 3; default: break; } ! switch (ei) ! { /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" } */ ! } /* { dg-warning "enumeration value `e2' not handled in switch" "enum e2" { target *-*-* } 23 } */ switch (ej) { /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" { target *-*-* } 28 } */ default: break; --- 19,27 ---- case 4: return 3; default: break; } ! switch (ei) /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" } */ ! { /* { dg-warning "enumeration value `e2' not handled in switch" "enum e2" { target *-*-* } 22 } */ ! } switch (ej) { /* { dg-warning "enumeration value `e1' not handled in switch" "enum e1" { target *-*-* } 28 } */ default: break; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-func-def-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-func-def-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-func-def-1.c 2002-07-03 02:41:34.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-func-def-1.c 2003-10-02 00:07:50.000000000 +0000 *************** f_impl3(int f) *** 143,163 **** return 0; } ! /* Test that we don't warn about stdarg functions. */ f_stdarg1(const char *s, ...) ! { return 0; } void f_stdarg2(const char *s, ...) ! { return; } extern void f_stdarg3(const char *, ...); void f_stdarg3(const char *s, ...) ! { return; } --- 143,163 ---- return 0; } ! /* Test stdarg functions. */ f_stdarg1(const char *s, ...) ! { /* { dg-warning "traditional C rejects ISO C style" } */ return 0; } void f_stdarg2(const char *s, ...) ! { /* { dg-warning "traditional C rejects ISO C style" } */ return; } extern void f_stdarg3(const char *, ...); void f_stdarg3(const char *s, ...) ! { /* { dg-warning "traditional C rejects ISO C style" } */ return; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-static-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-static-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-static-1.c 2002-07-03 02:41:34.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-static-1.c 2004-01-11 01:18:58.000000000 +0000 *************** *** 4,10 **** /* { dg-do compile } */ /* { dg-options "-Wtraditional" } */ ! static void testfunc1(void); void testfunc1() {} /* { dg-warning "non-static.*follows static" "non-static follows static" } */ # 11 "sys-header.h" 3 --- 4,10 ---- /* { dg-do compile } */ /* { dg-options "-Wtraditional" } */ ! static void testfunc1(void); /* { dg-warning "previous declaration" } */ void testfunc1() {} /* { dg-warning "non-static.*follows static" "non-static follows static" } */ # 11 "sys-header.h" 3 diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-strcat-1.c gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-strcat-1.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/wtr-strcat-1.c 2002-07-03 02:41:34.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/wtr-strcat-1.c 2003-07-05 00:23:59.000000000 +0000 *************** testfunc () *** 9,15 **** { const char *foo; ! foo = "hello" "hello"; /* { dg-warning "string concatenation" "string concatenation" } */ # 15 "sys-header.h" 3 /* We are in system headers now, no -Wtraditional warnings should issue. */ --- 9,15 ---- { const char *foo; ! foo = "hello" "hello"; /* { dg-warning "concatenation" "string concatenation" } */ # 15 "sys-header.h" 3 /* We are in system headers now, no -Wtraditional warnings should issue. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-3.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-3.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-3.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-3.c 2003-04-04 01:25:40.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR c/10175 */ + /* { dg-do compile } */ + /* { dg-options "-Wunreachable-code" } */ + + int i,j; + int main(void) + { + if (0) { + i = 0; /* { dg-warning "will never be executed" "" } */ + j = 0; + } else { + i = 1; + j = 1; + } + + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-4.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-4.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-4.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-4.c 2003-04-15 16:12:45.000000000 +0000 *************** *** 0 **** --- 1,12 ---- + /* PR middle-end/10336 */ + /* { dg-options "-Wunreachable-code" } */ + + void foo(int i) + { + switch(i) { + case 0: + break; + case 1: + break; + } + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-5.c gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-5.c *** gcc-3.3.3/gcc/testsuite/gcc.dg/Wunreachable-5.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.dg/Wunreachable-5.c 2003-04-17 01:22:50.000000000 +0000 *************** *** 0 **** --- 1,17 ---- + /* PR c/10175 */ + + /* { dg-do compile } */ + /* { dg-options "-Wunreachable-code" } */ + + int value; + + int main(void) + { + if (0) + value = 0; /* { dg-warning "will never be executed" "" } */ + else + value = 1; + + return 0; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/bprob.exp gcc-3.4.0/gcc/testsuite/gcc.misc-tests/bprob.exp *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/bprob.exp 2002-10-21 20:21:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/bprob.exp 2004-02-21 03:00:47.000000000 +0000 *************** *** 17,26 **** # Test the functionality of programs compiled with profile-directed block # ordering using -fprofile-arcs followed by -fbranch-probabilities. # Some targets don't have any implementation of __bb_init_func or are # missing other needed machinery. ! if { [istarget mmix-*-*] ! || [istarget cris-*-*] } { return } --- 17,27 ---- # Test the functionality of programs compiled with profile-directed block # ordering using -fprofile-arcs followed by -fbranch-probabilities. + load_lib target-supports.exp + # Some targets don't have any implementation of __bb_init_func or are # missing other needed machinery. ! if { ![check_profiling_available "-fprofile-arcs"] } { return } *************** if { [istarget mmix-*-*] *** 28,34 **** set tool gcc set profile_option -fprofile-arcs set feedback_option -fbranch-probabilities ! set prof_ext da set perf_ext tim # Override the list defined in profopt.exp. --- 29,35 ---- set tool gcc set profile_option -fprofile-arcs set feedback_option -fbranch-probabilities ! set prof_ext gcda set perf_ext tim # Override the list defined in profopt.exp. diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-10b.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-10b.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-10b.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-10b.c 2003-08-27 21:13:17.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + /* Test gcov block mode. */ + + /* { dg-options "-fprofile-arcs -ftest-coverage" } */ + /* { dg-do run { target native } } */ + + int main () + { + unsigned ix, jx = 0; + + ix = 10; goto test; loop: ; if (ix & 1) jx++; test: ; if (ix--) goto loop; /* count(11) */ + + return jx != 5; + } + + /* { dg-final { run-gcov { -a gcov-10b.c } } } */ + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-10.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-10.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-10.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-10.c 2003-04-06 13:18:41.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Test gcov block mode. */ + + /* { dg-options "-fprofile-arcs -ftest-coverage" } */ + /* { dg-do run { target native } } */ + + int main () + { + unsigned ix, jx = 0; + + for (ix = 10; ix--;) if (ix & 1) jx++; /* count(11) */ + + return jx != 5; + } + + /* { dg-final { run-gcov { -a gcov-10.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-11.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-11.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-11.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-11.c 2003-04-06 13:18:41.000000000 +0000 *************** *** 0 **** --- 1,23 ---- + /* Test gcov block mode. */ + + /* { dg-options "-fprofile-arcs -ftest-coverage" } */ + /* { dg-do run { target native } } */ + + int one = 1; /* subvert constant folder. */ + int zero = 0; + + int foo (int ix) + { + return ix & 1 ? one : zero; /* count(10) */ + } + + int main () + { + unsigned ix, jx = 0; + + for (ix = 10; ix--;) jx += foo (ix); /* count(11) */ + + return jx != 5; + } + + /* { dg-final { run-gcov { -a gcov-11.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-4b.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-4b.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-4b.c 2002-02-06 20:40:18.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-4b.c 2003-03-27 23:53:08.000000000 +0000 *************** main() *** 258,261 **** return 0; } ! /* { dg-final { run-gcov -b gcov-4b.c } } */ --- 258,261 ---- return 0; } ! /* { dg-final { run-gcov branches { -b gcov-4b.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-4b.x gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-4b.x *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-4b.x 2001-09-07 16:41:11.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-4b.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,2 **** - set gcov_verify_branches 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-5b.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-5b.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-5b.c 2001-08-20 17:40:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-5b.c 2003-03-27 23:53:08.000000000 +0000 *************** int main () *** 31,34 **** return 0; } ! /* { dg-final { run-gcov -b gcov-5b.c } } */ --- 31,34 ---- return 0; } ! /* { dg-final { run-gcov branches { -b gcov-5b.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-5b.x gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-5b.x *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-5b.x 2001-09-07 16:41:26.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-5b.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,2 **** - set gcov_verify_branches 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-6.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-6.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-6.c 2001-09-06 23:29:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-6.c 2003-03-27 23:53:08.000000000 +0000 *************** main() *** 34,37 **** /* returns(end) */ } ! /* { dg-final { run-gcov -b gcov-6.c } } */ --- 34,37 ---- /* returns(end) */ } ! /* { dg-final { run-gcov branches calls { -b gcov-6.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-6.x gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-6.x *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-6.x 2001-09-07 16:41:49.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-6.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,3 **** - set gcov_verify_branches 1 - set gcov_verify_calls 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-7.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-7.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-7.c 2001-09-07 16:42:54.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-7.c 2003-03-27 23:53:08.000000000 +0000 *************** main() *** 81,84 **** /* returns(end) */ } ! /* { dg-final { run-gcov -b gcov-7.c } } */ --- 81,84 ---- /* returns(end) */ } ! /* { dg-final { run-gcov calls branches { -b gcov-7.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-7.x gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-7.x *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-7.x 2001-09-07 16:42:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-7.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,3 **** - set gcov_verify_branches 1 - set gcov_verify_calls 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-8.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-8.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-8.c 2002-09-16 13:29:50.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-8.c 2003-03-27 23:53:08.000000000 +0000 *************** int main () *** 44,47 **** return t == 0; } ! /* { dg-final { run-gcov -b gcov-8.c } } */ --- 44,47 ---- return t == 0; } ! /* { dg-final { run-gcov branches {-b gcov-8.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-8.x gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-8.x *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-8.x 2002-08-05 22:16:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-8.x 1970-01-01 00:00:00.000000000 +0000 *************** *** 1,2 **** - set gcov_verify_branches 1 - return 0 --- 0 ---- diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-9.c gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-9.c *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov-9.c 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov-9.c 2003-04-06 13:18:41.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + /* Test gcov block mode. */ + + /* { dg-options "-fprofile-arcs -ftest-coverage" } */ + /* { dg-do run { target native } } */ + + int main () + { + unsigned ix; + + for (ix = 10; ix--;); /* count(11) */ + + return 0; + } + + /* { dg-final { run-gcov { -a gcov-9.c } } } */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov.exp gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov.exp *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/gcov.exp 2001-09-11 16:43:53.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/gcov.exp 2003-07-09 14:57:20.000000000 +0000 *************** if { ![is_remote host] && [string match *** 32,39 **** # Initialize harness. dg-init ! # Delete old .da files. ! set files [glob -nocomplain gcov-*.da]; if { $files != "" } { eval "remote_file build delete $files"; } --- 32,39 ---- # Initialize harness. dg-init ! # Delete old .gcda files. ! set files [glob -nocomplain gcov-*.gcda]; if { $files != "" } { eval "remote_file build delete $files"; } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/gcc.misc-tests/i386-prefetch.exp gcc-3.4.0/gcc/testsuite/gcc.misc-tests/i386-prefetch.exp *** gcc-3.3.3/gcc/testsuite/gcc.misc-tests/i386-prefetch.exp 2002-01-17 22:37:04.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/gcc.misc-tests/i386-prefetch.exp 2003-08-04 23:47:36.000000000 +0000 *************** *** 16,22 **** # Test that the correct data prefetch instructions (SSE or 3DNow! variant, # or none) are used for various i386 cpu-type and instruction set ! # extension options for __builtin_prefetch. # Failure reports do not include the compile option that was used; that # information can be seen in the compile line in the log file. --- 16,24 ---- # Test that the correct data prefetch instructions (SSE or 3DNow! variant, # or none) are used for various i386 cpu-type and instruction set ! # extension options for __builtin_prefetch. When using -mtune, specify ! # the minimum supported architecture in case the compiler was configured ! # with a different default. # Failure reports do not include the compile option that was used; that # information can be seen in the compile line in the log file. *************** *** 24,37 **** # Do not generate prefetch instructions for the following options. set PREFETCH_NONE [list \ ! { -mcpu=i386 } \ ! { -mcpu=i486 } \ ! { -mcpu=i586 } \ ! { -mcpu=i686 } \ ! { -mcpu=pentium2 } \ ! { -mcpu=k6 } \ ! { -mcpu=k6-2 } \ ! { -mcpu=k6-3 } \ { -march=i386 } \ { -march=i486 } \ { -march=i586 } \ --- 26,39 ---- # Do not generate prefetch instructions for the following options. set PREFETCH_NONE [list \ ! { -march=i386 -mtune=i386 } \ ! { -march=i386 -mtune=i486 } \ ! { -march=i386 -mtune=i586 } \ ! { -march=i386 -mtune=i686 } \ ! { -march=i386 -mtune=pentium2 } \ ! { -march=i386 -mtune=k6 } \ ! { -march=i386 -mtune=k6-2 } \ ! { -march=i386 -mtune=k6-3 } \ { -march=i386 } \ { -march=i486 } \ { -march=i586 } \ *************** set PREFETCH_NONE [list \ *** 40,53 **** { -march=k6 } ] # For options in PREFETCH_SSE, generate SSE prefetch instructions for ! # __builtin_prefetch. This includes -mcpu for targets that treat prefetch # instructions as nops. set PREFETCH_SSE [list \ ! { -mcpu=pentium3 } \ ! { -mcpu=pentium4 } \ ! { -mcpu=athlon } \ ! { -mcpu=athlon-4 } \ { -march=pentium3 } \ { -march=pentium4 } ] --- 42,55 ---- { -march=k6 } ] # For options in PREFETCH_SSE, generate SSE prefetch instructions for ! # __builtin_prefetch. This includes -mtune for targets that treat prefetch # instructions as nops. set PREFETCH_SSE [list \ ! { -march=i386 -mtune=pentium3 } \ ! { -march=i386 -mtune=pentium4 } \ ! { -march=i386 -mtune=athlon } \ ! { -march=i386 -mtune=athlon-4 } \ { -march=pentium3 } \ { -march=pentium4 } ] diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield10.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield10.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield10.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield10.C 2003-04-10 19:28:46.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + // { dg-options "-w" } + + struct S { + int i : 64; + }; diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield5.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield5.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield5.C 2002-08-27 22:14:51.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield5.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 1,5 **** // { dg-do compile } ! // { dg-options "-Wabi" } struct A { virtual void f(); --- 1,5 ---- // { dg-do compile } ! // { dg-options "-Wabi -fabi-version=1" } struct A { virtual void f(); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield7.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield7.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield7.C 2002-09-23 09:22:17.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield7.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 1,5 **** // { dg-do compile } ! // { dg-options "-Wabi" } union U { // { dg-warning "ABI" } int i: 4096; // { dg-warning "exceeds" } --- 1,5 ---- // { dg-do compile } ! // { dg-options "-Wabi -fabi-version=1" } union U { // { dg-warning "ABI" } int i: 4096; // { dg-warning "exceeds" } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield9.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield9.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/bitfield9.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/bitfield9.C 2003-01-07 01:33:53.000000000 +0000 *************** *** 0 **** --- 1,11 ---- + // { dg-do run { target i?86-*-* } } + // { dg-options -w } + + struct X { + char : 45; + }; + + int main () { + if (__alignof__ (X) != 4) + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/cookie1.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/cookie1.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/cookie1.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/cookie1.C 2003-03-08 09:12:54.000000000 +0000 *************** *** 0 **** --- 1,15 ---- + // { dg-options "-fabi-version=0" } + + void *operator new[](__SIZE_TYPE__, void *); + + struct A { + ~A(){} + }; + + int main() + { + A * a = (A*) new char[20]; + A * b = new(a) A[3]; + if (a != b) + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/cookie2.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/cookie2.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/cookie2.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/cookie2.C 2003-03-08 09:12:54.000000000 +0000 *************** *** 0 **** --- 1,16 ---- + // { dg-options "-fabi-version=1" } + + void *operator new[](__SIZE_TYPE__, void *); + + struct A { + ~A(){} + }; + + int main() + { + A * a = (A*) new char[20]; + A * b = new(a) A[3]; + // In the 3.2 ABI, a cookie was allocated in this case. + if (a == b) + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant1.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant1.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant1.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant1.C 2003-01-27 23:29:50.000000000 +0000 *************** *** 0 **** --- 1,21 ---- + // { dg-do compile } + // { dg-options "-w" } + + // We don't want to use a covariant thunk to have a virtual + // primary base + + struct c4 {}; + + struct c6 : c4 { virtual c4* f17(); }; + + c4* c6::f17() { return 0; } + + struct c11 : virtual c6 { int i; }; + + struct c12 : c11 { }; + + struct c14 : + virtual c12, + virtual c11 { virtual c12* f17(); }; + + // { dg-final { scan-assembler-not "\n_ZTch0_v0_n16_N3c143f17Ev\[: \t\n\]" } } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant2.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant2.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant2.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant2.C 2003-12-12 14:48:31.000000000 +0000 *************** *** 0 **** --- 1,32 ---- + // { dg-do compile } + + // Copyright (C) 2003 Free Software Foundation, Inc. + // Contributed by Nathan Sidwell 12 Dec 2003 + // Origin: grigory@stl.sarov.ru + + // PR c++/12881. ICE in thunk generation + + struct c1 {}; + + struct c3 : virtual c1 + { + virtual c1* f6() {}; + int i; + }; + + struct c6 : virtual c3 { }; + + struct c7 : c3 + { + virtual c3* f6() {}; + }; + + struct c24 : virtual c7 + { + virtual c6* f6(); + }; + + c6* c24::f6() { return 0; } + + struct c31 : c24 {}; + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant3.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant3.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/covariant3.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/covariant3.C 2003-12-12 18:22:23.000000000 +0000 *************** *** 0 **** --- 1,85 ---- + // { dg-do run } + + // Copyright (C) 2003 Free Software Foundation, Inc. + // Contributed by Nathan Sidwell 12 Dec 2003 + // Origin: grigory@stl.sarov.ru + + // PR c++/13118. Missing covariant thunk. + + struct c0 {}; + struct c1 : virtual c0 { + virtual c0* f6(); + }; + + struct c5 { + virtual void foo(); + }; + + struct c10 : virtual c1 { + virtual void foo(); + }; + + struct c1a : c1 {}; // disambiguation + + struct c11 : virtual c10, c1a { + int i; + virtual c1* f6 () = 0; + }; + + struct c18 : c5, virtual c1 { + virtual void bar(); + }; + + struct c28 : virtual c0, virtual c11 { + virtual c18* f6(); + }; + + c0 *c1::f6 () {} + void c5::foo () {} + void c10::foo () {} + void c18::bar () {} + + c18 ret; + + c18 *c28::f6 () + { + return &ret; + } + + bool check_c1 (c1 *ptr) + { + c0 *r = ptr->f6 (); + return r != &ret; + } + bool check_c10 (c10 *ptr) + { + c0 *r = ptr->f6 (); + return r != &ret; + } + bool check_c11 (c11 *ptr) + { + c1 *r = ptr->f6 (); + return r != &ret; + } + bool check_c28 (c28 *ptr) + { + c18 *r = ptr->f6 (); + return r != &ret; + } + + int main () + { + c28 obj; + + if (check_c1 (static_cast (&obj))) + return 1; + if (check_c1 (static_cast (&obj))) + return 2; + if (check_c10 (&obj)) + return 3; + if (check_c11 (&obj)) + return 4; + if (check_c28 (&obj)) + return 5; + return 0; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/dtor2.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/dtor2.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/dtor2.C 2002-11-07 21:33:44.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/dtor2.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 1,5 **** // { dg-do compile } ! // { dg-options "-Wabi" } struct A { virtual void a (); --- 1,5 ---- // { dg-do compile } ! // { dg-options "-Wabi -fabi-version=1" } struct A { virtual void a (); diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/empty6.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/empty6.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/empty6.C 2002-09-25 19:07:35.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/empty6.C 2003-06-03 19:10:09.000000000 +0000 *************** struct A {}; *** 5,8 **** struct B { A a; // { dg-warning "empty" } virtual void f () {} ! }; --- 5,13 ---- struct B { A a; // { dg-warning "empty" } virtual void f () {} ! } __attribute__((aligned(8))); ! /* The preceding attribute is necessary on targets with ! BIGGEST_ALIGNMENT <= 32 to trigger the warning, as otherwise a 32 bit ! offset is split into DECL_FIELD_OFFSET 4 and DECL_FIELD_BIT_OFFSET 0, ! and then there is no discrepancy between DECL_FIELD_OFFSET and ! byte_position to warn about. */ diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/layout3.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/layout3.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/layout3.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/layout3.C 2003-03-05 20:52:53.000000000 +0000 *************** *** 0 **** --- 1,26 ---- + // { dg-do run { target i?86-*-* } } + // { dg-options "-fabi-version=0 -w" } + + struct S { + virtual void f() {} + }; + + struct T : virtual public S { }; + + struct U : public S, virtual public T { + char c[100]; + }; + + struct V : public U, virtual public S {}; + + struct W : public V { + int i; + }; + + int main () { + W w; + + if ((char*) &w.i - (char *) &w != 104) + return 1; + } + diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/layout4.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/layout4.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/layout4.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/layout4.C 2003-09-03 22:00:42.000000000 +0000 *************** *** 0 **** --- 1,18 ---- + // { dg-do run { target i?86-*-* } } + // { dg-options "-fabi-version=1" } + + struct C4 + { + int b:30; + C4(){}; + }; + + struct C1: virtual C4 + { + int i; + }; + + int main() { + if (sizeof (C1) != 12) + return 1; + } diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro0.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro0.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro0.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro0.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + // { dg-options "-fabi-version=0" } + + #if __GXX_ABI_VERSION != 999999 + #error "Incorrect value of __GXX_ABI_VERSION" + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro1.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro1.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro1.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro1.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + // { dg-options "-fabi-version=1" } + + #if __GXX_ABI_VERSION != 102 + #error "Incorrect value of __GXX_ABI_VERSION" + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro2.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro2.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/macro2.C 1970-01-01 00:00:00.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/macro2.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 0 **** --- 1,5 ---- + // { dg-options "-fabi-version=2" } + + #if __GXX_ABI_VERSION != 1002 + #error "Incorrect value of __GXX_ABI_VERSION" + #endif diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/mangle11.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/mangle11.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/mangle11.C 2002-10-04 04:59:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/mangle11.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 1,4 **** ! // { dg-options "-Wabi" } template void f (typename Q::X) {} --- 1,4 ---- ! // { dg-options "-Wabi -fabi-version=1" } template void f (typename Q::X) {} diff -Nrc3pad gcc-3.3.3/gcc/testsuite/g++.dg/abi/mangle12.C gcc-3.4.0/gcc/testsuite/g++.dg/abi/mangle12.C *** gcc-3.3.3/gcc/testsuite/g++.dg/abi/mangle12.C 2002-10-04 04:59:37.000000000 +0000 --- gcc-3.4.0/gcc/testsuite/g++.dg/abi/mangle12.C 2003-12-23 16:53:52.000000000 +0000 *************** *** 1,4 **** ! // { dg-options "-Wabi" } template